From 175b3582053c13316f5bc160a9f68a6fcd6ca6f1 Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Fri, 22 Jul 2016 22:41:49 -0700 Subject: [PATCH] Get name linking right again, through post-processing. --- src/Bang/AST/Expression.hs | 2 +- src/Bang/Monad.hs | 27 +++++--- src/Bang/Syntax/Parser.y | 106 +++++++++++------------------ src/Bang/Syntax/ParserMonad.hs | 41 +---------- src/Bang/Syntax/PostProcess.hs | 120 +++++++++++++++++++++++++++++---- test.bang | 3 + 6 files changed, 172 insertions(+), 127 deletions(-) diff --git a/src/Bang/AST/Expression.hs b/src/Bang/AST/Expression.hs index e1f0a76..fd2dc58 100644 --- a/src/Bang/AST/Expression.hs +++ b/src/Bang/AST/Expression.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} module Bang.AST.Expression - ( Expression + ( Expression(..) , ppExpression -- * Constant Expressions , ConstantExpression diff --git a/src/Bang/Monad.hs b/src/Bang/Monad.hs index 5a3449a..a8b9343 100644 --- a/src/Bang/Monad.hs +++ b/src/Bang/Monad.hs @@ -10,13 +10,13 @@ module Bang.Monad( , runCompiler , runPass , getPassState, setPassState, overPassState, viewPassState - , registerNewName, genName, genTypeRef, genVarRef - , warn, err + , registerName, registerNewName, genName, genTypeRef, genVarRef + , warn, err, err' ) where import Bang.AST.Expression(Expression, mkRefExp) -import Bang.AST.Name(NameEnvironment(..), Name, mkName) +import Bang.AST.Name(NameEnvironment(..), Name, mkName, nameIndex) import Bang.AST.Type(Kind(..), Type, mkTypeRef) import Bang.CommandLine(BangCommand, CommandsWithInputFile(..)) import Bang.Error(exit) @@ -26,7 +26,7 @@ import Bang.Utils.Pretty(BangDoc) import Control.Exception(tryJust) import Control.Lens(Lens', over, set, view) import Control.Lens.TH(makeLenses) -import Control.Monad(guard) +import Control.Monad(guard, when) import Data.Text.Lazy(Text, pack) import qualified Data.Text.Lazy.IO as T import System.Exit(ExitCode(..), exitWith) @@ -107,6 +107,12 @@ viewPassState l = Compiler (\ st -> return (st, view (csPassState . l) st)) -- ----------------------------------------------------------------------------- +registerName :: Name -> Compiler s Name +registerName name = + Compiler (\ st -> + do let current = view csNextIdent st + return (over csNextIdent (+1) st, set nameIndex current name)) + registerNewName :: NameEnvironment -> Text -> Compiler s Name registerNewName env name = Compiler (\ st -> @@ -141,19 +147,22 @@ instance BangWarning w => BangError (WErrorWarning w) where warn :: BangWarning w => w -> Compiler s () warn w = Compiler (\ st -> if view csPromoteWarnings st - then runError (WErrorWarning w) + then runError (WErrorWarning w) False >> return (st, ()) else runWarning w >> return (st, ())) err :: BangError w => w -> Compiler s a -err w = Compiler (\ _ -> runError w) +err w = Compiler (\ _ -> runError w True >> undefined) + +err' :: BangError e => e -> Compiler s () +err' e = Compiler (\ st -> runError e False >> return (st, ())) runWarning :: BangWarning w => w -> IO () runWarning = undefined -runError :: BangError w => w -> IO a -runError e = +runError :: BangError w => w -> Bool -> IO () +runError e die = do putStrLn (go (ppError e)) - exitWith (ExitFailure 1) + when die $ exitWith (ExitFailure 1) where go (Nothing, doc) = render doc go (Just a, doc) = render (ppLocation a $+$ nest 3 doc) diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y index 0798e77..2bc4127 100644 --- a/src/Bang/Syntax/Parser.y +++ b/src/Bang/Syntax/Parser.y @@ -11,15 +11,13 @@ module Bang.Syntax.Parser( where import Bang.Monad(err) -import Bang.AST(Name, Module, NameEnvironment(..), mkModule, emptyExpression) +import Bang.AST(Name, Module, NameEnvironment(..), mkModule, mkName, emptyExpression) import Bang.AST.Declaration(Declaration, mkTypeDecl, mkValueDecl) import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp) import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp, mkPrimType) import Bang.Syntax.Location(Located(..), Origin, Position) import Bang.Syntax.ParserError(ParserError(..)) -import Bang.Syntax.ParserMonad(Parser, addFixities, registerName, - unregisterNames, lookupName, parseError, - runNextToken, runParser) +import Bang.Syntax.ParserMonad(Parser, addFixities, parseError, runNextToken, runParser) import Bang.Syntax.Token(Token(..), Fixity(..)) import Control.Monad(forM) import Data.List(union) @@ -119,8 +117,7 @@ top_module :: { Module } : 'module' TypeIdent listopt(Declaration) {% do let Located src (TypeIdent rawName) = $2 - name <- registerName False src ModuleEnv rawName - return (mkModule name [$3]) } + return (mkModule (mkName rawName ModuleEnv src 0) [$3]) } Declaration :: { Maybe Declaration } : ValueDeclaration { Just $1 } @@ -128,28 +125,21 @@ Declaration :: { Maybe Declaration } | TypeDeclaration { Just $1 } ValueDeclaration :: { Declaration } - : ValueDeclLHS Expression - {% - do let (builder, argNames) = $1 - unregisterNames VarEnv argNames - return (builder $2) - } - -ValueDeclLHS :: { (Expression -> Declaration, [Name]) } - : list1(ValIdent) '=' + : list1(ValIdent) '=' Expression {% case $1 of [] -> err (InternalError $2 "ValDeclLHS") [Located src (ValIdent rawName)] -> - do name <- registerName True src VarEnv rawName - return (mkValueDecl name src Nothing, [name]) + do let name = mkName rawName VarEnv src 0 + return (mkValueDecl name src Nothing $3) ((Located src (ValIdent rawName)) : args) -> - do name <- registerName True src VarEnv rawName - argNames <- forM args $ \ (Located asrc (ValIdent argName)) -> - registerName True asrc VarEnv argName - let builder = mkValueDecl name src Nothing . mkLambdaExp $2 argNames - return (builder, argNames) + do let name = mkName rawName VarEnv src 0 + argNames = map (\ (Located arsrc (ValIdent argName)) -> + mkName argName VarEnv arsrc 0) + args + return (mkValueDecl name src Nothing + (mkLambdaExp $2 argNames $3)) } FixityDeclaration :: { () } @@ -164,50 +154,38 @@ TypeDeclaration :: { Declaration } : ValIdent '::' Type {% do let Located src (ValIdent rawName) = $1 - name <- registerName True src VarEnv rawName + name = mkName rawName VarEnv src 0 return (mkValueDecl name src (Just $3) emptyExpression) } | 'type' TypeIdent '=' Type {% do let Located src (TypeIdent rawName) = $2 - name <- registerName True src TypeEnv rawName + name = mkName rawName TypeEnv src 0 return (mkTypeDecl name src $4) } | 'primitive' 'type' TypeIdent '=' String {% do let Located nsrc (TypeIdent rawName) = $3 Located tsrc (StringTok rawText) = $5 - name <- registerName False nsrc TypeEnv rawName + name = mkName rawName TypeEnv nsrc 0 return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) } -- ----------------------------------------------------------------------------- Type :: { Type } - : RawType {% - do let (result, names) = $1 - case names of - [] -> return result - xs -> - do unregisterNames TypeEnv xs - return result - } + : RawType { $1 } -RawType :: { (Type, [Name]) } - : RawType '->' BaseType {% - do let (p1, names1) = $1 - (p2, names2) = $3 - return (mkFunType $2 [p1] p2, union names1 names2) - } - | BaseType { $1 } +RawType :: { Type } + : RawType '->' BaseType { mkFunType $2 [$1] $3 } + | BaseType { $1 } -BaseType :: { (Type, [Name]) } +BaseType :: { Type } : TypeIdent {% - do let Located src (TypeIdent rawName) = $1 - name <- lookupName src TypeEnv rawName - return (mkTypeRef src Unknown name, []) } + let Located src (TypeIdent rawName) = $1 + name = mkName rawName TypeEnv src 0 + in return (mkTypeRef src Unknown name) } | ValIdent {% - do let Located src (ValIdent rawName) = $1 - name <- registerName True src TypeEnv rawName - return (mkTypeRef src Unknown name, [name]) - } + let Located src (ValIdent rawName) = $1 + name = mkName rawName TypeEnv src 0 + in return (mkTypeRef src Unknown name) } -- ----------------------------------------------------------------------------- @@ -216,25 +194,21 @@ Expression :: { Expression } BaseExpression :: { Expression } : OpIdent {% - do let Located src (OpIdent _ rawName) = $1 - name <- lookupName src VarEnv rawName - return (mkRefExp src name) } + let Located src (OpIdent _ rawName) = $1 + name = mkName rawName VarEnv src 0 + in return (mkRefExp src name) } | ValIdent {% - do let Located src (ValIdent rawName) = $1 - name <- lookupName src VarEnv rawName - return (mkRefExp src name) } - | Integer {% - do let Located src (IntTok base val) = $1 - return (mkConstExp src (ConstantInt base val)) } - | String {% - do let Located src (StringTok val) = $1 - return (mkConstExp src (ConstantString val)) } - | Float {% - do let Located src (FloatTok val) = $1 - return (mkConstExp src (ConstantFloat val)) } - | Char {% - do let Located src (CharTok val) = $1 - return (mkConstExp src (ConstantChar val)) } + let Located src (ValIdent rawName) = $1 + name = mkName rawName VarEnv src 0 + in return (mkRefExp src name) } + | Integer { let Located src (IntTok base val) = $1 + in mkConstExp src (ConstantInt base val) } + | String { let Located src (StringTok val) = $1 + in mkConstExp src (ConstantString val) } + | Float { let Located src (FloatTok val) = $1 + in mkConstExp src (ConstantFloat val) } + | Char { let Located src (CharTok val) = $1 + in mkConstExp src (ConstantChar val) } -- ----------------------------------------------------------------------------- diff --git a/src/Bang/Syntax/ParserMonad.hs b/src/Bang/Syntax/ParserMonad.hs index b54ee35..50362bf 100644 --- a/src/Bang/Syntax/ParserMonad.hs +++ b/src/Bang/Syntax/ParserMonad.hs @@ -5,16 +5,12 @@ module Bang.Syntax.ParserMonad( , NameDatabase , runParser , addFixities - , registerName - , unregisterNames - , lookupName , parseError , runNextToken ) where -import Bang.AST.Name(Name, NameEnvironment(..), mkName, - nameLocation, nameText) +import Bang.AST.Name(Name, NameEnvironment(..)) import Bang.Monad(Compiler, err, runPass, getPassState, overPassState, viewPassState) import Bang.Syntax.Lexer(AlexReturn(..), AlexInput(..), alexScan) @@ -37,7 +33,6 @@ type NameDatabase = Map (NameEnvironment, Text) Name data ParserState = ParserState { _psPrecTable :: Map Text Fixity , _psNameDatabase :: Map (NameEnvironment, Text) Name - , _psNextIdent :: Word , _psOrigin :: Origin , _psLexerState :: AlexInput } @@ -51,7 +46,7 @@ runParser origin stream action = over _1 (view psNameDatabase) `fmap` runPass pstate action where initInput = AlexInput initialPosition stream - pstate = ParserState Map.empty Map.empty 1 origin initInput + pstate = ParserState Map.empty Map.empty origin initInput -- ----------------------------------------------------------------------------- @@ -102,38 +97,6 @@ getFixities = viewPassState psPrecTable -- ----------------------------------------------------------------------------- -registerName :: Bool -> Location -> NameEnvironment -> Text -> Parser Name -registerName redefOk loc env name = - do state <- getPassState - let key = (env, name) - case Map.lookup key (view psNameDatabase state) of - Nothing -> - do let res = mkName name env loc (view psNextIdent state) - overPassState (over psNameDatabase (Map.insert key res) . - over psNextIdent (+1)) - return res - Just res | redefOk -> - return res - Just name' -> - err (RedefinitionError loc (view nameLocation name') name) - -unregisterNames :: NameEnvironment -> [Name] -> Parser () -unregisterNames env names = - do db <- viewPassState psNameDatabase - let db' = foldr (\ n m -> Map.delete (env, view nameText n) m) db names - overPassState (set psNameDatabase db') - -lookupName :: Location -> NameEnvironment -> Text -> Parser Name -lookupName loc env name = - do state <- getPassState - case Map.lookup (env, name) (view psNameDatabase state) of - Nothing -> - err (UnboundVariable loc name) - Just realName -> - return realName - --- ----------------------------------------------------------------------------- - runNextToken :: (Located Token -> Parser a) -> Parser a runNextToken parseAction = go =<< getLexerState diff --git a/src/Bang/Syntax/PostProcess.hs b/src/Bang/Syntax/PostProcess.hs index 8a4683d..aa6909a 100644 --- a/src/Bang/Syntax/PostProcess.hs +++ b/src/Bang/Syntax/PostProcess.hs @@ -1,28 +1,36 @@ +{-# LANGUAGE RankNTypes #-} module Bang.Syntax.PostProcess( runPostProcessor ) where -import Bang.AST(Name, Module, moduleDeclarations, ppName) +import Bang.AST(Name, Module, moduleDeclarations, ppName, + nameText, nameLocation, nameEnvironment) import Bang.AST.Declaration(Declaration(..), declName, - ValueDeclaration, - vdName, vdLocation, vdDeclaredType, - vdValue) -import Bang.AST.Expression(isEmptyExpression) -import Bang.AST.Type(Type) -import Bang.Monad(Compiler, BangError(..), err) + tdName, tdType, + ValueDeclaration, vdName, vdLocation, + vdDeclaredType, vdValue) +import Bang.AST.Expression(Expression(..), isEmptyExpression, refName, + lambdaArgumentNames, lambdaBody, + isEmptyExpression) +import Bang.AST.Type(Type(..), rtName, ftArgumentTypes, ftResultType, + taLeftType, taRightType) +import Bang.Monad(Compiler, BangError(..), err, err', registerName) import Bang.Syntax.Location(Location, ppLocation) import Bang.Utils.FreeVars(CanHaveFreeVars(..)) -import Bang.Utils.Pretty(BangDoc) -import Control.Lens(view, set) +import Bang.Utils.Pretty(BangDoc, text') +import Control.Lens(Lens', view, set) import Control.Monad(foldM) +import Data.Char(isLower) import Data.Graph(SCC(..)) import Data.Graph.SCC(stronglyConnComp) import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map -import Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest) +import Data.Text.Lazy(uncons) +import Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest, quotes) data PostProcessError = InternalError Name + | UndefinedVariable Name | RedefinitionError Name Location Location | TypeDeclWithoutValue Name Location deriving (Show) @@ -35,6 +43,8 @@ prettyError e = case e of InternalError n -> (Nothing, text "Serious post-processing error w.r.t. " <+> ppName n) + UndefinedVariable n -> + (Just (view nameLocation n), text "Undefined variable " <+> quotes (text' (view nameText n))) RedefinitionError n l1 l2 -> (Just l1, text "Name" <+> ppName n <+> text "redefined." $+$ nest 2 (text "original definiton at " <+> ppLocation l2)) @@ -44,13 +54,99 @@ prettyError e = runPostProcessor :: Module -> Compiler ps Module runPostProcessor mdl = - do let decls = concat (view moduleDeclarations mdl) + do let baseDecls = concat (view moduleDeclarations mdl) + decls <- linkNames baseDecls declTable <- makeDeclarationTable decls - decls' <- combineTypeValueDeclarations declTable decls + decls' <- combineTypeValueDeclarations declTable decls return (set moduleDeclarations (orderDecls decls') mdl) -- ----------------------------------------------------------------------------- +linkNames :: [Declaration] -> Compiler ps [Declaration] +linkNames decls = + do declaredNames <- foldM addNewNames Map.empty (map (view declName) decls) + mapM (linkDecls declaredNames) decls + where + addNewNames t n = + do n' <- registerName n + let key = (view nameText n, view nameEnvironment n) + return (Map.insert key n' t) + -- + replaceName nameMap name = + do let key = (view nameText name, view nameEnvironment name) + case Map.lookup key nameMap of + Nothing -> err' (UndefinedVariable name) >> return name + Just name' -> return name' + -- + addOrReplaceName nameMap name = + do let key = (view nameText name, view nameEnvironment name) + case Map.lookup key nameMap of + Nothing | couldBeTypeVariable name -> + do name' <- registerName name + return (name', Map.insert key name' nameMap) + Nothing -> + err' (UndefinedVariable name) >> return (name, nameMap) + Just name' -> + return (name', nameMap) + -- + couldBeTypeVariable n = + case uncons (view nameText n) of + Nothing -> + error "Empty variable name?" + Just (x,_) -> + isLower x + -- + linkDecls nameMap (DeclType td) = + do td' <- overM tdType (linkType' nameMap) td + td'' <- overM tdName (replaceName nameMap) td' + return (DeclType td'') + linkDecls nameMap (DeclVal vd) = + do vd' <- overM vdDeclaredType (traverse (linkType' nameMap)) vd + vd'' <- overM vdValue (linkExpr nameMap) vd' + vd''' <- overM vdName (replaceName nameMap) vd'' + return (DeclVal vd''') + -- + linkType' nm t = fst `fmap` linkType nm t + -- + linkType nameMap x@(TypeUnit _) = return (x, nameMap) + linkType nameMap x@(TypePrim _) = return (x, nameMap) + linkType nameMap (TypeRef t) = + do (name, nameMap') <- addOrReplaceName nameMap (view rtName t) + let t' = set rtName name t + return (TypeRef t', nameMap') + linkType nameMap (TypeFun t) = + do (argTypes, nameMap') <- foldM linkTypes ([], nameMap) (view ftArgumentTypes t) + (resType, nameMap'') <- linkType nameMap' (view ftResultType t) + return (TypeFun (set ftArgumentTypes argTypes $ + set ftResultType resType t), + nameMap'') + linkType nameMap (TypeApp t) = + do (lt, nameMap') <- linkType nameMap (view taLeftType t) + (rt, nameMap'') <- linkType nameMap' (view taRightType t) + return (TypeApp (set taLeftType lt (set taRightType rt t)), nameMap'') + -- + linkTypes (acc, nameMap) argType = + do (argType', nameMap') <- linkType nameMap argType + return (acc ++ [argType'], nameMap') + -- + linkExpr _ x | isEmptyExpression x = return x + linkExpr _ x@(ConstExp _) = return x + linkExpr nameMap (RefExp e) = + RefExp `fmap` overM refName (replaceName nameMap) e + linkExpr nameMap (LambdaExp e) = + do let names = view lambdaArgumentNames e + nameMap' <- foldM addNewNames nameMap names + e' <- overM lambdaArgumentNames (mapM (replaceName nameMap')) e + e'' <- overM lambdaBody (linkExpr nameMap') e' + return (LambdaExp e'') + +overM :: Monad m => Lens' s a -> (a -> m a) -> s -> m s +overM field action input = + do newval <- action (view field input) + return (set field newval input) + +-- ----------------------------------------------------------------------------- + type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration) makeDeclarationTable :: [Declaration] -> Compiler ps DeclarationTable diff --git a/test.bang b/test.bang index 9fe28dc..2a6181a 100644 --- a/test.bang +++ b/test.bang @@ -8,3 +8,6 @@ one = 1 id :: a -> a id x = x + +seq :: a -> a -> a +seq x y = y