created dummy monomorphizer

language.cabal

@@ -34,7 +34,6 @@ executable language
       TypeChecker.TypeChecker
       TypeChecker.TypeCheckerIr
       Renamer.Renamer
-      LambdaLifter.LambdaLifter
       Codegen.Codegen
       Codegen.LlvmIr
 

src/Codegen/Codegen.hs

@@ -2,25 +2,37 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Codegen.Codegen (generateCode) where
+
 import Auxiliary (snoc)
-import           Codegen.LlvmIr                (CallingConvention (..),
+import Codegen.LlvmIr (
-                                                LLVMComp (..), LLVMIr (..),
+    CallingConvention (..),
-                                                LLVMType (..), LLVMValue (..),
+    LLVMComp (..),
-                                                Visibility (..), llvmIrToString)
+    LLVMIr (..),
+    LLVMType (..),
+    LLVMValue (..),
+    Visibility (..),
+    llvmIrToString,
+ )
 import Codegen.LlvmIr as LIR
 import Control.Applicative ((<|>))
-import           Control.Monad.State           (StateT, execStateT, foldM_,
+import Control.Monad.State (
-                                                gets, modify)
+    StateT,
-import qualified Data.Bifunctor                as BI
+    execStateT,
+    foldM_,
+    gets,
+    modify,
+ )
+import Data.Bifunctor qualified as BI
 import Data.List.Extra (trim)
 import Data.Map (Map)
-import qualified Data.Map                      as Map
+import Data.Map qualified as Map
 import Data.Maybe (fromJust, fromMaybe)
 import Data.Tuple.Extra (dupe, first, second)
-import qualified Grammar.Abs                   as GA
+import Grammar.Abs qualified as GA
 import Grammar.ErrM (Err)
 import Monomorphizer.MonomorphizerIr as MIR
 import System.Process.Extra (readCreateProcess, shell)
+
 -- | The record used as the code generator state
 data CodeGenerator = CodeGenerator
     { instructions :: [LLVMIr]
@@ -36,13 +48,14 @@ type CompilerState a = StateT CodeGenerator Err a
 data FunctionInfo = FunctionInfo
     { numArgs :: Int
     , arguments :: [Id]
-    } deriving Show
+    }
+    deriving (Show)
 data ConstructorInfo = ConstructorInfo
     { numArgsCI :: Int
     , argumentsCI :: [Id]
     , numCI :: Integer
-    } deriving Show
+    }
-
+    deriving (Show)
 
 -- | Adds a instruction to the CodeGenerator state
 emit :: LLVMIr -> CompilerState ()
@@ -66,8 +79,9 @@ getNewLabel = do
     modify (\t -> t{labelCount = labelCount t + 1})
     gets labelCount
 
--- | Produces a map of functions infos from a list of binds,
+{- | Produces a map of functions infos from a list of binds,
---  which contains useful data for code generation.
+ which contains useful data for code generation.
+-}
 getFunctions :: [Bind] -> Map Id FunctionInfo
 getFunctions bs = Map.fromList $ go bs
   where
@@ -75,32 +89,56 @@ getFunctions bs = Map.fromList $ go bs
     go (Bind id args _ : xs) =
         (id, FunctionInfo{numArgs = length args, arguments = args})
             : go xs
-    go (DataType n cons : xs) = do
+    go (DataType n cons : xs) =
-        map (\(Constructor id xs) -> ((id, MIR.Type n), FunctionInfo {
+        do
-            numArgs=length xs, arguments=createArgs xs
+            map
-        })) cons
+                ( \(Constructor id xs) ->
+                    ( (id, MIR.Type n)
+                    , FunctionInfo
+                        { numArgs = length xs
+                        , arguments = createArgs xs
+                        }
+                    )
+                )
+                cons
             <> go xs
 
 createArgs :: [Type] -> [Id]
 createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs
 
