Got some more stuff working.

src/Codegen/Codegen.hs

@@ -1,9 +1,22 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Codegen.Codegen where
+module Codegen.Codegen (generateCode) where
 
--- module Codegen.Codegen (generateCode) where
+import           Auxiliary                     (snoc)
+import           Codegen.LlvmIr                as LIR
+import           Control.Applicative           ((<|>))
+import           Control.Monad.State           (StateT, execStateT, foldM_,
+                                                gets, modify)
+import qualified Data.Bifunctor                as BI
+import           Data.Coerce                   (coerce)
+import           Data.Map                      (Map)
+import qualified Data.Map                      as Map
+import           Data.Maybe                    (fromJust, fromMaybe)
+import           Data.Tuple.Extra              (dupe, first, second)
+import qualified Grammar.Abs                   as GA
+import           Grammar.ErrM                  (Err)
+import           Monomorphizer.MonomorphizerIr as MIR
 
 -- | The record used as the code generator state
 data CodeGenerator = CodeGenerator
@@ -14,45 +27,42 @@ data CodeGenerator = CodeGenerator
     , labelCount    :: Integer
     }
 
----- | The record used as the code generator state
--- data CodeGenerator = CodeGenerator
---    { instructions  :: [LLVMIr]
---    , functions     :: Map MIR.Id FunctionInfo
---    , constructors  :: Map Ident ConstructorInfo
---    , variableCount :: Integer
---    , labelCount    :: Integer
---    }
+-- | A state type synonym
+type CompilerState a = StateT CodeGenerator Err a
 
----- | A state type synonym
--- type CompilerState a = StateT CodeGenerator Err a
+data FunctionInfo = FunctionInfo
+    { numArgs   :: Int
+    , arguments :: [Id]
+    }
+    deriving (Show)
+data ConstructorInfo = ConstructorInfo
+    { numArgsCI   :: Int
+    , argumentsCI :: [Id]
+    , numCI       :: Integer
+    }
+    deriving (Show)
 
--- data FunctionInfo = FunctionInfo
---    { numArgs   :: Int
---    , arguments :: [Id]
---    }
---    deriving (Show)
--- data ConstructorInfo = ConstructorInfo
---    { numArgsCI   :: Int
---    , argumentsCI :: [Id]
---    , numCI       :: Integer
---    }
---    deriving (Show)
+-- | Adds a instruction to the CodeGenerator state
+emit :: LLVMIr -> CompilerState ()
+emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t}
 
----- | Adds a instruction to the CodeGenerator state
--- emit :: LLVMIr -> CompilerState ()
--- emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t}
+-- | Increases the variable counter in the CodeGenerator state
+increaseVarCount :: CompilerState ()
+increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1}
 
----- | Increases the variable counter in the CodeGenerator state
--- increaseVarCount :: CompilerState ()
--- increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1}
+-- | Returns the variable count from the CodeGenerator state
+getVarCount :: CompilerState Integer
+getVarCount = gets variableCount
 
----- | Returns the variable count from the CodeGenerator state
--- getVarCount :: CompilerState Integer
--- getVarCount = gets variableCount
+-- | Increases the variable count and returns it from the CodeGenerator state
+getNewVar :: CompilerState GA.Ident
+getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount)
 
