module Language.Haskell.Meta.Parse where
import Language.Haskell.TH.Syntax
import Language.Haskell.Meta.Syntax
import qualified Language.Haskell.Exts.Syntax as Hs
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty
parsePat :: String -> Either String Pat
parsePat = either Left (Right . toPat) . parseHsPat
parseExp :: String -> Either String Exp
parseExp = either Left (Right . toExp) . parseHsExp
parseType :: String -> Either String Type
parseType = either Left (Right . toType) . parseHsType
parseDecs :: String -> Either String [Dec]
parseDecs = either Left (Right . fmap toDec) . parseHsDecls
parseFile :: FilePath -> IO (ParseResult Hs.Module)
parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))
parseFileContents :: String -> ParseResult Hs.Module
parseFileContents = parseFileContentsWithMode defaultParseMode
parseFileContentsWithMode :: ParseMode -> String -> ParseResult Hs.Module
parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr)
where f ('#':_) = ""
f x = x
parseHsModule :: String -> Either String Hs.Module
parseHsModule s =
case parseModule s of
ParseOk m -> Right m
ParseFailed loc e ->
let line = Hs.srcLine loc 1
in Left (unlines [show line,show loc,e])
parseHsDecls :: String -> Either String [Hs.Decl]
parseHsDecls s =
let s' = unlines [pprHsModule (emptyHsModule "Main"), s]
in case parseModule s' of
ParseOk m -> Right (moduleDecls m)
ParseFailed loc e ->
let line = Hs.srcLine loc 1
in Left (unlines [show line,show loc,e])
parseHsType :: String -> Either String Hs.Type
parseHsType s =
case parseHsDecls ("zomg::\n" ++ (unlines
. fmap (" "++) . lines $ s ++"\n =()")) of
Left err -> Left err
Right xs ->
case [ t | Hs.PatBind _ _ (Just t) _ _ <- xs] of
[] -> Left "invalid type"
(t:_) -> Right t
parseHsExp :: String -> Either String Hs.Exp
parseHsExp s =
case parseHsDecls ("main =\n" ++ (unlines . fmap (" "++) . lines $ s)) of
Left err -> Left err
Right xs ->
case [ e | Hs.PatBind _ _ _ (Hs.UnGuardedRhs e) _ <- xs] of
[] -> Left "invalid expression"
(e:_) -> Right e
parseHsPat :: String -> Either String Hs.Pat
parseHsPat s =
case parseHsDecls ("("++(filter (/='\n') s)++")=()") of
Left err -> Left err
Right xs ->
case [ p | Hs.PatBind _ p _ _ _ <- xs] of
[] -> Left "invalid pattern"
(p:_) -> Right p
pprHsModule :: Hs.Module -> String
pprHsModule = prettyPrint
moduleDecls :: Hs.Module -> [Hs.Decl]
moduleDecls (Hs.Module _ _ _ _ _ _ x) = x
emptySrcLoc :: Hs.SrcLoc
emptySrcLoc = (Hs.SrcLoc [] 0 0)
emptyHsModule :: String -> Hs.Module
emptyHsModule n =
(Hs.Module
emptySrcLoc
(Hs.ModuleName n)
[]
Nothing
Nothing
[]
[])