-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.
-- SPDX-License-Identifier: BSD-3-Clause.

{-# OPTIONS_GHC -Wno-missing-fields #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
#include "ghclib_api.h"
module Language.Haskell.GhclibParserEx.GHC.Hs.Expr(
  isTag, isDol, isDot, isReturn, isSection, isRecConstr, isRecUpdate,
  isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isLambda, isQuasiQuote, isQuasiQuoteExpr, isQuasiQuoteSplice,  isOverLabel,
  isDotApp, isTypeApp, isWHNF, isLCase,
  isFieldPun, isFieldPunUpdate, isRecStmt, isParComp, isMDo, isListComp, isMonadComp, isTupleSection, isString, isPrimLiteral,
  isSpliceDecl, isFieldWildcard, isUnboxed, isWholeFrac, isStrictMatch, isMultiIf, isProc, isTransStmt,
  hasFieldsDotDot,
  varToStr, strToVar,
  fromChar
  ) where

#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810)
import GHC.Hs
#else
import HsSyn
#endif
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900)
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902)
import GHC.Types.SourceText
#endif
import GHC.Types.SrcLoc
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Builtin.Types
#else
import SrcLoc
import RdrName
import OccName
import Name
import BasicTypes
import TysWiredIn
#endif
import Data.Ratio

-- 'True' if the provided expression is a variable with name 'tag'.
isTag :: String -> LHsExpr GhcPs -> Bool
isTag :: String -> LHsExpr GhcPs -> Bool
isTag String
tag = \case (L _ (HsVar _ (L _ s))) -> OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
tag; LHsExpr GhcPs
_ -> Bool
False

isDot, isDol, isReturn, isSection, isRecConstr, isRecUpdate,
  isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isQuasiQuote, isQuasiQuoteExpr,
  isLambda, isDotApp, isTypeApp, isWHNF, isLCase, isOverLabel :: LHsExpr GhcPs -> Bool
