Renamer done.

It renames bound variables to numbers, converts let to lambda, and
removes all variables from binds

Grammar.cf

@@ -14,12 +14,12 @@ EAbs.   Exp  ::= "\\" Ident "." Exp ;
 CInt. Const ::= Integer ;
 CStr. Const ::= String ;
 
-TMono. Type1 ::= UIdent ;
+TMono. Type ::= "Mono" Ident ;
-TPoly. Type1 ::= LIdent ;
+TPoly. Type ::= "Poly" Ident ;
 TArrow. Type ::= Type "->" Type1 ;
 
-token UIdent (upper (letter | digit | '_')*) ;
+-- token Upper (upper (letter | digit | '_')*) ;
-token LIdent (lower (letter | digit | '_')*) ;
+-- token Lower (lower (letter | digit | '_')*) ;
 
 separator Bind ";" ;
 separator Ident " ";

language.cabal

@@ -31,12 +31,10 @@ executable language
       Grammar.Print
       Grammar.Skel
       Grammar.ErrM
-      -- LambdaLifter
       TypeChecker.TypeChecker
       TypeChecker.TypeCheckerIr
-      -- Renamer.Renamer
+      Renamer.Renamer
-      -- Renamer.RenamerIr
+      Renamer.RenamerIr
-      -- Interpreter
 
     hs-source-dirs:   src
 

sample-programs/basic-2

@@ -1,4 +1,3 @@
 add x = \y. x+y;
 
 main = (\z. z+z) ((add 4) 6);
-

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 "RENAME SUCCESSFUL"
-            putStrLn . show $ prg
+            putStrLn $ printTree prg
         Left err -> do
-            putStrLn "TYPE CHECK ERROR"
+            putStrLn "FAILED RENAMING"
             putStrLn . show $ err
             exitFailure
-

src/Renamer/Renamer.hs

@@ -1,90 +1,101 @@
-{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE LambdaCase, OverloadedRecordDot, OverloadedStrings #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 
 module Renamer.Renamer (rename) where
 
-import           Control.Applicative  (Applicative (liftA2))
+import Renamer.RenamerIr
-import           Control.Monad.Except (MonadError (throwError))
+import Control.Monad.State
-import           Control.Monad.RWS    (MonadState, gets, modify)
+import Control.Monad.Except
-import           Control.Monad.State  (StateT, evalStateT)
+import Control.Monad.Reader
-import           Data.Set             (Set)
+import Data.Functor.Identity (Identity, runIdentity)
-import qualified Data.Set             as Set
+import Data.Set (Set)
-import           Grammar.Abs
+import qualified Data.Set as S
-import           Grammar.ErrM         (Err)
+import Data.Map (Map)
-import           Grammar.Print        (printTree)
+import qualified Data.Map as M
-import qualified Renamer.RenamerIr            as R
 
+import Renamer.RenamerIr
+import qualified Grammar.Abs as Old
 
-data Cxt = Cxt
+type Rename = StateT Ctx (ExceptT Error Identity)
-  { uniques    :: [(Ident, R.Unique)]
-  , nextUnique :: R.Unique
-  , sig        :: Set Ident
-  }
 
-initCxt :: Cxt
+data Ctx = Ctx { count :: Integer
-initCxt = Cxt
+               , sig :: Set Ident
-  { uniques    = []
+               , env :: Map Ident Integer}
-  , nextUnique = R.Unique 0
-  , sig        = mempty
-  }
 
-newtype Rn a = Rn { runRn :: StateT Cxt Err a }
+run :: Rename a -> Either Error a
-  deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
+run = runIdentity . runExceptT . flip evalStateT initCtx
 
-rename :: Program -> Err R.Program
+initCtx :: Ctx
-rename p = evalStateT (runRn $ renameProgram p) initCxt
+initCtx = Ctx { count = 0
+              , sig = mempty
+              , env = mempty }
 
-renameProgram :: Program -> Rn R.Program
+rename :: Old.Program -> Either Error RProgram
-renameProgram (Program ds (Main e)) = do
+rename = run . renamePrg
-  ds' <- mapM renameDef ds
-  e'  <- renameExp e
-  pure $ R.Program ds' (R.Main e')
 
