module Language.Haskell.Exts.ParseMonad(
Parseable(..),
P, ParseResult(..), atSrcLoc, LexContext(..),
ParseMode(..), defaultParseMode, fromParseResult,
runParserWithMode, runParserWithModeComments, runParser,
getSrcLoc, pushCurrentContext, popContext,
getExtensions, getIgnoreFunctionArity,
Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile, lexWhile_,
alternative, checkBOL, setBOL, startToken, getOffside,
pushContextL, popContextL, getExtensionsL, addExtensionL,
saveExtensionsL, restoreExtensionsL, pushComment,
getSrcLocL, setSrcLineL, ignoreLinePragmasL, setLineFilenameL,
ExtContext(..),
pushExtContextL, popExtContextL, getExtContext,
pullCtxtFlag, flagDo,
getModuleName
) where
import Language.Haskell.Exts.SrcLoc (SrcLoc(..), noLoc)
import Language.Haskell.Exts.Fixity (Fixity, preludeFixities)
import Language.Haskell.Exts.Comments
import Language.Haskell.Exts.Extension
import Data.List (intercalate)
import Control.Applicative
import Control.Monad (when, liftM, ap)
import Data.Monoid
class Parseable ast where
parse :: String -> ParseResult ast
parse = parseWithMode defaultParseMode
parseWithMode :: ParseMode -> String -> ParseResult ast
parseWithMode mode = runParserWithMode mode . parser $ fixities mode
parseWithComments :: ParseMode -> String -> ParseResult (ast, [Comment])
parseWithComments mode = runParserWithModeComments mode . parser $ fixities mode
parser :: Maybe [Fixity] -> P ast
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 _ (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
fail = ParseFailed noLoc
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 _ `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],[[KnownExtension]],[ExtContext],CtxtFlag,[Comment])
indentOfParseState :: ParseState -> Int
indentOfParseState (Layout n:_,_,_,_,_) = n
indentOfParseState _ = 0
data ParseMode = ParseMode {
parseFilename :: String,
baseLanguage :: Language,
extensions :: [Extension],
ignoreLanguagePragmas :: Bool,
ignoreLinePragmas :: Bool,
fixities :: Maybe [Fixity],
ignoreFunctionArity :: Bool
}
defaultParseMode :: ParseMode
defaultParseMode = ParseMode {
parseFilename = "<unknown>.hs",
baseLanguage = Haskell2010,
extensions = [],
ignoreLanguagePragmas = False,
ignoreLinePragmas = True,
fixities = Just preludeFixities,
ignoreFunctionArity = False
}
data InternalParseMode = IParseMode {
iParseFilename :: String,
iExtensions :: [KnownExtension],
iIgnoreLinePragmas :: Bool,
iIgnoreFunctionArity :: Bool
}
toInternalParseMode :: ParseMode -> InternalParseMode
toInternalParseMode (ParseMode pf bLang exts _ilang iline _fx farity) =
IParseMode pf (toExtensionList bLang exts) iline farity
newtype P a = P { runP ::
String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> InternalParseMode
-> ParseStatus a
}
runParserWithMode :: ParseMode -> P a -> String -> ParseResult a
runParserWithMode mode pm = fmap fst . runParserWithModeComments mode pm
runParser :: P a -> String -> ParseResult a
runParser = runParserWithMode defaultParseMode
runParserWithModeComments :: ParseMode -> P a -> String -> ParseResult (a, [Comment])
runParserWithModeComments mode = let mode2 = toInternalParseMode mode in \(P m) s ->
case m s 0 1 start ([],[],[],(False,False),[]) mode2 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 Functor P where
fmap = liftM
instance Applicative P where
pure = return
(<*>) = ap
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 = iParseFilename m
mn = intercalate "." $ 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 _ stk _mode -> Ok stk (indentOfParseState stk)
pushContext :: LexContext -> P ()
pushContext ctxt =
P $ \_i _x _y _l (s, exts, e, p, c) _m -> Ok (ctxt:s, exts, e, p, c) ()
popContext :: P ()
popContext = P $ \_i _x _y loc stk _m ->
case stk of
(_:s, exts, e, p, c) ->
Ok (s, exts, e, p, c) ()
([],_,_,_,_) -> Failed loc "Unexpected }"
getExtensions :: P [KnownExtension]
getExtensions = P $ \_i _x _y _l s m ->
Ok s $ iExtensions m
pushCtxtFlag :: P ()
pushCtxtFlag =
P $ \_i _x _y _l (s, exts, e, (d,c), cs) _m -> case c of
False -> Ok (s, exts, e, (d,True), cs) ()
_ -> error "Internal error: context flag already pushed"
pullDoStatus :: P Bool
pullDoStatus = P $ \_i _x _y _l (s, exts, e, (d,c), cs) _m -> Ok (s,exts,e,(False,c),cs) d
getIgnoreFunctionArity :: P Bool
getIgnoreFunctionArity = P $ \_i _x _y _l s m ->
Ok s $ iIgnoreFunctionArity m
newtype Lex r a = Lex { runL :: (a -> P r) -> P r }
instance Functor (Lex r) where
fmap = liftM
instance Applicative (Lex r) where
pure = return
(<*>) = ap
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 $ \rs _x y loc ->
case rs of
(_:r) -> runP (cont ()) r 1 (y+1) loc
[] -> \_ _ -> Failed loc "Lexer: expected newline."
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
lexWhile :: (Char -> Bool) -> Lex a String
lexWhile p = Lex $ \cont -> P $ \rss c l ->
case rss of
[] -> runP (cont []) [] c l
(r:rs) ->
let
l' = case r of
'\n' -> l + 1
_ -> l
c' = case r of
'\n' -> 1
_ -> c + 1
in if p r
then runP (runL ((r:) <$> lexWhile p) cont) rs c' l'
else runP (cont []) (r:rs) c l
lexWhile_ :: (Char -> Bool) -> Lex a ()
lexWhile_ p = do _ <- lexWhile p
return ()
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 = iParseFilename 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, exts, e, pst, cs) ->
runP (cont ()) r x y loc (ctxt:stk, exts, e, pst, cs)
popContextL :: String -> Lex a ()
popContextL _ = Lex $ \cont -> P $ \r x y loc stk m -> case stk of
(_:ctxt, exts, e, pst, cs) -> runP (cont ()) r x y loc (ctxt, exts, e, pst, cs) m
([], _, _, _, _) -> Failed loc "Unexpected }"
pullCtxtFlag :: Lex a Bool
pullCtxtFlag = Lex $ \cont -> P $ \r x y loc (ct, exts, e, (d,c), cs) ->
runP (cont c) r x y loc (ct, exts, e, (d,False), cs)
flagDo :: Lex a ()
flagDo = Lex $ \cont -> P $ \r x y loc (ct, exts, e, (_,c), cs) ->
runP (cont ()) r x y loc (ct, exts, 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, exts, e, p, c) ->
runP (cont ()) r x y loc (s, exts, ec:e, p, c)
popExtContextL :: String -> Lex a ()
popExtContextL fn = Lex $ \cont -> P $ \r x y loc (s,exts,e,p,c) m -> case e of
(_:ec) -> runP (cont ()) r x y loc (s,exts,ec,p,c) m
[] -> Failed loc ("Internal error: empty tag context in " ++ fn)
getExtensionsL :: Lex a [KnownExtension]
getExtensionsL = Lex $ \cont -> P $ \r x y loc s m ->
runP (cont $ iExtensions m) r x y loc s m
addExtensionL :: KnownExtension -> Lex a ()
addExtensionL ext = Lex $ \cont -> P $ \r x y loc (s, oldExts, e, p, c) m ->
let newExts = impliesExts [ext] ++ iExtensions m
in runP (cont ()) r x y loc (s, oldExts, e, p, c) (m {iExtensions = newExts})
saveExtensionsL :: Lex a ()
saveExtensionsL = Lex $ \cont -> P $ \r x y loc (s, oldExts, e, p, c) m ->
runP (cont ()) r x y loc (s, iExtensions m:oldExts, e, p, c) m
restoreExtensionsL :: Lex a ()
restoreExtensionsL = Lex $ \cont -> P $ \r x y loc (s,exts,e,p,c) m -> case exts of
(_:prev) -> runP (cont ()) r x y loc (s,prev,e,p,c) m
_ -> Failed loc "Internal error: empty extension stack"
ignoreLinePragmasL :: Lex a Bool
ignoreLinePragmasL = Lex $ \cont -> P $ \r x y loc s m ->
runP (cont $ iIgnoreLinePragmas 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 {iParseFilename = name})
pushComment :: Comment -> Lex a ()
pushComment c = Lex $ \cont -> P $ \r x y loc (s, exts, e, p, cs) ->
runP (cont ()) r x y loc (s, exts, e, p, c:cs)