module Language.Haskell.Exts.ParseMonad(
P, ParseResult(..), atSrcLoc, LexContext(..),
ParseMode(..), defaultParseMode, fromParseResult,
runParserWithMode, runParserWithModeComments, runParser,
getSrcLoc, pushCurrentContext, popContext,
getExtensions,
Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,
alternative, checkBOL, setBOL, startToken, getOffside,
pushContextL, popContextL, getExtensionsL, pushComment,
getSrcLocL, setSrcLineL, ignoreLinePragmasL, setLineFilenameL,
ExtContext(..),
pushExtContextL, popExtContextL, getExtContext,
pullCtxtFlag, flagDo,
getModuleName
) where
import Language.Haskell.Exts.SrcLoc(SrcLoc(..))
import Language.Haskell.Exts.Fixity (Fixity, preludeFixities)
import Language.Haskell.Exts.Comments
import Language.Haskell.Exts.Extension (Extension)
import Data.List ( intersperse )
import Control.Applicative
import Control.Monad (when)
import Data.Monoid
data ParseResult a
= ParseOk a
| ParseFailed SrcLoc String
deriving Show
fromParseResult :: ParseResult a -> a
fromParseResult (ParseOk a) = a
fromParseResult (ParseFailed loc str) = error $ "fromParseResult: Parse failed at ["
++ srcFilename loc ++ "] (" ++ show (srcLine loc) ++ ":" ++ show (srcColumn loc) ++ "): " ++ str
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 CtxtFlag = (Bool,Bool)
type ParseState = ([LexContext],[ExtContext],CtxtFlag,[Comment])
indentOfParseState :: ParseState -> Int
indentOfParseState (Layout n:_,_,_,_) = n
indentOfParseState _ = 0
data ParseMode = ParseMode {
parseFilename :: String,
extensions :: [Extension],
ignoreLanguagePragmas :: Bool,
ignoreLinePragmas :: Bool,
fixities :: [Fixity]
}
defaultParseMode :: ParseMode
defaultParseMode = ParseMode {
parseFilename = "<unknown>.hs",
extensions = [],
ignoreLanguagePragmas = False,
ignoreLinePragmas = True,
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,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
runParserWithModeComments :: ParseMode -> P a -> String -> ParseResult (a, [Comment])
runParserWithModeComments mode (P m) s = case m s 0 1 start ([],[],(False,False),[]) mode of
Ok (_,_,_,cs) a -> ParseOk (a, reverse cs)
Failed loc msg -> ParseFailed loc msg
where start = SrcLoc {
srcFilename = parseFilename mode,
srcLine = 1,
srcColumn = 1
}
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
lc <- getSrcLoc
indent <- currentIndent
dob <- pullDoStatus
let loc = srcColumn lc
when (dob && loc < indent
|| not dob && 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, e, p, c) _m -> Ok (ctxt:s, e, p, c) ()
popContext :: P ()
popContext = P $ \_i _x _y _l stk _m ->
case stk of
(_:s, e, p, c) ->
Ok (s, e, p, c) ()
([],_,_,_) -> error "Internal error: empty context in popContext"
pushExtContext :: ExtContext -> P ()
pushExtContext ctxt = P $ \_i _x _y _l (s, e, p, c) _m -> Ok (s, ctxt:e, p, c) ()
popExtContext :: P ()
popExtContext = P $ \_i _x _y _l (s, e, p, c) _m ->
case e of
(_:e') ->
Ok (s, e', p, c) ()
[] -> error "Internal error: empty context in popExtContext"
getExtensions :: P [Extension]
getExtensions = P $ \_i _x _y _l s m ->
Ok s $ extensions m
pushCtxtFlag :: P ()
pushCtxtFlag =
P $ \_i _x _y _l (s, e, (d,c), cs) _m -> case c of
False -> Ok (s, e, (d,True), cs) ()
_ -> error "Internal error: context flag already pushed"
pullDoStatus :: P Bool
pullDoStatus = P $ \_i _x _y _l (s, e, (d,c), cs) _m -> Ok (s,e,(False,c),cs) d
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
getSrcLocL :: Lex a SrcLoc
getSrcLocL = Lex $ \cont -> P $ \i x y l ->
runP (cont (l { srcLine = y, srcColumn = x })) i x y l
setSrcLineL :: Int -> Lex a ()
setSrcLineL y = Lex $ \cont -> P $ \i x _ ->
runP (cont ()) i x y
pushContextL :: LexContext -> Lex a ()
pushContextL ctxt = Lex $ \cont -> P $ \r x y loc (stk, e, pst, cs) ->
runP (cont ()) r x y loc (ctxt:stk, e, pst, cs)
popContextL :: String -> Lex a ()
popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of
(_:ctxt, e, pst, cs) -> runP (cont ()) r x y loc (ctxt, e, pst, cs)
([], _, _, _) -> error ("Internal error: empty context in " ++ fn)
pullCtxtFlag :: Lex a Bool
pullCtxtFlag = Lex $ \cont -> P $ \r x y loc (ct, e, (d,c), cs) ->
runP (cont c) r x y loc (ct, e, (d,False), cs)
flagDo :: Lex a ()
flagDo = Lex $ \cont -> P $ \r x y loc (ct, e, (d,c), cs) ->
runP (cont ()) r x y loc (ct, e, (True,c), cs)
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, c) ->
runP (cont ()) r x y loc (s, ec:e, p, c)
popExtContextL :: String -> Lex a ()
popExtContextL fn = Lex $ \cont -> P $ \r x y loc stk@(s,e,p,c) -> case e of
(_:ec) -> runP (cont ()) r x y loc (s,ec,p,c)
[] -> 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
ignoreLinePragmasL :: Lex a Bool
ignoreLinePragmasL = Lex $ \cont -> P $ \r x y loc s m ->
runP (cont $ ignoreLinePragmas m) r x y loc s m
setLineFilenameL :: String -> Lex a ()
setLineFilenameL name = Lex $ \cont -> P $ \r x y loc s m ->
runP (cont ()) r x y loc s (m {parseFilename = name})
pushComment :: Comment -> Lex a ()
pushComment c = Lex $ \cont -> P $ \r x y loc (s, e, p, cs) ->
runP (cont ()) r x y loc (s, e, p, c:cs)