LifterSpec.hs

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

import           Control.Monad.State.Strict                        (runState)
import qualified Data.Map.Strict                                   as Map
import           Data.Word                                         (Word32)
import qualified Language.Cimple                                   as C
import           Language.Cimple.Analysis.Refined.Inference.Lifter
import           Language.Cimple.Analysis.Refined.Inference.Types
import           Language.Cimple.Analysis.Refined.LatticeOp
import           Language.Cimple.Analysis.Refined.Registry
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.Lifter" $ do
    let emptyTS = Map.empty :: TS.TypeSystem
    let st0 = emptyTranslatorState emptyTS

    describe "liftImplicitPolymorphism" $ do
        it "identifies implicit parameters in structs" $ do
            -- struct Box { void *data; };
            -- void* data translates to a node containing a TIdParam PLocal ...
            -- Lifter should find this and promote it.
            let tidT = TIdParam PLocal 10 (Just "T")
            let varNode = AnyRigidNodeF (RObject (VVar tidT Nothing) (Quals False))
            let member = Member (dummyL "data") 100
            let boxDef = StructDef (dummyL "Box") [] [member]
            let reg = Registry (Map.singleton "Box" boxDef)

            let st = st0 { tsNodes = Map.insert 100 varNode (tsNodes st0) }
            let (reg', st') = runState (liftImplicitPolymorphism reg) st

            let mDef = Map.lookup "Box" (regDefinitions reg')
            case mDef of
                Just (StructDef _ params _) -> params `shouldContain` [(tidT, Invariant)]
                _ -> expectationFailure "Expected Box to be a StructDef"

            -- Should also register an existential form
            Map.member "Box" (tsExistentials st') `shouldBe` True

        it "handles nested implicit polymorphism" $ do
            -- struct Inner { void *p; };
            -- struct Outer { struct Inner inner; };
            let tidT = TIdParam PLocal 10 (Just "T")
            let varNode = AnyRigidNodeF (RObject (VVar tidT Nothing) (Quals False))
            let innerId = 100 :: Word32

            let memberP = Member (dummyL "p") innerId
            let innerDef = StructDef (dummyL "Inner") [] [memberP]

            let innerNominal = AnyRigidNodeF (RObject (VNominal (dummyL (TIdName "Inner")) [innerId]) (Quals False))

            let memberI = Member (dummyL "inner") (102 :: Word32)
            let outerDef = StructDef (dummyL "Outer") [] [memberI]

            let reg = Registry (Map.fromList [("Inner", innerDef), ("Outer", outerDef)])
            let st = st0 { tsNodes = Map.fromList
                [ (innerId, varNode)
                , (102, innerNominal)
                ] }

            let (reg', _) = runState (liftImplicitPolymorphism reg) st

            case Map.lookup "Outer" (regDefinitions reg') of
                Just (StructDef _ params _) -> params `shouldContain` [(tidT, Invariant)]
                _ -> expectationFailure "Expected Outer to be a StructDef with lifted parameter T"

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