temporary commit incase of breakage

Grammar.cf

@@ -48,6 +48,7 @@ EVar.  Exp3 ::= LIdent;
 EInj.  Exp3 ::= UIdent;
 ELit.  Exp3 ::= Lit;
 EApp.  Exp2 ::= Exp2 Exp3;
+EAppInf.  Exp2 ::= Exp3 "`" Exp3 "`";
 EAdd.  Exp1 ::= Exp1 "+" Exp2;
 ELet.  Exp  ::= "let" Bind "in" Exp; 
 EAbs.  Exp  ::= "\\" LIdent "." Exp;

language.cabal

@@ -44,9 +44,8 @@ executable language
       Codegen.LlvmIr
       Compiler
       Renamer.Renamer
-      --Codegen.Codegen
-      --Codegen.LlvmIr
       TreeConverter
+      Desugar.Desugar
 
     hs-source-dirs:   src
 

src/Desugar/Desugar.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Desugar.Desugar where
+
+import Data.Function (on)
+import Grammar.Abs
+
+desugar :: Program -> Program
+desugar (Program defs) = Program (map desugarDef defs)
+
+desugarDef :: Def -> Def
+desugarDef = \case
+    DBind b -> DBind (desugarBind b)
+    DSig sig -> DSig sig
+    DData d -> DData d
+
+desugarBind :: Bind -> Bind
+desugarBind (Bind name args e) = Bind name args (desugarExp e)
+
+desugarExp :: Exp -> Exp
+desugarExp = \case
+    EAppInf e2 e1 -> (EApp `on` desugarExp) e1 e2
+    EApp e1 e2 -> (EApp `on` desugarExp) e1 e2
+    EAdd e1 e2 -> (EAdd `on` desugarExp) e1 e2
+    EAbs i e -> EAbs i (desugarExp e)
+    ELet b e -> ELet (desugarBind b) (desugarExp e)
+    ECase e br -> ECase (desugarExp e) (map desugarBranch br)
+    EAnn e t -> EAnn (desugarExp e) t
+    e -> e
+
+desugarBranch :: Branch -> Branch
+desugarBranch (Branch p e) = Branch p (desugarExp e)

src/Main.hs

@@ -2,34 +2,44 @@
 
 module Main where
 
-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)
+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 Desugar.Desugar (desugar)
+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'
@@ -76,11 +86,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
     }
 
@@ -92,8 +102,12 @@ main' opts s = do
     parsed <- fromSyntaxErr . pProgram $ myLexer file
     bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug
 
+    printToErr "-- Desugar --"
+    let desugared = desugar parsed
+    bool (printToErr $ printTree desugared) (printToErr $ show desugared) opts.debug
+
     printToErr "\n-- Renamer --"
-    renamed <- fromRenamerErr . rename $ parsed
+    renamed <- fromRenamerErr . rename $ desugared
     bool (printToErr $ printTree renamed) (printToErr $ show renamed) opts.debug
 
     printToErr "\n-- TypeChecker --"

src/TypeChecker/TypeCheckerHm.hs

@@ -21,6 +21,7 @@ import Data.Map qualified as M
 import Data.Maybe (fromJust)
 import Data.Set (Set)
 import Data.Set qualified as S
+import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
 import TypeChecker.TypeCheckerIr qualified as T
@@ -96,7 +97,8 @@ checkBind (Bind name args e) = do
     s <- gets sigs
     case M.lookup (coerce name) s of
         Just (Just t') -> do
-            let fsig = apply sub0 t'
+            sab <- unify t' lambda_t
+            let fsig = apply (sab `compose` sub0) t'
             sub1 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq fsig lambda_t) mempty
             sub2 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq lambda_t fsig) mempty
             unless
@@ -314,6 +316,7 @@ algoW = \case
         (subst, injs, ret_t) <- checkCase t injs
         let comp = subst `compose` sub
         return (comp, apply comp (T.ECase (e', t) injs, ret_t))
+    EAppInf{} -> error "desugar phase failed"
 
 checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type)
 checkCase _ [] = catchableErr "Atleast one case required"
@@ -687,15 +690,42 @@ typeEq (TVar (MkTVar a)) t@(TVar _) = do
     st <- get
     case M.lookup (coerce a) st of
         Nothing -> put $ M.insert (coerce a) t st
-        Just t' -> unless (t == t') (catchableErr "TYPE MISMATCH")
+        Just t' ->
+            unless
+                (t == t')
+                ( catchableErr $ Aux.do
+                    quote $ printTree t
+                    "does not match with"
+                    quote $ printTree t'
+                )
 typeEq (TFun l r) (TFun l' r') = typeEq l l' *> typeEq r r'
 typeEq (TAll _ l) (TAll _ r) = typeEq l r
-typeEq (TLit a) (TLit b) = unless (a == b) (catchableErr "TYPE MISMATCH")
-typeEq (TData nameL tL) (TData nameR tR) = do
-    unless (nameL == nameR) (catchableErr "TYPE MISMATCH")
+typeEq t@(TLit a) t'@(TLit b) =
+    unless
+        (a == b)
+        ( catchableErr $ Aux.do
+            quote $ printTree t
+            "does not match with"
+            quote $ printTree t'
+        )
+typeEq t@(TData nameL tL) t'@(TData nameR tR) = do
+    unless
+        (nameL == nameR)
+        ( catchableErr $ Aux.do
+            quote $ printTree t
+            "does not match with"
+            quote $ printTree t'
+        )
     zipWithM_ typeEq tL tR
-typeEq (TEVar _) (TEVar _) = catchableErr "TYPE MISMATCH"
-typeEq _ _ = catchableErr "TYPE MISMATCH"
+typeEq t@(TEVar _) t'@(TEVar _) =
+    catchableErr $ Aux.do
+        quote $ printTree t
+        "does not match with"
+        quote $ printTree t'
+typeEq t t' = catchableErr $ Aux.do
+    quote $ printTree t
+    "does not match with"
+    quote $ printTree t'
 
 {- | Catch an error if possible and add the given
 expression as addition to the error message

test_program.crf

@@ -1,5 +1,2 @@
-id x = x;
-
+main = const 1 2 ;
 const x y = x ;
-
-main = const (id 0) (id 'a') ;