Classify.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-- | Verify we infer the right classifier
module Test.RecoverRTTI.Classify (tests) where

import Control.Monad.Except
import Data.Ratio
import Data.SOP
import Data.Type.Equality

import qualified Data.Aeson                  as Aeson
import qualified Data.HashMap.Internal.Array as HashMap.Array
import qualified Data.HashMap.Lazy           as HashMap
import qualified Data.HashSet                as HashSet
import qualified Data.IntMap                 as IntMap
import qualified Data.IntSet                 as IntSet
import qualified Data.Map                    as Map
import qualified Data.Sequence               as Seq
import qualified Data.Set                    as Set
import qualified Data.Tree                   as Tree
import qualified Data.Vector                 as Vector.Boxed

import Test.Tasty
import Test.Tasty.QuickCheck hiding (classify, NonEmpty)

import Debug.RecoverRTTI

import Test.RecoverRTTI.Arbitrary
import Test.RecoverRTTI.ConcreteClassifier
import Test.RecoverRTTI.Orphans ()
import Test.RecoverRTTI.Staged
import Test.RecoverRTTI.UserDefined

tests :: TestTree
tests = testGroup "Test.RecoverRTTI.Classify" [
      testProperty "constants" prop_constants
    , testProperty "arbitrary" prop_arbitrary
    ]

