Simple polymorphic and monomorphic functions properly morphed in test demo.

language.cabal

@@ -81,6 +81,7 @@ Test-suite language-testsuite
       , extra
       , array
       , QuickCheck
+      , hspec
 
     default-language: GHC2021
 

tests/Tests.hs

@@ -1,56 +1,84 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use <$>" #-}
 
 module Main where
-
+import Grammar.Abs  (Ident (Ident), Literal (LInt))
-import           Control.Monad.Except
-import           Grammar.Abs
-import           Test.QuickCheck
-import           TypeChecker.TypeChecker
 import qualified TypeChecker.TypeCheckerIr as T
 
+import Monomorpher.Monomorpher (monomorphize)
+import Grammar.Print (printTree)
+import           System.IO                 (stderr)
+import           GHC.IO.Handle.Text        (hPutStrLn)
+import Test.Hspec
+
+printToErr :: String -> IO ()
+printToErr = hPutStrLn stderr
+
+-- A simple demo
+simpleDemo = do
+  printToErr "# Monomorphic function f"
+  printToErr "-- Lifted Tree --"
+  printToErr $ printTree example1
+  printToErr "-- Monomorphized Tree --"
+  printToErr $ printTree (monomorphize example1)
+
+  printToErr "# Polymorphic function p"
+  printToErr "-- Lifted Tree --"
+  printToErr $ printTree example2
+  printToErr "-- Monomorphized Tree --"
+  printToErr $ printTree (monomorphize example2)
+
 main :: IO ()
 main = do
-    quickCheck prop_isInt
+  return ()
-    quickCheck prop_idAbs_generic
 
-newtype AbsExp = AE Exp deriving Show
+-- | Reusable test constructs for Monomorpher.
-newtype EIntExp = EI Exp deriving Show
+typeInt :: T.Type
+typeInt = T.TMono $ Ident "Int"
 
-instance Arbitrary EIntExp where
+typeIntToInt :: T.Type
-  arbitrary = genInt
+typeIntToInt = T.TArr typeInt typeInt
 
-instance Arbitrary AbsExp where
+typeA :: T.Type
-  arbitrary = genLambda
+typeA = T.TPol $ Ident "a"
 
-getType :: Infer (Type, T.Exp) -> Either Error Type
+typeAToA :: T.Type
-getType ie = case run ie of
+typeAToA = T.TArr typeA typeA
-    Left err    -> Left err
-    Right (t,e) -> return t
 
-genInt :: Gen EIntExp
+-- f :: Int -> Int
-genInt = EI . ELit . LInt <$> arbitrary
+-- f x = x + x
+fName = (Ident "f", typeIntToInt)
+fArg1 = (Ident "x", typeInt)
+fArgs = [fArg1]
+fExp :: T.Exp
+fExp = T.EAdd typeInt (T.EId (Ident "x", typeInt)) (T.EId (Ident "x", typeInt))
+f :: T.Bind
+f = T.Bind fName fArgs fExp
 
-genLambda :: Gen AbsExp
+-- f :: a -> a
-genLambda = do
+-- f x = x + x
-    str <- arbitrary @String
+pName = (Ident "p", typeAToA)
-    let str' = Ident str
+pArg1 = (Ident "x", typeA)
-    return $ AE $ EAbs str' (EId str')
+pArgs = [pArg1]
+pExp :: T.Exp
+pExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId (Ident "x", typeA))
+p :: T.Bind
+p = T.Bind pName pArgs pExp
 
-prop_idAbs_generic :: AbsExp -> Bool
-prop_idAbs_generic (AE e) = case getType (inferExp e) of
-    Left _  -> False
-    Right t -> isGenericArr t
 
-prop_isInt :: EIntExp -> Bool
+-- | Examples
-prop_isInt (EI e) = case getType (inferExp e) of
-    Left _  -> False
-    Right t -> t == int
 
-int :: Type
+-- main = f 5
-int = TMono "Int"
+example1Name = (Ident "main", typeInt)
+example1Exp :: T.Exp
+example1Exp = T.EApp typeInt (T.EId (Ident "f", typeIntToInt)) (T.ELit typeInt $ LInt 5)
+example1 :: T.Program
+example1 = T.Program [T.Bind example1Name [] example1Exp, f]
+
+-- main = p 5
+example2Name = (Ident "main", typeInt)
+example2Exp :: T.Exp
+example2Exp = T.EApp typeInt (T.EId (Ident "p", typeIntToInt)) (T.ELit typeInt $ LInt 5)
+example2 :: T.Program
+example2 = T.Program [T.Bind example2Name [] example2Exp, p]
 
-isGenericArr :: Type -> Bool
-isGenericArr (TArr (TPol a) (TPol b)) = a == b
-isGenericArr _                        = False