Merged into commit not compiling on codegen 😤

tests/Tests.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use <$>" #-}
+
+module Main where
+import Grammar.Abs  (Ident (Ident), Literal (LInt))
+import qualified TypeChecker.TypeCheckerIr as T
+
+import Monomorpher.Monomorpher (monomorphize)
+import Grammar.Print (printTree)
+import           System.IO                 (stderr)
+import           GHC.IO.Handle.Text        (hPutStrLn)
+
+
+printToErr :: String -> IO ()
+printToErr = hPutStrLn stderr
+
+main :: IO ()
+main = do
+  -- Only demonstrations for now, will fail if error is thrown.
+  simpleDemo
+
+-- A simple demo
+simpleDemo = do
+  demo "main = f 5" $ simpleProgram [f] 
+    (mainApp (T.EId ("f", typeIntToInt)) lit5)
+  demo "main = bigId 5" $ simpleProgram [bigId] 
+    (mainApp (T.EId ("bigId", typeIntToInt)) lit5)
+  demo "main = g 5" $ simpleProgram [g, bigId] 
+    (mainApp (T.EId ("g", typeIntToInt)) lit5)
+  demo "main = (bigConst 5) ((bigConst 5) True)" $ simpleProgram [bigConst]
+    (T.EApp typeInt
+      -- (bigConst 5)
+      (T.EApp typeIntToInt (T.EId ("bigConst", typeIntToIntToInt)) lit5)
+      -- ((bigConst 5) True)
+      (T.EApp typeInt
+        (T.EApp typeBoolToInt
+          (T.EId ("bigConst", typeIntToBoolToInt))
+          lit5
+        )
+        litTrue
+      ) 
+    )
+
+-- Nice demo 👍
+demo :: String -> T.Program -> IO ()
+demo label prg = do
+  printToErr $ "#### " ++ label ++ " ####"
+  printToErr "    * Lifted Tree *    "
+  printToErr $ printTree prg
+  printToErr "    * Monomorphized Tree *    "
+  printToErr $ printTree (monomorphize prg)
+  printToErr "##########\n"
+
+-- Programs in the form of "main = 'func' 'x'"
+simpleProgram :: [T.Bind] -> T.Exp -> T.Program
+simpleProgram binds input = T.Program (T.Bind ("main", typeInt) [] input:binds)
+
+-- Applies two expressions, has type Int
+mainApp :: T.Exp -> T.Exp -> T.Exp
+mainApp = T.EApp typeInt
+
+-- f :: Int -> Int
+-- f x = x + x
+f = T.Bind ("f", typeIntToInt) [("x", typeInt)] fExp
+fExp = T.EAdd typeInt (T.EId ("x", typeInt)) (T.EId ("x", typeInt))
+
+-- bigId :: a -> a
+-- bigId x = x
+bigId = T.Bind (Ident "bigId", typeAToA) [(Ident "x", typeA)] bigIdExp
+bigIdExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId ("x", typeA))
+
+-- bigConst :: a -> a -> a
+-- bigConst x y = x
+bigConst = T.Bind ("bigConst", typeAToAToA) [("x", typeA), ("y", typeA)] bigConstExp
+bigConstExp = T.EId ("x", typeA)
+
+-- g :: a -> a
+-- g x = x + (bigId x)
+g = T.Bind ("g", typeAToA) [("x", typeA)] gExp
+gExp = T.EAdd typeA (T.EId ("x", typeA)) (T.EApp typeA (T.EId ("bigId", typeAToA)) (T.EId ("x", typeA)))
+
+-- | Reusable test constructs for Monomorpher.
+typeInt = T.TMono "Int"
+
+typeIntToInt = T.TArr typeInt typeInt
+
+typeIntToIntToInt = T.TArr typeInt typeIntToInt
+
+
+typeA = T.TPol $ Ident "a"
+
+typeAToA = T.TArr typeA typeA
+
+typeAToAToA = T.TArr typeA typeAToA
+
+
+typeBool = T.TMono "Bool"
+
+typeBoolToBool = T.TArr typeBool typeBool
+
+typeBoolToBoolToBool = T.TArr typeBool typeBoolToBool
+
+
+lit5 = T.ELit typeInt $ T.LInt 5
+
+litTrue = T.ELit typeBool T.LBool
+
+
+typeBoolToInt = T.TArr typeBool typeInt
+typeIntToBoolToInt = T.TArr typeInt typeBoolToInt
+