From 43e0f67fe2dceb87a8669c2d412be9c5e445dd3a Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Sun, 22 Jan 2023 20:16:03 +0100
Subject: [PATCH 01/71] Fix conflict

---
 Grammar.cf           |   2 +-
 src/Grammar/Doc.txt  |  56 ++++++++++++++++
 src/Grammar/Print.hs | 153 +++++++++++++++++++++++++++++++++++++++++++
 src/Interpreter.hs   |   4 +-
 test_program         |   2 +-
 5 files changed, 213 insertions(+), 4 deletions(-)
 create mode 100644 src/Grammar/Doc.txt
 create mode 100644 src/Grammar/Print.hs

diff --git a/Grammar.cf b/Grammar.cf
index b258446..d880ed2 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -6,7 +6,7 @@ EId.  Exp3 ::= Ident   ;
 EInt. Exp3 ::= Integer ;
 EApp. Exp2 ::= Exp2 Exp3 ;
 EAdd. Exp1 ::= Exp1 "+" Exp2 ;
-EAbs. Exp  ::= "\\" Ident "->" Exp ;
+EAbs. Exp  ::= "\\" Ident "." Exp ;
 
 coercions Exp 3 ;
 
diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt
new file mode 100644
index 0000000..18a68c9
--- /dev/null
+++ b/src/Grammar/Doc.txt
@@ -0,0 +1,56 @@
+The Language Grammar
+BNF Converter
+
+
+%Process by txt2tags to generate html or latex
+
+
+
+This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place).
+
+==The lexical structure of Grammar==
+===Identifiers===
+Identifiers //Ident// are unquoted strings beginning with a letter,
+followed by any combination of letters, digits, and the characters ``_ '``
+reserved words excluded.
+
+
+===Literals===
+Integer literals //Integer// are nonempty sequences of digits.
+
+
+
+
+===Reserved words and symbols===
+The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions.
+
+The reserved words used in Grammar are the following:
+  | ``main`` |  |  |
+
+The symbols used in Grammar are the following:
+  | = | + | \ | .
+  | ( | ) |  |
+
+===Comments===
+Single-line comments begin with --.Multiple-line comments are  enclosed with {- and -}.
+
+==The syntactic structure of Grammar==
+Non-terminals are enclosed between < and >.
+The symbols -> (production),  **|**  (union)
+and **eps** (empty rule) belong to the BNF notation.
+All other symbols are terminals.
+
+  | //Program// | -> | ``main`` ``=`` //Exp//
+  | //Exp3// | -> | //Ident//
+  |  |  **|**  | //Integer//
+  |  |  **|**  | ``(`` //Exp// ``)``
+  | //Exp2// | -> | //Exp2// //Exp3//
+  |  |  **|**  | //Exp3//
+  | //Exp1// | -> | //Exp1// ``+`` //Exp2//
+  |  |  **|**  | //Exp2//
+  | //Exp// | -> | ``\`` //Ident// ``.`` //Exp//
+  |  |  **|**  | //Exp1//
+
+
+
+%% File generated by the BNF Converter (bnfc 2.9.4.1).
diff --git a/src/Grammar/Print.hs b/src/Grammar/Print.hs
new file mode 100644
index 0000000..377a3cf
--- /dev/null
+++ b/src/Grammar/Print.hs
@@ -0,0 +1,153 @@
+-- File generated by the BNF Converter (bnfc 2.9.4.1).
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+#if __GLASGOW_HASKELL__ <= 708
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
+-- | Pretty-printer for Grammar.
+
+module Grammar.Print where
+
+import Prelude
+  ( ($), (.)
+  , Bool(..), (==), (<)
+  , Int, Integer, Double, (+), (-), (*)
+  , String, (++)
+  , ShowS, showChar, showString
+  , all, elem, foldr, id, map, null, replicate, shows, span
+  )
+import Data.Char ( Char, isSpace )
+import qualified Grammar.Abs
+
+-- | The top-level printing method.
+
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 False (map ($ "") $ d []) ""
+  where
+  rend
+    :: Int        -- ^ Indentation level.
+    -> Bool       -- ^ Pending indentation to be output before next character?
+    -> [String]
+    -> ShowS
+  rend i p = \case
+      "["      :ts -> char '[' . rend i False ts
+      "("      :ts -> char '(' . rend i False ts
+      "{"      :ts -> onNewLine i     p . showChar   '{'  . new (i+1) ts
+      "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts
+      "}"      :ts -> onNewLine (i-1) p . showChar   '}'  . new (i-1) ts
+      [";"]        -> char ';'
+      ";"      :ts -> char ';' . new i ts
+      t  : ts@(s:_) | closingOrPunctuation s
+                   -> pending . showString t . rend i False ts
+      t        :ts -> pending . space t      . rend i False ts
+      []           -> id
+    where
+    -- Output character after pending indentation.
+    char :: Char -> ShowS
+    char c = pending . showChar c
+
+    -- Output pending indentation.
+    pending :: ShowS
+    pending = if p then indent i else id
+
+  -- Indentation (spaces) for given indentation level.
+  indent :: Int -> ShowS
+  indent i = replicateS (2*i) (showChar ' ')
+
+  -- Continue rendering in new line with new indentation.
+  new :: Int -> [String] -> ShowS
+  new j ts = showChar '\n' . rend j True ts
+
+  -- Make sure we are on a fresh line.
+  onNewLine :: Int -> Bool -> ShowS
+  onNewLine i p = (if p then id else showChar '\n') . indent i
+
+  -- Separate given string from following text by a space (if needed).
+  space :: String -> ShowS
+  space t s =
+    case (all isSpace t', null spc, null rest) of
+      (True , _   , True ) -> []              -- remove trailing space
+      (False, _   , True ) -> t'              -- remove trailing space
+      (False, True, False) -> t' ++ ' ' : s   -- add space if none
+      _                    -> t' ++ s
+    where
+      t'          = showString t []
+      (spc, rest) = span isSpace s
+
+  closingOrPunctuation :: String -> Bool
+  closingOrPunctuation [c] = c `elem` closerOrPunct
+  closingOrPunctuation _   = False
+
+  closerOrPunct :: String
+  closerOrPunct = ")],;"
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- | The printer class does the job.
+
+class Print a where
+  prt :: Int -> a -> Doc
+
+instance {-# OVERLAPPABLE #-} Print a => Print [a] where
+  prt i = concatD . map (prt i)
+
+instance Print Char where
+  prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'')
+
+instance Print String where
+  prt _ = printString
+
+printString :: String -> Doc
+printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q = \case
+  s | s == q -> showChar '\\' . showChar s
+  '\\' -> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  s -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j < i then parenth else id
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+instance Print Grammar.Abs.Ident where
+  prt _ (Grammar.Abs.Ident i) = doc $ showString i
+instance Print Grammar.Abs.Program where
+  prt i = \case
+    Grammar.Abs.Program exp -> prPrec i 0 (concatD [doc (showString "main"), doc (showString "="), prt 0 exp])
+
+instance Print Grammar.Abs.Exp where
+  prt i = \case
+    Grammar.Abs.EId id_ -> prPrec i 3 (concatD [prt 0 id_])
+    Grammar.Abs.EInt n -> prPrec i 3 (concatD [prt 0 n])
+    Grammar.Abs.EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2])
+    Grammar.Abs.EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2])
+    Grammar.Abs.EAbs id_ exp -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 id_, doc (showString "."), prt 0 exp])
diff --git a/src/Interpreter.hs b/src/Interpreter.hs
index bdbd8d2..378c95b 100644
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@@ -39,7 +39,7 @@ eval cxt = \case
 
   EInt i    -> pure $ VInt i
 
-  --  γ     ⊢ e  ⇓ let δ in λx → f
+  --  γ     ⊢ e  ⇓ let δ in λx. f
   --  γ     ⊢ e₁ ⇓ v
   --  δ,x=v ⊢ f  ⇓ v₁
   --  ------------------------------
@@ -54,7 +54,7 @@ eval cxt = \case
 
   --
   --  -----------------------------
-  --  γ ⊢ λx → f ⇓ let γ in λx → f
+  --  γ ⊢ λx. f ⇓ let γ in λx. f
 
   EAbs x e  -> pure $ VClosure cxt x e
 
diff --git a/test_program b/test_program
index 83f3e9a..95235e4 100644
--- a/test_program
+++ b/test_program
@@ -2,4 +2,4 @@
 
 
 
-main = (\x -> x + x + 3) ((\x -> x) 2)
+main = (\x. x + x + 3) ((\x. x) 2)

From b6b2dfa25f40c2416503dfc3518a05b34d8ad878 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 23 Jan 2023 17:17:06 +0100
Subject: [PATCH 02/71] Some work on a typechecker

---
 Grammar.cf         | 18 ++++++++---
 Makefile           |  2 +-
 language.cabal     |  3 +-
 src/Interpreter.hs | 76 +++-------------------------------------------
 src/TypeChecker.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++++
 test_program       |  7 ++---
 6 files changed, 98 insertions(+), 84 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index b258446..fb80ea1 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,15 +1,23 @@
+Program. Program ::= [Def] ;
 
+DExp.  Def ::= Ident ":" Type
+               Ident [Ident] "=" Exp ;
 
-Program. Program ::= "main" "=" Exp ;
+separator Def "";
+separator Ident "";
+separator Type "->";
 
 EId.  Exp3 ::= Ident   ;
 EInt. Exp3 ::= Integer ;
-EApp. Exp2 ::= Exp2 Exp3 ;
+-- EApp. Exp2 ::= Exp2 Exp3 ;
 EAdd. Exp1 ::= Exp1 "+" Exp2 ;
-EAbs. Exp  ::= "\\" Ident "->" Exp ;
-
+-- EAbs. Exp  ::= "\\" Ident ":" Type "." Exp ;
 coercions Exp 3 ;
 
+TInt. Type1 ::= "Int" ;
+TPol. Type1 ::= Ident ;
+TFun. Type  ::= [Type] ;
+coercions Type 1 ;
+
 comment "--" ;
 comment "{-" "-}" ;
-
diff --git a/Makefile b/Makefile
index 16b753d..35736a1 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
 .PHONY : sdist clean
 
 language : src/Grammar/Test
-	cabal install --installdir=.
+	cabal install --installdir=. --overwrite-policy=always
 
 src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf
 	bnfc -o src -d $<
diff --git a/language.cabal b/language.cabal
index fc1c2fe..0f1a53c 100644
--- a/language.cabal
+++ b/language.cabal
@@ -31,11 +31,12 @@ executable language
       Grammar.Print
       Grammar.Skel
       Interpreter
+      TypeChecker
 
     hs-source-dirs:   src
 
     build-depends:    
-        base ^>=4.16.3.0
+        base >= 4.16.3.0
       , mtl
       , containers
       , either
diff --git a/src/Interpreter.hs b/src/Interpreter.hs
index bdbd8d2..dc34d49 100644
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@@ -1,78 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Interpreter where
 
-import           Control.Applicative     (Applicative)
-import           Control.Monad.Except    (Except, MonadError (throwError),
-                                          liftEither)
-import           Data.Either.Combinators (maybeToRight)
-import           Data.Map                (Map)
-import qualified Data.Map                as Map
+import           Control.Monad.Except    (Except, MonadError (throwError))
+
 import           Grammar.Abs
-import           Grammar.Print           (printTree)
 
 interpret :: Program -> Except String Integer
-interpret (Program e) =
-  eval mempty e >>= \case
-    VClosure {} -> throwError "main evaluated to a function"
-    VInt i      -> pure i
-
-
-data Val = VInt Integer
-         | VClosure Cxt Ident Exp
-
-type Cxt = Map Ident Val
-
-eval :: Cxt -> Exp -> Except String Val
-eval cxt = \case
-
-
-  --  ------------ x ∈ γ
-  --  γ ⊢ x ⇓ γ(x)
-
-  EId x     ->
-    maybeToRightM
-      ("Unbound variable:" ++ printTree x)
-      $ Map.lookup x cxt
-
-  --  ---------
-  --  γ ⊢ i ⇓ i
-
-  EInt i    -> pure $ VInt i
-
-  --  γ     ⊢ e  ⇓ let δ in λx → f
-  --  γ     ⊢ e₁ ⇓ v
-  --  δ,x=v ⊢ f  ⇓ v₁
-  --  ------------------------------
-  --  γ ⊢ e e₁ ⇓ v₁
-
-  EApp e e1 ->
-    eval cxt e >>= \case
-      VInt _ -> throwError "Not a function"
-      VClosure delta x f -> do
-        v <- eval cxt e1
-        eval (Map.insert x v delta) f
-
-  --
-  --  -----------------------------
-  --  γ ⊢ λx → f ⇓ let γ in λx → f
-
-  EAbs x e  -> pure $ VClosure cxt x e
-
-
-  --  γ ⊢ e  ⇓ v
-  --  γ ⊢ e₁ ⇓ v₁
-  --  ------------------
-  --  γ ⊢ e e₁ ⇓ v + v₁
-
-  EAdd e e1 -> do
-    v <- eval cxt e
-    v1 <- eval cxt e1
-    case (v, v1) of
-      (VInt i, VInt i1) -> pure $ VInt (i + i1)
-      _                 -> throwError "Can't add a function"
-
-
-
-maybeToRightM :: MonadError l m => l -> Maybe r -> m r
-maybeToRightM err = liftEither . maybeToRight err
-
+interpret (Program _) = throwError "Can not interpret program yet"
diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs
index e69de29..d4bf673 100644
--- a/src/TypeChecker.hs
+++ b/src/TypeChecker.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+
+module TypeChecker where
+
+import Grammar.Abs
+import Grammar.ErrM
+import Data.Kind qualified as T
+import Data.String qualified
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Control.Monad.Reader
+import Control.Monad.Except
+
+newtype Env = Env { signature :: Map Ident CType  }
+
+type Check a = ReaderT Env Err a
+
+initEnv :: Env
+initEnv = Env { signature = mempty }
+
+run :: Check a -> Either String a
+run = flip runReaderT initEnv
+
+checkProg :: Program -> Check Program
+checkProg (Program ds) = Program <$> mapM checkDef ds
+    
+checkDef :: Def -> Check Def
+checkDef = \case
+    (DExp n1 TInt n2 params e) -> undefined
+    (DExp n1 (TPol (Ident t)) n2 params e) -> undefined
+    (DExp n1 ts n2 params e) -> undefined
+
+class Typecheck a where
+    checkExp :: Exp -> Check (CExp a)
+
+instance Typecheck Int where
+    checkExp = \case
+        EInt i -> pure $ CInt (fromIntegral i)
+        EAdd e1 e2 -> do
+            e1' <- checkExp @Int e1
+            e2' <- checkExp @Int e2
+            return $ CAdd e1' e2'
+        EId (Ident i) -> asks (lookupSig (Ident i)) >>= liftEither >>= \case
+            TCInt -> pure (CId (CIdent i))
+            _     -> throwError $ "Unbound variable " <> show i
+
+data CExp :: T.Type -> T.Type where
+    CId :: CIdent -> CExp a
+    CInt :: Int -> CExp Int
+    CAdd :: Num a => CExp a -> CExp a -> CExp a
+
+instance Show (CExp a) where
+    show = \case
+        CId (CIdent a) -> show a
+        CInt i -> show i
+        CAdd e1 e2 -> show e1 <> " + " <> show e2
+
+data CDef a = CDef CIdent CType CIdent [CIdent] (CExp a)
+    deriving Show
+
+newtype CProgram = CProgram [Def]
+
+data CType = TCInt | TCPol Ident | TCFun Type Type
+  deriving (Eq, Ord, Show, Read)
+
+newtype CIdent = CIdent String
+  deriving (Eq, Ord, Show, Read, Data.String.IsString)
+
+lookupSig :: Ident -> Env -> Err CType
+lookupSig i (Env m) = case Map.lookup i m of
+                  Nothing -> throwError $ "Unbound variable: " <> show i
+                  Just x -> pure x
+
+
diff --git a/test_program b/test_program
index 83f3e9a..77bf0ad 100644
--- a/test_program
+++ b/test_program
@@ -1,5 +1,2 @@
-
-
-
-
-main = (\x -> x + x + 3) ((\x -> x) 2)
+main : Int
+main = (\x : Int. x + x + 3) ((\x : Int. x) 2)

From be3fcfc9e3c2394e5d6517cbeabbd19b38088420 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 24 Jan 2023 16:39:22 +0100
Subject: [PATCH 03/71] Typeinference/checking on expressions done.

Simplified the typechecker a bit, removed GADT solution for now.
Still not fully working
---
 Grammar.cf         |   4 +-
 language.cabal     |   4 +-
 src/Main.hs        |  30 +++++----
 src/NewAbs.hs      |  29 +++++++++
 src/TypeChecker.hs | 149 ++++++++++++++++++++++++++++++---------------
 5 files changed, 153 insertions(+), 63 deletions(-)
 create mode 100644 src/NewAbs.hs

diff --git a/Grammar.cf b/Grammar.cf
index fb80ea1..e072d5e 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -9,9 +9,9 @@ separator Type "->";
 
 EId.  Exp3 ::= Ident   ;
 EInt. Exp3 ::= Integer ;
--- EApp. Exp2 ::= Exp2 Exp3 ;
+EApp. Exp2 ::= Exp2 Exp3 ;
 EAdd. Exp1 ::= Exp1 "+" Exp2 ;
--- EAbs. Exp  ::= "\\" Ident ":" Type "." Exp ;
+EAbs. Exp  ::= "\\" Ident ":" Type "." Exp ;
 coercions Exp 3 ;
 
 TInt. Type1 ::= "Int" ;
diff --git a/language.cabal b/language.cabal
index 0f1a53c..bb35f1f 100644
--- a/language.cabal
+++ b/language.cabal
@@ -17,7 +17,7 @@ extra-source-fiels:
 
 
 common warnings
-    ghc-options: -Wall
+    ghc-options: -W
 
 executable language
     import:           warnings
@@ -30,8 +30,10 @@ executable language
       Grammar.Par
       Grammar.Print
       Grammar.Skel
+      Grammar.ErrM
       Interpreter
       TypeChecker
+      NewAbs
 
     hs-source-dirs:   src
 
diff --git a/src/Main.hs b/src/Main.hs
index ed753f2..ab2bd24 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,6 +4,7 @@ module Main where
 import           Control.Monad.Except (runExcept)
 import           Grammar.Par          (myLexer, pProgram)
 import           Interpreter          (interpret)
+import           TypeChecker          (typecheck)
 import           System.Environment   (getArgs)
 import           System.Exit          (exitFailure, exitSuccess)
 
@@ -13,18 +14,23 @@ main = getArgs >>= \case
   (x:_) -> do
     file <- readFile x
     case pProgram (myLexer file) of
-      Left err -> do
-       putStrLn "SYNTAX ERROR"
-       putStrLn err
-       exitFailure
-      Right prg -> case runExcept $ interpret prg of
-        Left err -> do
-          putStrLn "INTERPRETER ERROR"
-          putStrLn err
-          exitFailure
-        Right i -> do
-          print i
-          exitSuccess
+       Left err -> do
+           putStrLn "SYNTAX ERROR"
+           putStrLn err
+           exitFailure
+       Right p -> case typecheck p of
+          Left err -> do
+              putStrLn "TYPECHECKING ERROR"
+              putStrLn err
+              exitFailure
+          Right prg -> case runExcept $ interpret prg of
+                Left err -> do
+                  putStrLn "INTERPRETER ERROR"
+                  putStrLn err
+                  exitFailure
+                Right i -> do
+                  print i
+                  exitSuccess
 
 
 
diff --git a/src/NewAbs.hs b/src/NewAbs.hs
new file mode 100644
index 0000000..9a0296d
--- /dev/null
+++ b/src/NewAbs.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE GADTs, LambdaCase #-}
+
+module NewAbs where
+
+import Grammar.Abs ( Ident(..), Type )
+
+data CExp where
+    CId  :: Type -> Ident -> CExp
+    CInt :: Type -> Int -> CExp
+    CAdd :: Type -> CExp -> CExp -> CExp
+    CAbs :: Type -> Ident -> Type -> CExp -> CExp
+    CApp :: Type -> CExp -> CExp -> CExp 
+
+instance Show CExp where
+    show :: CExp -> String
+    show = \case
+        CId _ (Ident a) -> show a
+        CInt _ i -> show i
+        CAdd _ e1 e2 -> show e1 <> " + " <> show e2
+        CAbs t1 i t2 e -> appendType t1 $ show "\\" <> show i <> " : " <> show t2 <> ". " <> show e
+        CApp _ e1 e2 -> show e1 <> " " <> show e2
+
+appendType :: Type -> String -> String
+appendType t s = s <> " : " <> show t
+
+data CDef = CDef Ident Type Ident [Ident] CExp
+    deriving Show
+
+newtype CProgram = CProgram [CDef]
diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs
index d4bf673..8e233bb 100644
--- a/src/TypeChecker.hs
+++ b/src/TypeChecker.hs
@@ -1,76 +1,129 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 
-module TypeChecker where
+module TypeChecker (typecheck) where
 
 import Grammar.Abs
-import Grammar.ErrM
-import Data.Kind qualified as T
-import Data.String qualified
+import Grammar.ErrM ( Err )
+import NewAbs
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Control.Monad.Reader
 import Control.Monad.Except
+import Data.List (isPrefixOf)
+import Control.Applicative ((<|>))
 
-newtype Env = Env { signature :: Map Ident CType  }
+type Check a = ReaderT Context Err a
 
-type Check a = ReaderT Env Err a
+data Context = Ctx { sig :: Map Ident Type
+                   , env :: [Map Ident Type]
+                   }
 
-initEnv :: Env
-initEnv = Env { signature = mempty }
+initEnv :: Context
+initEnv = Ctx { sig = mempty
+              , env = mempty
+              }
 
 run :: Check a -> Either String a
 run = flip runReaderT initEnv
 
-checkProg :: Program -> Check Program
-checkProg (Program ds) = Program <$> mapM checkDef ds
+typecheck :: Program -> Err Program
+typecheck prg = case run $ checkProg prg of
+                  Left err -> fail err
+                  Right _ -> pure prg
+
+
+checkProg :: Program -> Check CProgram
+checkProg (Program ds) = undefined
     
-checkDef :: Def -> Check Def
-checkDef = \case
-    (DExp n1 TInt n2 params e) -> undefined
-    (DExp n1 (TPol (Ident t)) n2 params e) -> undefined
-    (DExp n1 ts n2 params e) -> undefined
+checkDef :: Def -> Check CDef
+checkDef (DExp i1 TInt i2 args e) = undefined
+checkDef (DExp i1 (TPol i) i2 args e) = undefined
+checkDef (DExp i1 (TFun xs) i2 args e) = do
+        when (i1 /= i2) (fail $ "Mismatched names: " <> show i1 <> " != " <> show i2)
+        case compare (length xs - 1) (length args) of
+          LT -> fail $ "Too many arguments, got " <> show (length args) <> " expected " <> show (length xs)
+          _ -> do
+              let vars = Map.fromList $ zip args xs
+              e' <- local (\r -> r { env =  [vars] }) (checkExp e)
+              return $ CDef i1 (TFun xs) i2 args e'
 
-class Typecheck a where
-    checkExp :: Exp -> Check (CExp a)
+checkExp :: Exp -> Check CExp
+checkExp = \case
 
-instance Typecheck Int where
-    checkExp = \case
-        EInt i -> pure $ CInt (fromIntegral i)
-        EAdd e1 e2 -> do
-            e1' <- checkExp @Int e1
-            e2' <- checkExp @Int e2
-            return $ CAdd e1' e2'
-        EId (Ident i) -> asks (lookupSig (Ident i)) >>= liftEither >>= \case
-            TCInt -> pure (CId (CIdent i))
-            _     -> throwError $ "Unbound variable " <> show i
+    EInt i -> pure $ CInt TInt (fromIntegral i)
 
-data CExp :: T.Type -> T.Type where
-    CId :: CIdent -> CExp a
-    CInt :: Int -> CExp Int
-    CAdd :: Num a => CExp a -> CExp a -> CExp a
+    EAdd e1 e2 -> do
+        e1' <- checkExp e1
+        e2' <- checkExp e2
+        let t1 = getType e1'
+        let t2 = getType e2'
+        when (t1 /= t2) (fail $ "Different types occured, got " <> show t1 <> " and " <> show t2)
+        return $ CAdd t1 e1' e2'
 
-instance Show (CExp a) where
-    show = \case
-        CId (CIdent a) -> show a
-        CInt i -> show i
-        CAdd e1 e2 -> show e1 <> " + " <> show e2
+    EId i -> do
+        asks (lookupEnv i) >>= \case
+            Right t -> return $ CId t i
+            Left _ -> asks (lookupSig i) >>= \case
+                Right t -> return $ CId t i
+                Left x -> fail x
 
-data CDef a = CDef CIdent CType CIdent [CIdent] (CExp a)
-    deriving Show
+    EAbs i t e -> do
+        e' <- local (\r -> r { env = Map.singleton i t : r.env }) (checkExp e)
+        return $ CAbs (TFun [t, getType e']) i t e'
 
-newtype CProgram = CProgram [Def]
+    EApp e1 e2 -> do
+        e1' <- checkExp e1
+        e2' <- checkExp e2
+        let retT = applyType (getType e1') (getType e2')
+        case retT of
+          Left x -> fail x
+          Right t -> return $ CApp t e1' e2'
 
-data CType = TCInt | TCPol Ident | TCFun Type Type
-  deriving (Eq, Ord, Show, Read)
+lookupSig :: Ident -> Context -> Err Type
+lookupSig i (Ctx s _) = case Map.lookup i s of
+                  Nothing -> throwError $ "Undefined function: " <> show i
+                  Just x -> pure x
 
-newtype CIdent = CIdent String
-  deriving (Eq, Ord, Show, Read, Data.String.IsString)
-
-lookupSig :: Ident -> Env -> Err CType
-lookupSig i (Env m) = case Map.lookup i m of
-                  Nothing -> throwError $ "Unbound variable: " <> show i
+lookupEnv :: Ident -> Context -> Err Type
+lookupEnv i (Ctx _ []) = throwError $ "Unbound variable: " <> show i
+lookupEnv i (Ctx s (e:es)) = case Map.lookup i e of
+                  Nothing -> lookupEnv i (Ctx s es)
                   Just x -> pure x
 
 
+applyType :: Type -> Type -> Err Type
+applyType (TFun (x:xs)) t = case t of
+    (TFun ys) -> if ys `isPrefixOf` (x:xs)
+                         then return . TFun $ drop (length ys) (x:xs)
+                         else fail $ "Mismatched types, expected " <> show x <> " got " <> show TInt
+applyType t1 t2 = fail $ "Can not apply " <> show t1 <> " to " <> show t2
+
+class ExtractType a where
+    getType :: a -> Type
+
+instance ExtractType CExp where
+    getType = \case
+        CId t _ -> t
+        CInt t _ -> t
+        CAdd t _ _ -> t
+        CAbs t _ _ _ -> t
+        CApp t _ _ -> t
+
+-- | λx : Int. x + 3 + 5
+customLambda1 :: Exp
+customLambda1 = EAbs (Ident "x") TInt (EAdd (EId (Ident "x")) (EAdd (EInt 3) (EInt 5)))
+
+customLambda2 :: Exp
+customLambda2 = EAbs (Ident "x") (TFun [TInt, TInt]) (EId (Ident "f"))
+
+-- | main : Int 
+--   main = λx : Int. x + 3 + 5
+customPrg1 :: Program
+customPrg1 = Program [DExp (Ident "main") TInt (Ident "main") [] customLambda1]
+
+-- | main : Int -> Int
+--   main = λx : Int. x + 3 + 5
+customPrg2 :: Program
+customPrg2 = Program [DExp (Ident "main") (TFun [TInt, TInt]) (Ident "main") [] customLambda2]

From 6607173b9353c8458967c097ea5bf4053ef5ba05 Mon Sep 17 00:00:00 2001
From: Patrik Jansson <patrik.ja@gmail.com>
Date: Fri, 3 Feb 2023 11:12:44 +0100
Subject: [PATCH 04/71] Typo fix (to check access).

---
 .gitignore     | 1 +
 language.cabal | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/.gitignore b/.gitignore
index 5aa7a08..5112877 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,3 +3,4 @@ dist-newstyle
 *.x
 *.bak
 src/Grammar
+/language
diff --git a/language.cabal b/language.cabal
index fc1c2fe..aac5d02 100644
--- a/language.cabal
+++ b/language.cabal
@@ -12,7 +12,7 @@ build-type:         Simple
 
 extra-doc-files:    CHANGELOG.md
 
-extra-source-fiels:
+extra-source-files:
   Grammar.cf
 
 

From 84eb430c41c8abd8a14e7d25197c600ee1b4ec37 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 3 Feb 2023 11:29:42 +0100
Subject: [PATCH 05/71] relaxed base dependency and added overwrite

---
 language.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/language.cabal b/language.cabal
index aac5d02..5734655 100644
--- a/language.cabal
+++ b/language.cabal
@@ -35,7 +35,7 @@ executable language
     hs-source-dirs:   src
 
     build-depends:    
-        base ^>=4.16.3.0
+        base >=4.16
       , mtl
       , containers
       , either

From b6693815726c08192d4a80761bfe8c1f0f4e3785 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 05:18:49 +0100
Subject: [PATCH 06/71] Remove files from git

---
 src/Grammar/Doc.txt  |  56 ----------------
 src/Grammar/Print.hs | 153 -------------------------------------------
 2 files changed, 209 deletions(-)
 delete mode 100644 src/Grammar/Doc.txt
 delete mode 100644 src/Grammar/Print.hs

diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt
deleted file mode 100644
index 18a68c9..0000000
--- a/src/Grammar/Doc.txt
+++ /dev/null
@@ -1,56 +0,0 @@
-The Language Grammar
-BNF Converter
-
-
-%Process by txt2tags to generate html or latex
-
-
-
-This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place).
-
-==The lexical structure of Grammar==
-===Identifiers===
-Identifiers //Ident// are unquoted strings beginning with a letter,
-followed by any combination of letters, digits, and the characters ``_ '``
-reserved words excluded.
-
-
-===Literals===
-Integer literals //Integer// are nonempty sequences of digits.
-
-
-
-
-===Reserved words and symbols===
-The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions.
-
-The reserved words used in Grammar are the following:
-  | ``main`` |  |  |
-
-The symbols used in Grammar are the following:
-  | = | + | \ | .
-  | ( | ) |  |
-
-===Comments===
-Single-line comments begin with --.Multiple-line comments are  enclosed with {- and -}.
-
-==The syntactic structure of Grammar==
-Non-terminals are enclosed between < and >.
-The symbols -> (production),  **|**  (union)
-and **eps** (empty rule) belong to the BNF notation.
-All other symbols are terminals.
-
-  | //Program// | -> | ``main`` ``=`` //Exp//
-  | //Exp3// | -> | //Ident//
-  |  |  **|**  | //Integer//
-  |  |  **|**  | ``(`` //Exp// ``)``
-  | //Exp2// | -> | //Exp2// //Exp3//
-  |  |  **|**  | //Exp3//
-  | //Exp1// | -> | //Exp1// ``+`` //Exp2//
-  |  |  **|**  | //Exp2//
-  | //Exp// | -> | ``\`` //Ident// ``.`` //Exp//
-  |  |  **|**  | //Exp1//
-
-
-
-%% File generated by the BNF Converter (bnfc 2.9.4.1).
diff --git a/src/Grammar/Print.hs b/src/Grammar/Print.hs
deleted file mode 100644
index 377a3cf..0000000
--- a/src/Grammar/Print.hs
+++ /dev/null
@@ -1,153 +0,0 @@
--- File generated by the BNF Converter (bnfc 2.9.4.1).
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-#if __GLASGOW_HASKELL__ <= 708
-{-# LANGUAGE OverlappingInstances #-}
-#endif
-
--- | Pretty-printer for Grammar.
-
-module Grammar.Print where
-
-import Prelude
-  ( ($), (.)
-  , Bool(..), (==), (<)
-  , Int, Integer, Double, (+), (-), (*)
-  , String, (++)
-  , ShowS, showChar, showString
-  , all, elem, foldr, id, map, null, replicate, shows, span
-  )
-import Data.Char ( Char, isSpace )
-import qualified Grammar.Abs
-
--- | The top-level printing method.
-
-printTree :: Print a => a -> String
-printTree = render . prt 0
-
-type Doc = [ShowS] -> [ShowS]
-
-doc :: ShowS -> Doc
-doc = (:)
-
-render :: Doc -> String
-render d = rend 0 False (map ($ "") $ d []) ""
-  where
-  rend
-    :: Int        -- ^ Indentation level.
-    -> Bool       -- ^ Pending indentation to be output before next character?
-    -> [String]
-    -> ShowS
-  rend i p = \case
-      "["      :ts -> char '[' . rend i False ts
-      "("      :ts -> char '(' . rend i False ts
-      "{"      :ts -> onNewLine i     p . showChar   '{'  . new (i+1) ts
-      "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts
-      "}"      :ts -> onNewLine (i-1) p . showChar   '}'  . new (i-1) ts
-      [";"]        -> char ';'
-      ";"      :ts -> char ';' . new i ts
-      t  : ts@(s:_) | closingOrPunctuation s
-                   -> pending . showString t . rend i False ts
-      t        :ts -> pending . space t      . rend i False ts
-      []           -> id
-    where
-    -- Output character after pending indentation.
-    char :: Char -> ShowS
-    char c = pending . showChar c
-
-    -- Output pending indentation.
-    pending :: ShowS
-    pending = if p then indent i else id
-
-  -- Indentation (spaces) for given indentation level.
-  indent :: Int -> ShowS
-  indent i = replicateS (2*i) (showChar ' ')
-
-  -- Continue rendering in new line with new indentation.
-  new :: Int -> [String] -> ShowS
-  new j ts = showChar '\n' . rend j True ts
-
-  -- Make sure we are on a fresh line.
-  onNewLine :: Int -> Bool -> ShowS
-  onNewLine i p = (if p then id else showChar '\n') . indent i
-
-  -- Separate given string from following text by a space (if needed).
-  space :: String -> ShowS
-  space t s =
-    case (all isSpace t', null spc, null rest) of
-      (True , _   , True ) -> []              -- remove trailing space
-      (False, _   , True ) -> t'              -- remove trailing space
-      (False, True, False) -> t' ++ ' ' : s   -- add space if none
-      _                    -> t' ++ s
-    where
-      t'          = showString t []
-      (spc, rest) = span isSpace s
-
-  closingOrPunctuation :: String -> Bool
-  closingOrPunctuation [c] = c `elem` closerOrPunct
-  closingOrPunctuation _   = False
-
-  closerOrPunct :: String
-  closerOrPunct = ")],;"
-
-parenth :: Doc -> Doc
-parenth ss = doc (showChar '(') . ss . doc (showChar ')')
-
-concatS :: [ShowS] -> ShowS
-concatS = foldr (.) id
-
-concatD :: [Doc] -> Doc
-concatD = foldr (.) id
-
-replicateS :: Int -> ShowS -> ShowS
-replicateS n f = concatS (replicate n f)
-
--- | The printer class does the job.
-
-class Print a where
-  prt :: Int -> a -> Doc
-
-instance {-# OVERLAPPABLE #-} Print a => Print [a] where
-  prt i = concatD . map (prt i)
-
-instance Print Char where
-  prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'')
-
-instance Print String where
-  prt _ = printString
-
-printString :: String -> Doc
-printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
-
-mkEsc :: Char -> Char -> ShowS
-mkEsc q = \case
-  s | s == q -> showChar '\\' . showChar s
-  '\\' -> showString "\\\\"
-  '\n' -> showString "\\n"
-  '\t' -> showString "\\t"
-  s -> showChar s
-
-prPrec :: Int -> Int -> Doc -> Doc
-prPrec i j = if j < i then parenth else id
-
-instance Print Integer where
-  prt _ x = doc (shows x)
-
-instance Print Double where
-  prt _ x = doc (shows x)
-
-instance Print Grammar.Abs.Ident where
-  prt _ (Grammar.Abs.Ident i) = doc $ showString i
-instance Print Grammar.Abs.Program where
-  prt i = \case
-    Grammar.Abs.Program exp -> prPrec i 0 (concatD [doc (showString "main"), doc (showString "="), prt 0 exp])
-
-instance Print Grammar.Abs.Exp where
-  prt i = \case
-    Grammar.Abs.EId id_ -> prPrec i 3 (concatD [prt 0 id_])
-    Grammar.Abs.EInt n -> prPrec i 3 (concatD [prt 0 n])
-    Grammar.Abs.EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2])
-    Grammar.Abs.EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2])
-    Grammar.Abs.EAbs id_ exp -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 id_, doc (showString "."), prt 0 exp])

From 1f47288fcffde023ee23d84aa188762246a57771 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 05:19:51 +0100
Subject: [PATCH 07/71] Implement lambda lifting passes: freeVars, abstract,
 and rename

---
 Grammar.cf          |  28 ++++---
 language.cabal      |   4 +-
 src/LambdaLifter.hs | 173 ++++++++++++++++++++++++++++++++++++++++++++
 src/Main.hs         |  29 ++++----
 4 files changed, 211 insertions(+), 23 deletions(-)
 create mode 100644 src/LambdaLifter.hs

diff --git a/Grammar.cf b/Grammar.cf
index d880ed2..9dba2f5 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,15 +1,25 @@
 
 
-Program. Program ::= "main" "=" Exp ;
+Program. Program ::= [ScDef];
 
-EId.  Exp3 ::= Ident   ;
-EInt. Exp3 ::= Integer ;
-EApp. Exp2 ::= Exp2 Exp3 ;
-EAdd. Exp1 ::= Exp1 "+" Exp2 ;
-EAbs. Exp  ::= "\\" Ident "." Exp ;
+ScDef. ScDef ::= Bind; 
+separator ScDef ";";
 
-coercions Exp 3 ;
+separator Ident " ";
 
-comment "--" ;
-comment "{-" "-}" ;
+
+EId.  Exp3 ::= Ident;
+EInt. Exp3 ::= Integer;
+ELet. Exp3 ::= "let" [Bind] "in" Exp; 
+EApp. Exp2 ::= Exp2 Exp3;
+EAdd. Exp1 ::= Exp1 "+" Exp2;
+EAbs. Exp  ::= "\\" Ident "." Exp;
+
+Bind. Bind ::= Ident [Ident] "=" Exp;
+separator Bind ";";
+
+coercions Exp 3;
+
+comment "--";
+comment "{-" "-}";
 
diff --git a/language.cabal b/language.cabal
index 5734655..3f4860c 100644
--- a/language.cabal
+++ b/language.cabal
@@ -30,7 +30,8 @@ executable language
       Grammar.Par
       Grammar.Print
       Grammar.Skel
-      Interpreter
+      LambdaLifter
+      -- Interpreter
 
     hs-source-dirs:   src
 
@@ -40,5 +41,6 @@ executable language
       , containers
       , either
       , array
+      , extra
 
     default-language: GHC2021
diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
new file mode 100644
index 0000000..6e1463d
--- /dev/null
+++ b/src/LambdaLifter.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms   #-}
+
+
+module LambdaLifter (lambdaLift, freeVars, abstract) where
+
+import           Data.List        (mapAccumL)
+import           Data.Map         (Map)
+import qualified Data.Map         as Map
+import           Data.Maybe       (fromJust)
+import           Data.Set         (Set, (\\))
+import qualified Data.Set         as Set
+import           Data.Tuple.Extra (uncurry3)
+import           Grammar.Abs
+import           Prelude          hiding (exp)
+
+pattern Sc :: Ident -> [Ident] -> Exp -> ScDef
+pattern Sc n xs e = ScDef (Bind n xs e)
+
+
+
+lambdaLift :: Program -> Program
+lambdaLift = rename . abstract . freeVars
+
+
+-- Annotate free variables
+
+freeVars :: Program -> AnnProgram
+freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
+                        | Sc n xs e <- ds
+                        ]
+
+
+freeVarsExp :: Set Ident -> Exp -> AnnExp
+freeVarsExp lv = \case
+
+  EId n | Set.member n lv -> (Set.singleton n, AId n)
+        | otherwise       -> (mempty, AId n)
+
+  EInt i     -> (mempty, AInt i)
+
+  EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2')
+    where e1' = freeVarsExp lv e1
+          e2' = freeVarsExp lv e2
+
+  EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2')
+    where e1' = freeVarsExp lv e1
+          e2' = freeVarsExp lv e2
+
+  EAbs n  e  -> (Set.delete n $ freeVarsOf e', AAbs n e')
+    where e'  = freeVarsExp (Set.insert n lv) e
+
+  ELet bs e  -> (Set.union bsFree eFree, ALet bs' e')
+    where
+      bsFree       = freeInValues \\ nsSet
+      eFree        = freeVarsOf e' \\ nsSet
+      bs'          = zipWith3 ABind ns xs es'
+      e'           = freeVarsExp e_lv e
+      (ns, xs, es) = fromBinders bs
+      nsSet        = Set.fromList ns
+      e_lv         = Set.union lv nsSet
+      es'          = map (freeVarsExp e_lv) es
+      freeInValues = foldr1 Set.union (map freeVarsOf es')
+
+
+
+freeVarsOf :: AnnExp -> Set Ident
+freeVarsOf = fst
+
+fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp])
+fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
+
+-- Lift lambda expression into let with binder "sc"
+
+abstract :: AnnProgram -> Program
+abstract p = Program
+  [ Sc sc_name xs $ abstractExp rhs
+  | (sc_name, xs, rhs) <- p
+  ]
+
+
+abstractExp :: AnnExp -> Exp
+abstractExp (free, exp) = case exp of
+  AId  n     -> EId n
+  AInt i     -> EInt i
+  AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2)
+  AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2)
+  ALet bs e  -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e
+  AAbs n  e  -> foldl EApp sc (map EId fvList)
+    where
+      fvList = Set.toList free
+      bind = Bind "sc" [] e'
+      e' = foldr EAbs (abstractExp e) (fvList ++ [n])
+      sc = ELet [bind] (EId (Ident "sc"))
+
+-- rename pass
+
+rename :: Program -> Program
+rename (Program ds) = Program $ map (uncurry3 Sc) tuples
+  where
+    tuples = snd (mapAccumL renameSc 0 ds)
+    renameSc i (Sc n xs e) = (i2, (n, xs', e'))
+      where
+        (i1, xs', env) = newNames i xs
+        (i2, e')       = renameExp env i1 e
+
+renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp)
+renameExp env i = \case
+
+
+  EId  n     -> (i, maybe (error "no") EId $ Map.lookup n env)
+
+
+  EInt i1    -> (i, EInt i1)
+
+  EApp e1 e2 -> (i2, EApp e1' e2')
+    where
+      (i1, e1') = renameExp env i e1
+      (i2, e2') = renameExp env i1 e2
+
+  EAdd e1 e2 -> (i2, EAdd e1' e2')
+    where
+      (i1, e1') = renameExp env i e1
+      (i2, e2') = renameExp env i1 e2
+
+  ELet bs e  -> (i3, ELet (zipWith3 Bind ns' xs es') e')
+    where
+      (i1, e')        = renameExp e_env i e
+      (ns, xs, es)    = fromBinders bs
+      (i2, ns', env') = newNames i1 ns
+      e_env           = Map.union env' env
+      (i3, es')       = mapAccumL (renameExp e_env) i2 es
+
+
+  EAbs n  e  -> (i2, EAbs (head ns) e')
+    where
+      (i1, ns, env') = newNames i [n]
+      (i2, e')       = renameExp (Map.union env' env ) i1 e
+
+
+newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident)
+newNames i old_names = (i', new_names, env)
+  where
+    (i', new_names) = getNames i old_names
+    env = Map.fromList $ zip old_names new_names
+
+
+getName :: Int -> Ident -> (Int, Ident)
+getName i (Ident s) = (i + 1, makeName s i)
+
+getNames :: Int -> [Ident] -> (Int, [Ident])
+getNames i ns = (i + length ss, zipWith makeName ss [i..])
+  where
+    ss = map (\(Ident s) -> s) ns
+
+makeName :: String -> Int -> Ident
+makeName prefix i = Ident (prefix ++ "_" ++ show i)
+
+-- Annotated AST
+
+type AnnProgram = [(Ident, [Ident], AnnExp)]
+type AnnExp = (Set Ident, AnnExp')
+
+data ABind = ABind Ident [Ident] AnnExp deriving Show
+
+data AnnExp' = AId Ident
+             | AInt Integer
+             | AApp AnnExp  AnnExp
+             | AAdd AnnExp  AnnExp
+             | AAbs Ident   AnnExp
+             | ALet [ABind] AnnExp
+             deriving Show
diff --git a/src/Main.hs b/src/Main.hs
index ed753f2..58aafe5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,11 +1,11 @@
 {-# LANGUAGE LambdaCase #-}
 module Main where
 
-import           Control.Monad.Except (runExcept)
-import           Grammar.Par          (myLexer, pProgram)
-import           Interpreter          (interpret)
-import           System.Environment   (getArgs)
-import           System.Exit          (exitFailure, exitSuccess)
+import           Grammar.Par        (myLexer, pProgram)
+import           Grammar.Print      (printTree)
+import           LambdaLifter       (abstract, freeVars, lambdaLift)
+import           System.Environment (getArgs)
+import           System.Exit        (exitFailure, exitSuccess)
 
 main :: IO ()
 main = getArgs >>= \case
@@ -17,14 +17,17 @@ main = getArgs >>= \case
        putStrLn "SYNTAX ERROR"
        putStrLn err
        exitFailure
-      Right prg -> case runExcept $ interpret prg of
-        Left err -> do
-          putStrLn "INTERPRETER ERROR"
-          putStrLn err
-          exitFailure
-        Right i -> do
-          print i
-          exitSuccess
+      Right prg -> do
+        putStrLn "-- Parser"
+        putStrLn $ printTree prg
+        putStrLn "\n--Lamda lifter"
+        putStrLn "\n--freevars"
+        print $ freeVars prg
+        putStrLn "\n--abstract"
+        putStrLn . printTree $ (abstract . freeVars) prg
+        putStrLn "\n--renamed"
+        putStrLn . printTree $ lambdaLift prg
+        exitSuccess
 
 
 

From 7a2404cf74b4fffcd649fab330c61b7158b5034e Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 06:19:58 +0100
Subject: [PATCH 08/71] Finish Lambda Lifter

---
 basic-2             |  4 +++
 src/LambdaLifter.hs | 76 ++++++++++++++++++++++++++++++++++++++++-----
 src/Main.hs         |  7 +----
 3 files changed, 74 insertions(+), 13 deletions(-)
 create mode 100644 basic-2

diff --git a/basic-2 b/basic-2
new file mode 100644
index 0000000..8afd060
--- /dev/null
+++ b/basic-2
@@ -0,0 +1,4 @@
+add x = \y. x + y;
+
+main = (\z. z + z) ((add 4) 6);
+
diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
index 6e1463d..512155d 100644
--- a/src/LambdaLifter.hs
+++ b/src/LambdaLifter.hs
@@ -3,12 +3,12 @@
 {-# LANGUAGE PatternSynonyms   #-}
 
 
-module LambdaLifter (lambdaLift, freeVars, abstract) where
+module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
 
 import           Data.List        (mapAccumL)
 import           Data.Map         (Map)
 import qualified Data.Map         as Map
-import           Data.Maybe       (fromJust)
+import           Data.Maybe       (fromMaybe)
 import           Data.Set         (Set, (\\))
 import qualified Data.Set         as Set
 import           Data.Tuple.Extra (uncurry3)
@@ -21,7 +21,7 @@ pattern Sc n xs e = ScDef (Bind n xs e)
 
 
 lambdaLift :: Program -> Program
-lambdaLift = rename . abstract . freeVars
+lambdaLift = collectScs . rename . abstract . freeVars
 
 
 -- Annotate free variables
@@ -94,7 +94,7 @@ abstractExp (free, exp) = case exp of
       e' = foldr EAbs (abstractExp e) (fvList ++ [n])
       sc = ELet [bind] (EId (Ident "sc"))
 
--- rename pass
+-- Rename
 
 rename :: Program -> Program
 rename (Program ds) = Program $ map (uncurry3 Sc) tuples
@@ -108,9 +108,7 @@ rename (Program ds) = Program $ map (uncurry3 Sc) tuples
 renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp)
 renameExp env i = \case
 
-
-  EId  n     -> (i, maybe (error "no") EId $ Map.lookup n env)
-
+  EId  n     -> (i, EId . fromMaybe n $ Map.lookup n env)
 
   EInt i1    -> (i, EInt i1)
 
@@ -157,6 +155,70 @@ getNames i ns = (i + length ss, zipWith makeName ss [i..])
 makeName :: String -> Int -> Ident
 makeName prefix i = Ident (prefix ++ "_" ++ show i)
 
+
+-- Collect supercombinators
+
+collectScs :: Program -> Program
+collectScs (Program ds) = Program $ concatMap collect_one_sc ds
+  where
+    collect_one_sc (Sc n xs e) = Sc n xs e' : scs
+      where (scs, e') = collectScsExp e
+
+
+
+collectScsExp :: Exp -> ([ScDef], Exp)
+collectScsExp = \case
+
+  EId  n     -> ([], EId n)
+
+  EInt i     -> ([], EInt i)
+
+  EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2')
+    where
+      (scs1, e1') = collectScsExp e1
+      (scs2, e2') = collectScsExp e2
+
+  EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2')
+    where
+      (scs1, e1') = collectScsExp e1
+      (scs2, e2') = collectScsExp e2
+
+  EAbs x  e  -> (scs, EAbs x e')
+    where
+      (scs, e') = collectScsExp e
+
+  ELet bs e  -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e')
+    where
+      (rhss_scs, bs') = mapAccumL collectScs_d [] bs
+      scs'            = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs]
+      non_scs'        = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs]
+      local_scs       = map peelLambda scs'
+      -- local_scs       = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs']
+      (e_scs, e')     = collectScsExp e
+
+      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs')
+        where
+          (rhs_scs1, rhs') = collectScsExp rhs
+
+
+
+peelLambda :: ScDef -> ScDef
+peelLambda sc@(Sc n xs e) = case e of
+                           EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1)
+                           _         -> sc
+
+
+
+isEAbs :: Exp -> Bool
+isEAbs = \case
+  EAbs {} -> True
+  _       -> False
+
+mkEAbs :: [Bind] -> Exp -> Exp
+mkEAbs [] e = e
+mkEAbs bs e = ELet bs e
+
+
 -- Annotated AST
 
 type AnnProgram = [(Ident, [Ident], AnnExp)]
diff --git a/src/Main.hs b/src/Main.hs
index 58aafe5..ee5a0a1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,7 +3,7 @@ module Main where
 
 import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
-import           LambdaLifter       (abstract, freeVars, lambdaLift)
+import           LambdaLifter       (abstract, freeVars, lambdaLift, rename)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
 
@@ -21,11 +21,6 @@ main = getArgs >>= \case
         putStrLn "-- Parser"
         putStrLn $ printTree prg
         putStrLn "\n--Lamda lifter"
-        putStrLn "\n--freevars"
-        print $ freeVars prg
-        putStrLn "\n--abstract"
-        putStrLn . printTree $ (abstract . freeVars) prg
-        putStrLn "\n--renamed"
         putStrLn . printTree $ lambdaLift prg
         exitSuccess
 

From b6f03e953ba007f17c2f766ef0a1f2dee72a2474 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 9 Feb 2023 09:42:44 +0100
Subject: [PATCH 09/71] deprecated branch

---
 language              |  1 +
 src/Abs.hs            | 20 +++++++++
 src/Rename/Renamer.hs | 96 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 117 insertions(+)
 create mode 120000 language
 create mode 100644 src/Abs.hs
 create mode 100644 src/Rename/Renamer.hs

diff --git a/language b/language
new file mode 120000
index 0000000..29e6f1c
--- /dev/null
+++ b/language
@@ -0,0 +1 @@
+/home/sebastian/.cabal/store/ghc-9.4.4/language-0.1.0.0-e-language-b98a5580bec9e5cee0ea5d675b3788bf6eec0b9eb955374c9ba250c1d3b935fc/bin/language
\ No newline at end of file
diff --git a/src/Abs.hs b/src/Abs.hs
new file mode 100644
index 0000000..35e2904
--- /dev/null
+++ b/src/Abs.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE TypeFamilies, StandaloneDeriving #-}
+
+module Abs where
+
+data Exp eps
+    = EInt (XInt eps) Integer
+    | EId (XId eps) String
+    | EAdd (XAdd eps) (Exp eps) (Exp eps)
+    | EApp (XApp eps) (Exp eps) (Exp eps)
+    | EAbs (XAbs eps) String (Exp eps)
+    | EExp (XExp eps)
+
+newtype Ident = Ident String
+
+type family XInt eps
+type family XId  eps
+type family XAdd eps
+type family XApp eps
+type family XAbs eps
+type family XExp eps
diff --git a/src/Rename/Renamer.hs b/src/Rename/Renamer.hs
new file mode 100644
index 0000000..a6cf12d
--- /dev/null
+++ b/src/Rename/Renamer.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE OverloadedRecordDot, LambdaCase, TypeFamilies, PatternSynonyms #-}
+
+module Rename.Renamer where
+
+import Abs
+
+import qualified Grammar.Abs as A
+import           Grammar.ErrM         (Err)
+import           Control.Monad.Except (throwError)
+import           Grammar.Print        (printTree)
+import           Control.Monad.State
+import qualified Data.Map as M
+import           Data.Map (Map)
+import qualified Data.Set as S
+import           Data.Set (Set)
+
+------------------ DATA TYPES ------------------
+
+type Rn a = StateT Env Err a
+
+data Env = Env { uniques :: Map String Unique
+               , nextUnique :: Unique
+               , sig :: Set String
+               }
+
+newtype Unique = Unique Int
+    deriving Enum
+
+data Name = Nu Unique | Ni String
+
+initEnv :: Env
+initEnv = Env
+        { uniques    = mempty
+        , nextUnique = Unique 0
+        , sig        = mempty
+        }
+
+findBind :: String -> Rn Name
+findBind x = lookupUnique x >>= \case
+    Just u  -> pure $ Nu u
+    Nothing -> gets (S.member x . sig) >>= \case
+      False -> throwError ("Unbound variable " ++ printTree x)
+      True  -> pure $ Ni x
+
+newUnique :: String -> Rn Unique
+newUnique x = do
+  u <- gets nextUnique
+  modify $ \env -> env { nextUnique = succ u
+                       , uniques = M.insert x u env.uniques }
+  return u
+
+lookupUnique :: String -> Rn (Maybe Unique)
+lookupUnique x = gets (M.lookup x . uniques)
+
+renameDef :: Def -> Rn Def
+renameDef = \case
+  DExp x t _ xs e -> do
+    newSig x
+    xs' <- mapM newUnique xs
+    e'  <- renameExp e
+    let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t
+    pure . R.DBind $ R.Bind x t e''
+
+renameExp :: A.Exp -> Rn ExpRE
+renameExp e =
+    case e of
+   A.EInt i -> pure (EIntR i)
+   A.EId (A.Ident str) -> flip EIdR str <$> findBind str
+   A.EAdd e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2
+   A.EApp e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2
+   A.EAbs (A.Ident x) e -> do
+       x' <- newUnique x
+       e' <- renameExp e
+       pure $ EAbsR x' x e'
+
+data R
+type ExpRE = Exp R
+
+type instance XInt R = ()
+type instance XId  R = Name
+type instance XAdd R = ()
+type instance XApp R = ()
+type instance XAbs R = Unique
+type instance XExp R = ()
+
+pattern EIntR :: Integer -> ExpRE
+pattern EIntR i = EInt () i
+
+pattern EIdR :: Name -> String -> ExpRE
+pattern EIdR n s = EId n s
+
+pattern EAppR :: ExpRE -> ExpRE -> ExpRE
+pattern EAppR e1 e2 = EApp () e1 e2
+
+pattern EAbsR :: Unique -> String -> ExpRE -> ExpRE
+pattern EAbsR u n e = EAbs u n e

From ce31e4d49056c252d9295c07bf267a81de6a6882 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 17:53:39 +0100
Subject: [PATCH 10/71] Fix first unnecessary supercombinator

---
 Grammar.cf              |  9 ++----
 basic-2                 |  4 ---
 sample-programs/basic-1 |  2 ++
 sample-programs/basic-2 |  4 +++
 sample-programs/basic-3 |  2 ++
 sample-programs/basic-4 |  2 ++
 sample-programs/basic-5 |  9 ++++++
 src/LambdaLifter.hs     | 72 ++++++++++++++++++++++-------------------
 src/Main.hs             |  8 +++--
 test_program            |  5 ---
 10 files changed, 66 insertions(+), 51 deletions(-)
 delete mode 100644 basic-2
 create mode 100644 sample-programs/basic-1
 create mode 100644 sample-programs/basic-2
 create mode 100644 sample-programs/basic-3
 create mode 100644 sample-programs/basic-4
 create mode 100644 sample-programs/basic-5
 delete mode 100644 test_program

diff --git a/Grammar.cf b/Grammar.cf
index 9dba2f5..410d11d 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,12 +1,6 @@
 
 
-Program. Program ::= [ScDef];
-
-ScDef. ScDef ::= Bind; 
-separator ScDef ";";
-
-separator Ident " ";
-
+Program. Program ::= [Bind];
 
 EId.  Exp3 ::= Ident;
 EInt. Exp3 ::= Integer;
@@ -17,6 +11,7 @@ EAbs. Exp  ::= "\\" Ident "." Exp;
 
 Bind. Bind ::= Ident [Ident] "=" Exp;
 separator Bind ";";
+separator Ident " ";
 
 coercions Exp 3;
 
diff --git a/basic-2 b/basic-2
deleted file mode 100644
index 8afd060..0000000
--- a/basic-2
+++ /dev/null
@@ -1,4 +0,0 @@
-add x = \y. x + y;
-
-main = (\z. z + z) ((add 4) 6);
-
diff --git a/sample-programs/basic-1 b/sample-programs/basic-1
new file mode 100644
index 0000000..f109950
--- /dev/null
+++ b/sample-programs/basic-1
@@ -0,0 +1,2 @@
+
+f = \x. x+1;
diff --git a/sample-programs/basic-2 b/sample-programs/basic-2
new file mode 100644
index 0000000..4b8ead0
--- /dev/null
+++ b/sample-programs/basic-2
@@ -0,0 +1,4 @@
+add x = \y. x+y;
+
+main = (\z. z+z) ((add 4) 6);
+
diff --git a/sample-programs/basic-3 b/sample-programs/basic-3
new file mode 100644
index 0000000..9443439
--- /dev/null
+++ b/sample-programs/basic-3
@@ -0,0 +1,2 @@
+
+main = (\x. x+x+3) ((\x. x) 2)
diff --git a/sample-programs/basic-4 b/sample-programs/basic-4
new file mode 100644
index 0000000..1de7a8c
--- /dev/null
+++ b/sample-programs/basic-4
@@ -0,0 +1,2 @@
+
+f x = let g = (\y. y+1) in g (g x)
diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
new file mode 100644
index 0000000..3168484
--- /dev/null
+++ b/sample-programs/basic-5
@@ -0,0 +1,9 @@
+id x = x;
+
+add x y = x + y;
+
+double n = n + n;
+
+apply f x = \y -> f x y;
+
+main = apply (id add) ((\x. x + 1) 1) (double 3);
diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
index 512155d..c9253b6 100644
--- a/src/LambdaLifter.hs
+++ b/src/LambdaLifter.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms   #-}
 
 
 module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
@@ -15,20 +14,14 @@ import           Data.Tuple.Extra (uncurry3)
 import           Grammar.Abs
 import           Prelude          hiding (exp)
 
-pattern Sc :: Ident -> [Ident] -> Exp -> ScDef
-pattern Sc n xs e = ScDef (Bind n xs e)
-
-
-
 lambdaLift :: Program -> Program
 lambdaLift = collectScs . rename . abstract . freeVars
 
-
 -- Annotate free variables
 
 freeVars :: Program -> AnnProgram
 freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
-                        | Sc n xs e <- ds
+                        | Bind n xs e <- ds
                         ]
 
 
@@ -64,7 +57,6 @@ freeVarsExp lv = \case
       freeInValues = foldr1 Set.union (map freeVarsOf es')
 
 
-
 freeVarsOf :: AnnExp -> Set Ident
 freeVarsOf = fst
 
@@ -74,10 +66,21 @@ fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
 -- Lift lambda expression into let with binder "sc"
 
 abstract :: AnnProgram -> Program
-abstract p = Program
-  [ Sc sc_name xs $ abstractExp rhs
-  | (sc_name, xs, rhs) <- p
-  ]
+abstract prog = Program $ map f prog
+  where
+  f :: (Ident, [Ident], AnnExp) -> Bind
+  f (name, pars, rhs@(_, e)) =
+    case e of
+      AAbs par body -> Bind name (snoc par pars) $ abstractExp body
+      _             -> Bind name pars            $ abstractExp rhs
+
+
+
+-- [ case rhs of
+--     EAbs par body -> Bind name (snoc par pars) body
+--     _             -> Bind name pars rhs
+--
+-- | (name, pars, rhs) <- prog
 
 
 abstractExp :: AnnExp -> Exp
@@ -94,13 +97,17 @@ abstractExp (free, exp) = case exp of
       e' = foldr EAbs (abstractExp e) (fvList ++ [n])
       sc = ELet [bind] (EId (Ident "sc"))
 
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
+
 -- Rename
 
 rename :: Program -> Program
-rename (Program ds) = Program $ map (uncurry3 Sc) tuples
+rename (Program ds) = Program $ map (uncurry3 Bind) tuples
   where
     tuples = snd (mapAccumL renameSc 0 ds)
-    renameSc i (Sc n xs e) = (i2, (n, xs', e'))
+    renameSc i (Bind n xs e) = (i2, (n, xs', e'))
       where
         (i1, xs', env) = newNames i xs
         (i2, e')       = renameExp env i1 e
@@ -159,14 +166,23 @@ makeName prefix i = Ident (prefix ++ "_" ++ show i)
 -- Collect supercombinators
 
 collectScs :: Program -> Program
-collectScs (Program ds) = Program $ concatMap collect_one_sc ds
+collectScs (Program ds) = Program $ concatMap collectOneSc ds
   where
-    collect_one_sc (Sc n xs e) = Sc n xs e' : scs
-      where (scs, e') = collectScsExp e
+    collectOneSc (Bind name args rhs) = Bind name args rhs' : scs
+      where (scs, rhs') = collectScsExp rhs
+  {-
 
 
 
-collectScsExp :: Exp -> ([ScDef], Exp)
+Bind (Ident "f") []
+
+  (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc")))
+
+
+  -}
+
+
+collectScsExp :: Exp -> ([Bind], Exp)
 collectScsExp = \case
 
   EId  n     -> ([], EId n)
@@ -190,25 +206,15 @@ collectScsExp = \case
   ELet bs e  -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e')
     where
       (rhss_scs, bs') = mapAccumL collectScs_d [] bs
-      scs'            = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs]
-      non_scs'        = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs]
-      local_scs       = map peelLambda scs'
-      -- local_scs       = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs']
+      scs'            = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs]
+      non_scs'        = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs]
+      local_scs       = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs']
       (e_scs, e')     = collectScsExp e
 
-      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs')
+      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs')
         where
           (rhs_scs1, rhs') = collectScsExp rhs
 
-
-
-peelLambda :: ScDef -> ScDef
-peelLambda sc@(Sc n xs e) = case e of
-                           EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1)
-                           _         -> sc
-
-
-
 isEAbs :: Exp -> Bool
 isEAbs = \case
   EAbs {} -> True
diff --git a/src/Main.hs b/src/Main.hs
index ee5a0a1..211bf3a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -18,9 +18,13 @@ main = getArgs >>= \case
        putStrLn err
        exitFailure
       Right prg -> do
-        putStrLn "-- Parser"
+        putStrLn "-- Parse"
         putStrLn $ printTree prg
-        putStrLn "\n--Lamda lifter"
+        putStrLn "\n-- Abstract"
+        putStrLn . printTree $ (abstract . freeVars) prg
+        putStrLn "\n-- Rename"
+        putStrLn . printTree $ (rename . abstract . freeVars) prg
+        putStrLn "\n-- Lamda lifter"
         putStrLn . printTree $ lambdaLift prg
         exitSuccess
 
diff --git a/test_program b/test_program
deleted file mode 100644
index 95235e4..0000000
--- a/test_program
+++ /dev/null
@@ -1,5 +0,0 @@
-
-
-
-
-main = (\x. x + x + 3) ((\x. x) 2)

From 23261ec380040a198eb9df626debfe23bc26fa85 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 20:23:20 +0100
Subject: [PATCH 11/71] Add llvm dep

---
 shell.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/shell.nix b/shell.nix
index 0c7624a..2eaf1cd 100644
--- a/shell.nix
+++ b/shell.nix
@@ -6,7 +6,7 @@ pkgs.haskellPackages.developPackage {
   withHoogle = true;
   modifier = drv:
   pkgs.haskell.lib.addBuildTools drv (
-    (with pkgs; [ hlint haskell-language-server ghc jasmin ])
+    (with pkgs; [ hlint haskell-language-server ghc jasmin llvmPackages_15.libllvm])
     ++
     (with pkgs.haskellPackages; [ 
       cabal-install

From 7c313b3faad5bb5b3a4439300c736e81c8140645 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 20:23:49 +0100
Subject: [PATCH 12/71] Fix basic tests

---
 Makefile                | 7 +++++++
 sample-programs/basic-5 | 2 +-
 2 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/Makefile b/Makefile
index 16b753d..6e8a54d 100644
--- a/Makefile
+++ b/Makefile
@@ -22,4 +22,11 @@ clean :
 	rm -r src/Grammar
 	rm language
 
+test :
+	./language ./sample-programs/basic-1
+	./language ./sample-programs/basic-2
+	./language ./sample-programs/basic-3
+	./language ./sample-programs/basic-4
+	./language ./sample-programs/basic-5
+
 # EOF
diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
index 3168484..9984ddd 100644
--- a/sample-programs/basic-5
+++ b/sample-programs/basic-5
@@ -4,6 +4,6 @@ add x y = x + y;
 
 double n = n + n;
 
-apply f x = \y -> f x y;
+apply f x = \y. f x y;
 
 main = apply (id add) ((\x. x + 1) 1) (double 3);

From 07bec3e7ef6111960e96c5ac8695624ee68bffa8 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 20:24:06 +0100
Subject: [PATCH 13/71] Add auxiliary module

---
 Auxiliary.hs   | 5 +++++
 language.cabal | 1 +
 2 files changed, 6 insertions(+)
 create mode 100644 Auxiliary.hs

diff --git a/Auxiliary.hs b/Auxiliary.hs
new file mode 100644
index 0000000..cd844d7
--- /dev/null
+++ b/Auxiliary.hs
@@ -0,0 +1,5 @@
+
+module Auxiliary (module Auxiliary) where
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
diff --git a/language.cabal b/language.cabal
index 3f4860c..52b2577 100644
--- a/language.cabal
+++ b/language.cabal
@@ -31,6 +31,7 @@ executable language
       Grammar.Print
       Grammar.Skel
       LambdaLifter
+      Auxiliary
       -- Interpreter
 
     hs-source-dirs:   src

From 59fb773bc1cc3d8d37531a08df223a706d2dc7a2 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 20:24:25 +0100
Subject: [PATCH 14/71] Some clean up and documenting

---
 src/LambdaLifter.hs | 62 +++++++++++++++------------------------------
 src/Main.hs         |  9 ++++---
 2 files changed, 26 insertions(+), 45 deletions(-)

diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
index c9253b6..ac9cee0 100644
--- a/src/LambdaLifter.hs
+++ b/src/LambdaLifter.hs
@@ -14,17 +14,19 @@ import           Data.Tuple.Extra (uncurry3)
 import           Grammar.Abs
 import           Prelude          hiding (exp)
 
+
+
+-- | Lift lambdas and let expression into supercombinators.
 lambdaLift :: Program -> Program
 lambdaLift = collectScs . rename . abstract . freeVars
 
--- Annotate free variables
 
+-- | Annotate free variables
 freeVars :: Program -> AnnProgram
 freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
                         | Bind n xs e <- ds
                         ]
 
-
 freeVarsExp :: Set Ident -> Exp -> AnnExp
 freeVarsExp lv = \case
 
@@ -63,8 +65,22 @@ freeVarsOf = fst
 fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp])
 fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
 
--- Lift lambda expression into let with binder "sc"
+-- AST annotated with free variables
+type AnnProgram = [(Ident, [Ident], AnnExp)]
 
+type AnnExp = (Set Ident, AnnExp')
+
+data ABind = ABind Ident [Ident] AnnExp deriving Show
+
+data AnnExp' = AId Ident
+             | AInt Integer
+             | AApp AnnExp  AnnExp
+             | AAdd AnnExp  AnnExp
+             | AAbs Ident   AnnExp
+             | ALet [ABind] AnnExp
+             deriving Show
+
+-- | Lift lambdas to let expression of the form @let sc = \x -> rhs@
 abstract :: AnnProgram -> Program
 abstract prog = Program $ map f prog
   where
@@ -74,15 +90,6 @@ abstract prog = Program $ map f prog
       AAbs par body -> Bind name (snoc par pars) $ abstractExp body
       _             -> Bind name pars            $ abstractExp rhs
 
-
-
--- [ case rhs of
---     EAbs par body -> Bind name (snoc par pars) body
---     _             -> Bind name pars rhs
---
--- | (name, pars, rhs) <- prog
-
-
 abstractExp :: AnnExp -> Exp
 abstractExp (free, exp) = case exp of
   AId  n     -> EId n
@@ -101,8 +108,7 @@ abstractExp (free, exp) = case exp of
 snoc :: a -> [a] -> [a]
 snoc x xs = xs ++ [x]
 
--- Rename
-
+-- | Rename all supercombinators and variables
 rename :: Program -> Program
 rename (Program ds) = Program $ map (uncurry3 Bind) tuples
   where
@@ -163,24 +169,12 @@ makeName :: String -> Int -> Ident
 makeName prefix i = Ident (prefix ++ "_" ++ show i)
 
 
--- Collect supercombinators
-
+-- | Collects supercombinators by lifting appropriate let expressions
 collectScs :: Program -> Program
 collectScs (Program ds) = Program $ concatMap collectOneSc ds
   where
     collectOneSc (Bind name args rhs) = Bind name args rhs' : scs
       where (scs, rhs') = collectScsExp rhs
-  {-
-
-
-
-Bind (Ident "f") []
-
-  (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc")))
-
-
-  -}
-
 
 collectScsExp :: Exp -> ([Bind], Exp)
 collectScsExp = \case
@@ -225,17 +219,3 @@ mkEAbs [] e = e
 mkEAbs bs e = ELet bs e
 
 
--- Annotated AST
-
-type AnnProgram = [(Ident, [Ident], AnnExp)]
-type AnnExp = (Set Ident, AnnExp')
-
-data ABind = ABind Ident [Ident] AnnExp deriving Show
-
-data AnnExp' = AId Ident
-             | AInt Integer
-             | AApp AnnExp  AnnExp
-             | AAdd AnnExp  AnnExp
-             | AAbs Ident   AnnExp
-             | ALet [ABind] AnnExp
-             deriving Show
diff --git a/src/Main.hs b/src/Main.hs
index 211bf3a..9af1753 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -20,12 +20,13 @@ main = getArgs >>= \case
       Right prg -> do
         putStrLn "-- Parse"
         putStrLn $ printTree prg
-        putStrLn "\n-- Abstract"
-        putStrLn . printTree $ (abstract . freeVars) prg
-        putStrLn "\n-- Rename"
-        putStrLn . printTree $ (rename . abstract . freeVars) prg
+        -- putStrLn "\n-- Abstract"
+        -- putStrLn . printTree $ (abstract . freeVars) prg
+        -- putStrLn "\n-- Rename"
+        -- putStrLn . printTree $ (rename . abstract . freeVars) prg
         putStrLn "\n-- Lamda lifter"
         putStrLn . printTree $ lambdaLift prg
+        putStrLn ""
         exitSuccess
 
 

From 3ac8377fa01259f91986d5833693c6911bd0e8ca Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 20:25:00 +0100
Subject: [PATCH 15/71] Fix auxiliary path

---
 Auxiliary.hs => src/Auxiliary.hs | 0
 1 file changed, 0 insertions(+), 0 deletions(-)
 rename Auxiliary.hs => src/Auxiliary.hs (100%)

diff --git a/Auxiliary.hs b/src/Auxiliary.hs
similarity index 100%
rename from Auxiliary.hs
rename to src/Auxiliary.hs

From f4f1786be3e84dc0b5bf1a6099aec45bf1b61550 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 10 Feb 2023 10:41:16 +0100
Subject: [PATCH 16/71] Revert "Merge branch 'typechecking' into
 codegen-martin-3"

This reverts commit e000e5159f12f3ba8140ed372c7aa647fd62d506, reversing
changes made to 3ac8377fa01259f91986d5833693c6911bd0e8ca.
---
 Grammar.cf            |   3 -
 Makefile              |   2 +-
 language              |   1 -
 language.cabal        |   2 +-
 src/Abs.hs            |  20 -------
 src/Interpreter.hs    |  10 +++-
 src/NewAbs.hs         |  29 ----------
 src/Rename/Renamer.hs |  96 -------------------------------
 src/TypeChecker.hs    | 129 ------------------------------------------
 test_program          |   2 -
 10 files changed, 9 insertions(+), 285 deletions(-)
 delete mode 120000 language
 delete mode 100644 src/Abs.hs
 delete mode 100644 src/NewAbs.hs
 delete mode 100644 src/Rename/Renamer.hs
 delete mode 100644 test_program

diff --git a/Grammar.cf b/Grammar.cf
index 4446eaf..410d11d 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,7 +1,4 @@
-Program. Program ::= [Def] ;
 
-DExp.  Def ::= Ident ":" Type
-               Ident [Ident] "=" Exp ;
 
 Program. Program ::= [Bind];
 
diff --git a/Makefile b/Makefile
index ad830b5..6e8a54d 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
 .PHONY : sdist clean
 
 language : src/Grammar/Test
-	cabal install --installdir=. --overwrite-policy=always
+	cabal install --installdir=.
 
 src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf
 	bnfc -o src -d $<
diff --git a/language b/language
deleted file mode 120000
index 29e6f1c..0000000
--- a/language
+++ /dev/null
@@ -1 +0,0 @@
-/home/sebastian/.cabal/store/ghc-9.4.4/language-0.1.0.0-e-language-b98a5580bec9e5cee0ea5d675b3788bf6eec0b9eb955374c9ba250c1d3b935fc/bin/language
\ No newline at end of file
diff --git a/language.cabal b/language.cabal
index f95d1dd..52b2577 100644
--- a/language.cabal
+++ b/language.cabal
@@ -17,7 +17,7 @@ extra-source-files:
 
 
 common warnings
-    ghc-options: -W
+    ghc-options: -Wall
 
 executable language
     import:           warnings
diff --git a/src/Abs.hs b/src/Abs.hs
deleted file mode 100644
index 35e2904..0000000
--- a/src/Abs.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE TypeFamilies, StandaloneDeriving #-}
-
-module Abs where
-
-data Exp eps
-    = EInt (XInt eps) Integer
-    | EId (XId eps) String
-    | EAdd (XAdd eps) (Exp eps) (Exp eps)
-    | EApp (XApp eps) (Exp eps) (Exp eps)
-    | EAbs (XAbs eps) String (Exp eps)
-    | EExp (XExp eps)
-
-newtype Ident = Ident String
-
-type family XInt eps
-type family XId  eps
-type family XAdd eps
-type family XApp eps
-type family XAbs eps
-type family XExp eps
diff --git a/src/Interpreter.hs b/src/Interpreter.hs
index b7d83a5..378c95b 100644
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@@ -1,10 +1,14 @@
 {-# LANGUAGE LambdaCase #-}
-
 module Interpreter where
 
-import           Control.Monad.Except    (Except, MonadError (throwError))
-
+import           Control.Applicative     (Applicative)
+import           Control.Monad.Except    (Except, MonadError (throwError),
+                                          liftEither)
+import           Data.Either.Combinators (maybeToRight)
+import           Data.Map                (Map)
+import qualified Data.Map                as Map
 import           Grammar.Abs
+import           Grammar.Print           (printTree)
 
 interpret :: Program -> Except String Integer
 interpret (Program e) =
diff --git a/src/NewAbs.hs b/src/NewAbs.hs
deleted file mode 100644
index 9a0296d..0000000
--- a/src/NewAbs.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE GADTs, LambdaCase #-}
-
-module NewAbs where
-
-import Grammar.Abs ( Ident(..), Type )
-
-data CExp where
-    CId  :: Type -> Ident -> CExp
-    CInt :: Type -> Int -> CExp
-    CAdd :: Type -> CExp -> CExp -> CExp
-    CAbs :: Type -> Ident -> Type -> CExp -> CExp
-    CApp :: Type -> CExp -> CExp -> CExp 
-
-instance Show CExp where
-    show :: CExp -> String
-    show = \case
-        CId _ (Ident a) -> show a
-        CInt _ i -> show i
-        CAdd _ e1 e2 -> show e1 <> " + " <> show e2
-        CAbs t1 i t2 e -> appendType t1 $ show "\\" <> show i <> " : " <> show t2 <> ". " <> show e
-        CApp _ e1 e2 -> show e1 <> " " <> show e2
-
-appendType :: Type -> String -> String
-appendType t s = s <> " : " <> show t
-
-data CDef = CDef Ident Type Ident [Ident] CExp
-    deriving Show
-
-newtype CProgram = CProgram [CDef]
diff --git a/src/Rename/Renamer.hs b/src/Rename/Renamer.hs
deleted file mode 100644
index a6cf12d..0000000
--- a/src/Rename/Renamer.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-{-# LANGUAGE OverloadedRecordDot, LambdaCase, TypeFamilies, PatternSynonyms #-}
-
-module Rename.Renamer where
-
-import Abs
-
-import qualified Grammar.Abs as A
-import           Grammar.ErrM         (Err)
-import           Control.Monad.Except (throwError)
-import           Grammar.Print        (printTree)
-import           Control.Monad.State
-import qualified Data.Map as M
-import           Data.Map (Map)
-import qualified Data.Set as S
-import           Data.Set (Set)
-
------------------- DATA TYPES ------------------
-
-type Rn a = StateT Env Err a
-
-data Env = Env { uniques :: Map String Unique
-               , nextUnique :: Unique
-               , sig :: Set String
-               }
-
-newtype Unique = Unique Int
-    deriving Enum
-
-data Name = Nu Unique | Ni String
-
-initEnv :: Env
-initEnv = Env
-        { uniques    = mempty
-        , nextUnique = Unique 0
-        , sig        = mempty
-        }
-
-findBind :: String -> Rn Name
-findBind x = lookupUnique x >>= \case
-    Just u  -> pure $ Nu u
-    Nothing -> gets (S.member x . sig) >>= \case
-      False -> throwError ("Unbound variable " ++ printTree x)
-      True  -> pure $ Ni x
-
-newUnique :: String -> Rn Unique
-newUnique x = do
-  u <- gets nextUnique
-  modify $ \env -> env { nextUnique = succ u
-                       , uniques = M.insert x u env.uniques }
-  return u
-
-lookupUnique :: String -> Rn (Maybe Unique)
-lookupUnique x = gets (M.lookup x . uniques)
-
-renameDef :: Def -> Rn Def
-renameDef = \case
-  DExp x t _ xs e -> do
-    newSig x
-    xs' <- mapM newUnique xs
-    e'  <- renameExp e
-    let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t
-    pure . R.DBind $ R.Bind x t e''
-
-renameExp :: A.Exp -> Rn ExpRE
-renameExp e =
-    case e of
-   A.EInt i -> pure (EIntR i)
-   A.EId (A.Ident str) -> flip EIdR str <$> findBind str
-   A.EAdd e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2
-   A.EApp e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2
-   A.EAbs (A.Ident x) e -> do
-       x' <- newUnique x
-       e' <- renameExp e
-       pure $ EAbsR x' x e'
-
-data R
-type ExpRE = Exp R
-
-type instance XInt R = ()
-type instance XId  R = Name
-type instance XAdd R = ()
-type instance XApp R = ()
-type instance XAbs R = Unique
-type instance XExp R = ()
-
-pattern EIntR :: Integer -> ExpRE
-pattern EIntR i = EInt () i
-
-pattern EIdR :: Name -> String -> ExpRE
-pattern EIdR n s = EId n s
-
-pattern EAppR :: ExpRE -> ExpRE -> ExpRE
-pattern EAppR e1 e2 = EApp () e1 e2
-
-pattern EAbsR :: Unique -> String -> ExpRE -> ExpRE
-pattern EAbsR u n e = EAbs u n e
diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs
index 8e233bb..e69de29 100644
--- a/src/TypeChecker.hs
+++ b/src/TypeChecker.hs
@@ -1,129 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-
-module TypeChecker (typecheck) where
-
-import Grammar.Abs
-import Grammar.ErrM ( Err )
-import NewAbs
-import Data.Map (Map)
-import Data.Map qualified as Map
-import Control.Monad.Reader
-import Control.Monad.Except
-import Data.List (isPrefixOf)
-import Control.Applicative ((<|>))
-
-type Check a = ReaderT Context Err a
-
-data Context = Ctx { sig :: Map Ident Type
-                   , env :: [Map Ident Type]
-                   }
-
-initEnv :: Context
-initEnv = Ctx { sig = mempty
-              , env = mempty
-              }
-
-run :: Check a -> Either String a
-run = flip runReaderT initEnv
-
-typecheck :: Program -> Err Program
-typecheck prg = case run $ checkProg prg of
-                  Left err -> fail err
-                  Right _ -> pure prg
-
-
-checkProg :: Program -> Check CProgram
-checkProg (Program ds) = undefined
-    
-checkDef :: Def -> Check CDef
-checkDef (DExp i1 TInt i2 args e) = undefined
-checkDef (DExp i1 (TPol i) i2 args e) = undefined
-checkDef (DExp i1 (TFun xs) i2 args e) = do
-        when (i1 /= i2) (fail $ "Mismatched names: " <> show i1 <> " != " <> show i2)
-        case compare (length xs - 1) (length args) of
-          LT -> fail $ "Too many arguments, got " <> show (length args) <> " expected " <> show (length xs)
-          _ -> do
-              let vars = Map.fromList $ zip args xs
-              e' <- local (\r -> r { env =  [vars] }) (checkExp e)
-              return $ CDef i1 (TFun xs) i2 args e'
-
-checkExp :: Exp -> Check CExp
-checkExp = \case
-
-    EInt i -> pure $ CInt TInt (fromIntegral i)
-
-    EAdd e1 e2 -> do
-        e1' <- checkExp e1
-        e2' <- checkExp e2
-        let t1 = getType e1'
-        let t2 = getType e2'
-        when (t1 /= t2) (fail $ "Different types occured, got " <> show t1 <> " and " <> show t2)
-        return $ CAdd t1 e1' e2'
-
-    EId i -> do
-        asks (lookupEnv i) >>= \case
-            Right t -> return $ CId t i
-            Left _ -> asks (lookupSig i) >>= \case
-                Right t -> return $ CId t i
-                Left x -> fail x
-
-    EAbs i t e -> do
-        e' <- local (\r -> r { env = Map.singleton i t : r.env }) (checkExp e)
-        return $ CAbs (TFun [t, getType e']) i t e'
-
-    EApp e1 e2 -> do
-        e1' <- checkExp e1
-        e2' <- checkExp e2
-        let retT = applyType (getType e1') (getType e2')
-        case retT of
-          Left x -> fail x
-          Right t -> return $ CApp t e1' e2'
-
-lookupSig :: Ident -> Context -> Err Type
-lookupSig i (Ctx s _) = case Map.lookup i s of
-                  Nothing -> throwError $ "Undefined function: " <> show i
-                  Just x -> pure x
-
-lookupEnv :: Ident -> Context -> Err Type
-lookupEnv i (Ctx _ []) = throwError $ "Unbound variable: " <> show i
-lookupEnv i (Ctx s (e:es)) = case Map.lookup i e of
-                  Nothing -> lookupEnv i (Ctx s es)
-                  Just x -> pure x
-
-
-applyType :: Type -> Type -> Err Type
-applyType (TFun (x:xs)) t = case t of
-    (TFun ys) -> if ys `isPrefixOf` (x:xs)
-                         then return . TFun $ drop (length ys) (x:xs)
-                         else fail $ "Mismatched types, expected " <> show x <> " got " <> show TInt
-applyType t1 t2 = fail $ "Can not apply " <> show t1 <> " to " <> show t2
-
-class ExtractType a where
-    getType :: a -> Type
-
-instance ExtractType CExp where
-    getType = \case
-        CId t _ -> t
-        CInt t _ -> t
-        CAdd t _ _ -> t
-        CAbs t _ _ _ -> t
-        CApp t _ _ -> t
-
--- | λx : Int. x + 3 + 5
-customLambda1 :: Exp
-customLambda1 = EAbs (Ident "x") TInt (EAdd (EId (Ident "x")) (EAdd (EInt 3) (EInt 5)))
-
-customLambda2 :: Exp
-customLambda2 = EAbs (Ident "x") (TFun [TInt, TInt]) (EId (Ident "f"))
-
--- | main : Int 
---   main = λx : Int. x + 3 + 5
-customPrg1 :: Program
-customPrg1 = Program [DExp (Ident "main") TInt (Ident "main") [] customLambda1]
-
--- | main : Int -> Int
---   main = λx : Int. x + 3 + 5
-customPrg2 :: Program
-customPrg2 = Program [DExp (Ident "main") (TFun [TInt, TInt]) (Ident "main") [] customLambda2]
diff --git a/test_program b/test_program
deleted file mode 100644
index 77bf0ad..0000000
--- a/test_program
+++ /dev/null
@@ -1,2 +0,0 @@
-main : Int
-main = (\x : Int. x + x + 3) ((\x : Int. x) 2)

From a1e9624d5ee896fe0314591ad539db995bd3b21e Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 10 Feb 2023 12:09:08 +0100
Subject: [PATCH 17/71] TTGing the lambda lifter

---
 language.cabal      |  1 -
 src/Abs.hs          | 28 ++++++++++++++++++++++++++++
 src/Auxiliary.hs    |  5 -----
 src/LambdaLifter.hs | 44 ++++++++++++++++++++++++++++++++++++++------
 src/Main.hs         |  2 +-
 5 files changed, 67 insertions(+), 13 deletions(-)
 create mode 100644 src/Abs.hs
 delete mode 100644 src/Auxiliary.hs

diff --git a/language.cabal b/language.cabal
index 52b2577..3f4860c 100644
--- a/language.cabal
+++ b/language.cabal
@@ -31,7 +31,6 @@ executable language
       Grammar.Print
       Grammar.Skel
       LambdaLifter
-      Auxiliary
       -- Interpreter
 
     hs-source-dirs:   src
diff --git a/src/Abs.hs b/src/Abs.hs
new file mode 100644
index 0000000..7cc3064
--- /dev/null
+++ b/src/Abs.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TypeFamilies, PatternSynonyms, StandaloneDeriving #-}
+
+module Abs where
+
+import Data.String
+
+data Program a = Program [Bind a]
+
+data Bind a = Bind Ident [Ident] (Exp a)
+
+newtype Ident = Ident String
+    deriving (Eq, Ord, Show, Data.String.IsString)
+
+data Exp a = EId  (IdFamily  a)  Ident
+           | EInt (IntFamily a) Integer
+           | EAdd (AddFamily a) (Exp a) (Exp a)
+           | EApp (AppFamily a) (Exp a) (Exp a)
+           | EAbs (AbsFamily a) Ident (Exp a)
+           | ELet (LetFamily a) [Bind a] (Exp a)
+           | EExp (ExpFamily a) (Exp a)
+
+type family IdFamily  a
+type family IntFamily a
+type family AddFamily a
+type family AppFamily a
+type family AbsFamily a
+type family LetFamily a
+type family ExpFamily a
diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs
deleted file mode 100644
index cd844d7..0000000
--- a/src/Auxiliary.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-
-module Auxiliary (module Auxiliary) where
-
-snoc :: a -> [a] -> [a]
-snoc x xs = xs ++ [x]
diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
index ac9cee0..79d5b8a 100644
--- a/src/LambdaLifter.hs
+++ b/src/LambdaLifter.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings, TypeFamilies, PatternSynonyms #-}
 
 
 module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
@@ -13,6 +12,8 @@ import qualified Data.Set         as Set
 import           Data.Tuple.Extra (uncurry3)
 import           Grammar.Abs
 import           Prelude          hiding (exp)
+import qualified Abs              as A
+import           Data.Void
 
 
 
@@ -74,10 +75,10 @@ data ABind = ABind Ident [Ident] AnnExp deriving Show
 
 data AnnExp' = AId Ident
              | AInt Integer
-             | AApp AnnExp  AnnExp
-             | AAdd AnnExp  AnnExp
-             | AAbs Ident   AnnExp
-             | ALet [ABind] AnnExp
+             | AApp (Set Ident, AnnExp') (Set Ident, AnnExp')
+             | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') 
+             | AAbs Ident   (Set Ident, AnnExp') 
+             | ALet [ABind] (Set Ident, AnnExp') 
              deriving Show
 
 -- | Lift lambdas to let expression of the form @let sc = \x -> rhs@
@@ -219,3 +220,34 @@ mkEAbs [] e = e
 mkEAbs bs e = ELet bs e
 
 
+{----------- BOILERPLATE -----------}
+
+data LL 
+
+type instance A.IdFamily  LL = ()
+type instance A.IntFamily LL = ()
+type instance A.AddFamily LL = (Set Ident, Set Ident)
+type instance A.AppFamily LL = (Set Ident, Set Ident)
+type instance A.AbsFamily LL = Set Ident
+type instance A.LetFamily LL = Set Ident
+type instance A.ExpFamily LL = Void
+
+pattern LLId ident = A.EId () ident
+pattern LLInt int = A.EInt () int
+pattern LLAdd s1 s2 e1 e2 = A.EAdd (s1,s2) e1 e2
+pattern LLApp s1 s2 e1 e2 = A.EApp (s1,s2) e1 e2
+pattern LLAbs s i e = A.EAbs s i e
+pattern LLLet s binds e = A.ELet s binds e
+pattern LLExp v e = A.EExp v e
+
+{-
+
+data AnnExp' = AId Ident
+             | AInt Integer
+             | AApp (Set Ident, AnnExp') (Set Ident, AnnExp')
+             | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') 
+             | AAbs Ident   (Set Ident, AnnExp') 
+             | ALet [ABind] (Set Ident, AnnExp') 
+             deriving Show
+
+-}
diff --git a/src/Main.hs b/src/Main.hs
index 9af1753..d367bc1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,7 +3,7 @@ module Main where
 
 import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
-import           LambdaLifter       (abstract, freeVars, lambdaLift, rename)
+import           LambdaLifter       (lambdaLift)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
 

From 73dc2e4b6a28c20b21fac8bee958733fc67507eb Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 13 Feb 2023 12:17:49 +0100
Subject: [PATCH 18/71] Inference on most expressions. HM based. Still have to
 figure out how to infer type of lambda variables, as well as how function
 application on polymorphic should work

---
 Grammar.cf                       |  28 ++--
 Makefile                         |   2 +-
 language.cabal                   |  11 +-
 src/Abs.hs                       |  28 ----
 src/LambdaLifter.hs              | 253 -------------------------------
 src/Main.hs                      |  16 +-
 src/Renamer/Renamer.hs           |  90 +++++++++++
 src/Renamer/RenamerIr.hs         |  84 ++++++++++
 src/TypeChecker.hs               |   0
 src/TypeChecker/TypeChecker.hs   | 122 +++++++++++++++
 src/TypeChecker/TypeCheckerIr.hs |  22 +++
 test_program                     |   1 +
 12 files changed, 347 insertions(+), 310 deletions(-)
 delete mode 100644 src/Abs.hs
 delete mode 100644 src/LambdaLifter.hs
 create mode 100644 src/Renamer/Renamer.hs
 create mode 100644 src/Renamer/RenamerIr.hs
 delete mode 100644 src/TypeChecker.hs
 create mode 100644 src/TypeChecker/TypeChecker.hs
 create mode 100644 src/TypeChecker/TypeCheckerIr.hs
 create mode 100644 test_program

diff --git a/Grammar.cf b/Grammar.cf
index 410d11d..b58dbea 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,20 +1,28 @@
 
-
 Program. Program ::= [Bind];
 
-EId.  Exp3 ::= Ident;
-EInt. Exp3 ::= Integer;
-ELet. Exp3 ::= "let" [Bind] "in" Exp; 
-EApp. Exp2 ::= Exp2 Exp3;
-EAdd. Exp1 ::= Exp1 "+" Exp2;
-EAbs. Exp  ::= "\\" Ident "." Exp;
-
 Bind. Bind ::= Ident [Ident] "=" Exp;
+
+EAnn.   Exp5 ::= Exp5 ":" Type ;
+EId.    Exp4 ::= Ident;
+EConst. Exp4 ::= Const;
+EApp.   Exp3 ::= Exp3 Exp4;
+ELet.   Exp2 ::= "let" Bind "in" Exp; 
+EAdd.   Exp1 ::= Exp1 "+" Exp2;
+EAbs.   Exp  ::= "\\" Ident "." Exp;
+
+CInt. Const ::= Integer ;
+CStr. Const ::= String ;
+
+TMono. Type1 ::= Ident ;
+TPoly. Type1 ::= Ident ;
+TFun. Type  ::= Type1 "->" Type ;
+
 separator Bind ";";
 separator Ident " ";
 
-coercions Exp 3;
+coercions Type 1 ;
+coercions Exp 5;
 
 comment "--";
 comment "{-" "-}";
-
diff --git a/Makefile b/Makefile
index 6e8a54d..ad830b5 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
 .PHONY : sdist clean
 
 language : src/Grammar/Test
-	cabal install --installdir=.
+	cabal install --installdir=. --overwrite-policy=always
 
 src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf
 	bnfc -o src -d $<
diff --git a/language.cabal b/language.cabal
index 3f4860c..d254e3e 100644
--- a/language.cabal
+++ b/language.cabal
@@ -17,7 +17,7 @@ extra-source-files:
 
 
 common warnings
-    ghc-options: -Wall
+    ghc-options: -W
 
 executable language
     import:           warnings
@@ -30,7 +30,12 @@ executable language
       Grammar.Par
       Grammar.Print
       Grammar.Skel
-      LambdaLifter
+      Grammar.ErrM
+      -- LambdaLifter
+      TypeChecker.TypeChecker
+      TypeChecker.TypeCheckerIr
+      -- Renamer.Renamer
+      -- Renamer.RenamerIr
       -- Interpreter
 
     hs-source-dirs:   src
@@ -40,7 +45,7 @@ executable language
       , mtl
       , containers
       , either
-      , array
       , extra
+      , array
 
     default-language: GHC2021
diff --git a/src/Abs.hs b/src/Abs.hs
deleted file mode 100644
index 7cc3064..0000000
--- a/src/Abs.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE TypeFamilies, PatternSynonyms, StandaloneDeriving #-}
-
-module Abs where
-
-import Data.String
-
-data Program a = Program [Bind a]
-
-data Bind a = Bind Ident [Ident] (Exp a)
-
-newtype Ident = Ident String
-    deriving (Eq, Ord, Show, Data.String.IsString)
-
-data Exp a = EId  (IdFamily  a)  Ident
-           | EInt (IntFamily a) Integer
-           | EAdd (AddFamily a) (Exp a) (Exp a)
-           | EApp (AppFamily a) (Exp a) (Exp a)
-           | EAbs (AbsFamily a) Ident (Exp a)
-           | ELet (LetFamily a) [Bind a] (Exp a)
-           | EExp (ExpFamily a) (Exp a)
-
-type family IdFamily  a
-type family IntFamily a
-type family AddFamily a
-type family AppFamily a
-type family AbsFamily a
-type family LetFamily a
-type family ExpFamily a
diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
deleted file mode 100644
index 79d5b8a..0000000
--- a/src/LambdaLifter.hs
+++ /dev/null
@@ -1,253 +0,0 @@
-{-# LANGUAGE LambdaCase, OverloadedStrings, TypeFamilies, PatternSynonyms #-}
-
-
-module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
-
-import           Data.List        (mapAccumL)
-import           Data.Map         (Map)
-import qualified Data.Map         as Map
-import           Data.Maybe       (fromMaybe)
-import           Data.Set         (Set, (\\))
-import qualified Data.Set         as Set
-import           Data.Tuple.Extra (uncurry3)
-import           Grammar.Abs
-import           Prelude          hiding (exp)
-import qualified Abs              as A
-import           Data.Void
-
-
-
--- | Lift lambdas and let expression into supercombinators.
-lambdaLift :: Program -> Program
-lambdaLift = collectScs . rename . abstract . freeVars
-
-
--- | Annotate free variables
-freeVars :: Program -> AnnProgram
-freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
-                        | Bind n xs e <- ds
-                        ]
-
-freeVarsExp :: Set Ident -> Exp -> AnnExp
-freeVarsExp lv = \case
-
-  EId n | Set.member n lv -> (Set.singleton n, AId n)
-        | otherwise       -> (mempty, AId n)
-
-  EInt i     -> (mempty, AInt i)
-
-  EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2')
-    where e1' = freeVarsExp lv e1
-          e2' = freeVarsExp lv e2
-
-  EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2')
-    where e1' = freeVarsExp lv e1
-          e2' = freeVarsExp lv e2
-
-  EAbs n  e  -> (Set.delete n $ freeVarsOf e', AAbs n e')
-    where e'  = freeVarsExp (Set.insert n lv) e
-
-  ELet bs e  -> (Set.union bsFree eFree, ALet bs' e')
-    where
-      bsFree       = freeInValues \\ nsSet
-      eFree        = freeVarsOf e' \\ nsSet
-      bs'          = zipWith3 ABind ns xs es'
-      e'           = freeVarsExp e_lv e
-      (ns, xs, es) = fromBinders bs
-      nsSet        = Set.fromList ns
-      e_lv         = Set.union lv nsSet
-      es'          = map (freeVarsExp e_lv) es
-      freeInValues = foldr1 Set.union (map freeVarsOf es')
-
-
-freeVarsOf :: AnnExp -> Set Ident
-freeVarsOf = fst
-
-fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp])
-fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
-
--- AST annotated with free variables
-type AnnProgram = [(Ident, [Ident], AnnExp)]
-
-type AnnExp = (Set Ident, AnnExp')
-
-data ABind = ABind Ident [Ident] AnnExp deriving Show
-
-data AnnExp' = AId Ident
-             | AInt Integer
-             | AApp (Set Ident, AnnExp') (Set Ident, AnnExp')
-             | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') 
-             | AAbs Ident   (Set Ident, AnnExp') 
-             | ALet [ABind] (Set Ident, AnnExp') 
-             deriving Show
-
--- | Lift lambdas to let expression of the form @let sc = \x -> rhs@
-abstract :: AnnProgram -> Program
-abstract prog = Program $ map f prog
-  where
-  f :: (Ident, [Ident], AnnExp) -> Bind
-  f (name, pars, rhs@(_, e)) =
-    case e of
-      AAbs par body -> Bind name (snoc par pars) $ abstractExp body
-      _             -> Bind name pars            $ abstractExp rhs
-
-abstractExp :: AnnExp -> Exp
-abstractExp (free, exp) = case exp of
-  AId  n     -> EId n
-  AInt i     -> EInt i
-  AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2)
-  AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2)
-  ALet bs e  -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e
-  AAbs n  e  -> foldl EApp sc (map EId fvList)
-    where
-      fvList = Set.toList free
-      bind = Bind "sc" [] e'
-      e' = foldr EAbs (abstractExp e) (fvList ++ [n])
-      sc = ELet [bind] (EId (Ident "sc"))
-
-
-snoc :: a -> [a] -> [a]
-snoc x xs = xs ++ [x]
-
--- | Rename all supercombinators and variables
-rename :: Program -> Program
-rename (Program ds) = Program $ map (uncurry3 Bind) tuples
-  where
-    tuples = snd (mapAccumL renameSc 0 ds)
-    renameSc i (Bind n xs e) = (i2, (n, xs', e'))
-      where
-        (i1, xs', env) = newNames i xs
-        (i2, e')       = renameExp env i1 e
-
-renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp)
-renameExp env i = \case
-
-  EId  n     -> (i, EId . fromMaybe n $ Map.lookup n env)
-
-  EInt i1    -> (i, EInt i1)
-
-  EApp e1 e2 -> (i2, EApp e1' e2')
-    where
-      (i1, e1') = renameExp env i e1
-      (i2, e2') = renameExp env i1 e2
-
-  EAdd e1 e2 -> (i2, EAdd e1' e2')
-    where
-      (i1, e1') = renameExp env i e1
-      (i2, e2') = renameExp env i1 e2
-
-  ELet bs e  -> (i3, ELet (zipWith3 Bind ns' xs es') e')
-    where
-      (i1, e')        = renameExp e_env i e
-      (ns, xs, es)    = fromBinders bs
-      (i2, ns', env') = newNames i1 ns
-      e_env           = Map.union env' env
-      (i3, es')       = mapAccumL (renameExp e_env) i2 es
-
-
-  EAbs n  e  -> (i2, EAbs (head ns) e')
-    where
-      (i1, ns, env') = newNames i [n]
-      (i2, e')       = renameExp (Map.union env' env ) i1 e
-
-
-newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident)
-newNames i old_names = (i', new_names, env)
-  where
-    (i', new_names) = getNames i old_names
-    env = Map.fromList $ zip old_names new_names
-
-
-getName :: Int -> Ident -> (Int, Ident)
-getName i (Ident s) = (i + 1, makeName s i)
-
-getNames :: Int -> [Ident] -> (Int, [Ident])
-getNames i ns = (i + length ss, zipWith makeName ss [i..])
-  where
-    ss = map (\(Ident s) -> s) ns
-
-makeName :: String -> Int -> Ident
-makeName prefix i = Ident (prefix ++ "_" ++ show i)
-
-
--- | Collects supercombinators by lifting appropriate let expressions
-collectScs :: Program -> Program
-collectScs (Program ds) = Program $ concatMap collectOneSc ds
-  where
-    collectOneSc (Bind name args rhs) = Bind name args rhs' : scs
-      where (scs, rhs') = collectScsExp rhs
-
-collectScsExp :: Exp -> ([Bind], Exp)
-collectScsExp = \case
-
-  EId  n     -> ([], EId n)
-
-  EInt i     -> ([], EInt i)
-
-  EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2')
-    where
-      (scs1, e1') = collectScsExp e1
-      (scs2, e2') = collectScsExp e2
-
-  EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2')
-    where
-      (scs1, e1') = collectScsExp e1
-      (scs2, e2') = collectScsExp e2
-
-  EAbs x  e  -> (scs, EAbs x e')
-    where
-      (scs, e') = collectScsExp e
-
-  ELet bs e  -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e')
-    where
-      (rhss_scs, bs') = mapAccumL collectScs_d [] bs
-      scs'            = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs]
-      non_scs'        = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs]
-      local_scs       = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs']
-      (e_scs, e')     = collectScsExp e
-
-      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs')
-        where
-          (rhs_scs1, rhs') = collectScsExp rhs
-
-isEAbs :: Exp -> Bool
-isEAbs = \case
-  EAbs {} -> True
-  _       -> False
-
-mkEAbs :: [Bind] -> Exp -> Exp
-mkEAbs [] e = e
-mkEAbs bs e = ELet bs e
-
-
-{----------- BOILERPLATE -----------}
-
-data LL 
-
-type instance A.IdFamily  LL = ()
-type instance A.IntFamily LL = ()
-type instance A.AddFamily LL = (Set Ident, Set Ident)
-type instance A.AppFamily LL = (Set Ident, Set Ident)
-type instance A.AbsFamily LL = Set Ident
-type instance A.LetFamily LL = Set Ident
-type instance A.ExpFamily LL = Void
-
-pattern LLId ident = A.EId () ident
-pattern LLInt int = A.EInt () int
-pattern LLAdd s1 s2 e1 e2 = A.EAdd (s1,s2) e1 e2
-pattern LLApp s1 s2 e1 e2 = A.EApp (s1,s2) e1 e2
-pattern LLAbs s i e = A.EAbs s i e
-pattern LLLet s binds e = A.ELet s binds e
-pattern LLExp v e = A.EExp v e
-
-{-
-
-data AnnExp' = AId Ident
-             | AInt Integer
-             | AApp (Set Ident, AnnExp') (Set Ident, AnnExp')
-             | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') 
-             | AAbs Ident   (Set Ident, AnnExp') 
-             | ALet [ABind] (Set Ident, AnnExp') 
-             deriving Show
-
--}
diff --git a/src/Main.hs b/src/Main.hs
index d367bc1..e55afe9 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,7 +3,6 @@ module Main where
 
 import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
-import           LambdaLifter       (lambdaLift)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
 
@@ -17,17 +16,4 @@ main = getArgs >>= \case
        putStrLn "SYNTAX ERROR"
        putStrLn err
        exitFailure
-      Right prg -> do
-        putStrLn "-- Parse"
-        putStrLn $ printTree prg
-        -- putStrLn "\n-- Abstract"
-        -- putStrLn . printTree $ (abstract . freeVars) prg
-        -- putStrLn "\n-- Rename"
-        -- putStrLn . printTree $ (rename . abstract . freeVars) prg
-        putStrLn "\n-- Lamda lifter"
-        putStrLn . printTree $ lambdaLift prg
-        putStrLn ""
-        exitSuccess
-
-
-
+      Right prg -> putStrLn "NO SYNTAX ERROR"
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
new file mode 100644
index 0000000..8d3fa1c
--- /dev/null
+++ b/src/Renamer/Renamer.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Renamer.Renamer (rename) where
+
+import           Control.Applicative  (Applicative (liftA2))
+import           Control.Monad.Except (MonadError (throwError))
+import           Control.Monad.RWS    (MonadState, gets, modify)
+import           Control.Monad.State  (StateT, evalStateT)
+import           Data.Set             (Set)
+import qualified Data.Set             as Set
+import           Grammar.Abs
+import           Grammar.ErrM         (Err)
+import           Grammar.Print        (printTree)
+import qualified Renamer.RenamerIr            as R
+
+
+data Cxt = Cxt
+  { uniques    :: [(Ident, R.Unique)]
+  , nextUnique :: R.Unique
+  , sig        :: Set Ident
+  }
+
+initCxt :: Cxt
+initCxt = Cxt
+  { uniques    = []
+  , nextUnique = R.Unique 0
+  , sig        = mempty
+  }
+
+newtype Rn a = Rn { runRn :: StateT Cxt Err a }
+  deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
+
+rename :: Program -> Err R.Program
+rename p = evalStateT (runRn $ renameProgram p) initCxt
+
+renameProgram :: Program -> Rn R.Program
+renameProgram (Program ds (Main e)) = do
+  ds' <- mapM renameDef ds
+  e'  <- renameExp e
+  pure $ R.Program ds' (R.Main e')
+
+renameDef :: Def -> Rn R.Def
+renameDef = \case
+  DExp x t _ xs e -> do
+    newSig x
+    xs' <- mapM newUnique xs
+    e'  <- renameExp e
+    let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t
+    pure . R.DBind $ R.Bind x t e''
+
+renameExp :: Exp -> Rn R.Exp
+renameExp = \case
+  EId x      -> R.EId <$> findBind x
+  EInt i     -> pure $ R.EInt i
+  EApp e e1  -> liftA2 R.EApp (renameExp e) $ renameExp e1
+  EAdd e e1  -> liftA2 R.EAdd (renameExp e) $ renameExp e1
+  EAbs x t e -> do
+    x' <- newUnique x
+    e' <- renameExp e
+    pure $ R.EAbs x' t e'
+
+findBind :: Ident -> Rn R.Name
+findBind x = lookupUnique x >>= \case
+    Just u  -> pure $ R.Nu u
+    Nothing -> gets (Set.member x . sig) >>= \case
+      False -> throwError ("Unbound variable " ++ printTree x)
+      True  -> pure $ R.Ni x
+
+newUnique :: Ident -> Rn R.Unique
+newUnique x = do
+  u <- gets nextUnique
+  modify $ \env -> env { nextUnique = succ u
+                       , uniques = (x, u) : env.uniques
+                       }
+  pure u
+
+newSig :: Ident -> Rn ()
+newSig x = modify $ \cxt -> cxt { sig = Set.insert x cxt.sig}
+
+lookupUnique :: Ident -> Rn (Maybe R.Unique)
+lookupUnique x = lookup x <$> gets uniques
+
+fromTree :: Type -> [Type]
+fromTree = fromTree' []
+
+fromTree' :: [Type] -> Type -> [Type]
+fromTree' acc = \case
+  TFun t t1 -> acc ++ [t] ++ fromTree t1
+  other     -> other : acc
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
new file mode 100644
index 0000000..e3c4cce
--- /dev/null
+++ b/src/Renamer/RenamerIr.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+
+module Renamer.RenamerIr where
+
+import           Grammar.Abs   (Ident, Type (..))
+import           Grammar.Print
+
+
+data Program = Program [Def] Main
+  deriving (Eq, Ord, Show, Read)
+
+newtype Main = Main Exp
+  deriving (Eq, Ord, Show, Read)
+
+
+newtype Def = DBind Bind
+  deriving (Eq, Ord, Show, Read)
+
+data Name = Nu Unique | Ni Ident deriving (Ord, Show, Eq, Read)
+
+newtype Unique = Unique Int deriving (Enum, Eq, Read, Ord)
+instance Show Unique where show (Unique i) = "x" ++ show i
+
+data Exp
+    = EId  Name
+    | EInt Integer
+    | EApp Exp Exp
+    | EAdd Exp Exp
+    | EAbs Unique Type Exp
+  deriving (Eq, Ord, Show, Read)
+
+
+data Bind = Bind Ident Type Exp
+  deriving (Eq, Ord, Show, Read)
+
+
+instance Print Program where
+  prt i = \case
+    Program defs main -> prPrec i 0 (concatD [prt 0 defs, prt 0 main])
+
+
+instance Print Def where
+  prt i (DBind b) = prPrec i 0 $ concatD [prt 0 b, doc (showString ";")]
+
+instance Print Bind where
+  prt i = \case
+    Bind x t e -> prPrec i 0 $ concatD
+      [ prt 0 x
+      , doc (showString ":")
+      , prt 0 t
+      , doc (showString "=")
+      , prt 0 e]
+
+instance Print [Def] where
+  prt _ []     = concatD []
+  prt _ (x:xs) = concatD [prt 0 x, prt 0 xs]
+
+
+instance Print Main where
+  prt i = \case
+    Main exp -> prPrec i 0 $ concatD
+     [ doc (showString "main")
+     , doc (showString "=")
+     , prt 0 exp
+     , doc (showString ";")
+     ]
+
+instance Print Exp where
+  prt i = \case
+    EId u -> prPrec i 3 (concatD [prt 0 u])
+    EInt n -> prPrec i 3 (concatD [prt 0 n])
+    EApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
+    EAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
+    EAbs u t e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 u, doc (showString ":"), prt 0 t, doc (showString "."), prt 0 e])
+
+
+instance Print Name where
+  prt _ = \case
+    Ni i -> prt 0 i
+    Nu u -> prt 0 u
+
+instance Print Unique where
+  prt _ = doc . showString . show
diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs
deleted file mode 100644
index e69de29..0000000
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
new file mode 100644
index 0000000..c98ad66
--- /dev/null
+++ b/src/TypeChecker/TypeChecker.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TypeChecker.TypeChecker where
+
+import Control.Monad (when)
+import Control.Monad.Except (throwError)
+import Control.Monad.Reader (ReaderT)
+import qualified Control.Monad.Reader as R
+import Control.Monad.Writer (WriterT)
+import qualified Control.Monad.Writer as W
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Set (Set)
+import qualified Data.Set as S
+
+import qualified Grammar.Abs as Old
+import Grammar.ErrM (Err)
+
+import TypeChecker.TypeCheckerIr
+
+data Ctx = Ctx
+    { env :: [Map Ident Type]
+    , sig :: Map Ident Bind
+    , typs :: Set Ident
+    }
+
+type Check a = WriterT String (ReaderT Ctx Err) a
+
+inferExp :: Old.Exp -> Check Type
+inferExp = \case
+    Old.EAnn e t -> do
+        infT <- inferExp e
+        when (t /= infT) (throwError $ show (AnnotatedMismatch (show e) (show t) (show infT)))
+        return infT
+    Old.EConst c -> case c of
+        (CInt i) -> return (TMono $ Old.Ident "Int")
+        (CStr s) -> return (TMono $ Old.Ident "String")
+    Old.EId i -> lookupEnv i
+    Old.EAdd e1 e2 -> do
+        t1 <- inferExp e1
+        t2 <- inferExp e2
+        case (t1, t2) of
+            (TMono (Old.Ident "Int"), TMono (Old.Ident "Int")) -> return t1
+            _ -> throwError $ show (NotNumber (show t1))
+        return t1
+
+    -- This is wrong currently. (a -> b) should be able to take String
+    Old.EApp e1 e2 -> do
+        inferExp e1 >>= \case
+            TFun mono@(TMono i) t2 -> do
+                t <- inferExp e2
+                when (t /= mono) (throwError $ show $ TypeMismatch (show t) (show mono))
+                return t
+
+            -- Not entirely correct. Should sometimes be able to provide mono types where poly expected.
+            -- i.e id : a -> a; id "string"
+            TFun poly@(TPoly f) t2 -> do
+                t <- inferExp e2
+                when (t /= poly) (throwError $ show (TypeMismatch (show t) (show poly)))
+                return t
+            t -> throwError $ show (NotFunction "Expected a function, but got:" (show t))
+
+    Old.EAbs i e -> undefined
+
+    Old.ELet b e -> undefined
+
+-- Aux
+
+lookupEnv :: Ident -> Check Type
+lookupEnv i =
+    R.asks env >>= \case
+        [] -> throwError $ show (UnboundVar "Variable not found" (show i))
+        xs -> lookupEnv' i xs
+  where
+    lookupEnv' :: Ident -> [Map Ident Type] -> Check Type
+    lookupEnv' i [] = throwError $ show (UnboundVar "Variable not found" (show i))
+    lookupEnv' i (x : xs) = case M.lookup i x of
+        Just t -> return t
+        Nothing -> lookupEnv' i xs
+
+lookupSig :: Ident -> Check Bind
+lookupSig b =
+    R.asks sig >>= \m -> case M.lookup b m of
+        Nothing -> undefined
+        Just b -> return b
+
+insertEnv :: Ident -> Type -> Ctx -> Ctx
+insertEnv i t c =
+    case env c of
+        [] -> Ctx{env = [M.insert i t mempty]}
+        (x : xs) -> Ctx{env = M.insert i t x : xs}
+
+data Error
+    = TypeMismatch String String
+    | NotNumber String
+    | FunctionTypeMismatch String String String
+    | NotFunction String String
+    | UnboundVar String String
+    | AnnotatedMismatch String String String
+    | Default String
+
+showErr :: Error -> String
+showErr = \case
+    TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found]
+    NotNumber mess -> "Expected a number, but got: " <> mess
+    NotFunction mess func -> mess <> ": " <> func
+    FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found]
+    UnboundVar mess var -> mess <> ": " <> var
+    AnnotatedMismatch expression expected found ->
+        unwords
+            [ "Expression"
+            , expression
+            , "expected type"
+            , expected
+            , "but was inferred as type"
+            , found
+            ]
+    Default mess -> mess
+
+instance Show Error where
+    show = showErr
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
new file mode 100644
index 0000000..3bca405
--- /dev/null
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TypeChecker.TypeCheckerIr
+    ( Program(..)
+    , Bind(..)
+    , Ident
+    , Type(..)
+    , Const(..)
+    , Exp(..)
+    )
+        where
+
+import Grammar.Abs (Program(..), Bind(..), Ident, Type(..), Const(..))
+
+data Exp
+    = EAnn Exp Type
+    | EId Ident Type
+    | EConst Const Type
+    | EApp Exp Exp Type
+    | EAdd Exp Exp Type
+    | EAbs Ident Exp Type
+  deriving (Eq, Ord, Show, Read)
diff --git a/test_program b/test_program
new file mode 100644
index 0000000..4a7b634
--- /dev/null
+++ b/test_program
@@ -0,0 +1 @@
+main = \x. x + (3 : Int)

From c10d7703ad8e5bb3634b51f8aaf018b01dd5e85c Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 13 Feb 2023 19:03:06 +0100
Subject: [PATCH 19/71] Progression on type checker ;)

---
 Grammar.cf                       |  11 +-
 src/Main.hs                      |  11 +-
 src/TypeChecker/TypeChecker.hs   | 172 +++++++++++++++++++------------
 src/TypeChecker/TypeCheckerIr.hs |  12 +--
 test_program                     |   2 +-
 5 files changed, 126 insertions(+), 82 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index b58dbea..45021c1 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -7,16 +7,19 @@ EAnn.   Exp5 ::= Exp5 ":" Type ;
 EId.    Exp4 ::= Ident;
 EConst. Exp4 ::= Const;
 EApp.   Exp3 ::= Exp3 Exp4;
-ELet.   Exp2 ::= "let" Bind "in" Exp; 
 EAdd.   Exp1 ::= Exp1 "+" Exp2;
+ELet.   Exp ::= "let" Ident "=" Exp "in" Exp; 
 EAbs.   Exp  ::= "\\" Ident "." Exp;
 
 CInt. Const ::= Integer ;
 CStr. Const ::= String ;
 
-TMono. Type1 ::= Ident ;
-TPoly. Type1 ::= Ident ;
-TFun. Type  ::= Type1 "->" Type ;
+TMono. Type1 ::= UIdent ;
+TPoly. Type1 ::= LIdent ;
+TArrow. Type ::= Type "->" Type1 ;
+
+token UIdent (upper (letter | digit | '_')*) ;
+token LIdent (lower (letter | digit | '_')*) ;
 
 separator Bind ";";
 separator Ident " ";
diff --git a/src/Main.hs b/src/Main.hs
index e55afe9..27802b7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,6 +5,7 @@ import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
+import TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
 main = getArgs >>= \case
@@ -16,4 +17,12 @@ main = getArgs >>= \case
        putStrLn "SYNTAX ERROR"
        putStrLn err
        exitFailure
-      Right prg -> putStrLn "NO SYNTAX ERROR"
+      Right prg -> case typecheck prg of
+        Right prg -> do
+            putStrLn "TYPE CHECK SUCCESSFUL"
+            putStrLn . show $ prg
+        Left err -> do
+            putStrLn "TYPE CHECK ERROR"
+            putStrLn . show $ err
+            exitFailure
+
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index c98ad66..9c3ac70 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,14 +1,18 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings #-}
 
-module TypeChecker.TypeChecker where
+module TypeChecker.TypeChecker (typecheck) where
+
+import Control.Monad (when, void)
+import Control.Monad.Except (ExceptT, throwError, runExceptT)
 
-import Control.Monad (when)
-import Control.Monad.Except (throwError)
 import Control.Monad.Reader (ReaderT)
 import qualified Control.Monad.Reader as R
+
 import Control.Monad.Writer (WriterT)
 import qualified Control.Monad.Writer as W
 
+import Data.Functor.Identity (Identity, runIdentity)
+
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Set (Set)
@@ -24,66 +28,88 @@ data Ctx = Ctx
     , sig :: Map Ident Bind
     , typs :: Set Ident
     }
+    deriving Show
 
-type Check a = WriterT String (ReaderT Ctx Err) a
+type Check = ReaderT Ctx (ExceptT Error Identity)
+
+initEnv :: Ctx
+initEnv =
+    Ctx { env = mempty
+        , sig = mempty
+        , typs = mempty
+        }
+
+run :: Check Type -> Either Error Type
+run = runIdentity . runExceptT . flip R.runReaderT initEnv
+
+typecheck :: Old.Program -> Either Error ()
+typecheck = runIdentity . runExceptT . flip R.runReaderT initEnv . inferPrg
+
+inferPrg :: Old.Program -> Check ()
+inferPrg (Program [x]) = void $ inferBind x
+
+inferBind :: Old.Bind -> Check ()
+inferBind (Bind _ _ e) = void $ inferExp e
 
 inferExp :: Old.Exp -> Check Type
 inferExp = \case
+
+    Old.EId i -> undefined
+
     Old.EAnn e t -> do
         infT <- inferExp e
-        when (t /= infT) (throwError $ show (AnnotatedMismatch (show e) (show t) (show infT)))
+        when (t /= infT) (throwError AnnotatedMismatch)
         return infT
+
     Old.EConst c -> case c of
-        (CInt i) -> return (TMono $ Old.Ident "Int")
-        (CStr s) -> return (TMono $ Old.Ident "String")
-    Old.EId i -> lookupEnv i
+        (Old.CInt i) -> return (TMono $ UIdent "Int")
+        (Old.CStr s) -> return (TMono $ UIdent "String")
+
     Old.EAdd e1 e2 -> do
         t1 <- inferExp e1
         t2 <- inferExp e2
         case (t1, t2) of
-            (TMono (Old.Ident "Int"), TMono (Old.Ident "Int")) -> return t1
-            _ -> throwError $ show (NotNumber (show t1))
+            (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return t1
+            _ -> throwError NotNumber
         return t1
 
-    -- This is wrong currently. (a -> b) should be able to take String
     Old.EApp e1 e2 -> do
         inferExp e1 >>= \case
-            TFun mono@(TMono i) t2 -> do
+            TArrow mono@(TMono i) t2 -> do
                 t <- inferExp e2
-                when (t /= mono) (throwError $ show $ TypeMismatch (show t) (show mono))
-                return t
+                when (t /= mono) (throwError TypeMismatch)
+                return t2
 
-            -- Not entirely correct. Should sometimes be able to provide mono types where poly expected.
-            -- i.e id : a -> a; id "string"
-            TFun poly@(TPoly f) t2 -> do
-                t <- inferExp e2
-                when (t /= poly) (throwError $ show (TypeMismatch (show t) (show poly)))
-                return t
-            t -> throwError $ show (NotFunction "Expected a function, but got:" (show t))
+            TArrow poly@(TPoly f) t2 -> do
+                t <- inferExp e2 
+                when (not $ t `subtype` t) (throwError TypeMismatch)
+                return t2
 
-    Old.EAbs i e -> undefined
+-- This is not entirely correct. The assumed type can change.
+    Old.EAbs i e -> do
+        let assume = (TPoly "a")
+        infT <- R.local (insertEnv i assume) (inferExp e)
+        return (TArrow assume infT)
 
-    Old.ELet b e -> undefined
+    Old.ELet i e1 e2 -> undefined
 
 -- Aux
 
-lookupEnv :: Ident -> Check Type
-lookupEnv i =
-    R.asks env >>= \case
-        [] -> throwError $ show (UnboundVar "Variable not found" (show i))
-        xs -> lookupEnv' i xs
-  where
-    lookupEnv' :: Ident -> [Map Ident Type] -> Check Type
-    lookupEnv' i [] = throwError $ show (UnboundVar "Variable not found" (show i))
-    lookupEnv' i (x : xs) = case M.lookup i x of
-        Just t -> return t
-        Nothing -> lookupEnv' i xs
+subtype :: Type -> Type -> Bool
+subtype (TMono t1) (TMono t2) = t1 == t2
+subtype (TMono t1) (TPoly t2) = True
+subtype (TPoly t2) (TMono t1) = False
+subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4
 
-lookupSig :: Ident -> Check Bind
-lookupSig b =
-    R.asks sig >>= \m -> case M.lookup b m of
-        Nothing -> undefined
-        Just b -> return b
+lookupEnv :: Ident -> Ctx -> Maybe Type
+lookupEnv i c = case env c of
+    [] -> Nothing
+    x : xs -> case M.lookup i x of
+            Nothing -> lookupEnv i (Ctx { env = xs })
+            Just x -> Just x
+
+lookupSig :: Ident -> Ctx -> Maybe Bind
+lookupSig i = M.lookup i . sig
 
 insertEnv :: Ident -> Type -> Ctx -> Ctx
 insertEnv i t c =
@@ -92,31 +118,45 @@ insertEnv i t c =
         (x : xs) -> Ctx{env = M.insert i t x : xs}
 
 data Error
-    = TypeMismatch String String
-    | NotNumber String
-    | FunctionTypeMismatch String String String
-    | NotFunction String String
-    | UnboundVar String String
-    | AnnotatedMismatch String String String
-    | Default String
+    = TypeMismatch
+    | NotNumber
+    | FunctionTypeMismatch
+    | NotFunction
+    | UnboundVar
+    | AnnotatedMismatch
+    | Default
+    deriving Show
 
-showErr :: Error -> String
-showErr = \case
-    TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found]
-    NotNumber mess -> "Expected a number, but got: " <> mess
-    NotFunction mess func -> mess <> ": " <> func
-    FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found]
-    UnboundVar mess var -> mess <> ": " <> var
-    AnnotatedMismatch expression expected found ->
-        unwords
-            [ "Expression"
-            , expression
-            , "expected type"
-            , expected
-            , "but was inferred as type"
-            , found
-            ]
-    Default mess -> mess
+-- showErr :: Error -> String
+-- showErr = \case
+--     TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found]
+--     NotNumber mess -> "Expected a number, but got: " <> mess
+--     NotFunction mess func -> mess <> ": " <> func
+--     FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found]
+--     UnboundVar mess var -> mess <> ": " <> var
+--     AnnotatedMismatch expression expected found ->
+--         unwords
+--             [ "Expression"
+--             , expression
+--             , "expected type"
+--             , expected
+--             , "but was inferred as type"
+--             , found
+--             ]
+--     Default mess -> mess
 
-instance Show Error where
-    show = showErr
+
+-- Tests
+
+number :: Old.Exp
+number = Old.EConst (CInt 3)
+
+lambda :: Old.Exp
+lambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3)))
+
+apply :: Old.Exp
+apply = Old.EApp lambda (Old.EConst (Old.CInt 3))
+
+{-# WARNING todo "TODO IN CODE" #-}
+todo :: a
+todo = error "TODO in code"
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 3bca405..7fb93fe 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,16 +1,8 @@
 {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr
-    ( Program(..)
-    , Bind(..)
-    , Ident
-    , Type(..)
-    , Const(..)
-    , Exp(..)
-    )
-        where
+module TypeChecker.TypeCheckerIr (module Grammar.Abs, Exp) where
 
-import Grammar.Abs (Program(..), Bind(..), Ident, Type(..), Const(..))
+import Grammar.Abs (Program(..), Ident(..), Bind(..), Const(..), Type(..), UIdent(..), LIdent(..))
 
 data Exp
     = EAnn Exp Type
diff --git a/test_program b/test_program
index 4a7b634..14077bd 100644
--- a/test_program
+++ b/test_program
@@ -1 +1 @@
-main = \x. x + (3 : Int)
+test y = y

From 200a9e57ed5d8fb8f2d019fc0e218a0b480172cd Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 14 Feb 2023 10:12:38 +0100
Subject: [PATCH 20/71] Fixed EId, more work on other expressions needed

---
 Grammar.cf                     | 24 +++++++--------
 language.cabal                 |  2 +-
 src/TypeChecker/TypeChecker.hs | 55 +++++++++++++++++++++++++---------
 test_program                   |  2 +-
 4 files changed, 55 insertions(+), 28 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index 45021c1..a570950 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,15 +1,15 @@
 
-Program. Program ::= [Bind];
+Program. Program ::= [Bind] ;
 
-Bind. Bind ::= Ident [Ident] "=" Exp;
+Bind. Bind ::= Ident [Ident] "=" Exp ;
 
 EAnn.   Exp5 ::= Exp5 ":" Type ;
-EId.    Exp4 ::= Ident;
-EConst. Exp4 ::= Const;
-EApp.   Exp3 ::= Exp3 Exp4;
-EAdd.   Exp1 ::= Exp1 "+" Exp2;
-ELet.   Exp ::= "let" Ident "=" Exp "in" Exp; 
-EAbs.   Exp  ::= "\\" Ident "." Exp;
+EId.    Exp4 ::= Ident ;
+EConst. Exp4 ::= Const ;
+EApp.   Exp3 ::= Exp3 Exp4 ;
+EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
+ELet.   Exp ::= "let" Ident "=" Exp "in" Exp ; 
+EAbs.   Exp  ::= "\\" Ident "." Exp ;
 
 CInt. Const ::= Integer ;
 CStr. Const ::= String ;
@@ -21,11 +21,11 @@ TArrow. Type ::= Type "->" Type1 ;
 token UIdent (upper (letter | digit | '_')*) ;
 token LIdent (lower (letter | digit | '_')*) ;
 
-separator Bind ";";
+separator Bind ";" ;
 separator Ident " ";
 
 coercions Type 1 ;
-coercions Exp 5;
+coercions Exp 5 ;
 
-comment "--";
-comment "{-" "-}";
+comment "--" ;
+comment "{-" "-}" ;
diff --git a/language.cabal b/language.cabal
index d254e3e..0f5aec2 100644
--- a/language.cabal
+++ b/language.cabal
@@ -17,7 +17,7 @@ extra-source-files:
 
 
 common warnings
-    ghc-options: -W
+    ghc-options: -Wdefault
 
 executable language
     import:           warnings
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 9c3ac70..36ec739 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, OverloadedStrings #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot #-}
 
 module TypeChecker.TypeChecker (typecheck) where
 
@@ -18,6 +18,8 @@ import qualified Data.Map as M
 import Data.Set (Set)
 import qualified Data.Set as S
 
+import Data.Bool (bool)
+
 import qualified Grammar.Abs as Old
 import Grammar.ErrM (Err)
 
@@ -25,7 +27,7 @@ import TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx
     { env :: [Map Ident Type]
-    , sig :: Map Ident Bind
+    , sigs :: Map Ident Type
     , typs :: Set Ident
     }
     deriving Show
@@ -35,7 +37,7 @@ type Check = ReaderT Ctx (ExceptT Error Identity)
 initEnv :: Ctx
 initEnv =
     Ctx { env = mempty
-        , sig = mempty
+        , sigs = mempty
         , typs = mempty
         }
 
@@ -54,7 +56,14 @@ inferBind (Bind _ _ e) = void $ inferExp e
 inferExp :: Old.Exp -> Check Type
 inferExp = \case
 
-    Old.EId i -> undefined
+    Old.EId i -> do
+        ctx <- R.ask
+        case lookupEnv i ctx of
+          Just t -> return t
+          Nothing -> case lookupSigs i ctx of
+                       Just t -> return t
+                       Nothing -> throwError UnboundVar
+        
 
     Old.EAnn e t -> do
         infT <- inferExp e
@@ -68,8 +77,12 @@ inferExp = \case
     Old.EAdd e1 e2 -> do
         t1 <- inferExp e1
         t2 <- inferExp e2
+        let int = TMono (UIdent "Int")
         case (t1, t2) of
-            (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return t1
+            (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return int
+            (_, TMono (UIdent "Int")) -> return int
+            (TMono (UIdent "Int"), _) -> return int
+            (TPoly (LIdent x), TPoly (LIdent y)) -> bool (throwError TypeMismatch) (return int) (x==y)
             _ -> throwError NotNumber
         return t1
 
@@ -95,27 +108,39 @@ inferExp = \case
 
 -- Aux
 
+-- Double check this function. It's bad and maybe wrong
 subtype :: Type -> Type -> Bool
 subtype (TMono t1) (TMono t2) = t1 == t2
 subtype (TMono t1) (TPoly t2) = True
 subtype (TPoly t2) (TMono t1) = False
 subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4
+subtype _ _                   = False
 
 lookupEnv :: Ident -> Ctx -> Maybe Type
 lookupEnv i c = case env c of
     [] -> Nothing
     x : xs -> case M.lookup i x of
-            Nothing -> lookupEnv i (Ctx { env = xs })
+            Nothing -> lookupEnv i (Ctx { env = xs
+                                        , sigs = c.sigs
+                                        , typs = c.typs
+                                        })
             Just x -> Just x
 
-lookupSig :: Ident -> Ctx -> Maybe Bind
-lookupSig i = M.lookup i . sig
+lookupSigs :: Ident -> Ctx -> Maybe Type
+lookupSigs i = M.lookup i . sigs
 
 insertEnv :: Ident -> Type -> Ctx -> Ctx
 insertEnv i t c =
     case env c of
-        [] -> Ctx{env = [M.insert i t mempty]}
-        (x : xs) -> Ctx{env = M.insert i t x : xs}
+        [] -> Ctx { env = [M.insert i t mempty]
+                  , sigs = c.sigs
+                  , typs = c.typs
+                  }
+
+        (x : xs) -> Ctx { env = M.insert i t x : xs
+                        , sigs = c.sigs
+                        , typs = c.typs
+                        }
 
 data Error
     = TypeMismatch
@@ -145,17 +170,19 @@ data Error
 --             ]
 --     Default mess -> mess
 
-
 -- Tests
 
 number :: Old.Exp
 number = Old.EConst (CInt 3)
 
-lambda :: Old.Exp
-lambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3)))
+aToInt :: Old.Exp
+aToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3)))
+
+intToInt :: Old.Exp
+intToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EConst (Old.CInt 3)))
 
 apply :: Old.Exp
-apply = Old.EApp lambda (Old.EConst (Old.CInt 3))
+apply = Old.EApp aToInt (Old.EConst (Old.CInt 3))
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
diff --git a/test_program b/test_program
index 14077bd..a17b924 100644
--- a/test_program
+++ b/test_program
@@ -1 +1 @@
-test y = y
+main = 3;

From 53314551f53c4fbd647cd6970465425dfa1087b3 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 14 Feb 2023 12:56:07 +0100
Subject: [PATCH 21/71] A bit cleaner code. A renamer is the focus to make the
 tc simpler

---
 .gitignore                     |   2 +-
 src/TypeChecker/TypeChecker.hs | 133 +++++++++++++++------------------
 2 files changed, 62 insertions(+), 73 deletions(-)

diff --git a/.gitignore b/.gitignore
index 5112877..193a11d 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,4 +3,4 @@ dist-newstyle
 *.x
 *.bak
 src/Grammar
-/language
+language
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 36ec739..0704832 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -4,48 +4,49 @@ module TypeChecker.TypeChecker (typecheck) where
 
 import Control.Monad (when, void)
 import Control.Monad.Except (ExceptT, throwError, runExceptT)
-
 import Control.Monad.Reader (ReaderT)
 import qualified Control.Monad.Reader as R
-
 import Control.Monad.Writer (WriterT)
 import qualified Control.Monad.Writer as W
-
+import Control.Monad.State (StateT)
+import qualified Control.Monad.State as St
 import Data.Functor.Identity (Identity, runIdentity)
-
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Set (Set)
 import qualified Data.Set as S
-
 import Data.Bool (bool)
-
 import qualified Grammar.Abs as Old
 import Grammar.ErrM (Err)
 
 import TypeChecker.TypeCheckerIr
 
-data Ctx = Ctx
-    { env :: [Map Ident Type]
-    , sigs :: Map Ident Type
-    , typs :: Set Ident
-    }
+data Ctx = Ctx { env :: Map Ident Type
+               , sigs :: Map Ident Type
+               }
     deriving Show
 
-type Check = ReaderT Ctx (ExceptT Error Identity)
+{-
+
+The type checker will assume we first rename all variables to unique name, as to not
+have to care about scoping. It significantly improves the quality of life of the
+programmer.
+
+-}
+
+type Check = StateT (Map Ident Type) (ReaderT Ctx (ExceptT Error Identity))
 
 initEnv :: Ctx
 initEnv =
     Ctx { env = mempty
         , sigs = mempty
-        , typs = mempty
         }
 
 run :: Check Type -> Either Error Type
-run = runIdentity . runExceptT . flip R.runReaderT initEnv
+run = runIdentity . runExceptT . flip R.runReaderT initEnv . flip St.evalStateT mempty
 
 typecheck :: Old.Program -> Either Error ()
-typecheck = runIdentity . runExceptT . flip R.runReaderT initEnv . inferPrg
+typecheck = todo
 
 inferPrg :: Old.Program -> Check ()
 inferPrg (Program [x]) = void $ inferBind x
@@ -56,15 +57,19 @@ inferBind (Bind _ _ e) = void $ inferExp e
 inferExp :: Old.Exp -> Check Type
 inferExp = \case
 
+    -- TODO: Fix bound variable lookup
     Old.EId i -> do
-        ctx <- R.ask
-        case lookupEnv i ctx of
+        st <- St.get 
+        case lookupBound i st of
           Just t -> return t
-          Nothing -> case lookupSigs i ctx of
-                       Just t -> return t
-                       Nothing -> throwError UnboundVar
+          Nothing -> do
+            ctx <- R.ask
+            case lookupEnv i ctx of
+              Just t -> return t
+              Nothing -> case lookupSigs i ctx of
+                           Just t -> return t
+                           Nothing -> throwError UnboundVar
         
-
     Old.EAnn e t -> do
         infT <- inferExp e
         when (t /= infT) (throwError AnnotatedMismatch)
@@ -75,17 +80,15 @@ inferExp = \case
         (Old.CStr s) -> return (TMono $ UIdent "String")
 
     Old.EAdd e1 e2 -> do
-        t1 <- inferExp e1
-        t2 <- inferExp e2
-        let int = TMono (UIdent "Int")
-        case (t1, t2) of
-            (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return int
-            (_, TMono (UIdent "Int")) -> return int
-            (TMono (UIdent "Int"), _) -> return int
-            (TPoly (LIdent x), TPoly (LIdent y)) -> bool (throwError TypeMismatch) (return int) (x==y)
-            _ -> throwError NotNumber
-        return t1
+        let int = TMono "Int"
+        updateBound e1 int
+        updateBound e2 int
+        inf1 <- inferExp e1
+        inf2 <- inferExp e2
+        when (not $ isInt inf1 && isInt inf2) (throwError TypeMismatch)
+        return int
 
+    -- Incomplete and probably wrong
     Old.EApp e1 e2 -> do
         inferExp e1 >>= \case
             TArrow mono@(TMono i) t2 -> do
@@ -98,13 +101,16 @@ inferExp = \case
                 when (not $ t `subtype` t) (throwError TypeMismatch)
                 return t2
 
--- This is not entirely correct. The assumed type can change.
+    -- This is not entirely correct. The assumed type can change.
     Old.EAbs i e -> do
         let assume = (TPoly "a")
+        St.modify (M.insert i assume)
         infT <- R.local (insertEnv i assume) (inferExp e)
-        return (TArrow assume infT)
+        St.gets (M.lookup i) >>= \case
+            Nothing -> todo
+            Just x -> return (TArrow x infT)
 
-    Old.ELet i e1 e2 -> undefined
+    Old.ELet i e1 e2 -> todo
 
 -- Aux
 
@@ -117,30 +123,31 @@ subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4
 subtype _ _                   = False
 
 lookupEnv :: Ident -> Ctx -> Maybe Type
-lookupEnv i c = case env c of
-    [] -> Nothing
-    x : xs -> case M.lookup i x of
-            Nothing -> lookupEnv i (Ctx { env = xs
-                                        , sigs = c.sigs
-                                        , typs = c.typs
-                                        })
-            Just x -> Just x
+lookupEnv i = M.lookup i . env
 
 lookupSigs :: Ident -> Ctx -> Maybe Type
 lookupSigs i = M.lookup i . sigs
 
 insertEnv :: Ident -> Type -> Ctx -> Ctx
-insertEnv i t c =
-    case env c of
-        [] -> Ctx { env = [M.insert i t mempty]
-                  , sigs = c.sigs
-                  , typs = c.typs
-                  }
+insertEnv i t c = Ctx { env = M.insert i t c.env
+                      , sigs = c.sigs
+                      }
 
-        (x : xs) -> Ctx { env = M.insert i t x : xs
-                        , sigs = c.sigs
-                        , typs = c.typs
-                        }
+updateBound :: Old.Exp -> Type -> Check ()
+updateBound (Old.EId i) t = St.modify (M.insert i t)
+updateBound _ _           = return ()
+
+isBound :: Old.Exp -> Check Bool
+isBound (Old.EId i) = (M.member i) <$> St.get
+isBound _           = return False
+
+lookupBound :: Ident -> Map Ident Type -> Maybe Type
+lookupBound = M.lookup
+
+isInt :: Type -> Bool
+isInt (TMono "Int") = True
+isInt (TPoly _)     = True
+isInt _             = False
 
 data Error
     = TypeMismatch
@@ -152,24 +159,6 @@ data Error
     | Default
     deriving Show
 
--- showErr :: Error -> String
--- showErr = \case
---     TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found]
---     NotNumber mess -> "Expected a number, but got: " <> mess
---     NotFunction mess func -> mess <> ": " <> func
---     FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found]
---     UnboundVar mess var -> mess <> ": " <> var
---     AnnotatedMismatch expression expected found ->
---         unwords
---             [ "Expression"
---             , expression
---             , "expected type"
---             , expected
---             , "but was inferred as type"
---             , found
---             ]
---     Default mess -> mess
-
 -- Tests
 
 number :: Old.Exp
@@ -181,8 +170,8 @@ aToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.ECons
 intToInt :: Old.Exp
 intToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EConst (Old.CInt 3)))
 
-apply :: Old.Exp
-apply = Old.EApp aToInt (Old.EConst (Old.CInt 3))
+addLambda :: Old.Exp
+addLambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EId $ Ident "x"))
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a

From 6218efac20481e794925bbd933eb4daa657b53cb Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 14 Feb 2023 16:44:38 +0100
Subject: [PATCH 22/71] Renamer done. It renames bound variables to numbers,
 converts let to lambda, and removes all variables from binds

---
 Grammar.cf                       |   8 +-
 language.cabal                   |   6 +-
 sample-programs/basic-2          |   1 -
 src/Main.hs                      |  10 +-
 src/Renamer/Renamer.hs           | 155 +++++++++++++++++--------------
 src/Renamer/RenamerIr.hs         | 119 +++++++++---------------
 src/TypeChecker/TypeChecker.hs   |   4 +-
 src/TypeChecker/TypeCheckerIr.hs |  25 +++--
 test_program                     |   5 +-
 9 files changed, 158 insertions(+), 175 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index a570950..21b563b 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -14,12 +14,12 @@ EAbs.   Exp  ::= "\\" Ident "." Exp ;
 CInt. Const ::= Integer ;
 CStr. Const ::= String ;
 
-TMono. Type1 ::= UIdent ;
-TPoly. Type1 ::= LIdent ;
+TMono. Type ::= "Mono" Ident ;
+TPoly. Type ::= "Poly" Ident ;
 TArrow. Type ::= Type "->" Type1 ;
 
-token UIdent (upper (letter | digit | '_')*) ;
-token LIdent (lower (letter | digit | '_')*) ;
+-- token Upper (upper (letter | digit | '_')*) ;
+-- token Lower (lower (letter | digit | '_')*) ;
 
 separator Bind ";" ;
 separator Ident " ";
diff --git a/language.cabal b/language.cabal
index 0f5aec2..0701df6 100644
--- a/language.cabal
+++ b/language.cabal
@@ -31,12 +31,10 @@ executable language
       Grammar.Print
       Grammar.Skel
       Grammar.ErrM
-      -- LambdaLifter
       TypeChecker.TypeChecker
       TypeChecker.TypeCheckerIr
-      -- Renamer.Renamer
-      -- Renamer.RenamerIr
-      -- Interpreter
+      Renamer.Renamer
+      Renamer.RenamerIr
 
     hs-source-dirs:   src
 
diff --git a/sample-programs/basic-2 b/sample-programs/basic-2
index 4b8ead0..f7d0807 100644
--- a/sample-programs/basic-2
+++ b/sample-programs/basic-2
@@ -1,4 +1,3 @@
 add x = \y. x+y;
 
 main = (\z. z+z) ((add 4) 6);
-
diff --git a/src/Main.hs b/src/Main.hs
index 27802b7..93b3edd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,6 +6,7 @@ import           Grammar.Print      (printTree)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
 import TypeChecker.TypeChecker (typecheck)
+import Renamer.Renamer (rename)
 
 main :: IO ()
 main = getArgs >>= \case
@@ -17,12 +18,11 @@ main = getArgs >>= \case
        putStrLn "SYNTAX ERROR"
        putStrLn err
        exitFailure
-      Right prg -> case typecheck prg of
+      Right prg -> case rename prg of
         Right prg -> do
-            putStrLn "TYPE CHECK SUCCESSFUL"
-            putStrLn . show $ prg
+            putStrLn "RENAME SUCCESSFUL"
+            putStrLn $ printTree prg
         Left err -> do
-            putStrLn "TYPE CHECK ERROR"
+            putStrLn "FAILED RENAMING"
             putStrLn . show $ err
             exitFailure
-
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 8d3fa1c..8f09a51 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -1,90 +1,101 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE LambdaCase, OverloadedRecordDot, OverloadedStrings #-}
 
 module Renamer.Renamer (rename) where
 
-import           Control.Applicative  (Applicative (liftA2))
-import           Control.Monad.Except (MonadError (throwError))
-import           Control.Monad.RWS    (MonadState, gets, modify)
-import           Control.Monad.State  (StateT, evalStateT)
-import           Data.Set             (Set)
-import qualified Data.Set             as Set
-import           Grammar.Abs
-import           Grammar.ErrM         (Err)
-import           Grammar.Print        (printTree)
-import qualified Renamer.RenamerIr            as R
+import Renamer.RenamerIr
+import Control.Monad.State
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.Functor.Identity (Identity, runIdentity)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Map (Map)
+import qualified Data.Map as M
 
+import Renamer.RenamerIr
+import qualified Grammar.Abs as Old
 
-data Cxt = Cxt
-  { uniques    :: [(Ident, R.Unique)]
-  , nextUnique :: R.Unique
-  , sig        :: Set Ident
-  }
+type Rename = StateT Ctx (ExceptT Error Identity)
 
-initCxt :: Cxt
-initCxt = Cxt
-  { uniques    = []
-  , nextUnique = R.Unique 0
-  , sig        = mempty
-  }
+data Ctx = Ctx { count :: Integer
+               , sig :: Set Ident
+               , env :: Map Ident Integer}
 
-newtype Rn a = Rn { runRn :: StateT Cxt Err a }
-  deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
+run :: Rename a -> Either Error a
+run = runIdentity . runExceptT . flip evalStateT initCtx
 
-rename :: Program -> Err R.Program
-rename p = evalStateT (runRn $ renameProgram p) initCxt
+initCtx :: Ctx
+initCtx = Ctx { count = 0
+              , sig = mempty
+              , env = mempty }
 
-renameProgram :: Program -> Rn R.Program
-renameProgram (Program ds (Main e)) = do
-  ds' <- mapM renameDef ds
-  e'  <- renameExp e
-  pure $ R.Program ds' (R.Main e')
+rename :: Old.Program -> Either Error RProgram
+rename = run . renamePrg
 
-renameDef :: Def -> Rn R.Def
-renameDef = \case
-  DExp x t _ xs e -> do
-    newSig x
-    xs' <- mapM newUnique xs
-    e'  <- renameExp e
-    let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t
-    pure . R.DBind $ R.Bind x t e''
+renamePrg :: Old.Program -> Rename RProgram
+renamePrg (Old.Program xs) = do
+    xs' <- mapM renameBind xs
+    return $ RProgram xs'
 
-renameExp :: Exp -> Rn R.Exp
+renameBind :: Old.Bind -> Rename RBind
+renameBind (Old.Bind i args e) = do
+    insertSig i
+    e' <- renameExp (makeLambda (reverse args) e)
+    return $ RBind i e'
+  where 
+    makeLambda :: [Ident] -> Old.Exp -> Old.Exp
+    makeLambda [] e = e
+    makeLambda (x:xs) e = makeLambda xs (Old.EAbs x e)
+
+renameExp :: Old.Exp -> Rename RExp
 renameExp = \case
-  EId x      -> R.EId <$> findBind x
-  EInt i     -> pure $ R.EInt i
-  EApp e e1  -> liftA2 R.EApp (renameExp e) $ renameExp e1
-  EAdd e e1  -> liftA2 R.EAdd (renameExp e) $ renameExp e1
-  EAbs x t e -> do
-    x' <- newUnique x
-    e' <- renameExp e
-    pure $ R.EAbs x' t e'
 
-findBind :: Ident -> Rn R.Name
-findBind x = lookupUnique x >>= \case
-    Just u  -> pure $ R.Nu u
-    Nothing -> gets (Set.member x . sig) >>= \case
-      False -> throwError ("Unbound variable " ++ printTree x)
-      True  -> pure $ R.Ni x
+    Old.EId i -> do
+        st <- get
+        case M.lookup i st.env of
+            Just n -> return $ RBound n i
+            Nothing -> case S.member i st.sig of
+                         True -> return $ RFree i
+                         False -> throwError $ UnboundVar (show i)
 
-newUnique :: Ident -> Rn R.Unique
-newUnique x = do
-  u <- gets nextUnique
-  modify $ \env -> env { nextUnique = succ u
-                       , uniques = (x, u) : env.uniques
-                       }
-  pure u
+    Old.EConst c -> return $ RConst c
 
-newSig :: Ident -> Rn ()
-newSig x = modify $ \cxt -> cxt { sig = Set.insert x cxt.sig}
+    Old.EAnn e t -> flip RAnn t <$> renameExp e
 
-lookupUnique :: Ident -> Rn (Maybe R.Unique)
-lookupUnique x = lookup x <$> gets uniques
+    Old.EApp e1 e2 -> RApp <$> renameExp e1 <*> renameExp e2
 
-fromTree :: Type -> [Type]
-fromTree = fromTree' []
+    Old.EAdd e1 e2 -> RAdd <$> renameExp e1 <*> renameExp e2
 
-fromTree' :: [Type] -> Type -> [Type]
-fromTree' acc = \case
-  TFun t t1 -> acc ++ [t] ++ fromTree t1
-  other     -> other : acc
+    -- Convert let-expressions to lambdas
+    Old.ELet i e1 e2 -> renameExp (Old.EApp (Old.EAbs i e2) e1)
+
+    Old.EAbs i e -> do
+        n <- cnt
+        ctx <- get
+        insertEnv i n
+        re <- renameExp e
+        return $ RAbs n i re
+
+-- | Get current count and increase it by one
+cnt :: Rename Integer
+cnt = do
+    st <- get
+    put (Ctx { count = succ st.count
+             , sig = st.sig
+             , env = st.env })
+    return st.count
+        
+insertEnv :: Ident -> Integer -> Rename ()
+insertEnv i n = do
+    c <- get
+    put ( Ctx { env = M.insert i n c.env , sig = c.sig , count = c.count} )
+
+insertSig :: Ident -> Rename ()
+insertSig i = do
+    c <- get
+    put ( Ctx { sig = S.insert i c.sig , env = c.env , count = c.count } )
+
+data Error = UnboundVar String
+
+instance Show Error where
+    show (UnboundVar str) = "Unbound variable: " <> str
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
index e3c4cce..882129c 100644
--- a/src/Renamer/RenamerIr.hs
+++ b/src/Renamer/RenamerIr.hs
@@ -1,84 +1,51 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE LambdaCase #-}
 
-module Renamer.RenamerIr where
+module Renamer.RenamerIr (module Grammar.Abs, RExp (..), RBind (..), RProgram (..)) where
 
-import           Grammar.Abs   (Ident, Type (..))
-import           Grammar.Print
+import Grammar.Abs (
+    Bind (..),
+    Const (..),
+    Ident (..),
+    Program (..),
+    Type (..),
+ )
+import Grammar.Print
 
+data RProgram = RProgram [RBind]
+    deriving (Eq, Show, Read, Ord)
 
-data Program = Program [Def] Main
-  deriving (Eq, Ord, Show, Read)
+data RBind = RBind Ident RExp
+    deriving (Eq, Show, Read, Ord)
 
-newtype Main = Main Exp
-  deriving (Eq, Ord, Show, Read)
+data RExp
+    = RAnn RExp Type
+    | RBound Integer Ident
+    | RFree Ident
+    | RConst Const
+    | RApp RExp RExp
+    | RAdd RExp RExp
+    | RAbs Integer Ident RExp
+    deriving (Eq, Ord, Show, Read)
 
+instance Print RProgram where
+    prt i = \case
+        RProgram defs -> prPrec i 0 (concatD [prt 0 defs])
 
-newtype Def = DBind Bind
-  deriving (Eq, Ord, Show, Read)
+instance Print RBind where
+    prt i = \case
+        RBind x e ->
+            prPrec i 0 $
+                concatD
+                    [ prt 0 x
+                    , doc (showString "=")
+                    , prt 0 e
+                    ]
 
-data Name = Nu Unique | Ni Ident deriving (Ord, Show, Eq, Read)
-
-newtype Unique = Unique Int deriving (Enum, Eq, Read, Ord)
-instance Show Unique where show (Unique i) = "x" ++ show i
-
-data Exp
-    = EId  Name
-    | EInt Integer
-    | EApp Exp Exp
-    | EAdd Exp Exp
-    | EAbs Unique Type Exp
-  deriving (Eq, Ord, Show, Read)
-
-
-data Bind = Bind Ident Type Exp
-  deriving (Eq, Ord, Show, Read)
-
-
-instance Print Program where
-  prt i = \case
-    Program defs main -> prPrec i 0 (concatD [prt 0 defs, prt 0 main])
-
-
-instance Print Def where
-  prt i (DBind b) = prPrec i 0 $ concatD [prt 0 b, doc (showString ";")]
-
-instance Print Bind where
-  prt i = \case
-    Bind x t e -> prPrec i 0 $ concatD
-      [ prt 0 x
-      , doc (showString ":")
-      , prt 0 t
-      , doc (showString "=")
-      , prt 0 e]
-
-instance Print [Def] where
-  prt _ []     = concatD []
-  prt _ (x:xs) = concatD [prt 0 x, prt 0 xs]
-
-
-instance Print Main where
-  prt i = \case
-    Main exp -> prPrec i 0 $ concatD
-     [ doc (showString "main")
-     , doc (showString "=")
-     , prt 0 exp
-     , doc (showString ";")
-     ]
-
-instance Print Exp where
-  prt i = \case
-    EId u -> prPrec i 3 (concatD [prt 0 u])
-    EInt n -> prPrec i 3 (concatD [prt 0 n])
-    EApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
-    EAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
-    EAbs u t e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 u, doc (showString ":"), prt 0 t, doc (showString "."), prt 0 e])
-
-
-instance Print Name where
-  prt _ = \case
-    Ni i -> prt 0 i
-    Nu u -> prt 0 u
-
-instance Print Unique where
-  prt _ = doc . showString . show
+instance Print RExp where
+    prt i = \case
+        RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)])
+        RFree id -> prPrec i 3 (concatD [prt 0 id])
+        RConst n -> prPrec i 3 (concatD [prt 0 n])
+        RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
+        RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
+        RAbs u id e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e])
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 0704832..ed59298 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -76,8 +76,8 @@ inferExp = \case
         return infT
 
     Old.EConst c -> case c of
-        (Old.CInt i) -> return (TMono $ UIdent "Int")
-        (Old.CStr s) -> return (TMono $ UIdent "String")
+        (Old.CInt i) -> return (TMono "Int")
+        (Old.CStr s) -> return (TMono "String")
 
     Old.EAdd e1 e2 -> do
         let int = TMono "Int"
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 7fb93fe..95e4108 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,14 +1,19 @@
 {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr (module Grammar.Abs, Exp) where
+module TypeChecker.TypeCheckerIr where
 
-import Grammar.Abs (Program(..), Ident(..), Bind(..), Const(..), Type(..), UIdent(..), LIdent(..))
+import Renamer.RenamerIr
 
-data Exp
-    = EAnn Exp Type
-    | EId Ident Type
-    | EConst Const Type
-    | EApp Exp Exp Type
-    | EAdd Exp Exp Type
-    | EAbs Ident Exp Type
-  deriving (Eq, Ord, Show, Read)
+data TProgram = TProgram [TBind]
+
+data TBind = TBind Ident Type TExp
+
+data TExp
+    = TAnn TExp Type
+    | TBound Integer Ident Type
+    | TFree Ident Type
+    | TConst Const Type
+    | TApp TExp TExp Type
+    | TAdd TExp TExp Type
+    | TAbs Integer Ident TExp Type
+    deriving (Eq, Ord, Show, Read)
diff --git a/test_program b/test_program
index a17b924..3fcfcea 100644
--- a/test_program
+++ b/test_program
@@ -1 +1,4 @@
-main = 3;
+letters = let x = 1
+           in let y = 2
+               in let z = 3
+                   in x + y + z

From 5d247057f56fc2ecd18323f863d59e92f34924c2 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 14 Feb 2023 22:03:56 +0100
Subject: [PATCH 23/71] Minor rewrite of tc. Some bugs still left

---
 Grammar.cf                       |   5 +-
 src/Main.hs                      |  21 ++-
 src/Renamer/RenamerIr.hs         |   9 +-
 src/TypeChecker/TypeChecker.hs   | 263 ++++++++++++++++++-------------
 src/TypeChecker/TypeCheckerIr.hs |  81 +++++++++-
 test_program                     |   5 +-
 6 files changed, 256 insertions(+), 128 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index 21b563b..234b2f0 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -3,7 +3,7 @@ Program. Program ::= [Bind] ;
 
 Bind. Bind ::= Ident [Ident] "=" Exp ;
 
-EAnn.   Exp5 ::= Exp5 ":" Type ;
+EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
 EId.    Exp4 ::= Ident ;
 EConst. Exp4 ::= Const ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
@@ -16,8 +16,9 @@ CStr. Const ::= String ;
 
 TMono. Type ::= "Mono" Ident ;
 TPoly. Type ::= "Poly" Ident ;
-TArrow. Type ::= Type "->" Type1 ;
+TArrow. Type ::= Type1 "->" Type ;
 
+-- This doesn't seem to work so we'll have to live with ugly keywords for now
 -- token Upper (upper (letter | digit | '_')*) ;
 -- token Lower (lower (letter | digit | '_')*) ;
 
diff --git a/src/Main.hs b/src/Main.hs
index 93b3edd..647ac9d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,8 +5,9 @@ import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
-import TypeChecker.TypeChecker (typecheck)
-import Renamer.Renamer (rename)
+import           TypeChecker.TypeChecker (typecheck)
+import           Renamer.Renamer (rename)
+import           Grammar.Print (prt)
 
 main :: IO ()
 main = getArgs >>= \case
@@ -19,10 +20,14 @@ main = getArgs >>= \case
        putStrLn err
        exitFailure
       Right prg -> case rename prg of
-        Right prg -> do
-            putStrLn "RENAME SUCCESSFUL"
-            putStrLn $ printTree prg
         Left err -> do
-            putStrLn "FAILED RENAMING"
-            putStrLn . show $ err
-            exitFailure
+          putStrLn "FAILED RENAMING"
+          putStrLn . show $ err
+          exitFailure
+        Right prg -> case typecheck prg of
+            Left err -> do
+                putStrLn "TYPECHECK ERROR"
+                putStrLn . show $ err
+                exitFailure
+            Right prg -> do
+                putStrLn . printTree $ prg
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
index 882129c..ea6f477 100644
--- a/src/Renamer/RenamerIr.hs
+++ b/src/Renamer/RenamerIr.hs
@@ -1,6 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Renamer.RenamerIr (module Grammar.Abs, RExp (..), RBind (..), RProgram (..)) where
+module Renamer.RenamerIr ( RExp (..)
+                         , RBind (..)
+                         , RProgram (..)
+                         , Const (..)
+                         , Ident (..)
+                         , Type (..)
+                         ) where
 
 import Grammar.Abs (
     Bind (..),
@@ -43,6 +49,7 @@ instance Print RBind where
 
 instance Print RExp where
     prt i = \case
+        RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t])
         RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)])
         RFree id -> prPrec i 3 (concatD [prt 0 id])
         RConst n -> prPrec i 3 (concatD [prt 0 n])
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index ed59298..acb3132 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot #-}
 
-module TypeChecker.TypeChecker (typecheck) where
+module TypeChecker.TypeChecker where
 
 import Control.Monad (when, void)
 import Control.Monad.Except (ExceptT, throwError, runExceptT)
@@ -13,15 +13,11 @@ import qualified Control.Monad.State as St
 import Data.Functor.Identity (Identity, runIdentity)
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Bool (bool)
-import qualified Grammar.Abs as Old
 import Grammar.ErrM (Err)
 
 import TypeChecker.TypeCheckerIr
 
-data Ctx = Ctx { env :: Map Ident Type
+data Ctx = Ctx { vars :: Map Integer Type
                , sigs :: Map Ident Type
                }
     deriving Show
@@ -34,121 +30,165 @@ programmer.
 
 -}
 
-type Check = StateT (Map Ident Type) (ReaderT Ctx (ExceptT Error Identity))
+type Infer = StateT Ctx (ExceptT Error Identity)
 
 initEnv :: Ctx
-initEnv =
-    Ctx { env = mempty
-        , sigs = mempty
-        }
+initEnv = Ctx mempty mempty
 
-run :: Check Type -> Either Error Type
-run = runIdentity . runExceptT . flip R.runReaderT initEnv . flip St.evalStateT mempty
+run :: Infer a -> Either Error a
+run = runIdentity . runExceptT . flip St.evalStateT initEnv
 
-typecheck :: Old.Program -> Either Error ()
-typecheck = todo
+typecheck :: RProgram -> Either Error TProgram
+typecheck = run . inferPrg 
 
-inferPrg :: Old.Program -> Check ()
-inferPrg (Program [x]) = void $ inferBind x
+inferPrg :: RProgram -> Infer TProgram
+inferPrg (RProgram xs) = do
+    xs' <- mapM inferBind xs
+    return $ TProgram xs'
 
-inferBind :: Old.Bind -> Check ()
-inferBind (Bind _ _ e) = void $ inferExp e
+inferBind :: RBind -> Infer TBind
+inferBind (RBind name e) = do
+    t <- inferExp e
+    e' <- toTExpr e
+    return $ TBind name t e'
 
-inferExp :: Old.Exp -> Check Type
+toTExpr :: RExp -> Infer TExp
+toTExpr = \case
+
+    re@(RAnn e t) -> do
+        t <- inferExp re
+        e' <- toTExpr e
+        return $ TAnn e' t
+
+    re@(RBound num name) -> do
+        t <- inferExp re
+        return $ TBound num name t
+
+    re@(RFree name) -> do
+        t <- inferExp re
+        return $ TFree name t
+
+    re@(RConst con)-> do
+        t <- inferExp re
+        return $ TConst con t
+
+    re@(RApp e1 e2) -> do
+        t <- inferExp re
+        e1' <- toTExpr e1
+        e2' <- toTExpr e2
+        return $ TApp e1' e2' t
+
+    re@(RAdd e1 e2)-> do
+        t <- inferExp re
+        e1' <- toTExpr e1
+        e2' <- toTExpr e2
+        return $ TAdd e1' e2' t
+
+    re@(RAbs num name e) -> do
+        t <- inferExp re
+        e' <- toTExpr e
+        return $ TAbs num name e' t
+
+
+inferExp :: RExp -> Infer Type
 inferExp = \case
 
-    -- TODO: Fix bound variable lookup
-    Old.EId i -> do
-        st <- St.get 
-        case lookupBound i st of
-          Just t -> return t
-          Nothing -> do
-            ctx <- R.ask
-            case lookupEnv i ctx of
-              Just t -> return t
-              Nothing -> case lookupSigs i ctx of
-                           Just t -> return t
-                           Nothing -> throwError UnboundVar
-        
-    Old.EAnn e t -> do
-        infT <- inferExp e
-        when (t /= infT) (throwError AnnotatedMismatch)
-        return infT
+    RAnn expr typ -> do
+        exprT <- inferExp expr
+        when (not (exprT == typ || isPoly exprT)) (throwError AnnotatedMismatch)
+        return typ
 
-    Old.EConst c -> case c of
-        (Old.CInt i) -> return (TMono "Int")
-        (Old.CStr s) -> return (TMono "String")
+    -- Name is only here for proper error messages
+    RBound num name ->
+        M.lookup num <$> St.gets vars >>= \case
+            Nothing -> throwError UnboundVar
+            Just t -> return t
 
-    Old.EAdd e1 e2 -> do
-        let int = TMono "Int"
-        updateBound e1 int
-        updateBound e2 int
-        inf1 <- inferExp e1
-        inf2 <- inferExp e2
-        when (not $ isInt inf1 && isInt inf2) (throwError TypeMismatch)
-        return int
+    RFree name -> do
+        M.lookup name <$> St.gets sigs >>= \case
+            Nothing -> throwError UnboundVar
+            Just t -> return t
 
-    -- Incomplete and probably wrong
-    Old.EApp e1 e2 -> do
-        inferExp e1 >>= \case
-            TArrow mono@(TMono i) t2 -> do
-                t <- inferExp e2
-                when (t /= mono) (throwError TypeMismatch)
-                return t2
+    RConst (CInt _) -> return $ TMono "Int"
+    RConst (CStr _) -> return $ TMono "Str"
 
-            TArrow poly@(TPoly f) t2 -> do
-                t <- inferExp e2 
-                when (not $ t `subtype` t) (throwError TypeMismatch)
-                return t2
+    -- Currently does not accept using a polymorphic type as the function.
+    RApp expr1 expr2 -> do
+        typ1 <- inferExp expr1
+        typ2 <- inferExp expr2
+        fit typ2 typ1
 
-    -- This is not entirely correct. The assumed type can change.
-    Old.EAbs i e -> do
-        let assume = (TPoly "a")
-        St.modify (M.insert i assume)
-        infT <- R.local (insertEnv i assume) (inferExp e)
-        St.gets (M.lookup i) >>= \case
-            Nothing -> todo
-            Just x -> return (TArrow x infT)
+    RAdd expr1 expr2 -> do
+        typ1 <- inferExp expr1
+        typ2 <- inferExp expr2
+        when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError TypeMismatch)
+        specifyType expr1 (TMono "Int")
+        specifyType expr2 (TMono "Int")
+        return (TMono "Int")
 
-    Old.ELet i e1 e2 -> todo
+    RAbs num name expr -> do
+        insertVars num (TPoly "a")
+        typ <- inferExp expr
+        newTyp <- lookupVars num
+        return $ TArrow newTyp typ
 
 -- Aux
-
--- Double check this function. It's bad and maybe wrong
-subtype :: Type -> Type -> Bool
-subtype (TMono t1) (TMono t2) = t1 == t2
-subtype (TMono t1) (TPoly t2) = True
-subtype (TPoly t2) (TMono t1) = False
-subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4
-subtype _ _                   = False
-
-lookupEnv :: Ident -> Ctx -> Maybe Type
-lookupEnv i = M.lookup i . env
-
-lookupSigs :: Ident -> Ctx -> Maybe Type
-lookupSigs i = M.lookup i . sigs
-
-insertEnv :: Ident -> Type -> Ctx -> Ctx
-insertEnv i t c = Ctx { env = M.insert i t c.env
-                      , sigs = c.sigs
-                      }
-
-updateBound :: Old.Exp -> Type -> Check ()
-updateBound (Old.EId i) t = St.modify (M.insert i t)
-updateBound _ _           = return ()
-
-isBound :: Old.Exp -> Check Bool
-isBound (Old.EId i) = (M.member i) <$> St.get
-isBound _           = return False
-
-lookupBound :: Ident -> Map Ident Type -> Maybe Type
-lookupBound = M.lookup
-
 isInt :: Type -> Bool
 isInt (TMono "Int") = True
-isInt (TPoly _)     = True
 isInt _             = False
 
+isArrow :: Type -> Bool
+isArrow (TArrow _ _) = True
+isArrow _            = False
+
+isPoly :: Type -> Bool
+isPoly (TPoly _) = True
+isPoly _         = False
+
+fit :: Type -> Type -> Infer Type
+fit (TArrow t1 (TArrow t2 t3)) t4
+  | t1 == t4 = return $ TArrow t2 t3
+  | otherwise = fit (TArrow (TArrow t1 t2) t3) t4
+fit (TArrow t1 t2) t3
+  | t1 == t3 = return t2
+  | otherwise = throwError TypeMismatch
+fit _ _ = throwError TypeMismatch
+
+-- a -> (b -> (c -> d))
+-- a -> b
+
+-- | Specify the type of a bound variable
+-- Because in lambdas we have to assume a general type and update it
+specifyType :: RExp -> Type -> Infer ()
+specifyType (RBound num name) typ = do
+    insertVars num typ
+    return ()
+specifyType _ _ = return ()
+
+lookupVars :: Integer -> Infer Type
+lookupVars i = do
+    st <- St.gets vars
+    case M.lookup i st of
+      Just t -> return t
+      Nothing -> throwError UnboundVar
+
+lookupSigs :: Ident -> Infer Type
+lookupSigs i = do
+    st <- St.gets sigs
+    case M.lookup i st of
+      Just t -> return t
+      Nothing -> throwError UnboundVar
+
+
+insertVars :: Integer -> Type -> Infer ()
+insertVars i t = do
+    st <- St.get
+    St.put ( Ctx { vars = M.insert i t st.vars, sigs = st.sigs } )
+
+{-# WARNING todo "TODO IN CODE" #-}
+todo :: a
+todo = error "TODO in code"
+
 data Error
     = TypeMismatch
     | NotNumber
@@ -161,18 +201,17 @@ data Error
 
 -- Tests
 
-number :: Old.Exp
-number = Old.EConst (CInt 3)
+lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x"))
+lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String")))
 
-aToInt :: Old.Exp
-aToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3)))
+pp :: Type -> String
+pp (TMono (Ident x)) = x
+pp (TPoly (Ident x)) = x
+pp (TArrow t1 t2) = pp t1 <> " -> " <> pp t2
 
-intToInt :: Old.Exp
-intToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EConst (Old.CInt 3)))
+int,str :: Type
+int = TMono "Int"
+str = TMono "Str"
 
-addLambda :: Old.Exp
-addLambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EId $ Ident "x"))
-
-{-# WARNING todo "TODO IN CODE" #-}
-todo :: a
-todo = error "TODO in code"
+arrow :: Type -> Type -> Type
+arrow = TArrow
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 95e4108..d1aa706 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,12 +1,25 @@
 {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr where
+module TypeChecker.TypeCheckerIr ( TProgram(..)
+                                 , TBind(..)
+                                 , TExp(..)
+                                 , RProgram(..)
+                                 , RBind(..)
+                                 , RExp(..)
+                                 , Type(..)
+                                 , Const(..)
+                                 , Ident(..)
+                                 )
+                                     where
 
 import Renamer.RenamerIr
+import Grammar.Print
 
 data TProgram = TProgram [TBind]
+    deriving (Eq, Show, Read, Ord)
 
 data TBind = TBind Ident Type TExp
+    deriving (Eq, Show, Read, Ord)
 
 data TExp
     = TAnn TExp Type
@@ -17,3 +30,69 @@ data TExp
     | TAdd TExp TExp Type
     | TAbs Integer Ident TExp Type
     deriving (Eq, Ord, Show, Read)
+
+instance Print TProgram where
+    prt i = \case
+        TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
+
+instance Print TBind where
+    prt i = \case
+        TBind x t e ->
+            prPrec i 0 $
+                concatD
+                    [ prt 0 x
+                    , doc (showString ":")
+                    , prt 0 t
+                    , doc (showString "=")
+                    , prt 0 e
+                    ]
+
+instance Print TExp where
+    prt i = \case
+        TAnn e t -> prPrec i 2 $ concatD
+            [ prt 0 e
+            , doc (showString ":")
+            , prt 1 t
+            ]
+        TBound _ u t -> prPrec i 3 $ concatD
+              [ doc (showString "(")
+              , prt 0 u
+              , doc (showString ":")
+              , prt 0 t
+              , doc (showString ")")
+              ]
+        TFree u t -> prPrec i 3 $ concatD
+              [ doc (showString "(")
+              , prt 0 u
+              , doc (showString ":")
+              , prt 0 t
+              , doc (showString ")")
+              ]
+        TConst c _ -> prPrec i 3 (concatD [prt 0 c])
+        TApp e e1 t -> prPrec i 2 $ concatD
+              [ doc (showString "(")
+              , prt 2 e
+              , prt 3 e1
+              , doc (showString ")")
+              , doc (showString ":")
+              , prt 0 t
+              ]
+        TAdd e e1 t -> prPrec i 1 $ concatD
+              [ doc (showString "(")
+              , prt 1 e
+              , doc (showString "+")
+              , prt 2 e1
+              , doc (showString ")")
+              , doc (showString ":")
+              , prt 0 t
+              ]
+        TAbs _ u e t -> prPrec i 0 $ concatD
+              [ doc (showString "(")
+              , doc (showString "\\")
+              , prt 0 u
+              , doc (showString ".")
+              , prt 0 e
+              , doc (showString ")")
+              , doc (showString ":")
+              , prt 0 t, doc (showString ".")
+              ]
diff --git a/test_program b/test_program
index 3fcfcea..e297617 100644
--- a/test_program
+++ b/test_program
@@ -1,4 +1 @@
-letters = let x = 1
-           in let y = 2
-               in let z = 3
-                   in x + y + z
+testType f x = f x

From ad3f6b7011b9e2c91606a130425cb92d9963d68d Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 14 Feb 2023 22:35:00 +0100
Subject: [PATCH 24/71] Attempt at fixing EApp, failed.

---
 src/TypeChecker/TypeChecker.hs | 36 +++++++++++++++++++---------------
 1 file changed, 20 insertions(+), 16 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index acb3132..5e16f36 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -14,11 +14,13 @@ import Data.Functor.Identity (Identity, runIdentity)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Grammar.ErrM (Err)
+import Grammar.Print
 
 import TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx { vars :: Map Integer Type
                , sigs :: Map Ident Type
+               , count :: Int
                }
     deriving Show
 
@@ -33,7 +35,7 @@ programmer.
 type Infer = StateT Ctx (ExceptT Error Identity)
 
 initEnv :: Ctx
-initEnv = Ctx mempty mempty
+initEnv = Ctx mempty mempty 0
 
 run :: Infer a -> Either Error a
 run = runIdentity . runExceptT . flip St.evalStateT initEnv
@@ -147,15 +149,27 @@ isPoly _         = False
 
 fit :: Type -> Type -> Infer Type
 fit (TArrow t1 (TArrow t2 t3)) t4
-  | t1 == t4 = return $ TArrow t2 t3
+  | t1 `match` t4 = return $ TArrow t2 t3
   | otherwise = fit (TArrow (TArrow t1 t2) t3) t4
 fit (TArrow t1 t2) t3
-  | t1 == t3 = return t2
+  | t1 `match` t3 = return t2
   | otherwise = throwError TypeMismatch
 fit _ _ = throwError TypeMismatch
 
--- a -> (b -> (c -> d))
--- a -> b
+match :: Type -> Type -> Bool
+match (TPoly _) (TMono _) = True
+match (TMono _) (TPoly _) = True
+match (TMono _) (TMono _) = True
+match (TPoly _) (TPoly _) = True
+match (TArrow t1 t2) (TArrow t3 t4) = match t1 t3 && match t2 t4
+
+incCount :: Infer Int
+incCount = do
+    st <- St.get
+    St.put (Ctx { vars = st.vars, sigs = st.sigs, count = succ st.count })
+    return st.count
+
+
 
 -- | Specify the type of a bound variable
 -- Because in lambdas we have to assume a general type and update it
@@ -204,14 +218,4 @@ data Error
 lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x"))
 lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String")))
 
-pp :: Type -> String
-pp (TMono (Ident x)) = x
-pp (TPoly (Ident x)) = x
-pp (TArrow t1 t2) = pp t1 <> " -> " <> pp t2
-
-int,str :: Type
-int = TMono "Int"
-str = TMono "Str"
-
-arrow :: Type -> Type -> Type
-arrow = TArrow
+fn_on_var = RAbs 0 "x" (RAbs 1 "y" (RApp (RBound 0 "x") (RBound 1 "y")))

From 7619e36c60776f7b0a8ca2d77f02f601e85b06a8 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 15 Feb 2023 17:40:18 +0100
Subject: [PATCH 25/71] Inference works better now. Still work to do. Should
 use proper library

---
 .gitignore                       |  1 +
 Grammar.cf                       |  8 ++-
 Makefile                         |  3 ++
 language.cabal                   |  1 +
 src/Main.hs                      |  5 ++
 src/TypeChecker/TypeChecker.hs   | 87 ++++++++++++++++----------------
 src/TypeChecker/TypeCheckerIr.hs | 38 ++------------
 test_program                     |  2 +-
 8 files changed, 66 insertions(+), 79 deletions(-)

diff --git a/.gitignore b/.gitignore
index 193a11d..5e276e4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -4,3 +4,4 @@ dist-newstyle
 *.bak
 src/Grammar
 language
+test_program_result
diff --git a/Grammar.cf b/Grammar.cf
index 234b2f0..1e99c21 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -14,8 +14,8 @@ EAbs.   Exp  ::= "\\" Ident "." Exp ;
 CInt. Const ::= Integer ;
 CStr. Const ::= String ;
 
-TMono. Type ::= "Mono" Ident ;
-TPoly. Type ::= "Poly" Ident ;
+TMono. Type1 ::= "Mono" Ident ;
+TPoly. Type1 ::= "Poly" Ident ;
 TArrow. Type ::= Type1 "->" Type ;
 
 -- This doesn't seem to work so we'll have to live with ugly keywords for now
@@ -30,3 +30,7 @@ coercions Exp 5 ;
 
 comment "--" ;
 comment "{-" "-}" ;
+
+-- Adt. Adt ::= "data" UIdent "=" [Constructor] ;
+-- Sum. Constructor ::= UIdent ; 
+-- separator Constructor "|" ;
diff --git a/Makefile b/Makefile
index ad830b5..9c0be2f 100644
--- a/Makefile
+++ b/Makefile
@@ -29,4 +29,7 @@ test :
 	./language ./sample-programs/basic-4
 	./language ./sample-programs/basic-5
 
+run :
+	cabal -v0 new-run language -- "test_program"
+
 # EOF
diff --git a/language.cabal b/language.cabal
index 0701df6..5668b83 100644
--- a/language.cabal
+++ b/language.cabal
@@ -45,5 +45,6 @@ executable language
       , either
       , extra
       , array
+      , equivalence
 
     default-language: GHC2021
diff --git a/src/Main.hs b/src/Main.hs
index 647ac9d..e9476fb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -30,4 +30,9 @@ main = getArgs >>= \case
                 putStrLn . show $ err
                 exitFailure
             Right prg -> do
+                putStrLn ""
                 putStrLn . printTree $ prg
+                putStrLn ""
+                putStrLn " ----- ADT ----- "
+                putStrLn ""
+                putStrLn $ show prg
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 5e16f36..cf1e7e8 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -4,10 +4,6 @@ module TypeChecker.TypeChecker where
 
 import Control.Monad (when, void)
 import Control.Monad.Except (ExceptT, throwError, runExceptT)
-import Control.Monad.Reader (ReaderT)
-import qualified Control.Monad.Reader as R
-import Control.Monad.Writer (WriterT)
-import qualified Control.Monad.Writer as W
 import Control.Monad.State (StateT)
 import qualified Control.Monad.State as St
 import Data.Functor.Identity (Identity, runIdentity)
@@ -52,6 +48,7 @@ inferBind :: RBind -> Infer TBind
 inferBind (RBind name e) = do
     t <- inferExp e
     e' <- toTExpr e
+    insertSigs name t
     return $ TBind name t e'
 
 toTExpr :: RExp -> Infer TExp
@@ -97,33 +94,40 @@ inferExp = \case
 
     RAnn expr typ -> do
         exprT <- inferExp expr
-        when (not (exprT == typ || isPoly exprT)) (throwError AnnotatedMismatch)
+        when (not (exprT == typ || isPoly exprT)) (throwError $ AnnotatedMismatch "inferExp, RAnn")
         return typ
 
     -- Name is only here for proper error messages
     RBound num name ->
         M.lookup num <$> St.gets vars >>= \case
-            Nothing -> throwError UnboundVar
+            Nothing -> throwError $ UnboundVar "RBound"
             Just t -> return t
 
     RFree name -> do
         M.lookup name <$> St.gets sigs >>= \case
-            Nothing -> throwError UnboundVar
+            Nothing -> throwError $ UnboundVar "RFree"
             Just t -> return t
 
     RConst (CInt _) -> return $ TMono "Int"
+
     RConst (CStr _) -> return $ TMono "Str"
 
-    -- Currently does not accept using a polymorphic type as the function.
+    -- Should do proper unification using union-find. Some nice libs exist
     RApp expr1 expr2 -> do
         typ1 <- inferExp expr1
         typ2 <- inferExp expr2
-        fit typ2 typ1
+        cnt <- incCount
+        case typ1 of
+            (TPoly (Ident x)) -> do 
+                let newType = (TArrow (TPoly (Ident x)) (TPoly . Ident $ x ++ (show cnt)))
+                specifyType expr1 newType
+                apply newType typ1
+            _         -> apply typ2 typ1
 
     RAdd expr1 expr2 -> do
         typ1 <- inferExp expr1
         typ2 <- inferExp expr2
-        when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError TypeMismatch)
+        when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError $ TypeMismatch "inferExp, RAdd")
         specifyType expr1 (TMono "Int")
         specifyType expr2 (TMono "Int")
         return (TMono "Int")
@@ -147,30 +151,12 @@ isPoly :: Type -> Bool
 isPoly (TPoly _) = True
 isPoly _         = False
 
-fit :: Type -> Type -> Infer Type
-fit (TArrow t1 (TArrow t2 t3)) t4
-  | t1 `match` t4 = return $ TArrow t2 t3
-  | otherwise = fit (TArrow (TArrow t1 t2) t3) t4
-fit (TArrow t1 t2) t3
-  | t1 `match` t3 = return t2
-  | otherwise = throwError TypeMismatch
-fit _ _ = throwError TypeMismatch
-
-match :: Type -> Type -> Bool
-match (TPoly _) (TMono _) = True
-match (TMono _) (TPoly _) = True
-match (TMono _) (TMono _) = True
-match (TPoly _) (TPoly _) = True
-match (TArrow t1 t2) (TArrow t3 t4) = match t1 t3 && match t2 t4
-
 incCount :: Infer Int
 incCount = do
     st <- St.get
-    St.put (Ctx { vars = st.vars, sigs = st.sigs, count = succ st.count })
+    St.put ( st { count = succ st.count } )
     return st.count
 
-
-
 -- | Specify the type of a bound variable
 -- Because in lambdas we have to assume a general type and update it
 specifyType :: RExp -> Type -> Infer ()
@@ -184,33 +170,48 @@ lookupVars i = do
     st <- St.gets vars
     case M.lookup i st of
       Just t -> return t
-      Nothing -> throwError UnboundVar
+      Nothing -> throwError $ UnboundVar "lookupVars"
+
+insertVars :: Integer -> Type -> Infer ()
+insertVars i t = do
+    st <- St.get
+    St.put ( st { vars = M.insert i t st.vars } )
 
 lookupSigs :: Ident -> Infer Type
 lookupSigs i = do
     st <- St.gets sigs
     case M.lookup i st of
       Just t -> return t
-      Nothing -> throwError UnboundVar
+      Nothing -> throwError $ UnboundVar "lookupSigs"
 
-
-insertVars :: Integer -> Type -> Infer ()
-insertVars i t = do
+insertSigs :: Ident -> Type -> Infer ()
+insertSigs i t = do
     st <- St.get
-    St.put ( Ctx { vars = M.insert i t st.vars, sigs = st.sigs } )
+    St.put ( st { sigs = M.insert i t st.sigs } )
+
+union :: Type -> Type -> Infer ()
+union = todo
+
+find :: Type -> Type
+find = todo
+
+apply :: Type -> Type -> Infer Type
+apply (TArrow t1 t2) t3
+  | t1 == t3 = return t2
+  | otherwise = throwError $ TypeMismatch "apply"
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
 todo = error "TODO in code"
 
 data Error
-    = TypeMismatch
-    | NotNumber
-    | FunctionTypeMismatch
-    | NotFunction
-    | UnboundVar
-    | AnnotatedMismatch
-    | Default
+    = TypeMismatch String
+    | NotNumber String
+    | FunctionTypeMismatch String
+    | NotFunction String
+    | UnboundVar String
+    | AnnotatedMismatch String
+    | Default String
     deriving Show
 
 -- Tests
@@ -218,4 +219,4 @@ data Error
 lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x"))
 lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String")))
 
-fn_on_var = RAbs 0 "x" (RAbs 1 "y" (RApp (RBound 0 "x") (RBound 1 "y")))
+fn_on_var = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index d1aa706..61f54df 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -45,6 +45,7 @@ instance Print TBind where
                     , prt 0 t
                     , doc (showString "=")
                     , prt 0 e
+                    , doc (showString "\n")
                     ]
 
 instance Print TExp where
@@ -54,38 +55,11 @@ instance Print TExp where
             , doc (showString ":")
             , prt 1 t
             ]
-        TBound _ u t -> prPrec i 3 $ concatD
-              [ doc (showString "(")
-              , prt 0 u
-              , doc (showString ":")
-              , prt 0 t
-              , doc (showString ")")
-              ]
-        TFree u t -> prPrec i 3 $ concatD
-              [ doc (showString "(")
-              , prt 0 u
-              , doc (showString ":")
-              , prt 0 t
-              , doc (showString ")")
-              ]
+        TBound _ u t -> prPrec i 3 $ concatD [ prt 0 u ]
+        TFree u t -> prPrec i 3 $ concatD [ prt 0 u ]
         TConst c _ -> prPrec i 3 (concatD [prt 0 c])
-        TApp e e1 t -> prPrec i 2 $ concatD
-              [ doc (showString "(")
-              , prt 2 e
-              , prt 3 e1
-              , doc (showString ")")
-              , doc (showString ":")
-              , prt 0 t
-              ]
-        TAdd e e1 t -> prPrec i 1 $ concatD
-              [ doc (showString "(")
-              , prt 1 e
-              , doc (showString "+")
-              , prt 2 e1
-              , doc (showString ")")
-              , doc (showString ":")
-              , prt 0 t
-              ]
+        TApp e e1 t -> prPrec i 2 $ concatD [ prt 2 e , prt 3 e1 ]
+        TAdd e e1 t -> prPrec i 1 $ concatD [ prt 1 e , doc (showString "+") , prt 2 e1 ]
         TAbs _ u e t -> prPrec i 0 $ concatD
               [ doc (showString "(")
               , doc (showString "\\")
@@ -93,6 +67,4 @@ instance Print TExp where
               , doc (showString ".")
               , prt 0 e
               , doc (showString ")")
-              , doc (showString ":")
-              , prt 0 t, doc (showString ".")
               ]
diff --git a/test_program b/test_program
index e297617..db9a44e 100644
--- a/test_program
+++ b/test_program
@@ -1 +1 @@
-testType f x = f x
+test f x = f x

From b03df17e34621b40f8c5d6c222f5506a0415ef27 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 15 Feb 2023 18:10:28 +0100
Subject: [PATCH 26/71] Minor changes. Added a comment

---
 src/Main.hs                    | 37 +++++++++++++++++++++-------------
 src/TypeChecker/TypeChecker.hs |  9 ++++++---
 2 files changed, 29 insertions(+), 17 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index e9476fb..354e468 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,20 +19,29 @@ main = getArgs >>= \case
        putStrLn "SYNTAX ERROR"
        putStrLn err
        exitFailure
-      Right prg -> case rename prg of
-        Left err -> do
-          putStrLn "FAILED RENAMING"
-          putStrLn . show $ err
-          exitFailure
-        Right prg -> case typecheck prg of
+      Right prg -> do
+        putStrLn ""
+        putStrLn " ----- PARSER ----- "
+        putStrLn ""
+        putStrLn . printTree $ prg
+        putStrLn . show $ prg
+        case rename prg of
             Left err -> do
-                putStrLn "TYPECHECK ERROR"
-                putStrLn . show $ err
-                exitFailure
-            Right prg -> do
+              putStrLn "FAILED RENAMING"
+              putStrLn . show $ err
+              exitFailure
+            Right prg ->do
+                putStrLn ""
+                putStrLn " ----- RENAMER ----- "
                 putStrLn ""
                 putStrLn . printTree $ prg
-                putStrLn ""
-                putStrLn " ----- ADT ----- "
-                putStrLn ""
-                putStrLn $ show prg
+                case typecheck prg of
+                    Left err -> do
+                        putStrLn "TYPECHECK ERROR"
+                        putStrLn . show $ err
+                        exitFailure
+                    Right prg -> do
+                        putStrLn ""
+                        putStrLn " ----- TYPECHECKER ----- "
+                        putStrLn ""
+                        putStrLn . printTree $ prg
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index cf1e7e8..34a27e9 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -12,6 +12,7 @@ import qualified Data.Map as M
 import Grammar.ErrM (Err)
 import Grammar.Print
 
+import Debug.Trace (trace)
 import TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx { vars :: Map Integer Type
@@ -51,6 +52,7 @@ inferBind (RBind name e) = do
     insertSigs name t
     return $ TBind name t e'
 
+-- This needs to be fixed. Should not separate inference of type and creation of the new data type.
 toTExpr :: RExp -> Infer TExp
 toTExpr = \case
 
@@ -88,7 +90,6 @@ toTExpr = \case
         e' <- toTExpr e
         return $ TAbs num name e' t
 
-
 inferExp :: RExp -> Infer Type
 inferExp = \case
 
@@ -198,7 +199,7 @@ find = todo
 apply :: Type -> Type -> Infer Type
 apply (TArrow t1 t2) t3
   | t1 == t3 = return t2
-  | otherwise = throwError $ TypeMismatch "apply"
+apply t1 t2 = throwError $ TypeMismatch "apply"
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
@@ -219,4 +220,6 @@ data Error
 lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x"))
 lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String")))
 
-fn_on_var = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
+fn_on_var = RAbs 0 (Ident "f") (RAbs 1 (Ident "x") (RApp (RBound 0 (Ident "f")) (RBound 1 (Ident "x"))))
+
+bind = RBind "test" fn_on_var

From f1b77a7efa60bc47d998c115f8dc125b600ecd17 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 15 Feb 2023 19:52:52 +0100
Subject: [PATCH 27/71] Refactored. Cleaner version, ala Martin version

---
 src/Main.hs                      |  1 -
 src/Renamer/RenamerIr.hs         |  3 +-
 src/TypeChecker/TypeChecker.hs   | 87 +++++++++++---------------------
 src/TypeChecker/TypeCheckerIr.hs |  2 +-
 4 files changed, 33 insertions(+), 60 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 354e468..3679582 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -24,7 +24,6 @@ main = getArgs >>= \case
         putStrLn " ----- PARSER ----- "
         putStrLn ""
         putStrLn . printTree $ prg
-        putStrLn . show $ prg
         case rename prg of
             Left err -> do
               putStrLn "FAILED RENAMING"
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
index ea6f477..33f1d3c 100644
--- a/src/Renamer/RenamerIr.hs
+++ b/src/Renamer/RenamerIr.hs
@@ -45,6 +45,7 @@ instance Print RBind where
                     [ prt 0 x
                     , doc (showString "=")
                     , prt 0 e
+                    , doc (showString "\n")
                     ]
 
 instance Print RExp where
@@ -55,4 +56,4 @@ instance Print RExp where
         RConst n -> prPrec i 3 (concatD [prt 0 n])
         RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
         RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
-        RAbs u id e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e])
+        RAbs u id e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e])
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 34a27e9..f663ec4 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -47,97 +47,60 @@ inferPrg (RProgram xs) = do
 
 inferBind :: RBind -> Infer TBind
 inferBind (RBind name e) = do
-    t <- inferExp e
-    e' <- toTExpr e
+    (t, e') <- inferExp e
     insertSigs name t
     return $ TBind name t e'
 
--- This needs to be fixed. Should not separate inference of type and creation of the new data type.
-toTExpr :: RExp -> Infer TExp
-toTExpr = \case
 
-    re@(RAnn e t) -> do
-        t <- inferExp re
-        e' <- toTExpr e
-        return $ TAnn e' t
-
-    re@(RBound num name) -> do
-        t <- inferExp re
-        return $ TBound num name t
-
-    re@(RFree name) -> do
-        t <- inferExp re
-        return $ TFree name t
-
-    re@(RConst con)-> do
-        t <- inferExp re
-        return $ TConst con t
-
-    re@(RApp e1 e2) -> do
-        t <- inferExp re
-        e1' <- toTExpr e1
-        e2' <- toTExpr e2
-        return $ TApp e1' e2' t
-
-    re@(RAdd e1 e2)-> do
-        t <- inferExp re
-        e1' <- toTExpr e1
-        e2' <- toTExpr e2
-        return $ TAdd e1' e2' t
-
-    re@(RAbs num name e) -> do
-        t <- inferExp re
-        e' <- toTExpr e
-        return $ TAbs num name e' t
-
-inferExp :: RExp -> Infer Type
+inferExp :: RExp -> Infer (Type, TExp)
 inferExp = \case
 
     RAnn expr typ -> do
-        exprT <- inferExp expr
-        when (not (exprT == typ || isPoly exprT)) (throwError $ AnnotatedMismatch "inferExp, RAnn")
-        return typ
+        (t,expr') <- inferExp expr
+        when (not (t == typ || isPoly t)) (throwError $ AnnotatedMismatch "inferExp, RAnn")
+        return (typ,expr')
 
     -- Name is only here for proper error messages
     RBound num name ->
         M.lookup num <$> St.gets vars >>= \case
             Nothing -> throwError $ UnboundVar "RBound"
-            Just t -> return t
+            Just t -> return (t, TBound num name t)
 
     RFree name -> do
         M.lookup name <$> St.gets sigs >>= \case
             Nothing -> throwError $ UnboundVar "RFree"
-            Just t -> return t
+            Just t -> return (t, TFree name t)
 
-    RConst (CInt _) -> return $ TMono "Int"
+    RConst (CInt i) -> return $ (TMono "Int", TConst (CInt i) (TMono "Int"))
 
-    RConst (CStr _) -> return $ TMono "Str"
+    RConst (CStr str) -> return $ (TMono "Str", TConst (CStr str) (TMono "Str"))
 
     -- Should do proper unification using union-find. Some nice libs exist
     RApp expr1 expr2 -> do
-        typ1 <- inferExp expr1
-        typ2 <- inferExp expr2
+        (typ1, expr1') <- inferExp expr1
+        (typ2, expr2') <- inferExp expr2
         cnt <- incCount
         case typ1 of
             (TPoly (Ident x)) -> do 
                 let newType = (TArrow (TPoly (Ident x)) (TPoly . Ident $ x ++ (show cnt)))
                 specifyType expr1 newType
-                apply newType typ1
-            _         -> apply typ2 typ1
+                typ1' <- apply newType typ1
+                return $ (typ1', TApp expr1' expr2' typ1')
+            _         -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ2 typ1
 
     RAdd expr1 expr2 -> do
-        typ1 <- inferExp expr1
-        typ2 <- inferExp expr2
+        (typ1, expr1') <- inferExp expr1
+        (typ2, expr2') <- inferExp expr2
         when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError $ TypeMismatch "inferExp, RAdd")
         specifyType expr1 (TMono "Int")
         specifyType expr2 (TMono "Int")
-        return (TMono "Int")
+        return (TMono "Int", TAdd expr1' expr2' (TMono "Int"))
 
     RAbs num name expr -> do
         insertVars num (TPoly "a")
-        typ <- inferExp expr
+        (typ, expr') <- inferExp expr
         newTyp <- lookupVars num
-        return $ TArrow newTyp typ
+        return $ (TArrow newTyp typ, TAbs num name expr' typ)
 
 -- Aux
 isInt :: Type -> Bool
@@ -196,6 +159,8 @@ union = todo
 find :: Type -> Type
 find = todo
 
+-- Have to figure out the equivalence classes for types.
+-- Currently this does not support more than exact matches.
 apply :: Type -> Type -> Infer Type
 apply (TArrow t1 t2) t3
   | t1 == t3 = return t2
@@ -222,4 +187,12 @@ lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String")
 
 fn_on_var = RAbs 0 (Ident "f") (RAbs 1 (Ident "x") (RApp (RBound 0 (Ident "f")) (RBound 1 (Ident "x"))))
 
-bind = RBind "test" fn_on_var
+
+--add x = \y. x+y;
+add = RAbs 0 "x" (RAbs 1 "y" (RAdd (RBound 0 "x") (RBound 1 "y")))
+-- main = (\z. z+z) ((add 4) 6);
+main = RApp (RAbs 0 "z" (RAdd (RBound 0 "z") (RBound 0 "z"))) applyAdd
+four = RConst (CInt 4)
+six = RConst (CInt 6)
+applyAdd = (RApp (RApp add four) six)
+partialAdd = RApp add four
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 61f54df..7d30ae8 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -62,7 +62,7 @@ instance Print TExp where
         TAdd e e1 t -> prPrec i 1 $ concatD [ prt 1 e , doc (showString "+") , prt 2 e1 ]
         TAbs _ u e t -> prPrec i 0 $ concatD
               [ doc (showString "(")
-              , doc (showString "\\")
+              , doc (showString "λ")
               , prt 0 u
               , doc (showString ".")
               , prt 0 e

From eafe0fea0b40fc5adc6b6cee3e5f243c5f2a6490 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 16 Feb 2023 16:37:36 +0100
Subject: [PATCH 28/71] Rewrote using unification-fd. Heavily inspired (aka
 copied) from:
 https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/

---
 language.cabal                 |   3 +-
 src/Main.hs                    |   5 +-
 src/TypeChecker/TypeChecker.hs |  39 +++--
 src/TypeChecker/Unification.hs | 284 +++++++++++++++++++++++++++++++++
 test_program                   |   4 +-
 5 files changed, 314 insertions(+), 21 deletions(-)
 create mode 100644 src/TypeChecker/Unification.hs

diff --git a/language.cabal b/language.cabal
index 5668b83..e3d40b9 100644
--- a/language.cabal
+++ b/language.cabal
@@ -33,6 +33,7 @@ executable language
       Grammar.ErrM
       TypeChecker.TypeChecker
       TypeChecker.TypeCheckerIr
+      TypeChecker.Unification
       Renamer.Renamer
       Renamer.RenamerIr
 
@@ -45,6 +46,6 @@ executable language
       , either
       , extra
       , array
-      , equivalence
+      , unification-fd
 
     default-language: GHC2021
diff --git a/src/Main.hs b/src/Main.hs
index 3679582..0845f8c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,7 +5,8 @@ import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
-import           TypeChecker.TypeChecker (typecheck)
+-- import           TypeChecker.TypeChecker (typecheck)
+import           TypeChecker.Unification (typecheck)
 import           Renamer.Renamer (rename)
 import           Grammar.Print (prt)
 
@@ -43,4 +44,4 @@ main = getArgs >>= \case
                         putStrLn ""
                         putStrLn " ----- TYPECHECKER ----- "
                         putStrLn ""
-                        putStrLn . printTree $ prg
+                        putStrLn . show $ prg
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index f663ec4..1584b4f 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -11,13 +11,14 @@ import Data.Map (Map)
 import qualified Data.Map as M
 import Grammar.ErrM (Err)
 import Grammar.Print
+import Data.List (findIndex)
 
 import Debug.Trace (trace)
 import TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx { vars :: Map Integer Type
                , sigs :: Map Ident Type
-               , count :: Int
+               , nextFresh :: Ident
                }
     deriving Show
 
@@ -32,7 +33,7 @@ programmer.
 type Infer = StateT Ctx (ExceptT Error Identity)
 
 initEnv :: Ctx
-initEnv = Ctx mempty mempty 0
+initEnv = Ctx mempty mempty "a"
 
 run :: Infer a -> Either Error a
 run = runIdentity . runExceptT . flip St.evalStateT initEnv
@@ -51,7 +52,6 @@ inferBind (RBind name e) = do
     insertSigs name t
     return $ TBind name t e'
 
-
 inferExp :: RExp -> Infer (Type, TExp)
 inferExp = \case
 
@@ -79,14 +79,14 @@ inferExp = \case
     RApp expr1 expr2 -> do
         (typ1, expr1') <- inferExp expr1
         (typ2, expr2') <- inferExp expr2
-        cnt <- incCount
+        fvar <- fresh
         case typ1 of
             (TPoly (Ident x)) -> do 
-                let newType = (TArrow (TPoly (Ident x)) (TPoly . Ident $ x ++ (show cnt)))
+                let newType = (TArrow (TPoly (Ident x)) (TPoly fvar))
                 specifyType expr1 newType
                 typ1' <- apply newType typ1
                 return $ (typ1', TApp expr1' expr2' typ1')
-            _         -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ2 typ1
+            _         -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ1 typ2
 
     RAdd expr1 expr2 -> do
         (typ1, expr1') <- inferExp expr1
@@ -115,11 +115,22 @@ isPoly :: Type -> Bool
 isPoly (TPoly _) = True
 isPoly _         = False
 
-incCount :: Infer Int
-incCount = do
-    st <- St.get
-    St.put ( st { count = succ st.count } )
-    return st.count
+fresh :: Infer Ident
+fresh = do
+    (Ident var) <- St.gets nextFresh
+    when (length var == 0) (throwError $ Default "fresh")
+    index <- case findIndex (== (head var)) alphabet of
+                  Nothing -> throwError $ Default "fresh"
+                  Just i -> return i
+    let nextIndex = (index + 1) `mod` 26
+    let newVar = Ident $ [alphabet !! nextIndex]
+    St.modify (\st -> st { nextFresh = newVar })
+    return newVar
+  where
+    alphabet = "abcdefghijklmnopqrstuvwxyz" :: [Char]
+
+unify :: Type -> Type -> Infer Type
+unify = todo
 
 -- | Specify the type of a bound variable
 -- Because in lambdas we have to assume a general type and update it
@@ -153,12 +164,6 @@ insertSigs i t = do
     st <- St.get
     St.put ( st { sigs = M.insert i t st.sigs } )
 
-union :: Type -> Type -> Infer ()
-union = todo
-
-find :: Type -> Type
-find = todo
-
 -- Have to figure out the equivalence classes for types.
 -- Currently this does not support more than exact matches.
 apply :: Type -> Type -> Infer Type
diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs
new file mode 100644
index 0000000..1842707
--- /dev/null
+++ b/src/TypeChecker/Unification.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE DeriveAnyClass, PatternSynonyms, GADTs, LambdaCase, OverloadedStrings #-}
+
+module TypeChecker.Unification where
+
+import           Renamer.Renamer
+import           Renamer.RenamerIr (Const(..), RExp(..), RBind(..), RProgram(..), Ident(..))
+import qualified Renamer.RenamerIr as R
+
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Control.Monad.Except
+import           Data.Functor.Identity
+import           Control.Arrow ((>>>))
+import           Control.Unification        hiding ((=:=), applyBindings)
+import qualified Control.Unification        as U
+import           Control.Unification.IntVar
+import           Data.Functor.Fixedpoint
+import           GHC.Generics (Generic1)
+import           Data.Foldable (fold)
+import           Data.Map (Map)
+import qualified Data.Map as M
+import           Data.Maybe (fromMaybe, fromJust)
+import           Data.Set (Set, (\\))
+import qualified Data.Set as S
+import           Debug.Trace (trace)
+
+type Ctx = Map Ident UPolytype
+
+type TypeError = String
+
+data TypeT a = TPolyT Ident | TMonoT Ident | TArrowT a a
+    deriving (Functor, Foldable, Traversable, Generic1, Unifiable)
+
+instance Show a => Show (TypeT a) where
+    show (TPolyT (Ident i)) = i
+    show (TMonoT (Ident i)) = i
+    show (TArrowT a b) = show a ++ " -> " ++ show b
+
+type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity)))
+
+type Type = Fix TypeT
+type UType = UTerm TypeT IntVar
+
+data Poly t = Forall [Ident] t
+  deriving (Eq, Show, Functor)
+
+type Polytype  = Poly Type
+
+type UPolytype = Poly UType
+
+pattern TPoly :: Ident -> Type
+pattern TPoly v = Fix (TPolyT v)
+
+pattern TMono :: Ident -> Type
+pattern TMono v = Fix (TMonoT v)
+
+pattern TArrow :: Type -> Type -> Type
+pattern TArrow t1 t2 = Fix (TArrowT t1 t2)
+
+pattern UTMono :: Ident -> UType
+pattern UTMono v = UTerm (TMonoT v)
+
+pattern UTArrow :: UType -> UType -> UType
+pattern UTArrow t1 t2 = UTerm (TArrowT t1 t2)
+
+pattern UTPoly :: Ident -> UType
+pattern UTPoly v = UTerm (TPolyT v)
+
+data TType = TTPoly Ident | TTMono Ident | TTArrow TType TType
+    deriving Show
+
+data Program = Program [Bind]
+    deriving Show
+
+data Bind = Bind Ident Exp Polytype
+    deriving Show
+
+data Exp
+    = EAnn Exp Polytype
+    | EBound Ident Polytype
+    | EFree Ident Polytype 
+    | EConst Const Polytype
+    | EApp Exp Exp Polytype
+    | EAdd Exp Exp Polytype
+    | EAbs Ident Exp Polytype
+    deriving Show
+
+data TExp
+    = TAnn TExp UType
+    | TFree Ident UType
+    | TBound Ident UType
+    | TConst Const UType
+    | TApp TExp TExp UType
+    | TAdd TExp TExp UType
+    | TAbs Ident TExp UType
+    deriving Show
+
+----------------------------------------------------------
+typecheck :: RProgram -> Either TypeError Program
+typecheck = run . inferProgram 
+
+inferProgram :: RProgram -> Infer Program
+inferProgram (RProgram binds) = do
+    binds' <- mapM inferBind binds
+    return $ Program binds'
+
+inferBind :: RBind -> Infer Bind
+inferBind (RBind i e) = do
+    (t,e') <- infer e
+    e'' <- convert fromUType e'
+    t' <- fromUType t
+    insertSigs i (Forall [] t)
+    return $ Bind i e'' t'
+
+fromUType :: UType -> Infer Polytype
+fromUType = applyBindings >>> (>>= (generalize >>> fmap fromUPolytype))
+    
+convert :: (UType -> Infer Polytype) -> TExp -> Infer Exp
+convert f = \case
+    (TAnn e t) -> do
+        e' <- convert f e
+        t' <- (f t)
+        return $ EAnn e' t'
+    (TFree i t) -> do
+        t' <- f t
+        return $ EFree i t'
+    (TBound i t) -> do
+        t' <- f t
+        return $ EBound i t'
+    (TConst c t) -> do 
+        t' <- f t
+        return $ EConst c t'
+    (TApp e1 e2 t) -> do
+        e1' <- convert f e1
+        e2' <- convert f e2
+        t' <- f t
+        return $ EApp e1' e2' t'
+    (TAdd e1 e2 t) -> do 
+        e1' <- convert f e1
+        e2' <- convert f e2
+        t' <- f t
+        return $ EAdd e1' e2' t'
+    (TAbs i e t) -> do 
+        e' <- convert f e
+        t' <- f t
+        return $ EAbs i e' t'
+
+run :: Infer a -> Either TypeError a
+run = flip evalStateT mempty
+      >>> flip runReaderT mempty
+      >>> runExceptT
+      >>> evalIntBindingT
+      >>> runIdentity
+
+infer :: RExp -> Infer (UType, TExp)
+infer = \case
+    (RConst (CInt i)) -> return $ (UTMono "Int", TConst (CInt i) (UTMono "Int"))
+    (RConst (CStr str)) -> return $ (UTMono "String", TConst (CStr str) (UTMono "String"))
+    (RAdd e1 e2) -> do
+        (t1,e1') <- infer e2
+        (t2,e2') <- infer e1
+        t1 =:= (UTMono "Int")
+        t2 =:= (UTMono "Int")
+        return $ (UTMono "Int", TAdd e1' e2' (UTMono "Int"))
+    (RAnn e t) -> do
+        (t',e') <- infer e
+        check e t'
+        return (t', TAnn e' t')
+    (RApp e1 e2) -> do
+        (f,e1') <- infer e1
+        (arg,e2') <- infer e2
+        res <- fresh
+        f =:= UTArrow f arg
+        return (res, TApp e1' e2' res)
+    (RAbs _ i e) -> do
+        arg <- fresh
+        withBinding i (Forall [] arg) $ do
+            (res, e') <- infer e
+            return $ (UTArrow arg res, TAbs i e' (UTArrow arg res))
+    (RFree i) -> do
+        t <- lookupSigsT i
+        return (t, TFree i t)
+    (RBound _ i) -> do
+        t <- lookupVarT i
+        return (t, TBound i t)
+
+check :: RExp -> UType -> Infer ()
+check expr t = do
+    (t', _) <- infer expr
+    t =:= t'
+    return ()
+
+lookupVarT :: Ident -> Infer UType
+lookupVarT x@(Ident i) = do
+    ctx <- ask
+    maybe (throwError $ "Var - Unbound variable: " <> i) instantiate (M.lookup x ctx)
+
+lookupSigsT :: Ident -> Infer UType
+lookupSigsT x@(Ident i) = do
+    ctx <- ask
+    case M.lookup x ctx of
+      Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i)
+      Just ut -> return $ fromPolytype ut
+
+insertSigs :: MonadState (Map Ident UPolytype) m => Ident -> UPolytype -> m ()
+insertSigs x ty = modify (M.insert x ty)
+
+fromPolytype :: UPolytype -> UType
+fromPolytype (Forall ids ut) = ut
+
+ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a
+ucata f _ (UVar v) = f v
+ucata f g (UTerm t) = g (fmap (ucata f g) t)
+
+withBinding :: MonadReader Ctx m => Ident -> UPolytype -> m a -> m a
+withBinding x ty = local (M.insert x ty)
+
+deriving instance Ord IntVar
+
+class FreeVars a where
+  freeVars :: a -> Infer (Set (Either Ident IntVar))
+
+instance FreeVars UType where
+  freeVars ut = do
+    fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut
+    let ftvs = ucata (const S.empty)
+                     (\case {TMonoT x -> S.singleton (Left x); f -> fold f})
+                     ut
+    return $ fuvs `S.union` ftvs
+
+instance FreeVars UPolytype where
+  freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut
+
+instance FreeVars Ctx where
+  freeVars = fmap S.unions . mapM freeVars . M.elems
+
+fresh :: Infer UType
+fresh = UVar <$> lift (lift (lift freeVar))
+
+instance Fallible TypeT IntVar TypeError where
+    occursFailure iv ut = "Infinite"
+    mismatchFailure iv ut = "Mismatch"
+
+(=:=) :: UType -> UType -> Infer UType
+(=:=) s t = lift . lift $ s U.=:= t
+
+applyBindings :: UType -> Infer UType
+applyBindings = lift . lift . U.applyBindings
+
+instantiate :: UPolytype -> Infer UType
+instantiate (Forall xs uty) = do
+  xs' <- mapM (const fresh) xs
+  return $ substU (M.fromList (zip (map Left xs) xs')) uty
+
+substU :: Map (Either Ident IntVar) UType -> UType -> UType
+substU m = ucata
+  (\v -> fromMaybe (UVar v) (M.lookup (Right v) m))
+  (\case
+      TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m)
+      f -> UTerm f
+  )
+
+skolemize :: UPolytype -> Infer UType
+skolemize (Forall xs uty) = do
+  xs' <- mapM (const fresh) xs
+  return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty
+  where
+    toSkolem (UVar v) = UTPoly (mkVarName "s" v)
+
+mkVarName :: String -> IntVar -> Ident
+mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1)
+
+generalize :: UType -> Infer UPolytype
+generalize uty = do
+  uty' <- applyBindings uty
+  ctx <- ask
+  tmfvs  <- freeVars uty'
+  ctxfvs <- freeVars ctx
+  let fvs = S.toList $ tmfvs \\ ctxfvs
+      xs  = map (either id (mkVarName "a")) fvs
+  return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty')
+
+fromUPolytype :: UPolytype -> Polytype
+fromUPolytype = fmap (fromJust . freeze)
diff --git a/test_program b/test_program
index db9a44e..fdb3de4 100644
--- a/test_program
+++ b/test_program
@@ -1 +1,3 @@
-test f x = f x
+apply w x = \y. \z. w + x + y + z ;
+
+main = apply 1 2 3 4 ;

From a9f54dbca1881adb3f364099a73369db52b26ca2 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 17 Feb 2023 11:09:48 +0100
Subject: [PATCH 29/71] Simplified quite a bit. Made a unify function. Still
 bugs left

---
 fourmolu.yaml                  |   4 +-
 language.cabal                 |   2 +-
 src/TypeChecker/TypeChecker.hs | 222 +++++++++++++++------------------
 src/TypeChecker/Unification.hs | 173 +++++++++++++------------
 4 files changed, 192 insertions(+), 209 deletions(-)

diff --git a/fourmolu.yaml b/fourmolu.yaml
index f15300e..cf7ab2f 100644
--- a/fourmolu.yaml
+++ b/fourmolu.yaml
@@ -3,12 +3,12 @@ function-arrows: trailing
 comma-style: leading
 import-export-style: diff-friendly
 indent-wheres: false
-record-brace-space: false
+record-brace-space: true
 newlines-between-decls: 1
 haddock-style: multi-line
 haddock-style-module:
 let-style: auto
 in-style: right-align
-respectful: true
+respectful: false
 fixities: []
 unicode: never
diff --git a/language.cabal b/language.cabal
index e3d40b9..36b63c7 100644
--- a/language.cabal
+++ b/language.cabal
@@ -17,7 +17,7 @@ extra-source-files:
 
 
 common warnings
-    ghc-options: -Wdefault
+    ghc-options: -W
 
 executable language
     import:           warnings
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 1584b4f..9b94f55 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,26 +1,30 @@
-{-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use camelCase" #-}
 
 module TypeChecker.TypeChecker where
 
-import Control.Monad (when, void)
-import Control.Monad.Except (ExceptT, throwError, runExceptT)
+import Control.Monad (void)
+import Control.Monad.Except (ExceptT, runExceptT, throwError)
 import Control.Monad.State (StateT)
-import qualified Control.Monad.State as St
+import Control.Monad.State qualified as St
 import Data.Functor.Identity (Identity, runIdentity)
 import Data.Map (Map)
-import qualified Data.Map as M
-import Grammar.ErrM (Err)
-import Grammar.Print
-import Data.List (findIndex)
-
-import Debug.Trace (trace)
+import Data.Map qualified as M
 import TypeChecker.TypeCheckerIr
 
-data Ctx = Ctx { vars :: Map Integer Type
-               , sigs :: Map Ident Type
-               , nextFresh :: Ident
-               }
-    deriving Show
+data Ctx = Ctx
+    { vars :: Map Integer Type
+    , sigs :: Map Ident Type
+    , nextFresh :: Int
+    }
+    deriving (Show)
+
+-- Perhaps swap over to reader monad instead for vars and sigs.
+type Infer = StateT Ctx (ExceptT Error Identity)
 
 {-
 
@@ -28,18 +32,20 @@ The type checker will assume we first rename all variables to unique name, as to
 have to care about scoping. It significantly improves the quality of life of the
 programmer.
 
+TODOs:
+    Add skolemization variables. i.e
+    { \x. 3 : forall a. a -> a }
+    should not type check
+
+    Generalize. Not really sure what that means though
+
 -}
 
-type Infer = StateT Ctx (ExceptT Error Identity)
-
-initEnv :: Ctx
-initEnv = Ctx mempty mempty "a"
-
 run :: Infer a -> Either Error a
-run = runIdentity . runExceptT . flip St.evalStateT initEnv
+run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
 
 typecheck :: RProgram -> Either Error TProgram
-typecheck = run . inferPrg 
+typecheck = run . inferPrg
 
 inferPrg :: RProgram -> Infer TProgram
 inferPrg (RProgram xs) = do
@@ -54,122 +60,83 @@ inferBind (RBind name e) = do
 
 inferExp :: RExp -> Infer (Type, TExp)
 inferExp = \case
-
     RAnn expr typ -> do
-        (t,expr') <- inferExp expr
-        when (not (t == typ || isPoly t)) (throwError $ AnnotatedMismatch "inferExp, RAnn")
-        return (typ,expr')
-
-    -- Name is only here for proper error messages
-    RBound num name ->
-        M.lookup num <$> St.gets vars >>= \case
-            Nothing -> throwError $ UnboundVar "RBound"
-            Just t -> return (t, TBound num name t)
-
+        (t, expr') <- inferExp expr
+        void $ t =:= typ
+        return (typ, expr')
+    RBound num name -> do
+        t <- lookupVars num
+        return (t, TBound num name t)
     RFree name -> do
-        M.lookup name <$> St.gets sigs >>= \case
-            Nothing -> throwError $ UnboundVar "RFree"
-            Just t -> return (t, TFree name t)
-
-    RConst (CInt i) -> return $ (TMono "Int", TConst (CInt i) (TMono "Int"))
-
-    RConst (CStr str) -> return $ (TMono "Str", TConst (CStr str) (TMono "Str"))
-
-    -- Should do proper unification using union-find. Some nice libs exist
-    RApp expr1 expr2 -> do
-        (typ1, expr1') <- inferExp expr1
-        (typ2, expr2') <- inferExp expr2
-        fvar <- fresh
-        case typ1 of
-            (TPoly (Ident x)) -> do 
-                let newType = (TArrow (TPoly (Ident x)) (TPoly fvar))
-                specifyType expr1 newType
-                typ1' <- apply newType typ1
-                return $ (typ1', TApp expr1' expr2' typ1')
-            _         -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ1 typ2
-
+        t <- lookupSigs name
+        return (t, TFree name t)
+    RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int"))
+    RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str"))
     RAdd expr1 expr2 -> do
-        (typ1, expr1') <- inferExp expr1
-        (typ2, expr2') <- inferExp expr2
-        when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError $ TypeMismatch "inferExp, RAdd")
-        specifyType expr1 (TMono "Int")
-        specifyType expr2 (TMono "Int")
-        return (TMono "Int", TAdd expr1' expr2' (TMono "Int"))
-
+        (typ1, expr1') <- check expr1 (TMono "Int")
+        (_, expr2') <- check expr2 (TMono "Int")
+        return (typ1, TAdd expr1' expr2' typ1)
+    RApp expr1 expr2 -> do
+        (fn_t, expr1') <- inferExp expr1
+        (arg_t, expr2') <- inferExp expr2
+        res <- fresh
+        -- TODO: Double check if this is correct behavior.
+        -- It might be the case that we should return res, rather than new_t
+        new_t <- fn_t =:= TArrow arg_t res
+        return (new_t, TApp expr1' expr2' new_t)
     RAbs num name expr -> do
-        insertVars num (TPoly "a")
+        arg <- fresh
+        insertVars num arg
         (typ, expr') <- inferExp expr
-        newTyp <- lookupVars num
-        return $ (TArrow newTyp typ, TAbs num name expr' typ)
+        return (TArrow arg typ, TAbs num name expr' typ)
 
--- Aux
-isInt :: Type -> Bool
-isInt (TMono "Int") = True
-isInt _             = False
+check :: RExp -> Type -> Infer (Type, TExp)
+check e t = do
+    (t', e') <- inferExp e
+    t'' <- t' =:= t
+    return (t'', e')
 
-isArrow :: Type -> Bool
-isArrow (TArrow _ _) = True
-isArrow _            = False
-
-isPoly :: Type -> Bool
-isPoly (TPoly _) = True
-isPoly _         = False
-
-fresh :: Infer Ident
+fresh :: Infer Type
 fresh = do
-    (Ident var) <- St.gets nextFresh
-    when (length var == 0) (throwError $ Default "fresh")
-    index <- case findIndex (== (head var)) alphabet of
-                  Nothing -> throwError $ Default "fresh"
-                  Just i -> return i
-    let nextIndex = (index + 1) `mod` 26
-    let newVar = Ident $ [alphabet !! nextIndex]
-    St.modify (\st -> st { nextFresh = newVar })
-    return newVar
-  where
-    alphabet = "abcdefghijklmnopqrstuvwxyz" :: [Char]
+    var <- St.gets nextFresh
+    St.modify (\st -> st {nextFresh = succ var})
+    return (TPoly $ Ident (show var))
 
-unify :: Type -> Type -> Infer Type
-unify = todo
-
--- | Specify the type of a bound variable
--- Because in lambdas we have to assume a general type and update it
-specifyType :: RExp -> Type -> Infer ()
-specifyType (RBound num name) typ = do
-    insertVars num typ
-    return ()
-specifyType _ _ = return ()
+-- | Unify two types.
+(=:=) :: Type -> Type -> Infer Type
+(=:=) (TPoly _) b = return b
+(=:=) a (TPoly _) = return a
+(=:=) (TMono a) (TMono b) | a == b = return (TMono a)
+(=:=) (TArrow a b) (TArrow c d) = do
+    t1 <- a =:= c
+    t2 <- b =:= d
+    return $ TArrow t1 t2
+(=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
 
+-- Unused currently
 lookupVars :: Integer -> Infer Type
 lookupVars i = do
     st <- St.gets vars
     case M.lookup i st of
-      Just t -> return t
-      Nothing -> throwError $ UnboundVar "lookupVars"
+        Just t -> return t
+        Nothing -> throwError $ UnboundVar "lookupVars"
 
 insertVars :: Integer -> Type -> Infer ()
 insertVars i t = do
     st <- St.get
-    St.put ( st { vars = M.insert i t st.vars } )
+    St.put (st {vars = M.insert i t st.vars})
 
 lookupSigs :: Ident -> Infer Type
 lookupSigs i = do
     st <- St.gets sigs
     case M.lookup i st of
-      Just t -> return t
-      Nothing -> throwError $ UnboundVar "lookupSigs"
+        Just t -> return t
+        Nothing -> throwError $ UnboundVar "lookupSigs"
 
 insertSigs :: Ident -> Type -> Infer ()
 insertSigs i t = do
     st <- St.get
-    St.put ( st { sigs = M.insert i t st.sigs } )
-
--- Have to figure out the equivalence classes for types.
--- Currently this does not support more than exact matches.
-apply :: Type -> Type -> Infer Type
-apply (TArrow t1 t2) t3
-  | t1 == t3 = return t2
-apply t1 t2 = throwError $ TypeMismatch "apply"
+    St.put (st {sigs = M.insert i t st.sigs})
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
@@ -183,21 +150,30 @@ data Error
     | UnboundVar String
     | AnnotatedMismatch String
     | Default String
-    deriving Show
+    deriving (Show)
 
 -- Tests
 
-lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x"))
-lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String")))
+-- (\x. x + 1) 1
+app_lambda :: RExp
+app_lambda = app lambda one
 
-fn_on_var = RAbs 0 (Ident "f") (RAbs 1 (Ident "x") (RApp (RBound 0 (Ident "f")) (RBound 1 (Ident "x"))))
+lambda :: RExp
+lambda = RAbs 0 "x" $ add bound one
 
+add :: RExp -> RExp -> RExp
+add = RAdd
 
---add x = \y. x+y;
-add = RAbs 0 "x" (RAbs 1 "y" (RAdd (RBound 0 "x") (RBound 1 "y")))
--- main = (\z. z+z) ((add 4) 6);
-main = RApp (RAbs 0 "z" (RAdd (RBound 0 "z") (RBound 0 "z"))) applyAdd
-four = RConst (CInt 4)
-six = RConst (CInt 6)
-applyAdd = (RApp (RApp add four) six)
-partialAdd = RApp add four
+bound = RBound 0 "x"
+
+app :: RExp -> RExp -> RExp
+app = RApp
+
+one :: RExp
+one = RConst (CInt 1)
+
+fn_t = TArrow (TPoly (Ident "0")) (TMono (Ident "Int"))
+
+arr_t = TArrow (TMono "Int") (TPoly "1")
+
+f_x = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs
index 1842707..6c86a70 100644
--- a/src/TypeChecker/Unification.hs
+++ b/src/TypeChecker/Unification.hs
@@ -1,28 +1,31 @@
-{-# LANGUAGE DeriveAnyClass, PatternSynonyms, GADTs, LambdaCase, OverloadedStrings #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module TypeChecker.Unification where
 
-import           Renamer.Renamer
-import           Renamer.RenamerIr (Const(..), RExp(..), RBind(..), RProgram(..), Ident(..))
-import qualified Renamer.RenamerIr as R
-
-import           Control.Monad.Reader
-import           Control.Monad.State
-import           Control.Monad.Except
-import           Data.Functor.Identity
-import           Control.Arrow ((>>>))
-import           Control.Unification        hiding ((=:=), applyBindings)
-import qualified Control.Unification        as U
-import           Control.Unification.IntVar
-import           Data.Functor.Fixedpoint
-import           GHC.Generics (Generic1)
-import           Data.Foldable (fold)
-import           Data.Map (Map)
-import qualified Data.Map as M
-import           Data.Maybe (fromMaybe, fromJust)
-import           Data.Set (Set, (\\))
-import qualified Data.Set as S
-import           Debug.Trace (trace)
+import Control.Arrow ((>>>))
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Unification hiding (applyBindings, (=:=))
+import Control.Unification qualified as U
+import Control.Unification.IntVar
+import Data.Foldable (fold)
+import Data.Functor.Fixedpoint
+import Data.Functor.Identity
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Set (Set, (\\))
+import Data.Set qualified as S
+import Debug.Trace (trace)
+import GHC.Generics (Generic1)
+import Renamer.Renamer
+import Renamer.RenamerIr (Const (..), Ident (..), RBind (..), RExp (..), RProgram (..))
+import Renamer.RenamerIr qualified as R
 
 type Ctx = Map Ident UPolytype
 
@@ -39,12 +42,13 @@ instance Show a => Show (TypeT a) where
 type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity)))
 
 type Type = Fix TypeT
+
 type UType = UTerm TypeT IntVar
 
 data Poly t = Forall [Ident] t
-  deriving (Eq, Show, Functor)
+    deriving (Eq, Show, Functor)
 
-type Polytype  = Poly Type
+type Polytype = Poly Type
 
 type UPolytype = Poly UType
 
@@ -67,23 +71,23 @@ pattern UTPoly :: Ident -> UType
 pattern UTPoly v = UTerm (TPolyT v)
 
 data TType = TTPoly Ident | TTMono Ident | TTArrow TType TType
-    deriving Show
+    deriving (Show)
 
-data Program = Program [Bind]
-    deriving Show
+newtype Program = Program [Bind]
+    deriving (Show)
 
 data Bind = Bind Ident Exp Polytype
-    deriving Show
+    deriving (Show)
 
 data Exp
     = EAnn Exp Polytype
     | EBound Ident Polytype
-    | EFree Ident Polytype 
+    | EFree Ident Polytype
     | EConst Const Polytype
     | EApp Exp Exp Polytype
     | EAdd Exp Exp Polytype
     | EAbs Ident Exp Polytype
-    deriving Show
+    deriving (Show)
 
 data TExp
     = TAnn TExp UType
@@ -93,11 +97,11 @@ data TExp
     | TApp TExp TExp UType
     | TAdd TExp TExp UType
     | TAbs Ident TExp UType
-    deriving Show
+    deriving (Show)
 
 ----------------------------------------------------------
 typecheck :: RProgram -> Either TypeError Program
-typecheck = run . inferProgram 
+typecheck = run . inferProgram
 
 inferProgram :: RProgram -> Infer Program
 inferProgram (RProgram binds) = do
@@ -106,7 +110,7 @@ inferProgram (RProgram binds) = do
 
 inferBind :: RBind -> Infer Bind
 inferBind (RBind i e) = do
-    (t,e') <- infer e
+    (t, e') <- infer e
     e'' <- convert fromUType e'
     t' <- fromUType t
     insertSigs i (Forall [] t)
@@ -114,20 +118,19 @@ inferBind (RBind i e) = do
 
 fromUType :: UType -> Infer Polytype
 fromUType = applyBindings >>> (>>= (generalize >>> fmap fromUPolytype))
-    
+
 convert :: (UType -> Infer Polytype) -> TExp -> Infer Exp
 convert f = \case
     (TAnn e t) -> do
         e' <- convert f e
-        t' <- (f t)
-        return $ EAnn e' t'
+        EAnn e' <$> f t
     (TFree i t) -> do
         t' <- f t
         return $ EFree i t'
     (TBound i t) -> do
         t' <- f t
         return $ EBound i t'
-    (TConst c t) -> do 
+    (TConst c t) -> do
         t' <- f t
         return $ EConst c t'
     (TApp e1 e2 t) -> do
@@ -135,42 +138,43 @@ convert f = \case
         e2' <- convert f e2
         t' <- f t
         return $ EApp e1' e2' t'
-    (TAdd e1 e2 t) -> do 
+    (TAdd e1 e2 t) -> do
         e1' <- convert f e1
         e2' <- convert f e2
         t' <- f t
         return $ EAdd e1' e2' t'
-    (TAbs i e t) -> do 
+    (TAbs i e t) -> do
         e' <- convert f e
         t' <- f t
         return $ EAbs i e' t'
 
 run :: Infer a -> Either TypeError a
-run = flip evalStateT mempty
-      >>> flip runReaderT mempty
-      >>> runExceptT
-      >>> evalIntBindingT
-      >>> runIdentity
+run =
+    flip evalStateT mempty
+        >>> flip runReaderT mempty
+        >>> runExceptT
+        >>> evalIntBindingT
+        >>> runIdentity
 
 infer :: RExp -> Infer (UType, TExp)
 infer = \case
-    (RConst (CInt i)) -> return $ (UTMono "Int", TConst (CInt i) (UTMono "Int"))
-    (RConst (CStr str)) -> return $ (UTMono "String", TConst (CStr str) (UTMono "String"))
+    (RConst (CInt i)) -> return (UTMono "Int", TConst (CInt i) (UTMono "Int"))
+    (RConst (CStr str)) -> return (UTMono "String", TConst (CStr str) (UTMono "String"))
     (RAdd e1 e2) -> do
-        (t1,e1') <- infer e2
-        (t2,e2') <- infer e1
-        t1 =:= (UTMono "Int")
-        t2 =:= (UTMono "Int")
-        return $ (UTMono "Int", TAdd e1' e2' (UTMono "Int"))
+        (t1, e1') <- infer e2
+        (t2, e2') <- infer e1
+        t1 =:= UTMono "Int"
+        t2 =:= UTMono "Int"
+        return (UTMono "Int", TAdd e1' e2' (UTMono "Int"))
     (RAnn e t) -> do
-        (t',e') <- infer e
+        (t', e') <- infer e
         check e t'
         return (t', TAnn e' t')
     (RApp e1 e2) -> do
-        (f,e1') <- infer e1
-        (arg,e2') <- infer e2
+        (f, e1') <- infer e1
+        (arg, e2') <- infer e2
         res <- fresh
-        f =:= UTArrow f arg
+        f =:= UTArrow arg res
         return (res, TApp e1' e2' res)
     (RAbs _ i e) -> do
         arg <- fresh
@@ -199,8 +203,8 @@ lookupSigsT :: Ident -> Infer UType
 lookupSigsT x@(Ident i) = do
     ctx <- ask
     case M.lookup x ctx of
-      Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i)
-      Just ut -> return $ fromPolytype ut
+        Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i)
+        Just ut -> return $ fromPolytype ut
 
 insertSigs :: MonadState (Map Ident UPolytype) m => Ident -> UPolytype -> m ()
 insertSigs x ty = modify (M.insert x ty)
@@ -218,21 +222,23 @@ withBinding x ty = local (M.insert x ty)
 deriving instance Ord IntVar
 
 class FreeVars a where
-  freeVars :: a -> Infer (Set (Either Ident IntVar))
+    freeVars :: a -> Infer (Set (Either Ident IntVar))
 
 instance FreeVars UType where
-  freeVars ut = do
-    fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut
-    let ftvs = ucata (const S.empty)
-                     (\case {TMonoT x -> S.singleton (Left x); f -> fold f})
-                     ut
-    return $ fuvs `S.union` ftvs
+    freeVars ut = do
+        fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut
+        let ftvs =
+                ucata
+                    (const S.empty)
+                    (\case TMonoT x -> S.singleton (Left x); f -> fold f)
+                    ut
+        return $ fuvs `S.union` ftvs
 
 instance FreeVars UPolytype where
-  freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut
+    freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut
 
 instance FreeVars Ctx where
-  freeVars = fmap S.unions . mapM freeVars . M.elems
+    freeVars = fmap S.unions . mapM freeVars . M.elems
 
 fresh :: Infer UType
 fresh = UVar <$> lift (lift (lift freeVar))
@@ -249,21 +255,22 @@ applyBindings = lift . lift . U.applyBindings
 
 instantiate :: UPolytype -> Infer UType
 instantiate (Forall xs uty) = do
-  xs' <- mapM (const fresh) xs
-  return $ substU (M.fromList (zip (map Left xs) xs')) uty
+    xs' <- mapM (const fresh) xs
+    return $ substU (M.fromList (zip (map Left xs) xs')) uty
 
 substU :: Map (Either Ident IntVar) UType -> UType -> UType
-substU m = ucata
-  (\v -> fromMaybe (UVar v) (M.lookup (Right v) m))
-  (\case
-      TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m)
-      f -> UTerm f
-  )
+substU m =
+    ucata
+        (\v -> fromMaybe (UVar v) (M.lookup (Right v) m))
+        ( \case
+            TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m)
+            f -> UTerm f
+        )
 
 skolemize :: UPolytype -> Infer UType
 skolemize (Forall xs uty) = do
-  xs' <- mapM (const fresh) xs
-  return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty
+    xs' <- mapM (const fresh) xs
+    return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty
   where
     toSkolem (UVar v) = UTPoly (mkVarName "s" v)
 
@@ -272,13 +279,13 @@ mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1)
 
 generalize :: UType -> Infer UPolytype
 generalize uty = do
-  uty' <- applyBindings uty
-  ctx <- ask
-  tmfvs  <- freeVars uty'
-  ctxfvs <- freeVars ctx
-  let fvs = S.toList $ tmfvs \\ ctxfvs
-      xs  = map (either id (mkVarName "a")) fvs
-  return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty')
+    uty' <- applyBindings uty
+    ctx <- ask
+    tmfvs <- freeVars uty'
+    ctxfvs <- freeVars ctx
+    let fvs = S.toList $ tmfvs \\ ctxfvs
+        xs = map (either id (mkVarName "a")) fvs
+    return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty')
 
 fromUPolytype :: UPolytype -> Polytype
 fromUPolytype = fmap (fromJust . freeze)

From f2e8a0225546d090b00b9afcf80274675040fcae Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 17 Feb 2023 12:01:22 +0100
Subject: [PATCH 30/71] Removed adhoc tests

---
 src/Main.hs                    | 85 ++++++++++++++++++----------------
 src/TypeChecker/TypeChecker.hs | 54 ++++++++-------------
 test_program                   |  4 +-
 3 files changed, 64 insertions(+), 79 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 0845f8c..9d83ea6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,47 +1,50 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Main where
 
-import           Grammar.Par        (myLexer, pProgram)
-import           Grammar.Print      (printTree)
-import           System.Environment (getArgs)
-import           System.Exit        (exitFailure, exitSuccess)
+import Grammar.Par (myLexer, pProgram)
 -- import           TypeChecker.TypeChecker (typecheck)
-import           TypeChecker.Unification (typecheck)
-import           Renamer.Renamer (rename)
-import           Grammar.Print (prt)
+
+import Grammar.Print (printTree)
+import Renamer.Renamer (rename)
+import System.Environment (getArgs)
+import System.Exit (exitFailure, exitSuccess)
+import TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
-main = getArgs >>= \case
-  []    -> print "Required file path missing"
-  (x:_) -> do
-    file <- readFile x
-    case pProgram (myLexer file) of
-      Left err -> do
-       putStrLn "SYNTAX ERROR"
-       putStrLn err
-       exitFailure
-      Right prg -> do
-        putStrLn ""
-        putStrLn " ----- PARSER ----- "
-        putStrLn ""
-        putStrLn . printTree $ prg
-        case rename prg of
-            Left err -> do
-              putStrLn "FAILED RENAMING"
-              putStrLn . show $ err
-              exitFailure
-            Right prg ->do
-                putStrLn ""
-                putStrLn " ----- RENAMER ----- "
-                putStrLn ""
-                putStrLn . printTree $ prg
-                case typecheck prg of
-                    Left err -> do
-                        putStrLn "TYPECHECK ERROR"
-                        putStrLn . show $ err
-                        exitFailure
-                    Right prg -> do
-                        putStrLn ""
-                        putStrLn " ----- TYPECHECKER ----- "
-                        putStrLn ""
-                        putStrLn . show $ prg
+main =
+    getArgs >>= \case
+        [] -> print "Required file path missing"
+        (x : _) -> do
+            file <- readFile x
+            case pProgram (myLexer file) of
+                Left err -> do
+                    putStrLn "SYNTAX ERROR"
+                    putStrLn err
+                    exitFailure
+                Right prg -> do
+                    putStrLn ""
+                    putStrLn " ----- PARSER ----- "
+                    putStrLn ""
+                    putStrLn . printTree $ prg
+                    case rename prg of
+                        Left err -> do
+                            putStrLn "FAILED RENAMING"
+                            print err
+                            exitFailure
+                        Right prg -> do
+                            putStrLn ""
+                            putStrLn " ----- RENAMER ----- "
+                            putStrLn ""
+                            putStrLn . printTree $ prg
+                            case typecheck prg of
+                                Left err -> do
+                                    putStrLn "TYPECHECK ERROR"
+                                    print err
+                                    exitFailure
+                                Right prg -> do
+                                    putStrLn ""
+                                    putStrLn " ----- TYPECHECKER ----- "
+                                    putStrLn ""
+                                    putStrLn . printTree $ prg
+                                    exitSuccess
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 9b94f55..d3aa41b 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -18,7 +18,7 @@ import TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx
     { vars :: Map Integer Type
-    , sigs :: Map Ident Type
+    , sigs :: Map Ident (RBind, Maybe Type)
     , nextFresh :: Int
     }
     deriving (Show)
@@ -52,12 +52,16 @@ inferPrg (RProgram xs) = do
     xs' <- mapM inferBind xs
     return $ TProgram xs'
 
+-- Binds are not correctly added to the context.
+-- Can't type check programs with more than one function currently
 inferBind :: RBind -> Infer TBind
-inferBind (RBind name e) = do
+inferBind b@(RBind name e) = do
+    insertSigs name b Nothing
     (t, e') <- inferExp e
-    insertSigs name t
     return $ TBind name t e'
 
+-- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
+-- { \x. \y. x + y } will have the type { a -> b -> Int }
 inferExp :: RExp -> Infer (Type, TExp)
 inferExp = \case
     RAnn expr typ -> do
@@ -68,8 +72,14 @@ inferExp = \case
         t <- lookupVars num
         return (t, TBound num name t)
     RFree name -> do
-        t <- lookupSigs name
-        return (t, TFree name t)
+        (b@(RBind name _), t) <- lookupSigs name
+        t' <- case t of
+            Nothing -> do
+                (TBind _ a _) <- inferBind b
+                insertSigs name b (Just a)
+                return a
+            Just a -> return a
+        return (t', TFree name t')
     RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int"))
     RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str"))
     RAdd expr1 expr2 -> do
@@ -126,17 +136,17 @@ insertVars i t = do
     st <- St.get
     St.put (st {vars = M.insert i t st.vars})
 
-lookupSigs :: Ident -> Infer Type
+lookupSigs :: Ident -> Infer (RBind, Maybe Type)
 lookupSigs i = do
     st <- St.gets sigs
     case M.lookup i st of
         Just t -> return t
         Nothing -> throwError $ UnboundVar "lookupSigs"
 
-insertSigs :: Ident -> Type -> Infer ()
-insertSigs i t = do
+insertSigs :: Ident -> RBind -> Maybe Type -> Infer ()
+insertSigs i b t = do
     st <- St.get
-    St.put (st {sigs = M.insert i t st.sigs})
+    St.put (st {sigs = M.insert i (b, t) st.sigs})
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
@@ -151,29 +161,3 @@ data Error
     | AnnotatedMismatch String
     | Default String
     deriving (Show)
-
--- Tests
-
--- (\x. x + 1) 1
-app_lambda :: RExp
-app_lambda = app lambda one
-
-lambda :: RExp
-lambda = RAbs 0 "x" $ add bound one
-
-add :: RExp -> RExp -> RExp
-add = RAdd
-
-bound = RBound 0 "x"
-
-app :: RExp -> RExp -> RExp
-app = RApp
-
-one :: RExp
-one = RConst (CInt 1)
-
-fn_t = TArrow (TPoly (Ident "0")) (TMono (Ident "Int"))
-
-arr_t = TArrow (TMono "Int") (TPoly "1")
-
-f_x = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
diff --git a/test_program b/test_program
index fdb3de4..0849842 100644
--- a/test_program
+++ b/test_program
@@ -1,3 +1 @@
-apply w x = \y. \z. w + x + y + z ;
-
-main = apply 1 2 3 4 ;
+apply = \x. \y. (x : Mono Int)

From 764faa582ba1a6eacfc54a0a1510df6e9a56360f Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 17 Feb 2023 12:01:57 +0100
Subject: [PATCH 31/71] Remove hls pragmas

---
 src/TypeChecker/TypeChecker.hs | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index d3aa41b..d175773 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,9 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use camelCase" #-}
 
 module TypeChecker.TypeChecker where
 

From f188cffb8d373823c08a50af1b69303f4cd6a9e5 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 17 Feb 2023 18:42:50 +0100
Subject: [PATCH 32/71] Unification part works (probably). Have a hard time
 understanding it.

---
 language.cabal                   |   2 +-
 src/Main.hs                      |  14 ++--
 src/Renamer/RenamerIr.hs         |  19 ++---
 src/TypeChecker/TypeChecker.hs   | 127 ++++++++++++++---------------
 src/TypeChecker/TypeCheckerIr.hs |  66 ++++++++--------
 src/TypeChecker/Unification.hs   | 132 ++++++++++++-------------------
 test_program                     |   4 +-
 7 files changed, 167 insertions(+), 197 deletions(-)

diff --git a/language.cabal b/language.cabal
index 36b63c7..e3d40b9 100644
--- a/language.cabal
+++ b/language.cabal
@@ -17,7 +17,7 @@ extra-source-files:
 
 
 common warnings
-    ghc-options: -W
+    ghc-options: -Wdefault
 
 executable language
     import:           warnings
diff --git a/src/Main.hs b/src/Main.hs
index 9d83ea6..68027d4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,14 +2,14 @@
 
 module Main where
 
-import Grammar.Par (myLexer, pProgram)
+import           Grammar.Par             (myLexer, pProgram)
 -- import           TypeChecker.TypeChecker (typecheck)
 
-import Grammar.Print (printTree)
-import Renamer.Renamer (rename)
-import System.Environment (getArgs)
-import System.Exit (exitFailure, exitSuccess)
-import TypeChecker.TypeChecker (typecheck)
+import           Grammar.Print           (printTree)
+import           Renamer.Renamer         (rename)
+import           System.Environment      (getArgs)
+import           System.Exit             (exitFailure, exitSuccess)
+import           TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
 main =
@@ -46,5 +46,5 @@ main =
                                     putStrLn ""
                                     putStrLn " ----- TYPECHECKER ----- "
                                     putStrLn ""
-                                    putStrLn . printTree $ prg
+                                    print prg
                                     exitSuccess
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
index 33f1d3c..bac9915 100644
--- a/src/Renamer/RenamerIr.hs
+++ b/src/Renamer/RenamerIr.hs
@@ -1,12 +1,13 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Renamer.RenamerIr ( RExp (..)
-                         , RBind (..)
-                         , RProgram (..)
-                         , Const (..)
-                         , Ident (..)
-                         , Type (..)
-                         ) where
+module Renamer.RenamerIr (
+    RExp (..),
+    RBind (..),
+    RProgram (..),
+    Const (..),
+    Ident (..),
+    Type (..),
+) where
 
 import Grammar.Abs (
     Bind (..),
@@ -51,9 +52,9 @@ instance Print RBind where
 instance Print RExp where
     prt i = \case
         RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t])
-        RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)])
+        RBound n _ -> prPrec i 3 (concatD [prt 0 n])
         RFree id -> prPrec i 3 (concatD [prt 0 id])
         RConst n -> prPrec i 3 (concatD [prt 0 n])
         RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
         RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
-        RAbs u id e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e])
+        RAbs u _ e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 u, doc (showString "."), prt 0 e])
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index d175773..48d26ac 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,21 +1,22 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
 
 module TypeChecker.TypeChecker where
 
-import Control.Monad (void)
-import Control.Monad.Except (ExceptT, runExceptT, throwError)
-import Control.Monad.State (StateT)
-import Control.Monad.State qualified as St
-import Data.Functor.Identity (Identity, runIdentity)
-import Data.Map (Map)
-import Data.Map qualified as M
-import TypeChecker.TypeCheckerIr
+import           Control.Monad             (void)
+import           Control.Monad.Except      (ExceptT, runExceptT, throwError)
+import           Control.Monad.State       (StateT)
+import qualified Control.Monad.State       as St
+import           Data.Functor.Identity     (Identity, runIdentity)
+import           Data.Map                  (Map)
+import qualified Data.Map                  as M
+
+import           TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx
-    { vars :: Map Integer Type
-    , sigs :: Map Ident (RBind, Maybe Type)
+    { vars      :: Map Integer Type
+    , sigs      :: Map Ident Type
     , nextFresh :: Int
     }
     deriving (Show)
@@ -38,70 +39,54 @@ TODOs:
 
 -}
 
+typecheck :: RProgram -> Either Error TProgram
+typecheck = todo
+
 run :: Infer a -> Either Error a
 run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
 
-typecheck :: RProgram -> Either Error TProgram
-typecheck = run . inferPrg
-
-inferPrg :: RProgram -> Infer TProgram
-inferPrg (RProgram xs) = do
-    xs' <- mapM inferBind xs
-    return $ TProgram xs'
-
--- Binds are not correctly added to the context.
--- Can't type check programs with more than one function currently
-inferBind :: RBind -> Infer TBind
-inferBind b@(RBind name e) = do
-    insertSigs name b Nothing
-    (t, e') <- inferExp e
-    return $ TBind name t e'
-
 -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
 -- { \x. \y. x + y } will have the type { a -> b -> Int }
-inferExp :: RExp -> Infer (Type, TExp)
+inferExp :: RExp -> Infer Type
 inferExp = \case
+
     RAnn expr typ -> do
-        (t, expr') <- inferExp expr
+        t <- inferExp expr
         void $ t =:= typ
-        return (typ, expr')
-    RBound num name -> do
-        t <- lookupVars num
-        return (t, TBound num name t)
-    RFree name -> do
-        (b@(RBind name _), t) <- lookupSigs name
-        t' <- case t of
-            Nothing -> do
-                (TBind _ a _) <- inferBind b
-                insertSigs name b (Just a)
-                return a
-            Just a -> return a
-        return (t', TFree name t')
-    RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int"))
-    RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str"))
+        return t
+
+    RBound num name -> lookupVars num
+
+    RFree name -> lookupSigs name
+
+    RConst (CInt i) -> return $ TMono "Int"
+
+    RConst (CStr str) -> return $ TMono "Str"
+
     RAdd expr1 expr2 -> do
-        (typ1, expr1') <- check expr1 (TMono "Int")
-        (_, expr2') <- check expr2 (TMono "Int")
-        return (typ1, TAdd expr1' expr2' typ1)
+        let int = TMono "Int"
+        typ1 <- check expr1 int
+        typ2 <- check expr2 int
+        return int
+
     RApp expr1 expr2 -> do
-        (fn_t, expr1') <- inferExp expr1
-        (arg_t, expr2') <- inferExp expr2
+        fn_t <- inferExp expr1
+        arg_t <- inferExp expr2
         res <- fresh
-        -- TODO: Double check if this is correct behavior.
-        -- It might be the case that we should return res, rather than new_t
         new_t <- fn_t =:= TArrow arg_t res
-        return (new_t, TApp expr1' expr2' new_t)
+        return res
+
     RAbs num name expr -> do
         arg <- fresh
         insertVars num arg
-        (typ, expr') <- inferExp expr
-        return (TArrow arg typ, TAbs num name expr' typ)
+        typ <- inferExp expr
+        return $ TArrow arg typ
 
-check :: RExp -> Type -> Infer (Type, TExp)
+check :: RExp -> Type -> Infer ()
 check e t = do
-    (t', e') <- inferExp e
-    t'' <- t' =:= t
-    return (t'', e')
+    t' <- inferExp e
+    t =:= t'
+    return ()
 
 fresh :: Infer Type
 fresh = do
@@ -120,30 +105,29 @@ fresh = do
     return $ TArrow t1 t2
 (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
 
--- Unused currently
 lookupVars :: Integer -> Infer Type
 lookupVars i = do
     st <- St.gets vars
     case M.lookup i st of
-        Just t -> return t
-        Nothing -> throwError $ UnboundVar "lookupVars"
+       Just t  -> return t
+       Nothing -> throwError $ UnboundVar "lookupVars"
 
 insertVars :: Integer -> Type -> Infer ()
 insertVars i t = do
     st <- St.get
     St.put (st {vars = M.insert i t st.vars})
 
-lookupSigs :: Ident -> Infer (RBind, Maybe Type)
+lookupSigs :: Ident -> Infer Type
 lookupSigs i = do
     st <- St.gets sigs
     case M.lookup i st of
-        Just t -> return t
+        Just t  -> return t
         Nothing -> throwError $ UnboundVar "lookupSigs"
 
-insertSigs :: Ident -> RBind -> Maybe Type -> Infer ()
-insertSigs i b t = do
+insertSigs :: Ident -> Type -> Infer ()
+insertSigs i t = do
     st <- St.get
-    St.put (st {sigs = M.insert i (b, t) st.sigs})
+    St.put (st {sigs = M.insert i t st.sigs})
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
@@ -158,3 +142,12 @@ data Error
     | AnnotatedMismatch String
     | Default String
     deriving (Show)
+
+
+{-
+
+The procedure inst(σ) specializes the polytype
+σ by copying the term and replacing the bound type variables
+consistently by new monotype variables.
+
+-}
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 7d30ae8..6845afd 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,21 +1,21 @@
 {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr ( TProgram(..)
-                                 , TBind(..)
-                                 , TExp(..)
-                                 , RProgram(..)
-                                 , RBind(..)
-                                 , RExp(..)
-                                 , Type(..)
-                                 , Const(..)
-                                 , Ident(..)
-                                 )
-                                     where
+module TypeChecker.TypeCheckerIr (
+    TProgram (..),
+    TBind (..),
+    TExp (..),
+    RProgram (..),
+    RBind (..),
+    RExp (..),
+    Type (..),
+    Const (..),
+    Ident (..),
+) where
 
-import Renamer.RenamerIr
-import Grammar.Print
+import           Grammar.Print
+import           Renamer.RenamerIr
 
-data TProgram = TProgram [TBind]
+newtype TProgram = TProgram [TBind]
     deriving (Eq, Show, Read, Ord)
 
 data TBind = TBind Ident Type TExp
@@ -50,21 +50,25 @@ instance Print TBind where
 
 instance Print TExp where
     prt i = \case
-        TAnn e t -> prPrec i 2 $ concatD
-            [ prt 0 e
-            , doc (showString ":")
-            , prt 1 t
-            ]
-        TBound _ u t -> prPrec i 3 $ concatD [ prt 0 u ]
-        TFree u t -> prPrec i 3 $ concatD [ prt 0 u ]
+        TAnn e t ->
+            prPrec i 2 $
+                concatD
+                    [ prt 0 e
+                    , doc (showString ":")
+                    , prt 1 t
+                    ]
+        TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
+        TFree u t -> prPrec i 3 $ concatD [prt 0 u]
         TConst c _ -> prPrec i 3 (concatD [prt 0 c])
-        TApp e e1 t -> prPrec i 2 $ concatD [ prt 2 e , prt 3 e1 ]
-        TAdd e e1 t -> prPrec i 1 $ concatD [ prt 1 e , doc (showString "+") , prt 2 e1 ]
-        TAbs _ u e t -> prPrec i 0 $ concatD
-              [ doc (showString "(")
-              , doc (showString "λ")
-              , prt 0 u
-              , doc (showString ".")
-              , prt 0 e
-              , doc (showString ")")
-              ]
+        TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
+        TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
+        TAbs _ u e t ->
+            prPrec i 0 $
+                concatD
+                    [ doc (showString "(")
+                    , doc (showString "λ")
+                    , prt 0 u
+                    , doc (showString ".")
+                    , prt 0 e
+                    , doc (showString ")")
+                    ]
diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs
index 6c86a70..226e1e9 100644
--- a/src/TypeChecker/Unification.hs
+++ b/src/TypeChecker/Unification.hs
@@ -1,31 +1,31 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms   #-}
 
 module TypeChecker.Unification where
 
-import Control.Arrow ((>>>))
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Unification hiding (applyBindings, (=:=))
-import Control.Unification qualified as U
-import Control.Unification.IntVar
-import Data.Foldable (fold)
-import Data.Functor.Fixedpoint
-import Data.Functor.Identity
-import Data.Map (Map)
-import Data.Map qualified as M
-import Data.Maybe (fromJust, fromMaybe)
-import Data.Set (Set, (\\))
-import Data.Set qualified as S
-import Debug.Trace (trace)
-import GHC.Generics (Generic1)
-import Renamer.Renamer
-import Renamer.RenamerIr (Const (..), Ident (..), RBind (..), RExp (..), RProgram (..))
-import Renamer.RenamerIr qualified as R
+import           Control.Arrow              ((>>>))
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Control.Unification        hiding (applyBindings, (=:=))
+import qualified Control.Unification        as U
+import           Control.Unification.IntVar
+import           Data.Foldable              (fold)
+import           Data.Functor.Fixedpoint
+import           Data.Functor.Identity
+import           Data.Map                   (Map)
+import qualified Data.Map                   as M
+import           Data.Maybe                 (fromJust, fromMaybe)
+import           Data.Set                   (Set, (\\))
+import qualified Data.Set                   as S
+import           Debug.Trace                (trace)
+import           GHC.Generics               (Generic1)
+import           Renamer.Renamer
+import qualified Renamer.RenamerIr          as R
+import           Renamer.RenamerIr          (Const (..), Ident (..), RBind (..),
+                                             RExp (..), RProgram (..))
 
 type Ctx = Map Ident UPolytype
 
@@ -37,7 +37,7 @@ data TypeT a = TPolyT Ident | TMonoT Ident | TArrowT a a
 instance Show a => Show (TypeT a) where
     show (TPolyT (Ident i)) = i
     show (TMonoT (Ident i)) = i
-    show (TArrowT a b) = show a ++ " -> " ++ show b
+    show (TArrowT a b)      = show a ++ " -> " ++ show b
 
 type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity)))
 
@@ -46,7 +46,10 @@ type Type = Fix TypeT
 type UType = UTerm TypeT IntVar
 
 data Poly t = Forall [Ident] t
-    deriving (Eq, Show, Functor)
+    deriving (Eq, Functor)
+
+instance Show t => Show (Poly t) where
+    show (Forall is t) = unwords (map (\(Ident x) -> "forall " ++ x ++ ".") is) ++ " " ++ show t
 
 type Polytype = Poly Type
 
@@ -101,60 +104,17 @@ data TExp
 
 ----------------------------------------------------------
 typecheck :: RProgram -> Either TypeError Program
-typecheck = run . inferProgram
+typecheck = undefined
 
-inferProgram :: RProgram -> Infer Program
-inferProgram (RProgram binds) = do
-    binds' <- mapM inferBind binds
-    return $ Program binds'
-
-inferBind :: RBind -> Infer Bind
-inferBind (RBind i e) = do
-    (t, e') <- infer e
-    e'' <- convert fromUType e'
-    t' <- fromUType t
-    insertSigs i (Forall [] t)
-    return $ Bind i e'' t'
-
-fromUType :: UType -> Infer Polytype
-fromUType = applyBindings >>> (>>= (generalize >>> fmap fromUPolytype))
-
-convert :: (UType -> Infer Polytype) -> TExp -> Infer Exp
-convert f = \case
-    (TAnn e t) -> do
-        e' <- convert f e
-        EAnn e' <$> f t
-    (TFree i t) -> do
-        t' <- f t
-        return $ EFree i t'
-    (TBound i t) -> do
-        t' <- f t
-        return $ EBound i t'
-    (TConst c t) -> do
-        t' <- f t
-        return $ EConst c t'
-    (TApp e1 e2 t) -> do
-        e1' <- convert f e1
-        e2' <- convert f e2
-        t' <- f t
-        return $ EApp e1' e2' t'
-    (TAdd e1 e2 t) -> do
-        e1' <- convert f e1
-        e2' <- convert f e2
-        t' <- f t
-        return $ EAdd e1' e2' t'
-    (TAbs i e t) -> do
-        e' <- convert f e
-        t' <- f t
-        return $ EAbs i e' t'
-
-run :: Infer a -> Either TypeError a
-run =
-    flip evalStateT mempty
-        >>> flip runReaderT mempty
-        >>> runExceptT
-        >>> evalIntBindingT
-        >>> runIdentity
+run :: Infer (UType, TExp) -> Either TypeError Polytype
+run = fmap fst
+      >>> (>>= applyBindings)
+      >>> (>>= (generalize >>> fmap fromUPolytype))
+      >>> flip evalStateT mempty
+      >>> flip runReaderT mempty
+      >>> runExceptT
+      >>> evalIntBindingT
+      >>> runIdentity
 
 infer :: RExp -> Infer (UType, TExp)
 infer = \case
@@ -166,6 +126,7 @@ infer = \case
         t1 =:= UTMono "Int"
         t2 =:= UTMono "Int"
         return (UTMono "Int", TAdd e1' e2' (UTMono "Int"))
+    -- type is not used, probably wrong
     (RAnn e t) -> do
         (t', e') <- infer e
         check e t'
@@ -180,7 +141,7 @@ infer = \case
         arg <- fresh
         withBinding i (Forall [] arg) $ do
             (res, e') <- infer e
-            return $ (UTArrow arg res, TAbs i e' (UTArrow arg res))
+            return (UTArrow arg res, TAbs i e' (UTArrow arg res))
     (RFree i) -> do
         t <- lookupSigsT i
         return (t, TFree i t)
@@ -213,7 +174,7 @@ fromPolytype :: UPolytype -> UType
 fromPolytype (Forall ids ut) = ut
 
 ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a
-ucata f _ (UVar v) = f v
+ucata f _ (UVar v)  = f v
 ucata f g (UTerm t) = g (fmap (ucata f g) t)
 
 withBinding :: MonadReader Ctx m => Ident -> UPolytype -> m a -> m a
@@ -277,6 +238,7 @@ skolemize (Forall xs uty) = do
 mkVarName :: String -> IntVar -> Ident
 mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1)
 
+-- | Used in let bindings to generalize functions declared there
 generalize :: UType -> Infer UPolytype
 generalize uty = do
     uty' <- applyBindings uty
@@ -289,3 +251,11 @@ generalize uty = do
 
 fromUPolytype :: UPolytype -> Polytype
 fromUPolytype = fmap (fromJust . freeze)
+
+inf = RAbs 0 "x" (RApp (RBound 0 "x") (RBound 0 "x"))
+
+one = RConst (CInt 1)
+
+lambda = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
+
+fn = RAbs 0 "x" (RBound 0 "x")
diff --git a/test_program b/test_program
index 0849842..0639729 100644
--- a/test_program
+++ b/test_program
@@ -1 +1,3 @@
-apply = \x. \y. (x : Mono Int)
+test = \x. (x : Mono String) ;
+
+apply x y = x + y ;

From 8b5cd3cf9ae6b7de6d046ad50187fb7672e019bc Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Sat, 18 Feb 2023 23:08:27 +0100
Subject: [PATCH 33/71] Remade the algorithm myself. Still some bugs.

---
 Grammar.cf                       |  17 +--
 language.cabal                   |  14 +-
 src/Auxiliary.hs                 |  21 +++
 src/Main.hs                      |  36 ++---
 src/Renamer/Renamer.hs           |   8 +-
 src/Renamer/RenamerIr.hs         |  32 +----
 src/Renamer/RenamerM.hs          |  83 +++++++++++
 src/TypeChecker/HM.hs            | 155 ++++++++++++++++++++
 src/TypeChecker/HMIr.hs          | 102 +++++++++++++
 src/TypeChecker/TypeChecker.hs   | 236 +++++++++++++++----------------
 src/TypeChecker/TypeCheckerIr.hs | 132 ++++++++---------
 test_program                     |   5 +-
 12 files changed, 584 insertions(+), 257 deletions(-)
 create mode 100644 src/Auxiliary.hs
 create mode 100644 src/Renamer/RenamerM.hs
 create mode 100644 src/TypeChecker/HM.hs
 create mode 100644 src/TypeChecker/HMIr.hs

diff --git a/Grammar.cf b/Grammar.cf
index 1e99c21..5406ac8 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,22 +1,21 @@
 
 Program. Program ::= [Bind] ;
 
-Bind. Bind ::= Ident [Ident] "=" Exp ;
+
+Bind. Bind ::= Ident ":" Type ";"
+               Ident [Ident] "=" Exp ;
 
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
 EId.    Exp4 ::= Ident ;
-EConst. Exp4 ::= Const ;
+EInt.   Exp4 ::= Integer ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
 ELet.   Exp ::= "let" Ident "=" Exp "in" Exp ; 
 EAbs.   Exp  ::= "\\" Ident "." Exp ;
 
-CInt. Const ::= Integer ;
-CStr. Const ::= String ;
-
 TMono. Type1 ::= "Mono" Ident ;
-TPoly. Type1 ::= "Poly" Ident ;
-TArrow. Type ::= Type1 "->" Type ;
+TPol. Type1 ::= "Poly" Ident ;
+TArr. Type ::= Type1 "->" Type ;
 
 -- This doesn't seem to work so we'll have to live with ugly keywords for now
 -- token Upper (upper (letter | digit | '_')*) ;
@@ -30,7 +29,3 @@ coercions Exp 5 ;
 
 comment "--" ;
 comment "{-" "-}" ;
-
--- Adt. Adt ::= "data" UIdent "=" [Constructor] ;
--- Sum. Constructor ::= UIdent ; 
--- separator Constructor "|" ;
diff --git a/language.cabal b/language.cabal
index e3d40b9..5653f08 100644
--- a/language.cabal
+++ b/language.cabal
@@ -31,11 +31,15 @@ executable language
       Grammar.Print
       Grammar.Skel
       Grammar.ErrM
-      TypeChecker.TypeChecker
-      TypeChecker.TypeCheckerIr
-      TypeChecker.Unification
-      Renamer.Renamer
-      Renamer.RenamerIr
+      Auxiliary
+      -- TypeChecker.TypeChecker
+      -- TypeChecker.TypeCheckerIr
+      -- TypeChecker.Unification
+      TypeChecker.HM
+      TypeChecker.HMIr
+      Renamer.RenamerM
+      -- Renamer.Renamer
+      -- Renamer.RenamerIr
 
     hs-source-dirs:   src
 
diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs
new file mode 100644
index 0000000..735d804
--- /dev/null
+++ b/src/Auxiliary.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE LambdaCase #-}
+module Auxiliary (module Auxiliary) where
+import           Control.Monad.Error.Class (liftEither)
+import           Control.Monad.Except      (MonadError)
+import           Data.Either.Combinators   (maybeToRight)
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
+
+maybeToRightM :: MonadError l m => l -> Maybe r -> m r
+maybeToRightM err = liftEither . maybeToRight err
+
+mapAccumM :: Monad m => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
+mapAccumM f = go
+  where
+    go acc = \case
+      [] -> pure (acc, [])
+      x:xs -> do
+        (acc', x') <- f acc x
+        (acc'', xs') <- go acc' xs
+        pure (acc'', x':xs')
diff --git a/src/Main.hs b/src/Main.hs
index 68027d4..1ef3fe3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,14 +2,14 @@
 
 module Main where
 
-import           Grammar.Par             (myLexer, pProgram)
+import           Grammar.Par        (myLexer, pProgram)
 -- import           TypeChecker.TypeChecker (typecheck)
 
-import           Grammar.Print           (printTree)
-import           Renamer.Renamer         (rename)
-import           System.Environment      (getArgs)
-import           System.Exit             (exitFailure, exitSuccess)
-import           TypeChecker.TypeChecker (typecheck)
+import           Grammar.Print      (printTree)
+import           Renamer.RenamerM   (rename)
+import           System.Environment (getArgs)
+import           System.Exit        (exitFailure, exitSuccess)
+import           TypeChecker.HM     (typecheck)
 
 main :: IO ()
 main =
@@ -27,24 +27,18 @@ main =
                     putStrLn " ----- PARSER ----- "
                     putStrLn ""
                     putStrLn . printTree $ prg
-                    case rename prg of
+                    case typecheck (rename prg) of
                         Left err -> do
-                            putStrLn "FAILED RENAMING"
+                            putStrLn "TYPECHECK ERROR"
                             print err
                             exitFailure
                         Right prg -> do
                             putStrLn ""
-                            putStrLn " ----- RENAMER ----- "
+                            putStrLn " ----- RAW ----- "
                             putStrLn ""
-                            putStrLn . printTree $ prg
-                            case typecheck prg of
-                                Left err -> do
-                                    putStrLn "TYPECHECK ERROR"
-                                    print err
-                                    exitFailure
-                                Right prg -> do
-                                    putStrLn ""
-                                    putStrLn " ----- TYPECHECKER ----- "
-                                    putStrLn ""
-                                    print prg
-                                    exitSuccess
+                            print prg
+                            putStrLn ""
+                            putStrLn " ----- TYPECHECKER ----- "
+                            putStrLn ""
+                            putStrLn $ printTree prg
+                            exitSuccess
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 8f09a51..c8b857e 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -38,7 +38,7 @@ renamePrg (Old.Program xs) = do
     return $ RProgram xs'
 
 renameBind :: Old.Bind -> Rename RBind
-renameBind (Old.Bind i args e) = do
+renameBind (Old.Bind n t i args e) = do
     insertSig i
     e' <- renameExp (makeLambda (reverse args) e)
     return $ RBind i e'
@@ -53,12 +53,12 @@ renameExp = \case
     Old.EId i -> do
         st <- get
         case M.lookup i st.env of
-            Just n -> return $ RBound n i
+            Just n -> return $ RId i
             Nothing -> case S.member i st.sig of
-                         True -> return $ RFree i
+                         True -> return $ RId i
                          False -> throwError $ UnboundVar (show i)
 
-    Old.EConst c -> return $ RConst c
+    Old.EInt c -> return $ RInt c
 
     Old.EAnn e t -> flip RAnn t <$> renameExp e
 
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
index bac9915..77e2f1f 100644
--- a/src/Renamer/RenamerIr.hs
+++ b/src/Renamer/RenamerIr.hs
@@ -4,14 +4,12 @@ module Renamer.RenamerIr (
     RExp (..),
     RBind (..),
     RProgram (..),
-    Const (..),
     Ident (..),
     Type (..),
 ) where
 
 import Grammar.Abs (
     Bind (..),
-    Const (..),
     Ident (..),
     Program (..),
     Type (..),
@@ -26,35 +24,9 @@ data RBind = RBind Ident RExp
 
 data RExp
     = RAnn RExp Type
-    | RBound Integer Ident
-    | RFree Ident
-    | RConst Const
+    | RId Ident
+    | RInt Integer
     | RApp RExp RExp
     | RAdd RExp RExp
     | RAbs Integer Ident RExp
     deriving (Eq, Ord, Show, Read)
-
-instance Print RProgram where
-    prt i = \case
-        RProgram defs -> prPrec i 0 (concatD [prt 0 defs])
-
-instance Print RBind where
-    prt i = \case
-        RBind x e ->
-            prPrec i 0 $
-                concatD
-                    [ prt 0 x
-                    , doc (showString "=")
-                    , prt 0 e
-                    , doc (showString "\n")
-                    ]
-
-instance Print RExp where
-    prt i = \case
-        RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t])
-        RBound n _ -> prPrec i 3 (concatD [prt 0 n])
-        RFree id -> prPrec i 3 (concatD [prt 0 id])
-        RConst n -> prPrec i 3 (concatD [prt 0 n])
-        RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
-        RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
-        RAbs u _ e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 u, doc (showString "."), prt 0 e])
diff --git a/src/Renamer/RenamerM.hs b/src/Renamer/RenamerM.hs
new file mode 100644
index 0000000..215290c
--- /dev/null
+++ b/src/Renamer/RenamerM.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Renamer.RenamerM  where
+
+import           Auxiliary           (mapAccumM)
+import           Control.Monad.State (MonadState, State, evalState, gets,
+                                      modify)
+import           Data.Map            (Map)
+import qualified Data.Map            as Map
+import           Data.Maybe          (fromMaybe)
+import           Data.Tuple.Extra    (dupe)
+import           Grammar.Abs
+
+
+-- | Rename all variables and local binds
+rename :: Program -> Program
+rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0
+  where
+    initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
+    renameSc :: Names -> Bind -> Rn Bind
+    renameSc old_names (Bind name t _ parms rhs) = do
+        (new_names, parms') <- newNames old_names parms
+        rhs'                <- snd <$> renameExp new_names rhs
+        pure $ Bind name t name parms' rhs'
+
+
+-- | Rename monad. State holds the number of renamed names.
+newtype Rn a = Rn { runRn :: State Int a }
+  deriving (Functor, Applicative, Monad, MonadState Int)
+
+-- | Maps old to new name
+type Names = Map Ident Ident
+
+renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
+renameLocalBind old_names (Bind name t _ parms rhs) = do
+    (new_names, name')   <- newName old_names name
+    (new_names', parms') <- newNames new_names parms
+    (new_names'', rhs')  <- renameExp new_names' rhs
+    pure (new_names'', Bind name' t name' parms' rhs')
+
+renameExp :: Names -> Exp -> Rn (Names, Exp)
+renameExp old_names = \case
+    EId  n     -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
+
+    EInt i1    -> pure (old_names, EInt i1)
+
+    EApp e1 e2 -> do
+        (env1, e1') <- renameExp old_names e1
+        (env2, e2') <- renameExp old_names e2
+        pure (Map.union env1 env2, EApp e1' e2')
+
+    EAdd e1 e2 -> do
+        (env1, e1') <- renameExp old_names e1
+        (env2, e2') <- renameExp old_names e2
+        pure (Map.union env1 env2, EAdd e1' e2')
+
+    ELet i e1 e2  -> do
+        (new_names, e1')   <- renameExp old_names e1
+        (new_names', e2') <- renameExp new_names e2
+        pure (new_names', ELet i e1' e2')
+
+    EAbs par e  -> do
+        (new_names, par') <- newName old_names par
+        (new_names', e')  <- renameExp new_names e
+        pure (new_names', EAbs par' e')
+
+    EAnn e t -> do
+        (new_names, e') <- renameExp old_names e
+        pure (new_names, EAnn e' t)
+
+-- | Create a new name and add it to name environment.
+newName :: Names -> Ident -> Rn (Names, Ident)
+newName env old_name = do
+    new_name <- makeName old_name
+    pure (Map.insert old_name new_name env, new_name)
+
+-- | Create multiple names and add them to the name environment
+newNames :: Names -> [Ident] -> Rn (Names, [Ident])
+newNames = mapAccumM newName
+
+-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
+makeName :: Ident -> Rn Ident
+makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ
diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs
new file mode 100644
index 0000000..27ed8ba
--- /dev/null
+++ b/src/TypeChecker/HM.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use traverse_" #-}
+
+module TypeChecker.HM (typecheck) where
+
+import           Control.Monad.Except
+import           Control.Monad.State
+import           Data.Bifunctor        (second)
+import           Data.Functor.Identity (Identity, runIdentity)
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+
+import           Grammar.Abs
+import           Grammar.Print
+import qualified TypeChecker.HMIr      as T
+
+type Infer = StateT Ctx (ExceptT String Identity)
+type Error = String
+
+data Ctx = Ctx { constr :: Map Type Type
+               , vars   :: Map Ident Type
+               , sigs   :: Map Ident Type
+               , frsh   :: Char }
+    deriving Show
+
+run :: Infer a -> Either String a
+run = runIdentity . runExceptT . flip evalStateT initC
+
+int = TMono "Int"
+
+initC :: Ctx
+initC = Ctx M.empty M.empty M.empty 'a'
+
+typecheck :: Program -> Either Error T.Program
+typecheck = run . inferPrg
+
+inferPrg :: Program -> Infer T.Program
+inferPrg (Program bs) = do
+    traverse (\(Bind n t _ _ _) -> insertSig n t) bs
+    bs' <- mapM inferBind bs
+    return $ T.Program bs'
+
+inferBind :: Bind -> Infer T.Bind
+inferBind (Bind i t _ params rhs) = do
+    (t',e') <- inferExp (makeLambda (reverse params) rhs)
+    addConstraint t t'
+    -- when (t /= t') (throwError $ "Signature of function" ++ printTree i ++ "does not match inferred type of expression: " ++ printTree e')
+    return $ T.Bind (t,i) [] e'
+
+makeLambda :: [Ident] -> Exp -> Exp
+makeLambda xs e = foldl (flip EAbs) e xs
+
+inferExp :: Exp -> Infer (Type, T.Exp)
+inferExp = \case
+    EAnn e t -> do
+        (t',e') <- inferExp e
+        when (t' /= t) (throwError "Annotated type and inferred type don't match")
+        return (t', e')
+    EInt i -> return (int, T.EInt int i)
+    EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
+    EAdd e1 e2 -> do
+        (t1, e1') <- inferExp e1
+        (t2, e2') <- inferExp e2
+        unless (isInt t1 && isInt t2) (throwError "Can not add non-ints")
+        return (int,T.EAdd int e1' e2')
+    EApp e1 e2 -> do
+        (t1, e1') <- inferExp e1
+        (t2, e2') <- inferExp e2
+        fr <- fresh
+        addConstraint t1 (TArr t2 fr)
+        return (fr, T.EApp fr e1' e2')
+    EAbs name e -> do
+        fr <- fresh
+        insertVar name fr
+        (ret_t,e') <- inferExp e
+        t <- solveConstraints (TArr fr ret_t)
+        return (t, T.EAbs t name e')
+    ELet name e1 e2 -> do
+        fr <- fresh
+        insertVar name fr
+        (t1, e1') <- inferExp e1
+        (t2, e2') <- inferExp e2
+        ret_t <- solveConstraints t1
+        return (ret_t, T.ELet ret_t name e1' e2')
+
+
+isInt :: Type -> Bool
+isInt (TMono "Int") = True
+isInt _             = False
+
+lookupVar :: Ident -> Infer Type
+lookupVar i = do
+    st <- get
+    case M.lookup i (vars st) of
+      Just t -> return t
+      Nothing -> case M.lookup i (sigs st) of
+        Just t  -> return t
+        Nothing -> throwError $ "Unbound variable or function" ++ printTree i
+
+insertVar :: Ident -> Type -> Infer ()
+insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } )
+
+insertSig :: Ident -> Type -> Infer ()
+insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } )
+
+
+fresh :: Infer Type
+fresh = do
+    chr <- gets frsh
+    modify (\st -> st { frsh = succ chr })
+    return $ TPol (Ident [chr])
+
+addConstraint :: Type -> Type -> Infer ()
+addConstraint t1 t2 = do
+    when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2)
+    modify (\st -> st { constr = M.insert t1 t2 (constr st) })
+
+contains :: Type -> Type -> Bool
+contains (TArr t1 t2) b      = t1 `contains` b || t2 `contains` b
+contains (TMono a) (TMono b) = False
+contains a b                 = a == b
+
+solveConstraints :: Type -> Infer Type
+solveConstraints t = do
+    c <- gets constr
+    v <- gets vars
+    subst t <$> solveAll (M.toList c)
+
+subst :: Type -> [(Type, Type)] -> Type
+subst t []                = t
+subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs
+subst t (x:xs)            = subst (replace x t) xs
+
+solveAll :: [(Type, Type)] -> Infer [(Type, Type)]
+solveAll [] = return []
+solveAll (x:xs) = case x of
+    (TArr t1 t2, TArr t3 t4) -> solveAll $ (t1,t3) : (t2,t4) : xs
+    (TArr t1 t2, b)          -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs
+    (a, TArr t1 t2)          -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs
+    (TMono a, TPol b)        -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs
+    (TPol a, TMono b)        -> fmap ((TPol a, TMono a) :) $ solveAll $ solve (TPol a, TMono b) xs
+    (TMono a, TMono b)       -> if a == b then solveAll xs else throwError "Can't unify types"
+    (TPol a, TPol b)         -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs
+
+solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)]
+solve x = map (second (replace x))
+
+replace :: (Type, Type) -> Type -> Type
+replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2)
+replace (a,b) c        = if a==c then b else c
+
+-- Known bugs
+-- (x : a) + 3 type checks
diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs
new file mode 100644
index 0000000..f0158b6
--- /dev/null
+++ b/src/TypeChecker/HMIr.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TypeChecker.HMIr
+  ( module Grammar.Abs
+  , module TypeChecker.HMIr
+  ) where
+
+import           Grammar.Abs   (Ident (..), Type (..))
+import           Grammar.Print
+import           Prelude
+import qualified Prelude       as C (Eq, Ord, Read, Show)
+
+newtype Program = Program [Bind]
+  deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+data Exp
+    = EId  Type Ident
+    | EInt Type Integer
+    | ELet Type Ident Exp Exp
+    | EApp Type Exp Exp
+    | EAdd Type Exp Exp
+    | EAbs Type Ident Exp
+      deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+type Id = (Type, Ident)
+
+data Bind = Bind Id [Id] Exp
+    deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+instance Print Program where
+    prt i (Program sc) = prPrec i 0 $ prt 0 sc
+
+instance Print Bind where
+    prt i (Bind name@(n, _) parms rhs) = prPrec i 0 $ concatD
+        [ prtId 0 name
+        , doc $ showString ";"
+        , prt 0 n
+        , prtIdPs 0 parms
+        , doc $ showString "="
+        , prt 0 rhs
+        ]
+
+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 (prtIdP i)
+
+prtId :: Int -> Id -> Doc
+prtId i (name, t) = prPrec i 0 $ concatD
+    [ prt 0 name
+    , doc $ showString ":"
+    , prt 0 t
+    ]
+
+prtIdP :: Int -> Id -> Doc
+prtIdP i (name, t) = prPrec i 0 $ concatD
+    [ doc $ showString "("
+    , prt 0 name
+    , doc $ showString ":"
+    , prt 0 t
+    , doc $ showString ")"
+    ]
+
+
+instance Print Exp where
+  prt i = \case
+    EId _ n       -> prPrec i 3 $ concatD [prt 0 n]
+    EInt _ i1      -> prPrec i 3 $ concatD [prt 0 i1]
+    ELet _ name e1 e2    -> prPrec i 3 $ concatD
+                        [ doc $ showString "let"
+                        , prt 0 name
+                        , prt 0 e1
+                        , doc $ showString "in"
+                        , prt 0 e2
+                        ]
+    EApp t e1 e2 -> prPrec i 2 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , prt 2 e1
+                        , prt 3 e2
+                        ]
+    EAdd t e1 e2 -> prPrec i 1 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , prt 1 e1
+                        , doc $ showString "+"
+                        , prt 2 e2
+                        ]
+    EAbs t n e  -> prPrec i 0 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , doc $ showString "\\"
+                        , prt 0 n
+                        , doc $ showString "."
+                        , prt 0 e
+                        ]
+
+
+
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 48d26ac..99a1e17 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,153 +1,153 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings   #-}
+-- {-# LANGUAGE LambdaCase          #-}
+-- {-# LANGUAGE OverloadedRecordDot #-}
+-- {-# LANGUAGE OverloadedStrings   #-}
 
 module TypeChecker.TypeChecker where
 
-import           Control.Monad             (void)
-import           Control.Monad.Except      (ExceptT, runExceptT, throwError)
-import           Control.Monad.State       (StateT)
-import qualified Control.Monad.State       as St
-import           Data.Functor.Identity     (Identity, runIdentity)
-import           Data.Map                  (Map)
-import qualified Data.Map                  as M
+-- import           Control.Monad             (void)
+-- import           Control.Monad.Except      (ExceptT, runExceptT, throwError)
+-- import           Control.Monad.State       (StateT)
+-- import qualified Control.Monad.State       as St
+-- import           Data.Functor.Identity     (Identity, runIdentity)
+-- import           Data.Map                  (Map)
+-- import qualified Data.Map                  as M
 
-import           TypeChecker.TypeCheckerIr
+-- import           TypeChecker.TypeCheckerIr
 
-data Ctx = Ctx
-    { vars      :: Map Integer Type
-    , sigs      :: Map Ident Type
-    , nextFresh :: Int
-    }
-    deriving (Show)
+-- data Ctx = Ctx
+--     { vars      :: Map Integer Type
+--     , sigs      :: Map Ident Type
+--     , nextFresh :: Int
+--     }
+--     deriving (Show)
 
--- Perhaps swap over to reader monad instead for vars and sigs.
-type Infer = StateT Ctx (ExceptT Error Identity)
+-- -- Perhaps swap over to reader monad instead for vars and sigs.
+-- type Infer = StateT Ctx (ExceptT Error Identity)
 
-{-
+-- {-
 
-The type checker will assume we first rename all variables to unique name, as to not
-have to care about scoping. It significantly improves the quality of life of the
-programmer.
+-- The type checker will assume we first rename all variables to unique name, as to not
+-- have to care about scoping. It significantly improves the quality of life of the
+-- programmer.
 
-TODOs:
-    Add skolemization variables. i.e
-    { \x. 3 : forall a. a -> a }
-    should not type check
+-- TODOs:
+--     Add skolemization variables. i.e
+--     { \x. 3 : forall a. a -> a }
+--     should not type check
 
-    Generalize. Not really sure what that means though
+--     Generalize. Not really sure what that means though
 
--}
+-- -}
 
-typecheck :: RProgram -> Either Error TProgram
-typecheck = todo
+-- typecheck :: RProgram -> Either Error TProgram
+-- typecheck = todo
 
-run :: Infer a -> Either Error a
-run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
+-- run :: Infer a -> Either Error a
+-- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
 
--- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
--- { \x. \y. x + y } will have the type { a -> b -> Int }
-inferExp :: RExp -> Infer Type
-inferExp = \case
+-- -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
+-- -- { \x. \y. x + y } will have the type { a -> b -> Int }
+-- inferExp :: RExp -> Infer Type
+-- inferExp = \case
 
-    RAnn expr typ -> do
-        t <- inferExp expr
-        void $ t =:= typ
-        return t
+--     RAnn expr typ -> do
+--         t <- inferExp expr
+--         void $ t =:= typ
+--         return t
 
-    RBound num name -> lookupVars num
+--     RBound num name -> lookupVars num
 
-    RFree name -> lookupSigs name
+--     RFree name -> lookupSigs name
 
-    RConst (CInt i) -> return $ TMono "Int"
+--     RConst (CInt i) -> return $ TMono "Int"
 
-    RConst (CStr str) -> return $ TMono "Str"
+--     RConst (CStr str) -> return $ TMono "Str"
 
-    RAdd expr1 expr2 -> do
-        let int = TMono "Int"
-        typ1 <- check expr1 int
-        typ2 <- check expr2 int
-        return int
+--     RAdd expr1 expr2 -> do
+--         let int = TMono "Int"
+--         typ1 <- check expr1 int
+--         typ2 <- check expr2 int
+--         return int
 
-    RApp expr1 expr2 -> do
-        fn_t <- inferExp expr1
-        arg_t <- inferExp expr2
-        res <- fresh
-        new_t <- fn_t =:= TArrow arg_t res
-        return res
+--     RApp expr1 expr2 -> do
+--         fn_t <- inferExp expr1
+--         arg_t <- inferExp expr2
+--         res <- fresh
+--         new_t <- fn_t =:= TArrow arg_t res
+--         return res
 
-    RAbs num name expr -> do
-        arg <- fresh
-        insertVars num arg
-        typ <- inferExp expr
-        return $ TArrow arg typ
+--     RAbs num name expr -> do
+--         arg <- fresh
+--         insertVars num arg
+--         typ <- inferExp expr
+--         return $ TArrow arg typ
 
-check :: RExp -> Type -> Infer ()
-check e t = do
-    t' <- inferExp e
-    t =:= t'
-    return ()
+-- check :: RExp -> Type -> Infer ()
+-- check e t = do
+--     t' <- inferExp e
+--     t =:= t'
+--     return ()
 
-fresh :: Infer Type
-fresh = do
-    var <- St.gets nextFresh
-    St.modify (\st -> st {nextFresh = succ var})
-    return (TPoly $ Ident (show var))
+-- fresh :: Infer Type
+-- fresh = do
+--     var <- St.gets nextFresh
+--     St.modify (\st -> st {nextFresh = succ var})
+--     return (TPoly $ Ident (show var))
 
--- | Unify two types.
-(=:=) :: Type -> Type -> Infer Type
-(=:=) (TPoly _) b = return b
-(=:=) a (TPoly _) = return a
-(=:=) (TMono a) (TMono b) | a == b = return (TMono a)
-(=:=) (TArrow a b) (TArrow c d) = do
-    t1 <- a =:= c
-    t2 <- b =:= d
-    return $ TArrow t1 t2
-(=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
+-- -- | Unify two types.
+-- (=:=) :: Type -> Type -> Infer Type
+-- (=:=) (TPoly _) b = return b
+-- (=:=) a (TPoly _) = return a
+-- (=:=) (TMono a) (TMono b) | a == b = return (TMono a)
+-- (=:=) (TArrow a b) (TArrow c d) = do
+--     t1 <- a =:= c
+--     t2 <- b =:= d
+--     return $ TArrow t1 t2
+-- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
 
-lookupVars :: Integer -> Infer Type
-lookupVars i = do
-    st <- St.gets vars
-    case M.lookup i st of
-       Just t  -> return t
-       Nothing -> throwError $ UnboundVar "lookupVars"
+-- lookupVars :: Integer -> Infer Type
+-- lookupVars i = do
+--     st <- St.gets vars
+--     case M.lookup i st of
+--        Just t  -> return t
+--        Nothing -> throwError $ UnboundVar "lookupVars"
 
-insertVars :: Integer -> Type -> Infer ()
-insertVars i t = do
-    st <- St.get
-    St.put (st {vars = M.insert i t st.vars})
+-- insertVars :: Integer -> Type -> Infer ()
+-- insertVars i t = do
+--     st <- St.get
+--     St.put (st {vars = M.insert i t st.vars})
 
-lookupSigs :: Ident -> Infer Type
-lookupSigs i = do
-    st <- St.gets sigs
-    case M.lookup i st of
-        Just t  -> return t
-        Nothing -> throwError $ UnboundVar "lookupSigs"
+-- lookupSigs :: Ident -> Infer Type
+-- lookupSigs i = do
+--     st <- St.gets sigs
+--     case M.lookup i st of
+--         Just t  -> return t
+--         Nothing -> throwError $ UnboundVar "lookupSigs"
 
-insertSigs :: Ident -> Type -> Infer ()
-insertSigs i t = do
-    st <- St.get
-    St.put (st {sigs = M.insert i t st.sigs})
+-- insertSigs :: Ident -> Type -> Infer ()
+-- insertSigs i t = do
+--     st <- St.get
+--     St.put (st {sigs = M.insert i t st.sigs})
 
-{-# WARNING todo "TODO IN CODE" #-}
-todo :: a
-todo = error "TODO in code"
+-- {-# WARNING todo "TODO IN CODE" #-}
+-- todo :: a
+-- todo = error "TODO in code"
 
-data Error
-    = TypeMismatch String
-    | NotNumber String
-    | FunctionTypeMismatch String
-    | NotFunction String
-    | UnboundVar String
-    | AnnotatedMismatch String
-    | Default String
-    deriving (Show)
+-- data Error
+--     = TypeMismatch String
+--     | NotNumber String
+--     | FunctionTypeMismatch String
+--     | NotFunction String
+--     | UnboundVar String
+--     | AnnotatedMismatch String
+--     | Default String
+--     deriving (Show)
 
 
-{-
+-- {-
 
-The procedure inst(σ) specializes the polytype
-σ by copying the term and replacing the bound type variables
-consistently by new monotype variables.
+-- The procedure inst(σ) specializes the polytype
+-- σ by copying the term and replacing the bound type variables
+-- consistently by new monotype variables.
 
--}
+-- -}
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 6845afd..c08d981 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,74 +1,74 @@
-{-# LANGUAGE LambdaCase #-}
+-- {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr (
-    TProgram (..),
-    TBind (..),
-    TExp (..),
-    RProgram (..),
-    RBind (..),
-    RExp (..),
-    Type (..),
-    Const (..),
-    Ident (..),
-) where
+module TypeChecker.TypeCheckerIr --(
+--     TProgram (..),
+--     TBind (..),
+--     TExp (..),
+--     RProgram (..),
+--     RBind (..),
+--     RExp (..),
+--     Type (..),
+--     Const (..),
+--     Ident (..),
+-- ) where
 
-import           Grammar.Print
-import           Renamer.RenamerIr
+-- import           Grammar.Print
+-- import           Renamer.RenamerIr
 
-newtype TProgram = TProgram [TBind]
-    deriving (Eq, Show, Read, Ord)
+-- newtype TProgram = TProgram [TBind]
+--     deriving (Eq, Show, Read, Ord)
 
-data TBind = TBind Ident Type TExp
-    deriving (Eq, Show, Read, Ord)
+-- data TBind = TBind Ident Type TExp
+--     deriving (Eq, Show, Read, Ord)
 
-data TExp
-    = TAnn TExp Type
-    | TBound Integer Ident Type
-    | TFree Ident Type
-    | TConst Const Type
-    | TApp TExp TExp Type
-    | TAdd TExp TExp Type
-    | TAbs Integer Ident TExp Type
-    deriving (Eq, Ord, Show, Read)
+-- data TExp
+--     = TAnn TExp Type
+--     | TBound Integer Ident Type
+--     | TFree Ident Type
+--     | TConst Const Type
+--     | TApp TExp TExp Type
+--     | TAdd TExp TExp Type
+--     | TAbs Integer Ident TExp Type
+--     deriving (Eq, Ord, Show, Read)
 
-instance Print TProgram where
-    prt i = \case
-        TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
+-- instance Print TProgram where
+--     prt i = \case
+--         TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
 
-instance Print TBind where
-    prt i = \case
-        TBind x t e ->
-            prPrec i 0 $
-                concatD
-                    [ prt 0 x
-                    , doc (showString ":")
-                    , prt 0 t
-                    , doc (showString "=")
-                    , prt 0 e
-                    , doc (showString "\n")
-                    ]
+-- instance Print TBind where
+--     prt i = \case
+--         TBind x t e ->
+--             prPrec i 0 $
+--                 concatD
+--                     [ prt 0 x
+--                     , doc (showString ":")
+--                     , prt 0 t
+--                     , doc (showString "=")
+--                     , prt 0 e
+--                     , doc (showString "\n")
+--                     ]
 
-instance Print TExp where
-    prt i = \case
-        TAnn e t ->
-            prPrec i 2 $
-                concatD
-                    [ prt 0 e
-                    , doc (showString ":")
-                    , prt 1 t
-                    ]
-        TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
-        TFree u t -> prPrec i 3 $ concatD [prt 0 u]
-        TConst c _ -> prPrec i 3 (concatD [prt 0 c])
-        TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
-        TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
-        TAbs _ u e t ->
-            prPrec i 0 $
-                concatD
-                    [ doc (showString "(")
-                    , doc (showString "λ")
-                    , prt 0 u
-                    , doc (showString ".")
-                    , prt 0 e
-                    , doc (showString ")")
-                    ]
+-- instance Print TExp where
+--     prt i = \case
+--         TAnn e t ->
+--             prPrec i 2 $
+--                 concatD
+--                     [ prt 0 e
+--                     , doc (showString ":")
+--                     , prt 1 t
+--                     ]
+--         TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
+--         TFree u t -> prPrec i 3 $ concatD [prt 0 u]
+--         TConst c _ -> prPrec i 3 (concatD [prt 0 c])
+--         TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
+--         TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
+--         TAbs _ u e t ->
+--             prPrec i 0 $
+--                 concatD
+--                     [ doc (showString "(")
+--                     , doc (showString "λ")
+--                     , prt 0 u
+--                     , doc (showString ".")
+--                     , prt 0 e
+--                     , doc (showString ")")
+--                     ]
diff --git a/test_program b/test_program
index 0639729..b81c8de 100644
--- a/test_program
+++ b/test_program
@@ -1,3 +1,4 @@
-test = \x. (x : Mono String) ;
+main : Mono Int ;
+main = let f = \x. x in f 5 ;
+
 
-apply x y = x + y ;

From db932048bab8d46070b6888b5d2427cb8f9309d4 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Sun, 19 Feb 2023 02:10:57 +0100
Subject: [PATCH 34/71] Tried fixing bug. Failed.

---
 src/TypeChecker/HM.hs   | 58 ++++++++++++++++++++++++++---------------
 src/TypeChecker/HMIr.hs | 10 ++++++-
 test_program            |  7 ++---
 3 files changed, 50 insertions(+), 25 deletions(-)

diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs
index 27ed8ba..8671d1b 100644
--- a/src/TypeChecker/HM.hs
+++ b/src/TypeChecker/HM.hs
@@ -3,11 +3,11 @@
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use traverse_" #-}
 
-module TypeChecker.HM (typecheck) where
+module TypeChecker.HM  where
 
 import           Control.Monad.Except
 import           Control.Monad.State
-import           Data.Bifunctor        (second)
+import           Data.Bifunctor        (bimap, second)
 import           Data.Functor.Identity (Identity, runIdentity)
 import           Data.Map              (Map)
 import qualified Data.Map              as M
@@ -25,16 +25,14 @@ data Ctx = Ctx { constr :: Map Type Type
                , frsh   :: Char }
     deriving Show
 
-run :: Infer a -> Either String a
-run = runIdentity . runExceptT . flip evalStateT initC
-
-int = TMono "Int"
+run :: Infer a -> Either String (a, Ctx)
+run = runIdentity . runExceptT . flip runStateT initC
 
 initC :: Ctx
 initC = Ctx M.empty M.empty M.empty 'a'
 
 typecheck :: Program -> Either Error T.Program
-typecheck = run . inferPrg
+typecheck = undefined . run . inferPrg
 
 inferPrg :: Program -> Infer T.Program
 inferPrg (Program bs) = do
@@ -61,10 +59,8 @@ inferExp = \case
     EInt i -> return (int, T.EInt int i)
     EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
     EAdd e1 e2 -> do
-        (t1, e1') <- inferExp e1
-        (t2, e2') <- inferExp e2
-        unless (isInt t1 && isInt t2) (throwError "Can not add non-ints")
-        return (int,T.EAdd int e1' e2')
+        insertSig "+" (TArr int (TArr int int))
+        inferExp (EApp (EApp (EId "+") e1) e2)
     EApp e1 e2 -> do
         (t1, e1') <- inferExp e1
         (t2, e2') <- inferExp e2
@@ -77,13 +73,7 @@ inferExp = \case
         (ret_t,e') <- inferExp e
         t <- solveConstraints (TArr fr ret_t)
         return (t, T.EAbs t name e')
-    ELet name e1 e2 -> do
-        fr <- fresh
-        insertVar name fr
-        (t1, e1') <- inferExp e1
-        (t2, e2') <- inferExp e2
-        ret_t <- solveConstraints t1
-        return (ret_t, T.ELet ret_t name e1' e2')
+    ELet name e1 e2 -> error "Let expression not implemented yet"
 
 
 isInt :: Type -> Bool
@@ -112,6 +102,8 @@ fresh = do
     modify (\st -> st { frsh = succ chr })
     return $ TPol (Ident [chr])
 
+-- Constraint solving is wrong. (\x. x) 3 is inferred with the type 'a'
+
 addConstraint :: Type -> Type -> Infer ()
 addConstraint t1 t2 = do
     when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2)
@@ -126,13 +118,16 @@ solveConstraints :: Type -> Infer Type
 solveConstraints t = do
     c <- gets constr
     v <- gets vars
-    subst t <$> solveAll (M.toList c)
+    xs <- solveAll (M.toList c)
+    modify (\st -> st { constr = M.fromList xs })
+    return $ subst t xs
 
 subst :: Type -> [(Type, Type)] -> Type
 subst t []                = t
 subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs
 subst t (x:xs)            = subst (replace x t) xs
 
+-- Annoying fucking bug here
 solveAll :: [(Type, Type)] -> Infer [(Type, Type)]
 solveAll [] = return []
 solveAll (x:xs) = case x of
@@ -140,16 +135,37 @@ solveAll (x:xs) = case x of
     (TArr t1 t2, b)          -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs
     (a, TArr t1 t2)          -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs
     (TMono a, TPol b)        -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs
-    (TPol a, TMono b)        -> fmap ((TPol a, TMono a) :) $ solveAll $ solve (TPol a, TMono b) xs
+    (TPol a, TMono b)        -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs
     (TMono a, TMono b)       -> if a == b then solveAll xs else throwError "Can't unify types"
     (TPol a, TPol b)         -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs
 
 solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)]
-solve x = map (second (replace x))
+solve x = map (both (replace x))
 
 replace :: (Type, Type) -> Type -> Type
 replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2)
 replace (a,b) c        = if a==c then b else c
 
+both :: (a -> b) -> (a,a) -> (b,b)
+both f = bimap f f
+
+int = TMono "Int"
+a = TPol "a"
+b = TPol "b"
+c = TPol "c"
+d = TPol "d"
+e = TPol "e"
+arr = TArr
+
+set = [(a, arr d e), (c, arr int d), (arr int (arr int int), arr b c)]
+
+prg = EAbs "f" (EAbs "x" (EApp (EId "f") (EAdd (EId "x") (EInt 1))))
+
+bug = EApp (EAbs "x" (EAdd (EAnn (EId "x") a) (EInt 3))) (EInt 2)
+
+-- (\x. \y. x + y + 1)
+prg2 = EApp (EAbs "x" (EId "x")) (EInt 1)
+
+--
 -- Known bugs
 -- (x : a) + 3 type checks
diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs
index f0158b6..036fa42 100644
--- a/src/TypeChecker/HMIr.hs
+++ b/src/TypeChecker/HMIr.hs
@@ -20,7 +20,15 @@ data Exp
     | EApp Type Exp Exp
     | EAdd Type Exp Exp
     | EAbs Type Ident Exp
-      deriving (C.Eq, C.Ord, C.Show, C.Read)
+      deriving (C.Eq, C.Ord, C.Read)
+
+instance Show Exp where
+    show (EId t (Ident i))    = i ++ " : " ++ show t
+    show (EInt _ i)           = show i
+    show (ELet t i e1 e2)     = error "Show for let not implemented"
+    show (EApp t e1 e2)       = show e1 ++ " " ++ show e2 ++ " : " ++ show t
+    show (EAdd _ e1 e2)       = show e1 ++ " + " ++ show e2
+    show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t
 
 type Id = (Type, Ident)
 
diff --git a/test_program b/test_program
index b81c8de..e342096 100644
--- a/test_program
+++ b/test_program
@@ -1,4 +1,5 @@
-main : Mono Int ;
-main = let f = \x. x in f 5 ;
-
+id : Mono Int -> Mono Int ;
+id = \x. x ;
 
+main : Poly a ;
+main = id 3 ;

From 420fb107f0867ab86ed7532d17685e8ab4b7de2e Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Sun, 19 Feb 2023 15:25:49 +0100
Subject: [PATCH 35/71] Commented code and fixed some bugs I think. Still not
 complete

id : Int -> Int
id x = x
does not type check
---
 src/TypeChecker/HM.hs | 126 ++++++++++++++++++++++--------------------
 test_program          |   7 +--
 2 files changed, 67 insertions(+), 66 deletions(-)

diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs
index 8671d1b..63072d1 100644
--- a/src/TypeChecker/HM.hs
+++ b/src/TypeChecker/HM.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use traverse_" #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module TypeChecker.HM  where
 
@@ -25,14 +26,17 @@ data Ctx = Ctx { constr :: Map Type Type
                , frsh   :: Char }
     deriving Show
 
-run :: Infer a -> Either String (a, Ctx)
-run = runIdentity . runExceptT . flip runStateT initC
+runC :: Ctx -> Infer a -> Either String (a, Ctx)
+runC c = runIdentity . runExceptT . flip runStateT c
+
+run :: Infer a -> Either String a
+run = runIdentity . runExceptT . flip evalStateT initC
 
 initC :: Ctx
 initC = Ctx M.empty M.empty M.empty 'a'
 
 typecheck :: Program -> Either Error T.Program
-typecheck = undefined . run . inferPrg
+typecheck = run . inferPrg
 
 inferPrg :: Program -> Infer T.Program
 inferPrg (Program bs) = do
@@ -42,39 +46,54 @@ inferPrg (Program bs) = do
 
 inferBind :: Bind -> Infer T.Bind
 inferBind (Bind i t _ params rhs) = do
-    (t',e') <- inferExp (makeLambda (reverse params) rhs)
-    addConstraint t t'
-    -- when (t /= t') (throwError $ "Signature of function" ++ printTree i ++ "does not match inferred type of expression: " ++ printTree e')
+    (t',e') <- inferExp (makeLambda rhs (reverse params))
+    when (t /= t') (throwError $ "Signature of function " ++ show i ++ " with type: " ++ show t ++ " does not match inferred type " ++ show t' ++ " of expression: " ++ show e')
     return $ T.Bind (t,i) [] e'
 
-makeLambda :: [Ident] -> Exp -> Exp
-makeLambda xs e = foldl (flip EAbs) e xs
+makeLambda :: Exp -> [Ident] -> Exp
+makeLambda = foldl (flip EAbs)
 
 inferExp :: Exp -> Infer (Type, T.Exp)
-inferExp = \case
-    EAnn e t -> do
-        (t',e') <- inferExp e
-        when (t' /= t) (throwError "Annotated type and inferred type don't match")
-        return (t', e')
-    EInt i -> return (int, T.EInt int i)
-    EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
-    EAdd e1 e2 -> do
-        insertSig "+" (TArr int (TArr int int))
-        inferExp (EApp (EApp (EId "+") e1) e2)
-    EApp e1 e2 -> do
-        (t1, e1') <- inferExp e1
-        (t2, e2') <- inferExp e2
-        fr <- fresh
-        addConstraint t1 (TArr t2 fr)
-        return (fr, T.EApp fr e1' e2')
-    EAbs name e -> do
-        fr <- fresh
-        insertVar name fr
-        (ret_t,e') <- inferExp e
-        t <- solveConstraints (TArr fr ret_t)
-        return (t, T.EAbs t name e')
-    ELet name e1 e2 -> error "Let expression not implemented yet"
+inferExp e = do
+    (t, e') <- inferExp' e
+    t'' <- solveConstraints t
+    return (t'', replaceType t'' e')
 
+  where
+    inferExp' :: Exp -> Infer (Type, T.Exp)
+    inferExp' = \case
+        EAnn e t -> do
+            (t',e') <- inferExp' e
+            t'' <- solveConstraints t'
+            when (t'' /= t) (throwError "Annotated type and inferred type don't match")
+            return (t', e')
+        EInt i -> return (int, T.EInt int i)
+        EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
+        EAdd e1 e2 -> do
+            insertSig "+" (TArr int (TArr int int))
+            inferExp' (EApp (EApp (EId "+") e1) e2)
+        EApp e1 e2 -> do
+            (t1, e1') <- inferExp' e1
+            (t2, e2') <- inferExp' e2
+            fr <- fresh
+            addConstraint t1 (TArr t2 fr)
+            return (fr, T.EApp fr e1' e2')
+        EAbs name e -> do
+            fr <- fresh
+            insertVar name fr
+            (ret_t,e') <- inferExp' e
+            t <- solveConstraints (TArr fr ret_t)
+            return (t, T.EAbs t name e')
+        ELet name e1 e2 -> error "Let expression not implemented yet"
+
+replaceType :: Type -> T.Exp -> T.Exp
+replaceType t = \case
+        T.EInt _ i -> T.EInt t i
+        T.EId _ i -> T.EId t i
+        T.EAdd _ e1 e2 -> T.EAdd t e1 e2
+        T.EApp _ e1 e2 -> T.EApp t e1 e2
+        T.EAbs _ name e -> T.EAbs t name e
+        T.ELet _ name e1 e2 -> T.ELet t name e1 e2
 
 isInt :: Type -> Bool
 isInt (TMono "Int") = True
@@ -95,25 +114,24 @@ insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } )
 insertSig :: Ident -> Type -> Infer ()
 insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } )
 
-
+-- | Generate a new fresh variable and increment the state
 fresh :: Infer Type
 fresh = do
     chr <- gets frsh
     modify (\st -> st { frsh = succ chr })
     return $ TPol (Ident [chr])
 
--- Constraint solving is wrong. (\x. x) 3 is inferred with the type 'a'
-
+-- | Adds a constraint to the constraint set.
+-- i.e: a = int -> b
+--      b = int
+-- thus when solving constraints it must be the case that
+--      a = int -> int
+--
 addConstraint :: Type -> Type -> Infer ()
 addConstraint t1 t2 = do
-    when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2)
     modify (\st -> st { constr = M.insert t1 t2 (constr st) })
 
-contains :: Type -> Type -> Bool
-contains (TArr t1 t2) b      = t1 `contains` b || t2 `contains` b
-contains (TMono a) (TMono b) = False
-contains a b                 = a == b
-
+-- | Given a type, solve the constraints and figure out the type that should be assigned to it.
 solveConstraints :: Type -> Infer Type
 solveConstraints t = do
     c <- gets constr
@@ -122,12 +140,15 @@ solveConstraints t = do
     modify (\st -> st { constr = M.fromList xs })
     return $ subst t xs
 
+-- | Substitute
 subst :: Type -> [(Type, Type)] -> Type
 subst t []                = t
 subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs
 subst t (x:xs)            = subst (replace x t) xs
 
--- Annoying fucking bug here
+-- | Given a set of constraints run the replacement on all of them, producing a new set of
+--  replacements.
+--  https://youtu.be/trmq3wYcUxU - good video for explanation
 solveAll :: [(Type, Type)] -> Infer [(Type, Type)]
 solveAll [] = return []
 solveAll (x:xs) = case x of
@@ -136,12 +157,14 @@ solveAll (x:xs) = case x of
     (a, TArr t1 t2)          -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs
     (TMono a, TPol b)        -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs
     (TPol a, TMono b)        -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs
-    (TMono a, TMono b)       -> if a == b then solveAll xs else throwError "Can't unify types"
     (TPol a, TPol b)         -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs
+    (TMono a, TMono b)       -> if a == b then solveAll xs else throwError "Can't unify types"
 
 solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)]
 solve x = map (both (replace x))
 
+-- | Given a constraint (type, type) and a type, if the constraint matches the input
+--   replace with the constrained type
 replace :: (Type, Type) -> Type -> Type
 replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2)
 replace (a,b) c        = if a==c then b else c
@@ -150,22 +173,3 @@ both :: (a -> b) -> (a,a) -> (b,b)
 both f = bimap f f
 
 int = TMono "Int"
-a = TPol "a"
-b = TPol "b"
-c = TPol "c"
-d = TPol "d"
-e = TPol "e"
-arr = TArr
-
-set = [(a, arr d e), (c, arr int d), (arr int (arr int int), arr b c)]
-
-prg = EAbs "f" (EAbs "x" (EApp (EId "f") (EAdd (EId "x") (EInt 1))))
-
-bug = EApp (EAbs "x" (EAdd (EAnn (EId "x") a) (EInt 3))) (EInt 2)
-
--- (\x. \y. x + y + 1)
-prg2 = EApp (EAbs "x" (EId "x")) (EInt 1)
-
---
--- Known bugs
--- (x : a) + 3 type checks
diff --git a/test_program b/test_program
index e342096..6d38647 100644
--- a/test_program
+++ b/test_program
@@ -1,5 +1,2 @@
-id : Mono Int -> Mono Int ;
-id = \x. x ;
-
-main : Poly a ;
-main = id 3 ;
+fun : Mono Int -> Mono Int ;
+fun = \x. x ;

From dfbdb6678edbb25083bcf2dc7515ac716e39a65e Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 20 Feb 2023 12:09:31 +0100
Subject: [PATCH 36/71] Working on non-ugly version of algorithm W
 (Hindley-Milner)

---
 language.cabal           |   1 +
 src/TypeChecker/AlgoW.hs | 123 +++++++++++++++++++++++++++++++++++++++
 src/TypeChecker/HM.hs    |  10 +++-
 3 files changed, 132 insertions(+), 2 deletions(-)
 create mode 100644 src/TypeChecker/AlgoW.hs

diff --git a/language.cabal b/language.cabal
index 5653f08..7b21b60 100644
--- a/language.cabal
+++ b/language.cabal
@@ -36,6 +36,7 @@ executable language
       -- TypeChecker.TypeCheckerIr
       -- TypeChecker.Unification
       TypeChecker.HM
+      TypeChecker.AlgoW
       TypeChecker.HMIr
       Renamer.RenamerM
       -- Renamer.Renamer
diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs
new file mode 100644
index 0000000..e630da2
--- /dev/null
+++ b/src/TypeChecker/AlgoW.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TypeChecker.AlgoW where
+
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Data.Bifunctor        (bimap, second)
+import           Data.Functor.Identity (Identity, runIdentity)
+import           Data.List             (intersect)
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+import           Data.Maybe            (fromMaybe)
+
+import           Grammar.Abs
+import qualified TypeChecker.HMIr      as T
+
+data Poly = Forall [Ident] Type
+    deriving Show
+
+a = TPol "a"
+b = TPol "b"
+int = TMono "int"
+arr = TArr
+
+data Ctx = Ctx { vars :: Map Ident Poly
+               , sigs :: Map Ident Poly }
+
+data Env = Env { counter       :: Int
+               , substitutions :: Map Type Type
+               }
+
+type Subst = Map Type Type
+type Error = String
+
+newtype Infer a = Infer { runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a }
+    deriving (Functor, Applicative, Monad, MonadState Env, MonadReader Ctx, MonadError Error)
+
+initCtx :: Ctx
+initCtx = Ctx mempty mempty
+
+initEnv :: Env
+initEnv = Env 0 mempty
+
+run :: Ctx -> Env -> Infer a -> Either Error a
+run c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e . runInfer
+
+w :: Exp -> Infer Type
+w = \case
+    EInt n -> return int
+    EId i -> (\(Forall _ t) -> t) <$> (lookupVar i >>= inst)
+    EAbs var e -> do
+        fr <- fresh
+        withBinding var (Forall [] (TPol fr)) $ do
+            t' <- w e
+            subst (Forall [] $ TArr (TPol fr) t')
+    EApp e0 e1 -> do
+        t0 <- substCtx (w e0)
+        t1 <- w e1
+        undefined
+
+substCtx :: Infer Type -> Infer Type
+substCtx m = do
+    vs <- asks (M.toList . vars)
+    ks <- traverse (subst . snd) vs
+    let x = map fst vs
+    local (\st -> st { vars = M.fromList $ zip x ks }) m
+
+subst :: Poly -> Infer Poly
+subst (Forall xs t) = do
+    subs <- gets substitutions
+    case t of
+        TPol a -> case M.lookup (TPol a) subs of
+                    Nothing -> return $ Forall xs t
+                    Just t' -> return $ Forall (remove a xs) t'
+        TMono a -> case M.lookup (TMono a) subs of
+                    Nothing -> return $ Forall xs t
+                    Just t' -> return $ Forall (remove a xs) t'
+        TArr a b -> do
+            (Forall xs' a') <- subst (Forall xs a)
+            (Forall xs'' b') <- subst (Forall xs b)
+            return $ Forall (xs' `intersect` xs'') (TArr a' b')
+
+
+remove :: Ord a => a -> [a] -> [a]
+remove a = foldr (\x acc -> if x == a then acc else x : acc) []
+
+inst :: Poly -> Infer Poly
+inst (Forall xs t) = do
+    xs' <- mapM (const fresh) xs
+    let sub = zip xs xs'
+    let subst' t = case t of
+            TMono a -> return $ TMono a
+            TPol a -> case lookup a sub of
+                       Nothing -> return $ TPol a
+                       Just t  -> return $ TPol t
+            TArr a b -> TArr <$> subst' a <*> subst' b
+    Forall [] <$> subst' t
+
+-- | Generate a new fresh variable and increment the state
+fresh :: Infer Ident
+fresh = do
+    n <- gets counter
+    modify (\st -> st { counter = n + 1 })
+    return . Ident $ "t" ++ show n
+
+insertSub :: Type -> Type -> Infer ()
+insertSub t1 t2 = modify (\st -> st { substitutions = M.insert t1 t2 (substitutions st) })
+
+withBinding :: Ident -> Poly -> Infer Poly -> Infer Type
+withBinding i t m = (\(Forall _ t) -> t) <$> local (\re -> re { vars = M.insert i t (vars re) }) m
+
+lookupVar :: Ident -> Infer Poly
+lookupVar i = do
+    m <- asks vars
+    case M.lookup i m of
+      Just t  -> return t
+      Nothing -> throwError $ "Unbound variable: " ++ show i
+
+{-# WARNING todo "TODO IN CODE" #-}
+todo :: a
+todo = error "TODO in code"
diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs
index 63072d1..7b33cbe 100644
--- a/src/TypeChecker/HM.hs
+++ b/src/TypeChecker/HM.hs
@@ -47,7 +47,14 @@ inferPrg (Program bs) = do
 inferBind :: Bind -> Infer T.Bind
 inferBind (Bind i t _ params rhs) = do
     (t',e') <- inferExp (makeLambda rhs (reverse params))
-    when (t /= t') (throwError $ "Signature of function " ++ show i ++ " with type: " ++ show t ++ " does not match inferred type " ++ show t' ++ " of expression: " ++ show e')
+    when (t /= t') (throwError . unwords $ [ "Signature of function"
+                                           , show i
+                                           , "with type:"
+                                           , show t
+                                           , "does not match inferred type"
+                                           , show t'
+                                           , "of expression:"
+                                           , show e'])
     return $ T.Bind (t,i) [] e'
 
 makeLambda :: Exp -> [Ident] -> Exp
@@ -126,7 +133,6 @@ fresh = do
 --      b = int
 -- thus when solving constraints it must be the case that
 --      a = int -> int
---
 addConstraint :: Type -> Type -> Infer ()
 addConstraint t1 t2 = do
     modify (\st -> st { constr = M.insert t1 t2 (constr st) })

From a98135827c5fb1df1afeb5387df4199abe2dc50d Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 20 Feb 2023 16:51:44 +0100
Subject: [PATCH 37/71] EAdd is bugged. Mostly complete though.

---
 src/TypeChecker/AlgoW.hs | 183 ++++++++++++++++++++++++---------------
 1 file changed, 113 insertions(+), 70 deletions(-)

diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs
index e630da2..3667761 100644
--- a/src/TypeChecker/AlgoW.hs
+++ b/src/TypeChecker/AlgoW.hs
@@ -8,108 +8,151 @@ import           Control.Monad.Reader
 import           Control.Monad.State
 import           Data.Bifunctor        (bimap, second)
 import           Data.Functor.Identity (Identity, runIdentity)
-import           Data.List             (intersect)
+import           Data.List             (foldl', intersect)
 import           Data.Map              (Map)
 import qualified Data.Map              as M
 import           Data.Maybe            (fromMaybe)
+import           Data.Set              (Set)
+import qualified Data.Set              as S
 
 import           Grammar.Abs
+import           Grammar.Print         (printTree)
 import qualified TypeChecker.HMIr      as T
 
 data Poly = Forall [Ident] Type
     deriving Show
 
-a = TPol "a"
-b = TPol "b"
-int = TMono "int"
-arr = TArr
-
 data Ctx = Ctx { vars :: Map Ident Poly
-               , sigs :: Map Ident Poly }
+               , sigs :: Map Ident Type }
 
-data Env = Env { counter       :: Int
-               , substitutions :: Map Type Type
-               }
-
-type Subst = Map Type Type
 type Error = String
+type Subst = Map Ident Type
 
-newtype Infer a = Infer { runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a }
-    deriving (Functor, Applicative, Monad, MonadState Env, MonadReader Ctx, MonadError Error)
+type Infer = StateT Int (ReaderT Ctx (ExceptT Error Identity))
 
-initCtx :: Ctx
 initCtx = Ctx mempty mempty
 
-initEnv :: Env
-initEnv = Env 0 mempty
+run :: Infer a -> Either Error a
+run = runC initCtx 0
 
-run :: Ctx -> Env -> Infer a -> Either Error a
-run c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e . runInfer
+runC :: Ctx -> Int -> Infer a -> Either Error a
+runC c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 
-w :: Exp -> Infer Type
-w = \case
-    EInt n -> return int
-    EId i -> (\(Forall _ t) -> t) <$> (lookupVar i >>= inst)
+inferExp :: Exp -> Infer Type
+inferExp e = snd <$> w nullSubst e
+
+w :: Subst -> Exp -> Infer (Subst, Type)
+w s = \case
+    EAnn e t -> do
+        (s1, t') <- w nullSubst e
+        let t'' = apply s1 t
+        return (s1, t'')
+    EInt n -> return (nullSubst, TMono "Int")
+    EId i -> do
+        var <- asks vars
+        case M.lookup i var of
+          Nothing -> throwError $ "Unbound variable: " ++ show i
+          Just t  -> (nullSubst,) <$> inst t
     EAbs var e -> do
         fr <- fresh
-        withBinding var (Forall [] (TPol fr)) $ do
-            t' <- w e
-            subst (Forall [] $ TArr (TPol fr) t')
+        withBinding var (Forall [] fr) $ do
+            (s1, t') <- w s e
+            return (s, TArr (apply s1 fr) t')
+    EAdd e0 e1 -> do
+        (s1, t1) <- w s e0
+        (s2, t2) <- w s1 e1
+        return (s2, TMono "Int")
     EApp e0 e1 -> do
-        t0 <- substCtx (w e0)
-        t1 <- w e1
-        undefined
+        fr <- fresh
+        (s1, t0) <- w s e0
+        (s2, t1) <- w s1 e1
+        s3 <- unify (subst s2 t0) (TArr t1 fr)
+        return (s3 `compose` s2 `compose` s1, apply s3 fr)
+    ELet name e0 e1 -> do
+        (s1, t1) <- w s e0
+        env <- asks vars
+        let t' = generalize (apply s1 env) t1
+        withBinding name t' $ do
+            (s2, t2) <- w s1 e1
+            return (s1 `compose` s2, t2)
 
-substCtx :: Infer Type -> Infer Type
-substCtx m = do
-    vs <- asks (M.toList . vars)
-    ks <- traverse (subst . snd) vs
-    let x = map fst vs
-    local (\st -> st { vars = M.fromList $ zip x ks }) m
+unify :: Type -> Type -> Infer Subst
+unify t0 t1 = case (t0, t1) of
+    (TArr a b, TArr c d) -> do
+        s1 <- unify a c
+        s2 <- unify (subst s1 b) (subst s1 c)
+        return $ s1 `compose` s2
+    (TPol a, b) -> occurs a b
+    (a, TPol b) -> occurs b a
+    (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
 
-subst :: Poly -> Infer Poly
-subst (Forall xs t) = do
-    subs <- gets substitutions
-    case t of
-        TPol a -> case M.lookup (TPol a) subs of
-                    Nothing -> return $ Forall xs t
-                    Just t' -> return $ Forall (remove a xs) t'
-        TMono a -> case M.lookup (TMono a) subs of
-                    Nothing -> return $ Forall xs t
-                    Just t' -> return $ Forall (remove a xs) t'
-        TArr a b -> do
-            (Forall xs' a') <- subst (Forall xs a)
-            (Forall xs'' b') <- subst (Forall xs b)
-            return $ Forall (xs' `intersect` xs'') (TArr a' b')
+occurs :: Ident -> Type -> Infer Subst
+occurs i (TPol a) = return nullSubst
+occurs i t = if S.member i (free t)
+                then throwError "Occurs check failed"
+                else return $ M.singleton i t
 
+generalize :: Map Ident Poly -> Type -> Poly
+generalize env t = Forall (S.toList $ free t S.\\ free env) t
 
-remove :: Ord a => a -> [a] -> [a]
-remove a = foldr (\x acc -> if x == a then acc else x : acc) []
-
-inst :: Poly -> Infer Poly
+inst :: Poly -> Infer Type
 inst (Forall xs t) = do
     xs' <- mapM (const fresh) xs
-    let sub = zip xs xs'
-    let subst' t = case t of
-            TMono a -> return $ TMono a
-            TPol a -> case lookup a sub of
-                       Nothing -> return $ TPol a
-                       Just t  -> return $ TPol t
-            TArr a b -> TArr <$> subst' a <*> subst' b
-    Forall [] <$> subst' t
+    let s = M.fromList $ zip xs xs'
+    return $ apply s t
+
+compose :: Subst -> Subst -> Subst
+compose m1 m2 = M.map (subst m1) m2 `M.union` m1
+
+class FreeVars t where
+  free :: t -> Set Ident
+  apply :: Subst -> t -> t
+
+instance FreeVars Type where
+  free :: Type -> Set Ident
+  free (TPol a)   = S.singleton a
+  free (TMono _)  = mempty
+  free (TArr a b) = free a `S.union` free b
+  apply :: Subst -> Type -> Type
+  apply sub t = do
+    case t of
+        TMono a -> TMono a
+        TPol a -> case M.lookup a sub of
+                   Nothing -> TPol a
+                   Just t  -> t
+        TArr a b -> TArr (apply sub a) (apply sub b)
+
+instance FreeVars Poly where
+  free :: Poly -> Set Ident
+  free (Forall xs t) = free t S.\\ S.fromList xs
+  apply :: Subst -> Poly -> Poly
+  apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
+
+instance FreeVars (Map Ident Poly) where
+  free :: Map Ident Poly -> Set Ident
+  free m = foldl' S.union S.empty (map free $ M.elems m)
+  apply :: Subst -> Map Ident Poly -> Map Ident Poly
+  apply s = M.map (apply s)
+
+nullSubst :: Subst
+nullSubst = M.empty
+
+subst :: Subst -> Type -> Type
+subst m t = do
+    case t of
+        TPol a   -> fromMaybe t (M.lookup a m)
+        TMono a  -> TMono a
+        TArr a b -> TArr (subst m a) (subst m b)
 
 -- | Generate a new fresh variable and increment the state
-fresh :: Infer Ident
+fresh :: Infer Type
 fresh = do
-    n <- gets counter
-    modify (\st -> st { counter = n + 1 })
-    return . Ident $ "t" ++ show n
+    n <- get
+    put (n + 1)
+    return . TPol . Ident $ "t" ++ show n
 
-insertSub :: Type -> Type -> Infer ()
-insertSub t1 t2 = modify (\st -> st { substitutions = M.insert t1 t2 (substitutions st) })
-
-withBinding :: Ident -> Poly -> Infer Poly -> Infer Type
-withBinding i t m = (\(Forall _ t) -> t) <$> local (\re -> re { vars = M.insert i t (vars re) }) m
+withBinding :: Ident -> Poly -> Infer (Subst, Type) -> Infer (Subst, Type)
+withBinding i t = local (\re -> re { vars = M.insert i t (vars re) })
 
 lookupVar :: Ident -> Infer Poly
 lookupVar i = do

From 8065576c31a141e191dc9f3b55afa0348b70cba9 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 20 Feb 2023 20:38:36 +0100
Subject: [PATCH 38/71] Let has a bug, otherwise probably(?) done

---
 src/Main.hs              |   2 +-
 src/TypeChecker/AlgoW.hs | 157 +++++++++++++++++++++++++++------------
 2 files changed, 112 insertions(+), 47 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 1ef3fe3..1a73e95 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,7 +9,7 @@ import           Grammar.Print      (printTree)
 import           Renamer.RenamerM   (rename)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
-import           TypeChecker.HM     (typecheck)
+import           TypeChecker.AlgoW  (typecheck)
 
 main :: IO ()
 main =
diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs
index 3667761..3c4b9b3 100644
--- a/src/TypeChecker/AlgoW.hs
+++ b/src/TypeChecker/AlgoW.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use traverse_" #-}
 
-module TypeChecker.AlgoW where
+module TypeChecker.AlgoW  where
 
 import           Control.Monad.Except
 import           Control.Monad.Reader
@@ -16,65 +18,119 @@ import           Data.Set              (Set)
 import qualified Data.Set              as S
 
 import           Grammar.Abs
-import           Grammar.Print         (printTree)
+import           Grammar.Print         (Print, printTree)
 import qualified TypeChecker.HMIr      as T
 
 data Poly = Forall [Ident] Type
     deriving Show
 
-data Ctx = Ctx { vars :: Map Ident Poly
-               , sigs :: Map Ident Type }
+newtype Ctx = Ctx { vars  :: Map Ident Poly }
+
+data Env = Env { count :: Int
+               , sigs  :: Map Ident Type
+               }
 
 type Error = String
 type Subst = Map Ident Type
 
-type Infer = StateT Int (ReaderT Ctx (ExceptT Error Identity))
+type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
-initCtx = Ctx mempty mempty
+int = TMono "Int"
+a = TPol "a"
+b = TPol "b"
+arr = TArr
+
+initCtx = Ctx mempty
+initEnv = Env 0 mempty
+
+runPretty :: Print a => Infer a -> Either Error String
+runPretty = fmap printTree . run
 
 run :: Infer a -> Either Error a
-run = runC initCtx 0
+run = runC initEnv initCtx
 
-runC :: Ctx -> Int -> Infer a -> Either Error a
-runC c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
+runC :: Env -> Ctx -> Infer a -> Either Error a
+runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 
-inferExp :: Exp -> Infer Type
-inferExp e = snd <$> w nullSubst e
+typecheck :: Program -> Either Error T.Program
+typecheck = run . checkPrg
 
-w :: Subst -> Exp -> Infer (Subst, Type)
-w s = \case
+checkPrg :: Program -> Infer T.Program
+checkPrg (Program bs) = do
+    traverse (\(Bind n t _ _ _) -> insertSig n t) bs
+    bs' <- mapM checkBind bs
+    return $ T.Program bs'
+
+checkBind :: Bind -> Infer T.Bind
+checkBind (Bind n t _ args e) = do
+    (t', e') <- inferExp $ makeLambda e (reverse args)
+    -- when (t /= t') (throwError "Signature of function and inferred type of body do not match")
+    s <- unify t t'
+    let t'' = apply s t
+    return $ T.Bind (t'',n) [] e'
+  where
+    makeLambda :: Exp -> [Ident] -> Exp
+    makeLambda = foldl (flip EAbs)
+
+inferExp :: Exp -> Infer (Type, T.Exp)
+inferExp e = do
+    (s, t, e') <- w e
+    let subbed = apply s t
+    return (subbed, replace subbed e')
+
+replace :: Type -> T.Exp -> T.Exp
+replace t = \case
+    T.EInt t' e -> T.EInt t e
+    T.EId t' i -> T.EId t i
+    T.EAbs t' name e -> T.EAbs t name e
+    T.EApp t' e1 e2 -> T.EApp t e1 e2
+    T.EAdd t' e1 e2 -> T.EAdd t e1 e2
+    T.ELet t' name e1 e2 -> T.ELet t name e1 e2
+
+w :: Exp -> Infer (Subst, Type, T.Exp)
+w = \case
     EAnn e t -> do
-        (s1, t') <- w nullSubst e
-        let t'' = apply s1 t
-        return (s1, t'')
-    EInt n -> return (nullSubst, TMono "Int")
+        (s1, t', e') <- w e
+        applySt s1 $ do
+            s2 <- unify (apply s1 t) t'
+            return (s2 `compose` s1, t, e')
+    EInt n -> return (nullSubst, TMono "Int", T.EInt (TMono "Int") n)
     EId i -> do
         var <- asks vars
         case M.lookup i var of
           Nothing -> throwError $ "Unbound variable: " ++ show i
-          Just t  -> (nullSubst,) <$> inst t
-    EAbs var e -> do
+          Just t  ->  inst t >>= \x -> return (nullSubst, x, T.EId x i)
+    EAbs name e -> do
         fr <- fresh
-        withBinding var (Forall [] fr) $ do
-            (s1, t') <- w s e
-            return (s, TArr (apply s1 fr) t')
+        withBinding name (Forall [] fr) $ do
+            (s1, t', e') <- w e
+            let newArr = TArr (apply s1 fr) t'
+            return (s1, newArr, T.EAbs newArr name e')
     EAdd e0 e1 -> do
-        (s1, t1) <- w s e0
-        (s2, t2) <- w s1 e1
-        return (s2, TMono "Int")
+        (s1, t0, e0') <- w e0
+        applySt s1 $ do
+            (s2, t1, e1') <- w e1
+            applySt s2 $ do
+                s3 <- unify (subst s2 t0) (TMono "Int")
+                s4 <- unify (subst s3 t1) (TMono "Int")
+                return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
     EApp e0 e1 -> do
         fr <- fresh
-        (s1, t0) <- w s e0
-        (s2, t1) <- w s1 e1
-        s3 <- unify (subst s2 t0) (TArr t1 fr)
-        return (s3 `compose` s2 `compose` s1, apply s3 fr)
+        (s1, t0, e0') <- w e0
+        applySt s1 $ do
+            (s2, t1, e1') <- w e1
+            applySt s2 $ do
+                s3 <- unify (subst s2 t0) (TArr t1 fr)
+                let t = apply s3 fr
+                return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1')
     ELet name e0 e1 -> do
-        (s1, t1) <- w s e0
-        env <- asks vars
-        let t' = generalize (apply s1 env) t1
-        withBinding name t' $ do
-            (s2, t2) <- w s1 e1
-            return (s1 `compose` s2, t2)
+        (s1, t1, e0') <- w e0
+        applySt s1 $ do
+            env <- asks vars
+            let t' = generalize (apply s1 env) t1
+            withBinding name t' $ do
+                (s2, t2, e1') <- w e1
+                return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' )
 
 unify :: Type -> Type -> Infer Subst
 unify t0 t1 = case (t0, t1) of
@@ -85,6 +141,7 @@ unify t0 t1 = case (t0, t1) of
     (TPol a, b) -> occurs a b
     (a, TPol b) -> occurs b a
     (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
+    (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
 
 occurs :: Ident -> Type -> Infer Subst
 occurs i (TPol a) = return nullSubst
@@ -104,8 +161,11 @@ inst (Forall xs t) = do
 compose :: Subst -> Subst -> Subst
 compose m1 m2 = M.map (subst m1) m2 `M.union` m1
 
+-- | A class representing free variables functions
 class FreeVars t where
+  -- | Get all free variables from t
   free :: t -> Set Ident
+  -- | Apply a substitution to t, generating a new t
   apply :: Subst -> t -> t
 
 instance FreeVars Type where
@@ -134,9 +194,14 @@ instance FreeVars (Map Ident Poly) where
   apply :: Subst -> Map Ident Poly -> Map Ident Poly
   apply s = M.map (apply s)
 
+applySt :: Subst -> Infer a -> Infer a
+applySt s = local (\st -> st { vars = apply s (vars st) })
+
+-- | Represents the empty substition set
 nullSubst :: Subst
 nullSubst = M.empty
 
+-- | Substitute type variables with their mappings from the substitution set.
 subst :: Subst -> Type -> Type
 subst m t = do
     case t of
@@ -144,23 +209,23 @@ subst m t = do
         TMono a  -> TMono a
         TArr a b -> TArr (subst m a) (subst m b)
 
--- | Generate a new fresh variable and increment the state
+-- | Generate a new fresh variable and increment the state counter
 fresh :: Infer Type
 fresh = do
-    n <- get
-    put (n + 1)
+    n <- gets count
+    modify (\st -> st { count = n + 1 })
     return . TPol . Ident $ "t" ++ show n
 
-withBinding :: Ident -> Poly -> Infer (Subst, Type) -> Infer (Subst, Type)
-withBinding i t = local (\re -> re { vars = M.insert i t (vars re) })
+withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
+withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
 
+insertSig :: Ident -> Type -> Infer ()
+insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
+
+-- | Lookup a variable in the context
 lookupVar :: Ident -> Infer Poly
 lookupVar i = do
     m <- asks vars
     case M.lookup i m of
-      Just t  -> return t
-      Nothing -> throwError $ "Unbound variable: " ++ show i
-
-{-# WARNING todo "TODO IN CODE" #-}
-todo :: a
-todo = error "TODO in code"
+        Just t  -> return t
+        Nothing -> throwError $ "Unbound variable: " ++ show i

From 5daa5573f26c42a1db125758d2e229fa772a2cec Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 22 Feb 2023 15:24:38 +0100
Subject: [PATCH 39/71] Added more comments to the code

---
 src/TypeChecker/AlgoW.hs | 22 +++++++++++++++-------
 src/TypeChecker/HMIr.hs  |  2 +-
 test_program             |  3 ++-
 3 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs
index 3c4b9b3..3492908 100644
--- a/src/TypeChecker/AlgoW.hs
+++ b/src/TypeChecker/AlgoW.hs
@@ -21,6 +21,7 @@ import           Grammar.Abs
 import           Grammar.Print         (Print, printTree)
 import qualified TypeChecker.HMIr      as T
 
+-- | A data type representing type variables
 data Poly = Forall [Ident] Type
     deriving Show
 
@@ -35,11 +36,6 @@ type Subst = Map Ident Type
 
 type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
-int = TMono "Int"
-a = TPol "a"
-b = TPol "b"
-arr = TArr
-
 initCtx = Ctx mempty
 initEnv = Env 0 mempty
 
@@ -64,7 +60,6 @@ checkPrg (Program bs) = do
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
     (t', e') <- inferExp $ makeLambda e (reverse args)
-    -- when (t /= t') (throwError "Signature of function and inferred type of body do not match")
     s <- unify t t'
     let t'' = apply s t
     return $ T.Bind (t'',n) [] e'
@@ -132,6 +127,7 @@ w = \case
                 (s2, t2, e1') <- w e1
                 return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' )
 
+-- | Unify two types producing a new substitution (constraint)
 unify :: Type -> Type -> Infer Subst
 unify t0 t1 = case (t0, t1) of
     (TArr a b, TArr c d) -> do
@@ -143,15 +139,19 @@ unify t0 t1 = case (t0, t1) of
     (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
     (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
 
+-- | Check if a type is contained in another type.
+-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
 occurs :: Ident -> Type -> Infer Subst
 occurs i (TPol a) = return nullSubst
 occurs i t = if S.member i (free t)
                 then throwError "Occurs check failed"
                 else return $ M.singleton i t
 
+-- | Generalize a type over all free variables in the substitution set
 generalize :: Map Ident Poly -> Type -> Poly
 generalize env t = Forall (S.toList $ free t S.\\ free env) t
 
+-- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones.
 inst :: Poly -> Infer Type
 inst (Forall xs t) = do
     xs' <- mapM (const fresh) xs
@@ -165,7 +165,7 @@ compose m1 m2 = M.map (subst m1) m2 `M.union` m1
 class FreeVars t where
   -- | Get all free variables from t
   free :: t -> Set Ident
-  -- | Apply a substitution to t, generating a new t
+  -- | Apply a substitution to t
   apply :: Subst -> t -> t
 
 instance FreeVars Type where
@@ -216,9 +216,11 @@ fresh = do
     modify (\st -> st { count = n + 1 })
     return . TPol . Ident $ "t" ++ show n
 
+-- | Run the monadic action with an additional binding
 withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
 withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
 
+-- | Insert a function signature into the environment
 insertSig :: Ident -> Type -> Infer ()
 insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
 
@@ -229,3 +231,9 @@ lookupVar i = do
     case M.lookup i m of
         Just t  -> return t
         Nothing -> throwError $ "Unbound variable: " ++ show i
+
+lett = let (Right (t,e)) = run $ inferExp $ ELet "x" (EAdd (EInt 5) (EInt 5)) (EAdd (EId "x") (EId "x"))
+        in t == TMono "Int"
+
+letty = let (Right (t,e)) = run $ inferExp $ ELet "f" (EAbs "x" (EId "x")) (EApp (EId "f") (EInt 3))
+         in e
diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs
index 036fa42..0a6085c 100644
--- a/src/TypeChecker/HMIr.hs
+++ b/src/TypeChecker/HMIr.hs
@@ -25,7 +25,7 @@ data Exp
 instance Show Exp where
     show (EId t (Ident i))    = i ++ " : " ++ show t
     show (EInt _ i)           = show i
-    show (ELet t i e1 e2)     = error "Show for let not implemented"
+    show (ELet t i e1 e2)     = "let " ++ show t ++ " = " ++ show e1 ++ " in " ++ show e2
     show (EApp t e1 e2)       = show e1 ++ " " ++ show e2 ++ " : " ++ show t
     show (EAdd _ e1 e2)       = show e1 ++ " + " ++ show e2
     show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t
diff --git a/test_program b/test_program
index 6d38647..3481a0b 100644
--- a/test_program
+++ b/test_program
@@ -1,2 +1,3 @@
 fun : Mono Int -> Mono Int ;
-fun = \x. x ;
+fun = let f = \x. x in f 3 ;
+

From 06e65de23574b53f2bd334af9a859357fe7e7051 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 23 Feb 2023 11:54:35 +0100
Subject: [PATCH 40/71] started on a test suite

---
 language.cabal                 |  31 +++-
 src/Main.hs                    |   3 +-
 src/Renamer/RenamerM.hs        |   2 +-
 src/TypeChecker/AlgoW.hs       |  11 +-
 src/TypeChecker/Unification.hs | 261 ---------------------------------
 tests/Main.hs                  |  21 +++
 6 files changed, 57 insertions(+), 272 deletions(-)
 delete mode 100644 src/TypeChecker/Unification.hs
 create mode 100644 tests/Main.hs

diff --git a/language.cabal b/language.cabal
index 7b21b60..f803c1b 100644
--- a/language.cabal
+++ b/language.cabal
@@ -15,7 +15,6 @@ extra-doc-files:    CHANGELOG.md
 extra-source-files:
   Grammar.cf
 
-
 common warnings
     ghc-options: -Wdefault
 
@@ -51,6 +50,34 @@ executable language
       , either
       , extra
       , array
-      , unification-fd
 
     default-language: GHC2021
+
+test-suite test
+  hs-source-dirs: tests, src
+  main-is: Main.hs
+  type: exitcode-stdio-1.0
+
+  other-modules:
+    Grammar.Abs
+    Grammar.Lex
+    Grammar.Par
+    Grammar.Print
+    Grammar.Skel
+    Grammar.ErrM
+    Auxiliary
+    Renamer.RenamerM
+    TypeChecker.AlgoW
+    TypeChecker.HM
+    TypeChecker.HMIr
+
+  build-depends:  
+      base >=4.16
+    , mtl
+    , containers
+    , either
+    , array
+    , extra
+    , hspec
+
+  default-language: GHC2021
diff --git a/src/Main.hs b/src/Main.hs
index 1a73e95..58811fe 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,8 +12,7 @@ import           System.Exit        (exitFailure, exitSuccess)
 import           TypeChecker.AlgoW  (typecheck)
 
 main :: IO ()
-main =
-    getArgs >>= \case
+main = getArgs >>= \case
         [] -> print "Required file path missing"
         (x : _) -> do
             file <- readFile x
diff --git a/src/Renamer/RenamerM.hs b/src/Renamer/RenamerM.hs
index 215290c..5fb1fa2 100644
--- a/src/Renamer/RenamerM.hs
+++ b/src/Renamer/RenamerM.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase                 #-}
 
 module Renamer.RenamerM  where
 
diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs
index 3492908..de931d1 100644
--- a/src/TypeChecker/AlgoW.hs
+++ b/src/TypeChecker/AlgoW.hs
@@ -120,12 +120,11 @@ w = \case
                 return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1')
     ELet name e0 e1 -> do
         (s1, t1, e0') <- w e0
-        applySt s1 $ do
-            env <- asks vars
-            let t' = generalize (apply s1 env) t1
-            withBinding name t' $ do
-                (s2, t2, e1') <- w e1
-                return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' )
+        env <- asks vars
+        let t' = generalize (apply s1 env) t1
+        withBinding name t' $ do
+            (s2, t2, e1') <- w e1
+            return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' )
 
 -- | Unify two types producing a new substitution (constraint)
 unify :: Type -> Type -> Infer Subst
diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs
deleted file mode 100644
index 226e1e9..0000000
--- a/src/TypeChecker/Unification.hs
+++ /dev/null
@@ -1,261 +0,0 @@
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms   #-}
-
-module TypeChecker.Unification where
-
-import           Control.Arrow              ((>>>))
-import           Control.Monad.Except
-import           Control.Monad.Reader
-import           Control.Monad.State
-import           Control.Unification        hiding (applyBindings, (=:=))
-import qualified Control.Unification        as U
-import           Control.Unification.IntVar
-import           Data.Foldable              (fold)
-import           Data.Functor.Fixedpoint
-import           Data.Functor.Identity
-import           Data.Map                   (Map)
-import qualified Data.Map                   as M
-import           Data.Maybe                 (fromJust, fromMaybe)
-import           Data.Set                   (Set, (\\))
-import qualified Data.Set                   as S
-import           Debug.Trace                (trace)
-import           GHC.Generics               (Generic1)
-import           Renamer.Renamer
-import qualified Renamer.RenamerIr          as R
-import           Renamer.RenamerIr          (Const (..), Ident (..), RBind (..),
-                                             RExp (..), RProgram (..))
-
-type Ctx = Map Ident UPolytype
-
-type TypeError = String
-
-data TypeT a = TPolyT Ident | TMonoT Ident | TArrowT a a
-    deriving (Functor, Foldable, Traversable, Generic1, Unifiable)
-
-instance Show a => Show (TypeT a) where
-    show (TPolyT (Ident i)) = i
-    show (TMonoT (Ident i)) = i
-    show (TArrowT a b)      = show a ++ " -> " ++ show b
-
-type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity)))
-
-type Type = Fix TypeT
-
-type UType = UTerm TypeT IntVar
-
-data Poly t = Forall [Ident] t
-    deriving (Eq, Functor)
-
-instance Show t => Show (Poly t) where
-    show (Forall is t) = unwords (map (\(Ident x) -> "forall " ++ x ++ ".") is) ++ " " ++ show t
-
-type Polytype = Poly Type
-
-type UPolytype = Poly UType
-
-pattern TPoly :: Ident -> Type
-pattern TPoly v = Fix (TPolyT v)
-
-pattern TMono :: Ident -> Type
-pattern TMono v = Fix (TMonoT v)
-
-pattern TArrow :: Type -> Type -> Type
-pattern TArrow t1 t2 = Fix (TArrowT t1 t2)
-
-pattern UTMono :: Ident -> UType
-pattern UTMono v = UTerm (TMonoT v)
-
-pattern UTArrow :: UType -> UType -> UType
-pattern UTArrow t1 t2 = UTerm (TArrowT t1 t2)
-
-pattern UTPoly :: Ident -> UType
-pattern UTPoly v = UTerm (TPolyT v)
-
-data TType = TTPoly Ident | TTMono Ident | TTArrow TType TType
-    deriving (Show)
-
-newtype Program = Program [Bind]
-    deriving (Show)
-
-data Bind = Bind Ident Exp Polytype
-    deriving (Show)
-
-data Exp
-    = EAnn Exp Polytype
-    | EBound Ident Polytype
-    | EFree Ident Polytype
-    | EConst Const Polytype
-    | EApp Exp Exp Polytype
-    | EAdd Exp Exp Polytype
-    | EAbs Ident Exp Polytype
-    deriving (Show)
-
-data TExp
-    = TAnn TExp UType
-    | TFree Ident UType
-    | TBound Ident UType
-    | TConst Const UType
-    | TApp TExp TExp UType
-    | TAdd TExp TExp UType
-    | TAbs Ident TExp UType
-    deriving (Show)
-
-----------------------------------------------------------
-typecheck :: RProgram -> Either TypeError Program
-typecheck = undefined
-
-run :: Infer (UType, TExp) -> Either TypeError Polytype
-run = fmap fst
-      >>> (>>= applyBindings)
-      >>> (>>= (generalize >>> fmap fromUPolytype))
-      >>> flip evalStateT mempty
-      >>> flip runReaderT mempty
-      >>> runExceptT
-      >>> evalIntBindingT
-      >>> runIdentity
-
-infer :: RExp -> Infer (UType, TExp)
-infer = \case
-    (RConst (CInt i)) -> return (UTMono "Int", TConst (CInt i) (UTMono "Int"))
-    (RConst (CStr str)) -> return (UTMono "String", TConst (CStr str) (UTMono "String"))
-    (RAdd e1 e2) -> do
-        (t1, e1') <- infer e2
-        (t2, e2') <- infer e1
-        t1 =:= UTMono "Int"
-        t2 =:= UTMono "Int"
-        return (UTMono "Int", TAdd e1' e2' (UTMono "Int"))
-    -- type is not used, probably wrong
-    (RAnn e t) -> do
-        (t', e') <- infer e
-        check e t'
-        return (t', TAnn e' t')
-    (RApp e1 e2) -> do
-        (f, e1') <- infer e1
-        (arg, e2') <- infer e2
-        res <- fresh
-        f =:= UTArrow arg res
-        return (res, TApp e1' e2' res)
-    (RAbs _ i e) -> do
-        arg <- fresh
-        withBinding i (Forall [] arg) $ do
-            (res, e') <- infer e
-            return (UTArrow arg res, TAbs i e' (UTArrow arg res))
-    (RFree i) -> do
-        t <- lookupSigsT i
-        return (t, TFree i t)
-    (RBound _ i) -> do
-        t <- lookupVarT i
-        return (t, TBound i t)
-
-check :: RExp -> UType -> Infer ()
-check expr t = do
-    (t', _) <- infer expr
-    t =:= t'
-    return ()
-
-lookupVarT :: Ident -> Infer UType
-lookupVarT x@(Ident i) = do
-    ctx <- ask
-    maybe (throwError $ "Var - Unbound variable: " <> i) instantiate (M.lookup x ctx)
-
-lookupSigsT :: Ident -> Infer UType
-lookupSigsT x@(Ident i) = do
-    ctx <- ask
-    case M.lookup x ctx of
-        Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i)
-        Just ut -> return $ fromPolytype ut
-
-insertSigs :: MonadState (Map Ident UPolytype) m => Ident -> UPolytype -> m ()
-insertSigs x ty = modify (M.insert x ty)
-
-fromPolytype :: UPolytype -> UType
-fromPolytype (Forall ids ut) = ut
-
-ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a
-ucata f _ (UVar v)  = f v
-ucata f g (UTerm t) = g (fmap (ucata f g) t)
-
-withBinding :: MonadReader Ctx m => Ident -> UPolytype -> m a -> m a
-withBinding x ty = local (M.insert x ty)
-
-deriving instance Ord IntVar
-
-class FreeVars a where
-    freeVars :: a -> Infer (Set (Either Ident IntVar))
-
-instance FreeVars UType where
-    freeVars ut = do
-        fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut
-        let ftvs =
-                ucata
-                    (const S.empty)
-                    (\case TMonoT x -> S.singleton (Left x); f -> fold f)
-                    ut
-        return $ fuvs `S.union` ftvs
-
-instance FreeVars UPolytype where
-    freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut
-
-instance FreeVars Ctx where
-    freeVars = fmap S.unions . mapM freeVars . M.elems
-
-fresh :: Infer UType
-fresh = UVar <$> lift (lift (lift freeVar))
-
-instance Fallible TypeT IntVar TypeError where
-    occursFailure iv ut = "Infinite"
-    mismatchFailure iv ut = "Mismatch"
-
-(=:=) :: UType -> UType -> Infer UType
-(=:=) s t = lift . lift $ s U.=:= t
-
-applyBindings :: UType -> Infer UType
-applyBindings = lift . lift . U.applyBindings
-
-instantiate :: UPolytype -> Infer UType
-instantiate (Forall xs uty) = do
-    xs' <- mapM (const fresh) xs
-    return $ substU (M.fromList (zip (map Left xs) xs')) uty
-
-substU :: Map (Either Ident IntVar) UType -> UType -> UType
-substU m =
-    ucata
-        (\v -> fromMaybe (UVar v) (M.lookup (Right v) m))
-        ( \case
-            TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m)
-            f -> UTerm f
-        )
-
-skolemize :: UPolytype -> Infer UType
-skolemize (Forall xs uty) = do
-    xs' <- mapM (const fresh) xs
-    return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty
-  where
-    toSkolem (UVar v) = UTPoly (mkVarName "s" v)
-
-mkVarName :: String -> IntVar -> Ident
-mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1)
-
--- | Used in let bindings to generalize functions declared there
-generalize :: UType -> Infer UPolytype
-generalize uty = do
-    uty' <- applyBindings uty
-    ctx <- ask
-    tmfvs <- freeVars uty'
-    ctxfvs <- freeVars ctx
-    let fvs = S.toList $ tmfvs \\ ctxfvs
-        xs = map (either id (mkVarName "a")) fvs
-    return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty')
-
-fromUPolytype :: UPolytype -> Polytype
-fromUPolytype = fmap (fromJust . freeze)
-
-inf = RAbs 0 "x" (RApp (RBound 0 "x") (RBound 0 "x"))
-
-one = RConst (CInt 1)
-
-lambda = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
-
-fn = RAbs 0 "x" (RBound 0 "x")
diff --git a/tests/Main.hs b/tests/Main.hs
new file mode 100644
index 0000000..7432800
--- /dev/null
+++ b/tests/Main.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Grammar.Abs
+import           System.Exit       (exitFailure)
+import           Test.Hspec
+import           TypeChecker.AlgoW
+
+main :: IO ()
+main = do
+    print "RUNNING TESTS BROTHER"
+    exitFailure
+    -- hspec $ do
+    --     describe "the algorithm W" $ do
+    --         it "infers EInt as type Int" $ do
+    --             fmap fst (run (inferExp (EInt 1))) `shouldBe` Right (TMono "Int")
+    --         it "throws an exception if a variable is inferred with an empty env" $ do
+    --             run (inferExp (EId "x")) `shouldBe` Left "Unbound variable: x"
+    --         it "throws an exception if the annotated type does not match the inferred type" $ do
+    --             fmap fst (run (inferExp (EAnn (EInt 3) (TPol "a")))) `shouldBe` Right (TMono "bad")

From 2f45f39435f207bfb5eb3a922ac33e86792a548e Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 27 Feb 2023 11:12:05 +0100
Subject: [PATCH 41/71] Incorporated most of main, as well as started on
 quickcheck

---
 Grammar.cf                       |  44 +++-
 language.cabal                   |  68 +++----
 src/Codegen/Codegen.hs           | 277 +++++++++++++++++++++++++
 src/Codegen/LlvmIr.hs            | 204 +++++++++++++++++++
 src/Compiler.hs                  |   0
 src/Interpreter.hs               |  78 --------
 src/LambdaLifter/LambdaLifter.hs | 192 ++++++++++++++++++
 src/Main.hs                      | 109 ++++++----
 src/Renamer/Renamer.hs           | 154 +++++++-------
 src/Renamer/RenamerIr.hs         |  32 ---
 src/Renamer/RenamerM.hs          |  83 --------
 src/TypeChecker/AlgoW.hs         | 238 ----------------------
 src/TypeChecker/HM.hs            | 181 -----------------
 src/TypeChecker/HMIr.hs          | 110 ----------
 src/TypeChecker/TypeChecker.hs   | 333 ++++++++++++++++++++-----------
 src/TypeChecker/TypeCheckerIr.hs | 157 +++++++++------
 test_program                     |   5 +-
 tests/Main.hs                    |  21 --
 tests/Tests.hs                   |  56 ++++++
 19 files changed, 1252 insertions(+), 1090 deletions(-)
 create mode 100644 src/Codegen/Codegen.hs
 create mode 100644 src/Codegen/LlvmIr.hs
 delete mode 100644 src/Compiler.hs
 delete mode 100644 src/Interpreter.hs
 create mode 100644 src/LambdaLifter/LambdaLifter.hs
 delete mode 100644 src/Renamer/RenamerIr.hs
 delete mode 100644 src/Renamer/RenamerM.hs
 delete mode 100644 src/TypeChecker/AlgoW.hs
 delete mode 100644 src/TypeChecker/HM.hs
 delete mode 100644 src/TypeChecker/HMIr.hs
 delete mode 100644 tests/Main.hs
 create mode 100644 tests/Tests.hs

diff --git a/Grammar.cf b/Grammar.cf
index 5406ac8..6870367 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,27 +1,54 @@
 
-Program. Program ::= [Bind] ;
+Program. Program ::= [Def] ;
 
+DBind. Def ::= Bind ;
+DData. Def ::= Data ;
+terminator Def ";" ;
 
 Bind. Bind ::= Ident ":" Type ";"
                Ident [Ident] "=" Exp ;
 
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
 EId.    Exp4 ::= Ident ;
-EInt.   Exp4 ::= Integer ;
+ELit.   Exp4 ::= Literal ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
-ELet.   Exp ::= "let" Ident "=" Exp "in" Exp ; 
+ELet.   Exp  ::= "let" Ident "=" Exp "in" Exp ; 
 EAbs.   Exp  ::= "\\" Ident "." Exp ;
+ECase.  Exp ::= "case" Exp "of" "{" [Inj]  "}";
 
-TMono. Type1 ::= "Mono" Ident ;
-TPol. Type1 ::= "Poly" Ident ;
+LInt. Literal ::= Integer ;
+
+Inj. Inj ::= Init "=>" Exp ;
+terminator Inj ";" ;
+
+InitLit. Init ::= Literal ;
+InitConstr. Init ::= Ident [Match] ;
+InitCatch. Init ::= "_" ;
+
+LMatch. Match ::= Literal ;
+IMatch. Match ::= Ident ;
+InitMatch. Match ::= Ident Match ;
+separator Match " " ;
+
+TMono. Type1 ::= "_" Ident ;
+TPol. Type1 ::= "'" Ident ;
 TArr. Type ::= Type1 "->" Type ;
+separator Type " " ;
+
+-- shift/reduce problem here
+Data. Data ::= "data" Ident [Type] "where" ";"
+               [Constructor];
+
+terminator Constructor ";" ;
+
+Constructor. Constructor ::= Ident ":" Type ;
 
 -- This doesn't seem to work so we'll have to live with ugly keywords for now
--- token Upper (upper (letter | digit | '_')*) ;
--- token Lower (lower (letter | digit | '_')*) ;
+-- token Poly upper (letter | digit | '_')* ;
+-- token Mono lower (letter | digit | '_')* ;
 
-separator Bind ";" ;
+terminator Bind ";" ;
 separator Ident " ";
 
 coercions Type 1 ;
@@ -29,3 +56,4 @@ coercions Exp 5 ;
 
 comment "--" ;
 comment "{-" "-}" ;
+
diff --git a/language.cabal b/language.cabal
index f803c1b..eb58aa0 100644
--- a/language.cabal
+++ b/language.cabal
@@ -16,7 +16,7 @@ extra-source-files:
   Grammar.cf
 
 common warnings
-    ghc-options: -Wdefault
+    ghc-options: -W
 
 executable language
     import:           warnings
@@ -31,15 +31,12 @@ executable language
       Grammar.Skel
       Grammar.ErrM
       Auxiliary
-      -- TypeChecker.TypeChecker
-      -- TypeChecker.TypeCheckerIr
-      -- TypeChecker.Unification
-      TypeChecker.HM
-      TypeChecker.AlgoW
-      TypeChecker.HMIr
-      Renamer.RenamerM
-      -- Renamer.Renamer
-      -- Renamer.RenamerIr
+      TypeChecker.TypeChecker
+      TypeChecker.TypeCheckerIr
+      Renamer.Renamer
+      LambdaLifter.LambdaLifter
+      Codegen.Codegen
+      Codegen.LlvmIr
 
     hs-source-dirs:   src
 
@@ -50,34 +47,35 @@ executable language
       , either
       , extra
       , array
+      , QuickCheck
 
     default-language: GHC2021
 
-test-suite test
-  hs-source-dirs: tests, src
-  main-is: Main.hs
-  type: exitcode-stdio-1.0
+Test-suite language-testsuite
+    type: exitcode-stdio-1.0
+    main-is: Tests.hs
 
-  other-modules:
-    Grammar.Abs
-    Grammar.Lex
-    Grammar.Par
-    Grammar.Print
-    Grammar.Skel
-    Grammar.ErrM
-    Auxiliary
-    Renamer.RenamerM
-    TypeChecker.AlgoW
-    TypeChecker.HM
-    TypeChecker.HMIr
+    other-modules:
+      Grammar.Abs
+      Grammar.Lex
+      Grammar.Par
+      Grammar.Print
+      Grammar.Skel
+      Grammar.ErrM
+      Auxiliary
+      TypeChecker.TypeChecker
+      TypeChecker.TypeCheckerIr
+      Renamer.Renamer
 
-  build-depends:  
-      base >=4.16
-    , mtl
-    , containers
-    , either
-    , array
-    , extra
-    , hspec
+    hs-source-dirs: src, tests
 
-  default-language: GHC2021
+    build-depends: 
+        base >=4.16
+      , mtl
+      , containers
+      , either
+      , extra
+      , array
+      , QuickCheck
+
+    default-language: GHC2021
diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs
new file mode 100644
index 0000000..76a1f02
--- /dev/null
+++ b/src/Codegen/Codegen.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Codegen.Codegen (compile) where
+
+import           Auxiliary                 (snoc)
+import           Codegen.LlvmIr            (LLVMIr (..), LLVMType (..),
+                                            LLVMValue (..), Visibility (..),
+                                            llvmIrToString)
+import           Control.Monad.State       (StateT, execStateT, gets, modify)
+import           Data.Map                  (Map)
+import qualified Data.Map                  as Map
+import           Data.Tuple.Extra          (dupe, first, second)
+import           Grammar.ErrM              (Err)
+import           TypeChecker.TypeChecker
+import           TypeChecker.TypeCheckerIr
+
+-- | The record used as the code generator state
+data CodeGenerator = CodeGenerator
+    { instructions  :: [LLVMIr]
+    , functions     :: Map Id FunctionInfo
+    , variableCount :: Integer
+    }
+
+-- | A state type synonym
+type CompilerState a = StateT CodeGenerator Err a
+
+data FunctionInfo = FunctionInfo
+    { numArgs   :: Int
+    , arguments :: [Id]
+    }
+
+-- | Adds a instruction to the CodeGenerator state
+emit :: LLVMIr -> CompilerState ()
+emit l = modify $ \t -> t { instructions = snoc l $ instructions t }
+
+-- | 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
+
+-- | Increases the variable count and returns it from the CodeGenerator state
+getNewVar :: CompilerState Integer
+getNewVar = increaseVarCount >> getVarCount
+
+-- | Produces a map of functions infos from a list of binds,
+-- which contains useful data for code generation.
+getFunctions :: [Bind] -> Map Id FunctionInfo
+getFunctions bs = Map.fromList $ map go bs
+  where
+    go (Bind id args _) =
+        (id, FunctionInfo { numArgs=length args, arguments=args })
+
+
+
+initCodeGenerator :: [Bind] -> CodeGenerator
+initCodeGenerator scs = CodeGenerator { instructions = defaultStart
+                                      , functions = getFunctions scs
+                                      , variableCount = 0
+                                      }
+
+-- | Compiles an AST and produces a LLVM Ir string.
+-- An easy way to actually "compile" this output is to
+-- Simply pipe it to lli
+compile :: Program -> Err String
+compile (Program scs) = do
+    let codegen = initCodeGenerator scs
+    llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
+
+compileScs :: [Bind] -> CompilerState ()
+compileScs []                             = pure ()
+compileScs (Bind (name, t) args exp : xs) = do
+    emit $ UnsafeRaw "\n"
+    emit . Comment $ show name <> ": " <> show exp
+    let args' = map (second type2LlvmType) args
+    emit $ Define (type2LlvmType t_return) name args'
+    functionBody <- exprToValue exp
+    if name == "main"
+        then mapM_ emit $ mainContent functionBody
+        else emit $ Ret I64 functionBody
+    emit DefineEnd
+    modify $ \s -> s { variableCount = 0 }
+    compileScs xs
+  where
+    t_return = snd $ partitionType (length args) t
+
+mainContent :: LLVMValue -> [LLVMIr]
+mainContent var =
+    [ UnsafeRaw $
+        "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
+    , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
+      -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2")
+      -- , Label (Ident "b_1")
+      -- , UnsafeRaw
+      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
+      -- , Br (Ident "end")
+      -- , Label (Ident "b_2")
+      -- , UnsafeRaw
+      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
+      -- , Br (Ident "end")
+      -- , Label (Ident "end")
+      Ret I64 (VInteger 0)
+    ]
+
+defaultStart :: [LLVMIr]
+defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n"
+               , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
+               ]
+
+compileExp :: Exp -> CompilerState ()
+compileExp = \case
+  ELit _ (LInt i)        -> emitInt i
+  EAdd t e1 e2  -> emitAdd t e1 e2
+  EId (name, _) -> emitIdent name
+  EApp t e1 e2  -> emitApp t e1 e2
+  EAbs t ti e   -> emitAbs t ti e
+  ELet bind e   -> emitLet bind e
+
+--- aux functions ---
+emitAbs :: Type -> Id -> Exp -> CompilerState ()
+emitAbs _t tid e = emit . Comment $ "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
+
+emitLet :: Bind -> Exp -> CompilerState ()
+emitLet b e = emit . Comment $ concat [ "ELet ("
+                                      , show b
+                                      , " = "
+                                      , show e
+                                      , ") is not implemented!"
+                                      ]
+
+emitApp :: Type -> Exp -> Exp -> CompilerState ()
+emitApp t e1 e2 = appEmitter t e1 e2 []
+  where
+    appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
+    appEmitter t e1 e2 stack = do
+        let newStack = e2 : stack
+        case e1 of
+            EApp _ e1' e2' -> appEmitter t e1' e2' newStack
+            EId id@(name, _) -> do
+                args <- traverse exprToValue newStack
+                vs <- getNewVar
+                funcs <- gets functions
+                let visibility = maybe Local (const Global) $ Map.lookup id funcs
+                    args'      = map (first valueGetType . dupe) args
+                    call       = Call (type2LlvmType t) visibility name args'
+                emit $ SetVariable (Ident $ show vs) call
+            x -> do
+                emit . Comment $ "The unspeakable happened: "
+                emit . Comment $ show x
+
+emitIdent :: Ident -> CompilerState ()
+emitIdent id = do
+    -- !!this should never happen!!
+    emit $ Comment "This should not have happened!"
+    emit $ Variable id
+    emit $ UnsafeRaw "\n"
+
+emitInt :: Integer -> CompilerState ()
+emitInt i = do
+    -- !!this should never happen!!
+    varCount <- getNewVar
+    emit $ Comment "This should not have happened!"
+    emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
+
+emitAdd :: Type -> Exp -> Exp -> CompilerState ()
+emitAdd t e1 e2 = do
+    v1 <- exprToValue e1
+    v2 <- exprToValue e2
+    v <- getNewVar
+    emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2)
+
+-- emitMul :: Exp -> Exp -> CompilerState ()
+-- emitMul e1 e2 = do
+--     (v1,v2) <- binExprToValues e1 e2
+--     increaseVarCount
+--     v <- gets variableCount
+--     emit $ SetVariable $ Ident $ show v
+--     emit $ Mul I64 v1 v2
+
+-- emitMod :: Exp -> Exp -> CompilerState ()
+-- emitMod e1 e2 = do
+--     -- `let m a b = rem (abs $ b + a) b`
+--     (v1,v2) <- binExprToValues e1 e2
+--     increaseVarCount
+--     vadd <- gets variableCount
+--     emit $ SetVariable $ Ident $ show vadd
+--     emit $ Add I64 v1 v2
+--
+--     increaseVarCount
+--     vabs <- gets variableCount
+--     emit $ SetVariable $ Ident $ show vabs
+--     emit $ Call I64 (Ident "llvm.abs.i64")
+--         [ (I64, VIdent (Ident $ show vadd))
+--         , (I1, VInteger 1)
+--         ]
+--     increaseVarCount
+--     v <- gets variableCount
+--     emit $ SetVariable $ Ident $ show v
+--     emit $ Srem I64 (VIdent (Ident $ show vabs)) v2
+
+-- emitDiv :: Exp -> Exp -> CompilerState ()
+-- emitDiv e1 e2 = do
+--     (v1,v2) <- binExprToValues e1 e2
+--     increaseVarCount
+--     v <- gets variableCount
+--     emit $ SetVariable $ Ident $ show v
+--     emit $ Div I64 v1 v2
+
+-- emitSub :: Exp -> Exp -> CompilerState ()
+-- emitSub e1 e2 = do
+--     (v1,v2) <- binExprToValues e1 e2
+--     increaseVarCount
+--     v <- gets variableCount
+--     emit $ SetVariable $ Ident $ show v
+--     emit $ Sub I64 v1 v2
+
+exprToValue :: Exp -> CompilerState LLVMValue
+exprToValue = \case
+    ELit _ (LInt i) -> pure $ VInteger i
+
+    EId id@(name, t) -> do
+        funcs <- gets functions
+        case Map.lookup id funcs of
+            Just fi -> do
+                if numArgs fi == 0
+                    then do
+                        vc <- getNewVar
+                        emit $ SetVariable (Ident $ show vc)
+                            (Call (type2LlvmType t) Global name [])
+                        pure $ VIdent (Ident $ show vc) (type2LlvmType t)
+                    else pure $ VFunction name Global (type2LlvmType t)
+            Nothing -> pure $ VIdent name (type2LlvmType t)
+
+    e -> do
+        compileExp e
+        v <- getVarCount
+        pure $ VIdent (Ident $ show v) (getType e)
+
+type2LlvmType :: Type -> LLVMType
+type2LlvmType = \case
+    (TMono "Int") -> I64
+    TArr t xs -> do
+        let (t', xs') = function2LLVMType xs [type2LlvmType t]
+        Function t' xs'
+    t -> I64 --CustomType $ Ident ("\"" ++ show t ++ "\"")
+  where
+    function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
+    function2LLVMType (TArr t xs) s = function2LLVMType xs (type2LlvmType t : s)
+    function2LLVMType x s           = (type2LlvmType x, s)
+
+getType :: Exp -> LLVMType
+getType (ELit _ (LInt _)) = I64
+getType (EAdd t _ _)      = type2LlvmType t
+getType (EId (_, t))      = type2LlvmType t
+getType (EApp t _ _)      = type2LlvmType t
+getType (EAbs t _ _)      = type2LlvmType t
+getType (ELet _ e)        = getType e
+
+valueGetType :: LLVMValue -> LLVMType
+valueGetType (VInteger _)      = I64
+valueGetType (VIdent _ t)      = t
+valueGetType (VConstant s)     = Array (length s) I8
+valueGetType (VFunction _ _ t) = t
+
+-- | Partion type into types of parameters and return type.
+partitionType :: Int -- Number of parameters to apply
+              -> Type
+              -> ([Type], Type)
+partitionType = go []
+  where
+    go acc 0 t = (acc, t)
+    go acc i t = case t of
+        TArr t1 t2 -> go (snoc t1 acc) (i - 1) t2
+        _          -> error "Number of parameters and type doesn't match"
diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs
new file mode 100644
index 0000000..aa6de54
--- /dev/null
+++ b/src/Codegen/LlvmIr.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Codegen.LlvmIr (
+    LLVMType (..),
+    LLVMIr (..),
+    llvmIrToString,
+    LLVMValue (..),
+    LLVMComp (..),
+    Visibility (..),
+) where
+
+import           Data.List                 (intercalate)
+import           TypeChecker.TypeCheckerIr
+
+-- | A datatype which represents some basic LLVM types
+data LLVMType
+    = I1
+    | I8
+    | I32
+    | I64
+    | Ptr
+    | Ref LLVMType
+    | Function LLVMType [LLVMType]
+    | Array Int LLVMType
+    | CustomType Ident
+
+instance Show LLVMType where
+    show :: LLVMType -> String
+    show = \case
+        I1 -> "i1"
+        I8 -> "i8"
+        I32 -> "i32"
+        I64 -> "i64"
+        Ptr -> "ptr"
+        Ref ty -> show ty <> "*"
+        Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*"
+        Array n ty -> concat ["[", show n, " x ", show ty, "]"]
+        CustomType (Ident ty) -> ty
+
+data LLVMComp
+    = LLEq
+    | LLNe
+    | LLUgt
+    | LLUge
+    | LLUlt
+    | LLUle
+    | LLSgt
+    | LLSge
+    | LLSlt
+    | LLSle
+instance Show LLVMComp where
+    show :: LLVMComp -> String
+    show = \case
+        LLEq  -> "eq"
+        LLNe  -> "ne"
+        LLUgt -> "ugt"
+        LLUge -> "uge"
+        LLUlt -> "ult"
+        LLUle -> "ule"
+        LLSgt -> "sgt"
+        LLSge -> "sge"
+        LLSlt -> "slt"
+        LLSle -> "sle"
+
+data Visibility = Local | Global
+instance Show Visibility where
+    show :: Visibility -> String
+    show Local  = "%"
+    show Global = "@"
+
+-- | Represents a LLVM "value", as in an integer, a register variable,
+-- or a string contstant
+data LLVMValue
+    = VInteger Integer
+    | VIdent Ident LLVMType
+    | VConstant String
+    | VFunction Ident Visibility LLVMType
+
+instance Show LLVMValue where
+    show :: LLVMValue -> String
+    show v = case v of
+        VInteger i                -> show i
+        VIdent (Ident n) _        -> "%" <> n
+        VFunction (Ident n) vis _ -> show vis <> n
+        VConstant s               -> "c" <> show s
+
+type Params = [(Ident, LLVMType)]
+type Args = [(LLVMType, LLVMValue)]
+
+-- | A datatype which represents different instructions in LLVM
+data LLVMIr
+    = Define LLVMType Ident Params
+    | DefineEnd
+    | Declare LLVMType Ident Params
+    | SetVariable Ident LLVMIr
+    | Variable Ident
+    | Add LLVMType LLVMValue LLVMValue
+    | Sub LLVMType LLVMValue LLVMValue
+    | Div LLVMType LLVMValue LLVMValue
+    | Mul LLVMType LLVMValue LLVMValue
+    | Srem LLVMType LLVMValue LLVMValue
+    | Icmp LLVMComp LLVMType LLVMValue LLVMValue
+    | Br Ident
+    | BrCond LLVMValue Ident Ident
+    | Label Ident
+    | Call LLVMType Visibility Ident Args
+    | Alloca LLVMType
+    | Store LLVMType Ident LLVMType Ident
+    | Bitcast LLVMType Ident LLVMType
+    | Ret LLVMType LLVMValue
+    | Comment String
+    | UnsafeRaw String -- This should generally be avoided, and proper
+    -- instructions should be used in its place
+    deriving (Show)
+
+-- | Converts a list of LLVMIr instructions to a string
+llvmIrToString :: [LLVMIr] -> String
+llvmIrToString = go 0
+  where
+    go :: Int -> [LLVMIr] -> String
+    go _ [] = mempty
+    go i (x : xs) = do
+        let (i', n) = case x of
+                Define{}  -> (i + 1, 0)
+                DefineEnd -> (i - 1, 0)
+                _         -> (i, i)
+        insToString n x <> go i' xs
+
+-- | Converts a LLVM inststruction to a String, allowing for printing etc.
+-- The integer represents the indentation
+insToString :: Int -> LLVMIr -> String
+insToString i l =
+    replicate i '\t' <> case l of
+        (Define t (Ident i) params) ->
+            concat
+                [ "define ", show t, " @", i
+                , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params)
+                , ") {\n"
+                ]
+        DefineEnd -> "}\n"
+        (Declare _t (Ident _i) _params) -> undefined
+        (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir]
+        (Add t v1 v2) ->
+            concat
+                [ "add ", show t, " ", show v1
+                , ", ", show v2, "\n"
+                ]
+        (Sub t v1 v2) ->
+            concat
+                [ "sub ", show t, " ", show v1, ", "
+                , show v2, "\n"
+                ]
+        (Div t v1 v2) ->
+            concat
+                [ "sdiv ", show t, " ", show v1, ", "
+                , show v2, "\n"
+                ]
+        (Mul t v1 v2) ->
+            concat
+                [ "mul ", show t, " ", show v1
+                , ", ", show v2, "\n"
+                ]
+        (Srem t v1 v2) ->
+            concat
+                [ "srem ", show t, " ", show v1, ", "
+                , show v2, "\n"
+                ]
+        (Call t vis (Ident i) arg) ->
+            concat
+                [ "call ", show t, " ", show vis, i, "("
+                , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg
+                , ")\n"
+                ]
+        (Alloca t) -> unwords ["alloca", show t, "\n"]
+        (Store t1 (Ident id1) t2 (Ident id2)) ->
+            concat
+                [ "store ", show t1, " %", id1
+                , ", ", show t2 , " %", id2, "\n"
+                ]
+        (Bitcast t1 (Ident i) t2) ->
+            concat
+                [ "bitcast ", show t1, " %"
+                , i, " to ", show t2, "\n"
+                ]
+        (Icmp comp t v1 v2) ->
+            concat
+                [ "icmp ", show comp, " ", show t
+                , " ", show v1, ", ", show v2, "\n"
+                ]
+        (Ret t v) ->
+            concat
+                [ "ret ", show t, " "
+                , show v, "\n"
+                ]
+        (UnsafeRaw s) -> s
+        (Label (Ident s)) -> "\nlabel_" <> s <> ":\n"
+        (Br (Ident s)) -> "br label %label_" <> s <> "\n"
+        (BrCond val (Ident s1) (Ident s2)) ->
+            concat
+                [ "br i1 ", show val, ", ", "label %"
+                , "label_", s1, ", ", "label %", "label_", s2, "\n"
+                ]
+        (Comment s) -> "; " <> s <> "\n"
+        (Variable (Ident id)) -> "%" <> id
diff --git a/src/Compiler.hs b/src/Compiler.hs
deleted file mode 100644
index e69de29..0000000
diff --git a/src/Interpreter.hs b/src/Interpreter.hs
deleted file mode 100644
index 378c95b..0000000
--- a/src/Interpreter.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-module Interpreter where
-
-import           Control.Applicative     (Applicative)
-import           Control.Monad.Except    (Except, MonadError (throwError),
-                                          liftEither)
-import           Data.Either.Combinators (maybeToRight)
-import           Data.Map                (Map)
-import qualified Data.Map                as Map
-import           Grammar.Abs
-import           Grammar.Print           (printTree)
-
-interpret :: Program -> Except String Integer
-interpret (Program e) =
-  eval mempty e >>= \case
-    VClosure {} -> throwError "main evaluated to a function"
-    VInt i      -> pure i
-
-
-data Val = VInt Integer
-         | VClosure Cxt Ident Exp
-
-type Cxt = Map Ident Val
-
-eval :: Cxt -> Exp -> Except String Val
-eval cxt = \case
-
-
-  --  ------------ x ∈ γ
-  --  γ ⊢ x ⇓ γ(x)
-
-  EId x     ->
-    maybeToRightM
-      ("Unbound variable:" ++ printTree x)
-      $ Map.lookup x cxt
-
-  --  ---------
-  --  γ ⊢ i ⇓ i
-
-  EInt i    -> pure $ VInt i
-
-  --  γ     ⊢ e  ⇓ let δ in λx. f
-  --  γ     ⊢ e₁ ⇓ v
-  --  δ,x=v ⊢ f  ⇓ v₁
-  --  ------------------------------
-  --  γ ⊢ e e₁ ⇓ v₁
-
-  EApp e e1 ->
-    eval cxt e >>= \case
-      VInt _ -> throwError "Not a function"
-      VClosure delta x f -> do
-        v <- eval cxt e1
-        eval (Map.insert x v delta) f
-
-  --
-  --  -----------------------------
-  --  γ ⊢ λx. f ⇓ let γ in λx. f
-
-  EAbs x e  -> pure $ VClosure cxt x e
-
-
-  --  γ ⊢ e  ⇓ v
-  --  γ ⊢ e₁ ⇓ v₁
-  --  ------------------
-  --  γ ⊢ e e₁ ⇓ v + v₁
-
-  EAdd e e1 -> do
-    v <- eval cxt e
-    v1 <- eval cxt e1
-    case (v, v1) of
-      (VInt i, VInt i1) -> pure $ VInt (i + i1)
-      _                 -> throwError "Can't add a function"
-
-
-
-maybeToRightM :: MonadError l m => l -> Maybe r -> m r
-maybeToRightM err = liftEither . maybeToRight err
-
diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs
new file mode 100644
index 0000000..a617159
--- /dev/null
+++ b/src/LambdaLifter/LambdaLifter.hs
@@ -0,0 +1,192 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
+
+import           Auxiliary                 (snoc)
+import           Control.Applicative       (Applicative (liftA2))
+import           Control.Monad.State       (MonadState (get, put), State,
+                                            evalState)
+import           Data.Set                  (Set)
+import qualified Data.Set                  as Set
+import           Prelude                   hiding (exp)
+import           Renamer.Renamer
+import           TypeChecker.TypeCheckerIr
+
+
+-- | Lift lambdas and let expression into supercombinators.
+-- Three phases:
+-- @freeVars@ annotatss 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 xs) e)
+                        | Bind n xs e <- ds
+                        ]
+
+freeVarsExp :: Set Id -> Exp -> AnnExp
+freeVarsExp localVars = \case
+    EId  n  | Set.member n localVars -> (Set.singleton n, AId n)
+            | otherwise              -> (mempty, AId n)
+
+    ELit _ (LInt i) -> (mempty, AInt i)
+
+    EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2')
+      where
+        e1' = freeVarsExp localVars e1
+        e2' = freeVarsExp localVars e2
+
+    EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2')
+      where
+        e1' = freeVarsExp localVars e1
+        e2' = freeVarsExp localVars e2
+
+    EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e')
+      where
+        e' = freeVarsExp (Set.insert par localVars) e
+
+    -- Sum free variables present in bind and the expression
+    ELet (Bind name parms rhs) e  -> (Set.union binders_frees e_free, ALet new_bind e')
+      where
+        binders_frees = Set.delete name $ freeVarsOf rhs'
+        e_free        = Set.delete name $ freeVarsOf e'
+
+        rhs'     = freeVarsExp e_localVars rhs
+        new_bind = ABind name parms rhs'
+
+        e'          = freeVarsExp e_localVars e
+        e_localVars = Set.insert name localVars
+
+
+freeVarsOf :: AnnExp -> Set Id
+freeVarsOf = fst
+
+-- AST annotated with free variables
+type AnnProgram = [(Id, [Id], AnnExp)]
+
+type AnnExp = (Set Id, AnnExp')
+
+data ABind = ABind Id [Id] AnnExp deriving Show
+
+data AnnExp' = AId  Id
+             | AInt Integer
+             | ALet ABind AnnExp
+             | AApp Type    AnnExp  AnnExp
+             | AAdd Type    AnnExp  AnnExp
+             | AAbs Type    Id      AnnExp
+             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], AnnExp) -> 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 :: AnnExp -> (AnnExp, [Id])
+flattenLambdasAnn ae = go (ae, [])
+  where
+    go :: (AnnExp, [Id]) -> (AnnExp, [Id])
+    go ((free, e), acc) =
+        case e of
+            AAbs _ par (free1, e1) ->
+                go ((Set.delete par free1, e1), snoc par acc)
+            _ -> ((free, e), acc)
+
+abstractExp :: AnnExp -> State Int Exp
+abstractExp (free, exp) = case exp of
+    AId  n       -> pure $ EId  n
+    AInt i       -> pure $ ELit (TMono "Int") (LInt i)
+    AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2)
+    AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2)
+    ALet b e     -> 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 :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp
+        skipLambdas f (free, ae) = case ae of
+            AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1
+            _              -> f (free, ae)
+
+    -- Lift lambda into let and bind free variables
+    AAbs t parm e -> do
+        i <- nextNumber
+        rhs <- abstractExp e
+
+        let sc_name = Ident ("sc_" ++ show i)
+            sc      = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t)
+
+        pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList
+      where
+        freeList = Set.toList free
+        parms    = snoc parm freeList
+
+
+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 :: Exp -> ([Bind], Exp)
+collectScsExp = \case
+    EId  n -> ([], EId n)
+    ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i))
+
+    EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2')
+      where
+        (scs1, e1') = collectScsExp e1
+        (scs2, e2') = collectScsExp e2
+
+    EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2')
+      where
+        (scs1, e1') = collectScsExp e1
+        (scs2, e2') = collectScsExp e2
+
+    EAbs t par e -> (scs, EAbs t par e')
+      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 ++ e_scs, ELet bind e')
+                                    else (bind : rhs_scs ++ e_scs, e')
+      where
+        bind            = Bind name parms rhs'
+        (rhs_scs, rhs') = collectScsExp rhs
+        (e_scs, e')     = collectScsExp e
+
+
+-- @\x.\y.\z. e → (e, [x,y,z])@
+flattenLambdas :: Exp -> (Exp, [Id])
+flattenLambdas = go . (, [])
+  where
+    go (e, acc) = case e of
+                      EAbs _ par e1 -> go (e1, snoc par acc)
+                      _             -> (e, acc)
+
diff --git a/src/Main.hs b/src/Main.hs
index 58811fe..3a7bde4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,42 +2,81 @@
 
 module Main where
 
-import           Grammar.Par        (myLexer, pProgram)
--- import           TypeChecker.TypeChecker (typecheck)
+import           Codegen.Codegen           (compile)
+import           GHC.IO.Handle.Text        (hPutStrLn)
+import           Grammar.ErrM              (Err)
+import           Grammar.Par               (myLexer, pProgram)
+import           Grammar.Print             (printTree)
 
-import           Grammar.Print      (printTree)
-import           Renamer.RenamerM   (rename)
-import           System.Environment (getArgs)
-import           System.Exit        (exitFailure, exitSuccess)
-import           TypeChecker.AlgoW  (typecheck)
+import           LambdaLifter.LambdaLifter (lambdaLift)
+import           Renamer.Renamer           (rename)
+import           System.Environment        (getArgs)
+import           System.Exit               (exitFailure, exitSuccess)
+import           System.IO                 (stderr)
+import           TypeChecker.TypeChecker   (typecheck)
 
 main :: IO ()
-main = getArgs >>= \case
+main =
+    getArgs >>= \case
         [] -> print "Required file path missing"
-        (x : _) -> do
-            file <- readFile x
-            case pProgram (myLexer file) of
-                Left err -> do
-                    putStrLn "SYNTAX ERROR"
-                    putStrLn err
-                    exitFailure
-                Right prg -> do
-                    putStrLn ""
-                    putStrLn " ----- PARSER ----- "
-                    putStrLn ""
-                    putStrLn . printTree $ prg
-                    case typecheck (rename prg) of
-                        Left err -> do
-                            putStrLn "TYPECHECK ERROR"
-                            print err
-                            exitFailure
-                        Right prg -> do
-                            putStrLn ""
-                            putStrLn " ----- RAW ----- "
-                            putStrLn ""
-                            print prg
-                            putStrLn ""
-                            putStrLn " ----- TYPECHECKER ----- "
-                            putStrLn ""
-                            putStrLn $ printTree prg
-                            exitSuccess
+        (s : _) -> main' s
+
+main' :: String -> IO ()
+main' s = do
+    file <- readFile s
+
+    printToErr "-- Parse Tree -- "
+    parsed <- fromSyntaxErr . pProgram $ myLexer file
+    printToErr $ printTree parsed
+
+    printToErr "\n-- Renamer --"
+    let renamed = rename parsed
+    printToErr $ printTree renamed
+
+    printToErr "\n-- TypeChecker --"
+    typechecked <- fromTypeCheckerErr $ typecheck renamed
+    printToErr $ printTree typechecked
+
+    printToErr "\n-- Lambda Lifter --"
+    let lifted = lambdaLift typechecked
+    printToErr $ printTree lifted
+
+    printToErr "\n -- Printing compiler output to stdout --"
+    compiled <- fromCompilerErr $ compile lifted
+    putStrLn compiled
+    writeFile "llvm.ll" compiled
+
+    exitSuccess
+
+printToErr :: String -> IO ()
+printToErr = hPutStrLn stderr
+
+fromCompilerErr :: Err a -> IO a
+fromCompilerErr =
+    either
+        ( \err -> do
+            putStrLn "\nCOMPILER ERROR"
+            putStrLn err
+            exitFailure
+        )
+        pure
+
+fromSyntaxErr :: Err a -> IO a
+fromSyntaxErr =
+    either
+        ( \err -> do
+            putStrLn "\nSYNTAX ERROR"
+            putStrLn err
+            exitFailure
+        )
+        pure
+
+fromTypeCheckerErr :: Err a -> IO a
+fromTypeCheckerErr =
+    either
+        ( \err -> do
+            putStrLn "\nTYPECHECKER ERROR"
+            putStrLn err
+            exitFailure
+        )
+        pure
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index c8b857e..1ea892c 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -1,101 +1,91 @@
-{-# LANGUAGE LambdaCase, OverloadedRecordDot, OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
-module Renamer.Renamer (rename) where
+module Renamer.Renamer where
 
-import Renamer.RenamerIr
-import Control.Monad.State
-import Control.Monad.Except
-import Control.Monad.Reader
-import Data.Functor.Identity (Identity, runIdentity)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Map (Map)
-import qualified Data.Map as M
+import           Auxiliary           (mapAccumM)
+import           Control.Monad.State (MonadState, State, evalState, gets,
+                                      modify)
+import           Data.List           (foldl')
+import           Data.Map            (Map)
+import qualified Data.Map            as Map
+import           Data.Maybe          (fromMaybe)
+import           Data.Tuple.Extra    (dupe)
+import           Grammar.Abs
 
-import Renamer.RenamerIr
-import qualified Grammar.Abs as Old
 
-type Rename = StateT Ctx (ExceptT Error Identity)
+-- | Rename all variables and local binds
+rename :: Program -> Program
+rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0
+  where
+    -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
+    initNames = Map.fromList $ foldl' saveIfBind [] bs
+    saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc
+    saveIfBind acc _                           = acc
+    renameSc :: Names -> Def -> Rn Def
+    renameSc old_names (DBind (Bind name t _ parms rhs)) = do
+        (new_names, parms') <- newNames old_names parms
+        rhs'                <- snd <$> renameExp new_names rhs
+        pure . DBind $ Bind name t name parms' rhs'
+    renameSc _ def = pure def
 
-data Ctx = Ctx { count :: Integer
-               , sig :: Set Ident
-               , env :: Map Ident Integer}
+--
 
-run :: Rename a -> Either Error a
-run = runIdentity . runExceptT . flip evalStateT initCtx
+-- | Rename monad. State holds the number of renamed names.
+newtype Rn a = Rn { runRn :: State Int a }
+  deriving (Functor, Applicative, Monad, MonadState Int)
 
-initCtx :: Ctx
-initCtx = Ctx { count = 0
-              , sig = mempty
-              , env = mempty }
+-- | Maps old to new name
+type Names = Map Ident Ident
 
-rename :: Old.Program -> Either Error RProgram
-rename = run . renamePrg
+renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
+renameLocalBind old_names (Bind name t _ parms rhs) = do
+    (new_names, name')   <- newName old_names name
+    (new_names', parms') <- newNames new_names parms
+    (new_names'', rhs')  <- renameExp new_names' rhs
+    pure (new_names'', Bind name' t name' parms' rhs')
 
-renamePrg :: Old.Program -> Rename RProgram
-renamePrg (Old.Program xs) = do
-    xs' <- mapM renameBind xs
-    return $ RProgram xs'
+renameExp :: Names -> Exp -> Rn (Names, Exp)
+renameExp old_names = \case
+    EId  n     -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
 
-renameBind :: Old.Bind -> Rename RBind
-renameBind (Old.Bind n t i args e) = do
-    insertSig i
-    e' <- renameExp (makeLambda (reverse args) e)
-    return $ RBind i e'
-  where 
-    makeLambda :: [Ident] -> Old.Exp -> Old.Exp
-    makeLambda [] e = e
-    makeLambda (x:xs) e = makeLambda xs (Old.EAbs x e)
+    ELit (LInt i1)    -> pure (old_names, ELit (LInt i1))
 
-renameExp :: Old.Exp -> Rename RExp
-renameExp = \case
+    EApp e1 e2 -> do
+        (env1, e1') <- renameExp old_names e1
+        (env2, e2') <- renameExp old_names e2
+        pure (Map.union env1 env2, EApp e1' e2')
 
-    Old.EId i -> do
-        st <- get
-        case M.lookup i st.env of
-            Just n -> return $ RId i
-            Nothing -> case S.member i st.sig of
-                         True -> return $ RId i
-                         False -> throwError $ UnboundVar (show i)
+    EAdd e1 e2 -> do
+        (env1, e1') <- renameExp old_names e1
+        (env2, e2') <- renameExp old_names e2
+        pure (Map.union env1 env2, EAdd e1' e2')
 
-    Old.EInt c -> return $ RInt c
+    ELet i e1 e2  -> do
+        (new_names, e1')   <- renameExp old_names e1
+        (new_names', e2') <- renameExp new_names e2
+        pure (new_names', ELet i e1' e2')
 
-    Old.EAnn e t -> flip RAnn t <$> renameExp e
+    EAbs par e  -> do
+        (new_names, par') <- newName old_names par
+        (new_names', e')  <- renameExp new_names e
+        pure (new_names', EAbs par' e')
 
-    Old.EApp e1 e2 -> RApp <$> renameExp e1 <*> renameExp e2
+    EAnn e t -> do
+        (new_names, e') <- renameExp old_names e
+        pure (new_names, EAnn e' t)
 
-    Old.EAdd e1 e2 -> RAdd <$> renameExp e1 <*> renameExp e2
+    ECase _ _ -> error "ECase NOT IMPLEMENTED YET"
 
-    -- Convert let-expressions to lambdas
-    Old.ELet i e1 e2 -> renameExp (Old.EApp (Old.EAbs i e2) e1)
+-- | Create a new name and add it to name environment.
+newName :: Names -> Ident -> Rn (Names, Ident)
+newName env old_name = do
+    new_name <- makeName old_name
+    pure (Map.insert old_name new_name env, new_name)
 
-    Old.EAbs i e -> do
-        n <- cnt
-        ctx <- get
-        insertEnv i n
-        re <- renameExp e
-        return $ RAbs n i re
+-- | Create multiple names and add them to the name environment
+newNames :: Names -> [Ident] -> Rn (Names, [Ident])
+newNames = mapAccumM newName
 
--- | Get current count and increase it by one
-cnt :: Rename Integer
-cnt = do
-    st <- get
-    put (Ctx { count = succ st.count
-             , sig = st.sig
-             , env = st.env })
-    return st.count
-        
-insertEnv :: Ident -> Integer -> Rename ()
-insertEnv i n = do
-    c <- get
-    put ( Ctx { env = M.insert i n c.env , sig = c.sig , count = c.count} )
-
-insertSig :: Ident -> Rename ()
-insertSig i = do
-    c <- get
-    put ( Ctx { sig = S.insert i c.sig , env = c.env , count = c.count } )
-
-data Error = UnboundVar String
-
-instance Show Error where
-    show (UnboundVar str) = "Unbound variable: " <> str
+-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
+makeName :: Ident -> Rn Ident
+makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ
diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs
deleted file mode 100644
index 77e2f1f..0000000
--- a/src/Renamer/RenamerIr.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Renamer.RenamerIr (
-    RExp (..),
-    RBind (..),
-    RProgram (..),
-    Ident (..),
-    Type (..),
-) where
-
-import Grammar.Abs (
-    Bind (..),
-    Ident (..),
-    Program (..),
-    Type (..),
- )
-import Grammar.Print
-
-data RProgram = RProgram [RBind]
-    deriving (Eq, Show, Read, Ord)
-
-data RBind = RBind Ident RExp
-    deriving (Eq, Show, Read, Ord)
-
-data RExp
-    = RAnn RExp Type
-    | RId Ident
-    | RInt Integer
-    | RApp RExp RExp
-    | RAdd RExp RExp
-    | RAbs Integer Ident RExp
-    deriving (Eq, Ord, Show, Read)
diff --git a/src/Renamer/RenamerM.hs b/src/Renamer/RenamerM.hs
deleted file mode 100644
index 5fb1fa2..0000000
--- a/src/Renamer/RenamerM.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# LANGUAGE LambdaCase                 #-}
-
-module Renamer.RenamerM  where
-
-import           Auxiliary           (mapAccumM)
-import           Control.Monad.State (MonadState, State, evalState, gets,
-                                      modify)
-import           Data.Map            (Map)
-import qualified Data.Map            as Map
-import           Data.Maybe          (fromMaybe)
-import           Data.Tuple.Extra    (dupe)
-import           Grammar.Abs
-
-
--- | Rename all variables and local binds
-rename :: Program -> Program
-rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0
-  where
-    initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
-    renameSc :: Names -> Bind -> Rn Bind
-    renameSc old_names (Bind name t _ parms rhs) = do
-        (new_names, parms') <- newNames old_names parms
-        rhs'                <- snd <$> renameExp new_names rhs
-        pure $ Bind name t name parms' rhs'
-
-
--- | Rename monad. State holds the number of renamed names.
-newtype Rn a = Rn { runRn :: State Int a }
-  deriving (Functor, Applicative, Monad, MonadState Int)
-
--- | Maps old to new name
-type Names = Map Ident Ident
-
-renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
-renameLocalBind old_names (Bind name t _ parms rhs) = do
-    (new_names, name')   <- newName old_names name
-    (new_names', parms') <- newNames new_names parms
-    (new_names'', rhs')  <- renameExp new_names' rhs
-    pure (new_names'', Bind name' t name' parms' rhs')
-
-renameExp :: Names -> Exp -> Rn (Names, Exp)
-renameExp old_names = \case
-    EId  n     -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
-
-    EInt i1    -> pure (old_names, EInt i1)
-
-    EApp e1 e2 -> do
-        (env1, e1') <- renameExp old_names e1
-        (env2, e2') <- renameExp old_names e2
-        pure (Map.union env1 env2, EApp e1' e2')
-
-    EAdd e1 e2 -> do
-        (env1, e1') <- renameExp old_names e1
-        (env2, e2') <- renameExp old_names e2
-        pure (Map.union env1 env2, EAdd e1' e2')
-
-    ELet i e1 e2  -> do
-        (new_names, e1')   <- renameExp old_names e1
-        (new_names', e2') <- renameExp new_names e2
-        pure (new_names', ELet i e1' e2')
-
-    EAbs par e  -> do
-        (new_names, par') <- newName old_names par
-        (new_names', e')  <- renameExp new_names e
-        pure (new_names', EAbs par' e')
-
-    EAnn e t -> do
-        (new_names, e') <- renameExp old_names e
-        pure (new_names, EAnn e' t)
-
--- | Create a new name and add it to name environment.
-newName :: Names -> Ident -> Rn (Names, Ident)
-newName env old_name = do
-    new_name <- makeName old_name
-    pure (Map.insert old_name new_name env, new_name)
-
--- | Create multiple names and add them to the name environment
-newNames :: Names -> [Ident] -> Rn (Names, [Ident])
-newNames = mapAccumM newName
-
--- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
-makeName :: Ident -> Rn Ident
-makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ
diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs
deleted file mode 100644
index de931d1..0000000
--- a/src/TypeChecker/AlgoW.hs
+++ /dev/null
@@ -1,238 +0,0 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Use traverse_" #-}
-
-module TypeChecker.AlgoW  where
-
-import           Control.Monad.Except
-import           Control.Monad.Reader
-import           Control.Monad.State
-import           Data.Bifunctor        (bimap, second)
-import           Data.Functor.Identity (Identity, runIdentity)
-import           Data.List             (foldl', intersect)
-import           Data.Map              (Map)
-import qualified Data.Map              as M
-import           Data.Maybe            (fromMaybe)
-import           Data.Set              (Set)
-import qualified Data.Set              as S
-
-import           Grammar.Abs
-import           Grammar.Print         (Print, printTree)
-import qualified TypeChecker.HMIr      as T
-
--- | A data type representing type variables
-data Poly = Forall [Ident] Type
-    deriving Show
-
-newtype Ctx = Ctx { vars  :: Map Ident Poly }
-
-data Env = Env { count :: Int
-               , sigs  :: Map Ident Type
-               }
-
-type Error = String
-type Subst = Map Ident Type
-
-type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
-
-initCtx = Ctx mempty
-initEnv = Env 0 mempty
-
-runPretty :: Print a => Infer a -> Either Error String
-runPretty = fmap printTree . run
-
-run :: Infer a -> Either Error a
-run = runC initEnv initCtx
-
-runC :: Env -> Ctx -> Infer a -> Either Error a
-runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
-
-typecheck :: Program -> Either Error T.Program
-typecheck = run . checkPrg
-
-checkPrg :: Program -> Infer T.Program
-checkPrg (Program bs) = do
-    traverse (\(Bind n t _ _ _) -> insertSig n t) bs
-    bs' <- mapM checkBind bs
-    return $ T.Program bs'
-
-checkBind :: Bind -> Infer T.Bind
-checkBind (Bind n t _ args e) = do
-    (t', e') <- inferExp $ makeLambda e (reverse args)
-    s <- unify t t'
-    let t'' = apply s t
-    return $ T.Bind (t'',n) [] e'
-  where
-    makeLambda :: Exp -> [Ident] -> Exp
-    makeLambda = foldl (flip EAbs)
-
-inferExp :: Exp -> Infer (Type, T.Exp)
-inferExp e = do
-    (s, t, e') <- w e
-    let subbed = apply s t
-    return (subbed, replace subbed e')
-
-replace :: Type -> T.Exp -> T.Exp
-replace t = \case
-    T.EInt t' e -> T.EInt t e
-    T.EId t' i -> T.EId t i
-    T.EAbs t' name e -> T.EAbs t name e
-    T.EApp t' e1 e2 -> T.EApp t e1 e2
-    T.EAdd t' e1 e2 -> T.EAdd t e1 e2
-    T.ELet t' name e1 e2 -> T.ELet t name e1 e2
-
-w :: Exp -> Infer (Subst, Type, T.Exp)
-w = \case
-    EAnn e t -> do
-        (s1, t', e') <- w e
-        applySt s1 $ do
-            s2 <- unify (apply s1 t) t'
-            return (s2 `compose` s1, t, e')
-    EInt n -> return (nullSubst, TMono "Int", T.EInt (TMono "Int") n)
-    EId i -> do
-        var <- asks vars
-        case M.lookup i var of
-          Nothing -> throwError $ "Unbound variable: " ++ show i
-          Just t  ->  inst t >>= \x -> return (nullSubst, x, T.EId x i)
-    EAbs name e -> do
-        fr <- fresh
-        withBinding name (Forall [] fr) $ do
-            (s1, t', e') <- w e
-            let newArr = TArr (apply s1 fr) t'
-            return (s1, newArr, T.EAbs newArr name e')
-    EAdd e0 e1 -> do
-        (s1, t0, e0') <- w e0
-        applySt s1 $ do
-            (s2, t1, e1') <- w e1
-            applySt s2 $ do
-                s3 <- unify (subst s2 t0) (TMono "Int")
-                s4 <- unify (subst s3 t1) (TMono "Int")
-                return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
-    EApp e0 e1 -> do
-        fr <- fresh
-        (s1, t0, e0') <- w e0
-        applySt s1 $ do
-            (s2, t1, e1') <- w e1
-            applySt s2 $ do
-                s3 <- unify (subst s2 t0) (TArr t1 fr)
-                let t = apply s3 fr
-                return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1')
-    ELet name e0 e1 -> do
-        (s1, t1, e0') <- w e0
-        env <- asks vars
-        let t' = generalize (apply s1 env) t1
-        withBinding name t' $ do
-            (s2, t2, e1') <- w e1
-            return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' )
-
--- | Unify two types producing a new substitution (constraint)
-unify :: Type -> Type -> Infer Subst
-unify t0 t1 = case (t0, t1) of
-    (TArr a b, TArr c d) -> do
-        s1 <- unify a c
-        s2 <- unify (subst s1 b) (subst s1 c)
-        return $ s1 `compose` s2
-    (TPol a, b) -> occurs a b
-    (a, TPol b) -> occurs b a
-    (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
-    (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
-
--- | Check if a type is contained in another type.
--- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
-occurs :: Ident -> Type -> Infer Subst
-occurs i (TPol a) = return nullSubst
-occurs i t = if S.member i (free t)
-                then throwError "Occurs check failed"
-                else return $ M.singleton i t
-
--- | Generalize a type over all free variables in the substitution set
-generalize :: Map Ident Poly -> Type -> Poly
-generalize env t = Forall (S.toList $ free t S.\\ free env) t
-
--- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones.
-inst :: Poly -> Infer Type
-inst (Forall xs t) = do
-    xs' <- mapM (const fresh) xs
-    let s = M.fromList $ zip xs xs'
-    return $ apply s t
-
-compose :: Subst -> Subst -> Subst
-compose m1 m2 = M.map (subst m1) m2 `M.union` m1
-
--- | A class representing free variables functions
-class FreeVars t where
-  -- | Get all free variables from t
-  free :: t -> Set Ident
-  -- | Apply a substitution to t
-  apply :: Subst -> t -> t
-
-instance FreeVars Type where
-  free :: Type -> Set Ident
-  free (TPol a)   = S.singleton a
-  free (TMono _)  = mempty
-  free (TArr a b) = free a `S.union` free b
-  apply :: Subst -> Type -> Type
-  apply sub t = do
-    case t of
-        TMono a -> TMono a
-        TPol a -> case M.lookup a sub of
-                   Nothing -> TPol a
-                   Just t  -> t
-        TArr a b -> TArr (apply sub a) (apply sub b)
-
-instance FreeVars Poly where
-  free :: Poly -> Set Ident
-  free (Forall xs t) = free t S.\\ S.fromList xs
-  apply :: Subst -> Poly -> Poly
-  apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
-
-instance FreeVars (Map Ident Poly) where
-  free :: Map Ident Poly -> Set Ident
-  free m = foldl' S.union S.empty (map free $ M.elems m)
-  apply :: Subst -> Map Ident Poly -> Map Ident Poly
-  apply s = M.map (apply s)
-
-applySt :: Subst -> Infer a -> Infer a
-applySt s = local (\st -> st { vars = apply s (vars st) })
-
--- | Represents the empty substition set
-nullSubst :: Subst
-nullSubst = M.empty
-
--- | Substitute type variables with their mappings from the substitution set.
-subst :: Subst -> Type -> Type
-subst m t = do
-    case t of
-        TPol a   -> fromMaybe t (M.lookup a m)
-        TMono a  -> TMono a
-        TArr a b -> TArr (subst m a) (subst m b)
-
--- | Generate a new fresh variable and increment the state counter
-fresh :: Infer Type
-fresh = do
-    n <- gets count
-    modify (\st -> st { count = n + 1 })
-    return . TPol . Ident $ "t" ++ show n
-
--- | Run the monadic action with an additional binding
-withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
-withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
-
--- | Insert a function signature into the environment
-insertSig :: Ident -> Type -> Infer ()
-insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
-
--- | Lookup a variable in the context
-lookupVar :: Ident -> Infer Poly
-lookupVar i = do
-    m <- asks vars
-    case M.lookup i m of
-        Just t  -> return t
-        Nothing -> throwError $ "Unbound variable: " ++ show i
-
-lett = let (Right (t,e)) = run $ inferExp $ ELet "x" (EAdd (EInt 5) (EInt 5)) (EAdd (EId "x") (EId "x"))
-        in t == TMono "Int"
-
-letty = let (Right (t,e)) = run $ inferExp $ ELet "f" (EAbs "x" (EId "x")) (EApp (EId "f") (EInt 3))
-         in e
diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs
deleted file mode 100644
index 7b33cbe..0000000
--- a/src/TypeChecker/HM.hs
+++ /dev/null
@@ -1,181 +0,0 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Use traverse_" #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module TypeChecker.HM  where
-
-import           Control.Monad.Except
-import           Control.Monad.State
-import           Data.Bifunctor        (bimap, second)
-import           Data.Functor.Identity (Identity, runIdentity)
-import           Data.Map              (Map)
-import qualified Data.Map              as M
-
-import           Grammar.Abs
-import           Grammar.Print
-import qualified TypeChecker.HMIr      as T
-
-type Infer = StateT Ctx (ExceptT String Identity)
-type Error = String
-
-data Ctx = Ctx { constr :: Map Type Type
-               , vars   :: Map Ident Type
-               , sigs   :: Map Ident Type
-               , frsh   :: Char }
-    deriving Show
-
-runC :: Ctx -> Infer a -> Either String (a, Ctx)
-runC c = runIdentity . runExceptT . flip runStateT c
-
-run :: Infer a -> Either String a
-run = runIdentity . runExceptT . flip evalStateT initC
-
-initC :: Ctx
-initC = Ctx M.empty M.empty M.empty 'a'
-
-typecheck :: Program -> Either Error T.Program
-typecheck = run . inferPrg
-
-inferPrg :: Program -> Infer T.Program
-inferPrg (Program bs) = do
-    traverse (\(Bind n t _ _ _) -> insertSig n t) bs
-    bs' <- mapM inferBind bs
-    return $ T.Program bs'
-
-inferBind :: Bind -> Infer T.Bind
-inferBind (Bind i t _ params rhs) = do
-    (t',e') <- inferExp (makeLambda rhs (reverse params))
-    when (t /= t') (throwError . unwords $ [ "Signature of function"
-                                           , show i
-                                           , "with type:"
-                                           , show t
-                                           , "does not match inferred type"
-                                           , show t'
-                                           , "of expression:"
-                                           , show e'])
-    return $ T.Bind (t,i) [] e'
-
-makeLambda :: Exp -> [Ident] -> Exp
-makeLambda = foldl (flip EAbs)
-
-inferExp :: Exp -> Infer (Type, T.Exp)
-inferExp e = do
-    (t, e') <- inferExp' e
-    t'' <- solveConstraints t
-    return (t'', replaceType t'' e')
-
-  where
-    inferExp' :: Exp -> Infer (Type, T.Exp)
-    inferExp' = \case
-        EAnn e t -> do
-            (t',e') <- inferExp' e
-            t'' <- solveConstraints t'
-            when (t'' /= t) (throwError "Annotated type and inferred type don't match")
-            return (t', e')
-        EInt i -> return (int, T.EInt int i)
-        EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
-        EAdd e1 e2 -> do
-            insertSig "+" (TArr int (TArr int int))
-            inferExp' (EApp (EApp (EId "+") e1) e2)
-        EApp e1 e2 -> do
-            (t1, e1') <- inferExp' e1
-            (t2, e2') <- inferExp' e2
-            fr <- fresh
-            addConstraint t1 (TArr t2 fr)
-            return (fr, T.EApp fr e1' e2')
-        EAbs name e -> do
-            fr <- fresh
-            insertVar name fr
-            (ret_t,e') <- inferExp' e
-            t <- solveConstraints (TArr fr ret_t)
-            return (t, T.EAbs t name e')
-        ELet name e1 e2 -> error "Let expression not implemented yet"
-
-replaceType :: Type -> T.Exp -> T.Exp
-replaceType t = \case
-        T.EInt _ i -> T.EInt t i
-        T.EId _ i -> T.EId t i
-        T.EAdd _ e1 e2 -> T.EAdd t e1 e2
-        T.EApp _ e1 e2 -> T.EApp t e1 e2
-        T.EAbs _ name e -> T.EAbs t name e
-        T.ELet _ name e1 e2 -> T.ELet t name e1 e2
-
-isInt :: Type -> Bool
-isInt (TMono "Int") = True
-isInt _             = False
-
-lookupVar :: Ident -> Infer Type
-lookupVar i = do
-    st <- get
-    case M.lookup i (vars st) of
-      Just t -> return t
-      Nothing -> case M.lookup i (sigs st) of
-        Just t  -> return t
-        Nothing -> throwError $ "Unbound variable or function" ++ printTree i
-
-insertVar :: Ident -> Type -> Infer ()
-insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } )
-
-insertSig :: Ident -> Type -> Infer ()
-insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } )
-
--- | Generate a new fresh variable and increment the state
-fresh :: Infer Type
-fresh = do
-    chr <- gets frsh
-    modify (\st -> st { frsh = succ chr })
-    return $ TPol (Ident [chr])
-
--- | Adds a constraint to the constraint set.
--- i.e: a = int -> b
---      b = int
--- thus when solving constraints it must be the case that
---      a = int -> int
-addConstraint :: Type -> Type -> Infer ()
-addConstraint t1 t2 = do
-    modify (\st -> st { constr = M.insert t1 t2 (constr st) })
-
--- | Given a type, solve the constraints and figure out the type that should be assigned to it.
-solveConstraints :: Type -> Infer Type
-solveConstraints t = do
-    c <- gets constr
-    v <- gets vars
-    xs <- solveAll (M.toList c)
-    modify (\st -> st { constr = M.fromList xs })
-    return $ subst t xs
-
--- | Substitute
-subst :: Type -> [(Type, Type)] -> Type
-subst t []                = t
-subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs
-subst t (x:xs)            = subst (replace x t) xs
-
--- | Given a set of constraints run the replacement on all of them, producing a new set of
---  replacements.
---  https://youtu.be/trmq3wYcUxU - good video for explanation
-solveAll :: [(Type, Type)] -> Infer [(Type, Type)]
-solveAll [] = return []
-solveAll (x:xs) = case x of
-    (TArr t1 t2, TArr t3 t4) -> solveAll $ (t1,t3) : (t2,t4) : xs
-    (TArr t1 t2, b)          -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs
-    (a, TArr t1 t2)          -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs
-    (TMono a, TPol b)        -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs
-    (TPol a, TMono b)        -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs
-    (TPol a, TPol b)         -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs
-    (TMono a, TMono b)       -> if a == b then solveAll xs else throwError "Can't unify types"
-
-solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)]
-solve x = map (both (replace x))
-
--- | Given a constraint (type, type) and a type, if the constraint matches the input
---   replace with the constrained type
-replace :: (Type, Type) -> Type -> Type
-replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2)
-replace (a,b) c        = if a==c then b else c
-
-both :: (a -> b) -> (a,a) -> (b,b)
-both f = bimap f f
-
-int = TMono "Int"
diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs
deleted file mode 100644
index 0a6085c..0000000
--- a/src/TypeChecker/HMIr.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module TypeChecker.HMIr
-  ( module Grammar.Abs
-  , module TypeChecker.HMIr
-  ) where
-
-import           Grammar.Abs   (Ident (..), Type (..))
-import           Grammar.Print
-import           Prelude
-import qualified Prelude       as C (Eq, Ord, Read, Show)
-
-newtype Program = Program [Bind]
-  deriving (C.Eq, C.Ord, C.Show, C.Read)
-
-data Exp
-    = EId  Type Ident
-    | EInt Type Integer
-    | ELet Type Ident Exp Exp
-    | EApp Type Exp Exp
-    | EAdd Type Exp Exp
-    | EAbs Type Ident Exp
-      deriving (C.Eq, C.Ord, C.Read)
-
-instance Show Exp where
-    show (EId t (Ident i))    = i ++ " : " ++ show t
-    show (EInt _ i)           = show i
-    show (ELet t i e1 e2)     = "let " ++ show t ++ " = " ++ show e1 ++ " in " ++ show e2
-    show (EApp t e1 e2)       = show e1 ++ " " ++ show e2 ++ " : " ++ show t
-    show (EAdd _ e1 e2)       = show e1 ++ " + " ++ show e2
-    show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t
-
-type Id = (Type, Ident)
-
-data Bind = Bind Id [Id] Exp
-    deriving (C.Eq, C.Ord, C.Show, C.Read)
-
-instance Print Program where
-    prt i (Program sc) = prPrec i 0 $ prt 0 sc
-
-instance Print Bind where
-    prt i (Bind name@(n, _) parms rhs) = prPrec i 0 $ concatD
-        [ prtId 0 name
-        , doc $ showString ";"
-        , prt 0 n
-        , prtIdPs 0 parms
-        , doc $ showString "="
-        , prt 0 rhs
-        ]
-
-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 (prtIdP i)
-
-prtId :: Int -> Id -> Doc
-prtId i (name, t) = prPrec i 0 $ concatD
-    [ prt 0 name
-    , doc $ showString ":"
-    , prt 0 t
-    ]
-
-prtIdP :: Int -> Id -> Doc
-prtIdP i (name, t) = prPrec i 0 $ concatD
-    [ doc $ showString "("
-    , prt 0 name
-    , doc $ showString ":"
-    , prt 0 t
-    , doc $ showString ")"
-    ]
-
-
-instance Print Exp where
-  prt i = \case
-    EId _ n       -> prPrec i 3 $ concatD [prt 0 n]
-    EInt _ i1      -> prPrec i 3 $ concatD [prt 0 i1]
-    ELet _ name e1 e2    -> prPrec i 3 $ concatD
-                        [ doc $ showString "let"
-                        , prt 0 name
-                        , prt 0 e1
-                        , doc $ showString "in"
-                        , prt 0 e2
-                        ]
-    EApp t e1 e2 -> prPrec i 2 $ concatD
-                        [ doc $ showString "@"
-                        , prt 0 t
-                        , prt 2 e1
-                        , prt 3 e2
-                        ]
-    EAdd t e1 e2 -> prPrec i 1 $ concatD
-                        [ doc $ showString "@"
-                        , prt 0 t
-                        , prt 1 e1
-                        , doc $ showString "+"
-                        , prt 2 e2
-                        ]
-    EAbs t n e  -> prPrec i 0 $ concatD
-                        [ doc $ showString "@"
-                        , prt 0 t
-                        , doc $ showString "\\"
-                        , prt 0 n
-                        , doc $ showString "."
-                        , prt 0 e
-                        ]
-
-
-
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 99a1e17..0d9ace9 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,153 +1,250 @@
--- {-# LANGUAGE LambdaCase          #-}
--- {-# LANGUAGE OverloadedRecordDot #-}
--- {-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use traverse_" #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module TypeChecker.TypeChecker where
 
--- import           Control.Monad             (void)
--- import           Control.Monad.Except      (ExceptT, runExceptT, throwError)
--- import           Control.Monad.State       (StateT)
--- import qualified Control.Monad.State       as St
--- import           Data.Functor.Identity     (Identity, runIdentity)
--- import           Data.Map                  (Map)
--- import qualified Data.Map                  as M
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Data.Functor.Identity     (Identity, runIdentity)
+import           Data.List                 (foldl')
+import           Data.Map                  (Map)
+import qualified Data.Map                  as M
+import           Data.Set                  (Set)
+import qualified Data.Set                  as S
 
--- import           TypeChecker.TypeCheckerIr
+import           Grammar.Abs
+import           Grammar.Print             (printTree)
+import qualified TypeChecker.TypeCheckerIr as T
 
--- data Ctx = Ctx
---     { vars      :: Map Integer Type
---     , sigs      :: Map Ident Type
---     , nextFresh :: Int
---     }
---     deriving (Show)
+-- | A data type representing type variables
+data Poly = Forall [Ident] Type
+    deriving Show
 
--- -- Perhaps swap over to reader monad instead for vars and sigs.
--- type Infer = StateT Ctx (ExceptT Error Identity)
+newtype Ctx = Ctx { vars  :: Map Ident Poly }
 
--- {-
+data Env = Env { count :: Int
+               , sigs  :: Map Ident Type
+               }
 
--- The type checker will assume we first rename all variables to unique name, as to not
--- have to care about scoping. It significantly improves the quality of life of the
--- programmer.
+type Error = String
+type Subst = Map Ident Type
 
--- TODOs:
---     Add skolemization variables. i.e
---     { \x. 3 : forall a. a -> a }
---     should not type check
+type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
---     Generalize. Not really sure what that means though
+initCtx = Ctx mempty
+initEnv = Env 0 mempty
 
--- -}
+runPretty :: Exp -> Either Error String
+runPretty = fmap (printTree . fst). run . inferExp
 
--- typecheck :: RProgram -> Either Error TProgram
--- typecheck = todo
+run :: Infer a -> Either Error a
+run = runC initEnv initCtx
 
--- run :: Infer a -> Either Error a
--- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
+runC :: Env -> Ctx -> Infer a -> Either Error a
+runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 
--- -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
--- -- { \x. \y. x + y } will have the type { a -> b -> Int }
--- inferExp :: RExp -> Infer Type
--- inferExp = \case
+typecheck :: Program -> Either Error T.Program
+typecheck = run . checkPrg
 
---     RAnn expr typ -> do
---         t <- inferExp expr
---         void $ t =:= typ
---         return t
+checkPrg :: Program -> Infer T.Program
+checkPrg (Program bs) = do
+    let bs' = getBinds bs
+    traverse (\(Bind n t _ _ _) -> insertSig n t) bs'
+    bs' <- mapM checkBind bs'
+    return $ T.Program bs'
+  where
+    getBinds :: [Def] -> [Bind]
+    getBinds = map toBind . filter isBind
+    isBind :: Def -> Bool
+    isBind (DBind _) = True
+    isBind _         = True
+    toBind :: Def -> Bind
+    toBind (DBind bind) = bind
+    toBind _            = error "Can't convert DData to Bind"
 
---     RBound num name -> lookupVars num
+checkBind :: Bind -> Infer T.Bind
+checkBind (Bind n t _ args e) = do
+    (t', e') <- inferExp $ makeLambda e (reverse args)
+    s <- unify t t'
+    let t'' = apply s t
+    unless (t `typeEq` t'') (throwError $ unwords ["Top level signature", printTree t, "does not match body with type:", printTree t''])
+    return $ T.Bind (n, t) [] e'
+  where
+    makeLambda :: Exp -> [Ident] -> Exp
+    makeLambda = foldl (flip EAbs)
 
---     RFree name -> lookupSigs name
+typeEq :: Type -> Type -> Bool
+typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
+typeEq (TMono a) (TMono b)     = a == b
+typeEq (TPol _) (TPol _)       = True
+typeEq _ _                     = False
 
---     RConst (CInt i) -> return $ TMono "Int"
+inferExp :: Exp -> Infer (Type, T.Exp)
+inferExp e = do
+    (s, t, e') <- w e
+    let subbed = apply s t
+    return (subbed, replace subbed e')
 
---     RConst (CStr str) -> return $ TMono "Str"
+replace :: Type -> T.Exp -> T.Exp
+replace t = \case
+    T.ELit _ e -> T.ELit t e
+    T.EId (n, _) -> T.EId (n, t)
+    T.EAbs _ name e -> T.EAbs t name e
+    T.EApp _ e1 e2 -> T.EApp t e1 e2
+    T.EAdd _ e1 e2 -> T.EAdd t e1 e2
+    T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2
 
---     RAdd expr1 expr2 -> do
---         let int = TMono "Int"
---         typ1 <- check expr1 int
---         typ2 <- check expr2 int
---         return int
+w :: Exp -> Infer (Subst, Type, T.Exp)
+w = \case
 
---     RApp expr1 expr2 -> do
---         fn_t <- inferExp expr1
---         arg_t <- inferExp expr2
---         res <- fresh
---         new_t <- fn_t =:= TArrow arg_t res
---         return res
+    EAnn e t -> do
+        (s1, t', e') <- w e
+        applySt s1 $ do
+            s2 <- unify (apply s1 t) t'
+            return (s2 `compose` s1, t, e')
 
---     RAbs num name expr -> do
---         arg <- fresh
---         insertVars num arg
---         typ <- inferExp expr
---         return $ TArrow arg typ
+    ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit  (TMono "Int") (LInt n))
 
--- check :: RExp -> Type -> Infer ()
--- check e t = do
---     t' <- inferExp e
---     t =:= t'
---     return ()
+    ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
 
--- fresh :: Infer Type
--- fresh = do
---     var <- St.gets nextFresh
---     St.modify (\st -> st {nextFresh = succ var})
---     return (TPoly $ Ident (show var))
+    EId i -> do
+        var <- asks vars
+        case M.lookup i var of
+          Just t  -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
+          Nothing -> do
+              sig <- gets sigs
+              case M.lookup i sig of
+                  Nothing -> throwError $ "Unbound variable: " ++ show i
+                  Just t  -> return (nullSubst, t, T.EId (i, t))
 
--- -- | Unify two types.
--- (=:=) :: Type -> Type -> Infer Type
--- (=:=) (TPoly _) b = return b
--- (=:=) a (TPoly _) = return a
--- (=:=) (TMono a) (TMono b) | a == b = return (TMono a)
--- (=:=) (TArrow a b) (TArrow c d) = do
---     t1 <- a =:= c
---     t2 <- b =:= d
---     return $ TArrow t1 t2
--- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
+    EAbs name e -> do
+        fr <- fresh
+        withBinding name (Forall [] fr) $ do
+            (s1, t', e') <- w e
+            let varType = apply s1 fr
+            let newArr = TArr varType t'
+            return (s1, newArr, T.EAbs newArr (name, varType) e')
 
--- lookupVars :: Integer -> Infer Type
--- lookupVars i = do
---     st <- St.gets vars
---     case M.lookup i st of
---        Just t  -> return t
---        Nothing -> throwError $ UnboundVar "lookupVars"
+    EAdd e0 e1 -> do
+        (s1, t0, e0') <- w e0
+        applySt s1 $ do
+            (s2, t1, e1') <- w e1
+            applySt s2 $ do
+                s3 <- unify (apply s2 t0) (TMono "Int")
+                s4 <- unify (apply s3 t1) (TMono "Int")
+                return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
 
--- insertVars :: Integer -> Type -> Infer ()
--- insertVars i t = do
---     st <- St.get
---     St.put (st {vars = M.insert i t st.vars})
+    EApp e0 e1 -> do
+        fr <- fresh
+        (s0, t0, e0') <- w e0
+        applySt s0 $ do
+            (s1, t1, e1') <- w e1
+            -- applySt s1 $ do
+            s2 <- unify (apply s1 t0) (TArr t1 fr)
+            let t = apply s2 fr
+            return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
 
--- lookupSigs :: Ident -> Infer Type
--- lookupSigs i = do
---     st <- St.gets sigs
---     case M.lookup i st of
---         Just t  -> return t
---         Nothing -> throwError $ UnboundVar "lookupSigs"
+    ELet name e0 e1 -> do
+        (s1, t1, e0') <- w e0
+        env <- asks vars
+        let t' = generalize (apply s1 env) t1
+        withBinding name t' $ do
+            (s2, t2, e1') <- w e1
+            return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' )
 
--- insertSigs :: Ident -> Type -> Infer ()
--- insertSigs i t = do
---     st <- St.get
---     St.put (st {sigs = M.insert i t st.sigs})
+    ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b
 
--- {-# WARNING todo "TODO IN CODE" #-}
--- todo :: a
--- todo = error "TODO in code"
+-- | Unify two types producing a new substitution (constraint)
+unify :: Type -> Type -> Infer Subst
+unify t0 t1 = case (t0, t1) of
+    (TArr a b, TArr c d) -> do
+        s1 <- unify a c
+        s2 <- unify (apply s1 b) (apply s1 d)
+        return $ s1 `compose` s2
+    (TPol a, b) -> occurs a b
+    (a, TPol b) -> occurs b a
+    (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
+    (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
 
--- data Error
---     = TypeMismatch String
---     | NotNumber String
---     | FunctionTypeMismatch String
---     | NotFunction String
---     | UnboundVar String
---     | AnnotatedMismatch String
---     | Default String
---     deriving (Show)
+-- | Check if a type is contained in another type.
+-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
+occurs :: Ident -> Type -> Infer Subst
+occurs _ (TPol _) = return nullSubst
+occurs i t = if S.member i (free t)
+                then throwError "Occurs check failed"
+                else return $ M.singleton i t
 
+-- | Generalize a type over all free variables in the substitution set
+generalize :: Map Ident Poly -> Type -> Poly
+generalize env t = Forall (S.toList $ free t S.\\ free env) t
 
--- {-
+-- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones.
+inst :: Poly -> Infer Type
+inst (Forall xs t) = do
+    xs' <- mapM (const fresh) xs
+    let s = M.fromList $ zip xs xs'
+    return $ apply s t
 
--- The procedure inst(σ) specializes the polytype
--- σ by copying the term and replacing the bound type variables
--- consistently by new monotype variables.
+-- | Compose two substitution sets
+compose :: Subst -> Subst -> Subst
+compose m1 m2 = M.map (apply m1) m2 `M.union` m1
 
--- -}
+-- | A class representing free variables functions
+class FreeVars t where
+  -- | Get all free variables from t
+  free :: t -> Set Ident
+  -- | Apply a substitution to t
+  apply :: Subst -> t -> t
+
+instance FreeVars Type where
+  free :: Type -> Set Ident
+  free (TPol a)   = S.singleton a
+  free (TMono _)  = mempty
+  free (TArr a b) = free a `S.union` free b
+  apply :: Subst -> Type -> Type
+  apply sub t = do
+    case t of
+        TMono a -> TMono a
+        TPol a -> case M.lookup a sub of
+                   Nothing -> TPol a
+                   Just t  -> t
+        TArr a b -> TArr (apply sub a) (apply sub b)
+
+instance FreeVars Poly where
+  free :: Poly -> Set Ident
+  free (Forall xs t) = free t S.\\ S.fromList xs
+  apply :: Subst -> Poly -> Poly
+  apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
+
+instance FreeVars (Map Ident Poly) where
+  free :: Map Ident Poly -> Set Ident
+  free m = foldl' S.union S.empty (map free $ M.elems m)
+  apply :: Subst -> Map Ident Poly -> Map Ident Poly
+  apply s = M.map (apply s)
+
+-- | Apply substitutions to the environment.
+applySt :: Subst -> Infer a -> Infer a
+applySt s = local (\st -> st { vars = apply s (vars st) })
+
+-- | Represents the empty substition set
+nullSubst :: Subst
+nullSubst = M.empty
+
+-- | Generate a new fresh variable and increment the state counter
+fresh :: Infer Type
+fresh = do
+    n <- gets count
+    modify (\st -> st { count = n + 1 })
+    return . TPol . Ident $ "t" ++ show n
+
+-- | Run the monadic action with an additional binding
+withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
+withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
+
+-- | Insert a function signature into the environment
+insertSig :: Ident -> Type -> Infer ()
+insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index c08d981..c85ebcc 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,74 +1,99 @@
--- {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr --(
---     TProgram (..),
---     TBind (..),
---     TExp (..),
---     RProgram (..),
---     RBind (..),
---     RExp (..),
---     Type (..),
---     Const (..),
---     Ident (..),
--- ) where
+module TypeChecker.TypeCheckerIr
+  ( module Grammar.Abs
+  , module TypeChecker.TypeCheckerIr
+  ) where
 
--- import           Grammar.Print
--- import           Renamer.RenamerIr
+import           Grammar.Abs   (Ident (..), Literal (..), Type (..))
+import           Grammar.Print
+import           Prelude
+import qualified Prelude       as C (Eq, Ord, Read, Show)
 
--- newtype TProgram = TProgram [TBind]
---     deriving (Eq, Show, Read, Ord)
+newtype Program = Program [Bind]
+  deriving (C.Eq, C.Ord, C.Show, C.Read)
 
--- data TBind = TBind Ident Type TExp
---     deriving (Eq, Show, Read, Ord)
+data Exp
+    = EId  Id
+    | ELit Type Literal
+    | ELet Bind Exp
+    | EApp Type Exp Exp
+    | EAdd Type Exp Exp
+    | EAbs Type Id Exp
+      deriving (C.Eq, C.Ord, C.Read, C.Show)
 
--- data TExp
---     = TAnn TExp Type
---     | TBound Integer Ident Type
---     | TFree Ident Type
---     | TConst Const Type
---     | TApp TExp TExp Type
---     | TAdd TExp TExp Type
---     | TAbs Integer Ident TExp Type
---     deriving (Eq, Ord, Show, Read)
+type Id = (Ident, Type)
+
+data Bind = Bind Id [Id] Exp
+    deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+instance Print Program where
+    prt i (Program sc) = prPrec i 0 $ prt 0 sc
+
+instance Print Bind where
+    prt i (Bind (t, name) parms rhs) = prPrec i 0 $ concatD
+        [ prt 0 name
+        , doc $ showString ":"
+        , prt 0 t
+        , prtIdPs 0 parms
+        , doc $ showString "="
+        , prt 0 rhs
+        ]
+
+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 (prtIdP i)
+
+prtId :: Int -> Id -> Doc
+prtId i (name, t) = prPrec i 0 $ concatD
+    [ prt 0 name
+    , doc $ showString ":"
+    , prt 0 t
+    ]
+
+prtIdP :: Int -> Id -> Doc
+prtIdP i (name, t) = prPrec i 0 $ concatD
+    [ doc $ showString "("
+    , prt 0 name
+    , doc $ showString ":"
+    , prt 0 t
+    , doc $ showString ")"
+    ]
+
+
+instance Print Exp where
+  prt i = \case
+    EId n       -> prPrec i 3 $ concatD [prtId 0 n]
+    ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1]
+    ELet bs e    -> prPrec i 3 $ concatD
+                    [ doc $ showString "let"
+                    , prt 0 bs
+                    , doc $ showString "in"
+                    , prt 0 e
+                    ]
+    EApp t e1 e2 -> prPrec i 2 $ concatD
+                        [ prt 2 e1
+                        , prt 3 e2
+                        ]
+    EAdd t e1 e2 -> prPrec i 1 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , prt 1 e1
+                        , doc $ showString "+"
+                        , prt 2 e2
+                        ]
+    EAbs t n e  -> prPrec i 0 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , doc $ showString "\\"
+                        , prtId 0 n
+                        , doc $ showString "."
+                        , prt 0 e
+                        ]
 
--- instance Print TProgram where
---     prt i = \case
---         TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
 
--- instance Print TBind where
---     prt i = \case
---         TBind x t e ->
---             prPrec i 0 $
---                 concatD
---                     [ prt 0 x
---                     , doc (showString ":")
---                     , prt 0 t
---                     , doc (showString "=")
---                     , prt 0 e
---                     , doc (showString "\n")
---                     ]
 
--- instance Print TExp where
---     prt i = \case
---         TAnn e t ->
---             prPrec i 2 $
---                 concatD
---                     [ prt 0 e
---                     , doc (showString ":")
---                     , prt 1 t
---                     ]
---         TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
---         TFree u t -> prPrec i 3 $ concatD [prt 0 u]
---         TConst c _ -> prPrec i 3 (concatD [prt 0 c])
---         TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
---         TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
---         TAbs _ u e t ->
---             prPrec i 0 $
---                 concatD
---                     [ doc (showString "(")
---                     , doc (showString "λ")
---                     , prt 0 u
---                     , doc (showString ".")
---                     , prt 0 e
---                     , doc (showString ")")
---                     ]
diff --git a/test_program b/test_program
index 3481a0b..69a2c20 100644
--- a/test_program
+++ b/test_program
@@ -1,3 +1,2 @@
-fun : Mono Int -> Mono Int ;
-fun = let f = \x. x in f 3 ;
-
+main : _Int ;
+main = 3 + 3 ;
diff --git a/tests/Main.hs b/tests/Main.hs
deleted file mode 100644
index 7432800..0000000
--- a/tests/Main.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Main where
-
-import           Grammar.Abs
-import           System.Exit       (exitFailure)
-import           Test.Hspec
-import           TypeChecker.AlgoW
-
-main :: IO ()
-main = do
-    print "RUNNING TESTS BROTHER"
-    exitFailure
-    -- hspec $ do
-    --     describe "the algorithm W" $ do
-    --         it "infers EInt as type Int" $ do
-    --             fmap fst (run (inferExp (EInt 1))) `shouldBe` Right (TMono "Int")
-    --         it "throws an exception if a variable is inferred with an empty env" $ do
-    --             run (inferExp (EId "x")) `shouldBe` Left "Unbound variable: x"
-    --         it "throws an exception if the annotated type does not match the inferred type" $ do
-    --             fmap fst (run (inferExp (EAnn (EInt 3) (TPol "a")))) `shouldBe` Right (TMono "bad")
diff --git a/tests/Tests.hs b/tests/Tests.hs
new file mode 100644
index 0000000..46a9a3f
--- /dev/null
+++ b/tests/Tests.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use <$>" #-}
+
+module Main where
+
+import           Control.Monad.Except
+import           Grammar.Abs
+import           Test.QuickCheck
+import           TypeChecker.TypeChecker
+import qualified TypeChecker.TypeCheckerIr as T
+
+main :: IO ()
+main = do
+    quickCheck prop_isInt
+    quickCheck prop_idAbs_generic
+
+newtype AbsExp = AE Exp deriving Show
+newtype EIntExp = EI Exp deriving Show
+
+instance Arbitrary EIntExp where
+  arbitrary = genInt
+
+instance Arbitrary AbsExp where
+  arbitrary = genLambda
+
+getType :: Infer (Type, T.Exp) -> Either Error Type
+getType ie = case run ie of
+    Left err    -> Left err
+    Right (t,e) -> return t
+
+genInt :: Gen EIntExp
+genInt = EI . ELit . LInt <$> arbitrary
+
+genLambda :: Gen AbsExp
+genLambda = do
+    str <- arbitrary @String
+    let str' = Ident str
+    return $ AE $ EAbs str' (EId str')
+
+prop_idAbs_generic :: AbsExp -> Bool
+prop_idAbs_generic (AE e) = case getType (inferExp e) of
+    Left _  -> False
+    Right t -> isGenericArr t
+
+prop_isInt :: EIntExp -> Bool
+prop_isInt (EI e) = case getType (inferExp e) of
+    Left _  -> False
+    Right t -> t == int
+
+int :: Type
+int = TMono "Int"
+
+isGenericArr :: Type -> Bool
+isGenericArr (TArr (TPol a) (TPol b)) = a == b
+isGenericArr _                        = False

From bbf6e159c7790056bb816cf94e428e7542978cbc Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 27 Feb 2023 17:22:42 +0100
Subject: [PATCH 42/71] Type inference/checking on ADTs mostly complete(?).
 Still have to test

---
 Grammar.cf                       |  18 +-
 language.cabal                   |   6 +-
 src/Codegen/Codegen.hs           | 484 +++++++++++++++----------------
 src/LambdaLifter/LambdaLifter.hs | 304 +++++++++----------
 src/Main.hs                      |  36 +--
 src/TypeChecker/TypeChecker.hs   | 153 +++++++---
 src/TypeChecker/TypeCheckerIr.hs |  13 +-
 test_program                     |  16 +-
 8 files changed, 563 insertions(+), 467 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index 6870367..96554bb 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -3,7 +3,7 @@ Program. Program ::= [Def] ;
 
 DBind. Def ::= Bind ;
 DData. Def ::= Data ;
-terminator Def ";" ;
+separator Def ";" ;
 
 Bind. Bind ::= Ident ":" Type ";"
                Ident [Ident] "=" Exp ;
@@ -31,16 +31,19 @@ IMatch. Match ::= Ident ;
 InitMatch. Match ::= Ident Match ;
 separator Match " " ;
 
-TMono. Type1 ::= "_" Ident ;
-TPol. Type1 ::= "'" Ident ;
-TArr. Type ::= Type1 "->" Type ;
+TMono.   Type1 ::= "_" Ident ;
+TPol.    Type1 ::= "'" Ident ;
+TConstr. Type1  ::= Ident "(" [Type] ")" ; 
+TArr.    Type ::= Type1 "->" Type ;
+
 separator Type " " ;
+coercions Type 2 ;
 
 -- shift/reduce problem here
-Data. Data ::= "data" Ident [Type] "where" ";"
+Data. Data ::= "data" Type "where" ";"
                [Constructor];
 
-terminator Constructor ";" ;
+separator Constructor "," ;
 
 Constructor. Constructor ::= Ident ":" Type ;
 
@@ -48,10 +51,9 @@ Constructor. Constructor ::= Ident ":" Type ;
 -- token Poly upper (letter | digit | '_')* ;
 -- token Mono lower (letter | digit | '_')* ;
 
-terminator Bind ";" ;
+separator Bind ";" ;
 separator Ident " ";
 
-coercions Type 1 ;
 coercions Exp 5 ;
 
 comment "--" ;
diff --git a/language.cabal b/language.cabal
index eb58aa0..3556367 100644
--- a/language.cabal
+++ b/language.cabal
@@ -34,9 +34,9 @@ executable language
       TypeChecker.TypeChecker
       TypeChecker.TypeCheckerIr
       Renamer.Renamer
-      LambdaLifter.LambdaLifter
-      Codegen.Codegen
-      Codegen.LlvmIr
+      -- LambdaLifter.LambdaLifter
+      -- Codegen.Codegen
+      -- Codegen.LlvmIr
 
     hs-source-dirs:   src
 
diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs
index 76a1f02..fe66b43 100644
--- a/src/Codegen/Codegen.hs
+++ b/src/Codegen/Codegen.hs
@@ -1,277 +1,277 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
+--{-# LANGUAGE LambdaCase        #-}
+--{-# LANGUAGE OverloadedStrings #-}
 
-module Codegen.Codegen (compile) where
+module Codegen.Codegen where
 
-import           Auxiliary                 (snoc)
-import           Codegen.LlvmIr            (LLVMIr (..), LLVMType (..),
-                                            LLVMValue (..), Visibility (..),
-                                            llvmIrToString)
-import           Control.Monad.State       (StateT, execStateT, gets, modify)
-import           Data.Map                  (Map)
-import qualified Data.Map                  as Map
-import           Data.Tuple.Extra          (dupe, first, second)
-import           Grammar.ErrM              (Err)
-import           TypeChecker.TypeChecker
-import           TypeChecker.TypeCheckerIr
+--import           Auxiliary                 (snoc)
+--import           Codegen.LlvmIr            (LLVMIr (..), LLVMType (..),
+--                                            LLVMValue (..), Visibility (..),
+--                                            llvmIrToString)
+--import           Control.Monad.State       (StateT, execStateT, gets, modify)
+--import           Data.Map                  (Map)
+--import qualified Data.Map                  as Map
+--import           Data.Tuple.Extra          (dupe, first, second)
+--import           Grammar.ErrM              (Err)
+--import           TypeChecker.TypeCheckerIr
 
--- | The record used as the code generator state
-data CodeGenerator = CodeGenerator
-    { instructions  :: [LLVMIr]
-    , functions     :: Map Id FunctionInfo
-    , variableCount :: Integer
-    }
+---- | The record used as the code generator state
+--data CodeGenerator = CodeGenerator
+--    { instructions  :: [LLVMIr]
+--    , functions     :: Map Id FunctionInfo
+--    , variableCount :: 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]
-    }
+--data FunctionInfo = FunctionInfo
+--    { numArgs   :: Int
+--    , arguments :: [Id]
+--    }
 
--- | Adds a instruction to the CodeGenerator state
-emit :: LLVMIr -> CompilerState ()
-emit l = modify $ \t -> t { instructions = snoc l $ instructions t }
+---- | Adds a instruction to the CodeGenerator state
+--emit :: LLVMIr -> CompilerState ()
+--emit l = modify $ \t -> t { instructions = 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 Integer
-getNewVar = increaseVarCount >> getVarCount
+---- | Increases the variable count and returns it from the CodeGenerator state
+--getNewVar :: CompilerState Integer
+--getNewVar = increaseVarCount >> getVarCount
 
--- | Produces a map of functions infos from a list of binds,
--- which contains useful data for code generation.
-getFunctions :: [Bind] -> Map Id FunctionInfo
-getFunctions bs = Map.fromList $ map go bs
-  where
-    go (Bind id args _) =
-        (id, FunctionInfo { numArgs=length args, arguments=args })
+---- | Produces a map of functions infos from a list of binds,
+---- which contains useful data for code generation.
+--getFunctions :: [Bind] -> Map Id FunctionInfo
+--getFunctions bs = Map.fromList $ map go bs
+--  where
+--    go (Bind id args _) =
+--        (id, FunctionInfo { numArgs=length args, arguments=args })
 
 
 
-initCodeGenerator :: [Bind] -> CodeGenerator
-initCodeGenerator scs = CodeGenerator { instructions = defaultStart
-                                      , functions = getFunctions scs
-                                      , variableCount = 0
-                                      }
+--initCodeGenerator :: [Bind] -> CodeGenerator
+--initCodeGenerator scs = CodeGenerator { instructions = defaultStart
+--                                      , functions = getFunctions scs
+--                                      , variableCount = 0
+--                                      }
 
--- | Compiles an AST and produces a LLVM Ir string.
--- An easy way to actually "compile" this output is to
--- Simply pipe it to lli
-compile :: Program -> Err String
-compile (Program scs) = do
-    let codegen = initCodeGenerator scs
-    llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
+---- | Compiles an AST and produces a LLVM Ir string.
+---- An easy way to actually "compile" this output is to
+---- Simply pipe it to lli
+--compile :: Program -> Err String
+--compile (Program scs) = do
+--    let codegen = initCodeGenerator scs
+--    llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
 
-compileScs :: [Bind] -> CompilerState ()
-compileScs []                             = pure ()
-compileScs (Bind (name, t) args exp : xs) = do
-    emit $ UnsafeRaw "\n"
-    emit . Comment $ show name <> ": " <> show exp
-    let args' = map (second type2LlvmType) args
-    emit $ Define (type2LlvmType t_return) name args'
-    functionBody <- exprToValue exp
-    if name == "main"
-        then mapM_ emit $ mainContent functionBody
-        else emit $ Ret I64 functionBody
-    emit DefineEnd
-    modify $ \s -> s { variableCount = 0 }
-    compileScs xs
-  where
-    t_return = snd $ partitionType (length args) t
+--compileScs :: [Bind] -> CompilerState ()
+--compileScs []                             = pure ()
+--compileScs (Bind (name, t) args exp : xs) = do
+--    emit $ UnsafeRaw "\n"
+--    emit . Comment $ show name <> ": " <> show exp
+--    let args' = map (second type2LlvmType) args
+--    emit $ Define (type2LlvmType t_return) name args'
+--    functionBody <- exprToValue exp
+--    if name == "main"
+--        then mapM_ emit $ mainContent functionBody
+--        else emit $ Ret I64 functionBody
+--    emit DefineEnd
+--    modify $ \s -> s { variableCount = 0 }
+--    compileScs xs
+--  where
+--    t_return = snd $ partitionType (length args) t
 
-mainContent :: LLVMValue -> [LLVMIr]
-mainContent var =
-    [ UnsafeRaw $
-        "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
-    , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
-      -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2")
-      -- , Label (Ident "b_1")
-      -- , UnsafeRaw
-      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
-      -- , Br (Ident "end")
-      -- , Label (Ident "b_2")
-      -- , UnsafeRaw
-      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
-      -- , Br (Ident "end")
-      -- , Label (Ident "end")
-      Ret I64 (VInteger 0)
-    ]
+--mainContent :: LLVMValue -> [LLVMIr]
+--mainContent var =
+--    [ UnsafeRaw $
+--        "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
+--    , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
+--      -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2")
+--      -- , Label (Ident "b_1")
+--      -- , UnsafeRaw
+--      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
+--      -- , Br (Ident "end")
+--      -- , Label (Ident "b_2")
+--      -- , UnsafeRaw
+--      --     "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
+--      -- , Br (Ident "end")
+--      -- , Label (Ident "end")
+--      Ret I64 (VInteger 0)
+--    ]
 
-defaultStart :: [LLVMIr]
-defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n"
-               , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
-               ]
+--defaultStart :: [LLVMIr]
+--defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n"
+--               , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
+--               ]
 
-compileExp :: Exp -> CompilerState ()
-compileExp = \case
-  ELit _ (LInt i)        -> emitInt i
-  EAdd t e1 e2  -> emitAdd t e1 e2
-  EId (name, _) -> emitIdent name
-  EApp t e1 e2  -> emitApp t e1 e2
-  EAbs t ti e   -> emitAbs t ti e
-  ELet bind e   -> emitLet bind e
+--compileExp :: Exp -> CompilerState ()
+--compileExp = \case
+--  ELit _ (LInt i)        -> emitInt i
+--  EAdd t e1 e2  -> emitAdd t e1 e2
+--  EId (name, _) -> emitIdent name
+--  EApp t e1 e2  -> emitApp t e1 e2
+--  EAbs t ti e   -> emitAbs t ti e
+--  ELet bind e   -> emitLet bind e
 
---- aux functions ---
-emitAbs :: Type -> Id -> Exp -> CompilerState ()
-emitAbs _t tid e = emit . Comment $ "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
+----- aux functions ---
+--emitAbs :: Type -> Id -> Exp -> CompilerState ()
+--emitAbs _t tid e = emit . Comment $ "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
 
-emitLet :: Bind -> Exp -> CompilerState ()
-emitLet b e = emit . Comment $ concat [ "ELet ("
-                                      , show b
-                                      , " = "
-                                      , show e
-                                      , ") is not implemented!"
-                                      ]
+--emitLet :: Bind -> Exp -> CompilerState ()
+--emitLet b e = emit . Comment $ concat [ "ELet ("
+--                                      , show b
+--                                      , " = "
+--                                      , show e
+--                                      , ") is not implemented!"
+--                                      ]
 
-emitApp :: Type -> Exp -> Exp -> CompilerState ()
-emitApp t e1 e2 = appEmitter t e1 e2 []
-  where
-    appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
-    appEmitter t e1 e2 stack = do
-        let newStack = e2 : stack
-        case e1 of
-            EApp _ e1' e2' -> appEmitter t e1' e2' newStack
-            EId id@(name, _) -> do
-                args <- traverse exprToValue newStack
-                vs <- getNewVar
-                funcs <- gets functions
-                let visibility = maybe Local (const Global) $ Map.lookup id funcs
-                    args'      = map (first valueGetType . dupe) args
-                    call       = Call (type2LlvmType t) visibility name args'
-                emit $ SetVariable (Ident $ show vs) call
-            x -> do
-                emit . Comment $ "The unspeakable happened: "
-                emit . Comment $ show x
+--emitApp :: Type -> Exp -> Exp -> CompilerState ()
+--emitApp t e1 e2 = appEmitter t e1 e2 []
+--  where
+--    appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
+--    appEmitter t e1 e2 stack = do
+--        let newStack = e2 : stack
+--        case e1 of
+--            EApp _ e1' e2' -> appEmitter t e1' e2' newStack
+--            EId id@(name, _) -> do
+--                args <- traverse exprToValue newStack
+--                vs <- getNewVar
+--                funcs <- gets functions
+--                let visibility = maybe Local (const Global) $ Map.lookup id funcs
+--                    args'      = map (first valueGetType . dupe) args
+--                    call       = Call (type2LlvmType t) visibility name args'
+--                emit $ SetVariable (Ident $ show vs) call
+--            x -> do
+--                emit . Comment $ "The unspeakable happened: "
+--                emit . Comment $ show x
 
-emitIdent :: Ident -> CompilerState ()
-emitIdent id = do
-    -- !!this should never happen!!
-    emit $ Comment "This should not have happened!"
-    emit $ Variable id
-    emit $ UnsafeRaw "\n"
+--emitIdent :: Ident -> CompilerState ()
+--emitIdent id = do
+--    -- !!this should never happen!!
+--    emit $ Comment "This should not have happened!"
+--    emit $ Variable id
+--    emit $ UnsafeRaw "\n"
 
-emitInt :: Integer -> CompilerState ()
-emitInt i = do
-    -- !!this should never happen!!
-    varCount <- getNewVar
-    emit $ Comment "This should not have happened!"
-    emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
+--emitInt :: Integer -> CompilerState ()
+--emitInt i = do
+--    -- !!this should never happen!!
+--    varCount <- getNewVar
+--    emit $ Comment "This should not have happened!"
+--    emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
 
-emitAdd :: Type -> Exp -> Exp -> CompilerState ()
-emitAdd t e1 e2 = do
-    v1 <- exprToValue e1
-    v2 <- exprToValue e2
-    v <- getNewVar
-    emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2)
+--emitAdd :: Type -> Exp -> Exp -> CompilerState ()
+--emitAdd t e1 e2 = do
+--    v1 <- exprToValue e1
+--    v2 <- exprToValue e2
+--    v <- getNewVar
+--    emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2)
 
--- emitMul :: Exp -> Exp -> CompilerState ()
--- emitMul e1 e2 = do
---     (v1,v2) <- binExprToValues e1 e2
---     increaseVarCount
---     v <- gets variableCount
---     emit $ SetVariable $ Ident $ show v
---     emit $ Mul I64 v1 v2
+---- emitMul :: Exp -> Exp -> CompilerState ()
+---- emitMul e1 e2 = do
+----     (v1,v2) <- binExprToValues e1 e2
+----     increaseVarCount
+----     v <- gets variableCount
+----     emit $ SetVariable $ Ident $ show v
+----     emit $ Mul I64 v1 v2
 
--- emitMod :: Exp -> Exp -> CompilerState ()
--- emitMod e1 e2 = do
---     -- `let m a b = rem (abs $ b + a) b`
---     (v1,v2) <- binExprToValues e1 e2
---     increaseVarCount
---     vadd <- gets variableCount
---     emit $ SetVariable $ Ident $ show vadd
---     emit $ Add I64 v1 v2
---
---     increaseVarCount
---     vabs <- gets variableCount
---     emit $ SetVariable $ Ident $ show vabs
---     emit $ Call I64 (Ident "llvm.abs.i64")
---         [ (I64, VIdent (Ident $ show vadd))
---         , (I1, VInteger 1)
---         ]
---     increaseVarCount
---     v <- gets variableCount
---     emit $ SetVariable $ Ident $ show v
---     emit $ Srem I64 (VIdent (Ident $ show vabs)) v2
+---- emitMod :: Exp -> Exp -> CompilerState ()
+---- emitMod e1 e2 = do
+----     -- `let m a b = rem (abs $ b + a) b`
+----     (v1,v2) <- binExprToValues e1 e2
+----     increaseVarCount
+----     vadd <- gets variableCount
+----     emit $ SetVariable $ Ident $ show vadd
+----     emit $ Add I64 v1 v2
+----
+----     increaseVarCount
+----     vabs <- gets variableCount
+----     emit $ SetVariable $ Ident $ show vabs
+----     emit $ Call I64 (Ident "llvm.abs.i64")
+----         [ (I64, VIdent (Ident $ show vadd))
+----         , (I1, VInteger 1)
+----         ]
+----     increaseVarCount
+----     v <- gets variableCount
+----     emit $ SetVariable $ Ident $ show v
+----     emit $ Srem I64 (VIdent (Ident $ show vabs)) v2
 
--- emitDiv :: Exp -> Exp -> CompilerState ()
--- emitDiv e1 e2 = do
---     (v1,v2) <- binExprToValues e1 e2
---     increaseVarCount
---     v <- gets variableCount
---     emit $ SetVariable $ Ident $ show v
---     emit $ Div I64 v1 v2
+---- emitDiv :: Exp -> Exp -> CompilerState ()
+---- emitDiv e1 e2 = do
+----     (v1,v2) <- binExprToValues e1 e2
+----     increaseVarCount
+----     v <- gets variableCount
+----     emit $ SetVariable $ Ident $ show v
+----     emit $ Div I64 v1 v2
 
--- emitSub :: Exp -> Exp -> CompilerState ()
--- emitSub e1 e2 = do
---     (v1,v2) <- binExprToValues e1 e2
---     increaseVarCount
---     v <- gets variableCount
---     emit $ SetVariable $ Ident $ show v
---     emit $ Sub I64 v1 v2
+---- emitSub :: Exp -> Exp -> CompilerState ()
+---- emitSub e1 e2 = do
+----     (v1,v2) <- binExprToValues e1 e2
+----     increaseVarCount
+----     v <- gets variableCount
+----     emit $ SetVariable $ Ident $ show v
+----     emit $ Sub I64 v1 v2
 
-exprToValue :: Exp -> CompilerState LLVMValue
-exprToValue = \case
-    ELit _ (LInt i) -> pure $ VInteger i
+--exprToValue :: Exp -> CompilerState LLVMValue
+--exprToValue = \case
+--    ELit _ (LInt i) -> pure $ VInteger i
 
-    EId id@(name, t) -> do
-        funcs <- gets functions
-        case Map.lookup id funcs of
-            Just fi -> do
-                if numArgs fi == 0
-                    then do
-                        vc <- getNewVar
-                        emit $ SetVariable (Ident $ show vc)
-                            (Call (type2LlvmType t) Global name [])
-                        pure $ VIdent (Ident $ show vc) (type2LlvmType t)
-                    else pure $ VFunction name Global (type2LlvmType t)
-            Nothing -> pure $ VIdent name (type2LlvmType t)
+--    EId id@(name, t) -> do
+--        funcs <- gets functions
+--        case Map.lookup id funcs of
+--            Just fi -> do
+--                if numArgs fi == 0
+--                    then do
+--                        vc <- getNewVar
+--                        emit $ SetVariable (Ident $ show vc)
+--                            (Call (type2LlvmType t) Global name [])
+--                        pure $ VIdent (Ident $ show vc) (type2LlvmType t)
+--                    else pure $ VFunction name Global (type2LlvmType t)
+--            Nothing -> pure $ VIdent name (type2LlvmType t)
 
-    e -> do
-        compileExp e
-        v <- getVarCount
-        pure $ VIdent (Ident $ show v) (getType e)
+--    e -> do
+--        compileExp e
+--        v <- getVarCount
+--        pure $ VIdent (Ident $ show v) (getType e)
 
-type2LlvmType :: Type -> LLVMType
-type2LlvmType = \case
-    (TMono "Int") -> I64
-    TArr t xs -> do
-        let (t', xs') = function2LLVMType xs [type2LlvmType t]
-        Function t' xs'
-    t -> I64 --CustomType $ Ident ("\"" ++ show t ++ "\"")
-  where
-    function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
-    function2LLVMType (TArr t xs) s = function2LLVMType xs (type2LlvmType t : s)
-    function2LLVMType x s           = (type2LlvmType x, s)
+--type2LlvmType :: Type -> LLVMType
+--type2LlvmType = \case
+--    (TMono "Int") -> I64
+--    TArr t xs -> do
+--        let (t', xs') = function2LLVMType xs [type2LlvmType t]
+--        Function t' xs'
+--    -- This part will not work as we don't have a monomorphization step yet
+--    t -> CustomType $ Ident ("\"" ++ show t ++ "\"")
+--  where
+--    function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
+--    function2LLVMType (TArr t xs) s = function2LLVMType xs (type2LlvmType t : s)
+--    function2LLVMType x s           = (type2LlvmType x, s)
 
-getType :: Exp -> LLVMType
-getType (ELit _ (LInt _)) = I64
-getType (EAdd t _ _)      = type2LlvmType t
-getType (EId (_, t))      = type2LlvmType t
-getType (EApp t _ _)      = type2LlvmType t
-getType (EAbs t _ _)      = type2LlvmType t
-getType (ELet _ e)        = getType e
+--getType :: Exp -> LLVMType
+--getType (ELit _ (LInt _)) = I64
+--getType (EAdd t _ _)      = type2LlvmType t
+--getType (EId (_, t))      = type2LlvmType t
+--getType (EApp t _ _)      = type2LlvmType t
+--getType (EAbs t _ _)      = type2LlvmType t
+--getType (ELet _ e)        = getType e
 
-valueGetType :: LLVMValue -> LLVMType
-valueGetType (VInteger _)      = I64
-valueGetType (VIdent _ t)      = t
-valueGetType (VConstant s)     = Array (length s) I8
-valueGetType (VFunction _ _ t) = t
+--valueGetType :: LLVMValue -> LLVMType
+--valueGetType (VInteger _)      = I64
+--valueGetType (VIdent _ t)      = t
+--valueGetType (VConstant s)     = Array (length s) I8
+--valueGetType (VFunction _ _ t) = t
 
--- | Partion type into types of parameters and return type.
-partitionType :: Int -- Number of parameters to apply
-              -> Type
-              -> ([Type], Type)
-partitionType = go []
-  where
-    go acc 0 t = (acc, t)
-    go acc i t = case t of
-        TArr t1 t2 -> go (snoc t1 acc) (i - 1) t2
-        _          -> error "Number of parameters and type doesn't match"
+---- | Partion type into types of parameters and return type.
+--partitionType :: Int -- Number of parameters to apply
+--              -> Type
+--              -> ([Type], Type)
+--partitionType = go []
+--  where
+--    go acc 0 t = (acc, t)
+--    go acc i t = case t of
+--        TArr t1 t2 -> go (snoc t1 acc) (i - 1) t2
+--        _          -> error "Number of parameters and type doesn't match"
diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs
index a617159..271cc70 100644
--- a/src/LambdaLifter/LambdaLifter.hs
+++ b/src/LambdaLifter/LambdaLifter.hs
@@ -1,192 +1,192 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
+--{-# LANGUAGE LambdaCase        #-}
+--{-# LANGUAGE OverloadedStrings #-}
 
 
-module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
+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 qualified Data.Set                  as Set
-import           Prelude                   hiding (exp)
-import           Renamer.Renamer
-import           TypeChecker.TypeCheckerIr
+--import           Auxiliary                 (snoc)
+--import           Control.Applicative       (Applicative (liftA2))
+--import           Control.Monad.State       (MonadState (get, put), State,
+--                                            evalState)
+--import           Data.Set                  (Set)
+--import qualified Data.Set                  as Set
+--import           Prelude                   hiding (exp)
+--import           Renamer.Renamer
+--import           TypeChecker.TypeCheckerIr
 
 
--- | Lift lambdas and let expression into supercombinators.
--- Three phases:
--- @freeVars@ annotatss 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
+---- | Lift lambdas and let expression into supercombinators.
+---- Three phases:
+---- @freeVars@ annotatss 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 xs) e)
-                        | Bind n xs e <- ds
-                        ]
+---- | Annotate free variables
+--freeVars :: Program -> AnnProgram
+--freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
+--                        | Bind n xs e <- ds
+--                        ]
 
-freeVarsExp :: Set Id -> Exp -> AnnExp
-freeVarsExp localVars = \case
-    EId  n  | Set.member n localVars -> (Set.singleton n, AId n)
-            | otherwise              -> (mempty, AId n)
+--freeVarsExp :: Set Id -> Exp -> AnnExp
+--freeVarsExp localVars = \case
+--    EId  n  | Set.member n localVars -> (Set.singleton n, AId n)
+--            | otherwise              -> (mempty, AId n)
 
-    ELit _ (LInt i) -> (mempty, AInt i)
+--    ELit _ (LInt i) -> (mempty, AInt i)
 
-    EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2')
-      where
-        e1' = freeVarsExp localVars e1
-        e2' = freeVarsExp localVars e2
+--    EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2')
+--      where
+--        e1' = freeVarsExp localVars e1
+--        e2' = freeVarsExp localVars e2
 
-    EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2')
-      where
-        e1' = freeVarsExp localVars e1
-        e2' = freeVarsExp localVars e2
+--    EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2')
+--      where
+--        e1' = freeVarsExp localVars e1
+--        e2' = freeVarsExp localVars e2
 
-    EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e')
-      where
-        e' = freeVarsExp (Set.insert par localVars) e
+--    EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e')
+--      where
+--        e' = freeVarsExp (Set.insert par localVars) e
 
-    -- Sum free variables present in bind and the expression
-    ELet (Bind name parms rhs) e  -> (Set.union binders_frees e_free, ALet new_bind e')
-      where
-        binders_frees = Set.delete name $ freeVarsOf rhs'
-        e_free        = Set.delete name $ freeVarsOf e'
+--    -- Sum free variables present in bind and the expression
+--    ELet (Bind name parms rhs) e  -> (Set.union binders_frees e_free, ALet new_bind e')
+--      where
+--        binders_frees = Set.delete name $ freeVarsOf rhs'
+--        e_free        = Set.delete name $ freeVarsOf e'
 
-        rhs'     = freeVarsExp e_localVars rhs
-        new_bind = ABind name parms rhs'
+--        rhs'     = freeVarsExp e_localVars rhs
+--        new_bind = ABind name parms rhs'
 
-        e'          = freeVarsExp e_localVars e
-        e_localVars = Set.insert name localVars
+--        e'          = freeVarsExp e_localVars e
+--        e_localVars = Set.insert name localVars
 
 
-freeVarsOf :: AnnExp -> Set Id
-freeVarsOf = fst
+--freeVarsOf :: AnnExp -> Set Id
+--freeVarsOf = fst
 
--- AST annotated with free variables
-type AnnProgram = [(Id, [Id], AnnExp)]
+---- AST annotated with free variables
+--type AnnProgram = [(Id, [Id], AnnExp)]
 
-type AnnExp = (Set Id, AnnExp')
+--type AnnExp = (Set Id, AnnExp')
 
-data ABind = ABind Id [Id] AnnExp deriving Show
+--data ABind = ABind Id [Id] AnnExp deriving Show
 
-data AnnExp' = AId  Id
-             | AInt Integer
-             | ALet ABind AnnExp
-             | AApp Type    AnnExp  AnnExp
-             | AAdd Type    AnnExp  AnnExp
-             | AAbs Type    Id      AnnExp
-             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], AnnExp) -> State Int Bind
-    go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs'
-      where
-        (rhs', parms1) = flattenLambdasAnn rhs
+--data AnnExp' = AId  Id
+--             | AInt Integer
+--             | ALet ABind AnnExp
+--             | AApp Type    AnnExp  AnnExp
+--             | AAdd Type    AnnExp  AnnExp
+--             | AAbs Type    Id      AnnExp
+--             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], AnnExp) -> 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 :: AnnExp -> (AnnExp, [Id])
-flattenLambdasAnn ae = go (ae, [])
-  where
-    go :: (AnnExp, [Id]) -> (AnnExp, [Id])
-    go ((free, e), acc) =
-        case e of
-            AAbs _ par (free1, e1) ->
-                go ((Set.delete par free1, e1), snoc par acc)
-            _ -> ((free, e), acc)
+---- | Flatten nested lambdas and collect the parameters
+---- @\x.\y.\z. ae → (ae, [x,y,z])@
+--flattenLambdasAnn :: AnnExp -> (AnnExp, [Id])
+--flattenLambdasAnn ae = go (ae, [])
+--  where
+--    go :: (AnnExp, [Id]) -> (AnnExp, [Id])
+--    go ((free, e), acc) =
+--        case e of
+--            AAbs _ par (free1, e1) ->
+--                go ((Set.delete par free1, e1), snoc par acc)
+--            _ -> ((free, e), acc)
 
-abstractExp :: AnnExp -> State Int Exp
-abstractExp (free, exp) = case exp of
-    AId  n       -> pure $ EId  n
-    AInt i       -> pure $ ELit (TMono "Int") (LInt i)
-    AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2)
-    AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2)
-    ALet b e     -> 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'
+--abstractExp :: AnnExp -> State Int Exp
+--abstractExp (free, exp) = case exp of
+--    AId  n       -> pure $ EId  n
+--    AInt i       -> pure $ ELit (TMono "Int") (LInt i)
+--    AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2)
+--    AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2)
+--    ALet b e     -> 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 :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp
-        skipLambdas f (free, ae) = case ae of
-            AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1
-            _              -> f (free, ae)
+--        skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp
+--        skipLambdas f (free, ae) = case ae of
+--            AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1
+--            _              -> f (free, ae)
 
-    -- Lift lambda into let and bind free variables
-    AAbs t parm e -> do
-        i <- nextNumber
-        rhs <- abstractExp e
+--    -- Lift lambda into let and bind free variables
+--    AAbs t parm e -> do
+--        i <- nextNumber
+--        rhs <- abstractExp e
 
-        let sc_name = Ident ("sc_" ++ show i)
-            sc      = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t)
+--        let sc_name = Ident ("sc_" ++ show i)
+--            sc      = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t)
 
-        pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList
-      where
-        freeList = Set.toList free
-        parms    = snoc parm freeList
+--        pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList
+--      where
+--        freeList = Set.toList free
+--        parms    = snoc parm freeList
 
 
-nextNumber :: State Int Int
-nextNumber = do
-    i <- get
-    put $ succ i
-    pure i
+--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
+---- | 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 :: Exp -> ([Bind], Exp)
-collectScsExp = \case
-    EId  n -> ([], EId n)
-    ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i))
+--collectScsExp :: Exp -> ([Bind], Exp)
+--collectScsExp = \case
+--    EId  n -> ([], EId n)
+--    ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i))
 
-    EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2')
-      where
-        (scs1, e1') = collectScsExp e1
-        (scs2, e2') = collectScsExp e2
+--    EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2')
+--      where
+--        (scs1, e1') = collectScsExp e1
+--        (scs2, e2') = collectScsExp e2
 
-    EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2')
-      where
-        (scs1, e1') = collectScsExp e1
-        (scs2, e2') = collectScsExp e2
+--    EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2')
+--      where
+--        (scs1, e1') = collectScsExp e1
+--        (scs2, e2') = collectScsExp e2
 
-    EAbs t par e -> (scs, EAbs t par e')
-      where
-        (scs, e') = collectScsExp e
+--    EAbs t par e -> (scs, EAbs t par e')
+--      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 ++ e_scs, ELet bind e')
-                                    else (bind : rhs_scs ++ e_scs, e')
-      where
-        bind            = Bind name parms rhs'
-        (rhs_scs, rhs') = collectScsExp rhs
-        (e_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 ++ e_scs, ELet bind e')
+--                                    else (bind : rhs_scs ++ e_scs, e')
+--      where
+--        bind            = Bind name parms rhs'
+--        (rhs_scs, rhs') = collectScsExp rhs
+--        (e_scs, e')     = collectScsExp e
 
 
--- @\x.\y.\z. e → (e, [x,y,z])@
-flattenLambdas :: Exp -> (Exp, [Id])
-flattenLambdas = go . (, [])
-  where
-    go (e, acc) = case e of
-                      EAbs _ par e1 -> go (e1, snoc par acc)
-                      _             -> (e, acc)
+---- @\x.\y.\z. e → (e, [x,y,z])@
+--flattenLambdas :: Exp -> (Exp, [Id])
+--flattenLambdas = go . (, [])
+--  where
+--    go (e, acc) = case e of
+--                      EAbs _ par e1 -> go (e1, snoc par acc)
+--                      _             -> (e, acc)
 
diff --git a/src/Main.hs b/src/Main.hs
index 3a7bde4..316c599 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,18 +2,18 @@
 
 module Main where
 
-import           Codegen.Codegen           (compile)
-import           GHC.IO.Handle.Text        (hPutStrLn)
-import           Grammar.ErrM              (Err)
-import           Grammar.Par               (myLexer, pProgram)
-import           Grammar.Print             (printTree)
+-- import           Codegen.Codegen           (compile)
+import           GHC.IO.Handle.Text      (hPutStrLn)
+import           Grammar.ErrM            (Err)
+import           Grammar.Par             (myLexer, pProgram)
+import           Grammar.Print           (printTree)
 
-import           LambdaLifter.LambdaLifter (lambdaLift)
-import           Renamer.Renamer           (rename)
-import           System.Environment        (getArgs)
-import           System.Exit               (exitFailure, exitSuccess)
-import           System.IO                 (stderr)
-import           TypeChecker.TypeChecker   (typecheck)
+-- import           LambdaLifter.LambdaLifter (lambdaLift)
+import           Renamer.Renamer         (rename)
+import           System.Environment      (getArgs)
+import           System.Exit             (exitFailure, exitSuccess)
+import           System.IO               (stderr)
+import           TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
 main =
@@ -37,14 +37,14 @@ main' s = do
     typechecked <- fromTypeCheckerErr $ typecheck renamed
     printToErr $ printTree typechecked
 
-    printToErr "\n-- Lambda Lifter --"
-    let lifted = lambdaLift typechecked
-    printToErr $ printTree lifted
+    -- printToErr "\n-- Lambda Lifter --"
+    -- let lifted = lambdaLift typechecked
+    -- printToErr $ printTree lifted
 
-    printToErr "\n -- Printing compiler output to stdout --"
-    compiled <- fromCompilerErr $ compile lifted
-    putStrLn compiled
-    writeFile "llvm.ll" compiled
+    -- printToErr "\n -- Printing compiler output to stdout --"
+    -- compiled <- fromCompilerErr $ compile lifted
+    -- putStrLn compiled
+    -- writeFile "llvm.ll" compiled
 
     exitSuccess
 
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 0d9ace9..d09a002 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -3,6 +3,7 @@
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use traverse_" #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+{-# HLINT ignore "Use zipWithM" #-}
 
 module TypeChecker.TypeChecker where
 
@@ -16,6 +17,7 @@ import qualified Data.Map                  as M
 import           Data.Set                  (Set)
 import qualified Data.Set                  as S
 
+import           Data.Foldable             (traverse_)
 import           Grammar.Abs
 import           Grammar.Print             (printTree)
 import qualified TypeChecker.TypeCheckerIr as T
@@ -24,10 +26,12 @@ import qualified TypeChecker.TypeCheckerIr as T
 data Poly = Forall [Ident] Type
     deriving Show
 
-newtype Ctx = Ctx { vars  :: Map Ident Poly }
+newtype Ctx = Ctx { vars   :: Map Ident Poly
+               }
 
-data Env = Env { count :: Int
-               , sigs  :: Map Ident Type
+data Env = Env { count  :: Int
+               , sigs   :: Map Ident Type
+               , dtypes :: Map Ident Type
                }
 
 type Error = String
@@ -36,7 +40,7 @@ type Subst = Map Ident Type
 type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
 initCtx = Ctx mempty
-initEnv = Env 0 mempty
+initEnv = Env 0 mempty mempty
 
 runPretty :: Exp -> Either Error String
 runPretty = fmap (printTree . fst). run . inferExp
@@ -50,21 +54,44 @@ runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 typecheck :: Program -> Either Error T.Program
 typecheck = run . checkPrg
 
+checkData :: Data -> Infer ()
+checkData d = case d of
+    (Data typ@(TConstr name _) constrs) -> do
+        traverse_ (\(Constructor name' t')
+                    -> if typ == retType t'
+                          then insertConstr name' t' else
+                          throwError $
+                              unwords
+                              [ "return type of constructor:"
+                              , printTree name
+                              , "with type:"
+                              , printTree (retType t')
+                              , "does not match data: "
+                              , printTree typ]) constrs
+    _ -> throwError "Data type incorrectly declared"
+  where
+    retType :: Type -> Type
+    retType (TArr _ t2) = retType t2
+    retType a           = a
+
 checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
-    let bs' = getBinds bs
-    traverse (\(Bind n t _ _ _) -> insertSig n t) bs'
-    bs' <- mapM checkBind bs'
-    return $ T.Program bs'
+    preRun bs
+    T.Program <$> checkDef bs
   where
-    getBinds :: [Def] -> [Bind]
-    getBinds = map toBind . filter isBind
-    isBind :: Def -> Bool
-    isBind (DBind _) = True
-    isBind _         = True
-    toBind :: Def -> Bind
-    toBind (DBind bind) = bind
-    toBind _            = error "Can't convert DData to Bind"
+    preRun :: [Def] -> Infer ()
+    preRun [] = return ()
+    preRun (x:xs) = case x of
+        DBind (Bind n t _ _ _ ) -> insertSig n t >> preRun xs
+        DData d@(Data _ _)      -> checkData d >> preRun xs
+
+    checkDef :: [Def] -> Infer [T.Def]
+    checkDef [] = return []
+    checkDef (x:xs) = case x of
+        (DBind b) -> do
+            b' <- checkBind b
+            fmap (T.DBind b' :) (checkDef xs)
+        (DData d)    -> fmap (T.DData d :) (checkDef xs)
 
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
@@ -77,15 +104,18 @@ checkBind (Bind n t _ args e) = do
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip EAbs)
 
+-- | Check if two types are considered equal
+--   For the purpose of the algorithm two polymorphic types are always considered equal
 typeEq :: Type -> Type -> Bool
-typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
-typeEq (TMono a) (TMono b)     = a == b
-typeEq (TPol _) (TPol _)       = True
-typeEq _ _                     = False
+typeEq (TArr l r) (TArr l' r')            = typeEq l l' && typeEq r r'
+typeEq (TMono a) (TMono b)                = a == b
+typeEq (TConstr name a) (TConstr name' b) = name == name' && and (zipWith typeEq a b)
+typeEq (TPol _) (TPol _)                  = True
+typeEq _ _                                = False
 
 inferExp :: Exp -> Infer (Type, T.Exp)
 inferExp e = do
-    (s, t, e') <- w e
+    (s, t, e') <- algoW e
     let subbed = apply s t
     return (subbed, replace subbed e')
 
@@ -98,19 +128,26 @@ replace t = \case
     T.EAdd _ e1 e2 -> T.EAdd t e1 e2
     T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2
 
-w :: Exp -> Infer (Subst, Type, T.Exp)
-w = \case
+algoW :: Exp -> Infer (Subst, Type, T.Exp)
+algoW = \case
 
     EAnn e t -> do
-        (s1, t', e') <- w e
+        (s1, t', e') <- algoW e
         applySt s1 $ do
             s2 <- unify (apply s1 t) t'
             return (s2 `compose` s1, t, e')
 
+-- | ------------------
+-- |   Γ ⊢ e₀ : Int, ∅
+
     ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit  (TMono "Int") (LInt n))
 
     ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
 
+-- | x : σ ∈ Γ   τ = inst(σ)
+-- | ----------------------
+-- |     Γ ⊢ x : τ, ∅
+
     EId i -> do
         var <- asks vars
         case M.lookup i var of
@@ -118,42 +155,67 @@ w = \case
           Nothing -> do
               sig <- gets sigs
               case M.lookup i sig of
-                  Nothing -> throwError $ "Unbound variable: " ++ show i
                   Just t  -> return (nullSubst, t, T.EId (i, t))
+                  Nothing -> do
+                    constr <- gets dtypes
+                    case M.lookup i constr of
+                      Just t  -> return (nullSubst, t, T.EId (i, t))
+                      Nothing -> throwError $ "Unbound variable: " ++ show i
+
+-- | τ = newvar   Γ, x : τ ⊢ e : τ', S
+-- | ---------------------------------
+-- |     Γ ⊢ w λx. e : Sτ → τ', S
 
     EAbs name e -> do
         fr <- fresh
         withBinding name (Forall [] fr) $ do
-            (s1, t', e') <- w e
+            (s1, t', e') <- algoW e
             let varType = apply s1 fr
             let newArr = TArr varType t'
             return (s1, newArr, T.EAbs newArr (name, varType) e')
 
+-- | Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
+-- | s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
+-- | ------------------------------------------
+-- |        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
+-- This might be wrong
+
     EAdd e0 e1 -> do
-        (s1, t0, e0') <- w e0
+        (s1, t0, e0') <- algoW e0
         applySt s1 $ do
-            (s2, t1, e1') <- w e1
-            applySt s2 $ do
-                s3 <- unify (apply s2 t0) (TMono "Int")
-                s4 <- unify (apply s3 t1) (TMono "Int")
-                return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
+            (s2, t1, e1') <- algoW e1
+            -- applySt s2 $ do
+            s3 <- unify (apply s2 t0) (TMono "Int")
+            s4 <- unify (apply s3 t1) (TMono "Int")
+            return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
+
+-- | Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
+-- | τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
+-- | --------------------------------------
+-- |       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
 
     EApp e0 e1 -> do
         fr <- fresh
-        (s0, t0, e0') <- w e0
+        (s0, t0, e0') <- algoW e0
         applySt s0 $ do
-            (s1, t1, e1') <- w e1
+            (s1, t1, e1') <- algoW e1
             -- applySt s1 $ do
             s2 <- unify (apply s1 t0) (TArr t1 fr)
             let t = apply s2 fr
             return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
 
+-- | Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
+-- | ----------------------------------------------
+-- |        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
+
+-- The bar over S₀ and Γ means "generalize"
+
     ELet name e0 e1 -> do
-        (s1, t1, e0') <- w e0
+        (s1, t1, e0') <- algoW e0
         env <- asks vars
         let t' = generalize (apply s1 env) t1
         withBinding name t' $ do
-            (s2, t2, e1') <- w e1
+            (s2, t2, e1') <- algoW e1
             return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' )
 
     ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b
@@ -168,6 +230,12 @@ unify t0 t1 = case (t0, t1) of
     (TPol a, b) -> occurs a b
     (a, TPol b) -> occurs b a
     (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
+    -- | TODO: Figure out a cleaner way to express the same thing
+    (TConstr name t, TConstr name' t') -> if name == name' && length t == length t'
+                                            then do
+                                                xs <- sequence $ zipWith unify t t'
+                                                return $ foldr compose nullSubst xs
+                                            else throwError $ unwords ["Type constructor:", printTree name, "(" ++ printTree t ++ ")", "does not match with:", printTree name', "(" ++ printTree t' ++ ")"]
     (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
 
 -- | Check if a type is contained in another type.
@@ -202,9 +270,11 @@ class FreeVars t where
 
 instance FreeVars Type where
   free :: Type -> Set Ident
-  free (TPol a)   = S.singleton a
-  free (TMono _)  = mempty
-  free (TArr a b) = free a `S.union` free b
+  free (TPol a)      = S.singleton a
+  free (TMono _)     = mempty
+  free (TArr a b)    = free a `S.union` free b
+  -- | Not guaranteed to be correct
+  free (TConstr _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a
   apply :: Subst -> Type -> Type
   apply sub t = do
     case t of
@@ -213,6 +283,7 @@ instance FreeVars Type where
                    Nothing -> TPol a
                    Just t  -> t
         TArr a b -> TArr (apply sub a) (apply sub b)
+        TConstr name a -> TConstr name (map (apply sub) a)
 
 instance FreeVars Poly where
   free :: Poly -> Set Ident
@@ -248,3 +319,7 @@ withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
 -- | Insert a function signature into the environment
 insertSig :: Ident -> Type -> Infer ()
 insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
+
+-- | Insert a constructor with its data type
+insertConstr :: Ident -> Type -> Infer ()
+insertConstr i t = modify (\st -> st { dtypes = M.insert i t (dtypes st) })
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index c85ebcc..ee02416 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -5,12 +5,12 @@ module TypeChecker.TypeCheckerIr
   , module TypeChecker.TypeCheckerIr
   ) where
 
-import           Grammar.Abs   (Ident (..), Literal (..), Type (..))
+import           Grammar.Abs   (Data (..), Ident (..), Literal (..), Type (..))
 import           Grammar.Print
 import           Prelude
 import qualified Prelude       as C (Eq, Ord, Read, Show)
 
-newtype Program = Program [Bind]
+newtype Program = Program [Def]
   deriving (C.Eq, C.Ord, C.Show, C.Read)
 
 data Exp
@@ -22,11 +22,18 @@ data Exp
     | EAbs Type Id Exp
       deriving (C.Eq, C.Ord, C.Read, C.Show)
 
+data Def = DBind Bind | DData Data
+    deriving (C.Eq, C.Ord, C.Read, C.Show)
+
 type Id = (Ident, Type)
 
 data Bind = Bind Id [Id] Exp
     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
+instance Print Def where
+  prt i (DBind bind) = prt i bind
+  prt i (DData d)    = prt i d
+
 instance Print Program where
     prt i (Program sc) = prPrec i 0 $ prt 0 sc
 
@@ -75,7 +82,7 @@ instance Print Exp where
                     , doc $ showString "in"
                     , prt 0 e
                     ]
-    EApp t e1 e2 -> prPrec i 2 $ concatD
+    EApp _ e1 e2 -> prPrec i 2 $ concatD
                         [ prt 2 e1
                         , prt 3 e2
                         ]
diff --git a/test_program b/test_program
index 69a2c20..5c2a164 100644
--- a/test_program
+++ b/test_program
@@ -1,2 +1,14 @@
-main : _Int ;
-main = 3 + 3 ;
+data List ('a) where;
+    Nil : List ('a),
+    Cons : 'a -> List ('a) -> List ('a) ;
+
+main : List (_Int) ;
+main = Cons 1 (Cons 0 Nil) ;
+
+data Bool () where;
+    True : Bool (),
+    False : Bool ();
+
+boolean : Bool (_Int);
+boolean = True ;
+    

From d23d417ff36040a712f9b015741e46be86cba9b9 Mon Sep 17 00:00:00 2001
From: Sebastian Selander <70573736+sebastianselander@users.noreply.github.com>
Date: Mon, 27 Feb 2023 19:38:45 +0100
Subject: [PATCH 43/71] Update TypeChecker.hs

---
 src/TypeChecker/TypeChecker.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index d09a002..b938477 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -109,7 +109,9 @@ checkBind (Bind n t _ args e) = do
 typeEq :: Type -> Type -> Bool
 typeEq (TArr l r) (TArr l' r')            = typeEq l l' && typeEq r r'
 typeEq (TMono a) (TMono b)                = a == b
-typeEq (TConstr name a) (TConstr name' b) = name == name' && and (zipWith typeEq a b)
+typeEq (TConstr name a) (TConstr name' b) = if length a == length b  
+                                                then name == name' && and (zipWith typeEq a b)
+                                                else False
 typeEq (TPol _) (TPol _)                  = True
 typeEq _ _                                = False
 

From 05313652f9951a157bd9599118502a5f1793e620 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 28 Feb 2023 17:15:48 +0100
Subject: [PATCH 44/71] unit tests, started on pattern matching

---
 Grammar.cf                       |  41 +++++-------
 language.cabal                   |   2 +-
 src/Main.hs                      |  24 +++----
 src/Renamer/Renamer.hs           |   1 -
 src/TypeChecker/CheckInj.hs      |  27 ++++++++
 src/TypeChecker/TypeChecker.hs   |  78 ++++++++++++-----------
 src/TypeChecker/TypeCheckerIr.hs |  44 ++++++++++---
 test_program                     |  22 +++----
 tests/Tests.hs                   | 106 +++++++++++++++++++++----------
 9 files changed, 212 insertions(+), 133 deletions(-)
 create mode 100644 src/TypeChecker/CheckInj.hs

diff --git a/Grammar.cf b/Grammar.cf
index 96554bb..dda87b4 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -8,6 +8,18 @@ separator Def ";" ;
 Bind. Bind ::= Ident ":" Type ";"
                Ident [Ident] "=" Exp ;
 
+Data. Data ::= "data" Type "where" "{"
+               [Constructor] "}" ;
+
+separator nonempty Constructor "" ;
+
+Constructor. Constructor ::= Ident ":" Type ;
+
+TMono.   Type1 ::= "_" Ident ;
+TPol.    Type1 ::= "'" Ident ;
+TConstr. Type1 ::= Ident "(" [Type] ")" ; 
+TArr.    Type  ::= Type1 "->" Type ;
+
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
 EId.    Exp4 ::= Ident ;
 ELit.   Exp4 ::= Literal ;
@@ -15,43 +27,24 @@ EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
 ELet.   Exp  ::= "let" Ident "=" Exp "in" Exp ; 
 EAbs.   Exp  ::= "\\" Ident "." Exp ;
-ECase.  Exp ::= "case" Exp "of" "{" [Inj]  "}";
+ECase.  Exp  ::= "case" Exp "of" "{" [Inj] "}";
 
 LInt. Literal ::= Integer ;
 
 Inj. Inj ::= Init "=>" Exp ;
-terminator Inj ";" ;
+separator nonempty Inj ";" ;
 
-InitLit. Init ::= Literal ;
-InitConstr. Init ::= Ident [Match] ;
-InitCatch. Init ::= "_" ;
-
-LMatch. Match ::= Literal ;
-IMatch. Match ::= Ident ;
-InitMatch. Match ::= Ident Match ;
-separator Match " " ;
-
-TMono.   Type1 ::= "_" Ident ;
-TPol.    Type1 ::= "'" Ident ;
-TConstr. Type1  ::= Ident "(" [Type] ")" ; 
-TArr.    Type ::= Type1 "->" Type ;
+InitLit. Init    ::= Literal ;
+InitConstr. Init ::= Ident [Ident] ;
+InitCatch. Init  ::= "_" ;
 
 separator Type " " ;
 coercions Type 2 ;
 
--- shift/reduce problem here
-Data. Data ::= "data" Type "where" ";"
-               [Constructor];
-
-separator Constructor "," ;
-
-Constructor. Constructor ::= Ident ":" Type ;
-
 -- This doesn't seem to work so we'll have to live with ugly keywords for now
 -- token Poly upper (letter | digit | '_')* ;
 -- token Mono lower (letter | digit | '_')* ;
 
-separator Bind ";" ;
 separator Ident " ";
 
 coercions Exp 5 ;
diff --git a/language.cabal b/language.cabal
index 3556367..637d9f7 100644
--- a/language.cabal
+++ b/language.cabal
@@ -47,7 +47,6 @@ executable language
       , either
       , extra
       , array
-      , QuickCheck
 
     default-language: GHC2021
 
@@ -76,6 +75,7 @@ Test-suite language-testsuite
       , either
       , extra
       , array
+      , hspec
       , QuickCheck
 
     default-language: GHC2021
diff --git a/src/Main.hs b/src/Main.hs
index 316c599..8e62f2b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,7 +3,6 @@
 module Main where
 
 -- import           Codegen.Codegen           (compile)
-import           GHC.IO.Handle.Text      (hPutStrLn)
 import           Grammar.ErrM            (Err)
 import           Grammar.Par             (myLexer, pProgram)
 import           Grammar.Print           (printTree)
@@ -12,7 +11,6 @@ import           Grammar.Print           (printTree)
 import           Renamer.Renamer         (rename)
 import           System.Environment      (getArgs)
 import           System.Exit             (exitFailure, exitSuccess)
-import           System.IO               (stderr)
 import           TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
@@ -25,32 +23,28 @@ main' :: String -> IO ()
 main' s = do
     file <- readFile s
 
-    printToErr "-- Parse Tree -- "
+    putStrLn "-- Parse Tree -- "
     parsed <- fromSyntaxErr . pProgram $ myLexer file
-    printToErr $ printTree parsed
+    putStrLn $ printTree parsed
 
-    printToErr "\n-- Renamer --"
+    putStrLn "\n-- Renamer --"
     let renamed = rename parsed
-    printToErr $ printTree renamed
+    putStrLn $ printTree renamed
 
-    printToErr "\n-- TypeChecker --"
+    putStrLn "\n-- TypeChecker --"
     typechecked <- fromTypeCheckerErr $ typecheck renamed
-    printToErr $ printTree typechecked
+    putStrLn $ printTree typechecked
 
-    -- printToErr "\n-- Lambda Lifter --"
+    -- putStrLn "\n-- Lambda Lifter --"
     -- let lifted = lambdaLift typechecked
-    -- printToErr $ printTree lifted
+    -- putStrLn $ printTree lifted
 
-    -- printToErr "\n -- Printing compiler output to stdout --"
+    -- putStrLn "\n -- Printing compiler output to stdout --"
     -- compiled <- fromCompilerErr $ compile lifted
     -- putStrLn compiled
-    -- writeFile "llvm.ll" compiled
 
     exitSuccess
 
-printToErr :: String -> IO ()
-printToErr = hPutStrLn stderr
-
 fromCompilerErr :: Err a -> IO a
 fromCompilerErr =
     either
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 1ea892c..24582f6 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -28,7 +28,6 @@ rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs)
         pure . DBind $ Bind name t name parms' rhs'
     renameSc _ def = pure def
 
---
 
 -- | Rename monad. State holds the number of renamed names.
 newtype Rn a = Rn { runRn :: State Int a }
diff --git a/src/TypeChecker/CheckInj.hs b/src/TypeChecker/CheckInj.hs
new file mode 100644
index 0000000..c5845df
--- /dev/null
+++ b/src/TypeChecker/CheckInj.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+module TypeChecker.CheckInj where
+
+import           TypeChecker.TypeChecker
+import qualified TypeChecker.TypeCheckerIr as T
+import           TypeChecker.TypeCheckerIr (Infer)
+
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Data.Functor.Identity     (Identity, runIdentity)
+import           Data.Map                  (Map)
+import qualified Data.Map                  as M
+
+import           Grammar.Abs
+import           Grammar.Print             (printTree)
+
+
+checkInj :: Inj -> Infer T.Inj
+checkInj (Inj it expr) = do
+    (_, e') <- inferExp expr
+    t' <- initType it
+    return $ T.Inj (it, t') e'
+
+initType :: Init -> Infer Type
+initType = undefined
+
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index b938477..80a5289 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,10 +1,7 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Use traverse_" #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# HLINT ignore "Use zipWithM" #-}
 
+-- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
 
 import           Control.Monad.Except
@@ -21,23 +18,9 @@ import           Data.Foldable             (traverse_)
 import           Grammar.Abs
 import           Grammar.Print             (printTree)
 import qualified TypeChecker.TypeCheckerIr as T
+import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
+                                            Poly (..), Subst)
 
--- | A data type representing type variables
-data Poly = Forall [Ident] Type
-    deriving Show
-
-newtype Ctx = Ctx { vars   :: Map Ident Poly
-               }
-
-data Env = Env { count  :: Int
-               , sigs   :: Map Ident Type
-               , dtypes :: Map Ident Type
-               }
-
-type Error = String
-type Subst = Map Ident Type
-
-type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
 initCtx = Ctx mempty
 initEnv = Env 0 mempty mempty
@@ -98,7 +81,11 @@ checkBind (Bind n t _ args e) = do
     (t', e') <- inferExp $ makeLambda e (reverse args)
     s <- unify t t'
     let t'' = apply s t
-    unless (t `typeEq` t'') (throwError $ unwords ["Top level signature", printTree t, "does not match body with type:", printTree t''])
+    unless (t `typeEq` t'') (throwError $ unwords ["Top level signature"
+                                                  , printTree t
+                                                  , "does not match body with inferred type:"
+                                                  , printTree t''
+                                                  ])
     return $ T.Bind (n, t) [] e'
   where
     makeLambda :: Exp -> [Ident] -> Exp
@@ -109,12 +96,17 @@ checkBind (Bind n t _ args e) = do
 typeEq :: Type -> Type -> Bool
 typeEq (TArr l r) (TArr l' r')            = typeEq l l' && typeEq r r'
 typeEq (TMono a) (TMono b)                = a == b
-typeEq (TConstr name a) (TConstr name' b) = if length a == length b  
-                                                then name == name' && and (zipWith typeEq a b)
-                                                else False
+typeEq (TConstr name a) (TConstr name' b) = length a == length b
+                                            && name == name'
+                                            && and (zipWith typeEq a b)
 typeEq (TPol _) (TPol _)                  = True
 typeEq _ _                                = False
 
+isMoreGeneral :: Type -> Type -> Bool
+isMoreGeneral _ (TPol _)            = True
+isMoreGeneral (TArr a b) (TArr c d) = isMoreGeneral a c && isMoreGeneral b d
+isMoreGeneral a b                   = a == b
+
 inferExp :: Exp -> Infer (Type, T.Exp)
 inferExp e = do
     (s, t, e') <- algoW e
@@ -123,24 +115,30 @@ inferExp e = do
 
 replace :: Type -> T.Exp -> T.Exp
 replace t = \case
-    T.ELit _ e -> T.ELit t e
-    T.EId (n, _) -> T.EId (n, t)
-    T.EAbs _ name e -> T.EAbs t name e
-    T.EApp _ e1 e2 -> T.EApp t e1 e2
-    T.EAdd _ e1 e2 -> T.EAdd t e1 e2
+    T.ELit _ e                        -> T.ELit t e
+    T.EId (n, _)                      -> T.EId (n, t)
+    T.EAbs _ name e                   -> T.EAbs t name e
+    T.EApp _ e1 e2                    -> T.EApp t e1 e2
+    T.EAdd _ e1 e2                    -> T.EAdd t e1 e2
     T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2
 
 algoW :: Exp -> Infer (Subst, Type, T.Exp)
 algoW = \case
 
+    -- | TODO: Reason more about this one. Could be wrong
     EAnn e t -> do
         (s1, t', e') <- algoW e
+        unless (t `isMoreGeneral` t') (throwError $ unwords
+            ["Annotated type:"
+            , printTree t
+            , "does not match inferred type:"
+            , printTree t' ])
         applySt s1 $ do
-            s2 <- unify (apply s1 t) t'
+            s2 <- unify t t'
             return (s2 `compose` s1, t, e')
 
 -- | ------------------
--- |   Γ ⊢ e₀ : Int, ∅
+-- |   Γ ⊢ i : Int, ∅
 
     ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit  (TMono "Int") (LInt n))
 
@@ -159,7 +157,7 @@ algoW = \case
               case M.lookup i sig of
                   Just t  -> return (nullSubst, t, T.EId (i, t))
                   Nothing -> do
-                    constr <- gets dtypes
+                    constr <- gets constructors
                     case M.lookup i constr of
                       Just t  -> return (nullSubst, t, T.EId (i, t))
                       Nothing -> throwError $ "Unbound variable: " ++ show i
@@ -220,9 +218,9 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' )
 
-    ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b
+    ECase e0 injs -> undefined
 
--- | Unify two types producing a new substitution (constraint)
+-- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
 unify t0 t1 = case (t0, t1) of
     (TArr a b, TArr c d) -> do
@@ -235,9 +233,15 @@ unify t0 t1 = case (t0, t1) of
     -- | TODO: Figure out a cleaner way to express the same thing
     (TConstr name t, TConstr name' t') -> if name == name' && length t == length t'
                                             then do
-                                                xs <- sequence $ zipWith unify t t'
+                                                xs <- zipWithM unify t t'
                                                 return $ foldr compose nullSubst xs
-                                            else throwError $ unwords ["Type constructor:", printTree name, "(" ++ printTree t ++ ")", "does not match with:", printTree name', "(" ++ printTree t' ++ ")"]
+                                            else throwError $ unwords
+                                                ["Type constructor:"
+                                                , printTree name
+                                                , "(" ++ printTree t ++ ")"
+                                                , "does not match with:"
+                                                , printTree name'
+                                                , "(" ++ printTree t' ++ ")"]
     (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
 
 -- | Check if a type is contained in another type.
@@ -324,4 +328,4 @@ insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
 
 -- | Insert a constructor with its data type
 insertConstr :: Ident -> Type -> Infer ()
-insertConstr i t = modify (\st -> st { dtypes = M.insert i t (dtypes st) })
+insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors st) })
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index ee02416..82956b8 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -1,14 +1,33 @@
 {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr
-  ( module Grammar.Abs
-  , module TypeChecker.TypeCheckerIr
-  ) where
+module TypeChecker.TypeCheckerIr where
 
-import           Grammar.Abs   (Data (..), Ident (..), Literal (..), Type (..))
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Data.Functor.Identity (Identity)
+import           Data.Map              (Map)
+import           Grammar.Abs           (Data (..), Ident (..), Init (..),
+                                        Literal (..), Type (..))
 import           Grammar.Print
 import           Prelude
-import qualified Prelude       as C (Eq, Ord, Read, Show)
+import qualified Prelude               as C (Eq, Ord, Read, Show)
+
+-- | A data type representing type variables
+data Poly = Forall [Ident] Type
+    deriving Show
+
+newtype Ctx = Ctx { vars :: Map Ident Poly }
+
+data Env = Env { count        :: Int
+               , sigs         :: Map Ident Type
+               , constructors :: Map Ident Type
+               }
+
+type Error = String
+type Subst = Map Ident Type
+
+type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
 newtype Program = Program [Def]
   deriving (C.Eq, C.Ord, C.Show, C.Read)
@@ -22,6 +41,9 @@ data Exp
     | EAbs Type Id Exp
       deriving (C.Eq, C.Ord, C.Read, C.Show)
 
+data Inj = Inj (Init, Type) Exp
+    deriving (C.Eq, C.Ord, C.Read, C.Show)
+
 data Def = DBind Bind | DData Data
     deriving (C.Eq, C.Ord, C.Read, C.Show)
 
@@ -30,6 +52,10 @@ type Id = (Ident, Type)
 data Bind = Bind Id [Id] Exp
     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
+instance Print [Def] where
+  prt _ []     = concatD []
+  prt _ (x:xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
+
 instance Print Def where
   prt i (DBind bind) = prt i bind
   prt i (DData d)    = prt i d
@@ -41,16 +67,16 @@ instance Print Bind where
     prt i (Bind (t, name) parms rhs) = prPrec i 0 $ concatD
         [ prt 0 name
         , doc $ showString ":"
-        , prt 0 t
+        , prt 1 t
         , prtIdPs 0 parms
         , doc $ showString "="
-        , prt 0 rhs
+        , prt 2 rhs
         ]
 
 instance Print [Bind] where
   prt _ []     = concatD []
   prt _ [x]    = concatD [prt 0 x]
-  prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
+  prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
 
 prtIdPs :: Int -> [Id] -> Doc
 prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
diff --git a/test_program b/test_program
index 5c2a164..0cc17b3 100644
--- a/test_program
+++ b/test_program
@@ -1,14 +1,12 @@
-data List ('a) where;
-    Nil : List ('a),
-    Cons : 'a -> List ('a) -> List ('a) ;
+data List ('a) where {
+    Nil : List ('a) 
+    Cons : 'a -> List ('a) -> List ('a) 
+};
 
-main : List (_Int) ;
+data Bool () where {
+    True : Bool () 
+    False : Bool ()
+};
+
+main : List ('a) ;
 main = Cons 1 (Cons 0 Nil) ;
-
-data Bool () where;
-    True : Bool (),
-    False : Bool ();
-
-boolean : Bool (_Int);
-boolean = True ;
-    
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 46a9a3f..5c52939 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -1,56 +1,94 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use <$>" #-}
+{-# HLINT ignore "Use camelCase" #-}
 
 module Main where
 
-import           Control.Monad.Except
+import           Data.Either               (isLeft, isRight)
+import           Data.Map                  (Map)
+import qualified Data.Map                  as M
 import           Grammar.Abs
+import           Test.Hspec
 import           Test.QuickCheck
 import           TypeChecker.TypeChecker
 import qualified TypeChecker.TypeCheckerIr as T
+import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
+                                            Poly (..))
 
 main :: IO ()
-main = do
-    quickCheck prop_isInt
-    quickCheck prop_idAbs_generic
+main = hspec $ do
+    infer_elit
+    infer_eann
+    infer_eid
+    infer_eabs
+    infer_eapp
 
-newtype AbsExp = AE Exp deriving Show
-newtype EIntExp = EI Exp deriving Show
+infer_elit = describe "algoW used on ELit" $ do
+    it "infers the type mono Int" $ do
+        getType (ELit (LInt 0)) `shouldBe` Right (TMono "Int")
 
-instance Arbitrary EIntExp where
-  arbitrary = genInt
+    it "infers the type mono Int" $ do
+        getType (ELit (LInt 9999)) `shouldBe` Right (TMono "Int")
 
-instance Arbitrary AbsExp where
-  arbitrary = genLambda
+infer_eann = describe "algoW used on EAnn" $ do
+    it "infers the type and checks if the annotated type matches" $ do
+        getType (EAnn (ELit $ LInt 0) (TMono "Int")) `shouldBe` Right (TMono "Int")
 
-getType :: Infer (Type, T.Exp) -> Either Error Type
-getType ie = case run ie of
-    Left err    -> Left err
-    Right (t,e) -> return t
+    it "fails if the annotated type does not match with the inferred type" $ do
+        getType (EAnn (ELit $ LInt 0) (TPol "a")) `shouldSatisfy` isLeft
 
-genInt :: Gen EIntExp
-genInt = EI . ELit . LInt <$> arbitrary
+    it "should be possible to annotate with a more specific type" $ do
+        let annotated_lambda = EAnn (EAbs "x" (EId "x")) (TArr (TMono "Int") (TMono "Int"))
+         in getType annotated_lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int"))
 
-genLambda :: Gen AbsExp
-genLambda = do
-    str <- arbitrary @String
-    let str' = Ident str
-    return $ AE $ EAbs str' (EId str')
+    it "should fail if the annotated type is more general than the inferred type" $ do
+        getType (EAnn (ELit (LInt 0)) (TPol "a")) `shouldSatisfy` isLeft
 
-prop_idAbs_generic :: AbsExp -> Bool
-prop_idAbs_generic (AE e) = case getType (inferExp e) of
-    Left _  -> False
-    Right t -> isGenericArr t
+    it "should fail if the annotated type is an arrow but the annotated type is not" $ do
+        getType (EAnn (EAbs "x" (EId "x")) (TPol "a")) `shouldSatisfy` isLeft
 
-prop_isInt :: EIntExp -> Bool
-prop_isInt (EI e) = case getType (inferExp e) of
-    Left _  -> False
-    Right t -> t == int
+infer_eid = describe "algoW used on EId" $ do
+    it "should fail if the variable is not added to the environment" $ do
+        property $ \x -> getType (EId (Ident (x :: String))) `shouldSatisfy` isLeft
 
-int :: Type
-int = TMono "Int"
+    it "should succeed if the type exist in the environment" $ do
+        property $ \x -> do
+            let env = Env 0 mempty mempty
+            let t = Forall [] (TPol "a")
+            let ctx = Ctx (M.singleton (Ident (x :: String)) t)
+            getTypeC env ctx (EId (Ident x)) `shouldBe` Right (TPol "a")
 
-isGenericArr :: Type -> Bool
-isGenericArr (TArr (TPol a) (TPol b)) = a == b
-isGenericArr _                        = False
+infer_eabs = describe "algoW used on EAbs" $ do
+    it "should infer the argument type as int if the variable is used as an int" $ do
+        let lambda = EAbs "x" (EAdd (EId "x") (ELit (LInt 0)))
+        getType lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int"))
+
+    it "should infer the argument type as polymorphic if it is not used in the lambda" $ do
+        let lambda = EAbs "x" (ELit (LInt 0))
+        getType lambda `shouldSatisfy` isArrowPolyToMono
+    it "should infer a variable as function if used as one" $ do
+        let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x")))
+        let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True
+            isOk _                                                                = False
+        getType lambda `shouldSatisfy` isOk
+
+infer_eapp = describe "algoW used on EApp" $ do
+    it "should fail if a variable is applied to itself (occurs check)" $ do
+        property $ \x -> do
+            let env = Env 0 mempty mempty
+            let t = Forall [] (TPol "a")
+            let ctx = Ctx (M.singleton (Ident (x :: String)) t)
+            getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed"
+
+isArrowPolyToMono :: Either Error Type -> Bool
+isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True
+isArrowPolyToMono _                                 = False
+
+-- | Empty environment
+getType :: Exp -> Either Error Type
+getType e = pure fst <*> run (inferExp e)
+
+-- | Custom environment
+getTypeC :: Env -> Ctx -> Exp -> Either Error Type
+getTypeC env ctx e = pure fst <*> runC env ctx (inferExp e)

From 2401b6437bc3f49f078b9cf19ec20ad0f9514c11 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 2 Mar 2023 16:05:43 +0100
Subject: [PATCH 45/71] continued work pattern matching

---
 Grammar.cf                       | 16 +++-----
 Justfile                         | 17 ++++++++
 src/TypeChecker/CheckInj.hs      | 27 ------------
 src/TypeChecker/TypeChecker.hs   | 70 ++++++++++++++++++++++++--------
 src/TypeChecker/TypeCheckerIr.hs |  5 +--
 test_program                     |  2 +-
 6 files changed, 79 insertions(+), 58 deletions(-)
 create mode 100644 Justfile
 delete mode 100644 src/TypeChecker/CheckInj.hs

diff --git a/Grammar.cf b/Grammar.cf
index dda87b4..37305e2 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -8,18 +8,19 @@ separator Def ";" ;
 Bind. Bind ::= Ident ":" Type ";"
                Ident [Ident] "=" Exp ;
 
-Data. Data ::= "data" Type "where" "{"
-               [Constructor] "}" ;
-
-separator nonempty Constructor "" ;
+Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ;
 
 Constructor. Constructor ::= Ident ":" Type ;
+separator nonempty Constructor "" ;
 
 TMono.   Type1 ::= "_" Ident ;
 TPol.    Type1 ::= "'" Ident ;
-TConstr. Type1 ::= Ident "(" [Type] ")" ; 
+TConstr. Type1 ::= Constr ;
 TArr.    Type  ::= Type1 "->" Type ;
 
+Constr.  Constr ::= Ident "(" [Type] ")" ;
+
+-- TODO: Move literal to its own thing since it's reused in Init as well.
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
 EId.    Exp4 ::= Ident ;
 ELit.   Exp4 ::= Literal ;
@@ -41,14 +42,9 @@ InitCatch. Init  ::= "_" ;
 separator Type " " ;
 coercions Type 2 ;
 
--- This doesn't seem to work so we'll have to live with ugly keywords for now
--- token Poly upper (letter | digit | '_')* ;
--- token Mono lower (letter | digit | '_')* ;
-
 separator Ident " ";
 
 coercions Exp 5 ;
 
 comment "--" ;
 comment "{-" "-}" ;
-
diff --git a/Justfile b/Justfile
new file mode 100644
index 0000000..a625e71
--- /dev/null
+++ b/Justfile
@@ -0,0 +1,17 @@
+alias b := build
+
+build:
+    bnfc -o src -d Grammar.cf
+
+# clean the generated directories
+clean:
+    rm -r src/Grammar
+    rm language
+
+# run all tests
+test:
+    cabal test
+
+# compile a specific file
+run FILE:
+    cabal run language {{FILE}}
diff --git a/src/TypeChecker/CheckInj.hs b/src/TypeChecker/CheckInj.hs
deleted file mode 100644
index c5845df..0000000
--- a/src/TypeChecker/CheckInj.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-module TypeChecker.CheckInj where
-
-import           TypeChecker.TypeChecker
-import qualified TypeChecker.TypeCheckerIr as T
-import           TypeChecker.TypeCheckerIr (Infer)
-
-import           Control.Monad.Except
-import           Control.Monad.Reader
-import           Control.Monad.State
-import           Data.Functor.Identity     (Identity, runIdentity)
-import           Data.Map                  (Map)
-import qualified Data.Map                  as M
-
-import           Grammar.Abs
-import           Grammar.Print             (printTree)
-
-
-checkInj :: Inj -> Infer T.Inj
-checkInj (Inj it expr) = do
-    (_, e') <- inferExp expr
-    t' <- initType it
-    return $ T.Inj (it, t') e'
-
-initType :: Init -> Infer Type
-initType = undefined
-
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 80a5289..73139f4 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -7,7 +7,7 @@ module TypeChecker.TypeChecker where
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Control.Monad.State
-import           Data.Functor.Identity     (Identity, runIdentity)
+import           Data.Functor.Identity     (runIdentity)
 import           Data.List                 (foldl')
 import           Data.Map                  (Map)
 import qualified Data.Map                  as M
@@ -21,7 +21,6 @@ import qualified TypeChecker.TypeCheckerIr as T
 import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
                                             Poly (..), Subst)
 
-
 initCtx = Ctx mempty
 initEnv = Env 0 mempty mempty
 
@@ -39,9 +38,10 @@ typecheck = run . checkPrg
 
 checkData :: Data -> Infer ()
 checkData d = case d of
-    (Data typ@(TConstr name _) constrs) -> do
+    (Data typ@(Constr name ts) constrs) -> do
+        unless (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"])
         traverse_ (\(Constructor name' t')
-                    -> if typ == retType t'
+                    -> if TConstr typ == retType t'
                           then insertConstr name' t' else
                           throwError $
                               unwords
@@ -51,11 +51,9 @@ checkData d = case d of
                               , printTree (retType t')
                               , "does not match data: "
                               , printTree typ]) constrs
-    _ -> throwError "Data type incorrectly declared"
-  where
-    retType :: Type -> Type
-    retType (TArr _ t2) = retType t2
-    retType a           = a
+retType :: Type -> Type
+retType (TArr _ t2) = retType t2
+retType a           = a
 
 checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
@@ -86,7 +84,7 @@ checkBind (Bind n t _ args e) = do
                                                   , "does not match body with inferred type:"
                                                   , printTree t''
                                                   ])
-    return $ T.Bind (n, t) [] e'
+    return $ T.Bind (n, t) e'
   where
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip EAbs)
@@ -96,7 +94,7 @@ checkBind (Bind n t _ args e) = do
 typeEq :: Type -> Type -> Bool
 typeEq (TArr l r) (TArr l' r')            = typeEq l l' && typeEq r r'
 typeEq (TMono a) (TMono b)                = a == b
-typeEq (TConstr name a) (TConstr name' b) = length a == length b
+typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = length a == length b
                                             && name == name'
                                             && and (zipWith typeEq a b)
 typeEq (TPol _) (TPol _)                  = True
@@ -107,6 +105,10 @@ isMoreGeneral _ (TPol _)            = True
 isMoreGeneral (TArr a b) (TArr c d) = isMoreGeneral a c && isMoreGeneral b d
 isMoreGeneral a b                   = a == b
 
+isPoly :: Type -> Bool
+isPoly (TPol _) = True
+isPoly _        = False
+
 inferExp :: Exp -> Infer (Type, T.Exp)
 inferExp e = do
     (s, t, e') <- algoW e
@@ -120,7 +122,7 @@ replace t = \case
     T.EAbs _ name e                   -> T.EAbs t name e
     T.EApp _ e1 e2                    -> T.EApp t e1 e2
     T.EAdd _ e1 e2                    -> T.EAdd t e1 e2
-    T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2
+    T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
 
 algoW :: Exp -> Infer (Subst, Type, T.Exp)
 algoW = \case
@@ -216,9 +218,9 @@ algoW = \case
         let t' = generalize (apply s1 env) t1
         withBinding name t' $ do
             (s2, t2, e1') <- algoW e1
-            return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' )
+            return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1' )
 
-    ECase e0 injs -> undefined
+    ECase _ _ -> undefined
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -231,7 +233,7 @@ unify t0 t1 = case (t0, t1) of
     (a, TPol b) -> occurs b a
     (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
     -- | TODO: Figure out a cleaner way to express the same thing
-    (TConstr name t, TConstr name' t') -> if name == name' && length t == length t'
+    (TConstr (Constr name t), TConstr (Constr name' t')) -> if name == name' && length t == length t'
                                             then do
                                                 xs <- zipWithM unify t t'
                                                 return $ foldr compose nullSubst xs
@@ -280,7 +282,7 @@ instance FreeVars Type where
   free (TMono _)     = mempty
   free (TArr a b)    = free a `S.union` free b
   -- | Not guaranteed to be correct
-  free (TConstr _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a
+  free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a
   apply :: Subst -> Type -> Type
   apply sub t = do
     case t of
@@ -289,7 +291,7 @@ instance FreeVars Type where
                    Nothing -> TPol a
                    Just t  -> t
         TArr a b -> TArr (apply sub a) (apply sub b)
-        TConstr name a -> TConstr name (map (apply sub) a)
+        TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
 
 instance FreeVars Poly where
   free :: Poly -> Set Ident
@@ -329,3 +331,37 @@ insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
 -- | Insert a constructor with its data type
 insertConstr :: Ident -> Type -> Infer ()
 insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors st) })
+
+
+-------- PATTERN MATCHING ---------
+
+checkInj :: Inj -> Infer T.Inj
+checkInj (Inj it expr) = do
+    (_, e') <- inferExp expr
+    t' <- initType it
+    return $ T.Inj (it, t') e'
+
+initType :: Init -> Infer Type
+initType = \case
+    InitLit lit -> return $ litType lit
+    InitConstr c args -> do
+        st <- gets constructors
+        case M.lookup c st of
+            Nothing -> throwError $ unwords ["Constructor:", printTree c, "does not exist"]
+            Just t -> do
+                let flat = flattenType t
+                let returnType = last flat
+                if length (init flat) == length args
+                   then return returnType
+                   else throwError $ "Can't partially match on the constructor: " ++ printTree c
+                -- Ignoring the variables for now, they can not be used in the expression to the
+                -- right of '=>'
+
+    InitCatch -> return $ TPol "catch"
+
+flattenType :: Type -> [Type]
+flattenType (TArr a b) = flattenType a ++ flattenType b
+flattenType a          = [a]
+
+litType :: Literal -> Type
+litType (LInt i) = TMono "Int"
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 82956b8..ea2b902 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -49,7 +49,7 @@ data Def = DBind Bind | DData Data
 
 type Id = (Ident, Type)
 
-data Bind = Bind Id [Id] Exp
+data Bind = Bind Id Exp
     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
 instance Print [Def] where
@@ -64,11 +64,10 @@ instance Print Program where
     prt i (Program sc) = prPrec i 0 $ prt 0 sc
 
 instance Print Bind where
-    prt i (Bind (t, name) parms rhs) = prPrec i 0 $ concatD
+    prt i (Bind (t, name) rhs) = prPrec i 0 $ concatD
         [ prt 0 name
         , doc $ showString ":"
         , prt 1 t
-        , prtIdPs 0 parms
         , doc $ showString "="
         , prt 2 rhs
         ]
diff --git a/test_program b/test_program
index 0cc17b3..c5af112 100644
--- a/test_program
+++ b/test_program
@@ -8,5 +8,5 @@ data Bool () where {
     False : Bool ()
 };
 
-main : List ('a) ;
+main : List (_Int) ;
 main = Cons 1 (Cons 0 Nil) ;

From 7656b46e3f052a7360b339b196e1c74b840bfc08 Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Thu, 2 Mar 2023 22:07:38 +0100
Subject: [PATCH 46/71] a bit more work on pattern match + case expr

---
 Justfile                         |  2 --
 src/TypeChecker/TypeChecker.hs   | 32 +++++++++++++++++++++-----------
 src/TypeChecker/TypeCheckerIr.hs |  1 +
 3 files changed, 22 insertions(+), 13 deletions(-)

diff --git a/Justfile b/Justfile
index a625e71..ea2d031 100644
--- a/Justfile
+++ b/Justfile
@@ -1,5 +1,3 @@
-alias b := build
-
 build:
     bnfc -o src -d Grammar.cf
 
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 73139f4..7a2b96b 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -220,7 +220,12 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1' )
 
-    ECase _ _ -> undefined
+    ECase caseExpr injs -> do
+        (s0, t0, e0') <- algoW caseExpr
+        injs' <- mapM (checkInj t0) injs
+        undefined
+
+
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -335,15 +340,19 @@ insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors
 
 -------- PATTERN MATCHING ---------
 
-checkInj :: Inj -> Infer T.Inj
-checkInj (Inj it expr) = do
+-- case expr of, the type of 'expr' is caseType
+checkInj :: Type -> Inj -> Infer T.Inj
+checkInj caseType (Inj it expr) = do
     (_, e') <- inferExp expr
-    t' <- initType it
+    t' <- initType caseType it
     return $ T.Inj (it, t') e'
 
-initType :: Init -> Infer Type
-initType = \case
-    InitLit lit -> return $ litType lit
+initType :: Type -> Init -> Infer Type
+initType expected = \case
+    InitLit lit -> let returnType = litType lit
+                    in if expected == returnType
+                      then return expected
+                      else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected]  
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of
@@ -351,13 +360,14 @@ initType = \case
             Just t -> do
                 let flat = flattenType t
                 let returnType = last flat
-                if length (init flat) == length args
-                   then return returnType
-                   else throwError $ "Can't partially match on the constructor: " ++ printTree c
+                case (length (init flat) == length args, returnType == expected) of
+                    (True, True) -> return returnType
+                    (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c
+                    (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] 
                 -- Ignoring the variables for now, they can not be used in the expression to the
                 -- right of '=>'
 
-    InitCatch -> return $ TPol "catch"
+    InitCatch -> return expected
 
 flattenType :: Type -> [Type]
 flattenType (TArr a b) = flattenType a ++ flattenType b
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index ea2b902..a2c86f7 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -39,6 +39,7 @@ data Exp
     | EApp Type Exp Exp
     | EAdd Type Exp Exp
     | EAbs Type Id Exp
+    | ECase Type Exp [Inj]
       deriving (C.Eq, C.Ord, C.Read, C.Show)
 
 data Inj = Inj (Init, Type) Exp

From 03d7080396bcd24b91506c5fb808e3759ef564e8 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 3 Mar 2023 11:46:54 +0100
Subject: [PATCH 47/71] pattern matching works? have to test more

---
 src/Main.hs                      |  2 +-
 src/Renamer/Renamer.hs           |  4 +-
 src/TypeChecker/TypeChecker.hs   | 63 +++++++++++++++++++-------------
 src/TypeChecker/TypeCheckerIr.hs | 11 ++++++
 test_program                     | 30 ++++++++++++---
 5 files changed, 76 insertions(+), 34 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 8e62f2b..bef4a3b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -33,7 +33,7 @@ main' s = do
 
     putStrLn "\n-- TypeChecker --"
     typechecked <- fromTypeCheckerErr $ typecheck renamed
-    putStrLn $ printTree typechecked
+    putStrLn $ show typechecked
 
     -- putStrLn "\n-- Lambda Lifter --"
     -- let lifted = lambdaLift typechecked
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 24582f6..d471553 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -73,7 +73,9 @@ renameExp old_names = \case
         (new_names, e') <- renameExp old_names e
         pure (new_names, EAnn e' t)
 
-    ECase _ _ -> error "ECase NOT IMPLEMENTED YET"
+    ECase e injs -> do
+        (new_names, e') <- renameExp old_names e
+        pure (new_names, ECase e' injs)
 
 -- | Create a new name and add it to name environment.
 newName :: Names -> Ident -> Rn (Names, Ident)
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 7a2b96b..9c55388 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use mapAndUnzipM" #-}
 
 -- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
@@ -100,10 +103,12 @@ typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = length a == length
 typeEq (TPol _) (TPol _)                  = True
 typeEq _ _                                = False
 
-isMoreGeneral :: Type -> Type -> Bool
-isMoreGeneral _ (TPol _)            = True
-isMoreGeneral (TArr a b) (TArr c d) = isMoreGeneral a c && isMoreGeneral b d
-isMoreGeneral a b                   = a == b
+isMoreSpecificOrEq :: Type -> Type -> Bool
+isMoreSpecificOrEq _ (TPol _)            = True
+isMoreSpecificOrEq (TArr a b) (TArr c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
+isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2))
+  = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2)
+isMoreSpecificOrEq a b                   = a == b
 
 isPoly :: Type -> Bool
 isPoly (TPol _) = True
@@ -117,12 +122,13 @@ inferExp e = do
 
 replace :: Type -> T.Exp -> T.Exp
 replace t = \case
-    T.ELit _ e                        -> T.ELit t e
-    T.EId (n, _)                      -> T.EId (n, t)
-    T.EAbs _ name e                   -> T.EAbs t name e
-    T.EApp _ e1 e2                    -> T.EApp t e1 e2
-    T.EAdd _ e1 e2                    -> T.EAdd t e1 e2
+    T.ELit _ e                   -> T.ELit t e
+    T.EId (n, _)                 -> T.EId (n, t)
+    T.EAbs _ name e              -> T.EAbs t name e
+    T.EApp _ e1 e2               -> T.EApp t e1 e2
+    T.EAdd _ e1 e2               -> T.EAdd t e1 e2
     T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
+    T.ECase _ expr injs          -> T.ECase t expr injs
 
 algoW :: Exp -> Infer (Subst, Type, T.Exp)
 algoW = \case
@@ -130,7 +136,7 @@ algoW = \case
     -- | TODO: Reason more about this one. Could be wrong
     EAnn e t -> do
         (s1, t', e') <- algoW e
-        unless (t `isMoreGeneral` t') (throwError $ unwords
+        unless (t `isMoreSpecificOrEq` t') (throwError $ unwords
             ["Annotated type:"
             , printTree t
             , "does not match inferred type:"
@@ -218,13 +224,18 @@ algoW = \case
         let t' = generalize (apply s1 env) t1
         withBinding name t' $ do
             (s2, t2, e1') <- algoW e1
-            return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1' )
+            return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1')
 
     ECase caseExpr injs -> do
         (s0, t0, e0') <- algoW caseExpr
-        injs' <- mapM (checkInj t0) injs
-        undefined
-
+        (injs', ts) <- unzip <$> mapM (checkInj t0) injs
+        case ts of
+          [] -> throwError "Case expression missing any matches"
+          ts -> do
+            unified <- zipWithM unify ts (tail ts)
+            let unified' = foldl' compose mempty unified
+            let typ = apply unified' (head ts)
+            return (unified', typ, T.ECase typ e0' injs')
 
 
 -- | Unify two types producing a new substitution
@@ -340,19 +351,19 @@ insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors
 
 -------- PATTERN MATCHING ---------
 
--- case expr of, the type of 'expr' is caseType
-checkInj :: Type -> Inj -> Infer T.Inj
+-- "case expr of", the type of 'expr' is caseType
+checkInj :: Type -> Inj -> Infer (T.Inj, Type)
 checkInj caseType (Inj it expr) = do
-    (_, e') <- inferExp expr
-    t' <- initType caseType it
-    return $ T.Inj (it, t') e'
+    (args, t') <- initType caseType it
+    (s, t, e') <- local (\st -> st { vars = args }) (algoW expr)
+    return (T.Inj (it, t') e', t)
 
-initType :: Type -> Init -> Infer Type
+initType :: Type -> Init -> Infer (Map Ident Poly, Type)
 initType expected = \case
     InitLit lit -> let returnType = litType lit
                     in if expected == returnType
-                      then return expected
-                      else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected]  
+                      then return (mempty,expected)
+                      else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected]
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of
@@ -360,14 +371,14 @@ initType expected = \case
             Just t -> do
                 let flat = flattenType t
                 let returnType = last flat
-                case (length (init flat) == length args, returnType == expected) of
-                    (True, True) -> return returnType
+                case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of
+                    (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected)
                     (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c
-                    (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] 
+                    (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected]
                 -- Ignoring the variables for now, they can not be used in the expression to the
                 -- right of '=>'
 
-    InitCatch -> return expected
+    InitCatch -> return (mempty, expected)
 
 flattenType :: Type -> [Type]
 flattenType (TArr a b) = flattenType a ++ flattenType b
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index a2c86f7..c07da96 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -127,6 +127,17 @@ instance Print Exp where
                         , doc $ showString "."
                         , prt 0 e
                         ]
+    ECase t exp injs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 injs, doc (showString "}"), doc (showString ":"), prt 0 t])
+
+instance Print Inj where
+  prt i = \case
+    Inj (init,t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
+
+instance Print [Inj] where
+  prt _ []     = concatD []
+  prt _ [x]    = concatD [prt 0 x]
+  prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
+
 
 
 
diff --git a/test_program b/test_program
index c5af112..26220e3 100644
--- a/test_program
+++ b/test_program
@@ -1,12 +1,30 @@
+-- data Bool () where {
+--     True : Bool () 
+--     False : Bool ()
+-- };
+-- 
+-- main : _Int ;
+-- main = case True of {
+--     False => 0 ;
+--     True => 1
+-- };
+
 data List ('a) where {
     Nil : List ('a) 
-    Cons : 'a -> List ('a) -> List ('a) 
+    Cons : ('a) -> List ('a) -> List ('a)
 };
 
-data Bool () where {
-    True : Bool () 
-    False : Bool ()
+data Maybe ('a) where {
+    Nothing : Maybe ('a)
+    Just : 'a -> Maybe ('a)
 };
 
-main : List (_Int) ;
-main = Cons 1 (Cons 0 Nil) ;
+safeHead : List ('a) -> Maybe ('a) ;
+safeHead xs =
+    case xs of {
+        Nil => Nothing ;
+        Cons x xs => Just x
+    };
+
+main : Maybe (_Int) ;
+main = safeHead (Cons 0 (Cons 1 Nil)) ;

From fecb71bc0799f0a6eb181d83cca53de5197ab3f7 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 3 Mar 2023 18:17:51 +0100
Subject: [PATCH 48/71] Found a bug.

---
 cabal.project.local            |  2 ++
 cabal.project.local~           |  2 ++
 llvm.ll                        | 16 +++++++++++++++
 src/TypeChecker/TypeChecker.hs | 36 +++++++++++++++++++++++++---------
 test_program                   | 33 +++++++++++++++++++++----------
 5 files changed, 70 insertions(+), 19 deletions(-)
 create mode 100644 cabal.project.local
 create mode 100644 cabal.project.local~
 create mode 100644 llvm.ll

diff --git a/cabal.project.local b/cabal.project.local
new file mode 100644
index 0000000..0432756
--- /dev/null
+++ b/cabal.project.local
@@ -0,0 +1,2 @@
+ignore-project: False
+tests: True
diff --git a/cabal.project.local~ b/cabal.project.local~
new file mode 100644
index 0000000..40fdf41
--- /dev/null
+++ b/cabal.project.local~
@@ -0,0 +1,2 @@
+ignore-project: False
+tests: False
diff --git a/llvm.ll b/llvm.ll
new file mode 100644
index 0000000..9f414c7
--- /dev/null
+++ b/llvm.ll
@@ -0,0 +1,16 @@
+@.str = private unnamed_addr constant [3 x i8] c"%i
+", align 1
+declare i32 @printf(ptr noalias nocapture, ...)
+
+; Ident "main": EAdd (TMono (Ident "Int")) (ELit (TMono (Ident "Int")) (LInt 3)) (EApp (TMono (Ident "Int")) (EId (Ident "sc_0",TArr (TPol (Ident "t1")) (TPol (Ident "t1")))) (ELit (TMono (Ident "Int")) (LInt 3)))
+define i64 @main() {
+	%1 = call i64 @sc_0(i64 3)
+	%2 = add i64 3, %1
+	call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef %2)
+	ret i64 0
+}
+
+; Ident "sc_0": EId (Ident "x_0",TPol (Ident "t1"))
+define "TPol (Ident "t1")" @sc_0("TPol (Ident "t1")" %x_0) {
+	ret i64 %x_0
+}
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 9c55388..09d5204 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -18,12 +18,18 @@ import           Data.Set                  (Set)
 import qualified Data.Set                  as S
 
 import           Data.Foldable             (traverse_)
+import           Debug.Trace               (trace)
 import           Grammar.Abs
 import           Grammar.Print             (printTree)
 import qualified TypeChecker.TypeCheckerIr as T
 import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
                                             Poly (..), Subst)
 
+{- BUGS TODO:
+    Occurs fails on data types, e.g declared Maybe a, used in fn as Maybe (a -> a)
+-}
+
+
 initCtx = Ctx mempty
 initEnv = Env 0 mempty mempty
 
@@ -237,10 +243,9 @@ algoW = \case
             let typ = apply unified' (head ts)
             return (unified', typ, T.ECase typ e0' injs')
 
-
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
-unify t0 t1 = case (t0, t1) of
+unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) t1) of
     (TArr a b, TArr c d) -> do
         s1 <- unify a c
         s2 <- unify (apply s1 b) (apply s1 d)
@@ -299,6 +304,7 @@ instance FreeVars Type where
   free (TArr a b)    = free a `S.union` free b
   -- | Not guaranteed to be correct
   free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a
+
   apply :: Subst -> Type -> Type
   apply sub t = do
     case t of
@@ -334,7 +340,7 @@ fresh :: Infer Type
 fresh = do
     n <- gets count
     modify (\st -> st { count = n + 1 })
-    return . TPol . Ident $ "t" ++ show n
+    return . TPol . Ident $ show n
 
 -- | Run the monadic action with an additional binding
 withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
@@ -352,7 +358,7 @@ insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors
 -------- PATTERN MATCHING ---------
 
 -- "case expr of", the type of 'expr' is caseType
-checkInj :: Type -> Inj -> Infer (T.Inj, Type)
+checkInj :: Type -> Inj -> Infer (T.Inj, Type);
 checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
     (s, t, e') <- local (\st -> st { vars = args }) (algoW expr)
@@ -360,23 +366,34 @@ checkInj caseType (Inj it expr) = do
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
 initType expected = \case
+
     InitLit lit -> let returnType = litType lit
                     in if expected == returnType
                       then return (mempty,expected)
-                      else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected]
+                      else throwError $ unwords [ "Inferred type"
+                                                , printTree returnType
+                                                , "does not match expected type:"
+                                                , printTree expected
+                                                ]
+
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of
-            Nothing -> throwError $ unwords ["Constructor:", printTree c, "does not exist"]
+            Nothing -> throwError $ unwords ["Constructor:"
+                                            , printTree c
+                                            , "does not exist"
+                                            ]
             Just t -> do
                 let flat = flattenType t
                 let returnType = last flat
                 case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of
                     (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected)
                     (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c
-                    (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected]
-                -- Ignoring the variables for now, they can not be used in the expression to the
-                -- right of '=>'
+                    (_, False) -> throwError $ unwords [ "Inferred type"
+                                                       , printTree returnType
+                                                       , "does not match expected type:"
+                                                       , printTree expected
+                                                       ]
 
     InitCatch -> return (mempty, expected)
 
@@ -386,3 +403,4 @@ flattenType a          = [a]
 
 litType :: Literal -> Type
 litType (LInt i) = TMono "Int"
+
diff --git a/test_program b/test_program
index 26220e3..5f6cce9 100644
--- a/test_program
+++ b/test_program
@@ -1,13 +1,7 @@
--- data Bool () where {
---     True : Bool () 
---     False : Bool ()
--- };
--- 
--- main : _Int ;
--- main = case True of {
---     False => 0 ;
---     True => 1
--- };
+data Bool () where {
+    True : Bool () 
+    False : Bool ()
+};
 
 data List ('a) where {
     Nil : List ('a) 
@@ -19,6 +13,11 @@ data Maybe ('a) where {
     Just : 'a -> Maybe ('a)
 };
 
+data Either ('a 'b) where {
+    Left : 'a -> Either ('a 'b)
+    Right : 'b -> Either ('a 'b)
+};
+
 safeHead : List ('a) -> Maybe ('a) ;
 safeHead xs =
     case xs of {
@@ -28,3 +27,17 @@ safeHead xs =
 
 main : Maybe (_Int) ;
 main = safeHead (Cons 0 (Cons 1 Nil)) ;
+
+maybeToEither : Either ('a 'b) ->  Maybe ('a) ;
+maybeToEither e =
+    case e of {
+        Left y => Nothing ;
+        Right x => Just x
+    };
+
+id : 'a -> 'a ;
+id x = x ;
+
+-- Bug, occurs check failed
+holdFn : Maybe ('b -> 'b) ;
+holdFn = Just id ;

From fe63fa62157048026a8c3778d39607b8a58c36a7 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Sun, 5 Mar 2023 13:24:56 +0100
Subject: [PATCH 49/71] Improved error message and created document for known
 bugs.

---
 src/TypeChecker/Bugs.md        | 43 +++++++++++++++++++
 src/TypeChecker/TypeChecker.hs |  2 +-
 test_program                   | 75 +++++++++++++++++++---------------
 3 files changed, 85 insertions(+), 35 deletions(-)
 create mode 100644 src/TypeChecker/Bugs.md

diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md
new file mode 100644
index 0000000..ce95446
--- /dev/null
+++ b/src/TypeChecker/Bugs.md
@@ -0,0 +1,43 @@
+## Bugs
+
+### Polymorphic type variables are global?
+
+This doesn't work (occurs check failed, can't unify `(a -> a) = a`
+```hs
+data Maybe ('a) where {
+    Nothing : Maybe ('a)
+    Just : 'a -> Maybe ('a)
+};
+
+id : 'a -> 'a ;
+id x = x ;
+
+main : Maybe ('a -> 'a) ; 
+main = Just id;
+```
+
+But this does
+```hs
+data Maybe ('a) where {
+    Nothing : Maybe ('a)
+    Just : 'a -> Maybe ('a)
+};
+
+id : 'b -> 'b ;
+id x = x ;
+
+main : Maybe ('a -> 'a) ; 
+main = Just id;
+```
+
+### The function f is not carried into the case-expression
+
+Code example that does not type check
+```hs
+fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
+fmap f x =
+    case x of {
+        Just x => Just (f x) ;
+        Nothing => Nothing
+    }
+```
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 09d5204..53e3678 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -272,7 +272,7 @@ unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1)
 occurs :: Ident -> Type -> Infer Subst
 occurs _ (TPol _) = return nullSubst
 occurs i t = if S.member i (free t)
-                then throwError "Occurs check failed"
+                then throwError $ unwords ["Occurs check failed, can't unify", printTree (TPol i), "with", printTree t]
                 else return $ M.singleton i t
 
 -- | Generalize a type over all free variables in the substitution set
diff --git a/test_program b/test_program
index 5f6cce9..f8dd9bc 100644
--- a/test_program
+++ b/test_program
@@ -1,43 +1,50 @@
-data Bool () where {
-    True : Bool () 
-    False : Bool ()
-};
-
-data List ('a) where {
-    Nil : List ('a) 
-    Cons : ('a) -> List ('a) -> List ('a)
-};
+-- data Bool () where {
+--     True : Bool () 
+--     False : Bool ()
+-- };
+-- 
+-- data List ('a) where {
+--     Nil : List ('a) 
+--     Cons : ('a) -> List ('a) -> List ('a)
+-- };
 
 data Maybe ('a) where {
     Nothing : Maybe ('a)
     Just : 'a -> Maybe ('a)
 };
 
-data Either ('a 'b) where {
-    Left : 'a -> Either ('a 'b)
-    Right : 'b -> Either ('a 'b)
-};
-
-safeHead : List ('a) -> Maybe ('a) ;
-safeHead xs =
-    case xs of {
-        Nil => Nothing ;
-        Cons x xs => Just x
-    };
-
-main : Maybe (_Int) ;
-main = safeHead (Cons 0 (Cons 1 Nil)) ;
-
-maybeToEither : Either ('a 'b) ->  Maybe ('a) ;
-maybeToEither e =
-    case e of {
-        Left y => Nothing ;
-        Right x => Just x
-    };
-
 id : 'a -> 'a ;
 id x = x ;
 
--- Bug, occurs check failed
-holdFn : Maybe ('b -> 'b) ;
-holdFn = Just id ;
+main : Maybe ('a -> 'a) ; 
+main = Just id;
+
+-- data Either ('a 'b) where {
+--     Left : 'a -> Either ('a 'b)
+--     Right : 'b -> Either ('a 'b)
+-- };
+
+-- safeHead : List ('a) -> Maybe ('a) ;
+-- safeHead xs =
+--     case xs of {
+--         Nil => Nothing ;
+--         Cons x xs => Just x
+--     };
+
+-- main : Maybe (_Int) ;
+-- main = safeHead (Cons 0 (Cons 1 Nil)) ;
+-- 
+-- maybeToEither : Either ('a 'b) ->  Maybe ('a) ;
+-- maybeToEither e =
+--     case e of {
+--         Left y => Nothing ;
+--         Right x => Just x
+--     };
+-- 
+-- -- Bug. f not included in the case-expression context
+-- fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
+-- fmap f x =
+--     case x of {
+--         Just x => Just (f x) ;
+--         Nothing => Nothing
+--     }

From 778fec3dc4b01d2011e21f0622a36009583e3786 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Sun, 5 Mar 2023 14:34:39 +0100
Subject: [PATCH 50/71] Implemented potential fix for one of the bugs

---
 src/TypeChecker/Bugs.md        |   1 +
 src/TypeChecker/TypeChecker.hs | 454 +++++++++++++++++++--------------
 test_program                   |   2 +-
 3 files changed, 262 insertions(+), 195 deletions(-)

diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md
index ce95446..616f0fe 100644
--- a/src/TypeChecker/Bugs.md
+++ b/src/TypeChecker/Bugs.md
@@ -29,6 +29,7 @@ id x = x ;
 main : Maybe ('a -> 'a) ; 
 main = Just id;
 ```
+UPDATE: Might have found a fix. Need to be tested.
 
 ### The function f is not carried into the case-expression
 
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 53e3678..c490c27 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,40 +1,42 @@
-{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use mapAndUnzipM" #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 -- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
 
-import           Control.Monad.Except
-import           Control.Monad.Reader
-import           Control.Monad.State
-import           Data.Functor.Identity     (runIdentity)
-import           Data.List                 (foldl')
-import           Data.Map                  (Map)
-import qualified Data.Map                  as M
-import           Data.Set                  (Set)
-import qualified Data.Set                  as S
-
-import           Data.Foldable             (traverse_)
-import           Debug.Trace               (trace)
-import           Grammar.Abs
-import           Grammar.Print             (printTree)
-import qualified TypeChecker.TypeCheckerIr as T
-import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
-                                            Poly (..), Subst)
-
-{- BUGS TODO:
-    Occurs fails on data types, e.g declared Maybe a, used in fn as Maybe (a -> a)
--}
-
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Foldable (traverse_)
+import Data.Functor.Identity (runIdentity)
+import Data.List (foldl')
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Set (Set)
+import Data.Set qualified as S
+import Debug.Trace (trace)
+import Grammar.Abs
+import Grammar.Print (printTree)
+import TypeChecker.TypeCheckerIr (
+    Ctx (..),
+    Env (..),
+    Error,
+    Infer,
+    Poly (..),
+    Subst,
+ )
+import TypeChecker.TypeCheckerIr qualified as T
 
 initCtx = Ctx mempty
+
 initEnv = Env 0 mempty mempty
 
 runPretty :: Exp -> Either Error String
-runPretty = fmap (printTree . fst). run . inferExp
+runPretty = fmap (printTree . fst) . run . inferExp
 
 run :: Infer a -> Either Error a
 run = runC initEnv initCtx
@@ -45,24 +47,60 @@ runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 typecheck :: Program -> Either Error T.Program
 typecheck = run . checkPrg
 
+{- | Start by freshening the type variable of data types to avoid clash with
+other user defined polymorphic types
+-}
+freshenData :: Data -> Infer Data
+freshenData (Data (Constr name ts) constrs) = do
+    fr <- fresh
+    let fr' = case fr of
+            TPol a -> a
+            -- Meh, this part assumes fresh generates a polymorphic type
+            _ -> error "Bug: implementation of fresh and freshenData are not compatible"
+    let new_ts = map (freshenType fr') ts
+    let new_constrs = map (freshenConstr fr') constrs
+    return $ Data (Constr name new_ts) new_constrs
+  where
+    freshenType :: Ident -> Type -> Type
+    freshenType iden = \case
+        (TPol a) -> TPol iden
+        (TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
+        (TConstr (Constr a ts)) -> TConstr (Constr a (map (freshenType iden) ts))
+        rest -> rest
+
+    freshenConstr :: Ident -> Constructor -> Constructor
+    freshenConstr iden (Constructor name t) = Constructor name (freshenType iden t)
+
 checkData :: Data -> Infer ()
-checkData d = case d of
-    (Data typ@(Constr name ts) constrs) -> do
-        unless (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"])
-        traverse_ (\(Constructor name' t')
-                    -> if TConstr typ == retType t'
-                          then insertConstr name' t' else
-                          throwError $
-                              unwords
-                              [ "return type of constructor:"
-                              , printTree name
-                              , "with type:"
-                              , printTree (retType t')
-                              , "does not match data: "
-                              , printTree typ]) constrs
+checkData d = do
+    trace ("OLD: " ++ show d) return ()
+    d' <- freshenData d
+    trace ("NEW: " ++ show d') return ()
+    case d' of
+        (Data typ@(Constr name ts) constrs) -> do
+            unless
+                (all isPoly ts)
+                (throwError $ unwords ["Data type incorrectly declared"])
+            traverse_
+                ( \(Constructor name' t') ->
+                    if TConstr typ == retType t'
+                        then insertConstr name' t'
+                        else
+                            throwError $
+                                unwords
+                                    [ "return type of constructor:"
+                                    , printTree name
+                                    , "with type:"
+                                    , printTree (retType t')
+                                    , "does not match data: "
+                                    , printTree typ
+                                    ]
+                )
+                constrs
+
 retType :: Type -> Type
 retType (TArr _ t2) = retType t2
-retType a           = a
+retType a = a
 
 checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
@@ -71,54 +109,62 @@ checkPrg (Program bs) = do
   where
     preRun :: [Def] -> Infer ()
     preRun [] = return ()
-    preRun (x:xs) = case x of
-        DBind (Bind n t _ _ _ ) -> insertSig n t >> preRun xs
-        DData d@(Data _ _)      -> checkData d >> preRun xs
+    preRun (x : xs) = case x of
+        DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs
+        DData d@(Data _ _) -> checkData d >> preRun xs
 
     checkDef :: [Def] -> Infer [T.Def]
     checkDef [] = return []
-    checkDef (x:xs) = case x of
+    checkDef (x : xs) = case x of
         (DBind b) -> do
             b' <- checkBind b
             fmap (T.DBind b' :) (checkDef xs)
-        (DData d)    -> fmap (T.DData d :) (checkDef xs)
+        (DData d) -> fmap (T.DData d :) (checkDef xs)
 
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
     (t', e') <- inferExp $ makeLambda e (reverse args)
     s <- unify t t'
     let t'' = apply s t
-    unless (t `typeEq` t'') (throwError $ unwords ["Top level signature"
-                                                  , printTree t
-                                                  , "does not match body with inferred type:"
-                                                  , printTree t''
-                                                  ])
+    unless
+        (t `typeEq` t'')
+        ( throwError $
+            unwords
+                [ "Top level signature"
+                , printTree t
+                , "does not match body with inferred type:"
+                , printTree t''
+                ]
+        )
     return $ T.Bind (n, t) e'
   where
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip EAbs)
 
--- | Check if two types are considered equal
---   For the purpose of the algorithm two polymorphic types are always considered equal
+{- | Check if two types are considered equal
+  For the purpose of the algorithm two polymorphic types are always considered
+  equal
+-}
 typeEq :: Type -> Type -> Bool
-typeEq (TArr l r) (TArr l' r')            = typeEq l l' && typeEq r r'
-typeEq (TMono a) (TMono b)                = a == b
-typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = length a == length b
-                                            && name == name'
-                                            && and (zipWith typeEq a b)
-typeEq (TPol _) (TPol _)                  = True
-typeEq _ _                                = False
+typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
+typeEq (TMono a) (TMono b) = a == b
+typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) =
+    length a == length b
+        && name == name'
+        && and (zipWith typeEq a b)
+typeEq (TPol _) (TPol _) = True
+typeEq _ _ = False
 
 isMoreSpecificOrEq :: Type -> Type -> Bool
-isMoreSpecificOrEq _ (TPol _)            = True
+isMoreSpecificOrEq _ (TPol _) = True
 isMoreSpecificOrEq (TArr a b) (TArr c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
-isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2))
-  = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2)
-isMoreSpecificOrEq a b                   = a == b
+isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
+    n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2)
+isMoreSpecificOrEq a b = a == b
 
 isPoly :: Type -> Bool
 isPoly (TPol _) = True
-isPoly _        = False
+isPoly _ = False
 
 inferExp :: Exp -> Infer (Type, T.Exp)
 inferExp e = do
@@ -128,57 +174,59 @@ inferExp e = do
 
 replace :: Type -> T.Exp -> T.Exp
 replace t = \case
-    T.ELit _ e                   -> T.ELit t e
-    T.EId (n, _)                 -> T.EId (n, t)
-    T.EAbs _ name e              -> T.EAbs t name e
-    T.EApp _ e1 e2               -> T.EApp t e1 e2
-    T.EAdd _ e1 e2               -> T.EAdd t e1 e2
+    T.ELit _ e -> T.ELit t e
+    T.EId (n, _) -> T.EId (n, t)
+    T.EAbs _ name e -> T.EAbs t name e
+    T.EApp _ e1 e2 -> T.EApp t e1 e2
+    T.EAdd _ e1 e2 -> T.EAdd t e1 e2
     T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
-    T.ECase _ expr injs          -> T.ECase t expr injs
+    T.ECase _ expr injs -> T.ECase t expr injs
 
 algoW :: Exp -> Infer (Subst, Type, T.Exp)
 algoW = \case
-
-    -- | TODO: Reason more about this one. Could be wrong
+    -- \| TODO: More testing need to be done. Unsure of the correctness of this
     EAnn e t -> do
         (s1, t', e') <- algoW e
-        unless (t `isMoreSpecificOrEq` t') (throwError $ unwords
-            ["Annotated type:"
-            , printTree t
-            , "does not match inferred type:"
-            , printTree t' ])
+        unless
+            (t `isMoreSpecificOrEq` t')
+            ( throwError $
+                unwords
+                    [ "Annotated type:"
+                    , printTree t
+                    , "does not match inferred type:"
+                    , printTree t'
+                    ]
+            )
         applySt s1 $ do
             s2 <- unify t t'
             return (s2 `compose` s1, t, e')
 
--- | ------------------
--- |   Γ ⊢ i : Int, ∅
-
-    ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit  (TMono "Int") (LInt n))
+    -- \| ------------------
+    -- \|   Γ ⊢ i : Int, ∅
 
+    ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
     ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
-
--- | x : σ ∈ Γ   τ = inst(σ)
--- | ----------------------
--- |     Γ ⊢ x : τ, ∅
+    -- \| x : σ ∈ Γ   τ = inst(σ)
+    -- \| ----------------------
+    -- \|     Γ ⊢ x : τ, ∅
 
     EId i -> do
         var <- asks vars
         case M.lookup i var of
-          Just t  -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
-          Nothing -> do
-              sig <- gets sigs
-              case M.lookup i sig of
-                  Just t  -> return (nullSubst, t, T.EId (i, t))
-                  Nothing -> do
-                    constr <- gets constructors
-                    case M.lookup i constr of
-                      Just t  -> return (nullSubst, t, T.EId (i, t))
-                      Nothing -> throwError $ "Unbound variable: " ++ show i
+            Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
+            Nothing -> do
+                sig <- gets sigs
+                case M.lookup i sig of
+                    Just t -> return (nullSubst, t, T.EId (i, t))
+                    Nothing -> do
+                        constr <- gets constructors
+                        case M.lookup i constr of
+                            Just t -> return (nullSubst, t, T.EId (i, t))
+                            Nothing -> throwError $ "Unbound variable: " ++ show i
 
--- | τ = newvar   Γ, x : τ ⊢ e : τ', S
--- | ---------------------------------
--- |     Γ ⊢ w λx. e : Sτ → τ', S
+    -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
+    -- \| ---------------------------------
+    -- \|     Γ ⊢ w λx. e : Sτ → τ', S
 
     EAbs name e -> do
         fr <- fresh
@@ -188,11 +236,11 @@ algoW = \case
             let newArr = TArr varType t'
             return (s1, newArr, T.EAbs newArr (name, varType) e')
 
--- | Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
--- | s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
--- | ------------------------------------------
--- |        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
--- This might be wrong
+    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
+    -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
+    -- \| ------------------------------------------
+    -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
+    -- This might be wrong
 
     EAdd e0 e1 -> do
         (s1, t0, e0') <- algoW e0
@@ -203,10 +251,10 @@ algoW = \case
             s4 <- unify (apply s3 t1) (TMono "Int")
             return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
 
--- | Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
--- | τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
--- | --------------------------------------
--- |       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
+    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
+    -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
+    -- \| --------------------------------------
+    -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
 
     EApp e0 e1 -> do
         fr <- fresh
@@ -218,11 +266,11 @@ algoW = \case
             let t = apply s2 fr
             return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
 
--- | Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
--- | ----------------------------------------------
--- |        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
+    -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
+    -- \| ----------------------------------------------
+    -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
 
--- The bar over S₀ and Γ means "generalize"
+    -- The bar over S₀ and Γ means "generalize"
 
     ELet name e0 e1 -> do
         (s1, t1, e0') <- algoW e0
@@ -230,18 +278,17 @@ algoW = \case
         let t' = generalize (apply s1 env) t1
         withBinding name t' $ do
             (s2, t2, e1') <- algoW e1
-            return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1')
-
+            return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
     ECase caseExpr injs -> do
         (s0, t0, e0') <- algoW caseExpr
         (injs', ts) <- unzip <$> mapM (checkInj t0) injs
         case ts of
-          [] -> throwError "Case expression missing any matches"
-          ts -> do
-            unified <- zipWithM unify ts (tail ts)
-            let unified' = foldl' compose mempty unified
-            let typ = apply unified' (head ts)
-            return (unified', typ, T.ECase typ e0' injs')
+            [] -> throwError "Case expression missing any matches"
+            ts -> do
+                unified <- zipWithM unify ts (tail ts)
+                let unified' = foldl' compose mempty unified
+                let typ = apply unified' (head ts)
+                return (unified', typ, T.ECase typ e0' injs')
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -253,27 +300,40 @@ unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1)
     (TPol a, b) -> occurs a b
     (a, TPol b) -> occurs b a
     (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
-    -- | TODO: Figure out a cleaner way to express the same thing
-    (TConstr (Constr name t), TConstr (Constr name' t')) -> if name == name' && length t == length t'
-                                            then do
-                                                xs <- zipWithM unify t t'
-                                                return $ foldr compose nullSubst xs
-                                            else throwError $ unwords
-                                                ["Type constructor:"
-                                                , printTree name
-                                                , "(" ++ printTree t ++ ")"
-                                                , "does not match with:"
-                                                , printTree name'
-                                                , "(" ++ printTree t' ++ ")"]
+    -- \| TODO: Figure out a cleaner way to express the same thing
+    (TConstr (Constr name t), TConstr (Constr name' t')) ->
+        if name == name' && length t == length t'
+            then do
+                xs <- zipWithM unify t t'
+                return $ foldr compose nullSubst xs
+            else
+                throwError $
+                    unwords
+                        [ "Type constructor:"
+                        , printTree name
+                        , "(" ++ printTree t ++ ")"
+                        , "does not match with:"
+                        , printTree name'
+                        , "(" ++ printTree t' ++ ")"
+                        ]
     (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
 
--- | Check if a type is contained in another type.
--- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
+{- | Check if a type is contained in another type.
+I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
+-}
 occurs :: Ident -> Type -> Infer Subst
 occurs _ (TPol _) = return nullSubst
-occurs i t = if S.member i (free t)
-                then throwError $ unwords ["Occurs check failed, can't unify", printTree (TPol i), "with", printTree t]
-                else return $ M.singleton i t
+occurs i t =
+    if S.member i (free t)
+        then
+            throwError $
+                unwords
+                    [ "Occurs check failed, can't unify"
+                    , printTree (TPol i)
+                    , "with"
+                    , printTree t
+                    ]
+        else return $ M.singleton i t
 
 -- | Generalize a type over all free variables in the substitution set
 generalize :: Map Ident Poly -> Type -> Poly
@@ -292,44 +352,45 @@ compose m1 m2 = M.map (apply m1) m2 `M.union` m1
 
 -- | A class representing free variables functions
 class FreeVars t where
-  -- | Get all free variables from t
-  free :: t -> Set Ident
-  -- | Apply a substitution to t
-  apply :: Subst -> t -> t
+    -- | Get all free variables from t
+    free :: t -> Set Ident
+
+    -- | Apply a substitution to t
+    apply :: Subst -> t -> t
 
 instance FreeVars Type where
-  free :: Type -> Set Ident
-  free (TPol a)      = S.singleton a
-  free (TMono _)     = mempty
-  free (TArr a b)    = free a `S.union` free b
-  -- | Not guaranteed to be correct
-  free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a
+    free :: Type -> Set Ident
+    free (TPol a) = S.singleton a
+    free (TMono _) = mempty
+    free (TArr a b) = free a `S.union` free b
+    -- \| Not guaranteed to be correct
+    free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a
 
-  apply :: Subst -> Type -> Type
-  apply sub t = do
-    case t of
-        TMono a -> TMono a
-        TPol a -> case M.lookup a sub of
-                   Nothing -> TPol a
-                   Just t  -> t
-        TArr a b -> TArr (apply sub a) (apply sub b)
-        TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
+    apply :: Subst -> Type -> Type
+    apply sub t = do
+        case t of
+            TMono a -> TMono a
+            TPol a -> case M.lookup a sub of
+                Nothing -> TPol a
+                Just t -> t
+            TArr a b -> TArr (apply sub a) (apply sub b)
+            TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
 
 instance FreeVars Poly where
-  free :: Poly -> Set Ident
-  free (Forall xs t) = free t S.\\ S.fromList xs
-  apply :: Subst -> Poly -> Poly
-  apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
+    free :: Poly -> Set Ident
+    free (Forall xs t) = free t S.\\ S.fromList xs
+    apply :: Subst -> Poly -> Poly
+    apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
 
 instance FreeVars (Map Ident Poly) where
-  free :: Map Ident Poly -> Set Ident
-  free m = foldl' S.union S.empty (map free $ M.elems m)
-  apply :: Subst -> Map Ident Poly -> Map Ident Poly
-  apply s = M.map (apply s)
+    free :: Map Ident Poly -> Set Ident
+    free m = foldl' S.union S.empty (map free $ M.elems m)
+    apply :: Subst -> Map Ident Poly -> Map Ident Poly
+    apply s = M.map (apply s)
 
 -- | Apply substitutions to the environment.
 applySt :: Subst -> Infer a -> Infer a
-applySt s = local (\st -> st { vars = apply s (vars st) })
+applySt s = local (\st -> st {vars = apply s (vars st)})
 
 -- | Represents the empty substition set
 nullSubst :: Subst
@@ -339,68 +400,73 @@ nullSubst = M.empty
 fresh :: Infer Type
 fresh = do
     n <- gets count
-    modify (\st -> st { count = n + 1 })
+    modify (\st -> st {count = n + 1})
     return . TPol . Ident $ show n
 
 -- | Run the monadic action with an additional binding
 withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
-withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
+withBinding i p = local (\st -> st {vars = M.insert i p (vars st)})
 
 -- | Insert a function signature into the environment
 insertSig :: Ident -> Type -> Infer ()
-insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
+insertSig i t = modify (\st -> st {sigs = M.insert i t (sigs st)})
 
 -- | Insert a constructor with its data type
 insertConstr :: Ident -> Type -> Infer ()
-insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors st) })
-
+insertConstr i t = modify (\st -> st {constructors = M.insert i t (constructors st)})
 
 -------- PATTERN MATCHING ---------
 
 -- "case expr of", the type of 'expr' is caseType
-checkInj :: Type -> Inj -> Infer (T.Inj, Type);
+checkInj :: Type -> Inj -> Infer (T.Inj, Type)
 checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
-    (s, t, e') <- local (\st -> st { vars = args }) (algoW expr)
+    (s, t, e') <- local (\st -> st {vars = args}) (algoW expr)
     return (T.Inj (it, t') e', t)
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
 initType expected = \case
-
-    InitLit lit -> let returnType = litType lit
-                    in if expected == returnType
-                      then return (mempty,expected)
-                      else throwError $ unwords [ "Inferred type"
-                                                , printTree returnType
-                                                , "does not match expected type:"
-                                                , printTree expected
-                                                ]
-
+    InitLit lit ->
+        let returnType = litType lit
+         in if expected == returnType
+                then return (mempty, expected)
+                else
+                    throwError $
+                        unwords
+                            [ "Inferred type"
+                            , printTree returnType
+                            , "does not match expected type:"
+                            , printTree expected
+                            ]
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of
-            Nothing -> throwError $ unwords ["Constructor:"
-                                            , printTree c
-                                            , "does not exist"
-                                            ]
+            Nothing ->
+                throwError $
+                    unwords
+                        [ "Constructor:"
+                        , printTree c
+                        , "does not exist"
+                        ]
             Just t -> do
                 let flat = flattenType t
                 let returnType = last flat
                 case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of
                     (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected)
                     (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c
-                    (_, False) -> throwError $ unwords [ "Inferred type"
-                                                       , printTree returnType
-                                                       , "does not match expected type:"
-                                                       , printTree expected
-                                                       ]
-
+                    (_, False) ->
+                        throwError $
+                            unwords
+                                [ "Inferred type"
+                                , printTree returnType
+                                , "does not match expected type:"
+                                , printTree expected
+                                ]
     InitCatch -> return (mempty, expected)
 
 flattenType :: Type -> [Type]
 flattenType (TArr a b) = flattenType a ++ flattenType b
-flattenType a          = [a]
+flattenType a = [a]
 
 litType :: Literal -> Type
 litType (LInt i) = TMono "Int"
-
diff --git a/test_program b/test_program
index f8dd9bc..db0c77d 100644
--- a/test_program
+++ b/test_program
@@ -16,7 +16,7 @@ data Maybe ('a) where {
 id : 'a -> 'a ;
 id x = x ;
 
-main : Maybe ('a -> 'a) ; 
+main : Maybe ('a -> 'a) ;
 main = Just id;
 
 -- data Either ('a 'b) where {

From 9c2f52f8bb2b07dcf9750b813cb215023da8c6f3 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 6 Mar 2023 11:27:17 +0100
Subject: [PATCH 51/71] fixed bug where bound variable didn't exist in case

---
 src/Renamer/Renamer.hs         | 71 +++++++++++++++++++---------------
 src/TypeChecker/TypeChecker.hs | 44 +++++++++++++--------
 test_program                   | 24 ++++++------
 3 files changed, 79 insertions(+), 60 deletions(-)

diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index d471553..e8e6c38 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -2,16 +2,20 @@
 
 module Renamer.Renamer where
 
-import           Auxiliary           (mapAccumM)
-import           Control.Monad.State (MonadState, State, evalState, gets,
-                                      modify)
-import           Data.List           (foldl')
-import           Data.Map            (Map)
-import qualified Data.Map            as Map
-import           Data.Maybe          (fromMaybe)
-import           Data.Tuple.Extra    (dupe)
-import           Grammar.Abs
-
+import Auxiliary (mapAccumM)
+import Control.Monad.State (
+    MonadState,
+    State,
+    evalState,
+    gets,
+    modify,
+ )
+import Data.List (foldl')
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Maybe (fromMaybe)
+import Data.Tuple.Extra (dupe)
+import Grammar.Abs
 
 -- | Rename all variables and local binds
 rename :: Program -> Program
@@ -20,62 +24,65 @@ rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs)
     -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
     initNames = Map.fromList $ foldl' saveIfBind [] bs
     saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc
-    saveIfBind acc _                           = acc
+    saveIfBind acc _ = acc
     renameSc :: Names -> Def -> Rn Def
     renameSc old_names (DBind (Bind name t _ parms rhs)) = do
         (new_names, parms') <- newNames old_names parms
-        rhs'                <- snd <$> renameExp new_names rhs
+        rhs' <- snd <$> renameExp new_names rhs
         pure . DBind $ Bind name t name parms' rhs'
     renameSc _ def = pure def
 
-
 -- | Rename monad. State holds the number of renamed names.
-newtype Rn a = Rn { runRn :: State Int a }
-  deriving (Functor, Applicative, Monad, MonadState Int)
+newtype Rn a = Rn {runRn :: State Int a}
+    deriving (Functor, Applicative, Monad, MonadState Int)
 
 -- | Maps old to new name
 type Names = Map Ident Ident
 
 renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
 renameLocalBind old_names (Bind name t _ parms rhs) = do
-    (new_names, name')   <- newName old_names name
+    (new_names, name') <- newName old_names name
     (new_names', parms') <- newNames new_names parms
-    (new_names'', rhs')  <- renameExp new_names' rhs
+    (new_names'', rhs') <- renameExp new_names' rhs
     pure (new_names'', Bind name' t name' parms' rhs')
 
 renameExp :: Names -> Exp -> Rn (Names, Exp)
 renameExp old_names = \case
-    EId  n     -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
-
-    ELit (LInt i1)    -> pure (old_names, ELit (LInt i1))
-
+    EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
+    ELit (LInt i1) -> pure (old_names, ELit (LInt i1))
     EApp e1 e2 -> do
         (env1, e1') <- renameExp old_names e1
         (env2, e2') <- renameExp old_names e2
         pure (Map.union env1 env2, EApp e1' e2')
-
     EAdd e1 e2 -> do
         (env1, e1') <- renameExp old_names e1
         (env2, e2') <- renameExp old_names e2
         pure (Map.union env1 env2, EAdd e1' e2')
-
-    ELet i e1 e2  -> do
-        (new_names, e1')   <- renameExp old_names e1
+    ELet i e1 e2 -> do
+        (new_names, e1') <- renameExp old_names e1
         (new_names', e2') <- renameExp new_names e2
         pure (new_names', ELet i e1' e2')
-
-    EAbs par e  -> do
+    EAbs par e -> do
         (new_names, par') <- newName old_names par
-        (new_names', e')  <- renameExp new_names e
+        (new_names', e') <- renameExp new_names e
         pure (new_names', EAbs par' e')
-
     EAnn e t -> do
         (new_names, e') <- renameExp old_names e
         pure (new_names, EAnn e' t)
-
     ECase e injs -> do
-        (new_names, e') <- renameExp old_names e
-        pure (new_names, ECase e' injs)
+        (_, e') <- renameExp old_names e
+        (new_names, injs') <- renameInjs old_names injs
+        pure (new_names, ECase e' injs')
+
+renameInjs :: Names -> [Inj] -> Rn (Names, [Inj])
+renameInjs ns xs = do
+    (new_names, xs') <- unzip <$> mapM (renameInj ns) xs
+    if null new_names then return (mempty, xs') else return (head new_names, xs')
+
+renameInj :: Names -> Inj -> Rn (Names, Inj)
+renameInj ns (Inj init e) = do
+    (new_names, e') <- renameExp ns e
+    return (new_names, Inj init e')
 
 -- | Create a new name and add it to name environment.
 newName :: Names -> Ident -> Rn (Names, Ident)
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index c490c27..afd2e1c 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,9 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+
 {-# HLINT ignore "Use mapAndUnzipM" #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 -- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
@@ -73,9 +71,7 @@ freshenData (Data (Constr name ts) constrs) = do
 
 checkData :: Data -> Infer ()
 checkData d = do
-    trace ("OLD: " ++ show d) return ()
     d' <- freshenData d
-    trace ("NEW: " ++ show d') return ()
     case d' of
         (Data typ@(Constr name ts) constrs) -> do
             unless
@@ -249,7 +245,11 @@ algoW = \case
             -- applySt s2 $ do
             s3 <- unify (apply s2 t0) (TMono "Int")
             s4 <- unify (apply s3 t1) (TMono "Int")
-            return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
+            return
+                ( s4 `compose` s3 `compose` s2 `compose` s1
+                , TMono "Int"
+                , T.EAdd (TMono "Int") e0' e1'
+                )
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
     -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
@@ -280,7 +280,7 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
     ECase caseExpr injs -> do
-        (s0, t0, e0') <- algoW caseExpr
+        (_, t0, e0') <- algoW caseExpr
         (injs', ts) <- unzip <$> mapM (checkInj t0) injs
         case ts of
             [] -> throwError "Case expression missing any matches"
@@ -292,14 +292,15 @@ algoW = \case
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
-unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) t1) of
+unify t0 t1 = case (t0, t1) of
     (TArr a b, TArr c d) -> do
         s1 <- unify a c
         s2 <- unify (apply s1 b) (apply s1 d)
         return $ s1 `compose` s2
     (TPol a, b) -> occurs a b
     (a, TPol b) -> occurs b a
-    (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
+    (TMono a, TMono b) ->
+        if a == b then return M.empty else throwError "Types do not unify"
     -- \| TODO: Figure out a cleaner way to express the same thing
     (TConstr (Constr name t), TConstr (Constr name' t')) ->
         if name == name' && length t == length t'
@@ -316,10 +317,17 @@ unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1)
                         , printTree name'
                         , "(" ++ printTree t' ++ ")"
                         ]
-    (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
+    (a, b) ->
+        throwError . unwords $
+            [ "Type:"
+            , printTree a
+            , "can't be unified with:"
+            , printTree b
+            ]
 
 {- | Check if a type is contained in another type.
-I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
+I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
+such that these are equal
 -}
 occurs :: Ident -> Type -> Infer Subst
 occurs _ (TPol _) = return nullSubst
@@ -339,7 +347,9 @@ occurs i t =
 generalize :: Map Ident Poly -> Type -> Poly
 generalize env t = Forall (S.toList $ free t S.\\ free env) t
 
--- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones.
+{- | Instantiate a polymorphic type. The free type variables are substituted
+with fresh ones.
+-}
 inst :: Poly -> Infer Type
 inst (Forall xs t) = do
     xs' <- mapM (const fresh) xs
@@ -364,7 +374,8 @@ instance FreeVars Type where
     free (TMono _) = mempty
     free (TArr a b) = free a `S.union` free b
     -- \| Not guaranteed to be correct
-    free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a
+    free (TConstr (Constr _ a)) =
+        foldl' (\acc x -> free x `S.union` acc) S.empty a
 
     apply :: Subst -> Type -> Type
     apply sub t = do
@@ -413,7 +424,8 @@ insertSig i t = modify (\st -> st {sigs = M.insert i t (sigs st)})
 
 -- | Insert a constructor with its data type
 insertConstr :: Ident -> Type -> Infer ()
-insertConstr i t = modify (\st -> st {constructors = M.insert i t (constructors st)})
+insertConstr i t =
+    modify (\st -> st {constructors = M.insert i t (constructors st)})
 
 -------- PATTERN MATCHING ---------
 
@@ -421,7 +433,7 @@ insertConstr i t = modify (\st -> st {constructors = M.insert i t (constructors
 checkInj :: Type -> Inj -> Infer (T.Inj, Type)
 checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
-    (s, t, e') <- local (\st -> st {vars = args}) (algoW expr)
+    (_, t, e') <- local (\st -> st {vars = args `M.union` vars st}) (algoW expr)
     return (T.Inj (it, t') e', t)
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
@@ -469,4 +481,4 @@ flattenType (TArr a b) = flattenType a ++ flattenType b
 flattenType a = [a]
 
 litType :: Literal -> Type
-litType (LInt i) = TMono "Int"
+litType (LInt _) = TMono "Int"
diff --git a/test_program b/test_program
index db0c77d..efa8eea 100644
--- a/test_program
+++ b/test_program
@@ -13,11 +13,11 @@ data Maybe ('a) where {
     Just : 'a -> Maybe ('a)
 };
 
-id : 'a -> 'a ;
-id x = x ;
+-- id : 'a -> 'a ;
+-- id x = x ;
 
-main : Maybe ('a -> 'a) ;
-main = Just id;
+-- main : Maybe ('a -> 'a) ;
+-- main = Just id;
 
 -- data Either ('a 'b) where {
 --     Left : 'a -> Either ('a 'b)
@@ -40,11 +40,11 @@ main = Just id;
 --         Left y => Nothing ;
 --         Right x => Just x
 --     };
--- 
--- -- Bug. f not included in the case-expression context
--- fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
--- fmap f x =
---     case x of {
---         Just x => Just (f x) ;
---         Nothing => Nothing
---     }
+ 
+-- Bug. f not included in the case-expression context
+fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
+fmap f x =
+    case x of {
+        Just x => Just (f x) ;
+        Nothing => Nothing
+    }

From f5b5f11903bddff75e0b6236433db2027388d886 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 6 Mar 2023 11:38:25 +0100
Subject: [PATCH 52/71] fixed formatting

---
 src/TypeChecker/TypeChecker.hs | 45 +++++++++++++++++++++++-----------
 1 file changed, 31 insertions(+), 14 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index afd2e1c..e1a6a2c 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -1,8 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-{-# HLINT ignore "Use mapAndUnzipM" #-}
-
 -- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
 
@@ -16,7 +14,6 @@ import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Set (Set)
 import Data.Set qualified as S
-import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
 import TypeChecker.TypeCheckerIr (
@@ -54,7 +51,10 @@ freshenData (Data (Constr name ts) constrs) = do
     let fr' = case fr of
             TPol a -> a
             -- Meh, this part assumes fresh generates a polymorphic type
-            _ -> error "Bug: implementation of fresh and freshenData are not compatible"
+            _ ->
+                error
+                    "Bug: implementation of \
+                    \ fresh and freshenData are not compatible"
     let new_ts = map (freshenType fr') ts
     let new_constrs = map (freshenConstr fr') constrs
     return $ Data (Constr name new_ts) new_constrs
@@ -63,11 +63,13 @@ freshenData (Data (Constr name ts) constrs) = do
     freshenType iden = \case
         (TPol a) -> TPol iden
         (TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
-        (TConstr (Constr a ts)) -> TConstr (Constr a (map (freshenType iden) ts))
+        (TConstr (Constr a ts)) ->
+            TConstr (Constr a (map (freshenType iden) ts))
         rest -> rest
 
     freshenConstr :: Ident -> Constructor -> Constructor
-    freshenConstr iden (Constructor name t) = Constructor name (freshenType iden t)
+    freshenConstr iden (Constructor name t) =
+        Constructor name (freshenType iden t)
 
 checkData :: Data -> Infer ()
 checkData d = do
@@ -153,9 +155,12 @@ typeEq _ _ = False
 
 isMoreSpecificOrEq :: Type -> Type -> Bool
 isMoreSpecificOrEq _ (TPol _) = True
-isMoreSpecificOrEq (TArr a b) (TArr c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
+isMoreSpecificOrEq (TArr a b) (TArr c d) =
+    isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
 isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
-    n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2)
+    n1 == n2
+        && length ts1 == length ts2
+        && and (zipWith isMoreSpecificOrEq ts1 ts2)
 isMoreSpecificOrEq a b = a == b
 
 isPoly :: Type -> Bool
@@ -200,7 +205,8 @@ algoW = \case
     -- \| ------------------
     -- \|   Γ ⊢ i : Int, ∅
 
-    ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
+    ELit (LInt n) ->
+        return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
     ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
     -- \| x : σ ∈ Γ   τ = inst(σ)
     -- \| ----------------------
@@ -218,7 +224,9 @@ algoW = \case
                         constr <- gets constructors
                         case M.lookup i constr of
                             Just t -> return (nullSubst, t, T.EId (i, t))
-                            Nothing -> throwError $ "Unbound variable: " ++ show i
+                            Nothing ->
+                                throwError $
+                                    "Unbound variable: " ++ show i
 
     -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
     -- \| ---------------------------------
@@ -281,7 +289,7 @@ algoW = \case
             return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
     ECase caseExpr injs -> do
         (_, t0, e0') <- algoW caseExpr
-        (injs', ts) <- unzip <$> mapM (checkInj t0) injs
+        (injs', ts) <- mapAndUnzipM (checkInj t0) injs
         case ts of
             [] -> throwError "Case expression missing any matches"
             ts -> do
@@ -463,9 +471,18 @@ initType expected = \case
             Just t -> do
                 let flat = flattenType t
                 let returnType = last flat
-                case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of
-                    (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected)
-                    (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c
+                case ( length (init flat) == length args
+                     , returnType `isMoreSpecificOrEq` expected
+                     ) of
+                    (True, True) ->
+                        return
+                            ( M.fromList $ zip args (map (Forall []) flat)
+                            , expected
+                            )
+                    (False, _) ->
+                        throwError $
+                            "Can't partially match on the constructor: "
+                                ++ printTree c
                     (_, False) ->
                         throwError $
                             unwords

From 6947614fba8aec3c85b7a367f06426ab0827703f Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 6 Mar 2023 13:04:07 +0100
Subject: [PATCH 53/71] Updated bug list & started working on more tests

---
 Justfile                       |  7 ++++++
 fourmolu.yaml                  | 13 ----------
 sample-programs/basic-1        |  4 ++--
 sample-programs/basic-2        |  4 +++-
 sample-programs/basic-3        |  4 ++--
 sample-programs/basic-4        |  2 +-
 sample-programs/basic-5        | 15 ++++++++----
 src/Main.hs                    | 14 +++++------
 src/TypeChecker/Bugs.md        | 31 ++++++++++++------------
 src/TypeChecker/TypeChecker.hs |  2 +-
 tests/Tests.hs                 | 43 ++++++++++++++++++++++++----------
 11 files changed, 80 insertions(+), 59 deletions(-)

diff --git a/Justfile b/Justfile
index ea2d031..8079213 100644
--- a/Justfile
+++ b/Justfile
@@ -10,6 +10,13 @@ clean:
 test:
     cabal test
 
+ctest:
+    cabal run language sample-programs/basic-1
+    cabal run language sample-programs/basic-2
+    cabal run language sample-programs/basic-3
+    cabal run language sample-programs/basic-4
+    cabal run language sample-programs/basic-5
+
 # compile a specific file
 run FILE:
     cabal run language {{FILE}}
diff --git a/fourmolu.yaml b/fourmolu.yaml
index cf7ab2f..8b96b58 100644
--- a/fourmolu.yaml
+++ b/fourmolu.yaml
@@ -1,14 +1 @@
-indentation: 4
-function-arrows: trailing
-comma-style: leading
-import-export-style: diff-friendly
 indent-wheres: false
-record-brace-space: true
-newlines-between-decls: 1
-haddock-style: multi-line
-haddock-style-module:
-let-style: auto
-in-style: right-align
-respectful: false
-fixities: []
-unicode: never
diff --git a/sample-programs/basic-1 b/sample-programs/basic-1
index f109950..5cb2b2a 100644
--- a/sample-programs/basic-1
+++ b/sample-programs/basic-1
@@ -1,2 +1,2 @@
-
-f = \x. x+1;
+f : _Int -> _Int ;
+f = \x. x+1 ;
diff --git a/sample-programs/basic-2 b/sample-programs/basic-2
index f7d0807..2f0448c 100644
--- a/sample-programs/basic-2
+++ b/sample-programs/basic-2
@@ -1,3 +1,5 @@
+add : _Int -> _Int -> _Int ;
 add x = \y. x+y;
 
-main = (\z. z+z) ((add 4) 6);
+main : _Int ;
+main = (\z. z+z) ((add 4) 6) ;
diff --git a/sample-programs/basic-3 b/sample-programs/basic-3
index 9443439..7ba4971 100644
--- a/sample-programs/basic-3
+++ b/sample-programs/basic-3
@@ -1,2 +1,2 @@
-
-main = (\x. x+x+3) ((\x. x) 2)
+main : _Int ;
+main = (\x. x+x+3) ((\x. x) 2) ;
diff --git a/sample-programs/basic-4 b/sample-programs/basic-4
index 1de7a8c..365e4cb 100644
--- a/sample-programs/basic-4
+++ b/sample-programs/basic-4
@@ -1,2 +1,2 @@
-
+f : _Int -> _Int ;
 f x = let g = (\y. y+1) in g (g x)
diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
index 9984ddd..e42b5f9 100644
--- a/sample-programs/basic-5
+++ b/sample-programs/basic-5
@@ -1,9 +1,14 @@
-id x = x;
+-- double : _Int -> _Int ;
+-- double n = n + n;
 
-add x y = x + y;
+apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
+apply f x = \y. f x y ;
 
-double n = n + n;
+id : 'a -> 'a ;
+id x = x ;
 
-apply f x = \y. f x y;
+add : _Int -> _Int -> _Int ;
+add x y = x + y ;
 
-main = apply (id add) ((\x. x + 1) 1) (double 3);
+main : _Int -> _Int -> _Int ;
+main = (id add) 1 2 ;
diff --git a/src/Main.hs b/src/Main.hs
index bef4a3b..7e3922d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,15 +3,15 @@
 module Main where
 
 -- import           Codegen.Codegen           (compile)
-import           Grammar.ErrM            (Err)
-import           Grammar.Par             (myLexer, pProgram)
-import           Grammar.Print           (printTree)
+import Grammar.ErrM (Err)
+import Grammar.Par (myLexer, pProgram)
+import Grammar.Print (printTree)
 
 -- import           LambdaLifter.LambdaLifter (lambdaLift)
-import           Renamer.Renamer         (rename)
-import           System.Environment      (getArgs)
-import           System.Exit             (exitFailure, exitSuccess)
-import           TypeChecker.TypeChecker (typecheck)
+import Renamer.Renamer (rename)
+import System.Environment (getArgs)
+import System.Exit (exitFailure, exitSuccess)
+import TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
 main =
diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md
index 616f0fe..a7875d1 100644
--- a/src/TypeChecker/Bugs.md
+++ b/src/TypeChecker/Bugs.md
@@ -1,8 +1,22 @@
 ## Bugs
 
-### Polymorphic type variables are global?
+None known at this moment
+
+## Fixed bugs
+
+* 1
+
+```hs
+fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
+fmap f x =
+    case x of {
+        Just x => Just (f x) ;
+        Nothing => Nothing
+    }
+```
+
+* 2
 
-This doesn't work (occurs check failed, can't unify `(a -> a) = a`
 ```hs
 data Maybe ('a) where {
     Nothing : Maybe ('a)
@@ -29,16 +43,3 @@ id x = x ;
 main : Maybe ('a -> 'a) ; 
 main = Just id;
 ```
-UPDATE: Might have found a fix. Need to be tested.
-
-### The function f is not carried into the case-expression
-
-Code example that does not type check
-```hs
-fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
-fmap f x =
-    case x of {
-        Just x => Just (f x) ;
-        Nothing => Nothing
-    }
-```
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index e1a6a2c..607dcfe 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -61,7 +61,7 @@ freshenData (Data (Constr name ts) constrs) = do
   where
     freshenType :: Ident -> Type -> Type
     freshenType iden = \case
-        (TPol a) -> TPol iden
+        (TPol _) -> TPol iden
         (TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
         (TConstr (Constr a ts)) ->
             TConstr (Constr a (map (freshenType iden) ts))
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 5c52939..6e20745 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -1,20 +1,26 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
 {-# HLINT ignore "Use <$>" #-}
 {-# HLINT ignore "Use camelCase" #-}
 
 module Main where
 
-import           Data.Either               (isLeft, isRight)
-import           Data.Map                  (Map)
-import qualified Data.Map                  as M
-import           Grammar.Abs
-import           Test.Hspec
-import           Test.QuickCheck
-import           TypeChecker.TypeChecker
-import qualified TypeChecker.TypeCheckerIr as T
-import           TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer,
-                                            Poly (..))
+import Data.Either (isLeft, isRight)
+import Data.Map (Map)
+import Data.Map qualified as M
+import Grammar.Abs
+import Test.Hspec
+import Test.QuickCheck
+import TypeChecker.TypeChecker
+import TypeChecker.TypeCheckerIr (
+    Ctx (..),
+    Env (..),
+    Error,
+    Infer,
+    Poly (..),
+ )
+import TypeChecker.TypeCheckerIr qualified as T
 
 main :: IO ()
 main = hspec $ do
@@ -67,10 +73,11 @@ infer_eabs = describe "algoW used on EAbs" $ do
     it "should infer the argument type as polymorphic if it is not used in the lambda" $ do
         let lambda = EAbs "x" (ELit (LInt 0))
         getType lambda `shouldSatisfy` isArrowPolyToMono
+
     it "should infer a variable as function if used as one" $ do
         let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x")))
         let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True
-            isOk _                                                                = False
+            isOk _ = False
         getType lambda `shouldSatisfy` isOk
 
 infer_eapp = describe "algoW used on EApp" $ do
@@ -81,9 +88,21 @@ infer_eapp = describe "algoW used on EApp" $ do
             let ctx = Ctx (M.singleton (Ident (x :: String)) t)
             getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed"
 
+churf_id :: Bind 
+churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x")
+
+churf_add :: Bind
+churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y"))
+
+churf_main :: Bind
+churf_main = Bind "main" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "main" [] (EApp (EId "id") (EId "add"))
+
+test_bug :: IO ()
+test_bug = undefined
+
 isArrowPolyToMono :: Either Error Type -> Bool
 isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True
-isArrowPolyToMono _                                 = False
+isArrowPolyToMono _ = False
 
 -- | Empty environment
 getType :: Exp -> Either Error Type

From eef6fa76683fc3aab2aedcd6ad1b6dc6afef3a92 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 6 Mar 2023 16:25:03 +0100
Subject: [PATCH 54/71] added new test and found another bug

---
 sample-programs/basic-5          |   7 +-
 src/TypeChecker/Bugs.md          |  38 ++++++
 src/TypeChecker/TypeChecker.hs   |  80 +++++++------
 src/TypeChecker/TypeCheckerIr.hs | 193 ++++++++++++++++++-------------
 tests/Tests.hs                   |  16 ++-
 5 files changed, 210 insertions(+), 124 deletions(-)

diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
index e42b5f9..7175091 100644
--- a/sample-programs/basic-5
+++ b/sample-programs/basic-5
@@ -2,7 +2,7 @@
 -- double n = n + n;
 
 apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
-apply f x = \y. f x y ;
+apply f x y = f x y ;
 
 id : 'a -> 'a ;
 id x = x ;
@@ -11,4 +11,7 @@ add : _Int -> _Int -> _Int ;
 add x y = x + y ;
 
 main : _Int -> _Int -> _Int ;
-main = (id add) 1 2 ;
+main = apply (id add) ;
+
+idadd : _Int -> _Int -> _Int ;
+idadd = id add ;
diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md
index a7875d1..a265cde 100644
--- a/src/TypeChecker/Bugs.md
+++ b/src/TypeChecker/Bugs.md
@@ -2,6 +2,44 @@
 
 None known at this moment
 
+main\_bug should not typecheck
+
+```hs
+apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
+apply f x = \y. f x y ;
+
+id : 'a -> 'a ;
+id x = x ;
+
+add : _Int -> _Int -> _Int ;
+add x y = x + y ;
+
+main_bug : _Int -> _Int -> _Int ;
+main_bug= (apply id) add ;
+
+idadd : _Int -> _Int -> _Int ;
+idadd = id add ;
+```
+
+main\_bug should typecheck
+
+```hs
+apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
+apply f x = \y. f x y ;
+
+id : 'a -> 'a ;
+id x = x ;
+
+add : _Int -> _Int -> _Int ;
+add x y = x + y ;
+
+main_bug : _Int -> _Int -> _Int ;
+main_bug = apply (id add) ;
+
+idadd : _Int -> _Int -> _Int ;
+idadd = id add ;
+```
+
 ## Fixed bugs
 
 * 1
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 607dcfe..b99313d 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -14,6 +14,7 @@ import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Set (Set)
 import Data.Set qualified as S
+import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
 import TypeChecker.TypeCheckerIr (
@@ -300,38 +301,41 @@ algoW = \case
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
-unify t0 t1 = case (t0, t1) of
-    (TArr a b, TArr c d) -> do
-        s1 <- unify a c
-        s2 <- unify (apply s1 b) (apply s1 d)
-        return $ s1 `compose` s2
-    (TPol a, b) -> occurs a b
-    (a, TPol b) -> occurs b a
-    (TMono a, TMono b) ->
-        if a == b then return M.empty else throwError "Types do not unify"
-    -- \| TODO: Figure out a cleaner way to express the same thing
-    (TConstr (Constr name t), TConstr (Constr name' t')) ->
-        if name == name' && length t == length t'
-            then do
-                xs <- zipWithM unify t t'
-                return $ foldr compose nullSubst xs
-            else
-                throwError $
-                    unwords
-                        [ "Type constructor:"
-                        , printTree name
-                        , "(" ++ printTree t ++ ")"
-                        , "does not match with:"
-                        , printTree name'
-                        , "(" ++ printTree t' ++ ")"
-                        ]
-    (a, b) ->
-        throwError . unwords $
-            [ "Type:"
-            , printTree a
-            , "can't be unified with:"
-            , printTree b
-            ]
+unify t0 t1 = do
+    trace ("t0: " ++ show t0) return ()
+    trace ("t1: " ++ show t1) return ()
+    case (t0, t1) of
+        (TArr a b, TArr c d) -> do
+            s1 <- unify a c
+            s2 <- unify (apply s1 b) (apply s1 d)
+            return $ s1 `compose` s2
+        (TPol a, b) -> occurs a b
+        (a, TPol b) -> occurs b a
+        (TMono a, TMono b) ->
+            if a == b then return M.empty else throwError "Types do not unify"
+        -- \| TODO: Figure out a cleaner way to express the same thing
+        (TConstr (Constr name t), TConstr (Constr name' t')) ->
+            if name == name' && length t == length t'
+                then do
+                    xs <- zipWithM unify t t'
+                    return $ foldr compose nullSubst xs
+                else
+                    throwError $
+                        unwords
+                            [ "Type constructor:"
+                            , printTree name
+                            , "(" ++ printTree t ++ ")"
+                            , "does not match with:"
+                            , printTree name'
+                            , "(" ++ printTree t' ++ ")"
+                            ]
+        (a, b) ->
+            throwError . unwords $
+                [ "Type:"
+                , printTree a
+                , "can't be unified with:"
+                , printTree b
+                ]
 
 {- | Check if a type is contained in another type.
 I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
@@ -409,7 +413,7 @@ instance FreeVars (Map Ident Poly) where
 
 -- | Apply substitutions to the environment.
 applySt :: Subst -> Infer a -> Infer a
-applySt s = local (\st -> st {vars = apply s (vars st)})
+applySt s = local (\st -> st{vars = apply s (vars st)})
 
 -- | Represents the empty substition set
 nullSubst :: Subst
@@ -419,21 +423,21 @@ nullSubst = M.empty
 fresh :: Infer Type
 fresh = do
     n <- gets count
-    modify (\st -> st {count = n + 1})
+    modify (\st -> st{count = n + 1})
     return . TPol . Ident $ show n
 
 -- | Run the monadic action with an additional binding
 withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
-withBinding i p = local (\st -> st {vars = M.insert i p (vars st)})
+withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
 
 -- | Insert a function signature into the environment
 insertSig :: Ident -> Type -> Infer ()
-insertSig i t = modify (\st -> st {sigs = M.insert i t (sigs st)})
+insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
 
 -- | Insert a constructor with its data type
 insertConstr :: Ident -> Type -> Infer ()
 insertConstr i t =
-    modify (\st -> st {constructors = M.insert i t (constructors st)})
+    modify (\st -> st{constructors = M.insert i t (constructors st)})
 
 -------- PATTERN MATCHING ---------
 
@@ -441,7 +445,7 @@ insertConstr i t =
 checkInj :: Type -> Inj -> Infer (T.Inj, Type)
 checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
-    (_, t, e') <- local (\st -> st {vars = args `M.union` vars st}) (algoW expr)
+    (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr)
     return (T.Inj (it, t') e', t)
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index c07da96..475201e 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -2,27 +2,33 @@
 
 module TypeChecker.TypeCheckerIr where
 
-import           Control.Monad.Except
-import           Control.Monad.Reader
-import           Control.Monad.State
-import           Data.Functor.Identity (Identity)
-import           Data.Map              (Map)
-import           Grammar.Abs           (Data (..), Ident (..), Init (..),
-                                        Literal (..), Type (..))
-import           Grammar.Print
-import           Prelude
-import qualified Prelude               as C (Eq, Ord, Read, Show)
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Functor.Identity (Identity)
+import Data.Map (Map)
+import Grammar.Abs (
+    Data (..),
+    Ident (..),
+    Init (..),
+    Literal (..),
+    Type (..),
+ )
+import Grammar.Print
+import Prelude
+import Prelude qualified as C (Eq, Ord, Read, Show)
 
 -- | A data type representing type variables
 data Poly = Forall [Ident] Type
-    deriving Show
+    deriving (Show)
 
-newtype Ctx = Ctx { vars :: Map Ident Poly }
+newtype Ctx = Ctx {vars :: Map Ident Poly}
 
-data Env = Env { count        :: Int
-               , sigs         :: Map Ident Type
-               , constructors :: Map Ident Type
-               }
+data Env = Env
+    { count :: Int
+    , sigs :: Map Ident Type
+    , constructors :: Map Ident Type
+    }
 
 type Error = String
 type Subst = Map Ident Type
@@ -30,17 +36,17 @@ type Subst = Map Ident Type
 type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
 newtype Program = Program [Def]
-  deriving (C.Eq, C.Ord, C.Show, C.Read)
+    deriving (C.Eq, C.Ord, C.Show, C.Read)
 
 data Exp
-    = EId  Id
+    = EId Id
     | ELit Type Literal
     | ELet Bind Exp
     | EApp Type Exp Exp
     | EAdd Type Exp Exp
     | EAbs Type Id Exp
     | ECase Type Exp [Inj]
-      deriving (C.Eq, C.Ord, C.Read, C.Show)
+    deriving (C.Eq, C.Ord, C.Read, C.Show)
 
 data Inj = Inj (Init, Type) Exp
     deriving (C.Eq, C.Ord, C.Read, C.Show)
@@ -54,90 +60,119 @@ data Bind = Bind Id Exp
     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
 instance Print [Def] where
-  prt _ []     = concatD []
-  prt _ (x:xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
+    prt _ [] = concatD []
+    prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
 
 instance Print Def where
-  prt i (DBind bind) = prt i bind
-  prt i (DData d)    = prt i d
+    prt i (DBind bind) = prt i bind
+    prt i (DData d) = prt i d
 
 instance Print Program where
     prt i (Program sc) = prPrec i 0 $ prt 0 sc
 
 instance Print Bind where
-    prt i (Bind (t, name) rhs) = prPrec i 0 $ concatD
-        [ prt 0 name
-        , doc $ showString ":"
-        , prt 1 t
-        , doc $ showString "="
-        , prt 2 rhs
-        ]
+    prt i (Bind (t, name) rhs) =
+        prPrec i 0 $
+            concatD
+                [ prt 0 name
+                , doc $ showString ":"
+                , prt 0 t
+                , doc $ showString "\n"
+                , prt 0 name
+                , doc $ showString "="
+                , prt 0 rhs
+                ]
 
 instance Print [Bind] where
-  prt _ []     = concatD []
-  prt _ [x]    = concatD [prt 0 x]
-  prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
+    prt _ [] = concatD []
+    prt _ [x] = concatD [prt 0 x]
+    prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
 
 prtIdPs :: Int -> [Id] -> Doc
 prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
 
 prtId :: Int -> Id -> Doc
-prtId i (name, t) = prPrec i 0 $ concatD
-    [ prt 0 name
-    , doc $ showString ":"
-    , prt 0 t
-    ]
+prtId i (name, t) =
+    prPrec i 0 $
+        concatD
+            [ prt 0 name
+            , doc $ showString ":"
+            , prt 0 t
+            ]
 
 prtIdP :: Int -> Id -> Doc
-prtIdP i (name, t) = prPrec i 0 $ concatD
-    [ doc $ showString "("
-    , prt 0 name
-    , doc $ showString ":"
-    , prt 0 t
-    , doc $ showString ")"
-    ]
-
+prtIdP i (name, t) =
+    prPrec i 0 $
+        concatD
+            [ doc $ showString "("
+            , prt 0 name
+            , doc $ showString ":"
+            , prt 0 t
+            , doc $ showString ")"
+            ]
 
 instance Print Exp where
-  prt i = \case
-    EId n       -> prPrec i 3 $ concatD [prtId 0 n]
-    ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1]
-    ELet bs e    -> prPrec i 3 $ concatD
+    prt i = \case
+        EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
+        ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
+        ELet bs e ->
+            prPrec i 3 $
+                concatD
                     [ doc $ showString "let"
                     , prt 0 bs
                     , doc $ showString "in"
                     , prt 0 e
+                    , doc $ showString "\n"
                     ]
-    EApp _ e1 e2 -> prPrec i 2 $ concatD
-                        [ prt 2 e1
-                        , prt 3 e2
-                        ]
-    EAdd t e1 e2 -> prPrec i 1 $ concatD
-                        [ doc $ showString "@"
-                        , prt 0 t
-                        , prt 1 e1
-                        , doc $ showString "+"
-                        , prt 2 e2
-                        ]
-    EAbs t n e  -> prPrec i 0 $ concatD
-                        [ doc $ showString "@"
-                        , prt 0 t
-                        , doc $ showString "\\"
-                        , prtId 0 n
-                        , doc $ showString "."
-                        , prt 0 e
-                        ]
-    ECase t exp injs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 injs, doc (showString "}"), doc (showString ":"), prt 0 t])
+        EApp _ e1 e2 ->
+            prPrec i 2 $
+                concatD
+                    [ prt 2 e1
+                    , prt 3 e2
+                    ]
+        EAdd t e1 e2 ->
+            prPrec i 1 $
+                concatD
+                    [ doc $ showString "@"
+                    , prt 0 t
+                    , prt 1 e1
+                    , doc $ showString "+"
+                    , prt 2 e2
+                    , doc $ showString "\n"
+                    ]
+        EAbs t n e ->
+            prPrec i 0 $
+                concatD
+                    [ doc $ showString "@"
+                    , prt 0 t
+                    , doc $ showString "\\"
+                    , prtId 0 n
+                    , doc $ showString "."
+                    , prt 0 e
+                    , doc $ showString "\n"
+                    ]
+        ECase t exp injs ->
+            prPrec
+                i
+                0
+                ( concatD
+                    [ doc (showString "case")
+                    , prt 0 exp
+                    , doc (showString "of")
+                    , doc (showString "{")
+                    , prt 0 injs
+                    , doc (showString "}")
+                    , doc (showString ":")
+                    , prt 0 t
+                    , doc $ showString "\n"
+                    ]
+                )
 
 instance Print Inj where
-  prt i = \case
-    Inj (init,t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
+    prt i = \case
+        Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
 
 instance Print [Inj] where
-  prt _ []     = concatD []
-  prt _ [x]    = concatD [prt 0 x]
-  prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
-
-
-
-
+    prt _ [] = concatD []
+    prt _ [x] = concatD [prt 0 x]
+    prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 6e20745..655c086 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -29,6 +29,7 @@ main = hspec $ do
     infer_eid
     infer_eabs
     infer_eapp
+    test_id_function
 
 infer_elit = describe "algoW used on ELit" $ do
     it "infers the type mono Int" $ do
@@ -86,19 +87,24 @@ infer_eapp = describe "algoW used on EApp" $ do
             let env = Env 0 mempty mempty
             let t = Forall [] (TPol "a")
             let ctx = Ctx (M.singleton (Ident (x :: String)) t)
-            getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed"
+            getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldSatisfy` isLeft
 
-churf_id :: Bind 
+churf_id :: Bind
 churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x")
 
 churf_add :: Bind
 churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y"))
 
 churf_main :: Bind
-churf_main = Bind "main" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "main" [] (EApp (EId "id") (EId "add"))
+churf_main = Bind "main" (TArr (TMono "Int") (TMono "Int")) "main" [] (EApp (EApp (EId "id") (EId "add")) (ELit (LInt 0)))
 
-test_bug :: IO ()
-test_bug = undefined
+prg = Program [DBind churf_main, DBind churf_add, DBind churf_id]
+
+test_id_function :: SpecWith ()
+test_id_function =
+    describe "typechecking a program with id, add and main, where id is applied to add in main" $ do
+        it "should succeed to find the correct type" $ do
+            typecheck prg `shouldSatisfy` isRight
 
 isArrowPolyToMono :: Either Error Type -> Bool
 isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True

From fce54e789996970dfe1bd71914f0c6f6669415a0 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 6 Mar 2023 16:41:59 +0100
Subject: [PATCH 55/71] documented possible bad functions

---
 sample-programs/basic-5        | 13 ++-----------
 src/TypeChecker/TypeChecker.hs | 26 +++++++++++++++-----------
 2 files changed, 17 insertions(+), 22 deletions(-)

diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
index 7175091..9a9a723 100644
--- a/sample-programs/basic-5
+++ b/sample-programs/basic-5
@@ -1,17 +1,8 @@
 -- double : _Int -> _Int ;
 -- double n = n + n;
 
-apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
-apply f x y = f x y ;
-
 id : 'a -> 'a ;
 id x = x ;
 
-add : _Int -> _Int -> _Int ;
-add x y = x + y ;
-
-main : _Int -> _Int -> _Int ;
-main = apply (id add) ;
-
-idadd : _Int -> _Int -> _Int ;
-idadd = id add ;
+main : ('a -> 'b -> 'c) ;
+main = id ;
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index b99313d..af4734d 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -45,6 +45,7 @@ typecheck = run . checkPrg
 
 {- | Start by freshening the type variable of data types to avoid clash with
 other user defined polymorphic types
+This might be wrong for type constructors that work over several variables
 -}
 freshenData :: Data -> Infer Data
 freshenData (Data (Constr name ts) constrs) = do
@@ -59,18 +60,21 @@ freshenData (Data (Constr name ts) constrs) = do
     let new_ts = map (freshenType fr') ts
     let new_constrs = map (freshenConstr fr') constrs
     return $ Data (Constr name new_ts) new_constrs
-  where
-    freshenType :: Ident -> Type -> Type
-    freshenType iden = \case
-        (TPol _) -> TPol iden
-        (TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
-        (TConstr (Constr a ts)) ->
-            TConstr (Constr a (map (freshenType iden) ts))
-        rest -> rest
 
-    freshenConstr :: Ident -> Constructor -> Constructor
-    freshenConstr iden (Constructor name t) =
-        Constructor name (freshenType iden t)
+{- | Freshen all polymorphic variables, regardless of name
+| freshenType "d" (a -> b -> c) becomes (d -> d -> d)
+-}
+freshenType :: Ident -> Type -> Type
+freshenType iden = \case
+    (TPol _) -> TPol iden
+    (TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
+    (TConstr (Constr a ts)) ->
+        TConstr (Constr a (map (freshenType iden) ts))
+    rest -> rest
+
+freshenConstr :: Ident -> Constructor -> Constructor
+freshenConstr iden (Constructor name t) =
+    Constructor name (freshenType iden t)
 
 checkData :: Data -> Infer ()
 checkData d = do

From 62724964d7144256c1c456a71f50a7af7539b3bf Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Wed, 8 Mar 2023 15:22:42 +0100
Subject: [PATCH 56/71] fixed Maybe ('a -> 'a) bug. Pattern matching still
 wonky, will have to redo

---
 "\\"                           | 511 +++++++++++++++++++++++++++++++++
 src/TypeChecker/TypeChecker.hs | 117 ++++----
 test_program                   |  48 +---
 3 files changed, 579 insertions(+), 97 deletions(-)
 create mode 100644 "\\"

diff --git "a/\\" "b/\\"
new file mode 100644
index 0000000..90c24ff
--- /dev/null
+++ "b/\\"
@@ -0,0 +1,511 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | A module for type checking and inference using algorithm W, Hindley-Milner
+module TypeChecker.TypeChecker where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Foldable (traverse_)
+import Data.Functor.Identity (runIdentity)
+import Debug.Trace (trace)
+import Data.List (foldl')
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Set (Set)
+import Data.Set qualified as S
+import Data.Maybe (fromMaybe)
+import Grammar.Abs
+import Grammar.Print (printTree)
+import TypeChecker.TypeCheckerIr (
+    Ctx (..),
+    Env (..),
+    Error,
+    Infer,
+    Poly (..),
+    Subst,
+ )
+import TypeChecker.TypeCheckerIr qualified as T
+
+initCtx = Ctx mempty
+
+initEnv = Env 0 mempty mempty
+
+runPretty :: Exp -> Either Error String
+runPretty = fmap (printTree . fst) . run . inferExp
+
+run :: Infer a -> Either Error a
+run = runC initEnv initCtx
+
+runC :: Env -> Ctx -> Infer a -> Either Error a
+runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
+
+typecheck :: Program -> Either Error T.Program
+typecheck = run . checkPrg
+
+{- | Start by freshening the type variable of data types to avoid clash with
+other user defined polymorphic types
+This might be wrong for type constructors that work over several variables
+-}
+-- freshenData :: Data -> Infer Data
+-- freshenData (Data (Constr name ts) constrs) = do
+--     new_ts <- traverse freshenType ts
+--     new_constrs <- traverse freshenConstr constrs
+--     return $ Data (Constr name new_ts) new_constrs
+--TODO: Fix incorrect behavior here
+
+{- | Freshen all polymorphic variables, regardless of name
+| freshenType "d" (a -> b -> c) becomes (d -> d -> d)
+-}
+-- freshenType :: Type -> Infer Type
+-- freshenType t = do
+--     let freeVars = (S.toList $ free t)
+--     frs <- sequenceA $ map (const fresh) freeVars
+--     let remaps = M.fromList $ zip freeVars frs
+--     return $ go remaps t
+--   where
+--     go :: Map Ident Type -> Type -> Type
+--     go m t = case t of
+--         TPol a -> fromMaybe (error "bug in \'free\'") (M.lookup a m )
+--         TMono a -> TMono a
+--         TArr t1 t2 -> TArr (go m t1) (go m t2)
+--         TConstr (Constr ident ts) -> TConstr (Constr ident (map (go m) ts))
+
+-- freshenConstr :: Constructor -> Infer Constructor
+-- freshenConstr (Constructor name t) = do
+--     t' <- freshenType t
+--     return $ Constructor name t'
+
+checkData :: Data -> Infer ()
+checkData d = do
+    case d of
+        (Data typ@(Constr name ts) constrs) -> do
+            unless
+                (all isPoly ts)
+                (throwError $ unwords ["Data type incorrectly declared"])
+            traverse_
+                ( \(Constructor name' t') ->
+                    if TConstr typ == retType t'
+                        then insertConstr name' t'
+                        else
+                            throwError $
+                                unwords
+                                    [ "return type of constructor:"
+                                    , printTree name
+                                    , "with type:"
+                                    , printTree (retType t')
+                                    , "does not match data: "
+                                    , printTree typ
+                                    ]
+                )
+                constrs
+
+retType :: Type -> Type
+retType (TArr _ t2) = retType t2
+retType a = a
+
+checkPrg :: Program -> Infer T.Program
+checkPrg (Program bs) = do
+    preRun bs
+    bs' <- checkDef bs
+    return $ T.Program bs'
+  where
+    preRun :: [Def] -> Infer ()
+    preRun [] = return ()
+    preRun (x : xs) = case x of
+        DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs
+        DData d@(Data _ _) -> checkData d >> preRun xs
+
+    checkDef :: [Def] -> Infer [T.Def]
+    checkDef [] = return []
+    checkDef (x : xs) = case x of
+        (DBind b) -> do
+            b' <- checkBind b
+            fmap (T.DBind b' :) (checkDef xs)
+        (DData d) -> fmap (T.DData d :) (checkDef xs)
+
+checkBind :: Bind -> Infer T.Bind
+checkBind (Bind n t _ args e) = do
+    (t', e') <- inferExp $ makeLambda e (reverse args)
+    s <- unify t t'
+    let t'' = apply s t
+    unless
+        (t `typeEq` t'')
+        ( throwError $
+            unwords
+                [ "Top level signature"
+                , printTree t
+                , "does not match body with inferred type:"
+                , printTree t''
+                ]
+        )
+    return $ T.Bind (n, t) e'
+  where
+    makeLambda :: Exp -> [Ident] -> Exp
+    makeLambda = foldl (flip EAbs)
+
+{- | Check if two types are considered equal
+  For the purpose of the algorithm two polymorphic types are always considered
+  equal
+-}
+typeEq :: Type -> Type -> Bool
+typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
+typeEq (TMono a) (TMono b) = a == b
+typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) =
+    length a == length b
+        && name == name'
+        && and (zipWith typeEq a b)
+typeEq (TPol _) (TPol _) = True
+typeEq _ _ = False
+
+isMoreSpecificOrEq :: Type -> Type -> Bool
+isMoreSpecificOrEq _ (TPol _) = True
+isMoreSpecificOrEq (TArr a b) (TArr c d) =
+    isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
+isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
+    n1 == n2
+        && length ts1 == length ts2
+        && and (zipWith isMoreSpecificOrEq ts1 ts2)
+isMoreSpecificOrEq a b = a == b
+
+isPoly :: Type -> Bool
+isPoly (TPol _) = True
+isPoly _ = False
+
+inferExp :: Exp -> Infer (Type, T.Exp)
+inferExp e = do
+    (s, t, e') <- algoW e
+    let subbed = apply s t
+    return (subbed, replace subbed e')
+
+replace :: Type -> T.Exp -> T.Exp
+replace t = \case
+    T.ELit _ e -> T.ELit t e
+    T.EId (n, _) -> T.EId (n, t)
+    T.EAbs _ name e -> T.EAbs t name e
+    T.EApp _ e1 e2 -> T.EApp t e1 e2
+    T.EAdd _ e1 e2 -> T.EAdd t e1 e2
+    T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
+    T.ECase _ expr injs -> T.ECase t expr injs
+
+algoW :: Exp -> Infer (Subst, Type, T.Exp)
+algoW = \case
+    -- \| TODO: More testing need to be done. Unsure of the correctness of this
+    EAnn e t -> do
+        (s1, t', e') <- algoW e
+        unless
+            (t `isMoreSpecificOrEq` t')
+            ( throwError $
+                unwords
+                    [ "Annotated type:"
+                    , printTree t
+                    , "does not match inferred type:"
+                    , printTree t'
+                    ]
+            )
+        applySt s1 $ do
+            s2 <- unify t t'
+            return (s2 `compose` s1, t, e')
+
+    -- \| ------------------
+    -- \|   Γ ⊢ i : Int, ∅
+
+    ELit (LInt n) ->
+        return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
+    ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
+    -- \| x : σ ∈ Γ   τ = inst(σ)
+    -- \| ----------------------
+    -- \|     Γ ⊢ x : τ, ∅
+
+    EId i -> do
+        var <- asks vars
+        case M.lookup i var of
+            Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
+            Nothing -> do
+                sig <- gets sigs
+                case M.lookup i sig of
+                    Just t -> return (nullSubst, t, T.EId (i, t))
+                    Nothing -> do
+                        constr <- gets constructors
+                        case M.lookup i constr of
+                            Just t -> return (nullSubst, t, T.EId (i, t))
+                            Nothing ->
+                                throwError $
+                                    "Unbound variable: " ++ show i
+
+    -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
+    -- \| ---------------------------------
+    -- \|     Γ ⊢ w λx. e : Sτ → τ', S
+
+    EAbs name e -> do
+        fr <- fresh
+        withBinding name (Forall [] fr) $ do
+            (s1, t', e') <- algoW e
+            let varType = apply s1 fr
+            let newArr = TArr varType t'
+            return (s1, newArr, T.EAbs newArr (name, varType) e')
+
+    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
+    -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
+    -- \| ------------------------------------------
+    -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
+    -- This might be wrong
+
+    EAdd e0 e1 -> do
+        (s1, t0, e0') <- algoW e0
+        applySt s1 $ do
+            (s2, t1, e1') <- algoW e1
+            -- applySt s2 $ do
+            s3 <- unify (apply s2 t0) (TMono "Int")
+            s4 <- unify (apply s3 t1) (TMono "Int")
+            return
+                ( s4 `compose` s3 `compose` s2 `compose` s1
+                , TMono "Int"
+                , T.EAdd (TMono "Int") e0' e1'
+                )
+
+    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
+    -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
+    -- \| --------------------------------------
+    -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
+
+    EApp e0 e1 -> do
+        fr <- fresh
+        (s0, t0, e0') <- algoW e0
+        applySt s0 $ do
+            (s1, t1, e1') <- algoW e1
+            -- applySt s1 $ do
+            s2 <- unify (apply s1 t0) (TArr t1 fr)
+            let t = apply s2 fr
+            return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
+
+    -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
+    -- \| ----------------------------------------------
+    -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
+
+    -- The bar over S₀ and Γ means "generalize"
+
+    ELet name e0 e1 -> do
+        (s1, t1, e0') <- algoW e0
+        env <- asks vars
+        let t' = generalize (apply s1 env) t1
+        withBinding name t' $ do
+            (s2, t2, e1') <- algoW e1
+            return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
+    ECase caseExpr injs -> do
+        (_, t0, e0') <- algoW caseExpr
+        (injs', ts) <- mapAndUnzipM (checkInj t0) injs
+        case ts of
+            [] -> throwError "Case expression missing any matches"
+            ts -> do
+                unified <- zipWithM unify ts (tail ts)
+                let unified' = foldl' compose mempty unified
+                let typ = apply unified' (head ts)
+                return (unified', typ, T.ECase typ e0' injs')
+
+-- | Unify two types producing a new substitution
+unify :: Type -> Type -> Infer Subst
+unify t0 t1 = do
+    case (t0, t1) of
+        (TArr a b, TArr c d) -> do
+            s1 <- unify a c
+            s2 <- unify (apply s1 b) (apply s1 d)
+            return $ s1 `compose` s2
+        (TPol a, b) -> occurs a b
+        (a, TPol b) -> occurs b a
+        (TMono a, TMono b) ->
+            if a == b then return M.empty else throwError "Types do not unify"
+        -- \| TODO: Figure out a cleaner way to express the same thing
+        (TConstr (Constr name t), TConstr (Constr name' t')) ->
+            if name == name' && length t == length t'
+                then do
+                    xs <- zipWithM unify t t'
+                    return $ foldr compose nullSubst xs
+                else
+                    throwError $
+                        unwords
+                            [ "Type constructor:"
+                            , printTree name
+                            , "(" ++ printTree t ++ ")"
+                            , "does not match with:"
+                            , printTree name'
+                            , "(" ++ printTree t' ++ ")"
+                            ]
+        (a, b) ->
+            throwError . unwords $
+                [ "Type:"
+                , printTree a
+                , "can't be unified with:"
+                , printTree b
+                ]
+
+{- | Check if a type is contained in another type.
+I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
+such that these are equal
+-}
+occurs :: Ident -> Type -> Infer Subst
+occurs _ (TPol _) = return nullSubst
+occurs i t =
+    if S.member i (free t)
+        then
+            throwError $
+                unwords
+                    [ "Occurs check failed, can't unify"
+                    , printTree (TPol i)
+                    , "with"
+                    , printTree t
+                    ]
+        else return $ M.singleton i t
+
+-- | Generalize a type over all free variables in the substitution set
+generalize :: Map Ident Poly -> Type -> Poly
+generalize env t = Forall (S.toList $ free t S.\\ free env) t
+
+{- | Instantiate a polymorphic type. The free type variables are substituted
+with fresh ones.
+-}
+inst :: Poly -> Infer Type
+inst (Forall xs t) = do
+    xs' <- mapM (const fresh) xs
+    let s = M.fromList $ zip xs xs'
+    return $ apply s t
+
+-- | Compose two substitution sets
+compose :: Subst -> Subst -> Subst
+compose m1 m2 = M.map (apply m1) m2 `M.union` m1
+
+-- | A class representing free variables functions
+class FreeVars t where
+    -- | Get all free variables from t
+    free :: t -> Set Ident
+
+    -- | Apply a substitution to t
+    apply :: Subst -> t -> t
+
+instance FreeVars Type where
+    free :: Type -> Set Ident
+    free (TPol a) = S.singleton a
+    free (TMono _) = mempty
+    free (TArr a b) = free a `S.union` free b
+    -- \| Not guaranteed to be correct
+    free (TConstr (Constr _ a)) =
+        foldl' (\acc x -> free x `S.union` acc) S.empty a
+
+    apply :: Subst -> Type -> Type
+    apply sub t = do
+        case t of
+            TMono a -> TMono a
+            TPol a -> case M.lookup a sub of
+                Nothing -> TPol a
+                Just t -> t
+            TArr a b -> TArr (apply sub a) (apply sub b)
+            TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
+
+instance FreeVars Poly where
+    free :: Poly -> Set Ident
+    free (Forall xs t) = free t S.\\ S.fromList xs
+    apply :: Subst -> Poly -> Poly
+    apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
+
+instance FreeVars (Map Ident Poly) where
+    free :: Map Ident Poly -> Set Ident
+    free m = foldl' S.union S.empty (map free $ M.elems m)
+    apply :: Subst -> Map Ident Poly -> Map Ident Poly
+    apply s = M.map (apply s)
+
+-- | Apply substitutions to the environment.
+applySt :: Subst -> Infer a -> Infer a
+applySt s = local (\st -> st{vars = apply s (vars st)})
+
+-- | Represents the empty substition set
+nullSubst :: Subst
+nullSubst = M.empty
+
+-- | Generate a new fresh variable and increment the state counter
+fresh :: Infer Type
+fresh = do
+    n <- gets count
+    modify (\st -> st{count = n + 1})
+    return . TPol . Ident $ show n
+
+-- | Run the monadic action with an additional binding
+withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
+withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
+
+-- | Insert a function signature into the environment
+insertSig :: Ident -> Type -> Infer ()
+insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
+
+-- | Insert a constructor with its data type
+insertConstr :: Ident -> Type -> Infer ()
+insertConstr i t =
+    modify (\st -> st{constructors = M.insert i t (constructors st)})
+
+-------- PATTERN MATCHING ---------
+
+-- "case expr of", the type of 'expr' is caseType
+checkInj :: Type -> Inj -> Infer (T.Inj, Type)
+checkInj caseType (Inj it expr) = do
+    (args, t') <- initType caseType it
+    subst <- unify caseType t'
+    trace ("SUBST: " ++ show subst) return ()
+    applySt subst $ do
+        (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr)
+        return (T.Inj (it, t') e', t)
+
+initType :: Type -> Init -> Infer (Map Ident Poly, Type)
+initType expected = \case
+    InitLit lit -> do
+             trace (show "EXPECTED: " ++ show expected ++ "\nreturnType: " ++ show (litType lit)) return ()
+             if litType lit `isMoreSpecificOrEq` expected
+                then return (mempty, litType lit)
+                else
+                    throwError $
+                        unwords
+                            [ "Inferred type"
+                            , printTree $ litType lit
+                            , "does not match expected type:"
+                            , printTree expected
+                            ]
+    InitConstr c args -> do
+        st <- gets constructors
+        case M.lookup c st of
+            Nothing ->
+                throwError $
+                    unwords
+                        [ "Constructor:"
+                        , printTree c
+                        , "does not exist"
+                        ]
+            Just t -> do
+                let flat = flattenType t
+                let returnType = last flat
+                case ( length (init flat) == length args
+                     , returnType `isMoreSpecificOrEq` expected
+                     ) of
+                    (True, True) ->
+                        return
+                            ( M.fromList $ zip args (map (Forall []) flat)
+                            , expected
+                            )
+                    (False, _) ->
+                        throwError $
+                            "Can't partially match on the constructor: "
+                                ++ printTree c
+                    (_, False) ->
+                        throwError $
+                            unwords
+                                [ "Inferred type"
+                                , printTree returnType
+                                , "does not match expected type:"
+                                , printTree expected
+                                ]
+    InitCatch -> return (mempty, expected)
+
+flattenType :: Type -> [Type]
+flattenType (TArr a b) = flattenType a ++ flattenType b
+flattenType a = [a]
+
+litType :: Literal -> Type
+litType (LInt _) = TMono "Int"
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index af4734d..0c3df12 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -9,12 +9,13 @@ import Control.Monad.Reader
 import Control.Monad.State
 import Data.Foldable (traverse_)
 import Data.Functor.Identity (runIdentity)
+import Debug.Trace (trace)
 import Data.List (foldl')
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Set (Set)
 import Data.Set qualified as S
-import Debug.Trace (trace)
+import Data.Maybe (fromMaybe)
 import Grammar.Abs
 import Grammar.Print (printTree)
 import TypeChecker.TypeCheckerIr (
@@ -45,36 +46,23 @@ typecheck = run . checkPrg
 
 {- | Start by freshening the type variable of data types to avoid clash with
 other user defined polymorphic types
-This might be wrong for type constructors that work over several variables
 -}
 freshenData :: Data -> Infer Data
 freshenData (Data (Constr name ts) constrs) = do
-    fr <- fresh
-    let fr' = case fr of
-            TPol a -> a
-            -- Meh, this part assumes fresh generates a polymorphic type
-            _ ->
-                error
-                    "Bug: implementation of \
-                    \ fresh and freshenData are not compatible"
-    let new_ts = map (freshenType fr') ts
-    let new_constrs = map (freshenConstr fr') constrs
-    return $ Data (Constr name new_ts) new_constrs
-
+    let xs = (S.toList . free) =<< ts
+    frs <- traverse (const fresh) xs
+    let m = M.fromList $ zip xs frs
+    return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs)
+    
 {- | Freshen all polymorphic variables, regardless of name
 | freshenType "d" (a -> b -> c) becomes (d -> d -> d)
 -}
-freshenType :: Ident -> Type -> Type
-freshenType iden = \case
-    (TPol _) -> TPol iden
-    (TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
-    (TConstr (Constr a ts)) ->
-        TConstr (Constr a (map (freshenType iden) ts))
-    rest -> rest
-
-freshenConstr :: Ident -> Constructor -> Constructor
-freshenConstr iden (Constructor name t) =
-    Constructor name (freshenType iden t)
+freshenType :: Map Ident Type -> Type -> Type
+freshenType m t = case t of
+        TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m)
+        TMono mono -> TMono mono
+        TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2)
+        TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts))
 
 checkData :: Data -> Infer ()
 checkData d = do
@@ -108,7 +96,8 @@ retType a = a
 checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
     preRun bs
-    T.Program <$> checkDef bs
+    bs' <- checkDef bs
+    return $ T.Program bs'
   where
     preRun :: [Def] -> Infer ()
     preRun [] = return ()
@@ -122,7 +111,9 @@ checkPrg (Program bs) = do
         (DBind b) -> do
             b' <- checkBind b
             fmap (T.DBind b' :) (checkDef xs)
-        (DData d) -> fmap (T.DData d :) (checkDef xs)
+        (DData d) -> do
+            d' <- freshenData d
+            fmap (T.DData d' :) (checkDef xs)
 
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
@@ -205,7 +196,8 @@ algoW = \case
             )
         applySt s1 $ do
             s2 <- unify t t'
-            return (s2 `compose` s1, t, e')
+            let composition = s2 `compose` s1
+            return (composition, t, apply composition e')
 
     -- \| ------------------
     -- \|   Γ ⊢ i : Int, ∅
@@ -243,7 +235,7 @@ algoW = \case
             (s1, t', e') <- algoW e
             let varType = apply s1 fr
             let newArr = TArr varType t'
-            return (s1, newArr, T.EAbs newArr (name, varType) e')
+            return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e')
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
@@ -258,10 +250,11 @@ algoW = \case
             -- applySt s2 $ do
             s3 <- unify (apply s2 t0) (TMono "Int")
             s4 <- unify (apply s3 t1) (TMono "Int")
+            let composition = s4 `compose` s3 `compose` s2 `compose` s1
             return
-                ( s4 `compose` s3 `compose` s2 `compose` s1
+                ( composition
                 , TMono "Int"
-                , T.EAdd (TMono "Int") e0' e1'
+                , apply composition $ T.EAdd (TMono "Int") e0' e1'
                 )
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
@@ -277,7 +270,8 @@ algoW = \case
             -- applySt s1 $ do
             s2 <- unify (apply s1 t0) (TArr t1 fr)
             let t = apply s2 fr
-            return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
+            let composition = s2 `compose` s1 `compose` s0
+            return (composition, t, apply composition $ T.EApp t e0' e1')
 
     -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
     -- \| ----------------------------------------------
@@ -291,7 +285,9 @@ algoW = \case
         let t' = generalize (apply s1 env) t1
         withBinding name t' $ do
             (s2, t2, e1') <- algoW e1
-            return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
+            let composition = s2 `compose` s1
+            return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
+
     ECase caseExpr injs -> do
         (_, t0, e0') <- algoW caseExpr
         (injs', ts) <- mapAndUnzipM (checkInj t0) injs
@@ -299,15 +295,13 @@ algoW = \case
             [] -> throwError "Case expression missing any matches"
             ts -> do
                 unified <- zipWithM unify ts (tail ts)
-                let unified' = foldl' compose mempty unified
-                let typ = apply unified' (head ts)
-                return (unified', typ, T.ECase typ e0' injs')
+                let composition = foldl' compose mempty unified
+                let typ = apply composition (head ts)
+                return (composition, typ, apply composition $ T.ECase typ e0' injs')
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
 unify t0 t1 = do
-    trace ("t0: " ++ show t0) return ()
-    trace ("t1: " ++ show t1) return ()
     case (t0, t1) of
         (TArr a b, TArr c d) -> do
             s1 <- unify a c
@@ -343,7 +337,7 @@ unify t0 t1 = do
 
 {- | Check if a type is contained in another type.
 I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
-such that these are equal
+where these are equal
 -}
 occurs :: Ident -> Type -> Infer Subst
 occurs _ (TPol _) = return nullSubst
@@ -415,6 +409,30 @@ instance FreeVars (Map Ident Poly) where
     apply :: Subst -> Map Ident Poly -> Map Ident Poly
     apply s = M.map (apply s)
 
+instance FreeVars T.Exp where
+    free :: T.Exp -> Set Ident
+    free = error "free not implemented for T.Exp"
+    apply :: Subst -> T.Exp -> T.Exp
+    apply s = \case
+       T.EId (ident, t) -> T.EId (ident, apply s t)
+       T.ELit t lit -> T.ELit (apply s t) lit
+       T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
+       T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2)
+       T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2)
+       T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
+       T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs)
+    
+instance FreeVars T.Inj where
+    free :: T.Inj -> Set Ident
+    free = undefined
+    apply :: Subst -> T.Inj -> T.Inj
+    apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
+
+instance FreeVars [T.Inj] where
+    free :: [T.Inj] -> Set Ident
+    free = foldl' (\acc x -> free x `S.union` acc) mempty
+    apply s = map (apply s)
+
 -- | Apply substitutions to the environment.
 applySt :: Subst -> Infer a -> Infer a
 applySt s = local (\st -> st{vars = apply s (vars st)})
@@ -449,23 +467,16 @@ insertConstr i t =
 checkInj :: Type -> Inj -> Infer (T.Inj, Type)
 checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
-    (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr)
-    return (T.Inj (it, t') e', t)
+    subst <- unify caseType t'
+    applySt subst $ do
+        (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr)
+        return (T.Inj (it, t') e', t)
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
 initType expected = \case
-    InitLit lit ->
-        let returnType = litType lit
-         in if expected == returnType
-                then return (mempty, expected)
-                else
-                    throwError $
-                        unwords
-                            [ "Inferred type"
-                            , printTree returnType
-                            , "does not match expected type:"
-                            , printTree expected
-                            ]
+
+    InitLit lit -> error "Pattern match on literals not implemented yet"
+
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of
diff --git a/test_program b/test_program
index efa8eea..0d74a4e 100644
--- a/test_program
+++ b/test_program
@@ -1,50 +1,10 @@
--- data Bool () where {
---     True : Bool () 
---     False : Bool ()
--- };
--- 
--- data List ('a) where {
---     Nil : List ('a) 
---     Cons : ('a) -> List ('a) -> List ('a)
--- };
-
 data Maybe ('a) where {
     Nothing : Maybe ('a)
     Just : 'a -> Maybe ('a)
 };
 
--- id : 'a -> 'a ;
--- id x = x ;
+id : 'a -> 'a ;
+id x = x ;
 
--- main : Maybe ('a -> 'a) ;
--- main = Just id;
-
--- data Either ('a 'b) where {
---     Left : 'a -> Either ('a 'b)
---     Right : 'b -> Either ('a 'b)
--- };
-
--- safeHead : List ('a) -> Maybe ('a) ;
--- safeHead xs =
---     case xs of {
---         Nil => Nothing ;
---         Cons x xs => Just x
---     };
-
--- main : Maybe (_Int) ;
--- main = safeHead (Cons 0 (Cons 1 Nil)) ;
--- 
--- maybeToEither : Either ('a 'b) ->  Maybe ('a) ;
--- maybeToEither e =
---     case e of {
---         Left y => Nothing ;
---         Right x => Just x
---     };
- 
--- Bug. f not included in the case-expression context
-fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
-fmap f x =
-    case x of {
-        Just x => Just (f x) ;
-        Nothing => Nothing
-    }
+main : Maybe ('a -> 'a) ;
+main = Just id ;

From c3ea343d0012e05b6aa9e4f495e1a6c82a6db396 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Fri, 10 Mar 2023 16:54:29 +0100
Subject: [PATCH 57/71] unified top level type with expression type

---
 src/TypeChecker/TypeChecker.hs | 45 +++++++++++++++++-----------------
 test_program                   | 10 +-------
 2 files changed, 23 insertions(+), 32 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 0c3df12..779867b 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -9,13 +9,13 @@ import Control.Monad.Reader
 import Control.Monad.State
 import Data.Foldable (traverse_)
 import Data.Functor.Identity (runIdentity)
-import Debug.Trace (trace)
 import Data.List (foldl')
 import Data.Map (Map)
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Set qualified as S
-import Data.Maybe (fromMaybe)
+import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
 import TypeChecker.TypeCheckerIr (
@@ -53,16 +53,16 @@ freshenData (Data (Constr name ts) constrs) = do
     frs <- traverse (const fresh) xs
     let m = M.fromList $ zip xs frs
     return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs)
-    
+
 {- | Freshen all polymorphic variables, regardless of name
 | freshenType "d" (a -> b -> c) becomes (d -> d -> d)
 -}
 freshenType :: Map Ident Type -> Type -> Type
 freshenType m t = case t of
-        TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m)
-        TMono mono -> TMono mono
-        TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2)
-        TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts))
+    TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m)
+    TMono mono -> TMono mono
+    TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2)
+    TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts))
 
 checkData :: Data -> Infer ()
 checkData d = do
@@ -115,10 +115,12 @@ checkPrg (Program bs) = do
             d' <- freshenData d
             fmap (T.DData d' :) (checkDef xs)
 
+-- TODO: Unify top level types with the types of the expressions beneath
+-- PERHAPS DONE
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
-    (t', e') <- inferExp $ makeLambda e (reverse args)
-    s <- unify t t'
+    (t', e) <- inferExp $ makeLambda e (reverse args)
+    s <- unify t' t
     let t'' = apply s t
     unless
         (t `typeEq` t'')
@@ -130,7 +132,7 @@ checkBind (Bind n t _ args e) = do
                 , printTree t''
                 ]
         )
-    return $ T.Bind (n, t) e'
+    return $ T.Bind (n, t) (apply s e)
   where
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip EAbs)
@@ -287,7 +289,6 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             let composition = s2 `compose` s1
             return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
-
     ECase caseExpr injs -> do
         (_, t0, e0') <- algoW caseExpr
         (injs', ts) <- mapAndUnzipM (checkInj t0) injs
@@ -340,7 +341,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
 where these are equal
 -}
 occurs :: Ident -> Type -> Infer Subst
-occurs _ (TPol _) = return nullSubst
+occurs i t@(TPol a) = return (M.singleton i t)
 occurs i t =
     if S.member i (free t)
         then
@@ -414,14 +415,14 @@ instance FreeVars T.Exp where
     free = error "free not implemented for T.Exp"
     apply :: Subst -> T.Exp -> T.Exp
     apply s = \case
-       T.EId (ident, t) -> T.EId (ident, apply s t)
-       T.ELit t lit -> T.ELit (apply s t) lit
-       T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
-       T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2)
-       T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2)
-       T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
-       T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs)
-    
+        T.EId (ident, t) -> T.EId (ident, apply s t)
+        T.ELit t lit -> T.ELit (apply s t) lit
+        T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
+        T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2)
+        T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2)
+        T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
+        T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs)
+
 instance FreeVars T.Inj where
     free :: T.Inj -> Set Ident
     free = undefined
@@ -469,14 +470,12 @@ checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
     subst <- unify caseType t'
     applySt subst $ do
-        (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr)
+        (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr)
         return (T.Inj (it, t') e', t)
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
 initType expected = \case
-
     InitLit lit -> error "Pattern match on literals not implemented yet"
-
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of
diff --git a/test_program b/test_program
index 0d74a4e..2470637 100644
--- a/test_program
+++ b/test_program
@@ -1,10 +1,2 @@
-data Maybe ('a) where {
-    Nothing : Maybe ('a)
-    Just : 'a -> Maybe ('a)
-};
-
 id : 'a -> 'a ;
-id x = x ;
-
-main : Maybe ('a -> 'a) ;
-main = Just id ;
+id = \x. x ;

From 9cd2cdb511fa0456a0f55cca08f6739617bb05b1 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 20 Mar 2023 17:40:09 +0100
Subject: [PATCH 58/71] continued work on pattern matching v2

---
 Session.vim                    | 219 +++++++++++++++++++++++++++++++++
 src/TypeChecker/TypeChecker.hs | 109 ++++++++--------
 test_program                   |  11 +-
 3 files changed, 279 insertions(+), 60 deletions(-)
 create mode 100644 Session.vim

diff --git a/Session.vim b/Session.vim
new file mode 100644
index 0000000..1db0ec6
--- /dev/null
+++ b/Session.vim
@@ -0,0 +1,219 @@
+let SessionLoad = 1
+let s:so_save = &g:so | let s:siso_save = &g:siso | setg so=0 siso=0 | setl so=-1 siso=-1
+let v:this_session=expand("<sfile>:p")
+silent only
+silent tabonly
+cd ~/Documents/bachelor_thesis/language
+if expand('%') == '' && !&modified && line('$') <= 1 && getline(1) == ''
+  let s:wipebuf = bufnr('%')
+endif
+let s:shortmess_save = &shortmess
+if &shortmess =~ 'A'
+  set shortmess=aoOA
+else
+  set shortmess=aoO
+endif
+badd +1 ~/Documents/bachelor_thesis/language
+badd +298 src/TypeChecker/TypeChecker.hs
+badd +7 test_program
+badd +46 src/TypeChecker/TypeCheckerIr.hs
+badd +6 Grammar.cf
+badd +1 src/Grammar/Abs.hs
+argglobal
+%argdel
+$argadd ~/Documents/bachelor_thesis/language
+set stal=2
+tabnew +setlocal\ bufhidden=wipe
+tabnew +setlocal\ bufhidden=wipe
+tabnew +setlocal\ bufhidden=wipe
+tabrewind
+edit src/TypeChecker/TypeChecker.hs
+let s:save_splitbelow = &splitbelow
+let s:save_splitright = &splitright
+set splitbelow splitright
+wincmd _ | wincmd |
+vsplit
+1wincmd h
+wincmd w
+let &splitbelow = s:save_splitbelow
+let &splitright = s:save_splitright
+wincmd t
+let s:save_winminheight = &winminheight
+let s:save_winminwidth = &winminwidth
+set winminheight=0
+set winheight=1
+set winminwidth=0
+set winwidth=1
+exe 'vert 1resize ' . ((&columns * 99 + 86) / 173)
+exe 'vert 2resize ' . ((&columns * 73 + 86) / 173)
+argglobal
+setlocal fdm=manual
+setlocal fde=0
+setlocal fmr={{{,}}}
+setlocal fdi=#
+setlocal fdl=0
+setlocal fml=1
+setlocal fdn=20
+setlocal fen
+silent! normal! zE
+let &fdl = &fdl
+let s:l = 298 - ((18 * winheight(0) + 21) / 42)
+if s:l < 1 | let s:l = 1 | endif
+keepjumps exe s:l
+normal! zt
+keepjumps 298
+normal! 029|
+lcd ~/Documents/bachelor_thesis/language
+wincmd w
+argglobal
+if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/Grammar.cf", ":p")) | buffer ~/Documents/bachelor_thesis/language/Grammar.cf | else | edit ~/Documents/bachelor_thesis/language/Grammar.cf | endif
+if &buftype ==# 'terminal'
+  silent file ~/Documents/bachelor_thesis/language/Grammar.cf
+endif
+balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs
+setlocal fdm=manual
+setlocal fde=0
+setlocal fmr={{{,}}}
+setlocal fdi=#
+setlocal fdl=0
+setlocal fml=1
+setlocal fdn=20
+setlocal fen
+silent! normal! zE
+let &fdl = &fdl
+let s:l = 7 - ((6 * winheight(0) + 21) / 42)
+if s:l < 1 | let s:l = 1 | endif
+keepjumps exe s:l
+normal! zt
+keepjumps 7
+normal! 0
+lcd ~/Documents/bachelor_thesis/language
+wincmd w
+exe 'vert 1resize ' . ((&columns * 99 + 86) / 173)
+exe 'vert 2resize ' . ((&columns * 73 + 86) / 173)
+tabnext
+edit ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs
+let s:save_splitbelow = &splitbelow
+let s:save_splitright = &splitright
+set splitbelow splitright
+wincmd _ | wincmd |
+vsplit
+1wincmd h
+wincmd w
+let &splitbelow = s:save_splitbelow
+let &splitright = s:save_splitright
+wincmd t
+let s:save_winminheight = &winminheight
+let s:save_winminwidth = &winminwidth
+set winminheight=0
+set winheight=1
+set winminwidth=0
+set winwidth=1
+exe 'vert 1resize ' . ((&columns * 86 + 86) / 173)
+exe 'vert 2resize ' . ((&columns * 86 + 86) / 173)
+argglobal
+balt ~/Documents/bachelor_thesis/language/test_program
+setlocal fdm=manual
+setlocal fde=0
+setlocal fmr={{{,}}}
+setlocal fdi=#
+setlocal fdl=0
+setlocal fml=1
+setlocal fdn=20
+setlocal fen
+silent! normal! zE
+let &fdl = &fdl
+let s:l = 1 - ((0 * winheight(0) + 21) / 42)
+if s:l < 1 | let s:l = 1 | endif
+keepjumps exe s:l
+normal! zt
+keepjumps 1
+normal! 0
+lcd ~/Documents/bachelor_thesis/language
+wincmd w
+argglobal
+if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs", ":p")) | buffer ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | else | edit ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | endif
+if &buftype ==# 'terminal'
+  silent file ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs
+endif
+balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs
+setlocal fdm=manual
+setlocal fde=0
+setlocal fmr={{{,}}}
+setlocal fdi=#
+setlocal fdl=0
+setlocal fml=1
+setlocal fdn=20
+setlocal fen
+silent! normal! zE
+let &fdl = &fdl
+let s:l = 1 - ((0 * winheight(0) + 21) / 42)
+if s:l < 1 | let s:l = 1 | endif
+keepjumps exe s:l
+normal! zt
+keepjumps 1
+normal! 0
+lcd ~/Documents/bachelor_thesis/language
+wincmd w
+exe 'vert 1resize ' . ((&columns * 86 + 86) / 173)
+exe 'vert 2resize ' . ((&columns * 86 + 86) / 173)
+tabnext
+edit ~/Documents/bachelor_thesis/language/Grammar.cf
+argglobal
+balt ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs
+setlocal fdm=manual
+setlocal fde=0
+setlocal fmr={{{,}}}
+setlocal fdi=#
+setlocal fdl=0
+setlocal fml=1
+setlocal fdn=20
+setlocal fen
+silent! normal! zE
+let &fdl = &fdl
+let s:l = 40 - ((12 * winheight(0) + 21) / 42)
+if s:l < 1 | let s:l = 1 | endif
+keepjumps exe s:l
+normal! zt
+keepjumps 40
+normal! 0
+lcd ~/Documents/bachelor_thesis/language
+tabnext
+edit ~/Documents/bachelor_thesis/language/test_program
+argglobal
+balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs
+setlocal fdm=manual
+setlocal fde=0
+setlocal fmr={{{,}}}
+setlocal fdi=#
+setlocal fdl=0
+setlocal fml=1
+setlocal fdn=20
+setlocal fen
+silent! normal! zE
+let &fdl = &fdl
+let s:l = 7 - ((6 * winheight(0) + 21) / 42)
+if s:l < 1 | let s:l = 1 | endif
+keepjumps exe s:l
+normal! zt
+keepjumps 7
+normal! 010|
+lcd ~/Documents/bachelor_thesis/language
+tabnext 1
+set stal=1
+if exists('s:wipebuf') && len(win_findbuf(s:wipebuf)) == 0 && getbufvar(s:wipebuf, '&buftype') isnot# 'terminal'
+  silent exe 'bwipe ' . s:wipebuf
+endif
+unlet! s:wipebuf
+set winheight=1 winwidth=20
+let &shortmess = s:shortmess_save
+let s:sx = expand("<sfile>:p:r")."x.vim"
+if filereadable(s:sx)
+  exe "source " . fnameescape(s:sx)
+endif
+let &g:so = s:so_save | let &g:siso = s:siso_save
+set hlsearch
+nohlsearch
+doautoall SessionLoadPost
+unlet SessionLoad
+" vim: set ft=vim :
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 779867b..ec7b005 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -8,13 +8,16 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.State
 import Data.Foldable (traverse_)
+import Data.Function (on)
 import Data.Functor.Identity (runIdentity)
 import Data.List (foldl')
+import Data.List.Extra (allSame)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Set qualified as S
+import Data.Tree (flatten)
 import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
@@ -204,9 +207,9 @@ algoW = \case
     -- \| ------------------
     -- \|   Γ ⊢ i : Int, ∅
 
-    ELit (LInt n) ->
-        return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
-    ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
+    ELit lit ->
+        let lt = litType lit
+         in return (nullSubst, lt, T.ELit lt lit)
     -- \| x : σ ∈ Γ   τ = inst(σ)
     -- \| ----------------------
     -- \|     Γ ⊢ x : τ, ∅
@@ -289,16 +292,14 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             let composition = s2 `compose` s1
             return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
+
+    -- TODO: give caseExpr a concrete type before proceeding
+    -- probably by returning substitutions in the functions used in this body
     ECase caseExpr injs -> do
-        (_, t0, e0') <- algoW caseExpr
-        (injs', ts) <- mapAndUnzipM (checkInj t0) injs
-        case ts of
-            [] -> throwError "Case expression missing any matches"
-            ts -> do
-                unified <- zipWithM unify ts (tail ts)
-                let composition = foldl' compose mempty unified
-                let typ = apply composition (head ts)
-                return (composition, typ, apply composition $ T.ECase typ e0' injs')
+        (sub, _, e') <- algoW caseExpr
+        trace ("SUB: " ++ show sub) return ()
+        t <- checkCase caseExpr injs
+        return (sub, t, T.ECase t e' (map (\(Inj i _) -> T.Inj (i, t) e') injs))
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -312,7 +313,6 @@ unify t0 t1 = do
         (a, TPol b) -> occurs b a
         (TMono a, TMono b) ->
             if a == b then return M.empty else throwError "Types do not unify"
-        -- \| TODO: Figure out a cleaner way to express the same thing
         (TConstr (Constr name t), TConstr (Constr name' t')) ->
             if name == name' && length t == length t'
                 then do
@@ -464,52 +464,45 @@ insertConstr i t =
 
 -------- PATTERN MATCHING ---------
 
--- "case expr of", the type of 'expr' is caseType
-checkInj :: Type -> Inj -> Infer (T.Inj, Type)
-checkInj caseType (Inj it expr) = do
-    (args, t') <- initType caseType it
-    subst <- unify caseType t'
-    applySt subst $ do
-        (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr)
-        return (T.Inj (it, t') e', t)
+unifyAll :: [Type] -> Infer [Subst]
+unifyAll [] = return []
+unifyAll [_] = return []
+unifyAll (x : y : xs) = do
+    uni <- unify x y
+    all <- unifyAll (y : xs)
+    return $ uni : all
 
-initType :: Type -> Init -> Infer (Map Ident Poly, Type)
-initType expected = \case
-    InitLit lit -> error "Pattern match on literals not implemented yet"
-    InitConstr c args -> do
-        st <- gets constructors
-        case M.lookup c st of
-            Nothing ->
-                throwError $
-                    unwords
-                        [ "Constructor:"
-                        , printTree c
-                        , "does not exist"
-                        ]
-            Just t -> do
-                let flat = flattenType t
-                let returnType = last flat
-                case ( length (init flat) == length args
-                     , returnType `isMoreSpecificOrEq` expected
-                     ) of
-                    (True, True) ->
-                        return
-                            ( M.fromList $ zip args (map (Forall []) flat)
-                            , expected
-                            )
-                    (False, _) ->
-                        throwError $
-                            "Can't partially match on the constructor: "
-                                ++ printTree c
-                    (_, False) ->
-                        throwError $
-                            unwords
-                                [ "Inferred type"
-                                , printTree returnType
-                                , "does not match expected type:"
-                                , printTree expected
-                                ]
-    InitCatch -> return (mempty, expected)
+checkCase :: Exp -> [Inj] -> Infer Type
+checkCase e injs = do
+    expT <- fst <$> inferExp e
+    (injTs, returns) <- mapAndUnzipM checkInj injs
+    unifyAll (expT : injTs)
+    subst <- foldl1 compose <$> zipWithM unify returns (tail returns)
+    let substed = map (apply subst) returns
+    unless (allSame substed || null substed) (throwError "Different return types of case, or no cases")
+    return $ head substed
+
+{- | fst = type of init
+| snd = type of expr
+-}
+checkInj :: Inj -> Infer (Type, Type)
+checkInj (Inj it expr) = do
+    initT <- inferInit it
+    (exprT, _) <- inferExp expr
+    return (initT, exprT)
+
+inferInit :: Init -> Infer Type
+inferInit = \case
+    InitLit lit -> return $ litType lit
+    InitConstr fn vars -> do
+        gets (M.lookup fn . constructors) >>= \case
+            Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist"
+            Just a -> do
+                let ft = init $ flattenType a
+                case compare (length vars) (length ft) of
+                    EQ -> return . last $ flattenType a
+                    _ -> throwError "Partial pattern match not allowed"
+    InitCatch -> fresh
 
 flattenType :: Type -> [Type]
 flattenType (TArr a b) = flattenType a ++ flattenType b
diff --git a/test_program b/test_program
index 2470637..a8accca 100644
--- a/test_program
+++ b/test_program
@@ -1,2 +1,9 @@
-id : 'a -> 'a ;
-id = \x. x ;
+data Bool () where {
+    True : Bool ()
+    False : Bool ()
+};
+
+main : Bool () -> _Int ;
+main x = case x of {
+    1 => 0
+}

From 4c015a4aac7e184c0d3342ed9fddf4d2ac32f558 Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Tue, 21 Mar 2023 14:33:18 +0100
Subject: [PATCH 59/71] initial pattern matching implementation. should be
 somewhat correct

---
 src/TypeChecker/TypeChecker.hs   | 47 +++++++++++++++-----------------
 src/TypeChecker/TypeCheckerIr.hs |  3 +-
 test_program                     | 10 +++++--
 3 files changed, 32 insertions(+), 28 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index ec7b005..af62451 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -118,11 +118,10 @@ checkPrg (Program bs) = do
             d' <- freshenData d
             fmap (T.DData d' :) (checkDef xs)
 
--- TODO: Unify top level types with the types of the expressions beneath
--- PERHAPS DONE
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
-    (t', e) <- inferExp $ makeLambda e (reverse args)
+    let lambda = makeLambda e (reverse args)
+    (t', e) <- inferExp lambda
     s <- unify t' t
     let t'' = apply s t
     unless
@@ -296,10 +295,11 @@ algoW = \case
     -- TODO: give caseExpr a concrete type before proceeding
     -- probably by returning substitutions in the functions used in this body
     ECase caseExpr injs -> do
-        (sub, _, e') <- algoW caseExpr
-        trace ("SUB: " ++ show sub) return ()
-        t <- checkCase caseExpr injs
-        return (sub, t, T.ECase t e' (map (\(Inj i _) -> T.Inj (i, t) e') injs))
+        (sub, t, e') <- algoW caseExpr
+        (subst, t) <- checkCase t injs
+        let composition = subst `compose` sub
+        let t' = apply composition t
+        return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, t') e') injs))
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -328,12 +328,18 @@ unify t0 t1 = do
                             , printTree name'
                             , "(" ++ printTree t' ++ ")"
                             ]
-        (a, b) ->
+        (a, b) -> do
+            ctx <- ask
+            env <- get
             throwError . unwords $
                 [ "Type:"
                 , printTree a
                 , "can't be unified with:"
                 , printTree b
+                , "\nCtx:"
+                , show ctx 
+                , "\nEnv:"
+                , show env
                 ]
 
 {- | Check if a type is contained in another type.
@@ -464,23 +470,12 @@ insertConstr i t =
 
 -------- PATTERN MATCHING ---------
 
-unifyAll :: [Type] -> Infer [Subst]
-unifyAll [] = return []
-unifyAll [_] = return []
-unifyAll (x : y : xs) = do
-    uni <- unify x y
-    all <- unifyAll (y : xs)
-    return $ uni : all
-
-checkCase :: Exp -> [Inj] -> Infer Type
-checkCase e injs = do
-    expT <- fst <$> inferExp e
-    (injTs, returns) <- mapAndUnzipM checkInj injs
-    unifyAll (expT : injTs)
-    subst <- foldl1 compose <$> zipWithM unify returns (tail returns)
-    let substed = map (apply subst) returns
-    unless (allSame substed || null substed) (throwError "Different return types of case, or no cases")
-    return $ head substed
+checkCase :: Type -> [Inj] -> Infer (Subst, Type)
+checkCase expT injs = do
+    (injs, returns) <- mapAndUnzipM checkInj injs
+    (sub, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, (a `apply` acc))) <$> unify x acc) (nullSubst, expT) injs
+    t <- foldM (\acc x -> (`apply` acc) <$> unify x acc) (head returns) (tail returns)
+    return (sub, t)
 
 {- | fst = type of init
 | snd = type of expr
@@ -510,3 +505,5 @@ flattenType a = [a]
 
 litType :: Literal -> Type
 litType (LInt _) = TMono "Int"
+
+ctrace a = trace (show a) a
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 475201e..016dd8a 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -23,12 +23,13 @@ data Poly = Forall [Ident] Type
     deriving (Show)
 
 newtype Ctx = Ctx {vars :: Map Ident Poly}
+    deriving Show
 
 data Env = Env
     { count :: Int
     , sigs :: Map Ident Type
     , constructors :: Map Ident Type
-    }
+    } deriving Show
 
 type Error = String
 type Subst = Map Ident Type
diff --git a/test_program b/test_program
index a8accca..2d6fed1 100644
--- a/test_program
+++ b/test_program
@@ -3,7 +3,13 @@ data Bool () where {
     False : Bool ()
 };
 
-main : Bool () -> _Int ;
+data Maybe ('a) where {
+    Nothing : Maybe ('a)
+    Just : 'a -> Maybe ('a)
+};
+
+main : Bool () -> Maybe (Bool ()) ;
 main x = case x of {
-    1 => 0
+    True => Nothing;
+    False => Just 0
 }

From 3026a96eb7e215ccdda1dd1fbc6d0ecf13d583d7 Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Tue, 21 Mar 2023 14:51:06 +0100
Subject: [PATCH 60/71] added todo for class

---
 src/TypeChecker/TypeChecker.hs | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index af62451..d909e49 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -377,6 +377,9 @@ inst (Forall xs t) = do
 compose :: Subst -> Subst -> Subst
 compose m1 m2 = M.map (apply m1) m2 `M.union` m1
 
+-- TODO: Split this class into two separate classes, one for free variables
+--       and one for applying substitutions
+
 -- | A class representing free variables functions
 class FreeVars t where
     -- | Get all free variables from t

From 509de4415e967af55f3bbc349080cfe34d45016e Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Tue, 21 Mar 2023 17:09:03 +0100
Subject: [PATCH 61/71] progress on fixing bugs

---
 src/TypeChecker/TypeChecker.hs | 51 +++++++++++++++++++++-------------
 test_program                   | 27 ++++++++++++------
 2 files changed, 49 insertions(+), 29 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index d909e49..7e59793 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -7,17 +7,16 @@ module TypeChecker.TypeChecker where
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.State
+import Data.Bifunctor (second)
 import Data.Foldable (traverse_)
-import Data.Function (on)
 import Data.Functor.Identity (runIdentity)
 import Data.List (foldl')
-import Data.List.Extra (allSame)
+import Data.List.Extra (unsnoc)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Set qualified as S
-import Data.Tree (flatten)
 import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
@@ -296,10 +295,13 @@ algoW = \case
     -- probably by returning substitutions in the functions used in this body
     ECase caseExpr injs -> do
         (sub, t, e') <- algoW caseExpr
-        (subst, t) <- checkCase t injs
+        (subst, inj_t, ret_t) <- checkCase t injs
         let composition = subst `compose` sub
         let t' = apply composition t
-        return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, t') e') injs))
+        trace ("COMPOSITION: " ++ show composition) return ()
+        trace ("T: " ++ show t) return ()
+        trace ("T': " ++ show t') return ()
+        return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, inj_t) e') injs))
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -337,7 +339,7 @@ unify t0 t1 = do
                 , "can't be unified with:"
                 , printTree b
                 , "\nCtx:"
-                , show ctx 
+                , show ctx
                 , "\nEnv:"
                 , show env
                 ]
@@ -462,6 +464,10 @@ fresh = do
 withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
 withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
 
+-- | Run the monadic action with several additional bindings
+withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
+withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
+
 -- | Insert a function signature into the environment
 insertSig :: Ident -> Type -> Infer ()
 insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
@@ -473,34 +479,39 @@ insertConstr i t =
 
 -------- PATTERN MATCHING ---------
 
-checkCase :: Type -> [Inj] -> Infer (Subst, Type)
+checkCase :: Type -> [Inj] -> Infer (Subst, Type, Type)
 checkCase expT injs = do
     (injs, returns) <- mapAndUnzipM checkInj injs
-    (sub, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, (a `apply` acc))) <$> unify x acc) (nullSubst, expT) injs
-    t <- foldM (\acc x -> (`apply` acc) <$> unify x acc) (head returns) (tail returns)
-    return (sub, t)
+    (sub, injs_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injs
+    (_, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns)
+    return (sub, injs_type, returns_type)
 
 {- | fst = type of init
-| snd = type of expr
+   | snd = type of expr
 -}
 checkInj :: Inj -> Infer (Type, Type)
 checkInj (Inj it expr) = do
-    initT <- inferInit it
-    (exprT, _) <- inferExp expr
+    (initT, vars) <- inferInit it
+    let converted = map (second (Forall [])) vars
+    (exprT, _) <- withBindings converted (inferExp expr)
     return (initT, exprT)
 
-inferInit :: Init -> Infer Type
+inferInit :: Init -> Infer (Type, [T.Id])
 inferInit = \case
-    InitLit lit -> return $ litType lit
+    InitLit lit -> return (litType lit, mempty)
     InitConstr fn vars -> do
         gets (M.lookup fn . constructors) >>= \case
             Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist"
             Just a -> do
-                let ft = init $ flattenType a
-                case compare (length vars) (length ft) of
-                    EQ -> return . last $ flattenType a
-                    _ -> throwError "Partial pattern match not allowed"
-    InitCatch -> fresh
+                case unsnoc $ flattenType a of
+                    Nothing -> throwError "Partial pattern match not allowed"
+                    Just (vs, ret) ->
+                        case length vars `compare` length vs of
+                            EQ -> do
+                                trace ("IDS AND TYPES: " ++ show (zip vars vs)) return ()
+                                return (ret, zip vars vs)
+                            _ -> throwError "Partial pattern match not allowed"
+    InitCatch -> (,mempty) <$> fresh
 
 flattenType :: Type -> [Type]
 flattenType (TArr a b) = flattenType a ++ flattenType b
diff --git a/test_program b/test_program
index 2d6fed1..e420e37 100644
--- a/test_program
+++ b/test_program
@@ -1,15 +1,24 @@
-data Bool () where {
-    True : Bool ()
-    False : Bool ()
-};
+-- data Bool () where {
+--     True : Bool ()
+--     False : Bool ()
+-- };
 
 data Maybe ('a) where {
     Nothing : Maybe ('a)
     Just : 'a -> Maybe ('a)
 };
 
-main : Bool () -> Maybe (Bool ()) ;
-main x = case x of {
-    True => Nothing;
-    False => Just 0
-}
+-- main : Bool () -> Maybe (Bool ()) ;
+-- main x =
+--     case x of {
+--         True => Nothing;
+--         False => Just True
+--     };
+
+fun : Maybe (_Int) -> _Int ;
+fun a =
+    case a of {
+        Just b => b;
+        Nothing => 0
+    };
+

From 57fe8cd0a69cd7594506029bc859152d7011f455 Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Tue, 21 Mar 2023 22:02:28 +0100
Subject: [PATCH 62/71]  Fixed larger bug

 where pattern matching on `Just a` with type `Maybe b` could be used for
 any type.
---
 src/TypeChecker/TypeChecker.hs | 33 ++++++++++++---------------------
 test_program                   |  5 ++---
 2 files changed, 14 insertions(+), 24 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 7e59793..ee01952 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -290,18 +290,12 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             let composition = s2 `compose` s1
             return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
-
-    -- TODO: give caseExpr a concrete type before proceeding
-    -- probably by returning substitutions in the functions used in this body
     ECase caseExpr injs -> do
         (sub, t, e') <- algoW caseExpr
-        (subst, inj_t, ret_t) <- checkCase t injs
+        (subst, injs, ret_t) <- checkCase t injs
         let composition = subst `compose` sub
-        let t' = apply composition t
-        trace ("COMPOSITION: " ++ show composition) return ()
-        trace ("T: " ++ show t) return ()
-        trace ("T': " ++ show t') return ()
-        return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, inj_t) e') injs))
+        let t' = apply composition ret_t
+        return (composition, t', T.ECase t' e' injs)
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -349,7 +343,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
 where these are equal
 -}
 occurs :: Ident -> Type -> Infer Subst
-occurs i t@(TPol a) = return (M.singleton i t)
+occurs i t@(TPol _) = return (M.singleton i t)
 occurs i t =
     if S.member i (free t)
         then
@@ -479,22 +473,22 @@ insertConstr i t =
 
 -------- PATTERN MATCHING ---------
 
-checkCase :: Type -> [Inj] -> Infer (Subst, Type, Type)
+checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
 checkCase expT injs = do
-    (injs, returns) <- mapAndUnzipM checkInj injs
-    (sub, injs_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injs
-    (_, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns)
-    return (sub, injs_type, returns_type)
+    (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
+    (sub1, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injTs
+    (sub2, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns)
+    return (sub2 `compose` sub1, injs, returns_type)
 
 {- | fst = type of init
    | snd = type of expr
 -}
-checkInj :: Inj -> Infer (Type, Type)
+checkInj :: Inj -> Infer (Type, T.Inj, Type)
 checkInj (Inj it expr) = do
     (initT, vars) <- inferInit it
     let converted = map (second (Forall [])) vars
-    (exprT, _) <- withBindings converted (inferExp expr)
-    return (initT, exprT)
+    (exprT, e) <- withBindings converted (inferExp expr)
+    return (initT, T.Inj (it, initT) e, exprT)
 
 inferInit :: Init -> Infer (Type, [T.Id])
 inferInit = \case
@@ -508,7 +502,6 @@ inferInit = \case
                     Just (vs, ret) ->
                         case length vars `compare` length vs of
                             EQ -> do
-                                trace ("IDS AND TYPES: " ++ show (zip vars vs)) return ()
                                 return (ret, zip vars vs)
                             _ -> throwError "Partial pattern match not allowed"
     InitCatch -> (,mempty) <$> fresh
@@ -519,5 +512,3 @@ flattenType a = [a]
 
 litType :: Literal -> Type
 litType (LInt _) = TMono "Int"
-
-ctrace a = trace (show a) a
diff --git a/test_program b/test_program
index e420e37..bc463fe 100644
--- a/test_program
+++ b/test_program
@@ -15,10 +15,9 @@ data Maybe ('a) where {
 --         False => Just True
 --     };
 
-fun : Maybe (_Int) -> _Int ;
+fun : Maybe ('a) -> 'a ;
 fun a =
     case a of {
-        Just b => b;
-        Nothing => 0
+        Just c => c
     };
 

From 33b69a1895715e5d0d949c53df487ff65c6cf0de Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Tue, 21 Mar 2023 22:07:21 +0100
Subject: [PATCH 63/71] Improved formatting

---
 src/TypeChecker/TypeChecker.hs | 78 +++++++++++++++++++++++-----------
 1 file changed, 54 insertions(+), 24 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index ee01952..1339212 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -54,7 +54,15 @@ freshenData (Data (Constr name ts) constrs) = do
     let xs = (S.toList . free) =<< ts
     frs <- traverse (const fresh) xs
     let m = M.fromList $ zip xs frs
-    return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs)
+    return $
+        Data
+            (Constr name (map (freshenType m) ts))
+            ( map
+                ( \(Constructor ident t) ->
+                    Constructor ident (freshenType m t)
+                )
+                constrs
+            )
 
 {- | Freshen all polymorphic variables, regardless of name
 | freshenType "d" (a -> b -> c) becomes (d -> d -> d)
@@ -199,8 +207,8 @@ algoW = \case
             )
         applySt s1 $ do
             s2 <- unify t t'
-            let composition = s2 `compose` s1
-            return (composition, t, apply composition e')
+            let comp = s2 `compose` s1
+            return (comp, t, apply comp e')
 
     -- \| ------------------
     -- \|   Γ ⊢ i : Int, ∅
@@ -253,11 +261,11 @@ algoW = \case
             -- applySt s2 $ do
             s3 <- unify (apply s2 t0) (TMono "Int")
             s4 <- unify (apply s3 t1) (TMono "Int")
-            let composition = s4 `compose` s3 `compose` s2 `compose` s1
+            let comp = s4 `compose` s3 `compose` s2 `compose` s1
             return
-                ( composition
+                ( comp
                 , TMono "Int"
-                , apply composition $ T.EAdd (TMono "Int") e0' e1'
+                , apply comp $ T.EAdd (TMono "Int") e0' e1'
                 )
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
@@ -273,8 +281,8 @@ algoW = \case
             -- applySt s1 $ do
             s2 <- unify (apply s1 t0) (TArr t1 fr)
             let t = apply s2 fr
-            let composition = s2 `compose` s1 `compose` s0
-            return (composition, t, apply composition $ T.EApp t e0' e1')
+            let comp = s2 `compose` s1 `compose` s0
+            return (comp, t, apply comp $ T.EApp t e0' e1')
 
     -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
     -- \| ----------------------------------------------
@@ -288,14 +296,14 @@ algoW = \case
         let t' = generalize (apply s1 env) t1
         withBinding name t' $ do
             (s2, t2, e1') <- algoW e1
-            let composition = s2 `compose` s1
-            return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
+            let comp = s2 `compose` s1
+            return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1')
     ECase caseExpr injs -> do
         (sub, t, e') <- algoW caseExpr
         (subst, injs, ret_t) <- checkCase t injs
-        let composition = subst `compose` sub
-        let t' = apply composition ret_t
-        return (composition, t', T.ECase t' e' injs)
+        let comp = subst `compose` sub
+        let t' = apply comp ret_t
+        return (comp, t', T.ECase t' e' injs)
 
 -- | Unify two types producing a new substitution
 unify :: Type -> Type -> Infer Subst
@@ -420,13 +428,20 @@ instance FreeVars T.Exp where
     free = error "free not implemented for T.Exp"
     apply :: Subst -> T.Exp -> T.Exp
     apply s = \case
-        T.EId (ident, t) -> T.EId (ident, apply s t)
-        T.ELit t lit -> T.ELit (apply s t) lit
-        T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
-        T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2)
-        T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2)
-        T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
-        T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs)
+        T.EId (ident, t) ->
+            T.EId (ident, apply s t)
+        T.ELit t lit ->
+            T.ELit (apply s t) lit
+        T.ELet (T.Bind (ident, t) e1) e2 ->
+            T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
+        T.EApp t e1 e2 ->
+            T.EApp (apply s t) (apply s e1) (apply s e2)
+        T.EAdd t e1 e2 ->
+            T.EAdd (apply s t) (apply s e1) (apply s e2)
+        T.EAbs t1 (ident, t2) e ->
+            T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
+        T.ECase t e injs ->
+            T.ECase (apply s t) (apply s e) (apply s injs)
 
 instance FreeVars T.Inj where
     free :: T.Inj -> Set Ident
@@ -460,7 +475,8 @@ withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
 
 -- | Run the monadic action with several additional bindings
 withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
-withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
+withBindings xs =
+    local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
 
 -- | Insert a function signature into the environment
 insertSig :: Ident -> Type -> Infer ()
@@ -476,8 +492,20 @@ insertConstr i t =
 checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
 checkCase expT injs = do
     (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
-    (sub1, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injTs
-    (sub2, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns)
+    (sub1, _) <-
+        foldM
+            ( \(sub, acc) x ->
+                (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
+            )
+            (nullSubst, expT)
+            injTs
+    (sub2, returns_type) <-
+        foldM
+            ( \(sub, acc) x ->
+                (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
+            )
+            (nullSubst, head returns)
+            (tail returns)
     return (sub2 `compose` sub1, injs, returns_type)
 
 {- | fst = type of init
@@ -495,7 +523,9 @@ inferInit = \case
     InitLit lit -> return (litType lit, mempty)
     InitConstr fn vars -> do
         gets (M.lookup fn . constructors) >>= \case
-            Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist"
+            Nothing ->
+                throwError $
+                    "Constructor: " ++ printTree fn ++ " does not exist"
             Just a -> do
                 case unsnoc $ flattenType a of
                     Nothing -> throwError "Partial pattern match not allowed"

From 24007313cb444f4ac5bc15c5e4979c4e4c1d6f81 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 22 Mar 2023 10:10:11 +0100
Subject: [PATCH 64/71] added shadowing for ECase in Renamer

---
 "\\"                   | 511 -----------------------------------------
 src/Renamer/Renamer.hs |  19 +-
 2 files changed, 14 insertions(+), 516 deletions(-)
 delete mode 100644 "\\"

diff --git "a/\\" "b/\\"
deleted file mode 100644
index 90c24ff..0000000
--- "a/\\"
+++ /dev/null
@@ -1,511 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | A module for type checking and inference using algorithm W, Hindley-Milner
-module TypeChecker.TypeChecker where
-
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.Foldable (traverse_)
-import Data.Functor.Identity (runIdentity)
-import Debug.Trace (trace)
-import Data.List (foldl')
-import Data.Map (Map)
-import Data.Map qualified as M
-import Data.Set (Set)
-import Data.Set qualified as S
-import Data.Maybe (fromMaybe)
-import Grammar.Abs
-import Grammar.Print (printTree)
-import TypeChecker.TypeCheckerIr (
-    Ctx (..),
-    Env (..),
-    Error,
-    Infer,
-    Poly (..),
-    Subst,
- )
-import TypeChecker.TypeCheckerIr qualified as T
-
-initCtx = Ctx mempty
-
-initEnv = Env 0 mempty mempty
-
-runPretty :: Exp -> Either Error String
-runPretty = fmap (printTree . fst) . run . inferExp
-
-run :: Infer a -> Either Error a
-run = runC initEnv initCtx
-
-runC :: Env -> Ctx -> Infer a -> Either Error a
-runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
-
-typecheck :: Program -> Either Error T.Program
-typecheck = run . checkPrg
-
-{- | Start by freshening the type variable of data types to avoid clash with
-other user defined polymorphic types
-This might be wrong for type constructors that work over several variables
--}
--- freshenData :: Data -> Infer Data
--- freshenData (Data (Constr name ts) constrs) = do
---     new_ts <- traverse freshenType ts
---     new_constrs <- traverse freshenConstr constrs
---     return $ Data (Constr name new_ts) new_constrs
---TODO: Fix incorrect behavior here
-
-{- | Freshen all polymorphic variables, regardless of name
-| freshenType "d" (a -> b -> c) becomes (d -> d -> d)
--}
--- freshenType :: Type -> Infer Type
--- freshenType t = do
---     let freeVars = (S.toList $ free t)
---     frs <- sequenceA $ map (const fresh) freeVars
---     let remaps = M.fromList $ zip freeVars frs
---     return $ go remaps t
---   where
---     go :: Map Ident Type -> Type -> Type
---     go m t = case t of
---         TPol a -> fromMaybe (error "bug in \'free\'") (M.lookup a m )
---         TMono a -> TMono a
---         TArr t1 t2 -> TArr (go m t1) (go m t2)
---         TConstr (Constr ident ts) -> TConstr (Constr ident (map (go m) ts))
-
--- freshenConstr :: Constructor -> Infer Constructor
--- freshenConstr (Constructor name t) = do
---     t' <- freshenType t
---     return $ Constructor name t'
-
-checkData :: Data -> Infer ()
-checkData d = do
-    case d of
-        (Data typ@(Constr name ts) constrs) -> do
-            unless
-                (all isPoly ts)
-                (throwError $ unwords ["Data type incorrectly declared"])
-            traverse_
-                ( \(Constructor name' t') ->
-                    if TConstr typ == retType t'
-                        then insertConstr name' t'
-                        else
-                            throwError $
-                                unwords
-                                    [ "return type of constructor:"
-                                    , printTree name
-                                    , "with type:"
-                                    , printTree (retType t')
-                                    , "does not match data: "
-                                    , printTree typ
-                                    ]
-                )
-                constrs
-
-retType :: Type -> Type
-retType (TArr _ t2) = retType t2
-retType a = a
-
-checkPrg :: Program -> Infer T.Program
-checkPrg (Program bs) = do
-    preRun bs
-    bs' <- checkDef bs
-    return $ T.Program bs'
-  where
-    preRun :: [Def] -> Infer ()
-    preRun [] = return ()
-    preRun (x : xs) = case x of
-        DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs
-        DData d@(Data _ _) -> checkData d >> preRun xs
-
-    checkDef :: [Def] -> Infer [T.Def]
-    checkDef [] = return []
-    checkDef (x : xs) = case x of
-        (DBind b) -> do
-            b' <- checkBind b
-            fmap (T.DBind b' :) (checkDef xs)
-        (DData d) -> fmap (T.DData d :) (checkDef xs)
-
-checkBind :: Bind -> Infer T.Bind
-checkBind (Bind n t _ args e) = do
-    (t', e') <- inferExp $ makeLambda e (reverse args)
-    s <- unify t t'
-    let t'' = apply s t
-    unless
-        (t `typeEq` t'')
-        ( throwError $
-            unwords
-                [ "Top level signature"
-                , printTree t
-                , "does not match body with inferred type:"
-                , printTree t''
-                ]
-        )
-    return $ T.Bind (n, t) e'
-  where
-    makeLambda :: Exp -> [Ident] -> Exp
-    makeLambda = foldl (flip EAbs)
-
-{- | Check if two types are considered equal
-  For the purpose of the algorithm two polymorphic types are always considered
-  equal
--}
-typeEq :: Type -> Type -> Bool
-typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
-typeEq (TMono a) (TMono b) = a == b
-typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) =
-    length a == length b
-        && name == name'
-        && and (zipWith typeEq a b)
-typeEq (TPol _) (TPol _) = True
-typeEq _ _ = False
-
-isMoreSpecificOrEq :: Type -> Type -> Bool
-isMoreSpecificOrEq _ (TPol _) = True
-isMoreSpecificOrEq (TArr a b) (TArr c d) =
-    isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
-isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
-    n1 == n2
-        && length ts1 == length ts2
-        && and (zipWith isMoreSpecificOrEq ts1 ts2)
-isMoreSpecificOrEq a b = a == b
-
-isPoly :: Type -> Bool
-isPoly (TPol _) = True
-isPoly _ = False
-
-inferExp :: Exp -> Infer (Type, T.Exp)
-inferExp e = do
-    (s, t, e') <- algoW e
-    let subbed = apply s t
-    return (subbed, replace subbed e')
-
-replace :: Type -> T.Exp -> T.Exp
-replace t = \case
-    T.ELit _ e -> T.ELit t e
-    T.EId (n, _) -> T.EId (n, t)
-    T.EAbs _ name e -> T.EAbs t name e
-    T.EApp _ e1 e2 -> T.EApp t e1 e2
-    T.EAdd _ e1 e2 -> T.EAdd t e1 e2
-    T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
-    T.ECase _ expr injs -> T.ECase t expr injs
-
-algoW :: Exp -> Infer (Subst, Type, T.Exp)
-algoW = \case
-    -- \| TODO: More testing need to be done. Unsure of the correctness of this
-    EAnn e t -> do
-        (s1, t', e') <- algoW e
-        unless
-            (t `isMoreSpecificOrEq` t')
-            ( throwError $
-                unwords
-                    [ "Annotated type:"
-                    , printTree t
-                    , "does not match inferred type:"
-                    , printTree t'
-                    ]
-            )
-        applySt s1 $ do
-            s2 <- unify t t'
-            return (s2 `compose` s1, t, e')
-
-    -- \| ------------------
-    -- \|   Γ ⊢ i : Int, ∅
-
-    ELit (LInt n) ->
-        return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
-    ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
-    -- \| x : σ ∈ Γ   τ = inst(σ)
-    -- \| ----------------------
-    -- \|     Γ ⊢ x : τ, ∅
-
-    EId i -> do
-        var <- asks vars
-        case M.lookup i var of
-            Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
-            Nothing -> do
-                sig <- gets sigs
-                case M.lookup i sig of
-                    Just t -> return (nullSubst, t, T.EId (i, t))
-                    Nothing -> do
-                        constr <- gets constructors
-                        case M.lookup i constr of
-                            Just t -> return (nullSubst, t, T.EId (i, t))
-                            Nothing ->
-                                throwError $
-                                    "Unbound variable: " ++ show i
-
-    -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
-    -- \| ---------------------------------
-    -- \|     Γ ⊢ w λx. e : Sτ → τ', S
-
-    EAbs name e -> do
-        fr <- fresh
-        withBinding name (Forall [] fr) $ do
-            (s1, t', e') <- algoW e
-            let varType = apply s1 fr
-            let newArr = TArr varType t'
-            return (s1, newArr, T.EAbs newArr (name, varType) e')
-
-    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
-    -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
-    -- \| ------------------------------------------
-    -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
-    -- This might be wrong
-
-    EAdd e0 e1 -> do
-        (s1, t0, e0') <- algoW e0
-        applySt s1 $ do
-            (s2, t1, e1') <- algoW e1
-            -- applySt s2 $ do
-            s3 <- unify (apply s2 t0) (TMono "Int")
-            s4 <- unify (apply s3 t1) (TMono "Int")
-            return
-                ( s4 `compose` s3 `compose` s2 `compose` s1
-                , TMono "Int"
-                , T.EAdd (TMono "Int") e0' e1'
-                )
-
-    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
-    -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
-    -- \| --------------------------------------
-    -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
-
-    EApp e0 e1 -> do
-        fr <- fresh
-        (s0, t0, e0') <- algoW e0
-        applySt s0 $ do
-            (s1, t1, e1') <- algoW e1
-            -- applySt s1 $ do
-            s2 <- unify (apply s1 t0) (TArr t1 fr)
-            let t = apply s2 fr
-            return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
-
-    -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
-    -- \| ----------------------------------------------
-    -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
-
-    -- The bar over S₀ and Γ means "generalize"
-
-    ELet name e0 e1 -> do
-        (s1, t1, e0') <- algoW e0
-        env <- asks vars
-        let t' = generalize (apply s1 env) t1
-        withBinding name t' $ do
-            (s2, t2, e1') <- algoW e1
-            return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
-    ECase caseExpr injs -> do
-        (_, t0, e0') <- algoW caseExpr
-        (injs', ts) <- mapAndUnzipM (checkInj t0) injs
-        case ts of
-            [] -> throwError "Case expression missing any matches"
-            ts -> do
-                unified <- zipWithM unify ts (tail ts)
-                let unified' = foldl' compose mempty unified
-                let typ = apply unified' (head ts)
-                return (unified', typ, T.ECase typ e0' injs')
-
--- | Unify two types producing a new substitution
-unify :: Type -> Type -> Infer Subst
-unify t0 t1 = do
-    case (t0, t1) of
-        (TArr a b, TArr c d) -> do
-            s1 <- unify a c
-            s2 <- unify (apply s1 b) (apply s1 d)
-            return $ s1 `compose` s2
-        (TPol a, b) -> occurs a b
-        (a, TPol b) -> occurs b a
-        (TMono a, TMono b) ->
-            if a == b then return M.empty else throwError "Types do not unify"
-        -- \| TODO: Figure out a cleaner way to express the same thing
-        (TConstr (Constr name t), TConstr (Constr name' t')) ->
-            if name == name' && length t == length t'
-                then do
-                    xs <- zipWithM unify t t'
-                    return $ foldr compose nullSubst xs
-                else
-                    throwError $
-                        unwords
-                            [ "Type constructor:"
-                            , printTree name
-                            , "(" ++ printTree t ++ ")"
-                            , "does not match with:"
-                            , printTree name'
-                            , "(" ++ printTree t' ++ ")"
-                            ]
-        (a, b) ->
-            throwError . unwords $
-                [ "Type:"
-                , printTree a
-                , "can't be unified with:"
-                , printTree b
-                ]
-
-{- | Check if a type is contained in another type.
-I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
-such that these are equal
--}
-occurs :: Ident -> Type -> Infer Subst
-occurs _ (TPol _) = return nullSubst
-occurs i t =
-    if S.member i (free t)
-        then
-            throwError $
-                unwords
-                    [ "Occurs check failed, can't unify"
-                    , printTree (TPol i)
-                    , "with"
-                    , printTree t
-                    ]
-        else return $ M.singleton i t
-
--- | Generalize a type over all free variables in the substitution set
-generalize :: Map Ident Poly -> Type -> Poly
-generalize env t = Forall (S.toList $ free t S.\\ free env) t
-
-{- | Instantiate a polymorphic type. The free type variables are substituted
-with fresh ones.
--}
-inst :: Poly -> Infer Type
-inst (Forall xs t) = do
-    xs' <- mapM (const fresh) xs
-    let s = M.fromList $ zip xs xs'
-    return $ apply s t
-
--- | Compose two substitution sets
-compose :: Subst -> Subst -> Subst
-compose m1 m2 = M.map (apply m1) m2 `M.union` m1
-
--- | A class representing free variables functions
-class FreeVars t where
-    -- | Get all free variables from t
-    free :: t -> Set Ident
-
-    -- | Apply a substitution to t
-    apply :: Subst -> t -> t
-
-instance FreeVars Type where
-    free :: Type -> Set Ident
-    free (TPol a) = S.singleton a
-    free (TMono _) = mempty
-    free (TArr a b) = free a `S.union` free b
-    -- \| Not guaranteed to be correct
-    free (TConstr (Constr _ a)) =
-        foldl' (\acc x -> free x `S.union` acc) S.empty a
-
-    apply :: Subst -> Type -> Type
-    apply sub t = do
-        case t of
-            TMono a -> TMono a
-            TPol a -> case M.lookup a sub of
-                Nothing -> TPol a
-                Just t -> t
-            TArr a b -> TArr (apply sub a) (apply sub b)
-            TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
-
-instance FreeVars Poly where
-    free :: Poly -> Set Ident
-    free (Forall xs t) = free t S.\\ S.fromList xs
-    apply :: Subst -> Poly -> Poly
-    apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
-
-instance FreeVars (Map Ident Poly) where
-    free :: Map Ident Poly -> Set Ident
-    free m = foldl' S.union S.empty (map free $ M.elems m)
-    apply :: Subst -> Map Ident Poly -> Map Ident Poly
-    apply s = M.map (apply s)
-
--- | Apply substitutions to the environment.
-applySt :: Subst -> Infer a -> Infer a
-applySt s = local (\st -> st{vars = apply s (vars st)})
-
--- | Represents the empty substition set
-nullSubst :: Subst
-nullSubst = M.empty
-
--- | Generate a new fresh variable and increment the state counter
-fresh :: Infer Type
-fresh = do
-    n <- gets count
-    modify (\st -> st{count = n + 1})
-    return . TPol . Ident $ show n
-
--- | Run the monadic action with an additional binding
-withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
-withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
-
--- | Insert a function signature into the environment
-insertSig :: Ident -> Type -> Infer ()
-insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
-
--- | Insert a constructor with its data type
-insertConstr :: Ident -> Type -> Infer ()
-insertConstr i t =
-    modify (\st -> st{constructors = M.insert i t (constructors st)})
-
--------- PATTERN MATCHING ---------
-
--- "case expr of", the type of 'expr' is caseType
-checkInj :: Type -> Inj -> Infer (T.Inj, Type)
-checkInj caseType (Inj it expr) = do
-    (args, t') <- initType caseType it
-    subst <- unify caseType t'
-    trace ("SUBST: " ++ show subst) return ()
-    applySt subst $ do
-        (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr)
-        return (T.Inj (it, t') e', t)
-
-initType :: Type -> Init -> Infer (Map Ident Poly, Type)
-initType expected = \case
-    InitLit lit -> do
-             trace (show "EXPECTED: " ++ show expected ++ "\nreturnType: " ++ show (litType lit)) return ()
-             if litType lit `isMoreSpecificOrEq` expected
-                then return (mempty, litType lit)
-                else
-                    throwError $
-                        unwords
-                            [ "Inferred type"
-                            , printTree $ litType lit
-                            , "does not match expected type:"
-                            , printTree expected
-                            ]
-    InitConstr c args -> do
-        st <- gets constructors
-        case M.lookup c st of
-            Nothing ->
-                throwError $
-                    unwords
-                        [ "Constructor:"
-                        , printTree c
-                        , "does not exist"
-                        ]
-            Just t -> do
-                let flat = flattenType t
-                let returnType = last flat
-                case ( length (init flat) == length args
-                     , returnType `isMoreSpecificOrEq` expected
-                     ) of
-                    (True, True) ->
-                        return
-                            ( M.fromList $ zip args (map (Forall []) flat)
-                            , expected
-                            )
-                    (False, _) ->
-                        throwError $
-                            "Can't partially match on the constructor: "
-                                ++ printTree c
-                    (_, False) ->
-                        throwError $
-                            unwords
-                                [ "Inferred type"
-                                , printTree returnType
-                                , "does not match expected type:"
-                                , printTree expected
-                                ]
-    InitCatch -> return (mempty, expected)
-
-flattenType :: Type -> [Type]
-flattenType (TArr a b) = flattenType a ++ flattenType b
-flattenType a = [a]
-
-litType :: Literal -> Type
-litType (LInt _) = TMono "Int"
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index e8e6c38..d056868 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -15,6 +15,7 @@ import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Tuple.Extra (dupe)
+import Debug.Trace (trace)
 import Grammar.Abs
 
 -- | Rename all variables and local binds
@@ -70,9 +71,9 @@ renameExp old_names = \case
         (new_names, e') <- renameExp old_names e
         pure (new_names, EAnn e' t)
     ECase e injs -> do
-        (_, e') <- renameExp old_names e
-        (new_names, injs') <- renameInjs old_names injs
-        pure (new_names, ECase e' injs')
+        (new_names, e') <- renameExp old_names e
+        (new_names', injs') <- renameInjs new_names injs
+        pure (new_names', ECase e' injs')
 
 renameInjs :: Names -> [Inj] -> Rn (Names, [Inj])
 renameInjs ns xs = do
@@ -81,8 +82,16 @@ renameInjs ns xs = do
 
 renameInj :: Names -> Inj -> Rn (Names, Inj)
 renameInj ns (Inj init e) = do
-    (new_names, e') <- renameExp ns e
-    return (new_names, Inj init e')
+    (new_names, init') <- renameInit ns init
+    (new_names', e') <- renameExp new_names e
+    return (new_names', Inj init' e')
+
+renameInit :: Names -> Init -> Rn (Names, Init)
+renameInit ns i = case i of
+    InitConstr cs vars -> do
+        (ns_new, vars') <- newNames ns vars
+        return (ns_new, InitConstr cs vars')
+    rest -> return (ns, rest)
 
 -- | Create a new name and add it to name environment.
 newName :: Names -> Ident -> Rn (Names, Ident)

From 88a4a934b8f448d98947543c6e1fd00b822826d9 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 22 Mar 2023 10:32:22 +0100
Subject: [PATCH 65/71] added more manual tests

---
 Makefile                |  3 +++
 sample-programs/basic-5 |  8 ++++----
 sample-programs/basic-6 | 10 ++++++++++
 sample-programs/basic-7 | 10 ++++++++++
 sample-programs/basic-8 | 24 ++++++++++++++++++++++++
 test_program            | 31 ++++++++++++++++---------------
 6 files changed, 67 insertions(+), 19 deletions(-)
 create mode 100644 sample-programs/basic-6
 create mode 100644 sample-programs/basic-7
 create mode 100644 sample-programs/basic-8

diff --git a/Makefile b/Makefile
index 9c0be2f..d5c908c 100644
--- a/Makefile
+++ b/Makefile
@@ -28,6 +28,9 @@ test :
 	./language ./sample-programs/basic-3
 	./language ./sample-programs/basic-4
 	./language ./sample-programs/basic-5
+	./language ./sample-programs/basic-6
+	./language ./sample-programs/basic-7
+	./language ./sample-programs/basic-8
 
 run :
 	cabal -v0 new-run language -- "test_program"
diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
index 9a9a723..319b9b0 100644
--- a/sample-programs/basic-5
+++ b/sample-programs/basic-5
@@ -1,8 +1,8 @@
--- double : _Int -> _Int ;
--- double n = n + n;
+double : _Int -> _Int ;
+double n = n + n;
 
 id : 'a -> 'a ;
 id x = x ;
 
-main : ('a -> 'b -> 'c) ;
-main = id ;
+main : _Int ;
+main = id double 5;
diff --git a/sample-programs/basic-6 b/sample-programs/basic-6
new file mode 100644
index 0000000..467d263
--- /dev/null
+++ b/sample-programs/basic-6
@@ -0,0 +1,10 @@
+data Bool () where {
+    True : Bool ()
+    False : Bool ()
+};
+
+main : Bool () -> _Int ;
+main b = case b of {
+    False => 0;
+    True => 0
+}
diff --git a/sample-programs/basic-7 b/sample-programs/basic-7
new file mode 100644
index 0000000..3ddf98b
--- /dev/null
+++ b/sample-programs/basic-7
@@ -0,0 +1,10 @@
+data Bool () where {
+    True : Bool ()
+    False : Bool ()
+};
+
+ifThenElse : Bool () -> 'a -> 'a -> 'a;
+ifThenElse b if else = case b of {
+        True => if;
+        False => else
+    }
diff --git a/sample-programs/basic-8 b/sample-programs/basic-8
new file mode 100644
index 0000000..d916d03
--- /dev/null
+++ b/sample-programs/basic-8
@@ -0,0 +1,24 @@
+data Maybe ('a) where {
+    Nothing : Maybe ('a)
+    Just : 'a -> Maybe ('a)
+};
+
+fromJust : Maybe ('a) -> 'a ;
+fromJust a =
+    case a of {
+        Just a => a
+    };
+
+fromMaybe : 'a -> Maybe ('a) -> 'a ;
+fromMaybe a b =
+    case b of {
+        Just a => a;
+        Nothing => a
+    };
+
+maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b;
+maybe b f ma =
+    case ma of {
+        Just a => f a;
+        Nothing => b
+    }
diff --git a/test_program b/test_program
index bc463fe..d916d03 100644
--- a/test_program
+++ b/test_program
@@ -1,23 +1,24 @@
--- data Bool () where {
---     True : Bool ()
---     False : Bool ()
--- };
-
 data Maybe ('a) where {
     Nothing : Maybe ('a)
     Just : 'a -> Maybe ('a)
 };
 
--- main : Bool () -> Maybe (Bool ()) ;
--- main x =
---     case x of {
---         True => Nothing;
---         False => Just True
---     };
-
-fun : Maybe ('a) -> 'a ;
-fun a =
+fromJust : Maybe ('a) -> 'a ;
+fromJust a =
     case a of {
-        Just c => c
+        Just a => a
     };
 
+fromMaybe : 'a -> Maybe ('a) -> 'a ;
+fromMaybe a b =
+    case b of {
+        Just a => a;
+        Nothing => a
+    };
+
+maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b;
+maybe b f ma =
+    case ma of {
+        Just a => f a;
+        Nothing => b
+    }

From 936cb1301fd5d73e92726ec5bf86d465c0f6a125 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 22 Mar 2023 12:45:51 +0100
Subject: [PATCH 66/71] new grammar and adapted renamer

---
 Grammar.cf                       |  87 ++-
 sample-programs/basic-1          |   2 +-
 sample-programs/basic-2          |   4 +-
 sample-programs/basic-3          |   2 +-
 sample-programs/basic-4          |   2 +-
 sample-programs/basic-5          |   6 +-
 sample-programs/basic-6          |   2 +-
 sample-programs/basic-7          |   2 +-
 sample-programs/basic-8          |  12 +-
 src/Main.hs                      |  21 +-
 src/Renamer/Renamer.hs           | 164 ++++--
 src/TypeChecker/Bugs.md          |  83 ---
 src/TypeChecker/TypeChecker.hs   | 958 ++++++++++++++++---------------
 src/TypeChecker/TypeCheckerIr.hs | 306 +++++-----
 test_program                     |  28 +-
 15 files changed, 858 insertions(+), 821 deletions(-)
 delete mode 100644 src/TypeChecker/Bugs.md

diff --git a/Grammar.cf b/Grammar.cf
index 37305e2..356646d 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,50 +1,91 @@
+--------------------------------------------------------------------------------
+-- * PROGRAM
+--------------------------------------------------------------------------------
 
 Program. Program ::= [Def] ;
 
+--------------------------------------------------------------------------------
+-- * TOP-LEVEL
+--------------------------------------------------------------------------------
+
 DBind. Def ::= Bind ;
+DSig.  Def ::= Sig ;
 DData. Def ::= Data ;
-separator Def ";" ;
 
-Bind. Bind ::= Ident ":" Type ";"
-               Ident [Ident] "=" Exp ;
+Sig. Sig ::= LIdent ":" Type ;
 
-Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ;
+Bind. Bind ::= LIdent [LIdent] "=" Exp ;
 
-Constructor. Constructor ::= Ident ":" Type ;
-separator nonempty Constructor "" ;
+--------------------------------------------------------------------------------
+-- * TYPES
+--------------------------------------------------------------------------------
 
-TMono.   Type1 ::= "_" Ident ;
-TPol.    Type1 ::= "'" Ident ;
-TConstr. Type1 ::= Constr ;
-TArr.    Type  ::= Type1 "->" Type ;
+         TLit.     Type2 ::= UIdent ;
+         TVar.     Type2 ::= TVar ;
+         TAll.     Type1 ::= "forall" TVar "." Type ;
+         TIndexed. Type1 ::= Indexed ;
+internal TEVar.    Type1 ::= TEVar ;
+         TFun.     Type  ::= Type1 "->" Type ;
 
-Constr.  Constr ::= Ident "(" [Type] ")" ;
+         MkTVar.  TVar  ::= LIdent ;
+internal MkTEVar. TEVar ::= LIdent ;
+
+--------------------------------------------------------------------------------
+-- * DATA TYPES
+--------------------------------------------------------------------------------
+
+Constructor. Constructor ::= UIdent ":" Type ;
+
+Indexed. Indexed ::= UIdent "(" [Type] ")" ;
+
+Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ;
+
+--------------------------------------------------------------------------------
+-- * EXPRESSIONS
+--------------------------------------------------------------------------------
 
--- TODO: Move literal to its own thing since it's reused in Init as well.
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
-EId.    Exp4 ::= Ident ;
-ELit.   Exp4 ::= Literal ;
+EId.    Exp4 ::= LIdent ;
+ELit.   Exp4 ::= Lit ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
-ELet.   Exp  ::= "let" Ident "=" Exp "in" Exp ; 
-EAbs.   Exp  ::= "\\" Ident "." Exp ;
+ELet.   Exp  ::= "let" LIdent "=" Exp "in" Exp ; 
+EAbs.   Exp  ::= "\\" LIdent "." Exp ;
 ECase.  Exp  ::= "case" Exp "of" "{" [Inj] "}";
 
-LInt. Literal ::= Integer ;
+--------------------------------------------------------------------------------
+-- * LITERALS
+--------------------------------------------------------------------------------
+
+LInt. Lit ::= Integer ;
+LChar. Lit ::= Char ;
+
+--------------------------------------------------------------------------------
+-- * CASE
+--------------------------------------------------------------------------------
 
 Inj. Inj ::= Init "=>" Exp ;
-separator nonempty Inj ";" ;
 
-InitLit. Init    ::= Literal ;
-InitConstr. Init ::= Ident [Ident] ;
-InitCatch. Init  ::= "_" ;
+InitLit. Init         ::= Lit ;
+InitConstructor. Init ::= UIdent [LIdent] ;
+InitCatch. Init       ::= "_" ;
 
+--------------------------------------------------------------------------------
+-- * AUX
+--------------------------------------------------------------------------------
+
+separator Def ";" ;
+separator nonempty Constructor "" ;
 separator Type " " ;
-coercions Type 2 ;
-
+separator nonempty Inj ";" ;
 separator Ident " ";
+separator LIdent " ";
 
 coercions Exp 5 ;
+coercions Type 2 ;
+
+token UIdent (upper (letter | digit | '_')*) ;
+token LIdent (lower (letter | digit | '_')*) ;
 
 comment "--" ;
 comment "{-" "-}" ;
diff --git a/sample-programs/basic-1 b/sample-programs/basic-1
index 5cb2b2a..d52aac2 100644
--- a/sample-programs/basic-1
+++ b/sample-programs/basic-1
@@ -1,2 +1,2 @@
-f : _Int -> _Int ;
+f : Int -> Int ;
 f = \x. x+1 ;
diff --git a/sample-programs/basic-2 b/sample-programs/basic-2
index 2f0448c..2db6128 100644
--- a/sample-programs/basic-2
+++ b/sample-programs/basic-2
@@ -1,5 +1,5 @@
-add : _Int -> _Int -> _Int ;
+add : Int -> Int -> Int ;
 add x = \y. x+y;
 
-main : _Int ;
+main : Int ;
 main = (\z. z+z) ((add 4) 6) ;
diff --git a/sample-programs/basic-3 b/sample-programs/basic-3
index 7ba4971..98c03b9 100644
--- a/sample-programs/basic-3
+++ b/sample-programs/basic-3
@@ -1,2 +1,2 @@
-main : _Int ;
+main : Int ;
 main = (\x. x+x+3) ((\x. x) 2) ;
diff --git a/sample-programs/basic-4 b/sample-programs/basic-4
index 365e4cb..55ac9eb 100644
--- a/sample-programs/basic-4
+++ b/sample-programs/basic-4
@@ -1,2 +1,2 @@
-f : _Int -> _Int ;
+f : Int -> Int ;
 f x = let g = (\y. y+1) in g (g x)
diff --git a/sample-programs/basic-5 b/sample-programs/basic-5
index 319b9b0..a6414f2 100644
--- a/sample-programs/basic-5
+++ b/sample-programs/basic-5
@@ -1,8 +1,8 @@
-double : _Int -> _Int ;
+double : Int -> Int ;
 double n = n + n;
 
-id : 'a -> 'a ;
+id : forall a. a -> a ;
 id x = x ;
 
-main : _Int ;
+main : Int ;
 main = id double 5;
diff --git a/sample-programs/basic-6 b/sample-programs/basic-6
index 467d263..3ed64a0 100644
--- a/sample-programs/basic-6
+++ b/sample-programs/basic-6
@@ -3,7 +3,7 @@ data Bool () where {
     False : Bool ()
 };
 
-main : Bool () -> _Int ;
+main : Bool () -> Int ;
 main b = case b of {
     False => 0;
     True => 0
diff --git a/sample-programs/basic-7 b/sample-programs/basic-7
index 3ddf98b..9ae2bdf 100644
--- a/sample-programs/basic-7
+++ b/sample-programs/basic-7
@@ -3,7 +3,7 @@ data Bool () where {
     False : Bool ()
 };
 
-ifThenElse : Bool () -> 'a -> 'a -> 'a;
+ifThenElse : forall a. Bool () -> a -> a -> a;
 ifThenElse b if else = case b of {
         True => if;
         False => else
diff --git a/sample-programs/basic-8 b/sample-programs/basic-8
index d916d03..c2c4042 100644
--- a/sample-programs/basic-8
+++ b/sample-programs/basic-8
@@ -1,22 +1,22 @@
-data Maybe ('a) where {
-    Nothing : Maybe ('a)
-    Just : 'a -> Maybe ('a)
+data Maybe (a) where {
+    Nothing : Maybe (a)
+    Just : forall a. a -> Maybe (a)
 };
 
-fromJust : Maybe ('a) -> 'a ;
+fromJust : Maybe (a) -> a ;
 fromJust a =
     case a of {
         Just a => a
     };
 
-fromMaybe : 'a -> Maybe ('a) -> 'a ;
+fromMaybe : a -> Maybe (a) -> a ;
 fromMaybe a b =
     case b of {
         Just a => a;
         Nothing => a
     };
 
-maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b;
+maybe : b -> (a -> b) -> Maybe (a) -> b;
 maybe b f ma =
     case ma of {
         Just a => f a;
diff --git a/src/Main.hs b/src/Main.hs
index 7e3922d..0a00cd6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -11,7 +11,8 @@ import Grammar.Print (printTree)
 import Renamer.Renamer (rename)
 import System.Environment (getArgs)
 import System.Exit (exitFailure, exitSuccess)
-import TypeChecker.TypeChecker (typecheck)
+
+-- import TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
 main =
@@ -28,12 +29,12 @@ main' s = do
     putStrLn $ printTree parsed
 
     putStrLn "\n-- Renamer --"
-    let renamed = rename parsed
+    renamed <- fromRenamerErr . rename $ parsed
     putStrLn $ printTree renamed
 
-    putStrLn "\n-- TypeChecker --"
-    typechecked <- fromTypeCheckerErr $ typecheck renamed
-    putStrLn $ show typechecked
+    -- putStrLn "\n-- TypeChecker --"
+    -- typechecked <- fromTypeCheckerErr $ typecheck renamed
+    -- putStrLn $ show typechecked
 
     -- putStrLn "\n-- Lambda Lifter --"
     -- let lifted = lambdaLift typechecked
@@ -55,6 +56,16 @@ fromCompilerErr =
         )
         pure
 
+fromRenamerErr :: Err a -> IO a
+fromRenamerErr =
+    either
+        ( \err -> do
+            putStrLn "\nRENAME ERROR"
+            putStrLn err
+            exitFailure
+        )
+        pure
+
 fromSyntaxErr :: Err a -> IO a
 fromSyntaxErr =
     either
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index d056868..aac8b16 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -1,56 +1,101 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
-module Renamer.Renamer where
+module Renamer.Renamer (rename) where
 
 import Auxiliary (mapAccumM)
+import Control.Applicative (Applicative (liftA2))
+import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad.Identity (Identity, runIdentity)
 import Control.Monad.State (
     MonadState,
-    State,
-    evalState,
+    StateT,
+    evalStateT,
     gets,
     modify,
  )
-import Data.List (foldl')
+import Data.Function (on)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Tuple.Extra (dupe)
-import Debug.Trace (trace)
 import Grammar.Abs
 
 -- | Rename all variables and local binds
-rename :: Program -> Program
-rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0
+rename :: Program -> Either String Program
+rename (Program defs) = Program <$> renameDefs defs
+
+renameDefs :: [Def] -> Either String [Def]
+renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt
   where
-    -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
-    initNames = Map.fromList $ foldl' saveIfBind [] bs
-    saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc
-    saveIfBind acc _ = acc
-    renameSc :: Names -> Def -> Rn Def
-    renameSc old_names (DBind (Bind name t _ parms rhs)) = do
-        (new_names, parms') <- newNames old_names parms
-        rhs' <- snd <$> renameExp new_names rhs
-        pure . DBind $ Bind name t name parms' rhs'
-    renameSc _ def = pure def
+    initNames = Map.fromList [dupe name | DBind (Bind name _ _) <- defs]
+
+    renameDef :: Def -> Rn Def
+    renameDef = \case
+        DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ
+        DBind (Bind name vars rhs) -> do
+            (new_names, vars') <- newNames initNames vars
+            rhs' <- snd <$> renameExp new_names rhs
+            pure . DBind $ Bind name vars' rhs'
+        DData (Data (Indexed cname types) constrs) -> do
+            tvars' <- mapM nextNameTVar tvars
+            let tvars_lt = zip tvars tvars'
+                typ' = map (substituteTVar tvars_lt) types
+                constrs' = map (renameConstr tvars_lt) constrs
+            pure . DData $ Data (Indexed cname typ') constrs'
+          where
+            tvars = concatMap (collectTVars []) types
+            collectTVars tvars = \case
+                TAll tvar t -> collectTVars (tvar : tvars) t
+                TIndexed _ -> tvars
+                -- Should be monad error
+                TVar v -> [v]
+                _ -> error ("Bad data type definition: " ++ show types)
+
+    renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor
+    renameConstr new_types (Constructor name typ) =
+        Constructor name $ substituteTVar new_types typ
+
+substituteTVar :: [(TVar, TVar)] -> Type -> Type
+substituteTVar new_names typ = case typ of
+    TLit _ -> typ
+    TVar tvar
+        | Just tvar' <- lookup tvar new_names ->
+            TVar tvar'
+        | otherwise ->
+            typ
+    TFun t1 t2 -> on TFun substitute' t1 t2
+    TAll tvar t
+        | Just tvar' <- lookup tvar new_names ->
+            TAll tvar' $ substitute' t
+        | otherwise ->
+            TAll tvar $ substitute' t
+    TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs
+    _ -> error ("Impossible " ++ show typ)
+  where
+    substitute' = substituteTVar new_names
+
+initCxt :: Cxt
+initCxt = Cxt 0 0
+
+data Cxt = Cxt
+    { var_counter :: Int
+    , tvar_counter :: Int
+    }
 
 -- | Rename monad. State holds the number of renamed names.
-newtype Rn a = Rn {runRn :: State Int a}
-    deriving (Functor, Applicative, Monad, MonadState Int)
+newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
+    deriving (Functor, Applicative, Monad, MonadState Cxt)
 
 -- | Maps old to new name
-type Names = Map Ident Ident
-
-renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
-renameLocalBind old_names (Bind name t _ parms rhs) = do
-    (new_names, name') <- newName old_names name
-    (new_names', parms') <- newNames new_names parms
-    (new_names'', rhs') <- renameExp new_names' rhs
-    pure (new_names'', Bind name' t name' parms' rhs')
+type Names = Map LIdent LIdent
 
 renameExp :: Names -> Exp -> Rn (Names, Exp)
 renameExp old_names = \case
     EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
-    ELit (LInt i1) -> pure (old_names, ELit (LInt i1))
+    ELit lit -> pure (old_names, ELit lit)
     EApp e1 e2 -> do
         (env1, e1') <- renameExp old_names e1
         (env2, e2') <- renameExp old_names e2
@@ -59,17 +104,21 @@ renameExp old_names = \case
         (env1, e1') <- renameExp old_names e1
         (env2, e2') <- renameExp old_names e2
         pure (Map.union env1 env2, EAdd e1' e2')
-    ELet i e1 e2 -> do
-        (new_names, e1') <- renameExp old_names e1
-        (new_names', e2') <- renameExp new_names e2
-        pure (new_names', ELet i e1' e2')
+
+    -- TODO fix shadowing
+    ELet name rhs e -> do
+        (new_names, name') <- newName old_names name
+        (new_names', rhs') <- renameExp new_names rhs
+        (new_names'', e') <- renameExp new_names' e
+        pure (new_names'', ELet name' rhs' e')
     EAbs par e -> do
         (new_names, par') <- newName old_names par
         (new_names', e') <- renameExp new_names e
         pure (new_names', EAbs par' e')
     EAnn e t -> do
         (new_names, e') <- renameExp old_names e
-        pure (new_names, EAnn e' t)
+        t' <- renameTVars t
+        pure (new_names, EAnn e' t')
     ECase e injs -> do
         (new_names, e') <- renameExp old_names e
         (new_names', injs') <- renameInjs new_names injs
@@ -88,21 +137,58 @@ renameInj ns (Inj init e) = do
 
 renameInit :: Names -> Init -> Rn (Names, Init)
 renameInit ns i = case i of
-    InitConstr cs vars -> do
+    InitConstructor cs vars -> do
         (ns_new, vars') <- newNames ns vars
-        return (ns_new, InitConstr cs vars')
+        return (ns_new, InitConstructor cs vars')
     rest -> return (ns, rest)
 
+renameTVars :: Type -> Rn Type
+renameTVars typ = case typ of
+    TAll tvar t -> do
+        tvar' <- nextNameTVar tvar
+        t' <- renameTVars $ substitute tvar tvar' t
+        pure $ TAll tvar' t'
+    TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2)
+    _ -> pure typ
+
+substitute ::
+    TVar -> -- α
+    TVar -> -- α_n
+    Type -> -- A
+    Type -- [α_n/α]A
+substitute tvar1 tvar2 typ = case typ of
+    TLit _ -> typ
+    TVar tvar'
+        | tvar' == tvar1 -> TVar tvar2
+        | otherwise -> typ
+    TFun t1 t2 -> on TFun substitute' t1 t2
+    TAll tvar t -> TAll tvar $ substitute' t
+    TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs
+    _ -> error "Impossible"
+  where
+    substitute' = substitute tvar1 tvar2
+
 -- | Create a new name and add it to name environment.
-newName :: Names -> Ident -> Rn (Names, Ident)
+newName :: Names -> LIdent -> Rn (Names, LIdent)
 newName env old_name = do
     new_name <- makeName old_name
     pure (Map.insert old_name new_name env, new_name)
 
 -- | Create multiple names and add them to the name environment
-newNames :: Names -> [Ident] -> Rn (Names, [Ident])
+newNames :: Names -> [LIdent] -> Rn (Names, [LIdent])
 newNames = mapAccumM newName
 
 -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
-makeName :: Ident -> Rn Ident
-makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ
+makeName :: LIdent -> Rn LIdent
+makeName (LIdent prefix) = do
+    i <- gets var_counter
+    let name = LIdent $ prefix ++ "_" ++ show i
+    modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
+    pure name
+
+nextNameTVar :: TVar -> Rn TVar
+nextNameTVar (MkTVar (LIdent s)) = do
+    i <- gets tvar_counter
+    let tvar = MkTVar . LIdent $ s ++ "_" ++ show i
+    modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter}
+    pure tvar
diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md
deleted file mode 100644
index a265cde..0000000
--- a/src/TypeChecker/Bugs.md
+++ /dev/null
@@ -1,83 +0,0 @@
-## Bugs
-
-None known at this moment
-
-main\_bug should not typecheck
-
-```hs
-apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
-apply f x = \y. f x y ;
-
-id : 'a -> 'a ;
-id x = x ;
-
-add : _Int -> _Int -> _Int ;
-add x y = x + y ;
-
-main_bug : _Int -> _Int -> _Int ;
-main_bug= (apply id) add ;
-
-idadd : _Int -> _Int -> _Int ;
-idadd = id add ;
-```
-
-main\_bug should typecheck
-
-```hs
-apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
-apply f x = \y. f x y ;
-
-id : 'a -> 'a ;
-id x = x ;
-
-add : _Int -> _Int -> _Int ;
-add x y = x + y ;
-
-main_bug : _Int -> _Int -> _Int ;
-main_bug = apply (id add) ;
-
-idadd : _Int -> _Int -> _Int ;
-idadd = id add ;
-```
-
-## Fixed bugs
-
-* 1
-
-```hs
-fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
-fmap f x =
-    case x of {
-        Just x => Just (f x) ;
-        Nothing => Nothing
-    }
-```
-
-* 2
-
-```hs
-data Maybe ('a) where {
-    Nothing : Maybe ('a)
-    Just : 'a -> Maybe ('a)
-};
-
-id : 'a -> 'a ;
-id x = x ;
-
-main : Maybe ('a -> 'a) ; 
-main = Just id;
-```
-
-But this does
-```hs
-data Maybe ('a) where {
-    Nothing : Maybe ('a)
-    Just : 'a -> Maybe ('a)
-};
-
-id : 'b -> 'b ;
-id x = x ;
-
-main : Maybe ('a -> 'a) ; 
-main = Just id;
-```
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 1339212..4e072d2 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -4,541 +4,543 @@
 -- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
 
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.Bifunctor (second)
-import Data.Foldable (traverse_)
-import Data.Functor.Identity (runIdentity)
-import Data.List (foldl')
-import Data.List.Extra (unsnoc)
-import Data.Map (Map)
-import Data.Map qualified as M
-import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import Data.Set qualified as S
-import Debug.Trace (trace)
-import Grammar.Abs
-import Grammar.Print (printTree)
-import TypeChecker.TypeCheckerIr (
-    Ctx (..),
-    Env (..),
-    Error,
-    Infer,
-    Poly (..),
-    Subst,
- )
-import TypeChecker.TypeCheckerIr qualified as T
+-- import Control.Monad.Except
+-- import Control.Monad.Reader
+-- import Control.Monad.State
+-- import Data.Bifunctor (second)
+-- import Data.Foldable (traverse_)
+-- import Data.Functor.Identity (runIdentity)
+-- import Data.List (foldl')
+-- import Data.List.Extra (unsnoc)
+-- import Data.Map (Map)
+-- import Data.Map qualified as M
+-- import Data.Maybe (fromMaybe)
+-- import Data.Set (Set)
+-- import Data.Set qualified as S
+-- import Debug.Trace (trace)
+-- import Grammar.Abs
+-- import Grammar.Print (printTree)
+-- import TypeChecker.TypeCheckerIr (
+--     Ctx (..),
+--     Env (..),
+--     Error,
+--     Infer,
+--     Poly (..),
+--     Subst,
+--  )
+-- import TypeChecker.TypeCheckerIr qualified as T
 
-initCtx = Ctx mempty
+-- initCtx = Ctx mempty
 
-initEnv = Env 0 mempty mempty
+-- initEnv = Env 0 mempty mempty
 
-runPretty :: Exp -> Either Error String
-runPretty = fmap (printTree . fst) . run . inferExp
+-- runPretty :: Exp -> Either Error String
+-- runPretty = fmap (printTree . fst) . run . inferExp
 
-run :: Infer a -> Either Error a
-run = runC initEnv initCtx
+-- run :: Infer a -> Either Error a
+-- run = runC initEnv initCtx
 
-runC :: Env -> Ctx -> Infer a -> Either Error a
-runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
+-- runC :: Env -> Ctx -> Infer a -> Either Error a
+-- runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 
-typecheck :: Program -> Either Error T.Program
-typecheck = run . checkPrg
+-- typecheck :: Program -> Either Error T.Program
+-- typecheck = run . checkPrg
 
-{- | Start by freshening the type variable of data types to avoid clash with
-other user defined polymorphic types
--}
-freshenData :: Data -> Infer Data
-freshenData (Data (Constr name ts) constrs) = do
-    let xs = (S.toList . free) =<< ts
-    frs <- traverse (const fresh) xs
-    let m = M.fromList $ zip xs frs
-    return $
-        Data
-            (Constr name (map (freshenType m) ts))
-            ( map
-                ( \(Constructor ident t) ->
-                    Constructor ident (freshenType m t)
-                )
-                constrs
-            )
+-- {- | Start by freshening the type variable of data types to avoid clash with
+-- other user defined polymorphic types
+-- -}
+-- freshenData :: Data -> Infer Data
+-- freshenData (Data (Constr name ts) constrs) = do
+--     let xs = (S.toList . free) =<< ts
+--     frs <- traverse (const fresh) xs
+--     let m = M.fromList $ zip xs frs
+--     return $
+--         Data
+--             (Constr name (map (freshenType m) ts))
+--             ( map
+--                 ( \(Constructor ident t) ->
+--                     Constructor ident (freshenType m t)
+--                 )
+--                 constrs
+--             )
 
-{- | Freshen all polymorphic variables, regardless of name
-| freshenType "d" (a -> b -> c) becomes (d -> d -> d)
--}
+-- {- | Freshen all polymorphic variables, regardless of name
+
+{- | freshenType "d" (a -> b -> c) becomes (d -> d -> d)
+-\}
 freshenType :: Map Ident Type -> Type -> Type
 freshenType m t = case t of
     TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m)
     TMono mono -> TMono mono
     TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2)
     TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts))
-
-checkData :: Data -> Infer ()
-checkData d = do
-    d' <- freshenData d
-    case d' of
-        (Data typ@(Constr name ts) constrs) -> do
-            unless
-                (all isPoly ts)
-                (throwError $ unwords ["Data type incorrectly declared"])
-            traverse_
-                ( \(Constructor name' t') ->
-                    if TConstr typ == retType t'
-                        then insertConstr name' t'
-                        else
-                            throwError $
-                                unwords
-                                    [ "return type of constructor:"
-                                    , printTree name
-                                    , "with type:"
-                                    , printTree (retType t')
-                                    , "does not match data: "
-                                    , printTree typ
-                                    ]
-                )
-                constrs
-
-retType :: Type -> Type
-retType (TArr _ t2) = retType t2
-retType a = a
-
-checkPrg :: Program -> Infer T.Program
-checkPrg (Program bs) = do
-    preRun bs
-    bs' <- checkDef bs
-    return $ T.Program bs'
-  where
-    preRun :: [Def] -> Infer ()
-    preRun [] = return ()
-    preRun (x : xs) = case x of
-        DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs
-        DData d@(Data _ _) -> checkData d >> preRun xs
-
-    checkDef :: [Def] -> Infer [T.Def]
-    checkDef [] = return []
-    checkDef (x : xs) = case x of
-        (DBind b) -> do
-            b' <- checkBind b
-            fmap (T.DBind b' :) (checkDef xs)
-        (DData d) -> do
-            d' <- freshenData d
-            fmap (T.DData d' :) (checkDef xs)
-
-checkBind :: Bind -> Infer T.Bind
-checkBind (Bind n t _ args e) = do
-    let lambda = makeLambda e (reverse args)
-    (t', e) <- inferExp lambda
-    s <- unify t' t
-    let t'' = apply s t
-    unless
-        (t `typeEq` t'')
-        ( throwError $
-            unwords
-                [ "Top level signature"
-                , printTree t
-                , "does not match body with inferred type:"
-                , printTree t''
-                ]
-        )
-    return $ T.Bind (n, t) (apply s e)
-  where
-    makeLambda :: Exp -> [Ident] -> Exp
-    makeLambda = foldl (flip EAbs)
-
-{- | Check if two types are considered equal
-  For the purpose of the algorithm two polymorphic types are always considered
-  equal
 -}
-typeEq :: Type -> Type -> Bool
-typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
-typeEq (TMono a) (TMono b) = a == b
-typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) =
-    length a == length b
-        && name == name'
-        && and (zipWith typeEq a b)
-typeEq (TPol _) (TPol _) = True
-typeEq _ _ = False
 
-isMoreSpecificOrEq :: Type -> Type -> Bool
-isMoreSpecificOrEq _ (TPol _) = True
-isMoreSpecificOrEq (TArr a b) (TArr c d) =
-    isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
-isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
-    n1 == n2
-        && length ts1 == length ts2
-        && and (zipWith isMoreSpecificOrEq ts1 ts2)
-isMoreSpecificOrEq a b = a == b
+-- checkData :: Data -> Infer ()
+-- checkData d = do
+--     d' <- freshenData d
+--     case d' of
+--         (Data typ@(Constr name ts) constrs) -> do
+--             unless
+--                 (all isPoly ts)
+--                 (throwError $ unwords ["Data type incorrectly declared"])
+--             traverse_
+--                 ( \(Constructor name' t') ->
+--                     if TConstr typ == retType t'
+--                         then insertConstr name' t'
+--                         else
+--                             throwError $
+--                                 unwords
+--                                     [ "return type of constructor:"
+--                                     , printTree name
+--                                     , "with type:"
+--                                     , printTree (retType t')
+--                                     , "does not match data: "
+--                                     , printTree typ
+--                                     ]
+--                 )
+--                 constrs
 
-isPoly :: Type -> Bool
-isPoly (TPol _) = True
-isPoly _ = False
+-- retType :: Type -> Type
+-- retType (TArr _ t2) = retType t2
+-- retType a = a
 
-inferExp :: Exp -> Infer (Type, T.Exp)
-inferExp e = do
-    (s, t, e') <- algoW e
-    let subbed = apply s t
-    return (subbed, replace subbed e')
+-- checkPrg :: Program -> Infer T.Program
+-- checkPrg (Program bs) = do
+--     preRun bs
+--     bs' <- checkDef bs
+--     return $ T.Program bs'
+--   where
+--     preRun :: [Def] -> Infer ()
+--     preRun [] = return ()
+--     preRun (x : xs) = case x of
+--         DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs
+--         DData d@(Data _ _) -> checkData d >> preRun xs
 
-replace :: Type -> T.Exp -> T.Exp
-replace t = \case
-    T.ELit _ e -> T.ELit t e
-    T.EId (n, _) -> T.EId (n, t)
-    T.EAbs _ name e -> T.EAbs t name e
-    T.EApp _ e1 e2 -> T.EApp t e1 e2
-    T.EAdd _ e1 e2 -> T.EAdd t e1 e2
-    T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
-    T.ECase _ expr injs -> T.ECase t expr injs
+--     checkDef :: [Def] -> Infer [T.Def]
+--     checkDef [] = return []
+--     checkDef (x : xs) = case x of
+--         (DBind b) -> do
+--             b' <- checkBind b
+--             fmap (T.DBind b' :) (checkDef xs)
+--         (DData d) -> do
+--             d' <- freshenData d
+--             fmap (T.DData d' :) (checkDef xs)
 
-algoW :: Exp -> Infer (Subst, Type, T.Exp)
-algoW = \case
-    -- \| TODO: More testing need to be done. Unsure of the correctness of this
-    EAnn e t -> do
-        (s1, t', e') <- algoW e
-        unless
-            (t `isMoreSpecificOrEq` t')
-            ( throwError $
-                unwords
-                    [ "Annotated type:"
-                    , printTree t
-                    , "does not match inferred type:"
-                    , printTree t'
-                    ]
-            )
-        applySt s1 $ do
-            s2 <- unify t t'
-            let comp = s2 `compose` s1
-            return (comp, t, apply comp e')
+-- checkBind :: Bind -> Infer T.Bind
+-- checkBind (Bind n t _ args e) = do
+--     let lambda = makeLambda e (reverse args)
+--     (t', e) <- inferExp lambda
+--     s <- unify t' t
+--     let t'' = apply s t
+--     unless
+--         (t `typeEq` t'')
+--         ( throwError $
+--             unwords
+--                 [ "Top level signature"
+--                 , printTree t
+--                 , "does not match body with inferred type:"
+--                 , printTree t''
+--                 ]
+--         )
+--     return $ T.Bind (n, t) (apply s e)
+--   where
+--     makeLambda :: Exp -> [Ident] -> Exp
+--     makeLambda = foldl (flip EAbs)
 
-    -- \| ------------------
-    -- \|   Γ ⊢ i : Int, ∅
+-- {- | Check if two types are considered equal
+--   For the purpose of the algorithm two polymorphic types are always considered
+--   equal
+-- -}
+-- typeEq :: Type -> Type -> Bool
+-- typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
+-- typeEq (TMono a) (TMono b) = a == b
+-- typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) =
+--     length a == length b
+--         && name == name'
+--         && and (zipWith typeEq a b)
+-- typeEq (TPol _) (TPol _) = True
+-- typeEq _ _ = False
 
-    ELit lit ->
-        let lt = litType lit
-         in return (nullSubst, lt, T.ELit lt lit)
-    -- \| x : σ ∈ Γ   τ = inst(σ)
-    -- \| ----------------------
-    -- \|     Γ ⊢ x : τ, ∅
+-- isMoreSpecificOrEq :: Type -> Type -> Bool
+-- isMoreSpecificOrEq _ (TPol _) = True
+-- isMoreSpecificOrEq (TArr a b) (TArr c d) =
+--     isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
+-- isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
+--     n1 == n2
+--         && length ts1 == length ts2
+--         && and (zipWith isMoreSpecificOrEq ts1 ts2)
+-- isMoreSpecificOrEq a b = a == b
 
-    EId i -> do
-        var <- asks vars
-        case M.lookup i var of
-            Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
-            Nothing -> do
-                sig <- gets sigs
-                case M.lookup i sig of
-                    Just t -> return (nullSubst, t, T.EId (i, t))
-                    Nothing -> do
-                        constr <- gets constructors
-                        case M.lookup i constr of
-                            Just t -> return (nullSubst, t, T.EId (i, t))
-                            Nothing ->
-                                throwError $
-                                    "Unbound variable: " ++ show i
+-- isPoly :: Type -> Bool
+-- isPoly (TPol _) = True
+-- isPoly _ = False
 
-    -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
-    -- \| ---------------------------------
-    -- \|     Γ ⊢ w λx. e : Sτ → τ', S
+-- inferExp :: Exp -> Infer (Type, T.Exp)
+-- inferExp e = do
+--     (s, t, e') <- algoW e
+--     let subbed = apply s t
+--     return (subbed, replace subbed e')
 
-    EAbs name e -> do
-        fr <- fresh
-        withBinding name (Forall [] fr) $ do
-            (s1, t', e') <- algoW e
-            let varType = apply s1 fr
-            let newArr = TArr varType t'
-            return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e')
+-- replace :: Type -> T.Exp -> T.Exp
+-- replace t = \case
+--     T.ELit _ e -> T.ELit t e
+--     T.EId (n, _) -> T.EId (n, t)
+--     T.EAbs _ name e -> T.EAbs t name e
+--     T.EApp _ e1 e2 -> T.EApp t e1 e2
+--     T.EAdd _ e1 e2 -> T.EAdd t e1 e2
+--     T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
+--     T.ECase _ expr injs -> T.ECase t expr injs
 
-    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
-    -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
-    -- \| ------------------------------------------
-    -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
-    -- This might be wrong
+-- algoW :: Exp -> Infer (Subst, Type, T.Exp)
+-- algoW = \case
+--     -- \| TODO: More testing need to be done. Unsure of the correctness of this
+--     EAnn e t -> do
+--         (s1, t', e') <- algoW e
+--         unless
+--             (t `isMoreSpecificOrEq` t')
+--             ( throwError $
+--                 unwords
+--                     [ "Annotated type:"
+--                     , printTree t
+--                     , "does not match inferred type:"
+--                     , printTree t'
+--                     ]
+--             )
+--         applySt s1 $ do
+--             s2 <- unify t t'
+--             let comp = s2 `compose` s1
+--             return (comp, t, apply comp e')
 
-    EAdd e0 e1 -> do
-        (s1, t0, e0') <- algoW e0
-        applySt s1 $ do
-            (s2, t1, e1') <- algoW e1
-            -- applySt s2 $ do
-            s3 <- unify (apply s2 t0) (TMono "Int")
-            s4 <- unify (apply s3 t1) (TMono "Int")
-            let comp = s4 `compose` s3 `compose` s2 `compose` s1
-            return
-                ( comp
-                , TMono "Int"
-                , apply comp $ T.EAdd (TMono "Int") e0' e1'
-                )
+--     -- \| ------------------
+--     -- \|   Γ ⊢ i : Int, ∅
 
-    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
-    -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
-    -- \| --------------------------------------
-    -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
+--     ELit lit ->
+--         let lt = litType lit
+--          in return (nullSubst, lt, T.ELit lt lit)
+--     -- \| x : σ ∈ Γ   τ = inst(σ)
+--     -- \| ----------------------
+--     -- \|     Γ ⊢ x : τ, ∅
 
-    EApp e0 e1 -> do
-        fr <- fresh
-        (s0, t0, e0') <- algoW e0
-        applySt s0 $ do
-            (s1, t1, e1') <- algoW e1
-            -- applySt s1 $ do
-            s2 <- unify (apply s1 t0) (TArr t1 fr)
-            let t = apply s2 fr
-            let comp = s2 `compose` s1 `compose` s0
-            return (comp, t, apply comp $ T.EApp t e0' e1')
+--     EId i -> do
+--         var <- asks vars
+--         case M.lookup i var of
+--             Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
+--             Nothing -> do
+--                 sig <- gets sigs
+--                 case M.lookup i sig of
+--                     Just t -> return (nullSubst, t, T.EId (i, t))
+--                     Nothing -> do
+--                         constr <- gets constructors
+--                         case M.lookup i constr of
+--                             Just t -> return (nullSubst, t, T.EId (i, t))
+--                             Nothing ->
+--                                 throwError $
+--                                     "Unbound variable: " ++ show i
 
-    -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
-    -- \| ----------------------------------------------
-    -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
+--     -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
+--     -- \| ---------------------------------
+--     -- \|     Γ ⊢ w λx. e : Sτ → τ', S
 
-    -- The bar over S₀ and Γ means "generalize"
+--     EAbs name e -> do
+--         fr <- fresh
+--         withBinding name (Forall [] fr) $ do
+--             (s1, t', e') <- algoW e
+--             let varType = apply s1 fr
+--             let newArr = TArr varType t'
+--             return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e')
 
-    ELet name e0 e1 -> do
-        (s1, t1, e0') <- algoW e0
-        env <- asks vars
-        let t' = generalize (apply s1 env) t1
-        withBinding name t' $ do
-            (s2, t2, e1') <- algoW e1
-            let comp = s2 `compose` s1
-            return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1')
-    ECase caseExpr injs -> do
-        (sub, t, e') <- algoW caseExpr
-        (subst, injs, ret_t) <- checkCase t injs
-        let comp = subst `compose` sub
-        let t' = apply comp ret_t
-        return (comp, t', T.ECase t' e' injs)
+--     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
+--     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
+--     -- \| ------------------------------------------
+--     -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
+--     -- This might be wrong
 
--- | Unify two types producing a new substitution
-unify :: Type -> Type -> Infer Subst
-unify t0 t1 = do
-    case (t0, t1) of
-        (TArr a b, TArr c d) -> do
-            s1 <- unify a c
-            s2 <- unify (apply s1 b) (apply s1 d)
-            return $ s1 `compose` s2
-        (TPol a, b) -> occurs a b
-        (a, TPol b) -> occurs b a
-        (TMono a, TMono b) ->
-            if a == b then return M.empty else throwError "Types do not unify"
-        (TConstr (Constr name t), TConstr (Constr name' t')) ->
-            if name == name' && length t == length t'
-                then do
-                    xs <- zipWithM unify t t'
-                    return $ foldr compose nullSubst xs
-                else
-                    throwError $
-                        unwords
-                            [ "Type constructor:"
-                            , printTree name
-                            , "(" ++ printTree t ++ ")"
-                            , "does not match with:"
-                            , printTree name'
-                            , "(" ++ printTree t' ++ ")"
-                            ]
-        (a, b) -> do
-            ctx <- ask
-            env <- get
-            throwError . unwords $
-                [ "Type:"
-                , printTree a
-                , "can't be unified with:"
-                , printTree b
-                , "\nCtx:"
-                , show ctx
-                , "\nEnv:"
-                , show env
-                ]
+--     EAdd e0 e1 -> do
+--         (s1, t0, e0') <- algoW e0
+--         applySt s1 $ do
+--             (s2, t1, e1') <- algoW e1
+--             -- applySt s2 $ do
+--             s3 <- unify (apply s2 t0) (TMono "Int")
+--             s4 <- unify (apply s3 t1) (TMono "Int")
+--             let comp = s4 `compose` s3 `compose` s2 `compose` s1
+--             return
+--                 ( comp
+--                 , TMono "Int"
+--                 , apply comp $ T.EAdd (TMono "Int") e0' e1'
+--                 )
 
-{- | Check if a type is contained in another type.
-I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
-where these are equal
--}
-occurs :: Ident -> Type -> Infer Subst
-occurs i t@(TPol _) = return (M.singleton i t)
-occurs i t =
-    if S.member i (free t)
-        then
-            throwError $
-                unwords
-                    [ "Occurs check failed, can't unify"
-                    , printTree (TPol i)
-                    , "with"
-                    , printTree t
-                    ]
-        else return $ M.singleton i t
+--     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
+--     -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
+--     -- \| --------------------------------------
+--     -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
 
--- | Generalize a type over all free variables in the substitution set
-generalize :: Map Ident Poly -> Type -> Poly
-generalize env t = Forall (S.toList $ free t S.\\ free env) t
+--     EApp e0 e1 -> do
+--         fr <- fresh
+--         (s0, t0, e0') <- algoW e0
+--         applySt s0 $ do
+--             (s1, t1, e1') <- algoW e1
+--             -- applySt s1 $ do
+--             s2 <- unify (apply s1 t0) (TArr t1 fr)
+--             let t = apply s2 fr
+--             let comp = s2 `compose` s1 `compose` s0
+--             return (comp, t, apply comp $ T.EApp t e0' e1')
 
-{- | Instantiate a polymorphic type. The free type variables are substituted
-with fresh ones.
--}
-inst :: Poly -> Infer Type
-inst (Forall xs t) = do
-    xs' <- mapM (const fresh) xs
-    let s = M.fromList $ zip xs xs'
-    return $ apply s t
+--     -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
+--     -- \| ----------------------------------------------
+--     -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
 
--- | Compose two substitution sets
-compose :: Subst -> Subst -> Subst
-compose m1 m2 = M.map (apply m1) m2 `M.union` m1
+--     -- The bar over S₀ and Γ means "generalize"
 
--- TODO: Split this class into two separate classes, one for free variables
---       and one for applying substitutions
+--     ELet name e0 e1 -> do
+--         (s1, t1, e0') <- algoW e0
+--         env <- asks vars
+--         let t' = generalize (apply s1 env) t1
+--         withBinding name t' $ do
+--             (s2, t2, e1') <- algoW e1
+--             let comp = s2 `compose` s1
+--             return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1')
+--     ECase caseExpr injs -> do
+--         (sub, t, e') <- algoW caseExpr
+--         (subst, injs, ret_t) <- checkCase t injs
+--         let comp = subst `compose` sub
+--         let t' = apply comp ret_t
+--         return (comp, t', T.ECase t' e' injs)
 
--- | A class representing free variables functions
-class FreeVars t where
-    -- | Get all free variables from t
-    free :: t -> Set Ident
+-- -- | Unify two types producing a new substitution
+-- unify :: Type -> Type -> Infer Subst
+-- unify t0 t1 = do
+--     case (t0, t1) of
+--         (TArr a b, TArr c d) -> do
+--             s1 <- unify a c
+--             s2 <- unify (apply s1 b) (apply s1 d)
+--             return $ s1 `compose` s2
+--         (TPol a, b) -> occurs a b
+--         (a, TPol b) -> occurs b a
+--         (TMono a, TMono b) ->
+--             if a == b then return M.empty else throwError "Types do not unify"
+--         (TConstr (Constr name t), TConstr (Constr name' t')) ->
+--             if name == name' && length t == length t'
+--                 then do
+--                     xs <- zipWithM unify t t'
+--                     return $ foldr compose nullSubst xs
+--                 else
+--                     throwError $
+--                         unwords
+--                             [ "Type constructor:"
+--                             , printTree name
+--                             , "(" ++ printTree t ++ ")"
+--                             , "does not match with:"
+--                             , printTree name'
+--                             , "(" ++ printTree t' ++ ")"
+--                             ]
+--         (a, b) -> do
+--             ctx <- ask
+--             env <- get
+--             throwError . unwords $
+--                 [ "Type:"
+--                 , printTree a
+--                 , "can't be unified with:"
+--                 , printTree b
+--                 , "\nCtx:"
+--                 , show ctx
+--                 , "\nEnv:"
+--                 , show env
+--                 ]
 
-    -- | Apply a substitution to t
-    apply :: Subst -> t -> t
+-- {- | Check if a type is contained in another type.
+-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
+-- where these are equal
+-- -}
+-- occurs :: Ident -> Type -> Infer Subst
+-- occurs i t@(TPol _) = return (M.singleton i t)
+-- occurs i t =
+--     if S.member i (free t)
+--         then
+--             throwError $
+--                 unwords
+--                     [ "Occurs check failed, can't unify"
+--                     , printTree (TPol i)
+--                     , "with"
+--                     , printTree t
+--                     ]
+--         else return $ M.singleton i t
 
-instance FreeVars Type where
-    free :: Type -> Set Ident
-    free (TPol a) = S.singleton a
-    free (TMono _) = mempty
-    free (TArr a b) = free a `S.union` free b
-    -- \| Not guaranteed to be correct
-    free (TConstr (Constr _ a)) =
-        foldl' (\acc x -> free x `S.union` acc) S.empty a
+-- -- | Generalize a type over all free variables in the substitution set
+-- generalize :: Map Ident Poly -> Type -> Poly
+-- generalize env t = Forall (S.toList $ free t S.\\ free env) t
 
-    apply :: Subst -> Type -> Type
-    apply sub t = do
-        case t of
-            TMono a -> TMono a
-            TPol a -> case M.lookup a sub of
-                Nothing -> TPol a
-                Just t -> t
-            TArr a b -> TArr (apply sub a) (apply sub b)
-            TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
+-- {- | Instantiate a polymorphic type. The free type variables are substituted
+-- with fresh ones.
+-- -}
+-- inst :: Poly -> Infer Type
+-- inst (Forall xs t) = do
+--     xs' <- mapM (const fresh) xs
+--     let s = M.fromList $ zip xs xs'
+--     return $ apply s t
 
-instance FreeVars Poly where
-    free :: Poly -> Set Ident
-    free (Forall xs t) = free t S.\\ S.fromList xs
-    apply :: Subst -> Poly -> Poly
-    apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
+-- -- | Compose two substitution sets
+-- compose :: Subst -> Subst -> Subst
+-- compose m1 m2 = M.map (apply m1) m2 `M.union` m1
 
-instance FreeVars (Map Ident Poly) where
-    free :: Map Ident Poly -> Set Ident
-    free m = foldl' S.union S.empty (map free $ M.elems m)
-    apply :: Subst -> Map Ident Poly -> Map Ident Poly
-    apply s = M.map (apply s)
+-- -- TODO: Split this class into two separate classes, one for free variables
+-- --       and one for applying substitutions
 
-instance FreeVars T.Exp where
-    free :: T.Exp -> Set Ident
-    free = error "free not implemented for T.Exp"
-    apply :: Subst -> T.Exp -> T.Exp
-    apply s = \case
-        T.EId (ident, t) ->
-            T.EId (ident, apply s t)
-        T.ELit t lit ->
-            T.ELit (apply s t) lit
-        T.ELet (T.Bind (ident, t) e1) e2 ->
-            T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
-        T.EApp t e1 e2 ->
-            T.EApp (apply s t) (apply s e1) (apply s e2)
-        T.EAdd t e1 e2 ->
-            T.EAdd (apply s t) (apply s e1) (apply s e2)
-        T.EAbs t1 (ident, t2) e ->
-            T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
-        T.ECase t e injs ->
-            T.ECase (apply s t) (apply s e) (apply s injs)
+-- -- | A class representing free variables functions
+-- class FreeVars t where
+--     -- | Get all free variables from t
+--     free :: t -> Set Ident
 
-instance FreeVars T.Inj where
-    free :: T.Inj -> Set Ident
-    free = undefined
-    apply :: Subst -> T.Inj -> T.Inj
-    apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
+--     -- | Apply a substitution to t
+--     apply :: Subst -> t -> t
 
-instance FreeVars [T.Inj] where
-    free :: [T.Inj] -> Set Ident
-    free = foldl' (\acc x -> free x `S.union` acc) mempty
-    apply s = map (apply s)
+-- instance FreeVars Type where
+--     free :: Type -> Set Ident
+--     free (TPol a) = S.singleton a
+--     free (TMono _) = mempty
+--     free (TArr a b) = free a `S.union` free b
+--     -- \| Not guaranteed to be correct
+--     free (TConstr (Constr _ a)) =
+--         foldl' (\acc x -> free x `S.union` acc) S.empty a
 
--- | Apply substitutions to the environment.
-applySt :: Subst -> Infer a -> Infer a
-applySt s = local (\st -> st{vars = apply s (vars st)})
+--     apply :: Subst -> Type -> Type
+--     apply sub t = do
+--         case t of
+--             TMono a -> TMono a
+--             TPol a -> case M.lookup a sub of
+--                 Nothing -> TPol a
+--                 Just t -> t
+--             TArr a b -> TArr (apply sub a) (apply sub b)
+--             TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
 
--- | Represents the empty substition set
-nullSubst :: Subst
-nullSubst = M.empty
+-- instance FreeVars Poly where
+--     free :: Poly -> Set Ident
+--     free (Forall xs t) = free t S.\\ S.fromList xs
+--     apply :: Subst -> Poly -> Poly
+--     apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
 
--- | Generate a new fresh variable and increment the state counter
-fresh :: Infer Type
-fresh = do
-    n <- gets count
-    modify (\st -> st{count = n + 1})
-    return . TPol . Ident $ show n
+-- instance FreeVars (Map Ident Poly) where
+--     free :: Map Ident Poly -> Set Ident
+--     free m = foldl' S.union S.empty (map free $ M.elems m)
+--     apply :: Subst -> Map Ident Poly -> Map Ident Poly
+--     apply s = M.map (apply s)
 
--- | Run the monadic action with an additional binding
-withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
-withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
+-- instance FreeVars T.Exp where
+--     free :: T.Exp -> Set Ident
+--     free = error "free not implemented for T.Exp"
+--     apply :: Subst -> T.Exp -> T.Exp
+--     apply s = \case
+--         T.EId (ident, t) ->
+--             T.EId (ident, apply s t)
+--         T.ELit t lit ->
+--             T.ELit (apply s t) lit
+--         T.ELet (T.Bind (ident, t) e1) e2 ->
+--             T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
+--         T.EApp t e1 e2 ->
+--             T.EApp (apply s t) (apply s e1) (apply s e2)
+--         T.EAdd t e1 e2 ->
+--             T.EAdd (apply s t) (apply s e1) (apply s e2)
+--         T.EAbs t1 (ident, t2) e ->
+--             T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
+--         T.ECase t e injs ->
+--             T.ECase (apply s t) (apply s e) (apply s injs)
 
--- | Run the monadic action with several additional bindings
-withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
-withBindings xs =
-    local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
+-- instance FreeVars T.Inj where
+--     free :: T.Inj -> Set Ident
+--     free = undefined
+--     apply :: Subst -> T.Inj -> T.Inj
+--     apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
 
--- | Insert a function signature into the environment
-insertSig :: Ident -> Type -> Infer ()
-insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
+-- instance FreeVars [T.Inj] where
+--     free :: [T.Inj] -> Set Ident
+--     free = foldl' (\acc x -> free x `S.union` acc) mempty
+--     apply s = map (apply s)
 
--- | Insert a constructor with its data type
-insertConstr :: Ident -> Type -> Infer ()
-insertConstr i t =
-    modify (\st -> st{constructors = M.insert i t (constructors st)})
+-- -- | Apply substitutions to the environment.
+-- applySt :: Subst -> Infer a -> Infer a
+-- applySt s = local (\st -> st{vars = apply s (vars st)})
 
--------- PATTERN MATCHING ---------
+-- -- | Represents the empty substition set
+-- nullSubst :: Subst
+-- nullSubst = M.empty
 
-checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
-checkCase expT injs = do
-    (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
-    (sub1, _) <-
-        foldM
-            ( \(sub, acc) x ->
-                (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
-            )
-            (nullSubst, expT)
-            injTs
-    (sub2, returns_type) <-
-        foldM
-            ( \(sub, acc) x ->
-                (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
-            )
-            (nullSubst, head returns)
-            (tail returns)
-    return (sub2 `compose` sub1, injs, returns_type)
+-- -- | Generate a new fresh variable and increment the state counter
+-- fresh :: Infer Type
+-- fresh = do
+--     n <- gets count
+--     modify (\st -> st{count = n + 1})
+--     return . TPol . Ident $ show n
 
-{- | fst = type of init
-   | snd = type of expr
--}
-checkInj :: Inj -> Infer (Type, T.Inj, Type)
-checkInj (Inj it expr) = do
-    (initT, vars) <- inferInit it
-    let converted = map (second (Forall [])) vars
-    (exprT, e) <- withBindings converted (inferExp expr)
-    return (initT, T.Inj (it, initT) e, exprT)
+-- -- | Run the monadic action with an additional binding
+-- withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
+-- withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
 
-inferInit :: Init -> Infer (Type, [T.Id])
-inferInit = \case
-    InitLit lit -> return (litType lit, mempty)
-    InitConstr fn vars -> do
-        gets (M.lookup fn . constructors) >>= \case
-            Nothing ->
-                throwError $
-                    "Constructor: " ++ printTree fn ++ " does not exist"
-            Just a -> do
-                case unsnoc $ flattenType a of
-                    Nothing -> throwError "Partial pattern match not allowed"
-                    Just (vs, ret) ->
-                        case length vars `compare` length vs of
-                            EQ -> do
-                                return (ret, zip vars vs)
-                            _ -> throwError "Partial pattern match not allowed"
-    InitCatch -> (,mempty) <$> fresh
+-- -- | Run the monadic action with several additional bindings
+-- withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
+-- withBindings xs =
+--     local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
 
-flattenType :: Type -> [Type]
-flattenType (TArr a b) = flattenType a ++ flattenType b
-flattenType a = [a]
+-- -- | Insert a function signature into the environment
+-- insertSig :: Ident -> Type -> Infer ()
+-- insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
 
-litType :: Literal -> Type
-litType (LInt _) = TMono "Int"
+-- -- | Insert a constructor with its data type
+-- insertConstr :: Ident -> Type -> Infer ()
+-- insertConstr i t =
+--     modify (\st -> st{constructors = M.insert i t (constructors st)})
+
+-- -------- PATTERN MATCHING ---------
+
+-- checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
+-- checkCase expT injs = do
+--     (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
+--     (sub1, _) <-
+--         foldM
+--             ( \(sub, acc) x ->
+--                 (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
+--             )
+--             (nullSubst, expT)
+--             injTs
+--     (sub2, returns_type) <-
+--         foldM
+--             ( \(sub, acc) x ->
+--                 (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
+--             )
+--             (nullSubst, head returns)
+--             (tail returns)
+--     return (sub2 `compose` sub1, injs, returns_type)
+
+-- {- | fst = type of init
+--    | snd = type of expr
+-- -}
+-- checkInj :: Inj -> Infer (Type, T.Inj, Type)
+-- checkInj (Inj it expr) = do
+--     (initT, vars) <- inferInit it
+--     let converted = map (second (Forall [])) vars
+--     (exprT, e) <- withBindings converted (inferExp expr)
+--     return (initT, T.Inj (it, initT) e, exprT)
+
+-- inferInit :: Init -> Infer (Type, [T.Id])
+-- inferInit = \case
+--     InitLit lit -> return (litType lit, mempty)
+--     InitConstr fn vars -> do
+--         gets (M.lookup fn . constructors) >>= \case
+--             Nothing ->
+--                 throwError $
+--                     "Constructor: " ++ printTree fn ++ " does not exist"
+--             Just a -> do
+--                 case unsnoc $ flattenType a of
+--                     Nothing -> throwError "Partial pattern match not allowed"
+--                     Just (vs, ret) ->
+--                         case length vars `compare` length vs of
+--                             EQ -> do
+--                                 return (ret, zip vars vs)
+--                             _ -> throwError "Partial pattern match not allowed"
+--     InitCatch -> (,mempty) <$> fresh
+
+-- flattenType :: Type -> [Type]
+-- flattenType (TArr a b) = flattenType a ++ flattenType b
+-- flattenType a = [a]
+
+-- litType :: Literal -> Type
+-- litType (LInt _) = TMono "Int"
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 016dd8a..2b3c702 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -2,178 +2,178 @@
 
 module TypeChecker.TypeCheckerIr where
 
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.Functor.Identity (Identity)
-import Data.Map (Map)
-import Grammar.Abs (
-    Data (..),
-    Ident (..),
-    Init (..),
-    Literal (..),
-    Type (..),
- )
-import Grammar.Print
-import Prelude
-import Prelude qualified as C (Eq, Ord, Read, Show)
+-- import Control.Monad.Except
+-- import Control.Monad.Reader
+-- import Control.Monad.State
+-- import Data.Functor.Identity (Identity)
+-- import Data.Map (Map)
+-- import Grammar.Abs (
+--     Data (..),
+--     Ident (..),
+--     Init (..),
+--     Literal (..),
+--     Type (..),
+--  )
+-- import Grammar.Print
+-- import Prelude
+-- import Prelude qualified as C (Eq, Ord, Read, Show)
 
--- | A data type representing type variables
-data Poly = Forall [Ident] Type
-    deriving (Show)
+-- -- | A data type representing type variables
+-- data Poly = Forall [Ident] Type
+--     deriving (Show)
 
-newtype Ctx = Ctx {vars :: Map Ident Poly}
-    deriving Show
+-- newtype Ctx = Ctx {vars :: Map Ident Poly}
+--     deriving Show
 
-data Env = Env
-    { count :: Int
-    , sigs :: Map Ident Type
-    , constructors :: Map Ident Type
-    } deriving Show
+-- data Env = Env
+--     { count :: Int
+--     , sigs :: Map Ident Type
+--     , constructors :: Map Ident Type
+--     } deriving Show
 
-type Error = String
-type Subst = Map Ident Type
+-- type Error = String
+-- type Subst = Map Ident Type
 
-type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
+-- type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
-newtype Program = Program [Def]
-    deriving (C.Eq, C.Ord, C.Show, C.Read)
+-- newtype Program = Program [Def]
+--     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
-data Exp
-    = EId Id
-    | ELit Type Literal
-    | ELet Bind Exp
-    | EApp Type Exp Exp
-    | EAdd Type Exp Exp
-    | EAbs Type Id Exp
-    | ECase Type Exp [Inj]
-    deriving (C.Eq, C.Ord, C.Read, C.Show)
+-- data Exp
+--     = EId Id
+--     | ELit Type Literal
+--     | ELet Bind Exp
+--     | EApp Type Exp Exp
+--     | EAdd Type Exp Exp
+--     | EAbs Type Id Exp
+--     | ECase Type Exp [Inj]
+--     deriving (C.Eq, C.Ord, C.Read, C.Show)
 
-data Inj = Inj (Init, Type) Exp
-    deriving (C.Eq, C.Ord, C.Read, C.Show)
+-- data Inj = Inj (Init, Type) Exp
+--     deriving (C.Eq, C.Ord, C.Read, C.Show)
 
-data Def = DBind Bind | DData Data
-    deriving (C.Eq, C.Ord, C.Read, C.Show)
+-- data Def = DBind Bind | DData Data
+--     deriving (C.Eq, C.Ord, C.Read, C.Show)
 
-type Id = (Ident, Type)
+-- type Id = (Ident, Type)
 
-data Bind = Bind Id Exp
-    deriving (C.Eq, C.Ord, C.Show, C.Read)
+-- data Bind = Bind Id Exp
+--     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
-instance Print [Def] where
-    prt _ [] = concatD []
-    prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
+-- instance Print [Def] where
+--     prt _ [] = concatD []
+--     prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
 
-instance Print Def where
-    prt i (DBind bind) = prt i bind
-    prt i (DData d) = prt i d
+-- instance Print Def where
+--     prt i (DBind bind) = prt i bind
+--     prt i (DData d) = prt i d
 
-instance Print Program where
-    prt i (Program sc) = prPrec i 0 $ prt 0 sc
+-- instance Print Program where
+--     prt i (Program sc) = prPrec i 0 $ prt 0 sc
 
-instance Print Bind where
-    prt i (Bind (t, name) rhs) =
-        prPrec i 0 $
-            concatD
-                [ prt 0 name
-                , doc $ showString ":"
-                , prt 0 t
-                , doc $ showString "\n"
-                , prt 0 name
-                , doc $ showString "="
-                , prt 0 rhs
-                ]
+-- instance Print Bind where
+--     prt i (Bind (t, name) rhs) =
+--         prPrec i 0 $
+--             concatD
+--                 [ prt 0 name
+--                 , doc $ showString ":"
+--                 , prt 0 t
+--                 , doc $ showString "\n"
+--                 , prt 0 name
+--                 , doc $ showString "="
+--                 , prt 0 rhs
+--                 ]
 
-instance Print [Bind] where
-    prt _ [] = concatD []
-    prt _ [x] = concatD [prt 0 x]
-    prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
+-- instance Print [Bind] where
+--     prt _ [] = concatD []
+--     prt _ [x] = concatD [prt 0 x]
+--     prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
 
-prtIdPs :: Int -> [Id] -> Doc
-prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
+-- prtIdPs :: Int -> [Id] -> Doc
+-- prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
 
-prtId :: Int -> Id -> Doc
-prtId i (name, t) =
-    prPrec i 0 $
-        concatD
-            [ prt 0 name
-            , doc $ showString ":"
-            , prt 0 t
-            ]
+-- prtId :: Int -> Id -> Doc
+-- prtId i (name, t) =
+--     prPrec i 0 $
+--         concatD
+--             [ prt 0 name
+--             , doc $ showString ":"
+--             , prt 0 t
+--             ]
 
-prtIdP :: Int -> Id -> Doc
-prtIdP i (name, t) =
-    prPrec i 0 $
-        concatD
-            [ doc $ showString "("
-            , prt 0 name
-            , doc $ showString ":"
-            , prt 0 t
-            , doc $ showString ")"
-            ]
+-- prtIdP :: Int -> Id -> Doc
+-- prtIdP i (name, t) =
+--     prPrec i 0 $
+--         concatD
+--             [ doc $ showString "("
+--             , prt 0 name
+--             , doc $ showString ":"
+--             , prt 0 t
+--             , doc $ showString ")"
+--             ]
 
-instance Print Exp where
-    prt i = \case
-        EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
-        ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
-        ELet bs e ->
-            prPrec i 3 $
-                concatD
-                    [ doc $ showString "let"
-                    , prt 0 bs
-                    , doc $ showString "in"
-                    , prt 0 e
-                    , doc $ showString "\n"
-                    ]
-        EApp _ e1 e2 ->
-            prPrec i 2 $
-                concatD
-                    [ prt 2 e1
-                    , prt 3 e2
-                    ]
-        EAdd t e1 e2 ->
-            prPrec i 1 $
-                concatD
-                    [ doc $ showString "@"
-                    , prt 0 t
-                    , prt 1 e1
-                    , doc $ showString "+"
-                    , prt 2 e2
-                    , doc $ showString "\n"
-                    ]
-        EAbs t n e ->
-            prPrec i 0 $
-                concatD
-                    [ doc $ showString "@"
-                    , prt 0 t
-                    , doc $ showString "\\"
-                    , prtId 0 n
-                    , doc $ showString "."
-                    , prt 0 e
-                    , doc $ showString "\n"
-                    ]
-        ECase t exp injs ->
-            prPrec
-                i
-                0
-                ( concatD
-                    [ doc (showString "case")
-                    , prt 0 exp
-                    , doc (showString "of")
-                    , doc (showString "{")
-                    , prt 0 injs
-                    , doc (showString "}")
-                    , doc (showString ":")
-                    , prt 0 t
-                    , doc $ showString "\n"
-                    ]
-                )
+-- instance Print Exp where
+--     prt i = \case
+--         EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
+--         ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
+--         ELet bs e ->
+--             prPrec i 3 $
+--                 concatD
+--                     [ doc $ showString "let"
+--                     , prt 0 bs
+--                     , doc $ showString "in"
+--                     , prt 0 e
+--                     , doc $ showString "\n"
+--                     ]
+--         EApp _ e1 e2 ->
+--             prPrec i 2 $
+--                 concatD
+--                     [ prt 2 e1
+--                     , prt 3 e2
+--                     ]
+--         EAdd t e1 e2 ->
+--             prPrec i 1 $
+--                 concatD
+--                     [ doc $ showString "@"
+--                     , prt 0 t
+--                     , prt 1 e1
+--                     , doc $ showString "+"
+--                     , prt 2 e2
+--                     , doc $ showString "\n"
+--                     ]
+--         EAbs t n e ->
+--             prPrec i 0 $
+--                 concatD
+--                     [ doc $ showString "@"
+--                     , prt 0 t
+--                     , doc $ showString "\\"
+--                     , prtId 0 n
+--                     , doc $ showString "."
+--                     , prt 0 e
+--                     , doc $ showString "\n"
+--                     ]
+--         ECase t exp injs ->
+--             prPrec
+--                 i
+--                 0
+--                 ( concatD
+--                     [ doc (showString "case")
+--                     , prt 0 exp
+--                     , doc (showString "of")
+--                     , doc (showString "{")
+--                     , prt 0 injs
+--                     , doc (showString "}")
+--                     , doc (showString ":")
+--                     , prt 0 t
+--                     , doc $ showString "\n"
+--                     ]
+--                 )
 
-instance Print Inj where
-    prt i = \case
-        Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
+-- instance Print Inj where
+--     prt i = \case
+--         Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
 
-instance Print [Inj] where
-    prt _ [] = concatD []
-    prt _ [x] = concatD [prt 0 x]
-    prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
+-- instance Print [Inj] where
+--     prt _ [] = concatD []
+--     prt _ [x] = concatD [prt 0 x]
+--     prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
diff --git a/test_program b/test_program
index d916d03..f14962d 100644
--- a/test_program
+++ b/test_program
@@ -1,24 +1,4 @@
-data Maybe ('a) where {
-    Nothing : Maybe ('a)
-    Just : 'a -> Maybe ('a)
-};
-
-fromJust : Maybe ('a) -> 'a ;
-fromJust a =
-    case a of {
-        Just a => a
-    };
-
-fromMaybe : 'a -> Maybe ('a) -> 'a ;
-fromMaybe a b =
-    case b of {
-        Just a => a;
-        Nothing => a
-    };
-
-maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b;
-maybe b f ma =
-    case ma of {
-        Just a => f a;
-        Nothing => b
-    }
+data Maybe (a) where {
+    Nothing : Maybe (a)
+    Just : a -> Maybe (a)
+}

From 914855e20f6389ca52d563f90689963582c73f72 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Wed, 22 Mar 2023 17:52:39 +0100
Subject: [PATCH 67/71] working on adapting the typechecker

---
 Grammar.cf                       |  36 +-
 src/TypeChecker/TypeChecker.hs   | 939 +++++++++++++++----------------
 src/TypeChecker/TypeCheckerIr.hs | 335 ++++++-----
 3 files changed, 658 insertions(+), 652 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index 356646d..27dfd05 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -1,12 +1,13 @@
---------------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
 -- * PROGRAM
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 Program. Program ::= [Def] ;
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * TOP-LEVEL
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 DBind. Def ::= Bind ;
 DSig.  Def ::= Sig ;
@@ -16,9 +17,9 @@ Sig. Sig ::= LIdent ":" Type ;
 
 Bind. Bind ::= LIdent [LIdent] "=" Exp ;
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * TYPES
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
          TLit.     Type2 ::= UIdent ;
          TVar.     Type2 ::= TVar ;
@@ -30,9 +31,9 @@ internal TEVar.    Type1 ::= TEVar ;
          MkTVar.  TVar  ::= LIdent ;
 internal MkTEVar. TEVar ::= LIdent ;
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * DATA TYPES
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 Constructor. Constructor ::= UIdent ":" Type ;
 
@@ -40,12 +41,12 @@ Indexed. Indexed ::= UIdent "(" [Type] ")" ;
 
 Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ;
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * EXPRESSIONS
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
-EId.    Exp4 ::= LIdent ;
+EId.    Exp4 ::= Ident ;
 ELit.   Exp4 ::= Lit ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
@@ -53,16 +54,16 @@ ELet.   Exp  ::= "let" LIdent "=" Exp "in" Exp ;
 EAbs.   Exp  ::= "\\" LIdent "." Exp ;
 ECase.  Exp  ::= "case" Exp "of" "{" [Inj] "}";
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * LITERALS
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 LInt. Lit ::= Integer ;
 LChar. Lit ::= Char ;
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * CASE
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 Inj. Inj ::= Init "=>" Exp ;
 
@@ -70,9 +71,9 @@ InitLit. Init         ::= Lit ;
 InitConstructor. Init ::= UIdent [LIdent] ;
 InitCatch. Init       ::= "_" ;
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- * AUX
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 separator Def ";" ;
 separator nonempty Constructor "" ;
@@ -80,6 +81,7 @@ separator Type " " ;
 separator nonempty Inj ";" ;
 separator Ident " ";
 separator LIdent " ";
+separator TVar " " ;
 
 coercions Exp 5 ;
 coercions Type 2 ;
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 4e072d2..4b9269d 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -4,543 +4,518 @@
 -- | A module for type checking and inference using algorithm W, Hindley-Milner
 module TypeChecker.TypeChecker where
 
--- import Control.Monad.Except
--- import Control.Monad.Reader
--- import Control.Monad.State
--- import Data.Bifunctor (second)
--- import Data.Foldable (traverse_)
--- import Data.Functor.Identity (runIdentity)
--- import Data.List (foldl')
--- import Data.List.Extra (unsnoc)
--- import Data.Map (Map)
--- import Data.Map qualified as M
--- import Data.Maybe (fromMaybe)
--- import Data.Set (Set)
--- import Data.Set qualified as S
--- import Debug.Trace (trace)
--- import Grammar.Abs
--- import Grammar.Print (printTree)
--- import TypeChecker.TypeCheckerIr (
---     Ctx (..),
---     Env (..),
---     Error,
---     Infer,
---     Poly (..),
---     Subst,
---  )
--- import TypeChecker.TypeCheckerIr qualified as T
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Bifunctor (second)
+import Data.Coerce (coerce)
+import Data.Foldable (traverse_)
+import Data.Functor.Identity (runIdentity)
+import Data.List (foldl')
+import Data.List.Extra (unsnoc)
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import Data.Set qualified as S
+import Debug.Trace (trace)
+import Grammar.Abs
+import Grammar.Print (printTree)
+import TypeChecker.TypeCheckerIr (
+    Ctx (..),
+    Env (..),
+    Error,
+    Infer,
+    Poly (..),
+    Subst,
+ )
+import TypeChecker.TypeCheckerIr qualified as T
 
--- initCtx = Ctx mempty
+initCtx = Ctx mempty
 
--- initEnv = Env 0 mempty mempty
+initEnv = Env 0 mempty mempty
 
--- runPretty :: Exp -> Either Error String
--- runPretty = fmap (printTree . fst) . run . inferExp
+runPretty :: Exp -> Either Error String
+runPretty = fmap (printTree . fst) . run . inferExp
 
--- run :: Infer a -> Either Error a
--- run = runC initEnv initCtx
+run :: Infer a -> Either Error a
+run = runC initEnv initCtx
 
--- runC :: Env -> Ctx -> Infer a -> Either Error a
--- runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
+runC :: Env -> Ctx -> Infer a -> Either Error a
+runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
 
--- typecheck :: Program -> Either Error T.Program
--- typecheck = run . checkPrg
+typecheck :: Program -> Either Error T.Program
+typecheck = run . checkPrg
 
--- {- | Start by freshening the type variable of data types to avoid clash with
--- other user defined polymorphic types
--- -}
--- freshenData :: Data -> Infer Data
--- freshenData (Data (Constr name ts) constrs) = do
---     let xs = (S.toList . free) =<< ts
---     frs <- traverse (const fresh) xs
---     let m = M.fromList $ zip xs frs
---     return $
---         Data
---             (Constr name (map (freshenType m) ts))
---             ( map
---                 ( \(Constructor ident t) ->
---                     Constructor ident (freshenType m t)
---                 )
---                 constrs
---             )
+checkData :: Data -> Infer ()
+checkData d = do
+    case d of
+        (Data typ@(Indexed name ts) constrs) -> do
+            unless
+                (all isPoly ts)
+                (throwError $ unwords ["Data type incorrectly declared"])
+            traverse_
+                ( \(Constructor name' t') ->
+                    if TIndexed typ == retType t'
+                        then insertConstr name' t'
+                        else
+                            throwError $
+                                unwords
+                                    [ "return type of constructor:"
+                                    , printTree name
+                                    , "with type:"
+                                    , printTree (retType t')
+                                    , "does not match data: "
+                                    , printTree typ
+                                    ]
+                )
+                constrs
 
--- {- | Freshen all polymorphic variables, regardless of name
+retType :: Type -> Type
+retType (TFun _ t2) = retType t2
+retType a = a
 
-{- | freshenType "d" (a -> b -> c) becomes (d -> d -> d)
--\}
-freshenType :: Map Ident Type -> Type -> Type
-freshenType m t = case t of
-    TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m)
-    TMono mono -> TMono mono
-    TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2)
-    TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts))
+checkPrg :: Program -> Infer T.Program
+checkPrg (Program bs) = do
+    preRun bs
+    bs' <- checkDef bs
+    return $ T.Program bs'
+  where
+    preRun :: [Def] -> Infer ()
+    preRun [] = return ()
+    preRun (x : xs) = case x of
+        -- TODO: Check for no overlapping signature definitions
+        DSig (Sig n t) -> insertSig n t >> preRun xs
+        DBind (Bind{}) -> preRun xs
+        DData d@(Data _ _) -> checkData d >> preRun xs
+
+    checkDef :: [Def] -> Infer [T.Def]
+    checkDef [] = return []
+    checkDef (x : xs) = case x of
+        (DBind b) -> do
+            b' <- checkBind b
+            fmap (T.DBind b' :) (checkDef xs)
+        (DData d) -> fmap (T.DData d :) (checkDef xs)
+        (DSig _) -> checkDef xs
+
+checkBind :: Bind -> Infer T.Bind
+checkBind (Bind name args e) = do
+    let lambda = makeLambda e (reverse args)
+    e@(_, t') <- inferExp lambda
+    -- TODO: Check for match against existing signatures
+    return $ T.Bind (coerce name, t') [] e -- (apply s e)
+  where
+    makeLambda :: Exp -> [LIdent] -> Exp
+    makeLambda = foldl (flip EAbs)
+
+{- | Check if two types are considered equal
+  For the purpose of the algorithm two polymorphic types are always considered
+  equal
 -}
+typeEq :: Type -> Type -> Bool
+typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r'
+typeEq (TLit a) (TLit b) = a == b
+typeEq (TIndexed (Indexed name a)) (TIndexed (Indexed name' b)) =
+    length a == length b
+        && name == name'
+        && and (zipWith typeEq a b)
+typeEq (TAll n1 t1) (TAll n2 t2) = t1 `typeEq` t2
+typeEq _ _ = False
 
--- checkData :: Data -> Infer ()
--- checkData d = do
---     d' <- freshenData d
---     case d' of
---         (Data typ@(Constr name ts) constrs) -> do
---             unless
---                 (all isPoly ts)
---                 (throwError $ unwords ["Data type incorrectly declared"])
---             traverse_
---                 ( \(Constructor name' t') ->
---                     if TConstr typ == retType t'
---                         then insertConstr name' t'
---                         else
---                             throwError $
---                                 unwords
---                                     [ "return type of constructor:"
---                                     , printTree name
---                                     , "with type:"
---                                     , printTree (retType t')
---                                     , "does not match data: "
---                                     , printTree typ
---                                     ]
---                 )
---                 constrs
+isMoreSpecificOrEq :: T.Type -> T.Type -> Bool
+isMoreSpecificOrEq _ (T.TAll _ _) = True
+isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) =
+    isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
+isMoreSpecificOrEq (T.TIndexed (T.Indexed n1 ts1)) (T.TIndexed (T.Indexed n2 ts2)) =
+    n1 == n2
+        && length ts1 == length ts2
+        && and (zipWith isMoreSpecificOrEq ts1 ts2)
+isMoreSpecificOrEq a b = a == b
 
--- retType :: Type -> Type
--- retType (TArr _ t2) = retType t2
--- retType a = a
+isPoly :: Type -> Bool
+isPoly (TAll _ _) = True
+isPoly _ = False
 
--- checkPrg :: Program -> Infer T.Program
--- checkPrg (Program bs) = do
---     preRun bs
---     bs' <- checkDef bs
---     return $ T.Program bs'
---   where
---     preRun :: [Def] -> Infer ()
---     preRun [] = return ()
---     preRun (x : xs) = case x of
---         DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs
---         DData d@(Data _ _) -> checkData d >> preRun xs
+inferExp :: Exp -> Infer T.ExpT
+inferExp e = do
+    (s, t, e') <- algoW e
+    let subbed = apply s t
+    return $ replace subbed (e', t)
 
---     checkDef :: [Def] -> Infer [T.Def]
---     checkDef [] = return []
---     checkDef (x : xs) = case x of
---         (DBind b) -> do
---             b' <- checkBind b
---             fmap (T.DBind b' :) (checkDef xs)
---         (DData d) -> do
---             d' <- freshenData d
---             fmap (T.DData d' :) (checkDef xs)
+replace :: T.Type -> T.ExpT -> T.ExpT
+replace t = second (const t)
 
--- checkBind :: Bind -> Infer T.Bind
--- checkBind (Bind n t _ args e) = do
---     let lambda = makeLambda e (reverse args)
---     (t', e) <- inferExp lambda
---     s <- unify t' t
---     let t'' = apply s t
---     unless
---         (t `typeEq` t'')
---         ( throwError $
---             unwords
---                 [ "Top level signature"
---                 , printTree t
---                 , "does not match body with inferred type:"
---                 , printTree t''
---                 ]
---         )
---     return $ T.Bind (n, t) (apply s e)
---   where
---     makeLambda :: Exp -> [Ident] -> Exp
---     makeLambda = foldl (flip EAbs)
+class NewType a b where
+    toNew :: a -> b
 
--- {- | Check if two types are considered equal
---   For the purpose of the algorithm two polymorphic types are always considered
---   equal
--- -}
--- typeEq :: Type -> Type -> Bool
--- typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
--- typeEq (TMono a) (TMono b) = a == b
--- typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) =
---     length a == length b
---         && name == name'
---         && and (zipWith typeEq a b)
--- typeEq (TPol _) (TPol _) = True
--- typeEq _ _ = False
+instance NewType Type T.Type where
+    toNew = \case
+        TLit i -> T.TLit $ coerce i
+        TVar v -> T.TVar v
+        TFun t1 t2 -> T.TFun (toNew t1) (toNew t2)
+        TAll b t -> T.TAll b (toNew t)
+        TIndexed i -> T.TIndexed (toNew i)
+        TEVar _ -> error "Should not exist after typechecker"
 
--- isMoreSpecificOrEq :: Type -> Type -> Bool
--- isMoreSpecificOrEq _ (TPol _) = True
--- isMoreSpecificOrEq (TArr a b) (TArr c d) =
---     isMoreSpecificOrEq a c && isMoreSpecificOrEq b d
--- isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) =
---     n1 == n2
---         && length ts1 == length ts2
---         && and (zipWith isMoreSpecificOrEq ts1 ts2)
--- isMoreSpecificOrEq a b = a == b
+instance NewType Indexed T.Indexed where
+    toNew (Indexed name vars) = T.Indexed (coerce name) (map toNew vars)
 
--- isPoly :: Type -> Bool
--- isPoly (TPol _) = True
--- isPoly _ = False
+algoW :: Exp -> Infer (Subst, T.ExpT)
+algoW = \case
+    -- \| TODO: More testing need to be done. Unsure of the correctness of this
+    EAnn e t -> do
+        (s1, (e', t')) <- algoW e
+        unless
+            (toNew t `isMoreSpecificOrEq` t')
+            ( throwError $
+                unwords
+                    [ "Annotated type:"
+                    , printTree t
+                    , "does not match inferred type:"
+                    , printTree t'
+                    ]
+            )
+        applySt s1 $ do
+            s2 <- unify (toNew t) t'
+            let comp = s2 `compose` s1
+            return (comp, (apply comp e', toNew t))
 
--- inferExp :: Exp -> Infer (Type, T.Exp)
--- inferExp e = do
---     (s, t, e') <- algoW e
---     let subbed = apply s t
---     return (subbed, replace subbed e')
+    -- \| ------------------
+    -- \|   Γ ⊢ i : Int, ∅
 
--- replace :: Type -> T.Exp -> T.Exp
--- replace t = \case
---     T.ELit _ e -> T.ELit t e
---     T.EId (n, _) -> T.EId (n, t)
---     T.EAbs _ name e -> T.EAbs t name e
---     T.EApp _ e1 e2 -> T.EApp t e1 e2
---     T.EAdd _ e1 e2 -> T.EAdd t e1 e2
---     T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2
---     T.ECase _ expr injs -> T.ECase t expr injs
+    ELit lit ->
+        let lt = toNew $ litType lit
+         in return (nullSubst, (T.ELit lt lit, lt))
+    -- \| x : σ ∈ Γ   τ = inst(σ)
+    -- \| ----------------------
+    -- \|     Γ ⊢ x : τ, ∅
 
--- algoW :: Exp -> Infer (Subst, Type, T.Exp)
--- algoW = \case
---     -- \| TODO: More testing need to be done. Unsure of the correctness of this
---     EAnn e t -> do
---         (s1, t', e') <- algoW e
---         unless
---             (t `isMoreSpecificOrEq` t')
---             ( throwError $
---                 unwords
---                     [ "Annotated type:"
---                     , printTree t
---                     , "does not match inferred type:"
---                     , printTree t'
---                     ]
---             )
---         applySt s1 $ do
---             s2 <- unify t t'
---             let comp = s2 `compose` s1
---             return (comp, t, apply comp e')
+    EId i -> do
+        var <- asks vars
+        case M.lookup i var of
+            Just t -> inst (toNew t) >>= \x -> return (nullSubst, x, T.EId (i, x))
+            Nothing -> do
+                sig <- gets sigs
+                case M.lookup i sig of
+                    Just t -> return (nullSubst, toNew t, T.EId (i, toNew t))
+                    Nothing -> do
+                        constr <- gets constructors
+                        case M.lookup i constr of
+                            Just t -> return (nullSubst, toNew t, T.EId (i, toNew t))
+                            Nothing ->
+                                throwError $
+                                    "Unbound variable: " ++ show i
 
---     -- \| ------------------
---     -- \|   Γ ⊢ i : Int, ∅
+    -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
+    -- \| ---------------------------------
+    -- \|     Γ ⊢ w λx. e : Sτ → τ', S
 
---     ELit lit ->
---         let lt = litType lit
---          in return (nullSubst, lt, T.ELit lt lit)
---     -- \| x : σ ∈ Γ   τ = inst(σ)
---     -- \| ----------------------
---     -- \|     Γ ⊢ x : τ, ∅
+    EAbs name e -> do
+        fr <- fresh
+        withBinding (coerce name) (Forall [] (toNew fr)) $ do
+            (s1, t', e') <- algoW e
+            let varType = toNew $ apply s1 fr
+            let newArr = T.TFun varType (toNew t')
+            return (s1, newArr, apply s1 $ T.EAbs newArr (coerce name, varType) (e', newArr))
 
---     EId i -> do
---         var <- asks vars
---         case M.lookup i var of
---             Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
---             Nothing -> do
---                 sig <- gets sigs
---                 case M.lookup i sig of
---                     Just t -> return (nullSubst, t, T.EId (i, t))
---                     Nothing -> do
---                         constr <- gets constructors
---                         case M.lookup i constr of
---                             Just t -> return (nullSubst, t, T.EId (i, t))
---                             Nothing ->
---                                 throwError $
---                                     "Unbound variable: " ++ show i
+    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
+    -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
+    -- \| ------------------------------------------
+    -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
+    -- This might be wrong
 
---     -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
---     -- \| ---------------------------------
---     -- \|     Γ ⊢ w λx. e : Sτ → τ', S
+    EAdd e0 e1 -> do
+        (s1, t0, e0') <- algoW e0
+        applySt s1 $ do
+            (s2, t1, e1') <- algoW e1
+            -- applySt s2 $ do
+            s3 <- unify (apply s2 t0) (T.TLit "Int")
+            s4 <- unify (apply s3 t1) (T.TLit "Int")
+            let comp = s4 `compose` s3 `compose` s2 `compose` s1
+            return
+                ( comp
+                , T.TLit "Int"
+                , apply comp $ T.EAdd (T.TLit "Int") (e0', t0) (e1', t1)
+                )
 
---     EAbs name e -> do
---         fr <- fresh
---         withBinding name (Forall [] fr) $ do
---             (s1, t', e') <- algoW e
---             let varType = apply s1 fr
---             let newArr = TArr varType t'
---             return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e')
+    -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
+    -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
+    -- \| --------------------------------------
+    -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
 
---     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
---     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
---     -- \| ------------------------------------------
---     -- \|        Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀
---     -- This might be wrong
+    EApp e0 e1 -> do
+        fr <- toNew <$> fresh
+        (s0, t0, e0') <- algoW e0
+        applySt s0 $ do
+            (s1, t1, e1') <- algoW e1
+            -- applySt s1 $ do
+            s2 <- unify (apply s1 t0) (T.TFun (toNew t1) fr)
+            let t = apply s2 fr
+            let comp = s2 `compose` s1 `compose` s0
+            return (comp, t, apply comp $ T.EApp t (e0', t0) (e1', t1))
 
---     EAdd e0 e1 -> do
---         (s1, t0, e0') <- algoW e0
---         applySt s1 $ do
---             (s2, t1, e1') <- algoW e1
---             -- applySt s2 $ do
---             s3 <- unify (apply s2 t0) (TMono "Int")
---             s4 <- unify (apply s3 t1) (TMono "Int")
---             let comp = s4 `compose` s3 `compose` s2 `compose` s1
---             return
---                 ( comp
---                 , TMono "Int"
---                 , apply comp $ T.EAdd (TMono "Int") e0' e1'
---                 )
+    -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
+    -- \| ----------------------------------------------
+    -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
 
---     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
---     -- \| τ' = newvar    S₂ = mgu(S₁τ₀, τ₁ → τ')
---     -- \| --------------------------------------
---     -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
+    -- The bar over S₀ and Γ means "generalize"
 
---     EApp e0 e1 -> do
---         fr <- fresh
---         (s0, t0, e0') <- algoW e0
---         applySt s0 $ do
---             (s1, t1, e1') <- algoW e1
---             -- applySt s1 $ do
---             s2 <- unify (apply s1 t0) (TArr t1 fr)
---             let t = apply s2 fr
---             let comp = s2 `compose` s1 `compose` s0
---             return (comp, t, apply comp $ T.EApp t e0' e1')
+    ELet name e0 e1 -> do
+        (s1, t1, e0') <- algoW e0
+        env <- asks vars
+        let t' = generalize (apply s1 env) t1
+        withBinding name t' $ do
+            (s2, t2, e1') <- algoW e1
+            let comp = s2 `compose` s1
+            return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1')
+    ECase caseExpr injs -> do
+        (sub, t, e') <- algoW caseExpr
+        (subst, injs, ret_t) <- checkCase t injs
+        let comp = subst `compose` sub
+        let t' = apply comp ret_t
+        return (comp, t', T.ECase t' e' injs)
 
---     -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
---     -- \| ----------------------------------------------
---     -- \|        Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀
+-- | Unify two types producing a new substitution
+unify :: T.Type -> T.Type -> Infer Subst
+unify t0 t1 = do
+    case (t0, t1) of
+        (T.TFun a b, T.TFun c d) -> do
+            s1 <- unify a c
+            s2 <- unify (apply s1 b) (apply s1 d)
+            return $ s1 `compose` s2
+        (T.TVar t, b) -> occurs b t
+        (a, T.TVar t) -> occurs a t
+        (T.TAll _ t, b) -> unify t b
+        (a, T.TAll _ t) -> unify a t
+        (T.TLit a, T.TLit b) ->
+            if a == b then return M.empty else throwError "Types do not unify"
+        (T.TIndexed (T.Indexed name t), T.TIndexed (T.Indexed name' t')) ->
+            if name == name' && length t == length t'
+                then do
+                    xs <- zipWithM unify t t'
+                    return $ foldr compose nullSubst xs
+                else
+                    throwError $
+                        unwords
+                            [ "T.Type constructor:"
+                            , printT . Tree name
+                            , "(" ++ printT . Tree t ++ ")"
+                            , "does not match with:"
+                            , printT . Tree name'
+                            , "(" ++ printT . Tree t' ++ ")"
+                            ]
+        (a, b) -> do
+            ctx <- ask
+            env <- get
+            throwError . unwords $
+                [ "T.Type:"
+                , printT . Tree a
+                , "can't be unified with:"
+                , printT . Tree b
+                , "\nCtx:"
+                , show ctx
+                , "\nEnv:"
+                , show env
+                ]
 
---     -- The bar over S₀ and Γ means "generalize"
+{- | Check if a type is contained in another type.
+I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
+where these are equal
+-}
+occurs :: LIdent -> T.Type -> Infer Subst
+occurs i t@(T.TVar _) = return (M.singleton i t)
+occurs i t =
+    if S.member i (free t)
+        then
+            throwError $
+                unwords
+                    [ "Occurs check failed, can't unify"
+                    , printTree (TVar $ MkTVar i)
+                    , "with"
+                    , printTree t
+                    ]
+        else return $ M.singleton i t
 
---     ELet name e0 e1 -> do
---         (s1, t1, e0') <- algoW e0
---         env <- asks vars
---         let t' = generalize (apply s1 env) t1
---         withBinding name t' $ do
---             (s2, t2, e1') <- algoW e1
---             let comp = s2 `compose` s1
---             return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1')
---     ECase caseExpr injs -> do
---         (sub, t, e') <- algoW caseExpr
---         (subst, injs, ret_t) <- checkCase t injs
---         let comp = subst `compose` sub
---         let t' = apply comp ret_t
---         return (comp, t', T.ECase t' e' injs)
+-- | Generalize a type over all free variables in the substitution set
+generalize :: Map Ident Poly -> Type -> Poly
+generalize env t = Forall (S.toList $ free t S.\\ free env) t
 
--- -- | Unify two types producing a new substitution
--- unify :: Type -> Type -> Infer Subst
--- unify t0 t1 = do
---     case (t0, t1) of
---         (TArr a b, TArr c d) -> do
---             s1 <- unify a c
---             s2 <- unify (apply s1 b) (apply s1 d)
---             return $ s1 `compose` s2
---         (TPol a, b) -> occurs a b
---         (a, TPol b) -> occurs b a
---         (TMono a, TMono b) ->
---             if a == b then return M.empty else throwError "Types do not unify"
---         (TConstr (Constr name t), TConstr (Constr name' t')) ->
---             if name == name' && length t == length t'
---                 then do
---                     xs <- zipWithM unify t t'
---                     return $ foldr compose nullSubst xs
---                 else
---                     throwError $
---                         unwords
---                             [ "Type constructor:"
---                             , printTree name
---                             , "(" ++ printTree t ++ ")"
---                             , "does not match with:"
---                             , printTree name'
---                             , "(" ++ printTree t' ++ ")"
---                             ]
---         (a, b) -> do
---             ctx <- ask
---             env <- get
---             throwError . unwords $
---                 [ "Type:"
---                 , printTree a
---                 , "can't be unified with:"
---                 , printTree b
---                 , "\nCtx:"
---                 , show ctx
---                 , "\nEnv:"
---                 , show env
---                 ]
+{- | Instantiate a polymorphic type. The free type variables are substituted
+with fresh ones.
+-}
+inst :: T.Type -> Infer T.Type
+inst = \case
+    T.TAll bound t -> do
+        fr <- fresh
+        let s = M.singleton fr bound
+        apply s <$> inst t
+    _ -> undefined
 
--- {- | Check if a type is contained in another type.
--- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
--- where these are equal
--- -}
--- occurs :: Ident -> Type -> Infer Subst
--- occurs i t@(TPol _) = return (M.singleton i t)
--- occurs i t =
---     if S.member i (free t)
---         then
---             throwError $
---                 unwords
---                     [ "Occurs check failed, can't unify"
---                     , printTree (TPol i)
---                     , "with"
---                     , printTree t
---                     ]
---         else return $ M.singleton i t
+-- | Compose two substitution sets
+compose :: Subst -> Subst -> Subst
+compose m1 m2 = M.map (apply m1) m2 `M.union` m1
 
--- -- | Generalize a type over all free variables in the substitution set
--- generalize :: Map Ident Poly -> Type -> Poly
--- generalize env t = Forall (S.toList $ free t S.\\ free env) t
+-- TODO: Split this class into two separate classes, one for free variables
+--       and one for applying substitutions
 
--- {- | Instantiate a polymorphic type. The free type variables are substituted
--- with fresh ones.
--- -}
--- inst :: Poly -> Infer Type
--- inst (Forall xs t) = do
---     xs' <- mapM (const fresh) xs
---     let s = M.fromList $ zip xs xs'
---     return $ apply s t
+-- | A class representing free variables functions
+class FreeVars t where
+    -- | Get all free variables from t
+    free :: t -> Set LIdent
 
--- -- | Compose two substitution sets
--- compose :: Subst -> Subst -> Subst
--- compose m1 m2 = M.map (apply m1) m2 `M.union` m1
+    -- | Apply a substitution to t
+    apply :: Subst -> t -> t
 
--- -- TODO: Split this class into two separate classes, one for free variables
--- --       and one for applying substitutions
+instance FreeVars T.Type where
+    free :: T.Type -> Set LIdent
+    free (T.TVar (MkTVar a)) = S.singleton a
+    free (T.TAll (MkTVar bound) t) = (S.singleton bound) `S.intersection` free t
+    free (T.TLit _) = mempty
+    free (T.TFun a b) = free a `S.union` free b
+    -- \| Not guaranteed to be correct
+    free (T.TIndexed (T.Indexed _ a)) =
+        foldl' (\acc x -> free x `S.union` acc) S.empty a
 
--- -- | A class representing free variables functions
--- class FreeVars t where
---     -- | Get all free variables from t
---     free :: t -> Set Ident
+    apply :: Subst -> T.Type -> T.Type
+    apply sub t = do
+        case t of
+            T.TLit a -> T.TLit a
+            T.TVar (MkTVar a) -> case M.lookup a sub of
+                Nothing -> T.TVar (MkTVar a)
+                Just t -> t
+            T.TAll bound t -> undefined
+            T.TFun a b -> T.TFun (apply sub a) (apply sub b)
+            T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a))
 
---     -- | Apply a substitution to t
---     apply :: Subst -> t -> t
+instance FreeVars Poly where
+    free :: Poly -> Set LIdent
+    free (Forall xs t) = free t S.\\ S.fromList xs
+    apply :: Subst -> Poly -> Poly
+    apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
 
--- instance FreeVars Type where
---     free :: Type -> Set Ident
---     free (TPol a) = S.singleton a
---     free (TMono _) = mempty
---     free (TArr a b) = free a `S.union` free b
---     -- \| Not guaranteed to be correct
---     free (TConstr (Constr _ a)) =
---         foldl' (\acc x -> free x `S.union` acc) S.empty a
+instance FreeVars (Map LIdent Poly) where
+    free :: Map LIdent Poly -> Set LIdent
+    free m = foldl' S.union S.empty (map free $ M.elems m)
+    apply :: Subst -> Map LIdent Poly -> Map LIdent Poly
+    apply s = M.map (apply s)
 
---     apply :: Subst -> Type -> Type
---     apply sub t = do
---         case t of
---             TMono a -> TMono a
---             TPol a -> case M.lookup a sub of
---                 Nothing -> TPol a
---                 Just t -> t
---             TArr a b -> TArr (apply sub a) (apply sub b)
---             TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a))
+instance FreeVars T.Exp where
+    free :: T.Exp -> Set LIdent
+    free = error "free not implemented for T.Exp"
+    apply :: Subst -> T.Exp -> T.Exp
+    apply s = \case
+        T.EId (ident, t) ->
+            T.EId (ident, apply s t)
+        T.ELit t lit ->
+            T.ELit (apply s t) lit
+        T.ELet (T.Bind (ident, t) args e1) e2 ->
+            T.ELet (T.Bind (ident, apply s t) args (apply s e1)) (apply s e2)
+        T.EApp t e1 e2 ->
+            T.EApp (apply s t) (apply s e1) (apply s e2)
+        T.EAdd t e1 e2 ->
+            T.EAdd (apply s t) (apply s e1) (apply s e2)
+        T.EAbs t1 (ident, t2) e ->
+            T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
+        T.ECase t e injs ->
+            T.ECase (apply s t) (apply s e) (apply s injs)
 
--- instance FreeVars Poly where
---     free :: Poly -> Set Ident
---     free (Forall xs t) = free t S.\\ S.fromList xs
---     apply :: Subst -> Poly -> Poly
---     apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
+instance FreeVars T.Inj where
+    free :: T.Inj -> Set LIdent
+    free = undefined
+    apply :: Subst -> T.Inj -> T.Inj
+    apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
 
--- instance FreeVars (Map Ident Poly) where
---     free :: Map Ident Poly -> Set Ident
---     free m = foldl' S.union S.empty (map free $ M.elems m)
---     apply :: Subst -> Map Ident Poly -> Map Ident Poly
---     apply s = M.map (apply s)
+instance FreeVars [T.Inj] where
+    free :: [T.Inj] -> Set LIdent
+    free = foldl' (\acc x -> free x `S.union` acc) mempty
+    apply s = map (apply s)
 
--- instance FreeVars T.Exp where
---     free :: T.Exp -> Set Ident
---     free = error "free not implemented for T.Exp"
---     apply :: Subst -> T.Exp -> T.Exp
---     apply s = \case
---         T.EId (ident, t) ->
---             T.EId (ident, apply s t)
---         T.ELit t lit ->
---             T.ELit (apply s t) lit
---         T.ELet (T.Bind (ident, t) e1) e2 ->
---             T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
---         T.EApp t e1 e2 ->
---             T.EApp (apply s t) (apply s e1) (apply s e2)
---         T.EAdd t e1 e2 ->
---             T.EAdd (apply s t) (apply s e1) (apply s e2)
---         T.EAbs t1 (ident, t2) e ->
---             T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
---         T.ECase t e injs ->
---             T.ECase (apply s t) (apply s e) (apply s injs)
+-- | Apply substitutions to the environment.
+applySt :: Subst -> Infer a -> Infer a
+applySt s = local (\st -> st{vars = apply s (vars st)})
 
--- instance FreeVars T.Inj where
---     free :: T.Inj -> Set Ident
---     free = undefined
---     apply :: Subst -> T.Inj -> T.Inj
---     apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
+-- | Represents the empty substition set
+nullSubst :: Subst
+nullSubst = M.empty
 
--- instance FreeVars [T.Inj] where
---     free :: [T.Inj] -> Set Ident
---     free = foldl' (\acc x -> free x `S.union` acc) mempty
---     apply s = map (apply s)
+-- | Generate a new fresh variable and increment the state counter
+fresh :: Infer Type
+fresh = do
+    n <- gets count
+    modify (\st -> st{count = n + 1})
+    return . TVar . MkTVar . LIdent $ show n
 
--- -- | Apply substitutions to the environment.
--- applySt :: Subst -> Infer a -> Infer a
--- applySt s = local (\st -> st{vars = apply s (vars st)})
+-- | Run the monadic action with an additional binding
+withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
+withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
 
--- -- | Represents the empty substition set
--- nullSubst :: Subst
--- nullSubst = M.empty
+-- | Run the monadic action with several additional bindings
+withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
+withBindings xs =
+    local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
 
--- -- | Generate a new fresh variable and increment the state counter
--- fresh :: Infer Type
--- fresh = do
---     n <- gets count
---     modify (\st -> st{count = n + 1})
---     return . TPol . Ident $ show n
+-- | Insert a function signature into the environment
+insertSig :: LIdent -> Type -> Infer ()
+insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
 
--- -- | Run the monadic action with an additional binding
--- withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
--- withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
+-- | Insert a constructor with its data type
+insertConstr :: UIdent -> Type -> Infer ()
+insertConstr i t =
+    modify (\st -> st{constructors = M.insert i t (constructors st)})
 
--- -- | Run the monadic action with several additional bindings
--- withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
--- withBindings xs =
---     local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
+-------- PATTERN MATCHING ---------
 
--- -- | Insert a function signature into the environment
--- insertSig :: Ident -> Type -> Infer ()
--- insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
+checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
+checkCase expT injs = do
+    (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
+    (sub1, _) <-
+        foldM
+            ( \(sub, acc) x ->
+                (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
+            )
+            (nullSubst, expT)
+            injTs
+    (sub2, returns_type) <-
+        foldM
+            ( \(sub, acc) x ->
+                (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
+            )
+            (nullSubst, head returns)
+            (tail returns)
+    return (sub2 `compose` sub1, injs, returns_type)
 
--- -- | Insert a constructor with its data type
--- insertConstr :: Ident -> Type -> Infer ()
--- insertConstr i t =
---     modify (\st -> st{constructors = M.insert i t (constructors st)})
+{- | fst = type of init
+   | snd = type of expr
+-}
+checkInj :: Inj -> Infer (Type, T.Inj, Type)
+checkInj (Inj it expr) = do
+    (initT, vars) <- inferInit it
+    let converted = map (second (Forall [])) vars
+    (exprT, e) <- withBindings converted (inferExp expr)
+    return (initT, T.Inj (it, initT) e, exprT)
 
--- -------- PATTERN MATCHING ---------
+inferInit :: Init -> Infer (Type, [T.Id])
+inferInit = \case
+    InitLit lit -> return (litType lit, mempty)
+    InitConstructor fn vars -> do
+        gets (M.lookup fn . constructors) >>= \case
+            Nothing ->
+                throwError $
+                    "Constructor: " ++ printTree fn ++ " does not exist"
+            Just a -> do
+                case unsnoc $ flattenType a of
+                    Nothing -> throwError "Partial pattern match not allowed"
+                    Just (vs, ret) ->
+                        case length vars `compare` length vs of
+                            EQ -> do
+                                return (ret, zip vars vs)
+                            _ -> throwError "Partial pattern match not allowed"
+    InitCatch -> (,mempty) <$> fresh
 
--- checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
--- checkCase expT injs = do
---     (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
---     (sub1, _) <-
---         foldM
---             ( \(sub, acc) x ->
---                 (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
---             )
---             (nullSubst, expT)
---             injTs
---     (sub2, returns_type) <-
---         foldM
---             ( \(sub, acc) x ->
---                 (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc
---             )
---             (nullSubst, head returns)
---             (tail returns)
---     return (sub2 `compose` sub1, injs, returns_type)
+flattenType :: Type -> [Type]
+flattenType (TFun a b) = flattenType a ++ flattenType b
+flattenType a = [a]
 
--- {- | fst = type of init
---    | snd = type of expr
--- -}
--- checkInj :: Inj -> Infer (Type, T.Inj, Type)
--- checkInj (Inj it expr) = do
---     (initT, vars) <- inferInit it
---     let converted = map (second (Forall [])) vars
---     (exprT, e) <- withBindings converted (inferExp expr)
---     return (initT, T.Inj (it, initT) e, exprT)
-
--- inferInit :: Init -> Infer (Type, [T.Id])
--- inferInit = \case
---     InitLit lit -> return (litType lit, mempty)
---     InitConstr fn vars -> do
---         gets (M.lookup fn . constructors) >>= \case
---             Nothing ->
---                 throwError $
---                     "Constructor: " ++ printTree fn ++ " does not exist"
---             Just a -> do
---                 case unsnoc $ flattenType a of
---                     Nothing -> throwError "Partial pattern match not allowed"
---                     Just (vs, ret) ->
---                         case length vars `compare` length vs of
---                             EQ -> do
---                                 return (ret, zip vars vs)
---                             _ -> throwError "Partial pattern match not allowed"
---     InitCatch -> (,mempty) <$> fresh
-
--- flattenType :: Type -> [Type]
--- flattenType (TArr a b) = flattenType a ++ flattenType b
--- flattenType a = [a]
-
--- litType :: Literal -> Type
--- litType (LInt _) = TMono "Int"
+litType :: Lit -> Type
+litType (LInt _) = TLit "Int"
+litType (LChar _) = TLit "Char"
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 2b3c702..bfc8a6a 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -2,178 +2,207 @@
 
 module TypeChecker.TypeCheckerIr where
 
--- import Control.Monad.Except
--- import Control.Monad.Reader
--- import Control.Monad.State
--- import Data.Functor.Identity (Identity)
--- import Data.Map (Map)
--- import Grammar.Abs (
---     Data (..),
---     Ident (..),
---     Init (..),
---     Literal (..),
---     Type (..),
---  )
--- import Grammar.Print
--- import Prelude
--- import Prelude qualified as C (Eq, Ord, Read, Show)
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Functor.Identity (Identity)
+import Data.Map (Map)
+import Grammar.Abs (
+    Data (..),
+    Ident (..),
+    Init (..),
+    Lit (..),
+    TVar (..),
+ )
+import Grammar.Abs qualified as GA (Type (..))
+import Grammar.Print
+import Prelude
+import Prelude qualified as C (Eq, Ord, Read, Show)
 
--- -- | A data type representing type variables
--- data Poly = Forall [Ident] Type
---     deriving (Show)
+-- | A data type representing type variables
+data Poly = Forall [Ident] Type
+    deriving (Show)
 
--- newtype Ctx = Ctx {vars :: Map Ident Poly}
---     deriving Show
+newtype Ctx = Ctx {vars :: Map Ident Poly}
+    deriving (Show)
 
--- data Env = Env
---     { count :: Int
---     , sigs :: Map Ident Type
---     , constructors :: Map Ident Type
---     } deriving Show
+data Env = Env
+    { count :: Int
+    , sigs :: Map Ident GA.Type
+    , constructors :: Map Ident GA.Type
+    }
+    deriving (Show)
 
--- type Error = String
--- type Subst = Map Ident Type
+type Error = String
+type Subst = Map Ident Type
 
--- type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
+type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 
--- newtype Program = Program [Def]
---     deriving (C.Eq, C.Ord, C.Show, C.Read)
+newtype Program = Program [Def]
+    deriving (C.Eq, C.Ord, C.Show, C.Read)
 
--- data Exp
---     = EId Id
---     | ELit Type Literal
---     | ELet Bind Exp
---     | EApp Type Exp Exp
---     | EAdd Type Exp Exp
---     | EAbs Type Id Exp
---     | ECase Type Exp [Inj]
---     deriving (C.Eq, C.Ord, C.Read, C.Show)
+data Type
+    = TLit Ident
+    | TVar TVar
+    | TFun Type Type
+    | TAll TVar Type
+    | TIndexed Indexed
+    deriving (Show, Eq, Ord, Read)
 
--- data Inj = Inj (Init, Type) Exp
---     deriving (C.Eq, C.Ord, C.Read, C.Show)
+data Exp
+    = EId Id
+    | ELit Lit
+    | ELet Bind ExpT
+    | EApp ExpT ExpT
+    | EAdd ExpT ExpT
+    | EAbs Id ExpT
+    | ECase ExpT [Inj]
+    deriving (C.Eq, C.Ord, C.Read, C.Show)
 
--- data Def = DBind Bind | DData Data
---     deriving (C.Eq, C.Ord, C.Read, C.Show)
+type ExpT = (Exp, Type)
 
--- type Id = (Ident, Type)
+data Indexed = Indexed Ident [Type]
+    deriving (Show, Read, Ord, Eq)
 
--- data Bind = Bind Id Exp
---     deriving (C.Eq, C.Ord, C.Show, C.Read)
+data Inj = Inj (Init, Type) ExpT
+    deriving (C.Eq, C.Ord, C.Read, C.Show)
 
--- instance Print [Def] where
---     prt _ [] = concatD []
---     prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
+data Def = DBind Bind | DData Data
+    deriving (C.Eq, C.Ord, C.Read, C.Show)
 
--- instance Print Def where
---     prt i (DBind bind) = prt i bind
---     prt i (DData d) = prt i d
+type Id = (Ident, Type)
 
--- instance Print Program where
---     prt i (Program sc) = prPrec i 0 $ prt 0 sc
+data Bind = Bind Id [Id] ExpT
+    deriving (C.Eq, C.Ord, C.Show, C.Read)
 
--- instance Print Bind where
---     prt i (Bind (t, name) rhs) =
---         prPrec i 0 $
---             concatD
---                 [ prt 0 name
---                 , doc $ showString ":"
---                 , prt 0 t
---                 , doc $ showString "\n"
---                 , prt 0 name
---                 , doc $ showString "="
---                 , prt 0 rhs
---                 ]
+instance Print [Def] where
+    prt _ [] = concatD []
+    prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
 
--- instance Print [Bind] where
---     prt _ [] = concatD []
---     prt _ [x] = concatD [prt 0 x]
---     prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
+instance Print Def where
+    prt i (DBind bind) = prt i bind
+    prt i (DData d) = prt i d
 
--- prtIdPs :: Int -> [Id] -> Doc
--- prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
+instance Print Program where
+    prt i (Program sc) = prPrec i 0 $ prt 0 sc
 
--- prtId :: Int -> Id -> Doc
--- prtId i (name, t) =
---     prPrec i 0 $
---         concatD
---             [ prt 0 name
---             , doc $ showString ":"
---             , prt 0 t
---             ]
+instance Print Bind where
+    prt i (Bind (t, name) args rhs) =
+        prPrec i 0 $
+            concatD
+                [ prt 0 name
+                , doc $ showString ":"
+                , prt 0 t
+                , doc $ showString "\n"
+                , prt 0 name
+                , doc $ showString "="
+                , prt 0 rhs
+                ]
 
--- prtIdP :: Int -> Id -> Doc
--- prtIdP i (name, t) =
---     prPrec i 0 $
---         concatD
---             [ doc $ showString "("
---             , prt 0 name
---             , doc $ showString ":"
---             , prt 0 t
---             , doc $ showString ")"
---             ]
+instance Print [Bind] where
+    prt _ [] = concatD []
+    prt _ [x] = concatD [prt 0 x]
+    prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
 
--- instance Print Exp where
---     prt i = \case
---         EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
---         ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
---         ELet bs e ->
---             prPrec i 3 $
---                 concatD
---                     [ doc $ showString "let"
---                     , prt 0 bs
---                     , doc $ showString "in"
---                     , prt 0 e
---                     , doc $ showString "\n"
---                     ]
---         EApp _ e1 e2 ->
---             prPrec i 2 $
---                 concatD
---                     [ prt 2 e1
---                     , prt 3 e2
---                     ]
---         EAdd t e1 e2 ->
---             prPrec i 1 $
---                 concatD
---                     [ doc $ showString "@"
---                     , prt 0 t
---                     , prt 1 e1
---                     , doc $ showString "+"
---                     , prt 2 e2
---                     , doc $ showString "\n"
---                     ]
---         EAbs t n e ->
---             prPrec i 0 $
---                 concatD
---                     [ doc $ showString "@"
---                     , prt 0 t
---                     , doc $ showString "\\"
---                     , prtId 0 n
---                     , doc $ showString "."
---                     , prt 0 e
---                     , doc $ showString "\n"
---                     ]
---         ECase t exp injs ->
---             prPrec
---                 i
---                 0
---                 ( concatD
---                     [ doc (showString "case")
---                     , prt 0 exp
---                     , doc (showString "of")
---                     , doc (showString "{")
---                     , prt 0 injs
---                     , doc (showString "}")
---                     , doc (showString ":")
---                     , prt 0 t
---                     , doc $ showString "\n"
---                     ]
---                 )
+prtIdPs :: Int -> [Id] -> Doc
+prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
 
--- instance Print Inj where
---     prt i = \case
---         Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
+prtId :: Int -> Id -> Doc
+prtId i (name, t) =
+    prPrec i 0 $
+        concatD
+            [ prt 0 name
+            , doc $ showString ":"
+            , prt 0 t
+            ]
 
--- instance Print [Inj] where
---     prt _ [] = concatD []
---     prt _ [x] = concatD [prt 0 x]
---     prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
+prtIdP :: Int -> Id -> Doc
+prtIdP i (name, t) =
+    prPrec i 0 $
+        concatD
+            [ doc $ showString "("
+            , prt 0 name
+            , doc $ showString ":"
+            , prt 0 t
+            , doc $ showString ")"
+            ]
+
+instance Print Exp where
+    prt i = \case
+        EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
+        ELit _ lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"]
+        ELet bs e ->
+            prPrec i 3 $
+                concatD
+                    [ doc $ showString "let"
+                    , prt 0 bs
+                    , doc $ showString "in"
+                    , prt 0 e
+                    , doc $ showString "\n"
+                    ]
+        EApp _ e1 e2 ->
+            prPrec i 2 $
+                concatD
+                    [ prt 2 e1
+                    , prt 3 e2
+                    ]
+        EAdd t e1 e2 ->
+            prPrec i 1 $
+                concatD
+                    [ doc $ showString "@"
+                    , prt 0 t
+                    , prt 1 e1
+                    , doc $ showString "+"
+                    , prt 2 e2
+                    , doc $ showString "\n"
+                    ]
+        EAbs t n e ->
+            prPrec i 0 $
+                concatD
+                    [ doc $ showString "@"
+                    , prt 0 t
+                    , doc $ showString "\\"
+                    , prtId 0 n
+                    , doc $ showString "."
+                    , prt 0 e
+                    , doc $ showString "\n"
+                    ]
+        ECase t exp injs ->
+            prPrec
+                i
+                0
+                ( concatD
+                    [ doc (showString "case")
+                    , prt 0 exp
+                    , doc (showString "of")
+                    , doc (showString "{")
+                    , prt 0 injs
+                    , doc (showString "}")
+                    , doc (showString ":")
+                    , prt 0 t
+                    , doc $ showString "\n"
+                    ]
+                )
+
+instance Print ExpT where
+    prt i (e, t) = concatD [prt i e, doc (showString ":"), prt i t]
+
+instance Print Inj where
+    prt i = \case
+        Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
+
+instance Print [Inj] 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 i = \case
+        TLit uident -> prPrec i 2 (concatD [prt 0 uident])
+        TVar tvar -> prPrec i 2 (concatD [prt 0 tvar])
+        TAll tvar type_ -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_])
+        TIndexed indexed -> prPrec i 1 (concatD [prt 0 indexed])
+        TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2])
+
+instance Print Indexed where
+    prt i (Indexed u ts) = concatD [prt i u, prt i ts]

From 3335ab7a57c4420a65bce8f8de1f3692b86f417c Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Wed, 22 Mar 2023 21:26:14 +0100
Subject: [PATCH 68/71] compatible, EId rule for parsing is not working,
 testing not done yet

---
 Grammar.cf                       |   4 +-
 src/Main.hs                      |   8 +-
 src/Renamer/Renamer.hs           |  35 ++---
 src/TypeChecker/TypeChecker.hs   | 212 ++++++++++++++++---------------
 src/TypeChecker/TypeCheckerIr.hs |  28 ++--
 5 files changed, 146 insertions(+), 141 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index 27dfd05..28696c6 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -51,14 +51,14 @@ ELit.   Exp4 ::= Lit ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
 ELet.   Exp  ::= "let" LIdent "=" Exp "in" Exp ; 
-EAbs.   Exp  ::= "\\" LIdent "." Exp ;
+EAbs.   Exp  ::= "\\" Ident "." Exp ;
 ECase.  Exp  ::= "case" Exp "of" "{" [Inj] "}";
 
 -------------------------------------------------------------------------------
 -- * LITERALS
 -------------------------------------------------------------------------------
 
-LInt. Lit ::= Integer ;
+LInt. Lit  ::= Integer ;
 LChar. Lit ::= Char ;
 
 -------------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
index 0a00cd6..5a96404 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,7 +12,7 @@ import Renamer.Renamer (rename)
 import System.Environment (getArgs)
 import System.Exit (exitFailure, exitSuccess)
 
--- import TypeChecker.TypeChecker (typecheck)
+import TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
 main =
@@ -32,9 +32,9 @@ main' s = do
     renamed <- fromRenamerErr . rename $ parsed
     putStrLn $ printTree renamed
 
-    -- putStrLn "\n-- TypeChecker --"
-    -- typechecked <- fromTypeCheckerErr $ typecheck renamed
-    -- putStrLn $ show typechecked
+    putStrLn "\n-- TypeChecker --"
+    typechecked <- fromTypeCheckerErr $ typecheck renamed
+    putStrLn $ printTree typechecked
 
     -- putStrLn "\n-- Lambda Lifter --"
     -- let lifted = lambdaLift typechecked
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index aac8b16..9f69185 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -21,6 +21,7 @@ import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Tuple.Extra (dupe)
+import Data.Coerce (coerce)
 import Grammar.Abs
 
 -- | Rename all variables and local binds
@@ -30,15 +31,15 @@ rename (Program defs) = Program <$> renameDefs defs
 renameDefs :: [Def] -> Either String [Def]
 renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt
   where
-    initNames = Map.fromList [dupe name | DBind (Bind name _ _) <- defs]
+    initNames = Map.fromList [dupe (coerce name) | DBind (Bind name _ _) <- defs]
 
     renameDef :: Def -> Rn Def
     renameDef = \case
         DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ
         DBind (Bind name vars rhs) -> do
-            (new_names, vars') <- newNames initNames vars
+            (new_names, vars') <- newNames initNames (coerce vars)
             rhs' <- snd <$> renameExp new_names rhs
-            pure . DBind $ Bind name vars' rhs'
+            pure . DBind $ Bind name (coerce vars') rhs'
         DData (Data (Indexed cname types) constrs) -> do
             tvars' <- mapM nextNameTVar tvars
             let tvars_lt = zip tvars tvars'
@@ -90,11 +91,11 @@ newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
     deriving (Functor, Applicative, Monad, MonadState Cxt)
 
 -- | Maps old to new name
-type Names = Map LIdent LIdent
+type Names = Map Ident Ident
 
 renameExp :: Names -> Exp -> Rn (Names, Exp)
 renameExp old_names = \case
-    EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
+    EId n -> pure (coerce old_names, EId . fromMaybe n $ Map.lookup n (coerce old_names))
     ELit lit -> pure (old_names, ELit lit)
     EApp e1 e2 -> do
         (env1, e1') <- renameExp old_names e1
@@ -107,14 +108,14 @@ renameExp old_names = \case
 
     -- TODO fix shadowing
     ELet name rhs e -> do
-        (new_names, name') <- newName old_names name
+        (new_names, name') <- newName old_names (coerce name)
         (new_names', rhs') <- renameExp new_names rhs
         (new_names'', e') <- renameExp new_names' e
-        pure (new_names'', ELet name' rhs' e')
+        pure (new_names'', ELet (coerce name') rhs' e')
     EAbs par e -> do
-        (new_names, par') <- newName old_names par
+        (new_names, par') <- newName old_names (coerce par)
         (new_names', e') <- renameExp new_names e
-        pure (new_names', EAbs par' e')
+        pure (new_names', EAbs (coerce par') e')
     EAnn e t -> do
         (new_names, e') <- renameExp old_names e
         t' <- renameTVars t
@@ -138,8 +139,8 @@ renameInj ns (Inj init e) = do
 renameInit :: Names -> Init -> Rn (Names, Init)
 renameInit ns i = case i of
     InitConstructor cs vars -> do
-        (ns_new, vars') <- newNames ns vars
-        return (ns_new, InitConstructor cs vars')
+        (ns_new, vars') <- newNames ns (coerce vars)
+        return (ns_new, InitConstructor cs (coerce vars'))
     rest -> return (ns, rest)
 
 renameTVars :: Type -> Rn Type
@@ -169,26 +170,26 @@ substitute tvar1 tvar2 typ = case typ of
     substitute' = substitute tvar1 tvar2
 
 -- | Create a new name and add it to name environment.
-newName :: Names -> LIdent -> Rn (Names, LIdent)
+newName :: Names -> Ident -> Rn (Names, Ident)
 newName env old_name = do
     new_name <- makeName old_name
     pure (Map.insert old_name new_name env, new_name)
 
 -- | Create multiple names and add them to the name environment
-newNames :: Names -> [LIdent] -> Rn (Names, [LIdent])
+newNames :: Names -> [Ident] -> Rn (Names, [Ident])
 newNames = mapAccumM newName
 
 -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
-makeName :: LIdent -> Rn LIdent
-makeName (LIdent prefix) = do
+makeName :: Ident -> Rn Ident
+makeName (Ident prefix) = do
     i <- gets var_counter
-    let name = LIdent $ prefix ++ "_" ++ show i
+    let name = Ident $ prefix ++ "_" ++ show i
     modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
     pure name
 
 nextNameTVar :: TVar -> Rn TVar
 nextNameTVar (MkTVar (LIdent s)) = do
     i <- gets tvar_counter
-    let tvar = MkTVar . LIdent $ s ++ "_" ++ show i
+    let tvar = MkTVar $ coerce $ s ++ "_" ++ show i
     modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter}
     pure tvar
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 4b9269d..a3929b5 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -57,7 +57,7 @@ checkData d = do
             traverse_
                 ( \(Constructor name' t') ->
                     if TIndexed typ == retType t'
-                        then insertConstr name' t'
+                        then insertConstr (coerce name') (toNew t')
                         else
                             throwError $
                                 unwords
@@ -85,7 +85,7 @@ checkPrg (Program bs) = do
     preRun [] = return ()
     preRun (x : xs) = case x of
         -- TODO: Check for no overlapping signature definitions
-        DSig (Sig n t) -> insertSig n t >> preRun xs
+        DSig (Sig n t) -> insertSig (coerce n) (toNew t) >> preRun xs
         DBind (Bind{}) -> preRun xs
         DData d@(Data _ _) -> checkData d >> preRun xs
 
@@ -100,13 +100,13 @@ checkPrg (Program bs) = do
 
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind name args e) = do
-    let lambda = makeLambda e (reverse args)
+    let lambda = makeLambda e (reverse $ coerce args)
     e@(_, t') <- inferExp lambda
     -- TODO: Check for match against existing signatures
     return $ T.Bind (coerce name, t') [] e -- (apply s e)
   where
-    makeLambda :: Exp -> [LIdent] -> Exp
-    makeLambda = foldl (flip EAbs)
+    makeLambda :: Exp -> [Ident] -> Exp
+    makeLambda = foldl (flip (EAbs . coerce))
 
 {- | Check if two types are considered equal
   For the purpose of the algorithm two polymorphic types are always considered
@@ -138,7 +138,7 @@ isPoly _ = False
 
 inferExp :: Exp -> Infer T.ExpT
 inferExp e = do
-    (s, t, e') <- algoW e
+    (s, (e', t)) <- algoW e
     let subbed = apply s t
     return $ replace subbed (e', t)
 
@@ -151,15 +151,18 @@ class NewType a b where
 instance NewType Type T.Type where
     toNew = \case
         TLit i -> T.TLit $ coerce i
-        TVar v -> T.TVar v
+        TVar v -> T.TVar $ toNew v
         TFun t1 t2 -> T.TFun (toNew t1) (toNew t2)
-        TAll b t -> T.TAll b (toNew t)
+        TAll b t -> T.TAll (toNew b) (toNew t)
         TIndexed i -> T.TIndexed (toNew i)
         TEVar _ -> error "Should not exist after typechecker"
 
 instance NewType Indexed T.Indexed where
     toNew (Indexed name vars) = T.Indexed (coerce name) (map toNew vars)
 
+instance NewType TVar T.TVar where
+    toNew (MkTVar i) = T.MkTVar $ coerce i
+
 algoW :: Exp -> Infer (Subst, T.ExpT)
 algoW = \case
     -- \| TODO: More testing need to be done. Unsure of the correctness of this
@@ -178,14 +181,14 @@ algoW = \case
         applySt s1 $ do
             s2 <- unify (toNew t) t'
             let comp = s2 `compose` s1
-            return (comp, (apply comp e', toNew t))
+            return (comp, apply comp (e', toNew t))
 
     -- \| ------------------
     -- \|   Γ ⊢ i : Int, ∅
 
     ELit lit ->
-        let lt = toNew $ litType lit
-         in return (nullSubst, (T.ELit lt lit, lt))
+        let lt = litType lit
+         in return (nullSubst, (T.ELit lit, lt))
     -- \| x : σ ∈ Γ   τ = inst(σ)
     -- \| ----------------------
     -- \|     Γ ⊢ x : τ, ∅
@@ -193,15 +196,15 @@ algoW = \case
     EId i -> do
         var <- asks vars
         case M.lookup i var of
-            Just t -> inst (toNew t) >>= \x -> return (nullSubst, x, T.EId (i, x))
+            Just t -> inst t >>= \(x) -> return (nullSubst, (T.EId (i, x), x))
             Nothing -> do
                 sig <- gets sigs
                 case M.lookup i sig of
-                    Just t -> return (nullSubst, toNew t, T.EId (i, toNew t))
+                    Just t -> return (nullSubst, (T.EId (i, t), t))
                     Nothing -> do
                         constr <- gets constructors
                         case M.lookup i constr of
-                            Just t -> return (nullSubst, toNew t, T.EId (i, toNew t))
+                            Just t -> return (nullSubst, (T.EId (i, t), t))
                             Nothing ->
                                 throwError $
                                     "Unbound variable: " ++ show i
@@ -212,11 +215,11 @@ algoW = \case
 
     EAbs name e -> do
         fr <- fresh
-        withBinding (coerce name) (Forall [] (toNew fr)) $ do
-            (s1, t', e') <- algoW e
-            let varType = toNew $ apply s1 fr
-            let newArr = T.TFun varType (toNew t')
-            return (s1, newArr, apply s1 $ T.EAbs newArr (coerce name, varType) (e', newArr))
+        withBinding (coerce name) fr $ do
+            (s1, (e', t')) <- algoW e
+            let varType = apply s1 fr
+            let newArr = T.TFun varType t'
+            return (s1, apply s1 $ (T.EAbs (coerce name, varType) (e', newArr), newArr))
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
@@ -225,17 +228,16 @@ algoW = \case
     -- This might be wrong
 
     EAdd e0 e1 -> do
-        (s1, t0, e0') <- algoW e0
+        (s1, (e0', t0)) <- algoW e0
         applySt s1 $ do
-            (s2, t1, e1') <- algoW e1
+            (s2, (e1', t1)) <- algoW e1
             -- applySt s2 $ do
-            s3 <- unify (apply s2 t0) (T.TLit "Int")
-            s4 <- unify (apply s3 t1) (T.TLit "Int")
+            s3 <- unify (apply s2 t0) int
+            s4 <- unify (apply s3 t1) int
             let comp = s4 `compose` s3 `compose` s2 `compose` s1
             return
                 ( comp
-                , T.TLit "Int"
-                , apply comp $ T.EAdd (T.TLit "Int") (e0', t0) (e1', t1)
+                , apply comp $ (T.EAdd (e0', t0) (e1', t1), int)
                 )
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
@@ -244,15 +246,15 @@ algoW = \case
     -- \|       Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀
 
     EApp e0 e1 -> do
-        fr <- toNew <$> fresh
-        (s0, t0, e0') <- algoW e0
+        fr <- fresh
+        (s0, (e0', t0)) <- algoW e0
         applySt s0 $ do
-            (s1, t1, e1') <- algoW e1
+            (s1, (e1', t1)) <- algoW e1
             -- applySt s1 $ do
-            s2 <- unify (apply s1 t0) (T.TFun (toNew t1) fr)
+            s2 <- unify (apply s1 t0) (T.TFun t1 fr)
             let t = apply s2 fr
             let comp = s2 `compose` s1 `compose` s0
-            return (comp, t, apply comp $ T.EApp t (e0', t0) (e1', t1))
+            return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t))
 
     -- \| Γ ⊢ e₀ : τ, S₀     S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
     -- \| ----------------------------------------------
@@ -261,19 +263,21 @@ algoW = \case
     -- The bar over S₀ and Γ means "generalize"
 
     ELet name e0 e1 -> do
-        (s1, t1, e0') <- algoW e0
+        (s1, (e0', t1)) <- algoW e0
         env <- asks vars
         let t' = generalize (apply s1 env) t1
-        withBinding name t' $ do
-            (s2, t2, e1') <- algoW e1
+        withBinding (coerce name) t' $ do
+            (s2, (e1', t2)) <- algoW e1
             let comp = s2 `compose` s1
-            return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1')
+            return (comp, apply comp (T.ELet (T.Bind (coerce name, t2) [] (e0', t1)) (e1', t2), t2))
+
+    -- \| TODO: Add judgement
     ECase caseExpr injs -> do
-        (sub, t, e') <- algoW caseExpr
+        (sub, (e', t)) <- algoW caseExpr
         (subst, injs, ret_t) <- checkCase t injs
         let comp = subst `compose` sub
         let t' = apply comp ret_t
-        return (comp, t', T.ECase t' e' injs)
+        return (comp, (T.ECase (e', t) injs, t'))
 
 -- | Unify two types producing a new substitution
 unify :: T.Type -> T.Type -> Infer Subst
@@ -283,8 +287,8 @@ unify t0 t1 = do
             s1 <- unify a c
             s2 <- unify (apply s1 b) (apply s1 d)
             return $ s1 `compose` s2
-        (T.TVar t, b) -> occurs b t
-        (a, T.TVar t) -> occurs a t
+        (T.TVar (T.MkTVar a), t) -> occurs a t
+        (t, T.TVar (T.MkTVar b)) -> occurs b t
         (T.TAll _ t, b) -> unify t b
         (a, T.TAll _ t) -> unify a t
         (T.TLit a, T.TLit b) ->
@@ -298,20 +302,20 @@ unify t0 t1 = do
                     throwError $
                         unwords
                             [ "T.Type constructor:"
-                            , printT . Tree name
-                            , "(" ++ printT . Tree t ++ ")"
+                            , printTree name
+                            , "(" ++ printTree t ++ ")"
                             , "does not match with:"
-                            , printT . Tree name'
-                            , "(" ++ printT . Tree t' ++ ")"
+                            , printTree name'
+                            , "(" ++ printTree t' ++ ")"
                             ]
         (a, b) -> do
             ctx <- ask
             env <- get
             throwError . unwords $
                 [ "T.Type:"
-                , printT . Tree a
+                , printTree a
                 , "can't be unified with:"
-                , printT . Tree b
+                , printTree b
                 , "\nCtx:"
                 , show ctx
                 , "\nEnv:"
@@ -322,7 +326,7 @@ unify t0 t1 = do
 I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
 where these are equal
 -}
-occurs :: LIdent -> T.Type -> Infer Subst
+occurs :: Ident -> T.Type -> Infer Subst
 occurs i t@(T.TVar _) = return (M.singleton i t)
 occurs i t =
     if S.member i (free t)
@@ -330,26 +334,37 @@ occurs i t =
             throwError $
                 unwords
                     [ "Occurs check failed, can't unify"
-                    , printTree (TVar $ MkTVar i)
+                    , printTree (T.TVar $ T.MkTVar i)
                     , "with"
                     , printTree t
                     ]
         else return $ M.singleton i t
 
 -- | Generalize a type over all free variables in the substitution set
-generalize :: Map Ident Poly -> Type -> Poly
-generalize env t = Forall (S.toList $ free t S.\\ free env) t
+generalize :: Map Ident T.Type -> T.Type -> T.Type
+generalize env t = go freeVars $ removeForalls t
+  where
+    freeVars :: [Ident]
+    freeVars = S.toList $ free t S.\\ free env
+    go :: [Ident] -> T.Type -> T.Type
+    go [] t = t
+    go (x : xs) t = T.TAll (T.MkTVar x) (go xs t)
+    removeForalls :: T.Type -> T.Type
+    removeForalls (T.TAll _ t) = removeForalls t
+    removeForalls (T.TFun t1 t2) = T.TFun (removeForalls t1) (removeForalls t2)
+    removeForalls t = t
 
 {- | Instantiate a polymorphic type. The free type variables are substituted
 with fresh ones.
 -}
 inst :: T.Type -> Infer T.Type
 inst = \case
-    T.TAll bound t -> do
+    T.TAll (T.MkTVar bound) t -> do
         fr <- fresh
-        let s = M.singleton fr bound
+        let s = M.singleton bound fr
         apply s <$> inst t
-    _ -> undefined
+    T.TFun t1 t2 -> T.TFun <$> inst t1 <*> inst t2
+    rest -> return rest
 
 -- | Compose two substitution sets
 compose :: Subst -> Subst -> Subst
@@ -361,15 +376,15 @@ compose m1 m2 = M.map (apply m1) m2 `M.union` m1
 -- | A class representing free variables functions
 class FreeVars t where
     -- | Get all free variables from t
-    free :: t -> Set LIdent
+    free :: t -> Set Ident
 
     -- | Apply a substitution to t
     apply :: Subst -> t -> t
 
 instance FreeVars T.Type where
-    free :: T.Type -> Set LIdent
-    free (T.TVar (MkTVar a)) = S.singleton a
-    free (T.TAll (MkTVar bound) t) = (S.singleton bound) `S.intersection` free t
+    free :: T.Type -> Set Ident
+    free (T.TVar (T.MkTVar a)) = S.singleton a
+    free (T.TAll (T.MkTVar bound) t) = (S.singleton bound) `S.intersection` free t
     free (T.TLit _) = mempty
     free (T.TFun a b) = free a `S.union` free b
     -- \| Not guaranteed to be correct
@@ -380,53 +395,40 @@ instance FreeVars T.Type where
     apply sub t = do
         case t of
             T.TLit a -> T.TLit a
-            T.TVar (MkTVar a) -> case M.lookup a sub of
-                Nothing -> T.TVar (MkTVar a)
+            T.TVar (T.MkTVar a) -> case M.lookup a sub of
+                Nothing -> T.TVar (T.MkTVar $ coerce a)
                 Just t -> t
             T.TAll bound t -> undefined
             T.TFun a b -> T.TFun (apply sub a) (apply sub b)
             T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a))
 
-instance FreeVars Poly where
-    free :: Poly -> Set LIdent
-    free (Forall xs t) = free t S.\\ S.fromList xs
-    apply :: Subst -> Poly -> Poly
-    apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
-
-instance FreeVars (Map LIdent Poly) where
-    free :: Map LIdent Poly -> Set LIdent
+instance FreeVars (Map Ident T.Type) where
+    free :: Map Ident T.Type -> Set Ident
     free m = foldl' S.union S.empty (map free $ M.elems m)
-    apply :: Subst -> Map LIdent Poly -> Map LIdent Poly
+    apply :: Subst -> Map Ident T.Type -> Map Ident T.Type
     apply s = M.map (apply s)
 
-instance FreeVars T.Exp where
-    free :: T.Exp -> Set LIdent
+instance FreeVars T.ExpT where
+    free :: T.ExpT -> Set Ident
     free = error "free not implemented for T.Exp"
-    apply :: Subst -> T.Exp -> T.Exp
+    apply :: Subst -> T.ExpT -> T.ExpT
     apply s = \case
-        T.EId (ident, t) ->
-            T.EId (ident, apply s t)
-        T.ELit t lit ->
-            T.ELit (apply s t) lit
-        T.ELet (T.Bind (ident, t) args e1) e2 ->
-            T.ELet (T.Bind (ident, apply s t) args (apply s e1)) (apply s e2)
-        T.EApp t e1 e2 ->
-            T.EApp (apply s t) (apply s e1) (apply s e2)
-        T.EAdd t e1 e2 ->
-            T.EAdd (apply s t) (apply s e1) (apply s e2)
-        T.EAbs t1 (ident, t2) e ->
-            T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
-        T.ECase t e injs ->
-            T.ECase (apply s t) (apply s e) (apply s injs)
+        (T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT)
+        (T.ELit lit, t) -> (T.ELit lit, apply s t)
+        (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2)
+        (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), (apply s t))
+        (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), (apply s t))
+        (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), (apply s t1))
+        (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), (apply s t))
 
 instance FreeVars T.Inj where
-    free :: T.Inj -> Set LIdent
+    free :: T.Inj -> Set Ident
     free = undefined
     apply :: Subst -> T.Inj -> T.Inj
     apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
 
 instance FreeVars [T.Inj] where
-    free :: [T.Inj] -> Set LIdent
+    free :: [T.Inj] -> Set Ident
     free = foldl' (\acc x -> free x `S.union` acc) mempty
     apply s = map (apply s)
 
@@ -439,33 +441,33 @@ nullSubst :: Subst
 nullSubst = M.empty
 
 -- | Generate a new fresh variable and increment the state counter
-fresh :: Infer Type
+fresh :: Infer T.Type
 fresh = do
     n <- gets count
     modify (\st -> st{count = n + 1})
-    return . TVar . MkTVar . LIdent $ show n
+    return . T.TVar . T.MkTVar . Ident $ show n
 
 -- | Run the monadic action with an additional binding
-withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
+withBinding :: (Monad m, MonadReader Ctx m) => Ident -> T.Type -> m a -> m a
 withBinding i p = local (\st -> st{vars = M.insert i p (vars st)})
 
 -- | Run the monadic action with several additional bindings
-withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a
+withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, T.Type)] -> m a -> m a
 withBindings xs =
     local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
 
 -- | Insert a function signature into the environment
-insertSig :: LIdent -> Type -> Infer ()
+insertSig :: Ident -> T.Type -> Infer ()
 insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
 
 -- | Insert a constructor with its data type
-insertConstr :: UIdent -> Type -> Infer ()
+insertConstr :: Ident -> T.Type -> Infer ()
 insertConstr i t =
     modify (\st -> st{constructors = M.insert i t (constructors st)})
 
 -------- PATTERN MATCHING ---------
 
-checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type)
+checkCase :: T.Type -> [Inj] -> Infer (Subst, [T.Inj], T.Type)
 checkCase expT injs = do
     (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs
     (sub1, _) <-
@@ -487,18 +489,17 @@ checkCase expT injs = do
 {- | fst = type of init
    | snd = type of expr
 -}
-checkInj :: Inj -> Infer (Type, T.Inj, Type)
+checkInj :: Inj -> Infer (T.Type, T.Inj, T.Type)
 checkInj (Inj it expr) = do
     (initT, vars) <- inferInit it
-    let converted = map (second (Forall [])) vars
-    (exprT, e) <- withBindings converted (inferExp expr)
-    return (initT, T.Inj (it, initT) e, exprT)
+    (e, exprT) <- withBindings vars (inferExp expr)
+    return (initT, T.Inj (it, initT) (e, exprT), exprT)
 
-inferInit :: Init -> Infer (Type, [T.Id])
+inferInit :: Init -> Infer (T.Type, [T.Id])
 inferInit = \case
     InitLit lit -> return (litType lit, mempty)
     InitConstructor fn vars -> do
-        gets (M.lookup fn . constructors) >>= \case
+        gets (M.lookup (coerce fn) . constructors) >>= \case
             Nothing ->
                 throwError $
                     "Constructor: " ++ printTree fn ++ " does not exist"
@@ -508,14 +509,17 @@ inferInit = \case
                     Just (vs, ret) ->
                         case length vars `compare` length vs of
                             EQ -> do
-                                return (ret, zip vars vs)
+                                return (ret, zip (coerce vars) vs)
                             _ -> throwError "Partial pattern match not allowed"
     InitCatch -> (,mempty) <$> fresh
 
-flattenType :: Type -> [Type]
-flattenType (TFun a b) = flattenType a ++ flattenType b
+flattenType :: T.Type -> [T.Type]
+flattenType (T.TFun a b) = flattenType a ++ flattenType b
 flattenType a = [a]
 
-litType :: Lit -> Type
-litType (LInt _) = TLit "Int"
-litType (LChar _) = TLit "Char"
+litType :: Lit -> T.Type
+litType (LInt _) = int
+litType (LChar _) = char
+
+int = T.TLit "Int"
+char = T.TLit "Char"
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index bfc8a6a..9cf2059 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -12,9 +12,7 @@ import Grammar.Abs (
     Ident (..),
     Init (..),
     Lit (..),
-    TVar (..),
  )
-import Grammar.Abs qualified as GA (Type (..))
 import Grammar.Print
 import Prelude
 import Prelude qualified as C (Eq, Ord, Read, Show)
@@ -23,13 +21,13 @@ import Prelude qualified as C (Eq, Ord, Read, Show)
 data Poly = Forall [Ident] Type
     deriving (Show)
 
-newtype Ctx = Ctx {vars :: Map Ident Poly}
+newtype Ctx = Ctx {vars :: Map Ident Type}
     deriving (Show)
 
 data Env = Env
     { count :: Int
-    , sigs :: Map Ident GA.Type
-    , constructors :: Map Ident GA.Type
+    , sigs :: Map Ident Type
+    , constructors :: Map Ident Type
     }
     deriving (Show)
 
@@ -41,6 +39,9 @@ type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 newtype Program = Program [Def]
     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
+data TVar = MkTVar Ident
+    deriving (Show, Eq, Ord, Read)
+
 data Type
     = TLit Ident
     | TVar TVar
@@ -130,7 +131,7 @@ prtIdP i (name, t) =
 instance Print Exp where
     prt i = \case
         EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
-        ELit _ lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"]
+        ELit lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"]
         ELet bs e ->
             prPrec i 3 $
                 concatD
@@ -140,34 +141,31 @@ instance Print Exp where
                     , prt 0 e
                     , doc $ showString "\n"
                     ]
-        EApp _ e1 e2 ->
+        EApp e1 e2 ->
             prPrec i 2 $
                 concatD
                     [ prt 2 e1
                     , prt 3 e2
                     ]
-        EAdd t e1 e2 ->
+        EAdd e1 e2 ->
             prPrec i 1 $
                 concatD
                     [ doc $ showString "@"
-                    , prt 0 t
                     , prt 1 e1
                     , doc $ showString "+"
                     , prt 2 e2
                     , doc $ showString "\n"
                     ]
-        EAbs t n e ->
+        EAbs n e ->
             prPrec i 0 $
                 concatD
                     [ doc $ showString "@"
-                    , prt 0 t
-                    , doc $ showString "\\"
                     , prtId 0 n
                     , doc $ showString "."
                     , prt 0 e
                     , doc $ showString "\n"
                     ]
-        ECase t exp injs ->
+        ECase exp injs ->
             prPrec
                 i
                 0
@@ -179,7 +177,6 @@ instance Print Exp where
                     , prt 0 injs
                     , doc (showString "}")
                     , doc (showString ":")
-                    , prt 0 t
                     , doc $ showString "\n"
                     ]
                 )
@@ -196,6 +193,9 @@ instance Print [Inj] where
     prt _ [x] = concatD [prt 0 x]
     prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
 
+instance Print TVar where
+    prt i (MkTVar id) = prt i id
+
 instance Print Type where
     prt i = \case
         TLit uident -> prPrec i 2 (concatD [prt 0 uident])

From 8d1330ad4260b9ca046ea35076be95b8f411f500 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 23 Mar 2023 11:13:48 +0100
Subject: [PATCH 69/71] typechecker is compatible with one extra addition to
 the spec

---
 Grammar.cf                     |  5 +--
 language.cabal                 |  2 ++
 sample-programs/basic-1        |  2 +-
 sample-programs/basic-8        |  2 +-
 src/Renamer/Renamer.hs         | 17 +++++-----
 src/TypeChecker/TypeChecker.hs | 42 ++++++++++++------------
 tests/Tests.hs                 | 59 ++++++++++++++--------------------
 7 files changed, 63 insertions(+), 66 deletions(-)

diff --git a/Grammar.cf b/Grammar.cf
index 28696c6..3bb15bd 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -46,12 +46,13 @@ Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ;
 -------------------------------------------------------------------------------
 
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
-EId.    Exp4 ::= Ident ;
+EVar.   Exp4 ::= LIdent ;
+ECons.  Exp4 ::= UIdent ;
 ELit.   Exp4 ::= Lit ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
 ELet.   Exp  ::= "let" LIdent "=" Exp "in" Exp ; 
-EAbs.   Exp  ::= "\\" Ident "." Exp ;
+EAbs.   Exp  ::= "\\" LIdent "." Exp ;
 ECase.  Exp  ::= "case" Exp "of" "{" [Inj] "}";
 
 -------------------------------------------------------------------------------
diff --git a/language.cabal b/language.cabal
index 637d9f7..7e335ee 100644
--- a/language.cabal
+++ b/language.cabal
@@ -47,6 +47,8 @@ executable language
       , either
       , extra
       , array
+      , hspec
+      , QuickCheck
 
     default-language: GHC2021
 
diff --git a/sample-programs/basic-1 b/sample-programs/basic-1
index d52aac2..ee0ad7a 100644
--- a/sample-programs/basic-1
+++ b/sample-programs/basic-1
@@ -1,2 +1,2 @@
 f : Int -> Int ;
-f = \x. x+1 ;
+f x = x ;
diff --git a/sample-programs/basic-8 b/sample-programs/basic-8
index c2c4042..92dd863 100644
--- a/sample-programs/basic-8
+++ b/sample-programs/basic-8
@@ -1,6 +1,6 @@
 data Maybe (a) where {
     Nothing : Maybe (a)
-    Just : forall a. a -> Maybe (a)
+    Just : a -> Maybe (a)
 };
 
 fromJust : Maybe (a) -> a ;
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 9f69185..66c8fb2 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -16,12 +16,12 @@ import Control.Monad.State (
     gets,
     modify,
  )
+import Data.Coerce (coerce)
 import Data.Function (on)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Tuple.Extra (dupe)
-import Data.Coerce (coerce)
 import Grammar.Abs
 
 -- | Rename all variables and local binds
@@ -91,11 +91,12 @@ newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
     deriving (Functor, Applicative, Monad, MonadState Cxt)
 
 -- | Maps old to new name
-type Names = Map Ident Ident
+type Names = Map LIdent LIdent
 
 renameExp :: Names -> Exp -> Rn (Names, Exp)
 renameExp old_names = \case
-    EId n -> pure (coerce old_names, EId . fromMaybe n $ Map.lookup n (coerce old_names))
+    EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names)
+    ECons n -> pure (old_names, ECons n)
     ELit lit -> pure (old_names, ELit lit)
     EApp e1 e2 -> do
         (env1, e1') <- renameExp old_names e1
@@ -170,20 +171,20 @@ substitute tvar1 tvar2 typ = case typ of
     substitute' = substitute tvar1 tvar2
 
 -- | Create a new name and add it to name environment.
-newName :: Names -> Ident -> Rn (Names, Ident)
+newName :: Names -> LIdent -> Rn (Names, LIdent)
 newName env old_name = do
     new_name <- makeName old_name
     pure (Map.insert old_name new_name env, new_name)
 
 -- | Create multiple names and add them to the name environment
-newNames :: Names -> [Ident] -> Rn (Names, [Ident])
+newNames :: Names -> [LIdent] -> Rn (Names, [LIdent])
 newNames = mapAccumM newName
 
 -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
-makeName :: Ident -> Rn Ident
-makeName (Ident prefix) = do
+makeName :: LIdent -> Rn LIdent
+makeName (LIdent prefix) = do
     i <- gets var_counter
-    let name = Ident $ prefix ++ "_" ++ show i
+    let name = LIdent $ prefix ++ "_" ++ show i
     modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
     pure name
 
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index a3929b5..112bf7d 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -134,6 +134,7 @@ isMoreSpecificOrEq a b = a == b
 
 isPoly :: Type -> Bool
 isPoly (TAll _ _) = True
+isPoly (TVar _) = True
 isPoly _ = False
 
 inferExp :: Exp -> Infer T.ExpT
@@ -193,21 +194,20 @@ algoW = \case
     -- \| ----------------------
     -- \|     Γ ⊢ x : τ, ∅
 
-    EId i -> do
+    EVar i -> do
         var <- asks vars
-        case M.lookup i var of
-            Just t -> inst t >>= \(x) -> return (nullSubst, (T.EId (i, x), x))
+        case M.lookup (coerce i) var of
+            Just t -> inst t >>= \x -> return (nullSubst, (T.EId (coerce i, x), x))
             Nothing -> do
                 sig <- gets sigs
-                case M.lookup i sig of
-                    Just t -> return (nullSubst, (T.EId (i, t), t))
-                    Nothing -> do
-                        constr <- gets constructors
-                        case M.lookup i constr of
-                            Just t -> return (nullSubst, (T.EId (i, t), t))
-                            Nothing ->
-                                throwError $
-                                    "Unbound variable: " ++ show i
+                case M.lookup (coerce i) sig of
+                    Just t -> return (nullSubst, (T.EId (coerce i, t), t))
+                    Nothing -> throwError $ "Unbound variable: " ++ show i
+    ECons i -> do
+        constr <- gets constructors
+        case M.lookup (coerce i) constr of
+            Just t -> return (nullSubst, (T.EId (coerce i, t), t))
+            Nothing -> throwError $ "Constructor: '" ++ printTree i ++ "' is not defined"
 
     -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
     -- \| ---------------------------------
@@ -219,7 +219,7 @@ algoW = \case
             (s1, (e', t')) <- algoW e
             let varType = apply s1 fr
             let newArr = T.TFun varType t'
-            return (s1, apply s1 $ (T.EAbs (coerce name, varType) (e', newArr), newArr))
+            return (s1, apply s1 (T.EAbs (coerce name, varType) (e', newArr), newArr))
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
@@ -237,7 +237,7 @@ algoW = \case
             let comp = s4 `compose` s3 `compose` s2 `compose` s1
             return
                 ( comp
-                , apply comp $ (T.EAdd (e0', t0) (e1', t1), int)
+                , apply comp (T.EAdd (e0', t0) (e1', t1), int)
                 )
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S1
@@ -384,7 +384,7 @@ class FreeVars t where
 instance FreeVars T.Type where
     free :: T.Type -> Set Ident
     free (T.TVar (T.MkTVar a)) = S.singleton a
-    free (T.TAll (T.MkTVar bound) t) = (S.singleton bound) `S.intersection` free t
+    free (T.TAll (T.MkTVar bound) t) = S.singleton bound `S.intersection` free t
     free (T.TLit _) = mempty
     free (T.TFun a b) = free a `S.union` free b
     -- \| Not guaranteed to be correct
@@ -398,7 +398,9 @@ instance FreeVars T.Type where
             T.TVar (T.MkTVar a) -> case M.lookup a sub of
                 Nothing -> T.TVar (T.MkTVar $ coerce a)
                 Just t -> t
-            T.TAll bound t -> undefined
+            T.TAll (T.MkTVar i) t -> case M.lookup i sub of
+                Nothing -> T.TAll (T.MkTVar i) (apply sub t)
+                Just _ -> apply sub t
             T.TFun a b -> T.TFun (apply sub a) (apply sub b)
             T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a))
 
@@ -416,10 +418,10 @@ instance FreeVars T.ExpT where
         (T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT)
         (T.ELit lit, t) -> (T.ELit lit, apply s t)
         (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2)
-        (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), (apply s t))
-        (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), (apply s t))
-        (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), (apply s t1))
-        (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), (apply s t))
+        (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t)
+        (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t)
+        (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), apply s t1)
+        (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t)
 
 instance FreeVars T.Inj where
     free :: T.Inj -> Set Ident
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 655c086..27a4eca 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -28,75 +28,66 @@ main = hspec $ do
     infer_eann
     infer_eid
     infer_eabs
-    infer_eapp
     test_id_function
 
 infer_elit = describe "algoW used on ELit" $ do
     it "infers the type mono Int" $ do
-        getType (ELit (LInt 0)) `shouldBe` Right (TMono "Int")
+        getType (ELit (LInt 0)) `shouldBe` Right (T.TLit "Int")
 
     it "infers the type mono Int" $ do
-        getType (ELit (LInt 9999)) `shouldBe` Right (TMono "Int")
+        getType (ELit (LInt 9999)) `shouldBe` Right (T.TLit "Int")
 
 infer_eann = describe "algoW used on EAnn" $ do
     it "infers the type and checks if the annotated type matches" $ do
-        getType (EAnn (ELit $ LInt 0) (TMono "Int")) `shouldBe` Right (TMono "Int")
+        getType (EAnn (ELit $ LInt 0) (TLit "Int")) `shouldBe` Right (T.TLit "Int")
 
     it "fails if the annotated type does not match with the inferred type" $ do
-        getType (EAnn (ELit $ LInt 0) (TPol "a")) `shouldSatisfy` isLeft
+        getType (EAnn (ELit $ LInt 0) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft
 
     it "should be possible to annotate with a more specific type" $ do
-        let annotated_lambda = EAnn (EAbs "x" (EId "x")) (TArr (TMono "Int") (TMono "Int"))
-         in getType annotated_lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int"))
+        let annotated_lambda = EAnn (EAbs "x" (EVar "x")) (TFun (TLit "Int") (TLit "Int"))
+         in getType annotated_lambda `shouldBe` Right (T.TFun (T.TLit "Int") (T.TLit "Int"))
 
     it "should fail if the annotated type is more general than the inferred type" $ do
-        getType (EAnn (ELit (LInt 0)) (TPol "a")) `shouldSatisfy` isLeft
+        getType (EAnn (ELit (LInt 0)) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft
 
     it "should fail if the annotated type is an arrow but the annotated type is not" $ do
-        getType (EAnn (EAbs "x" (EId "x")) (TPol "a")) `shouldSatisfy` isLeft
+        getType (EAnn (EAbs "x" (EVar "x")) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft
 
-infer_eid = describe "algoW used on EId" $ do
+infer_eid = describe "algoW used on EVar" $ do
     it "should fail if the variable is not added to the environment" $ do
-        property $ \x -> getType (EId (Ident (x :: String))) `shouldSatisfy` isLeft
+        property $ \x -> getType (EVar (LIdent (x :: String))) `shouldSatisfy` isLeft
 
     it "should succeed if the type exist in the environment" $ do
         property $ \x -> do
             let env = Env 0 mempty mempty
-            let t = Forall [] (TPol "a")
+            let t = T.TVar $ T.MkTVar "a"
             let ctx = Ctx (M.singleton (Ident (x :: String)) t)
-            getTypeC env ctx (EId (Ident x)) `shouldBe` Right (TPol "a")
+            getTypeC env ctx (EVar (LIdent x)) `shouldBe` Right (T.TVar $ T.MkTVar "a")
 
 infer_eabs = describe "algoW used on EAbs" $ do
     it "should infer the argument type as int if the variable is used as an int" $ do
-        let lambda = EAbs "x" (EAdd (EId "x") (ELit (LInt 0)))
-        getType lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int"))
+        let lambda = EAbs "x" (EAdd (EVar "x") (ELit (LInt 0)))
+        getType lambda `shouldBe` Right (T.TFun (T.TLit "Int") (T.TLit "Int"))
 
     it "should infer the argument type as polymorphic if it is not used in the lambda" $ do
         let lambda = EAbs "x" (ELit (LInt 0))
         getType lambda `shouldSatisfy` isArrowPolyToMono
 
     it "should infer a variable as function if used as one" $ do
-        let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x")))
-        let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True
+        let lambda = EAbs "f" (EAbs "x" (EApp (EVar "f") (EVar "x")))
+        let isOk (Right (T.TFun (T.TFun (T.TVar _) (T.TVar _)) (T.TFun (T.TVar _) (T.TVar _)))) = True
             isOk _ = False
         getType lambda `shouldSatisfy` isOk
 
-infer_eapp = describe "algoW used on EApp" $ do
-    it "should fail if a variable is applied to itself (occurs check)" $ do
-        property $ \x -> do
-            let env = Env 0 mempty mempty
-            let t = Forall [] (TPol "a")
-            let ctx = Ctx (M.singleton (Ident (x :: String)) t)
-            getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldSatisfy` isLeft
-
 churf_id :: Bind
-churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x")
+churf_id = Bind "id" ["x"] (EVar "x")
 
 churf_add :: Bind
-churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y"))
+churf_add = Bind "add" ["x", "y"] (EAdd (EVar "x") (EVar "y"))
 
 churf_main :: Bind
-churf_main = Bind "main" (TArr (TMono "Int") (TMono "Int")) "main" [] (EApp (EApp (EId "id") (EId "add")) (ELit (LInt 0)))
+churf_main = Bind "main" [] (EApp (EApp (EVar "id") (EVar "add")) (ELit (LInt 0)))
 
 prg = Program [DBind churf_main, DBind churf_add, DBind churf_id]
 
@@ -106,14 +97,14 @@ test_id_function =
         it "should succeed to find the correct type" $ do
             typecheck prg `shouldSatisfy` isRight
 
-isArrowPolyToMono :: Either Error Type -> Bool
-isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True
+isArrowPolyToMono :: Either Error T.Type -> Bool
+isArrowPolyToMono (Right (T.TFun (T.TVar _) (T.TLit _))) = True
 isArrowPolyToMono _ = False
 
 -- | Empty environment
-getType :: Exp -> Either Error Type
-getType e = pure fst <*> run (inferExp e)
+getType :: Exp -> Either Error T.Type
+getType e = pure snd <*> run (inferExp e)
 
 -- | Custom environment
-getTypeC :: Env -> Ctx -> Exp -> Either Error Type
-getTypeC env ctx e = pure fst <*> runC env ctx (inferExp e)
+getTypeC :: Env -> Ctx -> Exp -> Either Error T.Type
+getTypeC env ctx e = pure snd <*> runC env ctx (inferExp e)

From 7fa677e3d3729b2755d35ba380905d6ea1deb43c Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 23 Mar 2023 14:18:23 +0100
Subject: [PATCH 70/71] typechecker working, still unsure of quality

---
 src/TypeChecker/TypeChecker.hs   | 84 +++++++++++++++++---------------
 src/TypeChecker/TypeCheckerIr.hs | 30 +++++-------
 2 files changed, 56 insertions(+), 58 deletions(-)

diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 112bf7d..7da23a6 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -15,7 +15,6 @@ import Data.List (foldl')
 import Data.List.Extra (unsnoc)
 import Data.Map (Map)
 import Data.Map qualified as M
-import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Set qualified as S
 import Debug.Trace (trace)
@@ -26,7 +25,6 @@ import TypeChecker.TypeCheckerIr (
     Env (..),
     Error,
     Infer,
-    Poly (..),
     Subst,
  )
 import TypeChecker.TypeCheckerIr qualified as T
@@ -78,15 +76,21 @@ retType a = a
 checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
     preRun bs
-    bs' <- checkDef bs
-    return $ T.Program bs'
+    -- Type check the program twice to produce all top-level types in the first pass through
+    _ <- checkDef bs
+    bs'' <- checkDef bs
+    return $ T.Program bs''
   where
     preRun :: [Def] -> Infer ()
     preRun [] = return ()
     preRun (x : xs) = case x of
         -- TODO: Check for no overlapping signature definitions
-        DSig (Sig n t) -> insertSig (coerce n) (toNew t) >> preRun xs
-        DBind (Bind{}) -> preRun xs
+        DSig (Sig n t) -> insertSig (coerce n) (Just $ toNew t) >> preRun xs
+        DBind (Bind n _ _) -> do
+            s <- gets sigs
+            case M.lookup (coerce n) s of
+                Nothing -> insertSig (coerce n) Nothing >> preRun xs
+                Just _ -> preRun xs
         DData d@(Data _ _) -> checkData d >> preRun xs
 
     checkDef :: [Def] -> Infer [T.Def]
@@ -102,25 +106,33 @@ checkBind :: Bind -> Infer T.Bind
 checkBind (Bind name args e) = do
     let lambda = makeLambda e (reverse $ coerce args)
     e@(_, t') <- inferExp lambda
-    -- TODO: Check for match against existing signatures
-    return $ T.Bind (coerce name, t') [] e -- (apply s e)
+    s <- gets sigs
+    -- let fs = map (second Just) $ getFunctionTypes s e
+    -- mapM_ (uncurry insertSig) fs
+    case M.lookup (coerce name) s of
+        Just (Just t) -> do
+            sub <- unify t t'
+            let newT = apply sub t
+            insertSig (coerce name) (Just newT)
+            return $ T.Bind (coerce name, newT) [] e
+        _ -> do
+            insertSig (coerce name) (Just t')
+            return (T.Bind (coerce name, t') [] e) -- (apply s e)
   where
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip (EAbs . coerce))
 
-{- | Check if two types are considered equal
-  For the purpose of the algorithm two polymorphic types are always considered
-  equal
--}
-typeEq :: Type -> Type -> Bool
-typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r'
-typeEq (TLit a) (TLit b) = a == b
-typeEq (TIndexed (Indexed name a)) (TIndexed (Indexed name' b)) =
-    length a == length b
-        && name == name'
-        && and (zipWith typeEq a b)
-typeEq (TAll n1 t1) (TAll n2 t2) = t1 `typeEq` t2
-typeEq _ _ = False
+    -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)]
+    -- getFunctionTypes s = \case
+    --     (T.EId b, t) -> case M.lookup b s of
+    --         Just Nothing -> return (b, t)
+    --         _ -> []
+    --     (T.ELit _, _) -> []
+    --     (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
+    --     (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
+    --     (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
+    --     (T.EAbs _ e, _) -> getFunctionTypes s e
+    --     (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs
 
 isMoreSpecificOrEq :: T.Type -> T.Type -> Bool
 isMoreSpecificOrEq _ (T.TAll _ _) = True
@@ -193,20 +205,20 @@ algoW = \case
     -- \| x : σ ∈ Γ   τ = inst(σ)
     -- \| ----------------------
     -- \|     Γ ⊢ x : τ, ∅
-
     EVar i -> do
         var <- asks vars
         case M.lookup (coerce i) var of
-            Just t -> inst t >>= \x -> return (nullSubst, (T.EId (coerce i, x), x))
+            Just t -> inst t >>= \x -> return (nullSubst, (T.EId $ coerce i, x))
             Nothing -> do
                 sig <- gets sigs
                 case M.lookup (coerce i) sig of
-                    Just t -> return (nullSubst, (T.EId (coerce i, t), t))
-                    Nothing -> throwError $ "Unbound variable: " ++ show i
+                    Just (Just t) -> return (nullSubst, (T.EId $ coerce i, t))
+                    Just Nothing -> (\x -> (nullSubst, (T.EId $ coerce i, x))) <$> fresh
+                    Nothing -> throwError $ "Unbound variable: " ++ printTree i
     ECons i -> do
         constr <- gets constructors
         case M.lookup (coerce i) constr of
-            Just t -> return (nullSubst, (T.EId (coerce i, t), t))
+            Just t -> return (nullSubst, (T.EId $ coerce i, t))
             Nothing -> throwError $ "Constructor: '" ++ printTree i ++ "' is not defined"
 
     -- \| τ = newvar   Γ, x : τ ⊢ e : τ', S
@@ -219,7 +231,7 @@ algoW = \case
             (s1, (e', t')) <- algoW e
             let varType = apply s1 fr
             let newArr = T.TFun varType t'
-            return (s1, apply s1 (T.EAbs (coerce name, varType) (e', newArr), newArr))
+            return (s1, apply s1 (T.EAbs (coerce name, varType) (e', t'), newArr))
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
@@ -250,7 +262,6 @@ algoW = \case
         (s0, (e0', t0)) <- algoW e0
         applySt s0 $ do
             (s1, (e1', t1)) <- algoW e1
-            -- applySt s1 $ do
             s2 <- unify (apply s1 t0) (T.TFun t1 fr)
             let t = apply s2 fr
             let comp = s2 `compose` s1 `compose` s0
@@ -309,17 +320,10 @@ unify t0 t1 = do
                             , "(" ++ printTree t' ++ ")"
                             ]
         (a, b) -> do
-            ctx <- ask
-            env <- get
             throwError . unwords $
-                [ "T.Type:"
-                , printTree a
-                , "can't be unified with:"
-                , printTree b
-                , "\nCtx:"
-                , show ctx
-                , "\nEnv:"
-                , show env
+                [ "'" ++ printTree a ++ "'"
+                , "can't be unified with"
+                , "'" ++ printTree b ++ "'"
                 ]
 
 {- | Check if a type is contained in another type.
@@ -415,7 +419,7 @@ instance FreeVars T.ExpT where
     free = error "free not implemented for T.Exp"
     apply :: Subst -> T.ExpT -> T.ExpT
     apply s = \case
-        (T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT)
+        (T.EId i, outerT) -> (T.EId i, apply s outerT)
         (T.ELit lit, t) -> (T.ELit lit, apply s t)
         (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2)
         (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t)
@@ -459,7 +463,7 @@ withBindings xs =
     local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
 
 -- | Insert a function signature into the environment
-insertSig :: Ident -> T.Type -> Infer ()
+insertSig :: Ident -> Maybe T.Type -> Infer ()
 insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
 
 -- | Insert a constructor with its data type
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 9cf2059..7c24ab3 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -17,16 +17,12 @@ import Grammar.Print
 import Prelude
 import Prelude qualified as C (Eq, Ord, Read, Show)
 
--- | A data type representing type variables
-data Poly = Forall [Ident] Type
-    deriving (Show)
-
 newtype Ctx = Ctx {vars :: Map Ident Type}
     deriving (Show)
 
 data Env = Env
     { count :: Int
-    , sigs :: Map Ident Type
+    , sigs :: Map Ident (Maybe Type)
     , constructors :: Map Ident Type
     }
     deriving (Show)
@@ -39,7 +35,7 @@ type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
 newtype Program = Program [Def]
     deriving (C.Eq, C.Ord, C.Show, C.Read)
 
-data TVar = MkTVar Ident
+newtype TVar = MkTVar Ident
     deriving (Show, Eq, Ord, Read)
 
 data Type
@@ -51,7 +47,7 @@ data Type
     deriving (Show, Eq, Ord, Read)
 
 data Exp
-    = EId Id
+    = EId Ident
     | ELit Lit
     | ELet Bind ExpT
     | EApp ExpT ExpT
@@ -78,7 +74,7 @@ data Bind = Bind Id [Id] ExpT
 
 instance Print [Def] where
     prt _ [] = concatD []
-    prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
+    prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n\n"), prt 0 xs]
 
 instance Print Def where
     prt i (DBind bind) = prt i bind
@@ -88,7 +84,7 @@ instance Print Program where
     prt i (Program sc) = prPrec i 0 $ prt 0 sc
 
 instance Print Bind where
-    prt i (Bind (t, name) args rhs) =
+    prt i (Bind (name, t) _ rhs) =
         prPrec i 0 $
             concatD
                 [ prt 0 name
@@ -112,9 +108,11 @@ prtId :: Int -> Id -> Doc
 prtId i (name, t) =
     prPrec i 0 $
         concatD
-            [ prt 0 name
+            [ doc $ showString "("
+            , prt 0 name
             , doc $ showString ":"
             , prt 0 t
+            , doc $ showString ")"
             ]
 
 prtIdP :: Int -> Id -> Doc
@@ -130,8 +128,8 @@ prtIdP i (name, t) =
 
 instance Print Exp where
     prt i = \case
-        EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
-        ELit lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"]
+        EId n -> prPrec i 3 $ concatD [prt 0 n]
+        ELit lit -> prPrec i 3 $ concatD [prt 0 lit]
         ELet bs e ->
             prPrec i 3 $
                 concatD
@@ -139,7 +137,6 @@ instance Print Exp where
                     , prt 0 bs
                     , doc $ showString "in"
                     , prt 0 e
-                    , doc $ showString "\n"
                     ]
         EApp e1 e2 ->
             prPrec i 2 $
@@ -154,16 +151,14 @@ instance Print Exp where
                     , prt 1 e1
                     , doc $ showString "+"
                     , prt 2 e2
-                    , doc $ showString "\n"
                     ]
         EAbs n e ->
             prPrec i 0 $
                 concatD
-                    [ doc $ showString "@"
+                    [ doc $ showString "λ"
                     , prtId 0 n
                     , doc $ showString "."
                     , prt 0 e
-                    , doc $ showString "\n"
                     ]
         ECase exp injs ->
             prPrec
@@ -177,12 +172,11 @@ instance Print Exp where
                     , prt 0 injs
                     , doc (showString "}")
                     , doc (showString ":")
-                    , doc $ showString "\n"
                     ]
                 )
 
 instance Print ExpT where
-    prt i (e, t) = concatD [prt i e, doc (showString ":"), prt i t]
+    prt i (e, t) = concatD [doc $ showString "(", prt i e, doc (showString ":"), prt i t, doc $ showString ")"]
 
 instance Print Inj where
     prt i = \case

From 519ed8af6c9d0a32536469100c49d9b9450b2f91 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Thu, 23 Mar 2023 16:06:09 +0100
Subject: [PATCH 71/71] Added monadic fail to renamer

---
 src/Renamer/Renamer.hs           | 18 ++++++++++--------
 src/TypeChecker/TypeChecker.hs   | 22 +++++-----------------
 src/TypeChecker/TypeCheckerIr.hs |  4 ++--
 3 files changed, 17 insertions(+), 27 deletions(-)

diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 66c8fb2..3fa1afc 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -7,7 +7,7 @@ module Renamer.Renamer (rename) where
 
 import Auxiliary (mapAccumM)
 import Control.Applicative (Applicative (liftA2))
-import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
 import Control.Monad.Identity (Identity, runIdentity)
 import Control.Monad.State (
     MonadState,
@@ -41,19 +41,21 @@ renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef
             rhs' <- snd <$> renameExp new_names rhs
             pure . DBind $ Bind name (coerce vars') rhs'
         DData (Data (Indexed cname types) constrs) -> do
-            tvars' <- mapM nextNameTVar tvars
-            let tvars_lt = zip tvars tvars'
+            tvars_ <- tvars
+            tvars' <- mapM nextNameTVar tvars_
+            let tvars_lt = zip tvars_ tvars'
                 typ' = map (substituteTVar tvars_lt) types
                 constrs' = map (renameConstr tvars_lt) constrs
             pure . DData $ Data (Indexed cname typ') constrs'
           where
-            tvars = concatMap (collectTVars []) types
+            tvars = concat <$> mapM (collectTVars []) types
+            collectTVars :: [TVar] -> Type -> Rn [TVar]
             collectTVars tvars = \case
                 TAll tvar t -> collectTVars (tvar : tvars) t
-                TIndexed _ -> tvars
+                TIndexed _ -> return tvars
                 -- Should be monad error
-                TVar v -> [v]
-                _ -> error ("Bad data type definition: " ++ show types)
+                TVar v -> return [v]
+                _ -> throwError ("Bad data type definition: " ++ show types)
 
     renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor
     renameConstr new_types (Constructor name typ) =
@@ -88,7 +90,7 @@ data Cxt = Cxt
 
 -- | Rename monad. State holds the number of renamed names.
 newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
-    deriving (Functor, Applicative, Monad, MonadState Cxt)
+    deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
 
 -- | Maps old to new name
 type Names = Map LIdent LIdent
diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs
index 7da23a6..2bab6c8 100644
--- a/src/TypeChecker/TypeChecker.hs
+++ b/src/TypeChecker/TypeChecker.hs
@@ -77,7 +77,9 @@ checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
     preRun bs
     -- Type check the program twice to produce all top-level types in the first pass through
-    _ <- checkDef bs
+    bs' <- checkDef bs
+    trace "\nFIRST ITERATION" return ()
+    trace (printTree bs' ++ "\nSECOND ITERATION\n") return ()
     bs'' <- checkDef bs
     return $ T.Program bs''
   where
@@ -107,8 +109,6 @@ checkBind (Bind name args e) = do
     let lambda = makeLambda e (reverse $ coerce args)
     e@(_, t') <- inferExp lambda
     s <- gets sigs
-    -- let fs = map (second Just) $ getFunctionTypes s e
-    -- mapM_ (uncurry insertSig) fs
     case M.lookup (coerce name) s of
         Just (Just t) -> do
             sub <- unify t t'
@@ -122,18 +122,6 @@ checkBind (Bind name args e) = do
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip (EAbs . coerce))
 
-    -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)]
-    -- getFunctionTypes s = \case
-    --     (T.EId b, t) -> case M.lookup b s of
-    --         Just Nothing -> return (b, t)
-    --         _ -> []
-    --     (T.ELit _, _) -> []
-    --     (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
-    --     (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
-    --     (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
-    --     (T.EAbs _ e, _) -> getFunctionTypes s e
-    --     (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs
-
 isMoreSpecificOrEq :: T.Type -> T.Type -> Bool
 isMoreSpecificOrEq _ (T.TAll _ _) = True
 isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) =
@@ -231,7 +219,7 @@ algoW = \case
             (s1, (e', t')) <- algoW e
             let varType = apply s1 fr
             let newArr = T.TFun varType t'
-            return (s1, apply s1 (T.EAbs (coerce name, varType) (e', t'), newArr))
+            return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr))
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
@@ -424,7 +412,7 @@ instance FreeVars T.ExpT where
         (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2)
         (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t)
         (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t)
-        (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), apply s t1)
+        (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1)
         (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t)
 
 instance FreeVars T.Inj where
diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs
index 7c24ab3..03a2065 100644
--- a/src/TypeChecker/TypeCheckerIr.hs
+++ b/src/TypeChecker/TypeCheckerIr.hs
@@ -52,7 +52,7 @@ data Exp
     | ELet Bind ExpT
     | EApp ExpT ExpT
     | EAdd ExpT ExpT
-    | EAbs Id ExpT
+    | EAbs Ident ExpT
     | ECase ExpT [Inj]
     deriving (C.Eq, C.Ord, C.Read, C.Show)
 
@@ -156,7 +156,7 @@ instance Print Exp where
             prPrec i 0 $
                 concatD
                     [ doc $ showString "λ"
-                    , prtId 0 n
+                    , prt 0 n
                     , doc $ showString "."
                     , prt 0 e
                     ]