----- | Increases the variable count and returns it from the CodeGenerator state
--- getNewVar :: CompilerState GA.Ident
--- getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount)
+-- | Increses the label count and returns a label from the CodeGenerator state
+getNewLabel :: CompilerState Integer
+getNewLabel = do
+    modify (\t -> t{labelCount = labelCount t + 1})
+    gets labelCount
 
 {- | Produces a map of functions infos from a list of binds,
  which contains useful data for code generation.
@@ -64,41 +74,21 @@ getFunctions bs = Map.fromList $ go bs
     go (MIR.DBind (MIR.Bind id args _) : xs) =
         (id, FunctionInfo{numArgs = length args, arguments = args})
             : go xs
-    go (MIR.DData (MIR.Constructor n cons) : xs) =
+    go (MIR.DData (MIR.Data n cons) : xs) =
         do map
-                ( \(id, xs) ->
-                    ( (coerce id, MIR.TLit (coerce n))
+                ( \(Constructor id xs) ->
+                    ( (coerce id, MIR.TLit (extractTypeName n))
                     , FunctionInfo
-                        { numArgs = length (flattenType xs)
-                        , arguments = createArgs (flattenType xs)
+                        { numArgs = length xs
+                        , arguments = createArgs (snd <$> xs)
                         }
                     )
                 )
                 cons
             <> go xs
 
--- {- | Produces a map of functions infos from a list of binds,
--- which contains useful data for code generation.
----}
--- getFunctions :: [MIR.Def] -> Map Id FunctionInfo
--- getFunctions bs = Map.fromList $ go bs
---  where
---    go [] = []
---    go (MIR.DBind (MIR.Bind id args _) : xs) =
---        (id, FunctionInfo{numArgs = length args, arguments = args})
---            : go xs
---    go (MIR.DData (MIR.Constructor n cons) : xs) = undefined
---        {-do map
---                ( \(Constructor id xs) ->
---                    ( (id, MIR.TLit n)
---                    , FunctionInfo
---                        { numArgs = length xs
---                        , arguments = createArgs xs
---                        }
---                    )
---                )
---                cons
---            <> go xs-}
+createArgs :: [MIR.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,
  which contains useful data for code generation.
@@ -107,15 +97,16 @@ getConstructors :: [MIR.Def] -> Map MIR.Id ConstructorInfo
 getConstructors bs = Map.fromList $ go bs
   where
     go []                                        = []
-    go (MIR.DData (MIR.Constructor (GA.UIdent n) cons) : xs) =
+    go (MIR.DData (MIR.Data t cons) : xs) =
         do
+            let (GA.Ident n) = extractTypeName t
             fst
                 ( foldl
-                    ( \(acc, i) (GA.UIdent id, xs) ->
+                    ( \(acc, i) (Constructor (GA.UIdent id) xs) ->
                         ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n))
                           , ConstructorInfo
-                                { numArgsCI = length (flattenType xs)
-                                , argumentsCI = createArgs (flattenType xs)
+                                { numArgsCI = length xs
+                                , argumentsCI = createArgs (snd <$> xs)
                                 , numCI = i
                                 }
                           )
@@ -129,53 +120,66 @@ getConstructors bs = Map.fromList $ go bs
             <> go xs
     go (_ : xs)                                  = go xs
 
--- {- | Produces a map of functions infos from a list of binds,
--- which contains useful data for code generation.
----}
--- getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo
--- getConstructors bs = Map.fromList $ go bs
---  where
---    go []                                        = []
---    go (MIR.DData (MIR.Constructor n cons) : xs) = undefined
---        {-do
---            fst
---                ( foldl
---                    ( \(acc, i) (GA.Constructor (GA.Ident id) xs) ->
---                        ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n))
---                          , ConstructorInfo
---                                { numArgsCI = length xs
---                                , argumentsCI = createArgs xs
---                                , numCI = i
---                                }
---                          )
---                            : acc
---                        , i + 1
---                        )
---                    )
---                    ([], 0)
---                    cons
---                )
---            <> go xs-}
---    go (_ : xs)                                  = go xs
+initCodeGenerator :: [MIR.Def] -> CodeGenerator
+initCodeGenerator scs =
+    CodeGenerator
+        { instructions = defaultStart
+        , functions = getFunctions scs
+        , constructors = getConstructors scs
+        , variableCount = 0
+        , labelCount = 0
+        }
 
--- initCodeGenerator :: [MIR.Def] -> CodeGenerator
--- initCodeGenerator scs =
---    CodeGenerator
---        { instructions = defaultStart
---        , functions = getFunctions scs
---        , constructors = getConstructors scs
---        , variableCount = 0
---        , labelCount = 0
---        }
+{-
+run :: Err String -> IO ()
+run s = do
+    let s' = case s of
+            Right s -> s
+            Left _  -> error "yo"
+    writeFile "output/llvm.ll" s'
+    putStrLn . trim =<< readCreateProcess (shell "lli") s'
 
--- {-
--- run :: Err String -> IO ()
--- run s = do
---    let s' = case s of
---            Right s -> s
---            Left _  -> error "yo"
---    writeFile "output/llvm.ll" s'
---    putStrLn . trim =<< readCreateProcess (shell "lli") s'
+test :: Integer -> Program
+test v =
+    Program
+        [ DataType
+            (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")
+            [ 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.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (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)
+                  injectionCatchAll (int 10)
+                ]
+        ]
+  where
+    injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs)
+    injectionInt x = Injection (CLit (LInt x))
+    injectionCatchAll = Injection CatchAll
+    eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int"))
+    int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int"))
+-}
+{- | Compiles an AST and produces a LLVM Ir string.
+  An easy way to actually "compile" this output is to
+  Simply pipe it to LLI
+-}
+generateCode :: MIR.Program -> Err String
+generateCode (MIR.Program scs) = do
+    let codegen = initCodeGenerator scs
+    llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
 
 compileScs :: [MIR.Def] -> CompilerState ()
 compileScs [] = do
@@ -256,61 +260,61 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do
     emit DefineEnd
     modify $ \s -> s{variableCount = 0}
     compileScs xs
-compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do
-    let types = BI.second flattenType <$> ts
-    let biggestVariant = maximum $ sum . map (typeByteSize . type2LlvmType) <$> (snd <$> types)
+compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
+    let (Ident outer_id) = extractTypeName typ
+    let biggestVariant = maximum $ sum <$> (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts
     emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8]
     mapM_
-        ( \(GA.UIdent inner_id, fi) -> do
-            emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
+        ( \(Constructor (GA.UIdent inner_id) fi) -> do
+            emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi))
         )
-        types
+        ts
     compileScs xs
 
--- mainContent :: LLVMValue -> [LLVMIr]
--- mainContent var =
---    [ UnsafeRaw $
---        -- "%2 = alloca %Craig\n" <>
---        -- "    store %Craig %1, ptr %2\n" <>
---        -- "    %3 = bitcast %Craig* %2 to i72*\n" <>
---        -- "    %4 = load i72, ptr %3\n" <>
---        -- "    call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n"
---        "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n"
---    , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
---      -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2")
---      -- , Label (GA.Ident "b_1")
---      -- , UnsafeRaw
---      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
---      -- , Br (GA.Ident "end")
---      -- , Label (GA.Ident "b_2")
---      -- , UnsafeRaw
---      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
---      -- , Br (GA.Ident "end")
---      -- , Label (GA.Ident "end")
---      Ret I64 (VInteger 0)
---    ]
+mainContent :: LLVMValue -> [LLVMIr]
+mainContent var =
+    [ UnsafeRaw $
+        -- "%2 = alloca %Craig\n" <>
+        -- "    store %Craig %1, ptr %2\n" <>
+        -- "    %3 = bitcast %Craig* %2 to i72*\n" <>
+        -- "    %4 = load i72, ptr %3\n" <>
+        -- "    call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n"
+        "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n"
+    , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
+      -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2")
+      -- , Label (GA.Ident "b_1")
+      -- , UnsafeRaw
+      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
+      -- , Br (GA.Ident "end")
+      -- , Label (GA.Ident "b_2")
+      -- , UnsafeRaw
+      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
+      -- , Br (GA.Ident "end")
+      -- , Label (GA.Ident "end")
+      Ret I64 (VInteger 0)
+    ]
 
--- defaultStart :: [LLVMIr]
--- 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"
---    ]
+defaultStart :: [LLVMIr]
+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"
+    ]
 