isDol :: LHsExpr GhcPs -> Bool
isDol = String -> LHsExpr GhcPs -> Bool
isTag String
"$"
isDot :: LHsExpr GhcPs -> Bool
isDot = String -> LHsExpr GhcPs -> Bool
isTag String
"."
isReturn :: LHsExpr GhcPs -> Bool
isReturn LHsExpr GhcPs
x = String -> LHsExpr GhcPs -> Bool
isTag String
"return" LHsExpr GhcPs
x Bool -> Bool -> Bool
|| String -> LHsExpr GhcPs -> Bool
isTag String
"pure" LHsExpr GhcPs
x -- Allow both 'pure' and 'return' as they have the same semantics.
isSection :: LHsExpr GhcPs -> Bool
isSection = \case (L _ SectionL{}) -> Bool
True ; (L _ SectionR{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isRecConstr :: LHsExpr GhcPs -> Bool
isRecConstr = \case (L _ RecordCon{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isRecUpdate :: LHsExpr GhcPs -> Bool
isRecUpdate = \case (L _ RecordUpd{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isVar :: LHsExpr GhcPs -> Bool
isVar = \case (L _ HsVar{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isPar :: LHsExpr GhcPs -> Bool
isPar = \case (L _ HsPar{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isApp :: LHsExpr GhcPs -> Bool
isApp = \case (L _ HsApp{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isOpApp :: LHsExpr GhcPs -> Bool
isOpApp = \case (L _ OpApp{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isAnyApp :: LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
x = LHsExpr GhcPs -> Bool
isApp LHsExpr GhcPs
x Bool -> Bool -> Bool
|| LHsExpr GhcPs -> Bool
isOpApp LHsExpr GhcPs
x
isLexeme :: LHsExpr GhcPs -> Bool
isLexeme = \case (L _ HsVar{}) -> Bool
True; (L _ HsOverLit{}) -> Bool
True; (L _ HsLit{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isLambda :: LHsExpr GhcPs -> Bool
isLambda = \case (L _ HsLam{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isQuasiQuoteExpr :: LHsExpr GhcPs -> Bool
isQuasiQuoteExpr = \case (L _ (HsSpliceE _ HsQuasiQuote{})) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isQuasiQuote :: LHsExpr GhcPs -> Bool
isQuasiQuote = LHsExpr GhcPs -> Bool
isQuasiQuoteExpr -- Backwards compat.
isDotApp :: LHsExpr GhcPs -> Bool
isDotApp = \case (L _ (OpApp _ _ op _)) -> LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
op; LHsExpr GhcPs
_ -> Bool
False
isTypeApp :: LHsExpr GhcPs -> Bool
isTypeApp = \case (L _ HsAppType{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isWHNF :: LHsExpr GhcPs -> Bool
isWHNF = \case
  (L _ (HsVar _ (L _ x))) -> RdrName -> Bool
isRdrDataCon RdrName
x
  (L _ (HsLit _ x)) -> case HsLit GhcPs
x of HsString{} -> Bool
False; HsInt{} -> Bool
False; HsRat{} -> Bool
False; HsLit GhcPs
_ -> Bool
True
  (L _ HsLam{}) -> Bool
True
  (L _ ExplicitTuple{}) -> Bool
True
  (L _ ExplicitList{}) -> Bool
True
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
  (L _ (HsPar _ _ x _)) -> isWHNF x
#else
  (L _ (HsPar _ x)) -> LHsExpr GhcPs -> Bool
isWHNF LHsExpr GhcPs
x
#endif
  (L _ (ExprWithTySig _ x _)) -> LHsExpr GhcPs -> Bool
isWHNF LHsExpr GhcPs
x
  -- Other (unknown) constructors may have bang patterns in them, so
  -- approximate.
  (L _ (HsApp _ (L _ (HsVar _ (L _ x))) _))
    | OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
x) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Just", String
"Left", String
"Right"] -> Bool
True
  LHsExpr GhcPs
_ -> Bool
False
isLCase :: LHsExpr GhcPs -> Bool
isLCase = \case (L _ HsLamCase{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False
isOverLabel :: LHsExpr GhcPs -> Bool
isOverLabel = \case (L _ HsOverLabel{}) -> Bool
True; LHsExpr GhcPs
_ -> Bool
False

isQuasiQuoteSplice :: HsSplice GhcPs -> Bool
isQuasiQuoteSplice :: HsSplice GhcPs -> Bool
isQuasiQuoteSplice = \case HsQuasiQuote{} -> Bool
True; HsSplice GhcPs
_ -> Bool
False

#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_901)
isStrictMatch :: HsMatchContext GhcPs -> Bool
#else
isStrictMatch :: HsMatchContext RdrName -> Bool
#endif
isStrictMatch :: HsMatchContext GhcPs -> Bool
isStrictMatch = \case FunRhs{mc_strictness :: forall p. HsMatchContext p -> SrcStrictness
mc_strictness=SrcStrictness
SrcStrict} -> Bool
True; HsMatchContext GhcPs
_ -> Bool
False

-- Field is punned e.g. '{foo}'.
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
isFieldPun :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool
isFieldPun = \case (L _ HsFieldBind {hfbPun=True}) -> True; _ -> False
#else
isFieldPun :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool
isFieldPun :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool
isFieldPun = \case (L _ HsRecField {hsRecPun=True}) -> Bool
True; LHsRecField GhcPs (LHsExpr GhcPs)
_ -> Bool
False
#endif
-- Field puns in updates have a different type to field puns in
-- constructions.
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
isFieldPunUpdate :: HsFieldBind (LAmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool
isFieldPunUpdate = \case HsFieldBind {hfbPun=True} -> True; _ -> False
#else
isFieldPunUpdate :: HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool
isFieldPunUpdate :: HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool
isFieldPunUpdate = \case HsRecField {hsRecPun :: forall id arg. HsRecField' id arg -> Bool
hsRecPun=Bool
True} -> Bool
True; HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
_ -> Bool
False
#endif

-- Contains a '..' as in 'Foo{..}'
hasFieldsDotDot :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool
hasFieldsDotDot :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool
hasFieldsDotDot = \case HsRecFields {rec_dotdot :: forall p arg. HsRecFields p arg -> Maybe (Located Int)
rec_dotdot=Just Located Int
_} -> Bool
True; HsRecFields GhcPs (LHsExpr GhcPs)
_ -> Bool
False

isRecStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool
isRecStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool
isRecStmt = \case RecStmt{} -> Bool
True; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
_ -> Bool
False

isParComp :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool
isParComp :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool
isParComp = \case ParStmt{} -> Bool
True; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
_ -> Bool
False

-- TODO: Seems `HsStmtContext (HsDoRn p)` on master right now.
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
isMDo :: HsDoFlavour -> Bool
isMDo = \case MDoExpr _ -> True; _ -> False
isMonadComp :: HsDoFlavour -> Bool
isMonadComp = \case MonadComp -> True; _ -> False
isListComp :: HsDoFlavour -> Bool
isListComp = \case ListComp -> True; _ -> False
#elif defined(GHCLIB_API_902) || defined (GHCLIB_API_900)
isMDo :: HsStmtContext GhcRn -> Bool
isMDo :: HsStmtContext GhcRn -> Bool
isMDo = \case MDoExpr Maybe ModuleName
_ -> Bool
True; HsStmtContext GhcRn
_ -> Bool
False
isMonadComp :: HsStmtContext GhcRn -> Bool
isMonadComp :: HsStmtContext GhcRn -> Bool
isMonadComp = \case HsStmtContext GhcRn
MonadComp -> Bool
True; HsStmtContext GhcRn
_ -> Bool
False
isListComp :: HsStmtContext GhcRn -> Bool
isListComp :: HsStmtContext GhcRn -> Bool
isListComp = \case HsStmtContext GhcRn
ListComp -> Bool
True; HsStmtContext GhcRn
_ -> Bool
False
#else
isMDo :: HsStmtContext Name -> Bool
isMDo = \case MDoExpr -> True; _ -> False
isMonadComp :: HsStmtContext Name -> Bool
isMonadComp = \case MonadComp -> True; _ -> False
isListComp :: HsStmtContext Name -> Bool
isListComp = \case ListComp -> True; _ -> False
#endif

isTupleSection :: HsTupArg GhcPs -> Bool
isTupleSection :: HsTupArg GhcPs -> Bool
isTupleSection = \case Missing{} -> Bool
True; HsTupArg GhcPs
_ -> Bool
False

isString :: HsLit GhcPs -> Bool
isString :: HsLit GhcPs -> Bool
isString = \case HsString{} -> Bool
True; HsLit GhcPs
_ -> Bool
False

isPrimLiteral :: HsLit GhcPs -> Bool
isPrimLiteral :: HsLit GhcPs -> Bool
isPrimLiteral = \case
  HsCharPrim{} -> Bool
True
  HsStringPrim{} -> Bool
True
  HsIntPrim{} -> Bool
True
  HsWordPrim{} -> Bool
True
  HsInt64Prim{} -> Bool
True
  HsWord64Prim{} -> Bool
True
  HsFloatPrim{} -> Bool
True
  HsDoublePrim{} -> Bool
True
  HsLit GhcPs
_ -> Bool
False

isSpliceDecl :: HsExpr GhcPs -> Bool
isSpliceDecl :: HsExpr GhcPs -> Bool
isSpliceDecl = \case HsSpliceE{} -> Bool
True; HsExpr GhcPs
_ -> Bool
False

isMultiIf :: HsExpr GhcPs -> Bool
isMultiIf :: HsExpr GhcPs -> Bool
isMultiIf = \case HsMultiIf{} -> Bool
True; HsExpr GhcPs
_ -> Bool
False

isProc :: HsExpr GhcPs -> Bool
isProc :: HsExpr GhcPs -> Bool
isProc = \case HsProc{} -> Bool
True; HsExpr GhcPs
_ -> Bool
False

isTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool
isTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool
isTransStmt = \case TransStmt{} -> Bool
True; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
_ -> Bool
False

-- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'.
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
isFieldWildcard :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool
#else
isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool
#endif
isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool
isFieldWildcard = \case
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
  (L _ HsFieldBind {hfbRHS=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_"
#elif defined(GHCLIB_API_902) || defined (GHCLIB_API_900)
  (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ s))}) -> OccName -> String
occNameString OccName
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_"
#elif defined (GHCLIB_API_810)
  (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ _))}) -> True
#else
  (L _ HsRecField {hsRecFieldArg=(L _ (EWildPat _))}) -> True
#endif
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
  (L _ HsFieldBind {hfbPun=True}) -> True
  (L _ HsFieldBind {}) -> False
#else
  (L _ HsRecField {hsRecPun=True}) -> Bool
True
  (L _ HsRecField {}) -> Bool
False
#endif

isUnboxed :: Boxity -> Bool
isUnboxed :: Boxity -> Bool
isUnboxed = \case Boxity
Unboxed -> Bool
True; Boxity
_ -> Bool
False

isWholeFrac :: HsExpr GhcPs -> Bool

#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904)
isWholeFrac (HsLit _ (HsRat _ fl@FL{} _)) = denominator (rationalFromFractionalLit fl) == 1
isWholeFrac (HsOverLit _ (OverLit _ (HsFractional fl@FL {}) )) = denominator (rationalFromFractionalLit fl) == 1
#elif defined(GHCLIB_API_902)
isWholeFrac :: HsExpr GhcPs -> Bool
isWholeFrac (HsLit XLitE GhcPs
_ (HsRat XHsRat GhcPs
_ fl :: FractionalLit
fl@FL{} Type
_)) = Ratio Integer -> Integer
forall a. Ratio a -> a
denominator (FractionalLit -> Ratio Integer
rationalFromFractionalLit FractionalLit
fl) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
isWholeFrac (HsOverLit XOverLitE GhcPs
_ (OverLit XOverLit GhcPs
_ (HsFractional fl :: FractionalLit
fl@FL {}) HsExpr GhcPs
_)) = Ratio Integer -> Integer
forall a. Ratio a -> a
denominator (FractionalLit -> Ratio Integer
rationalFromFractionalLit FractionalLit
fl) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
#else
isWholeFrac (HsLit _ (HsRat _ (FL _ _ v) _)) = denominator v == 1
isWholeFrac (HsOverLit _ (OverLit _ (HsFractional (FL _ _ v)) _)) = denominator v == 1
#endif
isWholeFrac HsExpr GhcPs
_ = Bool
False

varToStr :: LHsExpr GhcPs -> String
varToStr :: LHsExpr GhcPs -> String
varToStr (L _ (HsVar _ (L _ n)))
  | RdrName
n RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
consDataCon_RDR = String
":"
  | RdrName
n RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName Name
nilDataConName = String
"[]"
  | RdrName
n RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName (DataCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
0)) = String
"()"
  | Bool
otherwise = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
n)
varToStr LHsExpr GhcPs
_ = String
""

strToVar :: String -> LHsExpr GhcPs
#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902)
strToVar :: String -> LHsExpr GhcPs
strToVar String
x = HsExpr GhcPs -> LocatedAn AnnListItem (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcPs -> LocatedAn AnnListItem (HsExpr GhcPs))
-> HsExpr GhcPs -> LocatedAn AnnListItem (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> LocatedAn NameAnn RdrName
forall a an. a -> LocatedAn an a
noLocA (RdrName -> LocatedAn NameAnn RdrName)
-> RdrName -> LocatedAn NameAnn RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (String -> OccName
mkVarOcc String
x))
#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810)
strToVar x = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc x))
#else
strToVar x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x))
#endif

fromChar :: LHsExpr GhcPs -> Maybe Char
fromChar :: LHsExpr GhcPs -> Maybe Char
fromChar = \case (L _ (HsLit _ (HsChar _ x))) -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
x; LHsExpr GhcPs
_ -> Maybe Char
forall a. Maybe a
Nothing