File size: 8,328 Bytes
a10b189 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | {-# LANGUAGE OverloadedStrings #-}
module Test.Backend.TypeCompiler
( tests
) where
import Test.Tasty
import Test.Tasty.HUnit
import qualified Data.Text as T
import qualified Data.Set as Set
import Assertica.Core.AST
import Assertica.Backend.CodeGen (defaultConfig)
import Assertica.Backend.TypeCompiler
-- ============================================================================
-- TEST SUITE
-- ============================================================================
tests :: TestTree
tests = testGroup "Assertica.Backend.TypeCompiler"
[ testGroup "Type Variables"
[ testCase "Compile type variable" testTypeVariable
]
, testGroup "Type Constants"
[ testCase "Unqualified type constructor" testUnqualifiedType
, testCase "Qualified type constructor" testQualifiedType
, testCase "Type constructor with arguments" testTypeWithArgs
]
, testGroup "Function Types"
[ testCase "Simple function type" testSimpleFunctionType
, testCase "Nested function type" testNestedFunctionType
, testCase "Function type with multiple args" testMultiArgFunctionType
]
, testGroup "Universe Types"
[ testCase "Type0 universe" testType0Universe
, testCase "TypeN universe" testTypeNUniverse
]
, testGroup "Dependent Types"
[ testCase "Forall type" testForallType
]
, testGroup "Type Application"
[ testCase "Type application" testTypeApplication
]
, testGroup "Equality Types"
[ testCase "Equality type compilation" testEqualityType
]
, testGroup "Determinism"
[ testCase "Type compilation is deterministic" testTypeDeterminism
]
]
-- ============================================================================
-- UNIT TESTS: TYPE VARIABLES
-- ============================================================================
testTypeVariable :: Assertion
testTypeVariable = do
let tv = TyVar (Var "a" 0)
result <- case compileType defaultConfig tv of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertEqual "Should be a" "a" result
-- ============================================================================
-- UNIT TESTS: TYPE CONSTANTS
-- ============================================================================
testUnqualifiedType :: Assertion
testUnqualifiedType = do
let ty = TyConst (QName [] "Int") []
result <- case compileType defaultConfig ty of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertEqual "Should be Int" "Int" result
testQualifiedType :: Assertion
testQualifiedType = do
let ty = TyConst (QName ["Data", "List"] "List") []
result <- case compileType defaultConfig ty of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertBool "Should contain List" ("List" `T.isInfixOf` result)
assertBool "Should contain qualified name" ("Data" `T.isInfixOf` result)
testTypeWithArgs :: Assertion
testTypeWithArgs = do
let elemType = TyConst (QName [] "Int") []
let listType = TyConst (QName [] "List") [elemType]
result <- case compileType defaultConfig listType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertBool "Should contain List" ("List" `T.isInfixOf` result)
assertBool "Should contain Int" ("Int" `T.isInfixOf` result)
-- ============================================================================
-- UNIT TESTS: FUNCTION TYPES
-- ============================================================================
testSimpleFunctionType :: Assertion
testSimpleFunctionType = do
let intType = TyConst (QName [] "Int") []
let boolType = TyConst (QName [] "Bool") []
let funType = TyFun intType boolType
result <- case compileType defaultConfig funType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertBool "Should contain arrow" ("->" `T.isInfixOf` result)
testNestedFunctionType :: Assertion
testNestedFunctionType = do
let intType = TyConst (QName [] "Int") []
let boolType = TyConst (QName [] "Bool") []
let charType = TyConst (QName [] "Char") []
-- Int -> (Bool -> Char)
let inner = TyFun boolType charType
let outer = TyFun intType inner
result <- case compileType defaultConfig outer of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
let hasArrows = (T.count "->" result) >= 2
assertBool "Should contain multiple arrows" hasArrows
testMultiArgFunctionType :: Assertion
testMultiArgFunctionType = do
let intType = TyConst (QName [] "Int") []
let stringType = TyConst (QName [] "String") []
let boolType = TyConst (QName [] "Bool") []
-- Int -> String -> Bool
let t1 = TyFun intType stringType
let t2 = TyFun t1 boolType
result <- case compileType defaultConfig t2 of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertBool "Should contain Int" ("Int" `T.isInfixOf` result)
assertBool "Should contain String" ("String" `T.isInfixOf` result)
assertBool "Should contain Bool" ("Bool" `T.isInfixOf` result)
-- ============================================================================
-- UNIT TESTS: UNIVERSE TYPES
-- ============================================================================
testType0Universe :: Assertion
testType0Universe = do
let univType = TyUniverse Type0
result <- case compileType defaultConfig univType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertEqual "Should be Type" "Type" result
testTypeNUniverse :: Assertion
testTypeNUniverse = do
let univType = TyUniverse (TypeN 5)
result <- case compileType defaultConfig univType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
-- Higher universes map to Type
assertEqual "Should be Type" "Type" result
-- ============================================================================
-- UNIT TESTS: DEPENDENT TYPES
-- ============================================================================
testForallType :: Assertion
testForallType = do
let varType = TyVar (Var "a" 0)
let bodyType = TyVar (Var "a" 0) -- forall a . a (identity)
let forallType = TyForall (Binder (Var "a" 0) Nothing) bodyType
result <- case compileType defaultConfig forallType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertBool "Should contain forall" ("forall" `T.isInfixOf` result)
-- ============================================================================
-- UNIT TESTS: TYPE APPLICATION
-- ============================================================================
testTypeApplication :: Assertion
testTypeApplication = do
let listConstr = TyConst (QName [] "List") []
let intType = TyConst (QName [] "Int") []
let appType = TyApp listConstr intType
result <- case compileType defaultConfig appType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
assertBool "Should contain List" ("List" `T.isInfixOf` result)
assertBool "Should contain Int" ("Int" `T.isInfixOf` result)
-- ============================================================================
-- UNIT TESTS: EQUALITY TYPES
-- ============================================================================
testEqualityType :: Assertion
testEqualityType = do
let x = Var (Var "x" 0)
let y = Var (Var "y" 0)
let eqType = TyEq (Var x) (Var y)
result <- case compileType defaultConfig eqType of
Right x -> return x
Left err -> assertFailure $ "Unexpected error: " ++ err
-- Equality type should compile to something
assertBool "Should produce valid output" (not (T.null result))
-- ============================================================================
-- PROPERTY TESTS: DETERMINISM
-- ============================================================================
testTypeDeterminism :: Assertion
testTypeDeterminism = do
let intType = TyConst (QName [] "Int") []
let boolType = TyConst (QName [] "Bool") []
let funType = TyFun intType boolType
let result1 = compileType defaultConfig funType
let result2 = compileType defaultConfig funType
assertEqual "Type compilation should be deterministic" result1 result2
|