Refactoring and remonadization.

src/Bang/Syntax/ParserMonad.hs

@@ -0,0 +1,176 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Bang.Syntax.ParserMonad(
+         Parser
+       , runParser
+       , addFixities
+       , registerName
+       , unregisterNames
+       , lookupName
+       , parseError
+       , runNextToken
+       )
+ where
+
+import           Bang.Monad(Compiler, err, runPass,
+                            getPassState, overPassState, viewPassState)
+import           Bang.Syntax.AST(Name(..), NameEnvironment(..))
+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)
+import           Control.Lens.TH(makeLenses)
+import           Control.Monad(forM_)
+import           Data.Char(digitToInt, isSpace)
+import           Data.Map.Strict(Map)
+import qualified Data.Map.Strict as Map
+import           Data.Text.Lazy(Text)
+import qualified Data.Text.Lazy as T
+
+data ParserState = ParserState {
+       _psPrecTable    :: Map Text Fixity
+     , _psNameDatabase :: Map (NameEnvironment, Text) Name
+     , _psNextIdent    :: Word
+     , _psOrigin       :: Origin
+     , _psLexerState   :: AlexInput
+     }
+
+makeLenses ''ParserState
+
+type Parser a = Compiler ParserState a
+
+runParser :: Origin -> Text -> Parser a -> Compiler ps a
+runParser origin stream action = runPass pstate action
+ where
+  initInput = AlexInput initialPosition stream
+  pstate    = ParserState Map.empty Map.empty 1 origin initInput
+
+-- -----------------------------------------------------------------------------
+
+addFixities :: Location ->
+               (Word -> Fixity) -> Located Token -> [Located Token] ->
+               Parser ()
+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))
+ where
+  processInteger x =
+    case x of
+      Located _ (IntTok base text) ->
+        return (makeNumeric base text 0)
+      _ ->
+        err (InternalError src "Non-number in fixity?")
+
+  --
+  makeNumeric base text acc =
+    case T.uncons text of
+      Nothing        -> acc
+      Just (x, rest) ->
+        let acc' = (acc * base) + charValue x
+        in makeNumeric base rest acc'
+  --
+  charValue = fromIntegral . digitToInt
+  --
+  tokenName t =
+    case t of
+      Located _ (TypeIdent   x) -> x
+      Located _ (ValIdent    x) -> x
+      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
+
+-- -----------------------------------------------------------------------------
+
+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 = Name loc env (view psNextIdent state) name
+            overPassState (over psNameDatabase (Map.insert key res) .
+                           over psNextIdent (+1))
+            return res
+       Just res | redefOk ->
+         return res
+       Just (Name origLoc _ _ _) ->
+         err (RedefinitionError loc origLoc name)
+
+unregisterNames :: NameEnvironment -> [Name] -> Parser ()
+unregisterNames env names =
+  do db <- viewPassState psNameDatabase
+     let db' = foldr (\ (Name _ _ _ n) m -> Map.delete (env, 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
+ where
+  go state@(AlexInput initPos _) =
+     case alexScan state 0 of
+       AlexEOF ->
+         do orig <- getOrigin
+            parseAction (EOFTok `locatedAt` Location orig initPos initPos)
+       AlexError (AlexInput pos text) ->
+         do let (as, bs) = T.break isSpace text
+                pos'     = advanceWith' pos as
+                input'   = AlexInput pos' bs
+            setLexerState input'
+            orig <- getOrigin
+            parseAction (ErrorTok as `locatedAt` Location orig initPos initPos)
+       AlexSkip input' _ ->
+         go input'
+       AlexToken input' len lexAction ->
+         do setLexerState input'
+            src <- getOrigin
+            table <- getFixities
+            parseAction (lexAction src table len state)
+
+-- -----------------------------------------------------------------------------
+
+getOrigin :: Parser Origin
+getOrigin = viewPassState psOrigin
+
+getLexerState :: Parser AlexInput
+getLexerState = viewPassState psLexerState
+
+setLexerState :: AlexInput -> Parser ()
+setLexerState lst = overPassState (set psLexerState lst)
+
+-- -----------------------------------------------------------------------------
+
+parseError :: Located Token -> Parser a
+parseError t =
+  case t of
+    Located _ EOFTok         -> err UnexpectedEOF
+    Located p (ErrorTok tok) -> err (LexError p tok)
+    Located p tok            -> err (ParseError p tok)
+
+