--- compileExp :: ExpT -> CompilerState ()
--- compileExp (MIR.ELit lit,t)     = emitLit lit
--- compileExp (MIR.EAdd e1 e2,t)   = emitAdd t e1 e2
----- compileExp (ESub t e1 e2)  = emitSub t e1 e2
--- compileExp (MIR.EId name,t)     = emitIdent name
--- compileExp (MIR.EApp e1 e2,t)   = emitApp t e1 e2
----- compileExp (EAbs t ti e)   = emitAbs t ti e
--- compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e)
--- compileExp (MIR.ECase e cs,t)   = emitECased t e (map (t,) cs)
+compileExp :: ExpT -> CompilerState ()
+compileExp (MIR.ELit lit,t)     = emitLit lit
+compileExp (MIR.EAdd e1 e2,t)   = emitAdd t e1 e2
+-- compileExp (ESub t e1 e2)  = emitSub t e1 e2
+compileExp (MIR.EId name,t)     = emitIdent name
+compileExp (MIR.EApp e1 e2,t)   = emitApp t e1 e2
+-- compileExp (EAbs t ti e)   = emitAbs t ti e
+compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e)
+compileExp (MIR.ECase e cs,t)   = 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
+-- go (EMul e1 e2)  = emitMul e1 e2
+-- go (EDiv e1 e2)  = emitDiv e1 e2
+-- go (EMod e1 e2)  = emitMod e1 e2
 
 --- aux functions ---
 emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState ()
