module FrontEnd.ParseMonad(
P, ParseResult(..), atSrcLoc, LexContext(..),
ParseMode(..),
parseModeOptions,
runParserWithMode, runParser,
getSrcLoc, setSrcLoc, pushCurrentContext, popContext,thenP,returnP,
Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,
alternative, checkBOL, setBOL, startToken, getOffside,
pushContextL, popContextL, lexParseMode,
pullCtxtFlag, setFlagDo
) where
import Control.Monad
import Data.Functor
import Data.Monoid
import qualified Control.Applicative as A
import qualified Data.Set as Set
import FrontEnd.SrcLoc
import FrontEnd.Warning
import Options
import PackedString
import qualified FlagOpts as FO
data ParseResult a
= ParseOk a
| ParseFailed SrcLoc String
deriving Show
data ParseStatus a = Ok ParseState a | Failed SrcLoc String
deriving Show
data LexContext = NoLayout | Layout Int
deriving (Eq,Ord,Show)
data ParseState = ParseState {
psLexContext :: [LexContext],
psWarnings :: [Warning],
psInDo :: !Bool,
psForceClose :: !Bool
} deriving(Show)
instance Functor ParseResult where
fmap f (ParseOk x) = ParseOk (f x)
fmap _ (ParseFailed x y) = ParseFailed x y
instance A.Applicative ParseResult where
pure = ParseOk
ParseOk f <*> x = f <$> x
ParseFailed loc msg <*> _ = ParseFailed loc msg
instance Monad ParseResult where
return = A.pure
ParseOk x >>= f = f x
ParseFailed loc msg >>= _ = ParseFailed loc msg
instance Monoid m => Monoid (ParseResult m) where
mempty = ParseOk mempty
ParseOk x `mappend` ParseOk y = ParseOk $ x `mappend` y
ParseOk x `mappend` err = err
err `mappend` _ = err
indentOfParseState :: ParseState -> Int
indentOfParseState ParseState { psLexContext = (Layout n:_) } = n
indentOfParseState _ = 0
emptyParseState = ParseState { psLexContext = [], psWarnings = [], psForceClose = False, psInDo = False }
data ParseMode = ParseMode {
parseFilename :: FilePath,
parseOpt :: Opt,
parseFFI :: Bool,
parseUnboxedValues :: Bool,
parseUnboxedTuples :: Bool
}
defaultParseMode :: ParseMode
defaultParseMode = ParseMode {
parseFilename = "<unknown>",
parseOpt = options,
parseFFI = False,
parseUnboxedValues = False,
parseUnboxedTuples = False
}
parseModeOptions options = defaultParseMode {
parseUnboxedTuples = FO.UnboxedTuples `Set.member` optFOptsSet options || FO.UnboxedValues `Set.member` optFOptsSet options,
parseUnboxedValues = FO.UnboxedValues `Set.member` optFOptsSet options,
parseFFI = FO.Ffi `Set.member` optFOptsSet options,
parseOpt = options
}
newtype P a = P { runP ::
String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
}
runParserWithMode :: ParseMode -> P a -> String -> ([Warning],ParseResult a)
runParserWithMode mode (P m) s = case m s 0 1 start emptyParseState mode of
Ok s a -> (psWarnings s,ParseOk a)
Failed loc msg -> ([],ParseFailed loc msg)
where start = SrcLoc {
srcLocFileName = packString $ parseFilename mode,
srcLocLine = 1,
srcLocColumn = 1
}
runParser :: P a -> String -> ([Warning],ParseResult a)
runParser = runParserWithMode defaultParseMode
instance Monad P where
return a = P $ \_i _x _y _l s _m -> Ok s a
P m >>= k = P $ \i x y l s mode ->
case m i x y l s mode of
Failed loc msg -> Failed loc msg
Ok s' a -> runP (k a) i x y l s' mode
fail s = P $ \_r _col _line loc _stk _m -> Failed loc s
returnP :: a -> P a
returnP = return
thenP :: P a -> (a -> P b) -> P b
thenP = (>>=)
atSrcLoc :: P a -> SrcLoc -> P a
P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc
instance MonadSrcLoc P where
getSrcLoc = P $ \_i _x _y l s _m -> Ok s l
instance MonadWarn P where
addWarning w = P $ \_i _x _y _l s _m -> Ok s { psWarnings = w:psWarnings s } ()
pushCurrentContext :: P ()
pushCurrentContext = do
lc <- getSrcLoc
indent <- currentIndent
let loc = srcLocColumn lc
dob <- pullDoStatus
when (if dob then loc < indent else loc <= indent) pushCtxtFlag
pushContext (Layout loc)
currentIndent :: P Int
currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk)
pushContext :: LexContext -> P ()
pushContext ctxt =
P $ \_i _x _y _l s _m -> Ok s { psLexContext = ctxt:psLexContext s } ()
popContext :: P ()
popContext = P $ \_i _x _y _l stk _m ->
case psLexContext stk of
(_:s) ->
Ok stk { psLexContext = s } ()
[] -> error "Internal error: empty context in popContext"
pullCtxtFlag :: Lex a Bool
pullCtxtFlag = Lex $ \cont -> P $ \r x y loc s ->
runP (cont $ psForceClose s) r x y loc s { psForceClose = False }
pushCtxtFlag :: P ()
pushCtxtFlag =
P $ \_i _x _y _l s _m -> case psForceClose s of
False -> Ok s { psForceClose = True } ()
_ -> error "Internal error: context flag already pushed"
pullDoStatus :: P Bool
pullDoStatus = P $ \_i _x _y _l s _m -> Ok s { psInDo = False } (psInDo s)
setFlagDo :: Lex a ()
setFlagDo = Lex $ \cont -> P $ \r x y loc s ->
runP (cont ()) r x y loc s { psInDo = True }
newtype Lex r a = Lex { runL :: (a -> P r) -> P r }
instance Monad (Lex r) where
return a = Lex $ \k -> k a
Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)
Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)
fail s = Lex $ \_ -> fail s
instance MonadWarn (Lex r) where
addWarning w = Lex $ \k -> addWarning w >> k ()
instance MonadSrcLoc (Lex r) where
getSrcLoc = Lex $ \k -> getSrcLoc >>= k
getInput :: Lex r String
getInput = Lex $ \cont -> P $ \r -> runP (cont r) r
discard :: Int -> Lex r ()
discard n = Lex $ \cont -> P $ \r x -> runP (cont ()) (drop n r) (x+n)
setSrcLoc :: SrcLoc -> Lex a ()
setSrcLoc srcloc = Lex $ \cont -> P $ \r x l _ -> runP (cont ()) r x l srcloc
lexNewline :: Lex a ()
lexNewline = Lex $ \cont -> P $ \(_:r) _x y loc -> runP (cont ()) r 1 (y+1) loc { srcLocLine = srcLocLine loc + 1 }
lexTab :: Lex a ()
lexTab = Lex $ \cont -> P $ \(_:r) x -> runP (cont ()) r (nextTab x)
nextTab :: Int -> Int
nextTab x = x + (tAB_LENGTH (x1) `mod` tAB_LENGTH)
tAB_LENGTH :: Int
tAB_LENGTH = 8
lexParseMode :: Lex a ParseMode
lexParseMode = Lex $ \cont -> P $ \r x y z s m -> runP (cont m) r x y z s m
lexWhile :: (Char -> Bool) -> Lex a String
lexWhile p = Lex $ \cont -> P $ \r x ->
let (cs,rest) = span p r in
runP (cont cs) rest (x + length cs)
alternative :: Lex a v -> Lex a (Lex a v)
alternative (Lex v) = Lex $ \cont -> P $ \r x y ->
runP (cont (Lex $ \cont' -> P $ \_r _x _y ->
runP (v cont') r x y)) r x y
checkBOL :: Lex a Bool
checkBOL = Lex $ \cont -> P $ \r x y loc ->
if x == 0 then runP (cont True) r (srcLocColumn loc) y loc
else runP (cont False) r x y loc
setBOL :: Lex a ()
setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0
startToken :: Lex a ()
startToken = Lex $ \cont -> P $ \s x y oloc stk mode ->
let loc = oloc { srcLocColumn = x } in
runP (cont ()) s x y loc stk mode
getOffside :: Lex a Ordering
getOffside = Lex $ \cont -> P $ \r x y loc stk ->
runP (cont (compare x (indentOfParseState stk))) r x y loc stk
pushContextL :: LexContext -> Lex a ()
pushContextL ctxt = Lex $ \cont -> P $ \r x y loc stk ->
runP (cont ()) r x y loc stk { psLexContext = ctxt:psLexContext stk }
popContextL :: String -> Lex a ()
popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case psLexContext stk of
(_:ctxt) -> runP (cont ()) r x y loc stk { psLexContext = ctxt }
[] -> error ("Internal error: empty context in " ++ fn)