Renamer done.
It renames bound variables to numbers, converts let to lambda, and removes all variables from binds
This commit is contained in:
sebastianselander
parent
53314551f5
commit
6218efac20
9 changed files with 158 additions and 175 deletions
|
|
@ -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 " ";
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
add x = \y. x+y;
|
||||
|
||||
main = (\z. z+z) ((add 4) 6);
|
||||
|
||||
|
|
|
|||
10
src/Main.hs
10
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1 +1,4 @@
|
|||
main = 3;
|
||||
letters = let x = 1
|
||||
in let y = 2
|
||||
in let z = 3
|
||||
in x + y + z
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue