mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-11 20:49:05 +03:00
195 lines
6.3 KiB
Haskell
195 lines
6.3 KiB
Haskell
import Test.HUnit
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Constraints
|
|
import Types
|
|
import Obj
|
|
import Parsing
|
|
import Infer
|
|
import Eval
|
|
|
|
main :: IO ()
|
|
main = do _ <- runTestTT (groupTests "Constraints" testConstraints)
|
|
_ <- runTestTT (groupTests "Memory Management" testMemoryManagement)
|
|
return ()
|
|
|
|
groupTests :: String -> [Test] -> Test
|
|
groupTests label testCases =
|
|
TestList (zipWith TestLabel (map ((\s -> label ++ " Test " ++ s) . show) [1..]) testCases)
|
|
|
|
-- | Helper functions for testing unification of Constraints
|
|
isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool
|
|
isUnificationFailure (Left _) = True
|
|
isUnificationFailure (Right _) = False
|
|
|
|
assertUnificationFailure :: [Constraint] -> Test
|
|
assertUnificationFailure constraints = TestCase $
|
|
assertBool "Failure" (isUnificationFailure (solve constraints))
|
|
|
|
assertSolution :: [Constraint] -> [(String, Ty)] -> Test
|
|
assertSolution constraints solution = TestCase $
|
|
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints)
|
|
|
|
-- | A dummy XObj
|
|
x = XObj External Nothing Nothing
|
|
|
|
-- | Some type variables
|
|
t0 = VarTy "t0"
|
|
t1 = VarTy "t1"
|
|
t2 = VarTy "t2"
|
|
t3 = VarTy "t3"
|
|
|
|
-- | Test constraints
|
|
testConstraints = [testConstr1, testConstr2, testConstr3, testConstr4, testConstr5
|
|
,testConstr6, testConstr7, testConstr8, testConstr9, testConstr10
|
|
,testConstr11, testConstr12, testConstr13
|
|
,testConstr20, testConstr21, testConstr22, testConstr23, testConstr24
|
|
,testConstr30, testConstr31, testConstr32, testConstr33
|
|
]
|
|
|
|
testConstr1 = assertUnificationFailure
|
|
[Constraint FloatTy IntTy x x]
|
|
|
|
testConstr2 = assertSolution
|
|
[Constraint IntTy t0 x x]
|
|
[("t0", IntTy)]
|
|
|
|
testConstr3 = assertSolution
|
|
[Constraint t0 IntTy x x]
|
|
[("t0", IntTy)]
|
|
|
|
testConstr4 = assertSolution
|
|
[Constraint t0 t1 x x, Constraint t0 IntTy x x]
|
|
[("t0", IntTy), ("t1", IntTy)]
|
|
|
|
testConstr5 = assertSolution
|
|
[Constraint t0 t1 x x, Constraint t1 IntTy x x]
|
|
[("t0", IntTy), ("t1", IntTy)]
|
|
|
|
testConstr6 = assertSolution
|
|
[Constraint t0 t1 x x, Constraint t1 t3 x x, Constraint t2 IntTy x x, Constraint t3 IntTy x x]
|
|
[("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)]
|
|
|
|
testConstr7 = assertUnificationFailure
|
|
[Constraint t0 IntTy x x, Constraint t0 FloatTy x x]
|
|
|
|
testConstr8 = assertSolution
|
|
[Constraint t0 IntTy x x, Constraint t0 t0 x x]
|
|
[("t0", IntTy)]
|
|
|
|
testConstr9 = assertSolution
|
|
[Constraint t0 IntTy x x, Constraint t0 t1 x x]
|
|
[("t0", IntTy), ("t1", IntTy)]
|
|
|
|
testConstr10 = assertSolution
|
|
[Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x]
|
|
[("a", (VarTy "a")), ("b", (VarTy "a"))]
|
|
|
|
testConstr11 = assertSolution
|
|
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy "Monkey" [])) x x]
|
|
[("a", (StructTy "Monkey" []))]
|
|
|
|
testConstr12 = assertSolution
|
|
[Constraint t1 (PointerTy (StructTy "Array" [IntTy])) x x
|
|
,Constraint t1 (PointerTy t2) x x]
|
|
[("t1", (PointerTy (StructTy "Array" [IntTy])))
|
|
,("t2", (StructTy "Array" [IntTy]))]
|
|
|
|
testConstr13 = assertSolution
|
|
[Constraint t1 CharTy x x
|
|
,Constraint t1 CharTy x x]
|
|
[("t1", CharTy)]
|
|
|
|
-- -- Should collapse type variables into minimal set:
|
|
-- testConstr10 = assertSolution
|
|
-- [Constraint t0 t1 x x, Constraint t1 t2 x x, Constraint t2 t3 x x]
|
|
-- [("t0", VarTy "t0"), ("t1", VarTy "t0"), ("t2", VarTy "t0")]
|
|
-- m7 = solve ([Constraint t1 t2 x x, Constraint t0 t1 x x])
|
|
|
|
-- Struct types
|
|
testConstr20 = assertSolution
|
|
[Constraint t0 (StructTy "Vector" [t1]) x x
|
|
,Constraint t0 (StructTy "Vector" [IntTy]) x x]
|
|
[("t0", (StructTy "Vector" [IntTy])), ("t1", IntTy)]
|
|
|
|
testConstr21 = assertSolution
|
|
[Constraint t1 (StructTy "Array" [t2]) x x
|
|
,Constraint t1 (StructTy "Array" [t3]) x x
|
|
,Constraint t3 BoolTy x x]
|
|
[("t1", (StructTy "Array" [BoolTy]))
|
|
,("t2", BoolTy)
|
|
,("t3", BoolTy)]
|
|
|
|
testConstr22 = assertSolution
|
|
[Constraint t1 (StructTy "Array" [t2]) x x
|
|
,Constraint t2 (StructTy "Array" [t3]) x x
|
|
,Constraint t3 FloatTy x x]
|
|
[("t1", (StructTy "Array" [(StructTy "Array" [FloatTy])]))
|
|
,("t2", (StructTy "Array" [FloatTy]))
|
|
,("t3", FloatTy)]
|
|
|
|
testConstr23 = assertUnificationFailure
|
|
[Constraint (StructTy "Array" [t1]) (StructTy "Array" [t2]) x x
|
|
,Constraint t1 IntTy x x
|
|
,Constraint t2 FloatTy x x]
|
|
|
|
testConstr24 = assertUnificationFailure
|
|
[Constraint t2 FloatTy x x
|
|
,Constraint t1 IntTy x x
|
|
,Constraint (StructTy "Array" [t1]) (StructTy "Array" [t2]) x x]
|
|
|
|
-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x]
|
|
-- m10 = solve [Constraint (StructTy "Vector" [t1]) (StructTy "Vector" [t2]) x x]
|
|
|
|
-- Func types
|
|
testConstr30 = assertSolution
|
|
[Constraint t2 (FuncTy [t0] t1) x x
|
|
,Constraint t2 (FuncTy [IntTy] BoolTy) x x]
|
|
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy))]
|
|
|
|
testConstr31 = assertSolution
|
|
[Constraint (FuncTy [t0] t1) (FuncTy [IntTy] BoolTy) x x]
|
|
[("t0", IntTy), ("t1", BoolTy)]
|
|
|
|
testConstr32 = assertSolution
|
|
[Constraint t0 (FuncTy [IntTy] BoolTy) x x]
|
|
[("t0", (FuncTy [IntTy] BoolTy))]
|
|
|
|
testConstr33 = assertSolution
|
|
[Constraint t1 (FuncTy [t2] IntTy) x x
|
|
,Constraint t1 (FuncTy [t3] IntTy) x x
|
|
,Constraint t3 BoolTy x x]
|
|
[("t1", (FuncTy [BoolTy] IntTy))
|
|
,("t2", BoolTy)
|
|
,("t3", BoolTy)]
|
|
|
|
|
|
|
|
-- | Test memory management
|
|
|
|
testMemoryManagement = [testMem1]
|
|
|
|
testEnv :: Env
|
|
testEnv = Env { envBindings = bs, envParent = Nothing, envModuleName = Nothing, envImports = [], envMode = ExternalEnv }
|
|
where bs = Map.fromList []
|
|
|
|
assertMem :: String -> [Deleter] -> Test
|
|
assertMem code deleters =
|
|
let Right [parsed] = parse code
|
|
Right expanded = expandAll testEnv parsed
|
|
xobjFullSymbols = setFullyQualifiedSymbols testEnv expanded
|
|
Right (ann : _) = annotate testEnv xobjFullSymbols
|
|
Just i = info ann
|
|
in TestCase $ assertEqual "Memory" (infoDelete i) (Set.fromList deleters)
|
|
|
|
testMem1 = assertMem "(defn f [] (let [s \"HELLO\"] 12345))" []
|
|
|
|
|
|
-- case expandAll env xobj of
|
|
-- Left err -> executeCommand ctx (ReplMacroError (show err))
|
|
-- Right expanded ->
|
|
-- let xobjFullPath = setFullyQualifiedDefn expanded (SymPath pathStrings (getName xobj))
|
|
-- xobjFullSymbols = setFullyQualifiedSymbols innerEnv xobjFullPath
|
|
-- in case annotate env xobjFullSymbols of
|
|
|