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 (
    module Language.Haskell.Meta.Parse
  , module Language.Haskell.Exts.Syntax
  , module Language.Haskell.Exts.Build
  , module Language.Haskell.Exts.Pretty
) where


import Language.Haskell.TH.Syntax
import Language.Haskell.Meta.Syntax
import Language.Haskell.Exts.Build
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.ParseMonad
import Language.Haskell.Exts.ParseUtils


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

-- * template-haskell

parsePat :: String -> Either String Pat
parsePat = either Left (Right . toPat) . parseHsPat

parseExp :: String -> Either String Exp
parseExp = either Left (Right . toExp) . parseHsExp


parseDecs :: String -> Either String [Dec]
parseDecs  = either Left (Right . fmap toDec) . parseHsDecls


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

-- * haskell-src-exts

parseFile :: FilePath -> IO (ParseResult HsModule)
parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))


parseFileContents :: String -> ParseResult HsModule
parseFileContents = parseFileContentsWithMode defaultParseMode


parseFileContentsWithMode :: ParseMode -> String -> ParseResult HsModule
parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr)
  where f ('#':_) = ""
        f x = x


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


parseHsModule :: String -> Either String HsModule
parseHsModule s =
  case parseModule s of
    ParseOk m -> Right m
    ParseFailed loc e ->
      let line = srcLine loc - 1
      in Left (unlines [show line,show loc,e])


parseHsDecls :: String -> Either String [HsDecl]
parseHsDecls s =
  let s' = unlines [pprHsModule (emptyHsModule "Main"), s]
  in case parseModule s' of
      ParseOk m -> Right (moduleDecls m)
      ParseFailed loc e ->
        let line = srcLine loc - 1
        in Left (unlines [show line,show loc,e])


parseHsExp :: String -> Either String HsExp
parseHsExp s =
  case parseHsDecls ("main =\n" ++ (unlines . fmap ("  "++) . lines $ s)) of
    Left err -> Left err
    Right xs ->
      case [ e | HsPatBind _ _ (HsUnGuardedRhs e) _ <- xs] of
        []    -> Left "invalid expression"
        (e:_) -> Right e


parseHsPat :: String -> Either String HsPat
parseHsPat s =
  case parseHsDecls ("("++(filter (/='\n') s)++")=()") of
    Left err -> Left err
    Right xs ->
      case [ p | HsPatBind _ p _ _ <- xs] of
        []    -> Left "invalid pattern"
        (p:_) -> Right p


pprHsModule :: HsModule -> String
pprHsModule = prettyPrint


moduleDecls :: HsModule -> [HsDecl]
moduleDecls (HsModule _ _ _ _ x) = x


mkModule :: String -> Module
mkModule = Module


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


emptyHsModule :: String -> HsModule
emptyHsModule n =
    (HsModule
        emptySrcLoc
        (mkModule n)
        Nothing
        []
        [])


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