-- | Test using manually specified examples
--
-- For " normal " code it doesn't matter if something is generated or not,
-- but their on-heap representation may be different, and this may effect the
-- RTTI recovery.
prop_constants :: Property
prop_constants = withMaxSuccess 1 $ conjoin [
      -- Primitive types

      compareClassifier $ Value CC_Bool     True
    , compareClassifier $ Value CC_Bool     False
    , compareClassifier $ Value CC_Char     'a'
    , compareClassifier $ Value CC_Double   1.25
    , compareClassifier $ Value CC_Float    1.25
    , compareClassifier $ Value CC_Int      1234
    , compareClassifier $ Value CC_Int      (-1234)
    , compareClassifier $ Value CC_Int8     123
    , compareClassifier $ Value CC_Int16    1234
    , compareClassifier $ Value CC_Int32    1234
    , compareClassifier $ Value CC_Int64    1234
    , compareClassifier $ Value CC_Integer  1234
    , compareClassifier $ Value CC_Integer  (succ (fromIntegral (maxBound :: Int)))
    , compareClassifier $ Value CC_Integer  (pred (fromIntegral (minBound :: Int)))
    , compareClassifier $ Value CC_Ordering LT
    , compareClassifier $ Value CC_Ordering GT
    , compareClassifier $ Value CC_Ordering EQ
    , compareClassifier $ Value CC_Unit     ()
    , compareClassifier $ Value CC_Word     1234
    , compareClassifier $ Value CC_Word8    123
    , compareClassifier $ Value CC_Word16   134
    , compareClassifier $ Value CC_Word32   1234
    , compareClassifier $ Value CC_Word64   1234

      -- String types
      --
      -- We skip the empty string, because we infer that as @CC_List Empty@

    , compareClassifier $ Value CC_String      "abcdefg"
    , compareClassifier $ Value CC_BS_Strict   ""
    , compareClassifier $ Value CC_BS_Strict   "abcdefg"
    , compareClassifier $ Value CC_BS_Lazy     ""
    , compareClassifier $ Value CC_BS_Lazy     "abcdefg"
    , compareClassifier $ Value CC_BS_Short    ""
    , compareClassifier $ Value CC_BS_Short    "abcdefg"
    , compareClassifier $ Value CC_Text_Strict ""
    , compareClassifier $ Value CC_Text_Strict "abcdefg"
    , compareClassifier $ Value CC_Text_Lazy   ""
    , compareClassifier $ Value CC_Text_Lazy   "abcdefg"

      -- Aeson

    , compareClassifier $ Value CC_Value (Aeson.object [("x" Aeson..= True)])

      -- Compound

    , compareClassifier $ Value (CC_Maybe FNothing)       Nothing
    , compareClassifier $ Value (CC_Maybe (FJust CC_Int)) (Just 3)

    , compareClassifier $ Value (CC_Either (FLeft  CC_Int))  (Left 3)
    , compareClassifier $ Value (CC_Either (FRight CC_Bool)) (Right True)

    , compareClassifier $ Value (CC_List FNothing)       []
    , compareClassifier $ Value (CC_List (FJust CC_Int)) [1, 2, 3]

    , compareClassifier $ Value (CC_Tuple (ConcreteClassifiers (CC_Int :* CC_Char :* Nil)))            (WrappedTuple (4, 'a'))
    , compareClassifier $ Value (CC_Tuple (ConcreteClassifiers (CC_Int :* CC_Char :* CC_Bool :* Nil))) (WrappedTuple (4, 'a', True))

    , compareClassifier $ Value (CC_Ratio CC_Integer) (1 % 2)

    , compareClassifier $ Value (CC_Set FNothing)        Set.empty
    , compareClassifier $ Value (CC_Set (FJust CC_Int)) (Set.fromList [1, 2, 3] )

    , compareClassifier $ Value (CC_Map FNothingPair)                Map.empty
    , compareClassifier $ Value (CC_Map (FJustPair CC_Int CC_Char)) (Map.fromList [(1, 'a'), (2, 'b')])

    , compareClassifier $ Value CC_IntSet  IntSet.empty
    , compareClassifier $ Value CC_IntSet (IntSet.fromList [1, 2, 3])

    , compareClassifier $ Value (CC_IntMap FNothing)         IntMap.empty
    , compareClassifier $ Value (CC_IntMap (FJust CC_Char)) (IntMap.fromList [(1, 'a'), (2, 'b')])

    , compareClassifier $ Value (CC_Sequence FNothing)        Seq.empty
    , compareClassifier $ Value (CC_Sequence (FJust CC_Int)) (Seq.fromList [1, 2, 3])

    , compareClassifier $ Value (CC_Tree CC_Int) (Tree.Node 1 [])

    , compareClassifier $ Value (CC_HashSet CC_Int) (HashSet.fromList [1, 2, 3])

    , compareClassifier $ Value (CC_HashMap FNothingPair)                HashMap.empty
    , compareClassifier $ Value (CC_HashMap (FJustPair CC_Int CC_Char)) (HashMap.fromList [(1, 'a'), (2, 'b')])

    , compareClassifier $ Value (CC_HM_Array FNothing)       (HashMap.Array.fromList 0 [])
    , compareClassifier $ Value (CC_HM_Array (FJust CC_Int)) (HashMap.Array.fromList 2 [1, 2])

    , compareClassifier $ Value (CC_Vector_Boxed FNothing)        Vector.Boxed.empty
    , compareClassifier $ Value (CC_Vector_Boxed (FJust CC_Int)) (Vector.Boxed.fromList [1, 2, 3])

      -- Reference cells

    , compareClassifier $ Value CC_STRef exampleIORef
    , compareClassifier $ Value CC_STRef exampleSTRef
    , compareClassifier $ Value CC_MVar  exampleMVar
    , compareClassifier $ Value CC_TVar  exampleTVar

      -- Functions

    , compareClassifier $ Value CC_Fun (SomeFun id)

      -- User defined

    , compareClassifier $ Value  CC_User_Simple                    SimpleA
    , compareClassifier $ Value  CC_User_Simple                    SimpleB
    , compareClassifier $ Value (CC_User_NonRec    FNothing)       (NR1 1234)
    , compareClassifier $ Value (CC_User_NonRec   (FJust CC_Char)) (NR2 'a' True)
    , compareClassifier $ Value (CC_User_Rec       FNothing)        RNil
    , compareClassifier $ Value (CC_User_Rec      (FJust CC_Char)) (RCons 'a' RNil)
    , compareClassifier $ Value  CC_User_Unlifted                  exampleContainsUnlifted
    ]
  where
    _checkAllCases :: ConcreteClassifier a -> ()
    _checkAllCases = \case
        -- Primitive types

        CC_Bool     -> ()
        CC_Char     -> ()
        CC_Double   -> ()
        CC_Float    -> ()
        CC_Int      -> ()
        CC_Int8     -> ()
        CC_Int16    -> ()
        CC_Int32    -> ()
        CC_Int64    -> ()
        CC_Integer  -> ()
        CC_Ordering -> ()
        CC_Unit     -> ()
        CC_Word     -> ()
        CC_Word8    -> ()
        CC_Word16   -> ()
        CC_Word32   -> ()
        CC_Word64   -> ()

        -- String types

        CC_String      -> ()
        CC_BS_Strict   -> ()
        CC_BS_Lazy     -> ()
        CC_BS_Short    -> ()
        CC_Text_Strict -> ()
        CC_Text_Lazy   -> ()

        -- Aeson

        CC_Value -> ()

        -- Compound

        CC_Maybe{}        -> ()
        CC_Either{}       -> ()
        CC_List{}         -> ()
        CC_Ratio{}        -> ()
        CC_Set{}          -> ()
        CC_Map{}          -> ()
        CC_IntSet{}       -> ()
        CC_IntMap{}       -> ()
        CC_Sequence{}     -> ()
        CC_Tree{}         -> ()
        CC_Tuple{}        -> ()
        CC_HashSet{}      -> ()
        CC_HashMap{}      -> ()
        CC_HM_Array{}     -> ()
        CC_Vector_Boxed{} -> ()

        -- Functions

        CC_Fun{} -> ()

        -- Reference cells

        CC_STRef -> ()
        CC_TVar  -> ()
        CC_MVar  -> ()

        -- User-defined

        CC_User_Simple{}   -> ()
        CC_User_NonRec{}   -> ()
        CC_User_Rec{}      -> ()
        CC_User_Unlifted{} -> ()

-- | Test using arbitrary values
prop_arbitrary :: Some Value -> Property
prop_arbitrary (Some v) = compareClassifier v

-- | Compare given to inferred classifier
--
-- The tests in this module differ only in how the produce the 'Value's.
compareClassifier :: Value a -> Property
compareClassifier = \(Value cc x) ->
      counterexample ("Generated classifier: " ++ show cc)
    $ case runExcept $ classifyThenReclassify x of
        Left err  ->
            counterexample ("Failed to reclassify. Error: " ++ err)
          $ property False
        Right (Reclassified cc' f) ->
          case sameConcreteClassifier cc cc' of
            Nothing ->
                counterexample ("Inferred different classifier: " ++ show cc')
              $ property False
            Just Refl ->
              x === f x