TranslatorSpec.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Cimple.Analysis.Refined.Inference.TranslatorSpec (spec) where

import           Control.Monad.State.Strict                            (runState)
import           Data.Fix                                              (Fix (..))
import qualified Data.Map.Strict                                       as Map
import qualified Data.Set                                              as Set
import           Data.Word                                             (Word32)
import qualified Language.Cimple                                       as C
import           Language.Cimple.Analysis.Refined.Inference.Translator
import           Language.Cimple.Analysis.Refined.Inference.Types
import           Language.Cimple.Analysis.Refined.Types
import qualified Language.Cimple.Analysis.TypeSystem                   as TS
import           Test.Hspec

spec :: Spec
spec = describe "Language.Cimple.Analysis.Refined.Inference.Translator" $ do
    let emptyTS = Map.empty :: TS.TypeSystem
    let st0 = emptyTranslatorState emptyTS

    describe "translateStdType" $ do
        it "maps BoolTy correctly" $ do
            translateStdType TS.BoolTy `shouldBe` Just BoolTy
        it "maps VoidTy to Nothing" $ do
            translateStdType TS.VoidTy `shouldBe` Nothing

    describe "translateType" $ do
        it "translates int32_t to VBuiltin S32Ty" $ do
            let ty = TS.builtin (dummyL "int32_t")
            let (nid, st) = runState (translateType ty) st0
            Map.lookup nid (tsNodes st) `shouldBe` Just (AnyRigidNodeF (RObject (VBuiltin S32Ty) (Quals False)))

        it "translates pointer types" $ do
            let ty = TS.Pointer (TS.builtin (dummyL "int32_t"))
            let (nid, st) = runState (translateType ty) st0
            case Map.lookup nid (tsNodes st) of
                Just (AnyRigidNodeF (RReference (Ptr (TargetObject innerId)) _ _ _)) ->
                    Map.lookup (innerId :: Word32) (tsNodes st) `shouldBe` Just (AnyRigidNodeF (RObject (VBuiltin S32Ty) (Quals False)))
                _ -> expectationFailure "Expected nid to be a pointer to int32_t"

        it "handles void* by creating a fresh template parameter" $ do
            let ty = TS.Pointer (TS.builtin (dummyL "void"))
            let (nid1, st1) = runState (translateType ty) st0
            let (nid2, _) = runState (translateType ty) st1
            nid1 `shouldNotBe` nid2

        it "preserves const qualifiers" $ do
            let ty = TS.Const (TS.builtin (dummyL "int32_t"))
            let (nid, st) = runState (translateType ty) st0
            Map.lookup nid (tsNodes st) `shouldBe` Just (AnyRigidNodeF (RObject (VBuiltin S32Ty) (Quals True)))

        it "handles nested pointers (Recursive Translation)" $ do
            let ty = TS.Pointer (TS.Pointer (TS.builtin (dummyL "int32_t")))
            let (nid, st) = runState (translateType ty) st0
            case Map.lookup nid (tsNodes st) of
                Just (AnyRigidNodeF (RReference (Ptr (TargetObject p1)) _ _ _)) ->
                    case Map.lookup p1 (tsNodes st) of
                        Just (AnyRigidNodeF (RReference (Ptr (TargetObject p2)) _ _ _)) ->
                            Map.lookup p2 (tsNodes st) `shouldBe` Just (AnyRigidNodeF (RObject (VBuiltin S32Ty) (Quals False)))
                        _ -> expectationFailure "Expected p1 to be a pointer"
                _ -> expectationFailure "Expected nid to be a pointer"

        it "returns an existential type for a nominal type if registered" $ do
            let baseName = "My_Callback"
            let ty = TS.TypeRef TS.StructRef (dummyL (TS.TIdName baseName)) []
            let existId = 100
            let st = st0 { tsExistentials = Map.singleton baseName existId }
            let (nid, _) = runState (translateType ty) st
            nid `shouldBe` existId

        it "returns an existential type for a nominal type with generic parameters" $ do
            let baseName = "My_Callback"
            let param = TS.Template (TS.TIdParam 0 Nothing) Nothing
            let ty = TS.TypeRef TS.StructRef (dummyL (TS.TIdName baseName)) [param]
            let existId = 100
            let st = st0 { tsExistentials = Map.singleton baseName existId }
            let (nid, _) = runState (translateType ty) st
            nid `shouldBe` existId

    describe "translateTemplateIdGlobal" $ do
        it "maps TIdName" $ do
            translateTemplateIdGlobal (TS.TIdName "foo") `shouldBe` TIdName "foo"
        it "maps TIdParam" $ do
            translateTemplateIdGlobal (TS.TIdParam 5 (Just "T")) `shouldBe` TIdParam PGlobal 5 (Just "T")

dummyL :: t -> C.Lexeme t
dummyL = C.L (C.AlexPn 0 0 0) C.IdSueType