A lot of small changes, added better error messages for bugs mainly

Justfile

@@ -22,6 +22,12 @@ hm FILE:
 bi FILE:
     cabal run language -- -t bi {{FILE}}
 
+hml FILE:
+    cabal run language -- -l -t hm {{FILE}}
+
+bil FILE:
+    cabal run language -- -l -t bi {{FILE}}
+
 hmd FILE:
     cabal run language -- -d -t hm {{FILE}}
 

language.cabal

@@ -55,6 +55,7 @@ executable language
       Codegen.Emits
       Compiler
       Renamer.Renamer
+      ReportForall
       TreeConverter
       Desugar.Desugar
 

sample-programs/PriorityQueue.crf

@@ -6,13 +6,6 @@ data Maybe a where
     Nothing : Maybe a
     Just : a -> Maybe a
 
-data Pair a b where
-    Pair : a -> b -> Pair a b
-
-data List a where
-    Nil : List a
-    Cons : a -> List a -> List a
-
 empty = Empty
 
 singleton x = Node Empty x Empty
@@ -35,7 +28,3 @@ merge tree1 tree2 = case tree1 of
     Empty => tree2
 
 insert x tree = merge (singleton x) tree
-
-main = case peek (insert 1 (insert 2 (insert 3 (singleton 4)))) of
-    Nothing => (0 - 1)
-    Just x => x

sample-programs/Quicksort.crf

@@ -42,13 +42,3 @@ descList from to = case to < from of
 
 main = let list = (5 :: (2 :: (8 :: (9 :: (6 :: (0 :: (1 :: Nil)))))))
         in printStr (toStr (quicksort list))
-
-{-
-
--- Program output --
-0125689
-In dispose
-Out dispose
-ExitSuccess
-
--}

src/Auxiliary.hs

@@ -53,7 +53,9 @@ liftMM2 f m1 m2 = do
 typeof :: Lit -> Type
 typeof (LInt _)  = int
 typeof (LChar _) = char
+typeof (LString _) = string
 
+string = TLit "String"
 int = TLit "Int"
 char = TLit "Char"
 

src/Codegen/LlvmIr.hs

@@ -161,6 +161,7 @@ typeOf = \case
     Store t _ _ _    -> t
     Type x _         -> CustomType x
     SetVariable _ ir -> typeOf ir
+    x -> error $ "\n -- MARTIN HJÄLP! -- \nType of: '" ++ show x ++ "' not found"
 
 
 

src/Compiler.hs

@@ -28,7 +28,8 @@ compileClang True =
             , "src/GC/lib/event.cpp"
             , "src/GC/lib/heap.cpp"
             , "src/GC/lib/profiler.cpp"
-            , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++"
+            -- , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++"
+            , "-w -g -std=gnu++20 -stdlib=libstdc++"
             , "-O3"
             --, "-tailcallopt"
             , "-Isrc/GC/include"

src/Main.hs

@@ -51,14 +51,15 @@ parseArgs argv = case getOpt RequireOrder flags argv of
         hPutStrLn stderr (concat errs ++ usageInfo header flags)
         exitWith (ExitFailure 1)
   where
-    header = "Usage: language [--help] [-d|--debug] [-m|--disable-gc] [-t|--type-checker bi/hm] [-p|--disable-prelude] <FILE> \n"
+    header = "Usage: language [--help] [-l|--log-intermediate] [-d|--debug] [-m|--disable-gc] [-t|--type-checker bi/hm] [-p|--disable-prelude] <FILE> \n"
 
 flags :: [OptDescr (Options -> Options)]
 flags =
-    [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages."
+    [ Option ['d'] ["debug"] (NoArg $ enableDebug . logIntermediate) "Print debug messages. --debug implies --log-intermediate"
     , Option ['t'] ["type-checker"] (ReqArg chooseTypechecker "bi/hm") "Choose type checker. Possible options are bi and hm"
     , Option ['m'] ["disable-gc"] (NoArg disableGC) "Disables the garbage collector and uses malloc instead."
     , Option ['p'] ["disable-prelude"] (NoArg disablePrelude) "Do not include the prelude"
+    , Option ['l'] ["log-intermediate"] (NoArg logIntermediate) "Log intermediate languages"
     , Option [] ["help"] (NoArg enableHelp) "Print this help message"
     ]
 
@@ -70,6 +71,7 @@ initOpts =
         , gc = True
         , typechecker = Nothing
         , preludeOpt = False
+        , logIL = False
         }
 
 enableHelp :: Options -> Options
