acw/bang
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Get name linking right again, through post-processing.

Browse Source
This commit is contained in:
Adam Wick
2016-07-22 22:41:49 -07:00
parent 6649b190ac
commit 175b358205
6 changed files with 172 additions and 127 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Bang/AST/Expression.hs
View File

@@ -1,6 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Expression
( Expression
( Expression(..)
, ppExpression
-- * Constant Expressions
, ConstantExpression

27
src/Bang/Monad.hs
View File

@@ -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)

104
src/Bang/Syntax/Parser.y
View File

@@ -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)
}
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) }
-- -----------------------------------------------------------------------------

41
src/Bang/Syntax/ParserMonad.hs
View File

@@ -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

118
src/Bang/Syntax/PostProcess.hs
View File

@@ -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
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

3
test.bang
View File

@@ -8,3 +8,6 @@ one = 1
id :: a -> a
id x = x
seq :: a -> a -> a
seq x y = y