@@ -333,89 +337,89 @@ emitECased t e cases = do
         cons <- gets constructors
         let r = fromJust $ Map.lookup (coerce consId, t) cons
 
---        lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
---        lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
+        lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
+        lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
 
---        consVal <- getNewVar
---        emit $ SetVariable consVal (ExtractValue rt vs 0)
+        consVal <- getNewVar
+        emit $ SetVariable consVal (ExtractValue rt vs 0)
 
---        consCheck <- getNewVar
---        emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r))
---        emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos
---        emit $ Label lbl_succPos
+        consCheck <- getNewVar
+        emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r))
+        emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos
+        emit $ Label lbl_succPos
 
---        castPtr <- getNewVar
---        castedPtr <- getNewVar
---        casted <- getNewVar
---        emit $ SetVariable castPtr (Alloca rt)
---        emit $ Store rt vs Ptr castPtr
---        emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr)
---        emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr)
+        castPtr <- getNewVar
+        castedPtr <- getNewVar
+        casted <- getNewVar
+        emit $ SetVariable castPtr (Alloca rt)
+        emit $ Store rt vs Ptr castPtr
+        emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr)
+        emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr)
 
---        val <- exprToValue exp
---        -- enumerateOneM_
---        --     (\i c -> do
---        --         case c of
---        --             CIdent x -> do
---        --                 emit . Comment $ "ident " <> show x
---        --                 emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
---        --                 emit $ Store ty val Ptr stackPtr
---        --             CCons x cs -> error "nested constructor"
---        --             CLit l -> do
---        --                 testVar <- getNewVar
---        --                 emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
---        --                 case l of
---        --                     LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l)
---        --                     LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c)
---        --             CCatch -> emit . Comment $ "Catch all"
---        --         emit . Comment $ "return this " <> toIr val
---        --         emit . Comment . show $ c
---        --         emit . Comment . show $ i
---        --     )
---        --     cs
---        -- emit $ Store ty val Ptr stackPtr
---        emit $ Br label
---        emit $ Label lbl_failPos
---    emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do
---        let i' = case i of
---                GA.LInt i  -> VInteger i
---                GA.LChar i -> VChar i
---        ns <- getNewVar
---        lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
---        lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
---        emit $ SetVariable ns (Icmp LLEq ty vs i')
---        emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos
---        emit $ Label lbl_succPos
---        val <- exprToValue exp
---        emit $ Store ty val Ptr stackPtr
---        emit $ Br label
---        emit $ Label lbl_failPos
-----     emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do
-----         -- //TODO this is pretty disgusting and would heavily benefit from a rewrite
-----         valPtr <- getNewVar
-----         emit $ SetVariable valPtr (Alloca rt)
-----         emit $ Store rt vs Ptr valPtr
-----         emit $ SetVariable id (Load rt Ptr valPtr)
-----         increaseVarCount
-----         val <- exprToValue (fst exp)
-----         emit $ Store ty val Ptr stackPtr
-----         emit $ Br label
---    emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do
---        val <- exprToValue exp
---        emit $ Store ty val Ptr stackPtr
---        emit $ Br label
+        val <- exprToValue exp
+        -- enumerateOneM_
+        --     (\i c -> do
+        --         case c of
+        --             CIdent x -> do
+        --                 emit . Comment $ "ident " <> show x
+        --                 emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
+        --                 emit $ Store ty val Ptr stackPtr
+        --             CCons x cs -> error "nested constructor"
+        --             CLit l -> do
+        --                 testVar <- getNewVar
+        --                 emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
+        --                 case l of
+        --                     LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l)
+        --                     LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c)
+        --             CCatch -> emit . Comment $ "Catch all"
+        --         emit . Comment $ "return this " <> toIr val
+        --         emit . Comment . show $ c
+        --         emit . Comment . show $ i
+        --     )
+        --     cs
+        -- emit $ Store ty val Ptr stackPtr
+        emit $ Br label
+        emit $ Label lbl_failPos
+    emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do
+        let i' = case i of
+                GA.LInt i  -> VInteger i
+                GA.LChar i -> VChar i
+        ns <- getNewVar
+        lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
+        lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
+        emit $ SetVariable ns (Icmp LLEq ty vs i')
+        emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos
+        emit $ Label lbl_succPos
+        val <- exprToValue exp
+        emit $ Store ty val Ptr stackPtr
+        emit $ Br label
+        emit $ Label lbl_failPos
+--     emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do
+--         -- //TODO this is pretty disgusting and would heavily benefit from a rewrite
+--         valPtr <- getNewVar
+--         emit $ SetVariable valPtr (Alloca rt)
+--         emit $ Store rt vs Ptr valPtr
+--         emit $ SetVariable id (Load rt Ptr valPtr)
+--         increaseVarCount
+--         val <- exprToValue (fst exp)
+--         emit $ Store ty val Ptr stackPtr
+--         emit $ Br label
+    emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do
+        val <- exprToValue exp
+        emit $ Store ty val Ptr stackPtr
+        emit $ Br label
 
-----emitLet :: Bind -> Exp -> CompilerState ()
--- emitLet xs e = do
---    emit $
---        Comment $
---            concat
---                [ "ELet ("
---                , show xs
---                , " = "
---                , show e
---                , ") is not implemented!"
---                ]
+--emitLet :: Bind -> Exp -> CompilerState ()
+emitLet xs e = do
+    emit $
+        Comment $
+            concat
+                [ "ELet ("
+                , show xs
+                , " = "
+                , show e
+                , ") is not implemented!"
+                ]
 
 emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
 emitApp t e1 e2 = appEmitter e1 e2 []
@@ -440,60 +444,60 @@ emitApp t e1 e2 = appEmitter e1 e2 []
                 emit $ SetVariable vs call
             x -> error $ "The unspeakable happened: " <> show x
 
--- emitIdent :: GA.Ident -> CompilerState ()
--- emitIdent id = do
---    -- !!this should never happen!!
---    emit $ Comment "This should not have happened!"
---    emit $ Variable id
---    emit $ UnsafeRaw "\n"
+emitIdent :: GA.Ident -> CompilerState ()
+emitIdent id = do
+    -- !!this should never happen!!
+    emit $ Comment "This should not have happened!"
+    emit $ Variable id
+    emit $ UnsafeRaw "\n"
 
--- emitLit :: MIR.Lit -> CompilerState ()
--- emitLit i = do
---    -- !!this should never happen!!
---    let (i', t) = case i of
---            (MIR.LInt i'')  -> (VInteger i'', I64)
---            (MIR.LChar i'') -> (VChar i'', I8)
---    varCount <- getNewVar
---    emit $ Comment "This should not have happened!"
---    emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0))
+emitLit :: MIR.Lit -> CompilerState ()
+emitLit i = do
+    -- !!this should never happen!!
+    let (i', t) = case i of
+            (MIR.LInt i'')  -> (VInteger i'', I64)
+            (MIR.LChar i'') -> (VChar i'', I8)
+    varCount <- getNewVar
+    emit $ Comment "This should not have happened!"
+    emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0))
 
--- emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
--- emitAdd t e1 e2 = do
---    v1 <- exprToValue e1
---    v2 <- exprToValue e2
---    v <- getNewVar
---    emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2)
+emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
+emitAdd t e1 e2 = do
+    v1 <- exprToValue e1
+    v2 <- exprToValue e2
+    v <- getNewVar
+    emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2)
 
--- emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
--- emitSub t e1 e2 = do
---    v1 <- exprToValue e1
---    v2 <- exprToValue e2
---    v <- getNewVar
---    emit $ SetVariable v (Sub (type2LlvmType t) v1 v2)
+emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
+emitSub t e1 e2 = do
+    v1 <- exprToValue e1
+    v2 <- exprToValue e2
+    v <- getNewVar
+    emit $ SetVariable v (Sub (type2LlvmType t) v1 v2)
 
--- exprToValue :: ExpT -> CompilerState LLVMValue
--- exprToValue = \case
---    (MIR.ELit i, t) -> pure $ case i of
---        (MIR.LInt i)  -> VInteger i
---        (MIR.LChar i) -> VChar i
---    (MIR.EId name, t) -> do
---        funcs <- gets functions
---        case Map.lookup (name, t) funcs of
---            Just fi -> do
---                if numArgs fi == 0
---                    then do
---                        vc <- getNewVar
---                        emit $
---                            SetVariable
---                                vc
---                                (Call FastCC (type2LlvmType t) Global name [])
---                        pure $ VIdent vc (type2LlvmType t)
---                    else pure $ VFunction name Global (type2LlvmType t)
---            Nothing -> pure $ VIdent name (type2LlvmType t)
---    e -> do
---        compileExp e
---        v <- getVarCount
---        pure $ VIdent (GA.Ident $ show v) (getType e)
+exprToValue :: ExpT -> CompilerState LLVMValue
+exprToValue = \case
+    (MIR.ELit i, t) -> pure $ case i of
+        (MIR.LInt i)  -> VInteger i
+        (MIR.LChar i) -> VChar i
+    (MIR.EId name, t) -> do
+        funcs <- gets functions
+        case Map.lookup (name, t) funcs of
+            Just fi -> do
+                if numArgs fi == 0
+                    then do
+                        vc <- getNewVar
+                        emit $
+                            SetVariable
+                                vc
+                                (Call FastCC (type2LlvmType t) Global name [])
+                        pure $ VIdent vc (type2LlvmType t)
+                    else pure $ VFunction name Global (type2LlvmType t)
+            Nothing -> pure $ VIdent name (type2LlvmType t)
+    e -> do
+        compileExp e
+        v <- getVarCount
+        pure $ VIdent (GA.Ident $ show v) (getType e)
 
 type2LlvmType :: MIR.Type -> LLVMType
 type2LlvmType (MIR.TLit id@(Ident name)) = case name of