--- | Produces a map of functions infos from a list of binds,
+{- | Produces a map of functions infos from a list of binds,
---  which contains useful data for code generation.
+ which contains useful data for code generation.
+-}
 getConstructors :: [Bind] -> Map Id ConstructorInfo
 getConstructors bs = Map.fromList $ go bs
   where
     go [] = []
-    go (DataType (GA.Ident n) cons : xs) = do
+    go (DataType (GA.Ident n) cons : xs) =
-        fst (foldl (\(acc,i) (Constructor (GA.Ident id) xs) -> (((GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)), ConstructorInfo {
+        do
-            numArgsCI=length xs,
+            fst
-            argumentsCI=createArgs xs,
+                ( foldl
-            numCI=i
+                    ( \(acc, i) (Constructor (GA.Ident id) xs) ->
-        }) : acc, i+1)) ([],0) cons)
+                        ( ( (GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n))
+                          , ConstructorInfo
+                                { numArgsCI = length xs
+                                , argumentsCI = createArgs xs
+                                , numCI = i
+                                }
+                          )
+                            : acc
+                        , i + 1
+                        )
+                    )
+                    ([], 0)
+                    cons
+                )
             <> go xs
     go (_ : xs) = go xs
 
 initCodeGenerator :: [Bind] -> CodeGenerator
-initCodeGenerator scs = CodeGenerator { instructions = defaultStart
+initCodeGenerator scs =
+    CodeGenerator
+        { instructions = defaultStart
         , functions = getFunctions scs
         , constructors = getConstructors scs
         , variableCount = 0
@@ -116,24 +154,29 @@ run s = do
     putStrLn . trim =<< readCreateProcess (shell "lli") s'
 
 test :: Integer -> Program
-test v = Program
+test v =
-    [ DataType (GA.Ident "Craig") [
+    Program
-        Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")],
+        [ DataType
-        Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")]
+            (GA.Ident "Craig")
+            [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")]
+            , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")]
             ]
-    , DataType (GA.Ident "Alice") [
+        , DataType
-        Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")]--,
+            (GA.Ident "Alice")
+            [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- ,
             -- (GA.Ident "Alice", [TInt, TInt])
             ]
         , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig"))
         , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) []
           -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92)
-        $ eCaseInt (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))
+          $
+            eCaseInt
+                (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))
                 [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int"))
                 , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2)
                 , Injection (CIdent (GA.Ident "z")) (int 3)
-            --, injectionInt 5 (int 6)
+                , -- , injectionInt 5 (int 6)
-            , injectionCatchAll (int 10)
+                  injectionCatchAll (int 10)
                 ]
         ]
   where
@@ -157,7 +200,8 @@ compileScs []                             = do
     -- as a last step create all the constructors
     -- //TODO maybe merge this with the data type match?
     c <- gets (Map.toList . constructors)
