module IHP.HSX.HaskellParser (parseHaskellExpression) where

import Prelude
import GHC.Parser.Lexer (ParseResult (..), PState (..))
import GHC.Types.SrcLoc
import qualified GHC.Parser as Parser
import qualified GHC.Parser.Lexer as Lexer
import GHC.Data.FastString
import GHC.Data.StringBuffer
import GHC.Parser.PostProcess
import Text.Megaparsec.Pos
import qualified "template-haskell" Language.Haskell.TH as TH

import qualified GHC.Data.EnumSet as EnumSet
import GHC
import IHP.HSX.HsExpToTH (toExp)

import GHC.Types.Error
import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Error
import qualified GHC.Types.SrcLoc as SrcLoc

parseHaskellExpression :: SourcePos -> [TH.Extension] -> String -> Either (Int, Int, String) TH.Exp
parseHaskellExpression :: SourcePos -> [Extension] -> String -> Either (Int, Int, String) Exp
parseHaskellExpression SourcePos
sourcePos [Extension]
extensions String
input =
        case ParseResult (LocatedA (HsExpr GhcPs))
expr of
            POk PState
parserState LocatedA (HsExpr GhcPs)
result -> Exp -> Either (Int, Int, String) Exp
forall a b. b -> Either a b
Right (HsExpr GhcPs -> Exp
toExp (LocatedA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr GhcPs)
result))
            PFailed PState
parserState ->
                let
                    error :: String
error = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext
                        (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                        ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (DecoratedSDoc -> SDoc) -> [DecoratedSDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
defaultSDocContext)
                        ([DecoratedSDoc] -> [SDoc]) -> [DecoratedSDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (PsMessage -> DecoratedSDoc) -> [PsMessage] -> [DecoratedSDoc]
forall a b. (a -> b) -> [a] -> [b]
map PsMessage -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage
                        ([PsMessage] -> [DecoratedSDoc]) -> [PsMessage] -> [DecoratedSDoc]
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope PsMessage -> PsMessage)
-> [MsgEnvelope PsMessage] -> [PsMessage]
forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope PsMessage -> PsMessage
forall e. MsgEnvelope e -> e
errMsgDiagnostic
                        ([MsgEnvelope PsMessage] -> [PsMessage])
-> [MsgEnvelope PsMessage] -> [PsMessage]
forall a b. (a -> b) -> a -> b
$ Maybe DiagOpts
-> Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage]
forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag Maybe DiagOpts
forall a. Maybe a
Nothing
                        (Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage])
-> Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage]
forall a b. (a -> b) -> a -> b
$ Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages PState
parserState.errors
                    line :: Int
line = RealSrcLoc -> Int
SrcLoc.srcLocLine PState
parserState.loc.psRealLoc
                    col :: Int
col = RealSrcLoc -> Int
SrcLoc.srcLocCol PState
parserState.loc.psRealLoc
                in
                    (Int, Int, String) -> Either (Int, Int, String) Exp
forall a b. a -> Either a b
Left (Int
line, Int
col, String
error)
    where
        expr :: ParseResult (LocatedA (HsExpr GhcPs))
        expr :: ParseResult (LocatedA (HsExpr GhcPs))
expr = case P ECP -> PState -> ParseResult ECP
forall a. P a -> PState -> ParseResult a
Lexer.unP P ECP
Parser.parseExpression PState
parseState of
                POk PState
parserState ECP
result -> P (LocatedA (HsExpr GhcPs))
-> PState -> ParseResult (LocatedA (HsExpr GhcPs))
forall a. P a -> PState -> ParseResult a
Lexer.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
result)) PState
parserState
                PFailed PState
parserState -> PState -> ParseResult (LocatedA (HsExpr GhcPs))
forall a. PState -> ParseResult a
PFailed PState
parserState

        location :: RealSrcLoc
        location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
filename Int
line Int
col
        
        filename :: FastString
        filename :: FastString
filename = String -> FastString
mkFastString SourcePos
sourcePos.sourceName

        line :: Int
        line :: Int
line = Pos -> Int
unPos SourcePos
sourcePos.sourceLine

        col :: Int
        col :: Int
col = Pos -> Int
unPos SourcePos
sourcePos.sourceColumn

        buffer :: StringBuffer
buffer = String -> StringBuffer
stringToStringBuffer String
input
        parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
Lexer.initParserState ParserOpts
parserOpts StringBuffer
buffer RealSrcLoc
location

        parserOpts :: Lexer.ParserOpts
        parserOpts :: ParserOpts
parserOpts = EnumSet Extension
-> DiagOpts
-> [String]
-> Bool
-> Bool
-> Bool
-> Bool
-> ParserOpts
Lexer.mkParserOpts ([Extension] -> EnumSet Extension
forall a. Enum a => [a] -> EnumSet a
EnumSet.fromList [Extension]
extensions) DiagOpts
diagOpts [] Bool
False Bool
False Bool
False Bool
False

diagOpts :: DiagOpts
diagOpts :: DiagOpts
diagOpts =
    DiagOpts
    { diag_warning_flags :: EnumSet WarningFlag
diag_warning_flags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty
    , diag_fatal_warning_flags :: EnumSet WarningFlag
diag_fatal_warning_flags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty
    , diag_warn_is_error :: Bool
diag_warn_is_error = Bool
False
    , diag_reverse_errors :: Bool
diag_reverse_errors = Bool
False
    , diag_max_errors :: Maybe Int
diag_max_errors = Maybe Int
forall a. Maybe a
Nothing
    , diag_ppr_ctx :: SDocContext
diag_ppr_ctx = SDocContext
defaultSDocContext
    }