{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
#if __GLASGOW_HASKELL__ >= 810
{-# LANGUAGE EmptyCase #-}
#endif
module Test.Hspec.Core.Formatters.Pretty.Parser (
  Expression(..)
, Literal(..)
, parseExpression
, unsafeParseExpression
) where

import           Prelude ()
import           Test.Hspec.Core.Compat hiding (fail)
import           Test.Hspec.Core.Formatters.Pretty.Parser.Types

#ifndef __GHCJS__
#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 904
#define PRETTY_PRINTING_SUPPORTED
#endif
#endif

#ifndef PRETTY_PRINTING_SUPPORTED

parseExpression :: String -> Maybe Expression
parseExpression _ = Nothing

unsafeParseExpression :: String -> Maybe Expression
unsafeParseExpression _ = Nothing

#else

import           GHC.Stack
import           GHC.Exception (throw, errorCallWithCallStackException)

#if __GLASGOW_HASKELL__ >= 904
import           GHC.Utils.Error
import           GHC.Utils.Outputable
#endif

#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904
import           GHC.LanguageExtensions.Type
#endif

#if __GLASGOW_HASKELL__ >= 902
import           GHC.Types.SourceText
#elif __GLASGOW_HASKELL__ >= 900
import           GHC.Types.Basic
import           GHC.Unit.Types
#endif

#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Parser as GHC
import           GHC.Parser.Lexer
import           GHC.Data.StringBuffer
import           GHC.Data.FastString
import           GHC.Types.SrcLoc
import           GHC.Types.Name
import           GHC.Types.Name.Reader
import           GHC.Parser.PostProcess hiding (Tuple)
#else
import           Lexer
import qualified Parser as GHC
import           StringBuffer
import           FastString
import           SrcLoc
import           Name
import           RdrName
import           BasicTypes
import           Module
#endif

#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904
#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Data.EnumSet as EnumSet
#else
import qualified EnumSet
#endif
#endif

#if __GLASGOW_HASKELL__ == 810
import           RdrHsSyn hiding (Tuple)
#endif

#if __GLASGOW_HASKELL__ >= 810
import           GHC.Hs
#else
import           HsSyn
#endif

#if __GLASGOW_HASKELL__ <= 806
import           Data.Bits
import           Control.Exception
#endif

parseExpression :: String -> Maybe Expression
parseExpression :: String -> Maybe Expression
parseExpression = (Error -> Maybe Expression) -> String -> Maybe Expression
parseWith (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)

unsafeParseExpression :: String -> Maybe Expression
unsafeParseExpression :: String -> Maybe Expression
unsafeParseExpression = (Error -> Maybe Expression) -> String -> Maybe Expression
parseWith forall a. Error -> a
throwError

parseWith :: (Error -> Maybe Expression) -> String -> Maybe Expression
parseWith :: (Error -> Maybe Expression) -> String -> Maybe Expression
parseWith Error -> Maybe Expression
err = String -> Maybe (HsExpr GhcPs)
parse forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> Maybe Expression
err forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpression a => a -> Either Error Expression
toExpression

data Error = Error CallStack String

throwError :: Error -> a
throwError :: forall a. Error -> a
throwError (Error CallStack
stack String
err) = forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ String -> CallStack -> SomeException
errorCallWithCallStackException String
err CallStack
stack

fail :: HasCallStack => String -> Either Error a
fail :: forall a. HasCallStack => String -> Either Error a
fail = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> String -> Error
Error HasCallStack => CallStack
callStack

class ToExpression a where
  toExpression :: a -> Either Error Expression

#if __GLASGOW_HASKELL__ < 806
#define _x
#endif

#if __GLASGOW_HASKELL__ >= 900
#define X(name, expr)
#elif __GLASGOW_HASKELL__ == 810
#define X(name, expr) name none -> case none of
#elif __GLASGOW_HASKELL__ >= 806
#define X(name, expr) name none -> case none of NoExt -> expr
#else
#define X(name, expr)
#endif

#if __GLASGOW_HASKELL__ >= 804
#define GhcPsHsLit GhcPs
#else
type GhcPs = RdrName
#define GhcPsHsLit
#endif

#if __GLASGOW_HASKELL__ >= 902
#define _listSynExpr
#endif

#if __GLASGOW_HASKELL__ >= 806
#define RecCon(name, fields) RecordCon _ (L _ name) fields
#else
#define RecCon(name, fields) RecordCon (L _ name) _ _ fields
#endif

#define REJECT(name) name{} -> fail "name"

instance ToExpression (HsExpr GhcPs) where
  toExpression :: HsExpr GhcPs -> Either Error Expression
toExpression HsExpr GhcPs
expr = case HsExpr GhcPs
expr of
    HsVar XVar GhcPs
_x LIdP GhcPs
name -> forall a. ToExpression a => a -> Either Error Expression
toExpression LIdP GhcPs
name
    HsLit XLitE GhcPs
_x HsLit GhcPs
lit -> forall a. ToExpression a => a -> Either Error Expression
toExpression HsLit GhcPs
lit
    HsOverLit XOverLitE GhcPs
_x HsOverLit GhcPs
lit -> forall a. ToExpression a => a -> Either Error Expression
toExpression HsOverLit GhcPs
lit
    HsApp XApp GhcPs
_x LHsExpr GhcPs
f LHsExpr GhcPs
x -> Expression -> Expression -> Expression
App forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToExpression a => a -> Either Error Expression
toExpression LHsExpr GhcPs
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ToExpression a => a -> Either Error Expression
toExpression LHsExpr GhcPs
x
    NegApp XNegApp GhcPs
_x LHsExpr GhcPs
e SyntaxExpr GhcPs
_ -> forall a. ToExpression a => a -> Either Error Expression
toExpression LHsExpr GhcPs
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Expression
x -> case Expression
x of
      Literal (Rational String
n) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Literal -> Expression
Literal (String -> Literal
Rational forall a b. (a -> b) -> a -> b
$ Char
'-' forall a. a -> [a] -> [a]
: String
n)
      Literal (Integer Integer
n) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Literal -> Expression
Literal (Integer -> Literal
Integer forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate Integer
n)
      Expression
_ -> forall a. HasCallStack => String -> Either Error a
fail String
"NegApp"

    HsPar XPar GhcPs
_x
#if __GLASGOW_HASKELL__ >= 904
      _ e _ ->
#else
      LHsExpr GhcPs
e ->
#endif
        Expression -> Expression
Parentheses forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToExpression a => a -> Either Error Expression
toExpression LHsExpr GhcPs
e
    ExplicitTuple XExplicitTuple GhcPs
_x [HsTupArg GhcPs]
xs Boxity
_ -> [Expression] -> Expression
Tuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. ToExpression a => a -> Either Error Expression
toExpression [HsTupArg GhcPs]
xs
    ExplicitList XExplicitList GhcPs
_ _listSynExpr xs -> List <$> mapM toExpression xs
    RecCon(name, fields) -> HsRecordBinds GhcPs
Record (showRdrName name) <$> (recordFields $ rec_flds fields)
      where
#if __GLASGOW_HASKELL__ >= 904
        hsRecFieldLbl = hfbLHS
        hsRecFieldArg = hfbRHS
#endif
        fieldName :: HsRecField' (FieldOcc GhcPs) arg -> String
fieldName = FieldOcc GhcPs -> String
showFieldLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl
        recordFields :: [GenLocated
   l
   (HsRecField'
      (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Either Error [(String, Expression)]
recordFields = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
ToExpression a =>
HsRecField' (FieldOcc GhcPs) a -> Either Error (String, Expression)
recordField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
        recordField :: HsRecField' (FieldOcc GhcPs) a -> Either Error (String, Expression)
recordField HsRecField' (FieldOcc GhcPs) a
field = (,) (forall {arg}. HsRecField' (FieldOcc GhcPs) arg -> String
fieldName HsRecField' (FieldOcc GhcPs) a
field) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToExpression a => a -> Either Error Expression
toExpression (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (FieldOcc GhcPs) a
field)

    REJECT(HsUnboundVar)
    REJECT(HsOverLabel)
    REJECT(HsIPVar)
    REJECT(HsLam)
    REJECT(HsLamCase)
    REJECT(HsAppType)
    REJECT(OpApp)
    REJECT(SectionL)
    REJECT(SectionR)
    REJECT(ExplicitSum)
    REJECT(HsCase)
    HsExpr GhcPs
REJECT(HsIf)
    REJECT(HsMultiIf)
    REJECT(HsLet)
    HsExpr GhcPs
REJECT(HsDo)
    REJECT(RecordUpd)
    REJECT(ExprWithTySig)
    REJECT(ArithSeq)
    REJECT(HsSpliceE)
    REJECT(HsProc)
    REJECT(HsStatic)

#if __GLASGOW_HASKELL__ >= 904
    REJECT(HsRecSel)
    REJECT(HsTypedBracket)
    REJECT(HsUntypedBracket)
#endif
#if __GLASGOW_HASKELL__ >= 902
    REJECT(HsGetField)
    REJECT(HsProjection)
#endif
#if __GLASGOW_HASKELL__ >= 900
    REJECT(HsPragE)
#endif

#if __GLASGOW_HASKELL__ < 904
    REJECT(HsConLikeOut)
    REJECT(HsRecFld)
    REJECT(HsBracket)
    REJECT(HsRnBracketOut)
    REJECT(HsTcBracketOut)
    REJECT(HsTick)
    REJECT(HsBinTick)
#endif
#if __GLASGOW_HASKELL__ < 900
    REJECT(HsSCC)
    REJECT(HsCoreAnn)
    REJECT(HsTickPragma)
    REJECT(HsWrap)
#endif
#if __GLASGOW_HASKELL__ < 810
    REJECT(HsArrApp)
    REJECT(HsArrForm)
    REJECT(EWildPat)
    REJECT(EAsPat)
    REJECT(EViewPat)
    REJECT(ELazyPat)
#endif
#if __GLASGOW_HASKELL__ < 806
    REJECT(HsAppTypeOut)
    REJECT(ExplicitPArr)
    REJECT(ExprWithTySigOut)
    REJECT(PArrSeq)
#endif
    X(XExpr, fail "XExpr")

instance ToExpression RdrName where
  toExpression :: RdrName -> Either Error Expression
toExpression = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Expression
Id forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> String
showRdrName

instance ToExpression (HsTupArg GhcPs) where
  toExpression :: HsTupArg GhcPs -> Either Error Expression
toExpression HsTupArg GhcPs
t = case HsTupArg GhcPs
t of
    Present XPresent GhcPs
_x LHsExpr GhcPs
expr -> forall a. ToExpression a => a -> Either Error Expression
toExpression LHsExpr GhcPs
expr
    Missing XMissing GhcPs
_ -> forall a. HasCallStack => String -> Either Error a
fail String
"Missing (tuple section)"
    X(XTupArg, fail "XTupArg")

instance ToExpression e => ToExpression (GenLocated l e) where
  toExpression :: GenLocated l e -> Either Error Expression
toExpression (L l
_ e
e) = forall a. ToExpression a => a -> Either Error Expression
toExpression e
e

instance ToExpression (HsOverLit GhcPs) where
  toExpression :: HsOverLit GhcPs -> Either Error Expression
toExpression = forall a. ToExpression a => a -> Either Error Expression
toExpression forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsOverLit p -> OverLitVal
ol_val

#if __GLASGOW_HASKELL__ > 802
#define _integralSource

instance ToExpression IntegralLit where
  toExpression :: IntegralLit -> Either Error Expression
toExpression IntegralLit
il = forall a. ToExpression a => a -> Either Error Expression
toExpression (IntegralLit -> Integer
il_value IntegralLit
il)
#endif

instance ToExpression OverLitVal where
  toExpression :: OverLitVal -> Either Error Expression
toExpression OverLitVal
lit = case OverLitVal
lit of
    HsIntegral _integralSource il -> toExpression il
    HsFractional FractionalLit
fl -> forall a. ToExpression a => a -> Either Error Expression
toExpression FractionalLit
fl
    HsIsString SourceText
_ FastString
str -> forall a. ToExpression a => a -> Either Error Expression
toExpression FastString
str

instance ToExpression FractionalLit where
  toExpression :: FractionalLit -> Either Error Expression
toExpression FractionalLit
fl = case FractionalLit -> SourceText
fl_text FractionalLit
fl of
#if __GLASGOW_HASKELL__ > 802
    REJECT(NoSourceText)
    SourceText String
n
#else
    n
#endif
      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Expression
Literal forall a b. (a -> b) -> a -> b
$ String -> Literal
Rational String
n

instance ToExpression FastString where
  toExpression :: FastString -> Either Error Expression
toExpression = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Expression
Literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Literal
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS

instance ToExpression Integer where
  toExpression :: Integer -> Either Error Expression
toExpression = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Expression
Literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
Integer

instance ToExpression Char where
  toExpression :: Char -> Either Error Expression
toExpression = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Expression
Literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Literal
Char

instance ToExpression (HsLit GhcPsHsLit) where
  toExpression :: HsLit GhcPs -> Either Error Expression
toExpression HsLit GhcPs
lit = case HsLit GhcPs
lit of
    HsChar XHsChar GhcPs
_ Char
c -> forall a. ToExpression a => a -> Either Error Expression
toExpression Char
c
    HsString XHsString GhcPs
_ FastString
str -> forall a. ToExpression a => a -> Either Error Expression
toExpression FastString
str
    REJECT(HsCharPrim)
    REJECT(HsStringPrim)
    REJECT(HsInt)
    REJECT(HsIntPrim)
    REJECT(HsWordPrim)
    REJECT(HsInt64Prim)
    REJECT(HsWord64Prim)
    REJECT(HsInteger)
    REJECT(HsRat)
    REJECT(HsFloatPrim)
    REJECT(HsDoublePrim)
    X(XLit, fail "XLit")

showFieldLabel :: FieldOcc GhcPs -> String
showFieldLabel :: FieldOcc GhcPs -> String
showFieldLabel FieldOcc GhcPs
label = case FieldOcc GhcPs
label of
#if __GLASGOW_HASKELL__ >= 806
  FieldOcc XCFieldOcc GhcPs
_ (L SrcSpanAnnN
_ RdrName
name) -> RdrName -> String
showRdrName RdrName
name
#else
  FieldOcc (L _ name) _ -> showRdrName name
#endif
  X(XFieldOcc, "")

showRdrName :: RdrName -> String
showRdrName :: RdrName -> String
showRdrName RdrName
n = case RdrName
n of
  Unqual OccName
name -> OccName -> String
showOccName OccName
name
  Qual ModuleName
_ OccName
name -> OccName -> String
showOccName OccName
name
  Orig Module
_ OccName
name -> OccName -> String
showOccName OccName
name
  Exact Name
name -> OccName -> String
showOccName (Name -> OccName
nameOccName Name
name)

showOccName :: OccName -> String
showOccName :: OccName -> String
showOccName = FastString -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS

parse :: String -> Maybe (HsExpr GhcPs)
parse :: String -> Maybe (HsExpr GhcPs)
parse String
input = case forall a. String -> P a -> ParseResult a
runParser String
input P (GenLocated SrcSpanAnnA (HsExpr GhcPs))
pHsExpr of
  POk PState
_ (L SrcSpanAnnA
_ HsExpr GhcPs
x) -> forall a. a -> Maybe a
Just HsExpr GhcPs
x
  PFailed {} -> forall a. Maybe a
Nothing
  where
    pHsExpr :: P (GenLocated SrcSpanAnnA (HsExpr GhcPs))
pHsExpr = do
      ECP
r <- P ECP
GHC.parseExpression
      forall a. PV a -> P a
runPV (ECP -> forall b. DisambECP b => PV (LocatedA b)
unECP ECP
r)

#if __GLASGOW_HASKELL__ <= 900
#if __GLASGOW_HASKELL__ >= 810
    unECP = runECP_PV
#else
    unECP = return
    runPV = id
#endif
#endif

runParser :: String -> P a -> ParseResult a
runParser :: forall a. String -> P a -> ParseResult a
runParser String
str P a
parser = forall a. P a -> PState -> ParseResult a
unP P a
parser PState
parseState
  where
    location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"" Int
1 Int
1
    input :: StringBuffer
input = String -> StringBuffer
stringToStringBuffer String
str
    parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState ParserOpts
opts StringBuffer
input RealSrcLoc
location
    opts :: ParserOpts
opts = EnumSet WarningFlag
-> EnumSet Extension -> Bool -> Bool -> Bool -> Bool -> ParserOpts
mkParserOpts forall {a}. EnumSet a
warn
#if __GLASGOW_HASKELL__ >= 904
      (DiagOpts mempty mempty False False Nothing defaultSDocContext)
#endif
      EnumSet Extension
extensions Bool
False Bool
False Bool
False Bool
True

#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904
    warn :: EnumSet a
warn = forall {a}. EnumSet a
EnumSet.empty
#else
    warn = mempty
#endif

#if __GLASGOW_HASKELL__ >= 904
    extensions = ["TraditionalRecordSyntax"]
#elif __GLASGOW_HASKELL__ >= 804
    extensions :: EnumSet Extension
extensions = forall a. Enum a => [a] -> EnumSet a
EnumSet.fromList [Extension
TraditionalRecordSyntax]
#else
    extensions = mempty
#endif

#if __GLASGOW_HASKELL__ <= 900
    initParserState = mkPStatePure
    mkParserOpts warningFlags extensionFlags = mkParserFlags' warningFlags extensionFlags unit
#if __GLASGOW_HASKELL__ == 900
    unit = UnitId ""
#else
    unit = fsToUnitId ""
#endif
#endif

#if __GLASGOW_HASKELL__ <= 806
    mkParserFlags' ws es u _ _ _ _ = assert (traditionalRecordSyntaxEnabled extensionsBitmap) $
      ParserFlags ws es u extensionsBitmap
    extensionsBitmap = shift 1 traditionalRecordSyntaxBit
#if __GLASGOW_HASKELL__ == 806
    traditionalRecordSyntaxBit = 28
#else
    traditionalRecordSyntaxBit = 29
#endif
#endif

#endif