-    mapM_ (\((id, t), ci) -> do
+    mapM_
+        ( \((id, t), ci) -> do
             let t' = type2LlvmType t
             let x = BI.second type2LlvmType <$> argumentsCI ci
             emit $ Define FastCC t' id x
@@ -167,10 +211,16 @@ compileScs []                             = do
             emit $ SetVariable top (Alloca t')
 
             -- set the first byte to the index of the constructor
-            emit $ SetVariable ptr $
+            emit $
-                GetElementPtr t' (Ref t') (VIdent top I8)
+                SetVariable ptr $
-                                      I64 (VInteger 0)
+                    GetElementPtr
-                                      I32 (VInteger 0)
+                        t'
+                        (Ref t')
+                        (VIdent top I8)
+                        I64
+                        (VInteger 0)
+                        I32
+                        (VInteger 0)
             emit $ Store I8 (VInteger $ numCI ci) (Ref I8) ptr
 
             -- get a pointer of the correct type
@@ -179,17 +229,26 @@ compileScs []                             = do
 
             -- emit $ UnsafeRaw "\n"
 
-            enumerateOneM_ (\i (GA.Ident arg_n, arg_t) -> do
+            enumerateOneM_
+                ( \i (GA.Ident arg_n, arg_t) -> do
                     let arg_t' = type2LlvmType arg_t
                     emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i)
                     elemPtr <- getNewVar
-                emit $ SetVariable elemPtr (
+                    emit $
-                    GetElementPtr (CustomType id) (Ref (CustomType id))
+                        SetVariable
+                            elemPtr
+                            ( GetElementPtr
+                                (CustomType id)
+                                (Ref (CustomType id))
                                 (VIdent ptr' Ptr)
-                                          I64 (VInteger 0)
+                                I64
-                                          I32 (VInteger i))
+                                (VInteger 0)
+                                I32
+                                (VInteger i)
+                            )
                     emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr
-                ) (argumentsCI ci)
+                )
+                (argumentsCI ci)
 
             -- emit $ UnsafeRaw "\n"
 
@@ -201,7 +260,8 @@ compileScs []                             = do
             emit DefineEnd
 
             modify $ \s -> s{variableCount = 0}
-        ) c
+        )
+        c
 compileScs (Bind (name, _t) args exp : xs) = do
     emit $ UnsafeRaw "\n"
     emit . Comment $ show name <> ": " <> show exp
@@ -217,9 +277,11 @@ compileScs (Bind (name, _t) args exp : xs) = do
 compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do
     let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
     emit $ LIR.Type id [I8, Array biggestVariant I8]
-    mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do
+    mapM_
+        ( \(Constructor (GA.Ident inner_id) fi) -> do
             emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
-        ) ts
+        )
+        ts
     compileScs xs
 
 -- where
@@ -249,7 +311,8 @@ mainContent var =
     ]
 
 defaultStart :: [LLVMIr]
-defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n"
+defaultStart =
+    [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n"
     , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n"
     , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n"
     , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
@@ -264,6 +327,7 @@ compileExp (EApp t e1 e2)   = emitApp t (fst e1) (fst e2)
 -- compileExp (EAbs t ti e)   = emitAbs t ti e
 compileExp (ELet _ binds e) = undefined emitLet binds (fst e)
 compileExp (ECase t e cs) = emitECased t e (map (t,) cs)
+
 -- go (EMul e1 e2)  = emitMul e1 e2
 -- go (EDiv e1 e2)  = emitDiv e1 e2
 -- go (EMod e1 e2)  = emitMod e1 e2
@@ -309,7 +373,8 @@ emitECased t e cases = do
         emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr)
 
         val <- exprToValue (fst exp)
-        enumerateOneM_ (\i c -> do
+        enumerateOneM_
+            ( \i c -> do
                 case c of
                     CIdent x -> do
                         emit . Comment $ "ident " <> show x
@@ -326,7 +391,8 @@ emitECased t e cases = do
                 emit . Comment $ "return this " <> toIr val
                 emit . Comment . show $ c
                 emit . Comment . show $ i
-            ) cs
+            )
+            cs
         -- emit $ Store ty val Ptr stackPtr
         emit $ Br label
         emit $ Label lbl_failPos
@@ -359,7 +425,6 @@ emitECased t e cases = do
         emit $ Store ty val Ptr stackPtr
         emit $ Br label
 
-
 emitLet :: Bind -> Exp -> CompilerState ()
 emitLet xs e = do
     emit $
@@ -385,10 +450,10 @@ emitApp t e1 e2 = appEmitter t e1 e2 []
                 vs <- getNewVar
                 funcs <- gets functions
                 consts <- gets constructors
-                let visibility = fromMaybe Local $
+                let visibility =
+                        fromMaybe Local $
                             Global <$ Map.lookup id consts
-                        <|>
+                                <|> Global <$ Map.lookup id funcs
-                        Global <$ Map.lookup id funcs
                     -- this piece of code could probably be improved, i.e remove the double `const Global`
                     args' = map (first valueGetType . dupe) args
                     call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args'
@@ -412,7 +477,6 @@ emitLit i = do
     emit $ Comment "This should not have happened!"
     emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0))
 
