{-# LANGUAGE CPP #-}

-- | This module is here to parse Haskell expression using the GHC Api
--
-- Stolen from ghc-hs-meta
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)

-- @HsExpr@ is available from GHC.Hs.Expr in all versions we support.
-- However, the goal of GHC is to split HsExpr into its own package, under
-- the namespace Language.Haskell.Syntax. The module split happened in 9.0,
-- but still in the ghc package.
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)

-- | Parse a Haskell expression from source code into a Template Haskell expression.
-- See @parseExpWithExts@ or @parseExpWithFlags@ for customizing with additional extensions and settings.
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

-- | Parse a Haskell expression from source code into a Template Haskell expression
-- using a given set of GHC extensions.
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)

-- | Parse a Haskell expression from source code into a Template Haskell expression
-- using a given set of GHC DynFlags.
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)

-- | Run the GHC parser to parse a Haskell expression into a @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

{- ORMOLU_DISABLE #-}
#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
                -- err = concatMap show errorMessages
                line = SrcLoc.srcLocLine srcLoc
                col = SrcLoc.srcLocCol srcLoc
            in Left (line, col, err)
#endif

-- From Language.Haskell.GhclibParserEx.GHC.Parser

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