module Language.Haskell.Exts.ParseMonad(
P, ParseResult(..), atSrcLoc, LexContext(..),
ParseMode(..), defaultParseMode,
runParserWithMode, runParser,
getSrcLoc, pushCurrentContext, popContext,
getExtensions,
Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,
alternative, checkBOL, setBOL, startToken, getOffside,
pushContextL, popContextL, getExtensionsL,
ExtContext(..),
pushExtContextL, popExtContextL, getExtContext,
pushLexState, pullLexState,
getModuleName
) where
import Language.Haskell.Exts.Syntax(SrcLoc(..))
import Language.Haskell.Exts.Extension (Extension)
import Language.Haskell.Exts.Fixity (Fixity, preludeFixities)
import Data.List ( intersperse )
import Control.Applicative
import Control.Monad (when)
import Data.Monoid
data ParseResult a
= ParseOk { unParseOk :: a }
| ParseFailed SrcLoc String
deriving Show
instance Functor ParseResult where
fmap f (ParseOk x) = ParseOk $ f x
fmap f (ParseFailed loc msg) = ParseFailed loc msg
instance Applicative ParseResult where
pure = ParseOk
ParseOk f <*> x = f <$> x
ParseFailed loc msg <*> _ = ParseFailed loc msg
instance Monad ParseResult where
return = ParseOk
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
data ParseStatus a = Ok ParseState a | Failed SrcLoc String
deriving Show
data LexContext = NoLayout | Layout Int
deriving (Eq,Ord,Show)
data ExtContext = CodeCtxt | HarpCtxt | TagCtxt | ChildCtxt
| CloseTagCtxt | CodeTagCtxt
deriving (Eq,Ord,Show)
type LexState = Bool
type ParseState = ([LexContext],[ExtContext],LexState)
indentOfParseState :: ParseState -> Int
indentOfParseState (Layout n:_,_,_) = n
indentOfParseState _ = 0
data ParseMode = ParseMode {
parseFilename :: String,
extensions :: [Extension],
ignoreLanguagePragmas :: Bool,
fixities :: [Fixity]
}
defaultParseMode :: ParseMode
defaultParseMode = ParseMode {
parseFilename = "<unknown>.hs",
extensions = [],
ignoreLanguagePragmas = False,
fixities = preludeFixities
}
newtype P a = P { runP ::
String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
}
runParserWithMode :: ParseMode -> P a -> String -> ParseResult a
runParserWithMode mode (P m) s = case m s 0 1 start ([],[],False) mode of
Ok _ a -> ParseOk a
Failed loc msg -> ParseFailed loc msg
where start = SrcLoc {
srcFilename = parseFilename mode,
srcLine = 1,
srcColumn = 1
}
runParser :: P a -> String -> 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
atSrcLoc :: P a -> SrcLoc -> P a
P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc
getSrcLoc :: P SrcLoc
getSrcLoc = P $ \_i _x _y l s _m -> Ok s l
getModuleName :: P String
getModuleName = P $ \_i _x _y _l s m ->
let fn = parseFilename m
mn = concat $ intersperse "." $ splitPath fn
splitPath :: String -> [String]
splitPath "" = []
splitPath str = let (l,str') = break ('\\'==) str
in case str' of
[] -> [removeSuffix l]
(_:str'') -> l : splitPath str''
removeSuffix l = reverse $ tail $ dropWhile ('.'/=) $ reverse l
in Ok s mn
pushCurrentContext :: P ()
pushCurrentContext = do
loc <- getSrcLoc
indent <- currentIndent
when (srcColumn loc <= indent) $ pushLexState
pushContext (Layout (srcColumn 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, e, p) _m -> Ok (ctxt:s, e, p) ()
popContext :: P ()
popContext = P $ \_i _x _y _l stk _m ->
case stk of
(_:s, e, p) ->
Ok (s, e, p) ()
([],_,_) -> error "Internal error: empty context in popContext"
pushExtContext :: ExtContext -> P ()
pushExtContext ctxt = P $ \_i _x _y _l (s, e, p) _m -> Ok (s, ctxt:e, p) ()
popExtContext :: P ()
popExtContext = P $ \_i _x _y _l (s, e, p) _m ->
case e of
(_:e') ->
Ok (s, e', p) ()
[] -> error "Internal error: empty context in popExtContext"
getExtensions :: P [Extension]
getExtensions = P $ \_i _x _y _l s m ->
Ok s $ extensions m
pushLexState :: P ()
pushLexState =
P $ \_i _x _y _l (s, e, p) _m -> case p of
False -> Ok (s, e, True) ()
_ -> error "Internal error: Lex state already pushed"
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
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)
lexNewline :: Lex a ()
lexNewline = Lex $ \cont -> P $ \(_:r) _x y -> runP (cont ()) r 1 (y+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 :: Int
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 (srcColumn 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 _ stk mode ->
let loc = SrcLoc {
srcFilename = parseFilename mode,
srcLine = y,
srcColumn = 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, e, pst) ->
runP (cont ()) r x y loc (ctxt:stk, e, pst)
popContextL :: String -> Lex a ()
popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of
(_:ctxt, e, pst) -> runP (cont ()) r x y loc (ctxt, e, pst)
([], _, _) -> error ("Internal error: empty context in " ++ fn)
pullLexState :: Lex a LexState
pullLexState = Lex $ \cont -> P $ \r x y loc (ct, e, pst) ->
runP (cont pst) r x y loc (ct, e, False)
getExtContext :: Lex a (Maybe ExtContext)
getExtContext = Lex $ \cont -> P $ \r x y loc stk@(_, e, _) ->
let me = case e of
[] -> Nothing
(c:_) -> Just c
in runP (cont me) r x y loc stk
pushExtContextL :: ExtContext -> Lex a ()
pushExtContextL ec = Lex $ \cont -> P $ \r x y loc (s, e, p) ->
runP (cont ()) r x y loc (s, ec:e, p)
popExtContextL :: String -> Lex a ()
popExtContextL fn = Lex $ \cont -> P $ \r x y loc stk@(s,e,p) -> case e of
(_:ec) -> runP (cont ()) r x y loc (s,ec,p)
[] -> error ("Internal error: empty tag context in " ++ fn)
getExtensionsL :: Lex a [Extension]
getExtensionsL = Lex $ \cont -> P $ \r x y loc s m ->
runP (cont $ extensions m) r x y loc s m