Parse.hs

{- |
  Module      :  Language.Haskell.Meta.Parse
  Copyright   :  (c) Matt Morrow 2008
  License     :  BSD3
  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  experimental
  Portability :  portable (template-haskell)
-}

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


-----------------------------------------------------------------------------

-- * template-haskell

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


-----------------------------------------------------------------------------

-- * haskell-src-exts

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


-- mkModule :: String -> Hs.Module
-- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] []


emptySrcLoc :: Hs.SrcLoc
emptySrcLoc = (Hs.SrcLoc [] 0 0)


emptyHsModule :: String -> Hs.Module
emptyHsModule n =
    (Hs.Module
        emptySrcLoc
        (Hs.ModuleName n)
        []
        Nothing
        Nothing
        []
        [])

{-
ghci> :i Module
data Module
  = Module SrcLoc
           ModuleName
           [OptionPragma]
           (Maybe WarningText)
           (Maybe [ExportSpec])
           [ImportDecl]
           [Decl]
        -- Defined in Language.Haskell.Exts.Syntax
instance Show Module -- Defined in Language.Haskell.Exts.Syntax
-}

-----------------------------------------------------------------------------