added printTree for monomorphizer
This commit is contained in:
sebastianselander
parent
cf12c3443d
commit
ba832ba288
3 changed files with 178 additions and 76 deletions
105
src/Main.hs
105
src/Main.hs
|
|
@ -1,34 +1,44 @@
|
|||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Bool (bool)
|
||||
import Data.List.Extra (isSuffixOf)
|
||||
import Data.Maybe (fromJust, isNothing)
|
||||
import GHC.IO.Handle.Text (hPutStrLn)
|
||||
import System.Console.GetOpt (ArgDescr (NoArg, ReqArg),
|
||||
ArgOrder (RequireOrder),
|
||||
OptDescr (Option), getOpt,
|
||||
usageInfo)
|
||||
import System.Directory (createDirectory, doesPathExist,
|
||||
getDirectoryContents,
|
||||
removeDirectoryRecursive,
|
||||
setCurrentDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (ExitCode (ExitFailure),
|
||||
exitFailure, exitSuccess,
|
||||
exitWith)
|
||||
import System.IO (stderr)
|
||||
import Codegen.Codegen (generateCode)
|
||||
import Compiler (compile)
|
||||
import Grammar.ErrM (Err)
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
import Grammar.Print (printTree)
|
||||
import LambdaLifter (lambdaLift)
|
||||
import Monomorphizer.Monomorphizer (monomorphize)
|
||||
import Renamer.Renamer (rename)
|
||||
import System.Process (spawnCommand, waitForProcess)
|
||||
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
|
||||
import Codegen.Codegen (generateCode)
|
||||
import Compiler (compile)
|
||||
import Control.Monad (when)
|
||||
import Data.Bool (bool)
|
||||
import Data.List.Extra (isSuffixOf)
|
||||
import Data.Maybe (fromJust, isNothing)
|
||||
import GHC.IO.Handle.Text (hPutStrLn)
|
||||
import Grammar.ErrM (Err)
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
import Grammar.Print (printTree)
|
||||
import LambdaLifter (lambdaLift)
|
||||
import Monomorphizer.Monomorphizer (monomorphize)
|
||||
import Renamer.Renamer (rename)
|
||||
import System.Console.GetOpt (
|
||||
ArgDescr (NoArg, ReqArg),
|
||||
ArgOrder (RequireOrder),
|
||||
OptDescr (Option),
|
||||
getOpt,
|
||||
usageInfo,
|
||||
)
|
||||
import System.Directory (
|
||||
createDirectory,
|
||||
doesPathExist,
|
||||
getDirectoryContents,
|
||||
removeDirectoryRecursive,
|
||||
setCurrentDirectory,
|
||||
)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (
|
||||
ExitCode (ExitFailure),
|
||||
exitFailure,
|
||||
exitSuccess,
|
||||
exitWith,
|
||||
)
|
||||
import System.IO (stderr)
|
||||
import System.Process (spawnCommand, waitForProcess)
|
||||
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= parseArgs >>= uncurry main'
|
||||
|
|
@ -75,11 +85,11 @@ chooseTypechecker s options = options{typechecker = tc}
|
|||
tc = case s of
|
||||
"hm" -> pure Hm
|
||||
"bi" -> pure Bi
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
data Options = Options
|
||||
{ help :: Bool
|
||||
, debug :: Bool
|
||||
{ help :: Bool
|
||||
, debug :: Bool
|
||||
, typechecker :: Maybe TypeChecker
|
||||
}
|
||||
|
||||
|
|
@ -100,46 +110,25 @@ main' opts s = do
|
|||
bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) opts.debug
|
||||
|
||||
printToErr "\n-- Lambda Lifter --"
|
||||
--let lifted = lambdaLift typechecked
|
||||
--printToErr $ printTree lifted
|
||||
let lifted = lambdaLift typechecked
|
||||
printToErr $ printTree lifted
|
||||
|
||||
printToErr "\n -- Monomorphizer --"
|
||||
let monomorphized = monomorphize typechecked
|
||||
printToErr $ show monomorphized
|
||||
let monomorphized = monomorphize lifted
|
||||
printToErr $ printTree monomorphized
|
||||
|
||||
-- printToErr "\n-- Lambda Lifter --"
|
||||
-- let lifted = lambdaLift typechecked
|
||||
-- printToErr $ printTree lifted
|
||||
--
|
||||
printToErr "\n -- Compiler --"
|
||||
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
|
||||
-- putStrLn generatedCode
|
||||
|
||||
check <- doesPathExist "output"
|
||||
when check (removeDirectoryRecursive "output")
|
||||
createDirectory "output"
|
||||
when opts.debug $ do
|
||||
_ <- writeFile "output/llvm.ll" generatedCode
|
||||
writeFile "output/llvm.ll" generatedCode
|
||||
debugDotViz
|
||||
|
||||
compile generatedCode
|
||||
spawnWait "./output/hello_world"
|
||||
--printToErr "\n -- Compiler --"
|
||||
--generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
|
||||
--putStrLn generatedCode
|
||||
|
||||
--check <- doesPathExist "output"
|
||||
--when check (removeDirectoryRecursive "output")
|
||||
--createDirectory "output"
|
||||
--when debug $ do
|
||||
-- writeFile "output/llvm.ll" generatedCode
|
||||
-- debugDotViz
|
||||
|
||||
--compile generatedCode
|
||||
--spawnWait "./hello_world"
|
||||
-- interpred <- fromInterpreterErr $ interpret lifted
|
||||
-- putStrLn "\n-- interpret"
|
||||
-- print interpred
|
||||
spawnWait "./hello_world"
|
||||
|
||||
exitSuccess
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,8 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr) where
|
||||
|
||||
import Grammar.Print
|
||||
import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..))
|
||||
|
||||
type Id = (TIR.Ident, Type)
|
||||
|
|
@ -52,3 +55,128 @@ data Type = TLit TIR.Ident | TFun Type Type
|
|||
flattenType :: Type -> [Type]
|
||||
flattenType (TFun t1 t2) = t1 : flattenType t2
|
||||
flattenType x = [x]
|
||||
|
||||
instance Print Program where
|
||||
prt i (Program sc) = prPrec i 0 $ prt 0 sc
|
||||
|
||||
instance Print (Bind) where
|
||||
prt i (Bind sig@(name, _) parms rhs) =
|
||||
prPrec i 0 $
|
||||
concatD
|
||||
[ prtSig sig
|
||||
, prt 0 name
|
||||
, prtIdPs 0 parms
|
||||
, doc $ showString "="
|
||||
, prt 0 rhs
|
||||
]
|
||||
|
||||
prtSig :: Id -> Doc
|
||||
prtSig (name, t) =
|
||||
concatD
|
||||
[ prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
, doc $ showString ";"
|
||||
]
|
||||
|
||||
instance Print (ExpT) where
|
||||
prt i (e, t) =
|
||||
concatD
|
||||
[ doc $ showString "("
|
||||
, prt i e
|
||||
, doc $ showString ","
|
||||
, prt i t
|
||||
, doc $ showString ")"
|
||||
]
|
||||
|
||||
instance Print [Bind] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
|
||||
prtIdPs :: Int -> [Id] -> Doc
|
||||
prtIdPs i = prPrec i 0 . concatD . map (prt i)
|
||||
|
||||
instance Print Exp where
|
||||
prt i = \case
|
||||
EVar name -> prPrec i 3 $ prt 0 name
|
||||
ELit lit -> prPrec i 3 $ prt 0 lit
|
||||
ELet b e ->
|
||||
prPrec i 3 $
|
||||
concatD
|
||||
[ doc $ showString "let"
|
||||
, prt 0 b
|
||||
, doc $ showString "in"
|
||||
, prt 0 e
|
||||
]
|
||||
EApp e1 e2 ->
|
||||
prPrec i 2 $
|
||||
concatD
|
||||
[ prt 2 e1
|
||||
, prt 3 e2
|
||||
]
|
||||
EAdd e1 e2 ->
|
||||
prPrec i 1 $
|
||||
concatD
|
||||
[ prt 1 e1
|
||||
, doc $ showString "+"
|
||||
, prt 2 e2
|
||||
]
|
||||
ECase e branches ->
|
||||
prPrec i 0 $
|
||||
concatD
|
||||
[ doc $ showString "case"
|
||||
, prt 0 e
|
||||
, doc $ showString "of"
|
||||
, doc $ showString "{"
|
||||
, prt 0 branches
|
||||
, doc $ showString "}"
|
||||
]
|
||||
|
||||
instance Print Branch where
|
||||
prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp])
|
||||
|
||||
instance Print [Branch] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
|
||||
instance Print Def where
|
||||
prt i = \case
|
||||
DBind bind -> prPrec i 0 (concatD [prt 0 bind])
|
||||
DData data_ -> prPrec i 0 (concatD [prt 0 data_])
|
||||
|
||||
instance Print Data where
|
||||
prt i = \case
|
||||
Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")])
|
||||
|
||||
instance Print Inj where
|
||||
prt i = \case
|
||||
Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_])
|
||||
|
||||
instance Print Pattern where
|
||||
prt i = \case
|
||||
PVar name -> prPrec i 1 (concatD [prt 0 name])
|
||||
PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit])
|
||||
PCatch -> prPrec i 1 (concatD [doc (showString "_")])
|
||||
PEnum name -> prPrec i 1 (concatD [prt 0 name])
|
||||
PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns])
|
||||
|
||||
instance Print [Def] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
|
||||
instance Print [Type] where
|
||||
prt _ [] = concatD []
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs]
|
||||
|
||||
instance Print Type where
|
||||
prt i = \case
|
||||
TLit uident -> prPrec i 1 (concatD [prt 0 uident])
|
||||
TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2])
|
||||
|
||||
instance Print Lit where
|
||||
prt i = \case
|
||||
LInt int -> prt i int
|
||||
LChar char -> prt i char
|
||||
|
|
|
|||
|
|
@ -1,20 +1,5 @@
|
|||
data List () where {
|
||||
Nil : List ()
|
||||
Cons : Int -> List () -> List ()
|
||||
};
|
||||
id x = x;
|
||||
|
||||
main = case Nil of {
|
||||
Nil => 0 ;
|
||||
Cons a _ => a ;
|
||||
};
|
||||
const x y = x ;
|
||||
|
||||
-- length : List () -> Int ;
|
||||
-- length xs = case xs of {
|
||||
-- Nil => 0;
|
||||
-- Cons _ xs => 1 + length xs ;
|
||||
-- };
|
||||
|
||||
--sum xs = case xs of {
|
||||
-- Nil => 0 ;
|
||||
-- Cons a xs => a + main xs ;
|
||||
--};
|
||||
main = const (id 0) (id 'a') ;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue