{-# LANGUAGE CPP #-}
module Exon.Haskell.Parse (parseExp, parseExpWithExts, parseExpWithFlags, parseHsExpr) where
import Prelude hiding (srcLoc)
#if MIN_VERSION_ghc(9,4,0)
import GHC.Parser.Errors.Ppr ()
import GHC.Parser.Annotation (LocatedA)
import GHC.Utils.Outputable (ppr, defaultSDocContext, renderWithContext)
#else
import qualified GHC.Parser.Errors.Ppr as ParserErrorPpr
import GHC.Parser.Annotation (LocatedA)
#endif
#if MIN_VERSION_ghc(9,4,0)
import GHC.Driver.Config.Parser (initParserOpts)
#else
import GHC.Driver.Config (initParserOpts)
#endif
import GHC.Parser.PostProcess
import qualified GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Data.StringBuffer
import GHC.Parser.Lexer
import qualified GHC.Parser.Lexer as Lexer
import qualified GHC.Parser as Parser
import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Hs.Extension (GhcPs)
import Language.Haskell.Syntax (HsExpr(..))
import Language.Haskell.TH (Extension(..))
import qualified Language.Haskell.TH.Syntax as TH
import qualified Exon.Haskell.Settings as Settings
import Exon.Haskell.Translate (toExp)
parseExp :: String -> Either (Int, Int, String) TH.Exp
#if MIN_VERSION_ghc(9,2,0)
parseExp :: String -> Either (Int, Int, String) Exp
parseExp = [Extension] -> String -> Either (Int, Int, String) Exp
parseExpWithExts
[ Item [Extension]
Extension
TypeApplications
, Item [Extension]
Extension
OverloadedRecordDot
, Item [Extension]
Extension
OverloadedLabels
, Item [Extension]
Extension
OverloadedRecordUpdate
]
#else
parseExp = parseExpWithExts
[ TypeApplications
, OverloadedLabels
]
#endif
parseExpWithExts :: [Extension] -> String -> Either (Int, Int, String) TH.Exp
parseExpWithExts :: [Extension] -> String -> Either (Int, Int, String) Exp
parseExpWithExts [Extension]
exts = DynFlags -> String -> Either (Int, Int, String) Exp
parseExpWithFlags ([Extension] -> DynFlags
Settings.baseDynFlags [Extension]
exts)
parseExpWithFlags :: DynFlags -> String -> Either (Int, Int, String) TH.Exp
parseExpWithFlags :: DynFlags -> String -> Either (Int, Int, String) Exp
parseExpWithFlags DynFlags
flags String
expStr = do
HsExpr GhcPs
hsExpr <- DynFlags -> String -> Either (Int, Int, String) (HsExpr GhcPs)
parseHsExpr DynFlags
flags String
expStr
pure (DynFlags -> HsExpr GhcPs -> Exp
toExp DynFlags
flags HsExpr GhcPs
hsExpr)
parseHsExpr :: DynFlags -> String -> Either (Int, Int, String) (HsExpr GhcPs)
parseHsExpr :: DynFlags -> String -> Either (Int, Int, String) (HsExpr GhcPs)
parseHsExpr DynFlags
dynFlags String
s =
case DynFlags -> String -> ParseResult (LocatedA (HsExpr GhcPs))
runParser DynFlags
dynFlags String
s of
POk PState
_ LocatedA (HsExpr GhcPs)
locatedExpr ->
let expr :: HsExpr GhcPs
expr = LocatedA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
SrcLoc.unLoc LocatedA (HsExpr GhcPs)
locatedExpr
in HsExpr GhcPs -> Either (Int, Int, String) (HsExpr GhcPs)
forall a b. b -> Either a b
Right
HsExpr GhcPs
expr
#if MIN_VERSION_ghc(9,4,0)
PFailed PState{loc :: PState -> PsLoc
loc=PsLoc -> RealSrcLoc
SrcLoc.psRealLoc -> RealSrcLoc
srcLoc, errors :: PState -> Messages PsMessage
errors=Messages PsMessage
errorMessages} ->
let
err :: String
err = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Messages PsMessage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Messages PsMessage
errorMessages)
line :: Int
line = RealSrcLoc -> Int
SrcLoc.srcLocLine RealSrcLoc
srcLoc
col :: Int
col = RealSrcLoc -> Int
SrcLoc.srcLocCol RealSrcLoc
srcLoc
in (Int, Int, String) -> Either (Int, Int, String) (HsExpr GhcPs)
forall a b. a -> Either a b
Left (Int
line, Int
col, String
err)
#else
PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, errors=errorMessages} ->
let
psErrToString e = show $ ParserErrorPpr.pprError e
err = concatMap psErrToString errorMessages
line = SrcLoc.srcLocLine srcLoc
col = SrcLoc.srcLocCol srcLoc
in Left (line, col, err)
#endif
parse :: P a -> String -> DynFlags -> ParseResult a
parse :: forall a. P a -> String -> DynFlags -> ParseResult a
parse P a
p String
str DynFlags
flags =
P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
Lexer.unP P a
p PState
parseState
where
location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
"<string>") Int
1 Int
1
strBuffer :: StringBuffer
strBuffer = String -> StringBuffer
stringToStringBuffer String
str
parseState :: PState
parseState =
ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
flags) StringBuffer
strBuffer RealSrcLoc
location
runParser :: DynFlags -> String -> ParseResult (LocatedA (HsExpr GhcPs))
runParser :: DynFlags -> String -> ParseResult (LocatedA (HsExpr GhcPs))
runParser DynFlags
flags String
str =
case P ECP -> String -> DynFlags -> ParseResult ECP
forall a. P a -> String -> DynFlags -> ParseResult a
parse P ECP
Parser.parseExpression String
str DynFlags
flags of
POk PState
s ECP
e -> P (LocatedA (HsExpr GhcPs))
-> PState -> ParseResult (LocatedA (HsExpr GhcPs))
forall a. P a -> PState -> ParseResult a
unP (PV (LocatedA (HsExpr GhcPs)) -> P (LocatedA (HsExpr GhcPs))
forall a. PV a -> P a
runPV (ECP -> forall b. DisambECP b => PV (LocatedA b)
unECP ECP
e)) PState
s
PFailed PState
ps -> PState -> ParseResult (LocatedA (HsExpr GhcPs))
forall a. PState -> ParseResult a
PFailed PState
ps