diff --git a/src/Bang/Monad.hs b/src/Bang/Monad.hs index a8b9343..a08675e 100644 --- a/src/Bang/Monad.hs +++ b/src/Bang/Monad.hs @@ -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)) diff --git a/src/Bang/Syntax/ParserMonad.hs b/src/Bang/Syntax/ParserMonad.hs index 50362bf..e8647be 100644 --- a/src/Bang/Syntax/ParserMonad.hs +++ b/src/Bang/Syntax/ParserMonad.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/src/Bang/TypeInfer.hs b/src/Bang/TypeInfer.hs index fa433c6..03fb69d 100644 --- a/src/Bang/TypeInfer.hs +++ b/src/Bang/TypeInfer.hs @@ -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, diff --git a/src/Main.hs b/src/Main.hs index f5b67bc..42b91ad 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/test.bang b/test.bang index 2a6181a..c097ec0 100644 --- a/test.bang +++ b/test.bang @@ -9,5 +9,5 @@ one = 1 id :: a -> a id x = x -seq :: a -> a -> a +seq :: a -> b -> b seq x y = y