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

Complete the removal of the name database.

Browse Source
This commit is contained in:
Adam Wick
2016-07-24 15:47:16 -07:00
parent 175b358205
commit 7b5397f661
5 changed files with 22 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
src/Bang/Monad.hs
View File

@@ -9,7 +9,7 @@ module Bang.Monad(
, BangWarning(..)
, runCompiler
, runPass
, getPassState, setPassState, overPassState, viewPassState
, getPassState, setPassState, mapPassState, overPassState, viewPassState
, registerName, registerNewName, genName, genTypeRef, genVarRef
, warn, err, err'
)
@@ -96,11 +96,16 @@ runPass s2 action =
getPassState :: Compiler s s
getPassState = Compiler (\ st -> return (st, view csPassState st))
setPassState :: s -> Compiler s ()
setPassState ps' = Compiler (\ st -> return (set csPassState ps' st, ()))
setPassState :: Lens' s b -> b -> Compiler s ()
setPassState passLens v =
Compiler (\ st -> return (set (csPassState . passLens) v st, ()))
overPassState :: (s -> s) -> Compiler s ()
overPassState f = Compiler (\ st -> return (over csPassState f st, ()))
mapPassState :: (s -> s) -> Compiler s ()
mapPassState f = Compiler (\ st -> return (over csPassState f st, ()))
overPassState :: Lens' s b -> (b -> b) -> Compiler s ()
overPassState passLens f =
Compiler (\ st -> return (over (csPassState . passLens) f st, ()))
viewPassState :: Lens' s b -> Compiler s b
viewPassState l = Compiler (\ st -> return (st, view (csPassState . l) st))

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

@@ -2,7 +2,6 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.Syntax.ParserMonad(
Parser
, NameDatabase
, runParser
, addFixities
, parseError
@@ -10,16 +9,14 @@ module Bang.Syntax.ParserMonad(
)
where
import Bang.AST.Name(Name, NameEnvironment(..))
import Bang.Monad(Compiler, err, runPass,
getPassState, overPassState, viewPassState)
setPassState, overPassState, viewPassState)
import Bang.Syntax.Lexer(AlexReturn(..), AlexInput(..), alexScan)
import Bang.Syntax.Location(Location(..), Located(..),
Origin(..), initialPosition,
advanceWith', locatedAt)
import Bang.Syntax.ParserError(ParserError(..))
import Bang.Syntax.Token(Token(..), Fixity)
import Control.Lens(view, set, over, _1)
import Control.Lens.TH(makeLenses)
import Control.Monad(forM_)
import Data.Char(digitToInt, isSpace)
@@ -28,11 +25,8 @@ import qualified Data.Map.Strict as Map
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
type NameDatabase = Map (NameEnvironment, Text) Name
data ParserState = ParserState {
_psPrecTable :: Map Text Fixity
, _psNameDatabase :: Map (NameEnvironment, Text) Name
, _psOrigin :: Origin
, _psLexerState :: AlexInput
}
@@ -41,12 +35,11 @@ makeLenses ''ParserState
type Parser a = Compiler ParserState a
runParser :: Origin -> Text -> Parser a -> Compiler ps (NameDatabase, a)
runParser origin stream action =
over _1 (view psNameDatabase) `fmap` runPass pstate action
runParser :: Origin -> Text -> Parser a -> Compiler ps a
runParser origin stream action = snd `fmap` runPass pstate action
where
initInput = AlexInput initialPosition stream
pstate = ParserState Map.empty Map.empty origin initInput
pstate = ParserState Map.empty origin initInput
-- -----------------------------------------------------------------------------
@@ -57,9 +50,7 @@ addFixities src fixityBuilder lval names =
do value <- processInteger lval
let fixity = fixityBuilder value
forM_ names $ \ tok ->
do state <- getPassState
name <- forceNameDefined VarEnv src tok state
overPassState (over psPrecTable (Map.insert name fixity))
overPassState psPrecTable (Map.insert (tokenName tok) fixity)
where
processInteger x =
case x of
@@ -85,12 +76,6 @@ addFixities src fixityBuilder lval names =
Located _ (OpIdent _ x) -> x
_ ->
error "Internal error (tokenName in Parser.y)"
--
forceNameDefined env loc token state =
do let name = tokenName token
case Map.lookup (env, name) (view psNameDatabase state) of
Just _ -> return name
Nothing -> err (UnboundVariable loc name)
getFixities :: Parser (Map Text Fixity)
getFixities = viewPassState psPrecTable
@@ -130,7 +115,7 @@ getLexerState :: Parser AlexInput
getLexerState = viewPassState psLexerState
setLexerState :: AlexInput -> Parser ()
setLexerState lst = overPassState (set psLexerState lst)
setLexerState = setPassState psLexerState
-- -----------------------------------------------------------------------------

5
src/Bang/TypeInfer.hs
View File

@@ -5,10 +5,9 @@ module Bang.TypeInfer(runTypeInference)
import Bang.AST(Module)
import Bang.Monad(Compiler)
import Bang.Syntax.ParserMonad(NameDatabase)
runTypeInference :: NameDatabase -> Module -> Compiler ps Module
runTypeInference _ x = return x
runTypeInference :: Module -> Compiler ps Module
runTypeInference x = return x
{- Better version
import Bang.Monad(Compiler, BangError(..), err,

6
src/Main.hs
View File

@@ -11,12 +11,12 @@ import Text.PrettyPrint.Annotated(render)
main :: IO ()
main = getCommand >>= \ cmd ->
case cmd of
Parse o -> do (_, mdl) <- runCompiler cmd o (\ r t -> runParser r t parseModule)
Parse o -> do mdl <- runCompiler cmd o (\ r t -> runParser r t parseModule)
putStrLn (render (ppModule mdl))
TypeCheck o -> do mdl <- runCompiler cmd o (\ r t ->
do (ndb, mdl) <- runParser r t parseModule
do mdl <- runParser r t parseModule
mdl' <- runPostProcessor mdl
runTypeInference ndb mdl')
runTypeInference mdl')
putStrLn (render (ppModule mdl))
Help -> putStrLn helpString
Version -> putStrLn ("Bang tool, version " ++ showVersion version)

2
test.bang
View File

@@ -9,5 +9,5 @@ one = 1
id :: a -> a
id x = x
seq :: a -> a -> a
seq :: a -> b -> b
seq x y = y