diff --git a/src/Main.hs b/src/Main.hs index 4208137..84e109a 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 66888c0..052cdc1 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -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 diff --git a/test_program.crf b/test_program.crf index 4771d93..8cee923 100644 --- a/test_program.crf +++ b/test_program.crf @@ -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 ; ---}; \ No newline at end of file +main = const (id 0) (id 'a') ;