Complete the removal of the name database.

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 :: Lens' s b -> b -> Compiler s ()
-setPassState ps' = Compiler (\ st -> return (set csPassState ps' st, ()))
+setPassState passLens v =
+  Compiler (\ st -> return (set (csPassState . passLens) v st, ()))
 
-overPassState :: (s -> s) -> Compiler s ()
+mapPassState :: (s -> s) -> Compiler s ()
-overPassState f = Compiler (\ st -> return (over csPassState f st, ()))
+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))

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 -> Text -> Parser a -> Compiler ps a
-runParser origin stream action =
+runParser origin stream action = snd `fmap` runPass pstate action
-  over _1 (view psNameDatabase) `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
+       overPassState psPrecTable (Map.insert (tokenName tok) fixity)
-          name <- forceNameDefined VarEnv src tok state
-          overPassState (over psPrecTable (Map.insert name 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
 
 -- -----------------------------------------------------------------------------
 

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 :: Module -> Compiler ps Module
-runTypeInference _ x = return x
+runTypeInference x = return x
 
 {- Better version 
 import           Bang.Monad(Compiler, BangError(..), err,

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)

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