-renameDef :: Def -> Rn R.Def
+renamePrg :: Old.Program -> Rename RProgram
-renameDef = \case
+renamePrg (Old.Program xs) = do
-  DExp x t _ xs e -> do
+    xs' <- mapM renameBind xs
-    newSig x
+    return $ RProgram xs'
-    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
+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
+    Old.EId i -> do
-findBind x = lookupUnique x >>= \case
+        st <- get
-    Just u  -> pure $ R.Nu u
+        case M.lookup i st.env of
-    Nothing -> gets (Set.member x . sig) >>= \case
+            Just n -> return $ RBound n i
-      False -> throwError ("Unbound variable " ++ printTree x)
+            Nothing -> case S.member i st.sig of
-      True  -> pure $ R.Ni x
+                         True -> return $ RFree i
+                         False -> throwError $ UnboundVar (show i)
 
-newUnique :: Ident -> Rn R.Unique
+    Old.EConst c -> return $ RConst c
-newUnique x = do
-  u <- gets nextUnique
-  modify $ \env -> env { nextUnique = succ u
-                       , uniques = (x, u) : env.uniques
-                       }
-  pure u
 
-newSig :: Ident -> Rn ()
+    Old.EAnn e t -> flip RAnn t <$> renameExp e
-newSig x = modify $ \cxt -> cxt { sig = Set.insert x cxt.sig}
 
-lookupUnique :: Ident -> Rn (Maybe R.Unique)
+    Old.EApp e1 e2 -> RApp <$> renameExp e1 <*> renameExp e2
-lookupUnique x = lookup x <$> gets uniques
 
-fromTree :: Type -> [Type]
+    Old.EAdd e1 e2 -> RAdd <$> renameExp e1 <*> renameExp e2
-fromTree = fromTree' []
 
-fromTree' :: [Type] -> Type -> [Type]
+    -- Convert let-expressions to lambdas
-fromTree' acc = \case
+    Old.ELet i e1 e2 -> renameExp (Old.EApp (Old.EAbs i e2) e1)
-  TFun t t1 -> acc ++ [t] ++ fromTree t1
+
-  other     -> other : acc
+    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

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.Abs (
-import           Grammar.Print
+    Bind (..),
+    Const (..),
+    Ident (..),
+    Program (..),
+    Type (..),
+ )
+import Grammar.Print
 
+data RProgram = RProgram [RBind]
+    deriving (Eq, Show, Read, Ord)
 
-data Program = Program [Def] Main
+data RBind = RBind Ident RExp
-  deriving (Eq, Ord, Show, Read)
+    deriving (Eq, Show, Read, Ord)
 
-newtype Main = Main Exp
+data RExp
-  deriving (Eq, Ord, Show, Read)
+    = 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
+instance Print RBind where
-  deriving (Eq, Ord, Show, Read)
+    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)
+instance Print RExp where
-
+    prt i = \case
-newtype Unique = Unique Int deriving (Enum, Eq, Read, Ord)
+        RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)])
-instance Show Unique where show (Unique i) = "x" ++ show i
+        RFree id -> prPrec i 3 (concatD [prt 0 id])
-
+        RConst n -> prPrec i 3 (concatD [prt 0 n])
-data Exp
+        RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
-    = EId  Name
+        RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
-    | EInt Integer
+        RAbs u id e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e])
-    | 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

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.CInt i) -> return (TMono "Int")
-        (Old.CStr s) -> return (TMono $ UIdent "String")
+        (Old.CStr s) -> return (TMono "String")
 
     Old.EAdd e1 e2 -> do
         let int = TMono "Int"

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
+data TProgram = TProgram [TBind]
-    = EAnn Exp Type
+
-    | EId Ident Type
+data TBind = TBind Ident Type TExp
-    | EConst Const Type
+
-    | EApp Exp Exp Type
+data TExp
-    | EAdd Exp Exp Type
+    = TAnn TExp Type
-    | EAbs Ident Exp Type
+    | TBound Integer Ident Type
-  deriving (Eq, Ord, Show, Read)
+    | TFree Ident Type
+    | TConst Const Type
+    | TApp TExp TExp Type
+    | TAdd TExp TExp Type
+    | TAbs Integer Ident TExp Type
+    deriving (Eq, Ord, Show, Read)

test_program

@@ -1 +1,4 @@
-main = 3;
+letters = let x = 1
+           in let y = 2
+               in let z = 3
+                   in x + y + z