@@ -84,6 +86,10 @@ disableGC opts = opts{gc = False}
 disablePrelude :: Options -> Options
 disablePrelude opts = opts{preludeOpt = True}
 
+logIntermediate :: Options -> Options
+logIntermediate opts = opts{logIL = True}
+
+
 chooseTypechecker :: String -> Options -> Options
 chooseTypechecker s options = options{typechecker = tc}
   where
@@ -98,6 +104,7 @@ data Options = Options
     , gc          :: Bool
     , typechecker :: Maybe TypeChecker
     , preludeOpt  :: Bool
+    , logIL       :: Bool
     }
 
 main' :: Options -> String -> IO ()
@@ -109,33 +116,33 @@ main' opts s =
         do
             file <- readFile s
 
-            printToErr "-- Parse Tree -- "
+           
             let file' = if opts.preludeOpt then file else file ++ prelude
             parsed <- fromErr . pProgram . resolveLayout True $ myLexer file'
-            log parsed
+            when opts.logIL (printToErr "-- Parse Tree -- " >> log parsed)
 
-            printToErr "-- Desugar --"
+            
             let desugared = desugar parsed
-            log desugared
+            when opts.logIL (printToErr "-- Desugar --" >> log desugared)
 
-            printToErr "\n-- Renamer --"
+            
             _ <- fromErr $ reportForall (fromJust opts.typechecker) desugared
             renamed <- fromErr $ (rename <=< annotateForall) desugared
-            log renamed
+            when opts.logIL (printToErr "\n-- Renamer --" >> log renamed) 
 
-            printToErr "\n-- TypeChecker --"
+            
             typechecked <- fromErr $ typecheck (fromJust opts.typechecker) (orderDefs renamed)
-            log typechecked
+            when opts.logIL (printToErr "\n-- TypeChecker --" >> log typechecked)
 
-            printToErr "\n-- Lambda Lifter --"
+            
             let lifted = lambdaLift typechecked
-            log lifted
+            when opts.logIL (printToErr "\n-- Lambda Lifter --" >> log lifted)
 
-            printToErr "\n -- Monomorphizer --"
+            
             let monomorphized = monomorphize lifted
-            log monomorphized
+            when opts.logIL (printToErr "\n -- Monomorphizer --" >> log monomorphized)
 
-            printToErr "\n -- Compiler --"
+            
             generatedCode <- fromErr $ generateCode monomorphized (gc opts)
             -- generatedCode <- fromErr $ generateCode monomorphized False
 
@@ -144,6 +151,7 @@ main' opts s =
             createDirectory "output"
             createDirectory "output/logs"
             when opts.debug $ do
+                printToErr "\n -- Compiler --"
                 writeFile "output/llvm.ll" generatedCode
                 debugDotViz
 

src/Monomorphizer/Monomorphizer.hs

@@ -345,7 +345,6 @@ morphPattern p expectedType = case p of
     return $ Just ((M.PEnum newIdent, expectedType), Set.empty)
   L.PInj ident pts -> do let newIdent = newName expectedType ident
                          ts' <- mapM (getMonoFromPoly . snd) pts
-                         trace ("Constructor: " ++ show ident ++ "expected: " ++ show expectedType ++ "\nTS': " ++ show ts' ++ "\n\n\n") pure ()
                          morphCons (convertConsTypeToDataType expectedType (reverse ts')) ident newIdent
                          let pts' = zip (map fst pts) ts'
                          psSets <- mapM (uncurry morphPattern) pts'

src/TypeChecker/TypeCheckerBidir.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE PatternSynonyms     #-}
-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+-- {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
 module TypeChecker.TypeCheckerBidir (typecheck) where
 
@@ -248,6 +248,7 @@ checkPattern PCatch a = apply (T.PCatch, a)
 --  ------------------------- PLit
 --  Γ ⊢ lit ↑ A ⊣ Γ
 checkPattern (PLit lit) a | a == typeof lit = apply (T.PLit lit, a)
+checkPattern (PLit lit) a = error $ "\n -- MARTIN HJÄLP!! --\nUnimplemented match for: '" ++ printTree a ++ "' == '" ++ printTree (typeof lit) ++ "'"
 
 --  Γ ∋ (K : T)  Γ ⊢ A <: B ⊣ Δ
 --  ---------------------------