@@ -507,26 +511,32 @@ type2LlvmType (MIR.TFun t xs)           = do
     function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
     function2LLVMType x s           = (type2LlvmType x, s)
 
--- getType :: ExpT -> LLVMType
--- getType (_, t)     = type2LlvmType t
+getType :: ExpT -> LLVMType
+getType (_, t)     = type2LlvmType t
 
--- valueGetType :: LLVMValue -> LLVMType
--- valueGetType (VInteger _)      = I64
--- valueGetType (VChar _)         = I8
--- valueGetType (VIdent _ t)      = t
--- valueGetType (VConstant s)     = Array (fromIntegral $ length s) I8
--- valueGetType (VFunction _ _ t) = t
+extractTypeName :: MIR.Type -> Ident
+extractTypeName (MIR.TLit id) = id
+extractTypeName (MIR.TFun t xs) = let (Ident i) = extractTypeName t
+                                      (Ident is) = extractTypeName xs
+                                      in Ident $ i <> "_$_" <> is
 
--- typeByteSize :: LLVMType -> Integer
--- typeByteSize I1             = 1
--- typeByteSize I8             = 1
--- typeByteSize I32            = 4
--- typeByteSize I64            = 8
--- typeByteSize Ptr            = 8
--- typeByteSize (Ref _)        = 8
--- typeByteSize (Function _ _) = 8
--- typeByteSize (Array n t)    = n * typeByteSize t
--- typeByteSize (CustomType _) = 8
+valueGetType :: LLVMValue -> LLVMType
+valueGetType (VInteger _)      = I64
+valueGetType (VChar _)         = I8
+valueGetType (VIdent _ t)      = t
+valueGetType (VConstant s)     = Array (fromIntegral $ length s) I8
+valueGetType (VFunction _ _ t) = t
 
--- enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m ()
--- enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1
+typeByteSize :: LLVMType -> Integer
+typeByteSize I1             = 1
+typeByteSize I8             = 1
+typeByteSize I32            = 4
+typeByteSize I64            = 8
+typeByteSize Ptr            = 8
+typeByteSize (Ref _)        = 8
+typeByteSize (Function _ _) = 8
+typeByteSize (Array n t)    = n * typeByteSize t
+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/Monomorphizer/Monomorphizer.hs

