{-# 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