unit tests, started on pattern matching

tests/Tests.hs

@@ -1,56 +1,94 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use <$>" #-}
+{-# HLINT ignore "Use camelCase" #-}
 
 module Main where
 
-import           Control.Monad.Except
+import           Data.Either               (isLeft, isRight)
+import           Data.Map                  (Map)
+import qualified Data.Map                  as M
 import           Grammar.Abs
+import           Test.Hspec
 import           Test.QuickCheck
 import           TypeChecker.TypeChecker
 import qualified TypeChecker.TypeCheckerIr as T
+import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
+                                            Poly (..))
 
 main :: IO ()
-main = do
-    quickCheck prop_isInt
-    quickCheck prop_idAbs_generic
+main = hspec $ do
+    infer_elit
+    infer_eann
+    infer_eid
+    infer_eabs
+    infer_eapp
 
-newtype AbsExp = AE Exp deriving Show
-newtype EIntExp = EI Exp deriving Show
+infer_elit = describe "algoW used on ELit" $ do
+    it "infers the type mono Int" $ do
+        getType (ELit (LInt 0)) `shouldBe` Right (TMono "Int")
 
-instance Arbitrary EIntExp where
-  arbitrary = genInt
+    it "infers the type mono Int" $ do
+        getType (ELit (LInt 9999)) `shouldBe` Right (TMono "Int")
 
-instance Arbitrary AbsExp where
-  arbitrary = genLambda
+infer_eann = describe "algoW used on EAnn" $ do
+    it "infers the type and checks if the annotated type matches" $ do
+        getType (EAnn (ELit $ LInt 0) (TMono "Int")) `shouldBe` Right (TMono "Int")
 
-getType :: Infer (Type, T.Exp) -> Either Error Type
-getType ie = case run ie of
-    Left err    -> Left err
-    Right (t,e) -> return t
+    it "fails if the annotated type does not match with the inferred type" $ do
+        getType (EAnn (ELit $ LInt 0) (TPol "a")) `shouldSatisfy` isLeft
 
-genInt :: Gen EIntExp
-genInt = EI . ELit . LInt <$> arbitrary
+    it "should be possible to annotate with a more specific type" $ do
+        let annotated_lambda = EAnn (EAbs "x" (EId "x")) (TArr (TMono "Int") (TMono "Int"))
+         in getType annotated_lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int"))
 
-genLambda :: Gen AbsExp
-genLambda = do
-    str <- arbitrary @String
-    let str' = Ident str
-    return $ AE $ EAbs str' (EId str')
+    it "should fail if the annotated type is more general than the inferred type" $ do
+        getType (EAnn (ELit (LInt 0)) (TPol "a")) `shouldSatisfy` isLeft
 
-prop_idAbs_generic :: AbsExp -> Bool
-prop_idAbs_generic (AE e) = case getType (inferExp e) of
-    Left _  -> False
-    Right t -> isGenericArr t
+    it "should fail if the annotated type is an arrow but the annotated type is not" $ do
+        getType (EAnn (EAbs "x" (EId "x")) (TPol "a")) `shouldSatisfy` isLeft
 
-prop_isInt :: EIntExp -> Bool
-prop_isInt (EI e) = case getType (inferExp e) of
-    Left _  -> False
-    Right t -> t == int
+infer_eid = describe "algoW used on EId" $ do
+    it "should fail if the variable is not added to the environment" $ do
+        property $ \x -> getType (EId (Ident (x :: String))) `shouldSatisfy` isLeft
 
-int :: Type
-int = TMono "Int"
+    it "should succeed if the type exist in the environment" $ do
+        property $ \x -> do
+            let env = Env 0 mempty mempty
+            let t = Forall [] (TPol "a")
+            let ctx = Ctx (M.singleton (Ident (x :: String)) t)
+            getTypeC env ctx (EId (Ident x)) `shouldBe` Right (TPol "a")
 
-isGenericArr :: Type -> Bool
-isGenericArr (TArr (TPol a) (TPol b)) = a == b
-isGenericArr _                        = False
+infer_eabs = describe "algoW used on EAbs" $ do
+    it "should infer the argument type as int if the variable is used as an int" $ do
+        let lambda = EAbs "x" (EAdd (EId "x") (ELit (LInt 0)))
+        getType lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int"))
+
+    it "should infer the argument type as polymorphic if it is not used in the lambda" $ do
+        let lambda = EAbs "x" (ELit (LInt 0))
+        getType lambda `shouldSatisfy` isArrowPolyToMono
+    it "should infer a variable as function if used as one" $ do
+        let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x")))
+        let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True
+            isOk _                                                                = False
+        getType lambda `shouldSatisfy` isOk
+
+infer_eapp = describe "algoW used on EApp" $ do
+    it "should fail if a variable is applied to itself (occurs check)" $ do
+        property $ \x -> do
+            let env = Env 0 mempty mempty
+            let t = Forall [] (TPol "a")
+            let ctx = Ctx (M.singleton (Ident (x :: String)) t)
+            getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed"
+
+isArrowPolyToMono :: Either Error Type -> Bool
+isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True
+isArrowPolyToMono _                                 = False
+
+-- | Empty environment
+getType :: Exp -> Either Error Type
+getType e = pure fst <*> run (inferExp e)
+
+-- | Custom environment
+getTypeC :: Env -> Ctx -> Exp -> Either Error Type
+getTypeC env ctx e = pure fst <*> runC env ctx (inferExp e)