@@ -2,13 +2,13 @@
 
 module Monomorphizer.Monomorphizer (monomorphize) where
 
-import Data.Coerce (coerce)
-import Grammar.Abs (Constructor (..), Ident (..))
-import Unsafe.Coerce (unsafeCoerce)
+import           Data.Coerce                   (coerce)
+import           Grammar.Abs                   (Constructor (..), Ident (..))
+import           Unsafe.Coerce                 (unsafeCoerce)
 
-import Grammar.Abs qualified as GA
-import Monomorphizer.MonomorphizerIr qualified as M
-import TypeChecker.TypeCheckerIr qualified as T
+import qualified Grammar.Abs                   as GA
+import qualified Monomorphizer.MonomorphizerIr as M
+import qualified TypeChecker.TypeCheckerIr     as T
 
 monomorphize :: T.Program -> M.Program
 monomorphize (T.Program ds) = M.Program $ monoDefs ds
@@ -18,7 +18,7 @@ monoDefs = map monoDef
 
 monoDef :: T.Def -> M.Def
 monoDef (T.DBind bind) = M.DBind $ monoBind bind
-monoDef (T.DData d) = M.DData $ unsafeCoerce d
+monoDef (T.DData d)    = M.DData $ unsafeCoerce d
 
 monoBind :: T.Bind -> M.Bind
 monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t)
@@ -34,19 +34,19 @@ monoExpr = \case
     T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs)
 
 monoAbsType :: GA.Type -> M.Type
-monoAbsType (GA.TLit u) = M.TLit (coerce u)
-monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES"
+monoAbsType (GA.TLit u)     = M.TLit (coerce u)
+monoAbsType (GA.TVar _v)    = error "NOT POLYMORHPIC TYPES"
 monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES"
-monoAbsType (GA.TData _ i) = error "NOT INDEXED TYPES"
-monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS"
+monoAbsType (GA.TEVar _v)   = error "I DONT KNOW WHAT THIS IS"
 monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2)
+monoAbsType (GA.TIndexed _) = error "NOT INDEXED TYPES"
 
 monoType :: T.Type -> M.Type
-monoType (T.TAll _ t) = monoType t
+monoType (T.TAll _ t)          = monoType t
 monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES"
-monoType (T.TLit i) = M.TLit i
-monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2)
-monoType (T.TData _ _) = error "Not sure what this is"
+monoType (T.TLit i)            = M.TLit i
+monoType (T.TFun t1 t2)        = M.TFun (monoType t1) (monoType t2)
+monoType (T.TData _ _)         = error "Not sure what this is"
 
 monoexpt :: T.ExpT -> M.ExpT
 monoexpt (e, t) = (monoExpr e, monoType t)
@@ -55,7 +55,7 @@ monoId :: T.Id -> M.Id
 monoId (n, t) = (n, monoType t)
 
 monoLit :: T.Lit -> M.Lit
-monoLit (T.LInt i) = M.LInt i
+monoLit (T.LInt i)  = M.LInt i
 monoLit (T.LChar c) = M.LChar c
 
 monoInjs :: [T.Inj] -> [M.Injection]

src/Monomorphizer/MonomorphizerIr.hs

@@ -1,8 +1,8 @@
 module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where
 
-import Grammar.Abs (Ident (..), Init (..), UIdent)
-import Grammar.Abs qualified as GA (Ident (..), Init (..))
-import TypeChecker.TypeCheckerIr qualified as RE
+import           Grammar.Abs               (Ident (..), Init (..), UIdent)
+import qualified Grammar.Abs               as GA (Ident (..), Init (..))
+import qualified TypeChecker.TypeCheckerIr as RE
 
 type Id = (Ident, Type)
 
@@ -12,7 +12,7 @@ newtype Program = Program [Def]
 data Def = DBind Bind | DData Data
     deriving (Show, Ord, Eq)
 
-data Data = Data Type Constructor
+data Data = Data Type [Constructor]
     deriving (Show, Ord, Eq)
 
 data Bind = Bind Id [Id] ExpT
@@ -45,4 +45,4 @@ data Type = TLit Ident | TFun Type Type
 
 flattenType :: Type -> [Type]
 flattenType (TFun t1 t2) = t1 : flattenType t2
-flattenType x = [x]
+flattenType x            = [x]