From 6218efac20481e794925bbd933eb4daa657b53cb Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 14 Feb 2023 16:44:38 +0100 Subject: [PATCH] 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