112 lines
3 KiB
Haskell
112 lines
3 KiB
Haskell
{-# 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
|
|
|