added printTree for monomorphizer

src/Main.hs

@@ -1,34 +1,44 @@
 {-# LANGUAGE OverloadedRecordDot #-}
+
 module Main where
 
-import           Control.Monad               (when)
+import Codegen.Codegen (generateCode)
-import           Data.Bool                   (bool)
+import Compiler (compile)
-import           Data.List.Extra             (isSuffixOf)
+import Control.Monad (when)
-import           Data.Maybe                  (fromJust, isNothing)
+import Data.Bool (bool)
-import           GHC.IO.Handle.Text          (hPutStrLn)
+import Data.List.Extra (isSuffixOf)
-import           System.Console.GetOpt       (ArgDescr (NoArg, ReqArg),
+import Data.Maybe (fromJust, isNothing)
-                                              ArgOrder (RequireOrder),
+import GHC.IO.Handle.Text (hPutStrLn)
-                                              OptDescr (Option), getOpt,
+import Grammar.ErrM (Err)
-                                              usageInfo)
+import Grammar.Par (myLexer, pProgram)
-import           System.Directory            (createDirectory, doesPathExist,
+import Grammar.Print (printTree)
-                                              getDirectoryContents,
+import LambdaLifter (lambdaLift)
-                                              removeDirectoryRecursive,
+import Monomorphizer.Monomorphizer (monomorphize)
-                                              setCurrentDirectory)
+import Renamer.Renamer (rename)
-import           System.Environment          (getArgs)
+import System.Console.GetOpt (
-import           System.Exit                 (ExitCode (ExitFailure),
+    ArgDescr (NoArg, ReqArg),
-                                              exitFailure, exitSuccess,
+    ArgOrder (RequireOrder),
-                                              exitWith)
+    OptDescr (Option),
-import           System.IO                   (stderr)
+    getOpt,
-import           Codegen.Codegen             (generateCode)
+    usageInfo,
-import           Compiler                    (compile)
+ )
-import           Grammar.ErrM                (Err)
+import System.Directory (
-import           Grammar.Par                 (myLexer, pProgram)
+    createDirectory,
-import           Grammar.Print               (printTree)
+    doesPathExist,
-import           LambdaLifter                (lambdaLift)
+    getDirectoryContents,
-import           Monomorphizer.Monomorphizer (monomorphize)
+    removeDirectoryRecursive,
-import           Renamer.Renamer             (rename)
+    setCurrentDirectory,
-import           System.Process              (spawnCommand, waitForProcess)
+ )
-import           TypeChecker.TypeChecker     (TypeChecker (Bi, Hm), typecheck)
+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
+    { help :: Bool
-    , debug       :: 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
+    let lifted = lambdaLift typechecked
-    --printToErr $ printTree lifted
+    printToErr $ printTree lifted
 
     printToErr "\n -- Monomorphizer --"
-    let monomorphized = monomorphize typechecked
+    let monomorphized = monomorphize lifted
-    printToErr $ show monomorphized
+    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"
+    spawnWait "./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
 
     exitSuccess
 

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

test_program.crf

@@ -1,20 +1,5 @@
-data List () where {
+id x = x;
-    Nil : List ()
-    Cons : Int -> List () -> List ()
-};
 
-main = case Nil of {
+const x y = x ;
-    Nil => 0 ;
-    Cons a _ => a ;
-};
 
--- length : List () -> Int ;
+main = const (id 0) (id 'a') ;
--- 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 ;
---};