177 lines
5.9 KiB
Haskell
177 lines
5.9 KiB
Haskell
{-# 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)
|
|
|
|
|