Making progress towards finished product

language.cabal

@@ -34,9 +34,9 @@ executable language
       TypeChecker.TypeChecker
       TypeChecker.TypeCheckerIr
       Renamer.Renamer
-      -- LambdaLifter.LambdaLifter
+      LambdaLifter.LambdaLifter
-      -- Codegen.Codegen
+      Codegen.Codegen
-      -- Codegen.LlvmIr
+      Codegen.LlvmIr
 
     hs-source-dirs:   src
 
@@ -49,6 +49,7 @@ executable language
       , array
       , hspec
       , QuickCheck
+      , directory
 
     default-language: GHC2021
 

src/LambdaLifter/LambdaLifter.hs

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

src/Main.hs

@@ -11,12 +11,16 @@ import           Grammar.Print           (printTree)
 -- import           Interpreter        (interpret)
 import Control.Monad (when)
 import Data.List.Extra (isSuffixOf)
+
 -- import           LambdaLifter.LambdaLifter (lambdaLift)
 import Renamer.Renamer (rename)
-import           System.Directory        (createDirectory, doesPathExist,
+import System.Directory (
+    createDirectory,
+    doesPathExist,
     getDirectoryContents,
     removeDirectoryRecursive,
-                                          setCurrentDirectory)
+    setCurrentDirectory,
+ )
 import System.Environment (getArgs)
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (stderr)
@@ -39,7 +43,7 @@ main' debug s = do
     printToErr $ printTree parsed
 
     printToErr "\n-- Renamer --"
-    let renamed = rename parsed
+    renamed <- fromRenamerErr . rename $ parsed
     printToErr $ printTree renamed
 
     printToErr "\n-- TypeChecker --"
@@ -60,7 +64,6 @@ main' debug s = do
     -- writeFile "output/llvm.ll" compiled
     -- if debug then debugDotViz else putStrLn compiled
 
-
     -- interpred <- fromInterpreterErr $ interpret lifted
     -- putStrLn "\n-- interpret"
     -- print interpred
@@ -111,6 +114,16 @@ fromTypeCheckerErr =
         )
         pure
 
+fromRenamerErr :: Err a -> IO a
+fromRenamerErr =
+    either
+        ( \err -> do
+            putStrLn "\nRENAMER ERROR"
+            putStrLn err
+            exitFailure
+        )
+        pure
+
 fromInterpreterErr :: Err a -> IO a
 fromInterpreterErr =
     either

src/TypeChecker/TypeChecker.hs

@@ -517,3 +517,15 @@ litType (LChar _) = char
 
 int = T.TLit "Int"
 char = T.TLit "Char"
+
+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
+        TAll tvar t' -> second (TAll tvar) $ go acc i t'
+        TFun t1 t2 -> go (acc ++ [t1]) (i - 1) t2
+        _ -> error "Number of parameters and type doesn't match"

tests/Tests.hs

@@ -18,7 +18,6 @@ import TypeChecker.TypeCheckerIr (
     Env (..),
     Error,
     Infer,
-    Poly (..),
  )
 import TypeChecker.TypeCheckerIr qualified as T