-
 emitAdd :: Type -> Exp -> Exp -> CompilerState ()
 emitAdd t e1 e2 = do
     v1 <- exprToValue e1
@@ -439,7 +503,9 @@ exprToValue = \case
                 if numArgs fi == 0
                     then do
                         vc <- getNewVar
-                        emit $ SetVariable vc
+                        emit $
+                            SetVariable
+                                vc
                                 (Call FastCC (type2LlvmType t) Global name [])
                         pure $ VIdent vc (type2LlvmType t)
                     else pure $ VFunction name Global (type2LlvmType t)
@@ -453,6 +519,7 @@ type2LlvmType :: Type -> LLVMType
 type2LlvmType (MIR.Type (GA.Ident t)) = case t of
     "_Int" -> I64
     t -> CustomType (GA.Ident t)
+
 -- TInt -> I64
 -- TFun t xs -> do
 --     let (t', xs') = function2LLVMType xs [type2LlvmType t]
@@ -493,4 +560,3 @@ typeByteSize (CustomType _) = 8
 
 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m ()
 enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1
-

src/LambdaLifter/LambdaLifter.hs

@@ -1,194 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module LambdaLifter.LambdaLifter where
-
-import Auxiliary (snoc)
-import Control.Applicative (Applicative (liftA2))
-import Control.Monad.State (MonadState (get, put), State, evalState)
-import Data.Set (Set)
-import Data.Set qualified as Set
-import Renamer.Renamer
-import TypeChecker.TypeChecker (partitionType)
-import TypeChecker.TypeCheckerIr
-import Prelude hiding (exp)
-
-{- | Lift lambdas and let expression into supercombinators.
-Three phases:
-@freeVars@ annotates all the free variables.
-@abstract@ converts lambdas into let expressions.
-@collectScs@ moves every non-constant let expression to a top-level function.
--}
-lambdaLift :: Program -> Program
-lambdaLift = collectScs . abstract . freeVars
-
--- | Annotate free variables
-freeVars :: Program -> AnnProgram
-freeVars (Program ds) =
-    [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e)
-    | Bind n xs e <- ds
-    ]
-
-freeVarsExp :: Set Ident -> ExpT -> AnnExpT
-freeVarsExp localVars (exp, t) = case exp of
-    EId n
-        | Set.member n localVars -> (Set.singleton n, (AId n, t))
-        | otherwise -> (mempty, (AId n, t))
-    -- EInt i -> (mempty, AInt i)
-    ELit lit -> (mempty, (ALit lit, t))
-    EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t))
-      where
-        e1' = freeVarsExp localVars e1
-        e2' = freeVarsExp localVars e2
-    EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t))
-      where
-        e1' = freeVarsExp localVars e1
-        e2' = freeVarsExp localVars e2
-    EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t))
-      where
-        e' = freeVarsExp (Set.insert par localVars) e
-
-    -- Sum free variables present in bind and the expression
-    ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t))
-      where
-        binders_frees = Set.delete name $ freeVarsOf rhs'
-        e_free = Set.delete name $ freeVarsOf e'
-
-        rhs' = freeVarsExp e_localVars rhs
-        new_bind = ABind (name, t_bind) parms rhs'
-
-        e' = freeVarsExp e_localVars e
-        e_localVars = Set.insert name localVars
-
-freeVarsOf :: AnnExpT -> Set Ident
-freeVarsOf = fst
-
--- AST annotated with free variables
-type AnnProgram = [(Id, [Id], AnnExpT)]
-
-type AnnExpT = (Set Ident, AnnExpT')
-
-data ABind = ABind Id [Id] AnnExpT deriving (Show)
-
-type AnnExpT' = (AnnExp, Type)
-
-data AnnExp
-    = AId Ident
-    | ALit Lit
-    | ALet ABind AnnExpT
-    | AApp AnnExpT AnnExpT
-    | AAdd AnnExpT AnnExpT
-    | AAbs Ident AnnExpT
-    deriving (Show)
-
-{- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@.
-Free variables are @v₁ v₂ .. vₙ@ are bound.
--}
-abstract :: AnnProgram -> Program
-abstract prog = Program $ evalState (mapM go prog) 0
-  where
-    go :: (Id, [Id], AnnExpT) -> State Int Bind
-    go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs'
-      where
-        (rhs', parms1) = flattenLambdasAnn rhs
-
-{- | Flatten nested lambdas and collect the parameters
-@\x.\y.\z. ae → (ae, [x,y,z])@
--}
-flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id])
-flattenLambdasAnn ae = go (ae, [])
-  where
-    go :: (AnnExpT, [Id]) -> (AnnExpT, [Id])
-    go ((free, (e, t)), acc)
-        | AAbs par (free1, e1) <- e
-        , TFun t_par _ <- t =
-            go ((Set.delete par free1, e1), snoc (par, t_par) acc)
-        | otherwise = ((free, (e, t)), acc)
-
-abstractExp :: AnnExpT -> State Int ExpT
-abstractExp (free, (exp, t)) = case exp of
-    AId n -> pure (EId n, t)
-    ALit lit -> pure (ELit lit, t)
-    AApp e1 e2 -> (,t) <$> liftA2 EApp (abstractExp e1) (abstractExp e2)
-    AAdd e1 e2 -> (,t) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2)
-    ALet b e -> (,t) <$> liftA2 ELet (go b) (abstractExp e)
-      where
-        go (ABind name parms rhs) = do
-            (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs
-            pure $ Bind name (parms ++ parms1) rhs'
-
-        skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT
-        skipLambdas f (free, (ae, t)) = case ae of
-            AAbs par ae1 -> do
-                ae1' <- skipLambdas f ae1
-                pure (EAbs par ae1', t)
-            _ -> f (free, (ae, t))
-
-    -- Lift lambda into let and bind free variables
-    AAbs parm e -> do
-        i <- nextNumber
-        rhs <- abstractExp e
-
-        let sc_name = Ident ("sc_" ++ show i)
-            sc = (ELet (Bind (sc_name, t) vars rhs) (EId sc_name, t), t)
-        pure $ foldl applyVars sc freeList
-      where
-        freeList = Set.toList free
-        vars = zip names . fst $ partitionType (length names) t
-        names = snoc parm freeList
-        applyVars (e, t) name = (EApp (e, t) (EId name, t_var), t_return)
-          where
-            (t_var : _, t_return) = partitionType 1 t
-
-nextNumber :: State Int Int
-nextNumber = do
-    i <- get
-    put $ succ i
-    pure i
-
--- | Collects supercombinators by lifting non-constant let expressions
-collectScs :: Program -> Program
-collectScs (Program scs) = Program $ concatMap collectFromRhs scs
-  where
-    collectFromRhs (Bind name parms rhs) =
-        let (rhs_scs, rhs') = collectScsExp rhs
-         in Bind name parms rhs' : rhs_scs
-
-collectScsExp :: ExpT -> ([Bind], ExpT)
-collectScsExp expT@(exp, typ) = case exp of
-    EId _ -> ([], expT)
-    ELit _ -> ([], expT)
-    EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ))
-      where
-        (scs1, e1') = collectScsExp e1
-        (scs2, e2') = collectScsExp e2
-    EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ))
-      where
-        (scs1, e1') = collectScsExp e1
-        (scs2, e2') = collectScsExp e2
-    EAbs par e -> (scs, (EAbs par e', typ))
-      where
-        (scs, e') = collectScsExp e
-
-    -- Collect supercombinators from bind, the rhss, and the expression.
-    --
-    -- > f = let sc x y = rhs in e
-    --
-    ELet (Bind name parms rhs) e ->
-        if null parms
-            then (rhs_scs ++ et_scs, (ELet bind et', snd et'))
-            else (bind : rhs_scs ++ et_scs, et')
-      where
-        bind = Bind name parms rhs'
-        (rhs_scs, rhs') = collectScsExp rhs
-        (et_scs, et') = collectScsExp e
-
--- @\x.\y.\z. e → (e, [x,y,z])@
-flattenLambdas :: ExpT -> (ExpT, [Id])
-flattenLambdas = go . (,[])
-  where
-    go ((e, t), acc) = case e of
-        EAbs name e1 -> go (e1, snoc (name, t_var) acc)
-          where
-            t_var : _ = fst $ partitionType 1 t
-        _ -> ((e, t), acc)

src/Main.hs

@@ -2,17 +2,16 @@
 
 module Main where
 
--- import           Codegen.Codegen           (generateCode)
+import Codegen.Codegen (generateCode)
 import GHC.IO.Handle.Text (hPutStrLn)
 import Grammar.ErrM (Err)
 import Grammar.Par (myLexer, pProgram)
 import Grammar.Print (printTree)
+import Monomorphizer.Monomorphizer (monomorphize)
 
--- import           Interpreter        (interpret)
 import Control.Monad (when)
 import Data.List.Extra (isSuffixOf)
 
--- import           LambdaLifter.LambdaLifter (lambdaLift)
 import Renamer.Renamer (rename)
 import System.Directory (
     createDirectory,
@@ -54,9 +53,9 @@ main' debug s = do
     -- let lifted = lambdaLift typechecked
     -- printToErr $ printTree lifted
     --
-    -- printToErr "\n -- Printing compiler output to stdout --"
+    printToErr "\n -- Printing compiler output to stdout --"
-    -- compiled <- fromCompilerErr $ generateCode lifted
+    compiled <- fromCompilerErr $ generateCode (monomorphize typechecked)
-    -- putStrLn compiled
+    putStrLn compiled
 
     -- check <- doesPathExist "output"
     -- when check (removeDirectoryRecursive "output")

src/Monomorphizer/Monomorphizer.hs

@@ -1 +1,17 @@
-module Monomorphizer.Monomorphizer where
+module Monomorphizer.Monomorphizer (monomorphize) where
+
+import Monomorphizer.MonomorphizerIr
+import TypeChecker.TypeCheckerIr qualified as T
+
+monomorphize :: T.Program -> Program
+monomorphize (T.Program ds) = Program $ monoDefs ds
+
+monoDefs :: [T.Def] -> [Def]
+monoDefs = map monoDef
+
+monoDef :: T.Def -> Def
+monoDef (T.DBind bind) = DBind $ monoBind bind
+monoDef (T.DData d) = DData d
+
+monoBind :: T.Bind -> Bind
+monoBind (T.Bind name args e) = Bind name args e

src/Monomorphizer/MonomorphizerIr.hs

@@ -1,10 +1,15 @@
 module Monomorphizer.MonomorphizerIr where
-import           Grammar.Abs (Ident)
 
-newtype Program = Program [Bind]
+import Grammar.Abs (Data, Ident, Init)
+import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed)
+
+newtype Program = Program [Def]
     deriving (Show, Ord, Eq)
 
-data Bind = Bind Id [Id] ExpT | DataType Ident [Constructor]
+data Def = DBind Bind | DData Data
+    deriving (Show, Ord, Eq)
+
+data Bind = Bind Id [Id] ExpT
     deriving (Show, Ord, Eq)
 
 data Exp
@@ -16,19 +21,14 @@ data Exp
     | ECase Type ExpT [Injection]
     deriving (Show, Ord, Eq)
 
-data Injection = Injection Case ExpT
+data Injection = Injection (Init, Type) ExpT
-    deriving (Show, Ord, Eq)
+    deriving (Eq, Ord, Show)
-
-data Case = CLit Lit | CCons Id [Case] | CIdent Ident | CatchAll
-    deriving (Show, Ord, Eq)
 
 data Constructor = Constructor Ident [Type]
     deriving (Show, Ord, Eq)
 
-type Id  = (Ident, Type)
+data Lit
-type ExpT = (Exp, Type)
+    = LInt Integer
-
-data Lit = LInt Integer
     | LChar Char
     deriving (Show, Ord, Eq)