diff --git a/language.cabal b/language.cabal index 12d374b..2f00ced 100644 --- a/language.cabal +++ b/language.cabal @@ -81,6 +81,7 @@ Test-suite language-testsuite , extra , array , QuickCheck + , hspec default-language: GHC2021 diff --git a/tests/Monomorpher/Monomorpher.hs b/tests/Monomorpher/Monomorpher.hs deleted file mode 100644 index e69de29..0000000 diff --git a/tests/Tests.hs b/tests/Tests.hs index 46a9a3f..cbe80e7 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,56 +1,84 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use <$>" #-} module Main where - -import Control.Monad.Except -import Grammar.Abs -import Test.QuickCheck -import TypeChecker.TypeChecker +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) +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 - quickCheck prop_idAbs_generic + return () -newtype AbsExp = AE Exp deriving Show -newtype EIntExp = EI Exp deriving Show +-- | Reusable test constructs for Monomorpher. +typeInt :: T.Type +typeInt = T.TMono $ Ident "Int" -instance Arbitrary EIntExp where - arbitrary = genInt +typeIntToInt :: T.Type +typeIntToInt = T.TArr typeInt typeInt -instance Arbitrary AbsExp where - arbitrary = genLambda +typeA :: T.Type +typeA = T.TPol $ Ident "a" -getType :: Infer (Type, T.Exp) -> Either Error Type -getType ie = case run ie of - Left err -> Left err - Right (t,e) -> return t +typeAToA :: T.Type +typeAToA = T.TArr typeA typeA -genInt :: Gen EIntExp -genInt = EI . ELit . LInt <$> arbitrary +-- f :: Int -> Int +-- 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 -genLambda = do - str <- arbitrary @String - let str' = Ident str - return $ AE $ EAbs str' (EId str') +-- f :: a -> a +-- f x = x + x +pName = (Ident "p", typeAToA) +pArg1 = (Ident "x", typeA) +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 -prop_isInt (EI e) = case getType (inferExp e) of - Left _ -> False - Right t -> t == int +-- | Examples -int :: Type -int = TMono "Int" +-- main = f 5 +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