{-# LANGUAGE CPP             #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE ViewPatterns    #-}

-- | Interface to the GHC API that closely mimicks Template Haskell
--
-- See "Language.Haskell.TH.Lib".
--
-- This module is intended to be CPP-free, with all CPP confined to
-- "Data.Record.Plugin.GHC.Shim". The only exception to this is the redundant
-- pattern matches that we need for the poor extension design in ghc 9.0; I've
-- not yet found a nice way to shim this.
module Data.Record.Internal.GHC.TemplateHaskellStyle (
    -- * Names
    nameBase
  , mkExpVar
  , mkTyVar
  , mkTyCon
  , pattern ExpVar
  , pattern TyVar
  , pattern TyCon
    -- * Expressions
  , litE
  , stringE
  , pattern VarE
  , pattern ConE
  , recConE
  , pattern RecUpdE
  , appE
  , listE
  , lamE
  , lamE1
  , caseE
  , appsE
  , appTypeE
  , tupE
  , sigE
    -- ** Without direct equivalent
  , intE
    -- * Types
  , parensT
  , litT
  , pattern VarT
  , pattern ConT
  , appT
  , listT
    -- ** Without direct equivalent
  , stringT
  , appsT
  , funT
  , tupT
    -- * Patterns
  , varP
  , conP
  , bangP
  , listP
  , wildP
    -- * Strictness
  , bangType
    -- * Class contexts
  , equalP
    -- * Constructors
  , pattern RecC
  , forallRecC
    -- * Type variable binders
  , kindedTV
    -- ** Without direct equivalent
  , tyVarBndrName
    -- * Top-level declarations
  , sigD
  , valD
  , pattern DataD
  , pattern DerivClause
  , instanceD
  , classD
  , tySynEqn
    -- * Pragmas
  , pattern TypeAnnotation
  , pattern PragAnnD

    -- * Re-exported types (intentionally without constructors)
    --
    -- We intentionally:
    --
    -- o Do not export constructors (unless otherwise indicated): the functions
    --   in this module are replacements for those constructors.
    -- o Only export the located versions of these types: we should try to
    --   minimize location loss when generating code, for better errors.
  , AnnDecl
  , DerivStrategy(..) -- Exported with constructors, is similar enough to TH
  , GhcPs
  , HsLit
  , HsTyLit
  , LConDecl
  , LDerivStrategy
  , LHsDecl
  , LHsDerivingClause
  , LHsExpr
  , LHsType
  , LHsTyVarBndr
  , LPat
  , LTyFamInstDecl
  , LRdrName
  ) where

import Data.List (foldl')

import Data.Record.Internal.GHC.Shim hiding (mkTyVar)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE

{-------------------------------------------------------------------------------
  Internal auxiliary: types of names
-------------------------------------------------------------------------------}

isTermVar, isTermCon, isTypeVar, isTypeCon :: LRdrName -> Bool
isTermVar :: LRdrName -> Bool
isTermVar = (OccName -> Bool) -> LRdrName -> Bool
checkNameType OccName -> Bool
isVarOcc
isTermCon :: LRdrName -> Bool
isTermCon = (OccName -> Bool) -> LRdrName -> Bool
checkNameType OccName -> Bool
isDataOcc
isTypeVar :: LRdrName -> Bool
isTypeVar = (OccName -> Bool) -> LRdrName -> Bool
checkNameType OccName -> Bool
isTvOcc
isTypeCon :: LRdrName -> Bool
isTypeCon = (OccName -> Bool) -> LRdrName -> Bool
checkNameType OccName -> Bool
isTcOcc

checkNameType :: (OccName -> Bool) -> LRdrName -> Bool
checkNameType :: (OccName -> Bool) -> LRdrName -> Bool
checkNameType OccName -> Bool
f (L SrcSpan
_ RdrName
n) = OccName -> Bool
f (RdrName -> OccName
rdrNameOcc RdrName
n)

{-------------------------------------------------------------------------------
  Names
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Syntax.nameBase'
nameBase :: LRdrName -> String
nameBase :: LRdrName -> String
nameBase = OccName -> String
occNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc

-- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for expression vars
mkExpVar :: SrcSpan -> String -> LRdrName
mkExpVar :: SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
l = forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc

-- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type vars
mkTyVar :: SrcSpan -> String -> LRdrName
mkTyVar :: SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
l = forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkTyVarOcc

-- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type constructors
mkTyCon :: SrcSpan -> String -> LRdrName
mkTyCon :: SrcSpan -> String -> LRdrName
mkTyCon SrcSpan
l = forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkTcOcc

-- | Inverse to 'mkExpVar'
--
-- NOTE: Defined in terms of 'nameBase', so discards qualifiers.
viewExpVar :: LRdrName -> Maybe String
viewExpVar :: LRdrName -> Maybe String
viewExpVar LRdrName
n | LRdrName -> Bool
isTermVar LRdrName
n = forall a. a -> Maybe a
Just (LRdrName -> String
nameBase LRdrName
n)
viewExpVar LRdrName
_otherwise = forall a. Maybe a
Nothing

-- | Inverse to 'mkTyVar'
--
-- NOTE: Defined in terms of 'nameBase', so discards qualifiers.
viewTyVar :: LRdrName -> Maybe String
viewTyVar :: LRdrName -> Maybe String
viewTyVar LRdrName
n | LRdrName -> Bool
isTypeVar LRdrName
n = forall a. a -> Maybe a
Just (LRdrName -> String
nameBase LRdrName
n)
viewTyVar LRdrName
_otherwise = forall a. Maybe a
Nothing

-- | Inverse to 'mkTyCon'
viewTyCon :: LRdrName -> Maybe String
viewTyCon :: LRdrName -> Maybe String
viewTyCon LRdrName
n | LRdrName -> Bool
isTypeCon LRdrName
n = forall a. a -> Maybe a
Just (LRdrName -> String
nameBase LRdrName
n)
viewTyCon LRdrName
_otherwise = forall a. Maybe a
Nothing

-- This patterns are not bidirectional: to construct a LRdrName, we need a
-- location. We may want to change this somehow. Use a Located String?

pattern ExpVar :: String -> LRdrName
pattern $mExpVar :: forall {r}. LRdrName -> (String -> r) -> ((# #) -> r) -> r
ExpVar n <- (viewExpVar -> Just n)

pattern TyVar :: String -> LRdrName
pattern $mTyVar :: forall {r}. LRdrName -> (String -> r) -> ((# #) -> r) -> r
TyVar n <- (viewTyVar -> Just n)

pattern TyCon :: String -> LRdrName
pattern $mTyCon :: forall {r}. LRdrName -> (String -> r) -> ((# #) -> r) -> r
TyCon n <- (viewTyCon -> Just n)

{-------------------------------------------------------------------------------
  Expressions
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.varE'
varE :: HasCallStack => LRdrName -> LHsExpr GhcPs
varE :: HasCallStack => LRdrName -> LHsExpr GhcPs
varE LRdrName
name
  | LRdrName -> Bool
isTermVar LRdrName
name = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar forall a. HasDefaultExt a => a
defExt (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name)
  | Bool
otherwise      = forall a. HasCallStack => String -> a
error String
"varE: incorrect name type"

-- | Inverse to 'varE'
viewVarE :: LHsExpr GhcPs -> Maybe LRdrName
viewVarE :: LHsExpr GhcPs -> Maybe LRdrName
viewVarE (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (forall a e. LocatedAn a e -> Located e
reLoc -> LRdrName
name))) | LRdrName -> Bool
isTermVar LRdrName
name = forall a. a -> Maybe a
Just LRdrName
name
viewVarE LHsExpr GhcPs
_ = forall a. Maybe a
Nothing

pattern VarE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs
pattern $bVarE :: HasCallStack => LRdrName -> LHsExpr GhcPs
$mVarE :: forall {r}.
HasCallStack =>
LHsExpr GhcPs -> (LRdrName -> r) -> ((# #) -> r) -> r
VarE name <- (viewVarE -> Just name)
  where
    VarE = HasCallStack => LRdrName -> LHsExpr GhcPs
varE

-- | Equivalent of 'Language.Haskell.TH.Lib.conE'
conE :: HasCallStack => LRdrName -> LHsExpr GhcPs
conE :: HasCallStack => LRdrName -> LHsExpr GhcPs
conE LRdrName
name
  | LRdrName -> Bool
isTermCon LRdrName
name = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar forall a. HasDefaultExt a => a
defExt (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name)
  | Bool
otherwise      = forall a. HasCallStack => String -> a
error String
"conE: incorrect name type"

-- | Inverse to 'conE'
viewConE :: LHsExpr GhcPs -> Maybe LRdrName
viewConE :: LHsExpr GhcPs -> Maybe LRdrName
viewConE (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (forall a e. LocatedAn a e -> Located e
reLoc -> LRdrName
name))) | LRdrName -> Bool
isTermCon LRdrName
name = forall a. a -> Maybe a
Just LRdrName
name
viewConE LHsExpr GhcPs
_ = forall a. Maybe a
Nothing

pattern ConE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs
pattern $bConE :: HasCallStack => LRdrName -> LHsExpr GhcPs
$mConE :: forall {r}.
HasCallStack =>
LHsExpr GhcPs -> (LRdrName -> r) -> ((# #) -> r) -> r
ConE name <- (viewConE -> Just name)
  where
    ConE = HasCallStack => LRdrName -> LHsExpr GhcPs
conE

-- | Equivalent of 'Language.Haskell.TH.Lib.litE'
litE :: HsLit GhcPs -> LHsExpr GhcPs
litE :: HsLit GhcPs -> LHsExpr GhcPs
litE = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. HasDefaultExt a => a
defExt

-- | Equivalent of 'Language.Haskell.TH.Lib.stringE'
stringE :: String -> LHsExpr GhcPs
stringE :: String -> LHsExpr GhcPs
stringE = HsLit GhcPs -> LHsExpr GhcPs
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. XHsString x -> FastString -> HsLit x
HsString SourceText
NoSourceText forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
fsLit

-- | Equivalent of 'Language.Haskell.TH.Lib.recConE'
recConE :: LRdrName -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
recConE :: LRdrName -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
recConE = \LRdrName
recName -> LRdrName -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
mkRec LRdrName
recName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)
mkFld)
  where
    mkRec :: LRdrName -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
    mkRec :: LRdrName -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
mkRec LRdrName
name [LHsRecField GhcPs (LHsExpr GhcPs)]
fields = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$
        forall p.
XRecordCon p -> XRec p (ConLikeP p) -> HsRecordBinds p -> HsExpr p
RecordCon forall a. HasDefaultExt a => a
defExt (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name) (forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [LHsRecField GhcPs (LHsExpr GhcPs)]
fields forall a. Maybe a
Nothing)

    mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)
    mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)
mkFld LRdrName
name LHsExpr GhcPs
val = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 904
        HsFieldBind defExt
#elif __GLASGOW_HASKELL__ >= 902
        forall id arg.
XHsRecField id -> Located id -> arg -> Bool -> HsRecField' id arg
HsRecField forall a. HasDefaultExt a => a
defExt
#else
        HsRecField
#endif
          (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name (LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name))) LHsExpr GhcPs
val Bool
False

-- | Equivalent of 'Language.Haskell.TH.Lib.recUpdE'
recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
recUpdE = \LHsExpr GhcPs
recExpr -> LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs
updRec LHsExpr GhcPs
recExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs
updFld)
  where
    updRec :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs
    updRec :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs
updRec LHsExpr GhcPs
expr [LHsRecUpdField GhcPs]
fields = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
expr forall a b. (a -> b) -> a -> b
$
        forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd forall a. HasDefaultExt a => a
defExt LHsExpr GhcPs
expr
#if __GLASGOW_HASKELL__ >= 902
          forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
#endif
            [LHsRecUpdField GhcPs]
fields

    updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs
    updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs
updFld LRdrName
name LHsExpr GhcPs
val = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 904
        HsFieldBind
#else
        forall id arg.
XHsRecField id -> Located id -> arg -> Bool -> HsRecField' id arg
HsRecField
#endif
#if __GLASGOW_HASKELL__ >= 902
          forall a. HasDefaultExt a => a
defExt
#endif
          (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name (LocatedN RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name))) LHsExpr GhcPs
val Bool
False

viewRecUpdE ::
     LHsExpr GhcPs
  -> Maybe (LHsExpr GhcPs, [(LRdrName, LHsExpr GhcPs)])
viewRecUpdE :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(LRdrName, LHsExpr GhcPs)])
viewRecUpdE (L SrcSpanAnnA
_ (RecordUpd XRecordUpd GhcPs
_ LHsExpr GhcPs
recExpr Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
fields)) =
    (LHsExpr GhcPs
recExpr,) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
-> Maybe [(LRdrName, LHsExpr GhcPs)]
simpleRecordUpdates Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
fields
viewRecUpdE LHsExpr GhcPs
_otherwise = forall a. Maybe a
Nothing

pattern RecUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
pattern $bRecUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
$mRecUpdE :: forall {r}.
LHsExpr GhcPs
-> (LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> r)
-> ((# #) -> r)
-> r
RecUpdE recExpr fields <- (viewRecUpdE -> Just (recExpr, fields))
  where
    RecUpdE = LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
recUpdE

-- | Equivalent of 'Language.Haskell.TH.Lib.appE'
appE :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE LHsExpr GhcPs
a LHsExpr GhcPs
b = forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp LHsExpr GhcPs
a LHsExpr GhcPs
b

-- | Equivalent of 'Language.Haskell.TH.Lib.listE'
listE :: [LHsExpr GhcPs] -> LHsExpr GhcPs
listE :: [LHsExpr GhcPs] -> LHsExpr GhcPs
listE [LHsExpr GhcPs]
es = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc [LHsExpr GhcPs]
es forall a b. (a -> b) -> a -> b
$ forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList forall a. HasDefaultExt a => a
defExt
#if __GLASGOW_HASKELL__ < 902
    Nothing
#endif
    [LHsExpr GhcPs]
es

-- | Equivalent of 'Language.Haskell.TH.Lib.lamE'
lamE :: NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE :: NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE NonEmpty (LPat GhcPs)
pats LHsExpr GhcPs
body = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
body forall a b. (a -> b) -> a -> b
$
    forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$
      forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG forall a. HasDefaultExt a => a
defExt (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
body [forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
body Match GhcPs (LHsExpr GhcPs)
match]) Origin
Generated
  where
    match :: Match GhcPs (LHsExpr GhcPs)
    match :: Match GhcPs (LHsExpr GhcPs)
match = forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match forall a. HasDefaultExt a => a
defExt forall p. HsMatchContext p
LambdaExpr (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (LPat GhcPs)
pats) (LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
simpleGHRSs LHsExpr GhcPs
body)

-- | Convenience wrapper around 'lamE' for a single argument
lamE1 :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 LPat GhcPs
p = NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE (LPat GhcPs
p forall a. a -> [a] -> NonEmpty a
:| [])

-- | Equivalent of 'Language.Haskell.TH.Lib.caseE'
caseE :: LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs
caseE :: LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs
caseE LHsExpr GhcPs
x [(LPat GhcPs, LHsExpr GhcPs)]
alts = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
x forall a b. (a -> b) -> a -> b
$
    forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase forall a. HasDefaultExt a => a
defExt LHsExpr GhcPs
x (forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG forall a. HasDefaultExt a => a
defExt (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
x (forall a b. (a -> b) -> [a] -> [b]
map (LPat GhcPs, LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
mkAlt [(LPat GhcPs, LHsExpr GhcPs)]
alts)) Origin
Generated)
  where
    mkAlt :: (LPat GhcPs, LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
    mkAlt :: (LPat GhcPs, LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
mkAlt (LPat GhcPs
pat, LHsExpr GhcPs
body) = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
x forall a b. (a -> b) -> a -> b
$
        forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match forall a. HasDefaultExt a => a
defExt forall p. HsMatchContext p
CaseAlt [LPat GhcPs
pat] (LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
simpleGHRSs LHsExpr GhcPs
body)

-- | Equivalent of 'Language.Haskell.TH.Lib.appsE'
appsE :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE

-- | Equivalent of 'Language.Haskell.TH.Lib.appT'
appTypeE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
appTypeE :: LHsExpr GhcPs -> XRec GhcPs (HsType GhcPs) -> LHsExpr GhcPs
appTypeE LHsExpr GhcPs
expr XRec GhcPs (HsType GhcPs)
typ = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
expr forall a b. (a -> b) -> a -> b
$
    forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType
#if __GLASGOW_HASKELL__ >= 902
      (forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan LHsExpr GhcPs
expr)
#else
      defExt
#endif
      LHsExpr GhcPs
expr
      (forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC forall a. HasDefaultExt a => a
defExt XRec GhcPs (HsType GhcPs)
typ)

-- | Equivalent of 'Language.Haskell.TH.Lib.tupE'
tupE :: NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
tupE :: NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
tupE NonEmpty (LHsExpr GhcPs)
xs = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc NonEmpty (LHsExpr GhcPs)
xs forall a b. (a -> b) -> a -> b
$
    forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple
      forall a. HasDefaultExt a => a
defExt
      [forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc NonEmpty (LHsExpr GhcPs)
xs (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present forall a. HasDefaultExt a => a
defExt GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) | GenLocated SrcSpanAnnA (HsExpr GhcPs)
x <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty (LHsExpr GhcPs)
xs]
      Boxity
Boxed

-- | Equivalent of 'Language.Haskell.TH.Lib.sigE'
sigE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
sigE :: LHsExpr GhcPs -> XRec GhcPs (HsType GhcPs) -> LHsExpr GhcPs
sigE LHsExpr GhcPs
expr XRec GhcPs (HsType GhcPs)
ty = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
expr forall a b. (a -> b) -> a -> b
$
    forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig forall a. HasDefaultExt a => a
defExt LHsExpr GhcPs
expr (forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC forall a. HasDefaultExt a => a
defExt (XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
implicitBndrs XRec GhcPs (HsType GhcPs)
ty))

{-------------------------------------------------------------------------------
  .. without direct equivalent
-------------------------------------------------------------------------------}

-- | By analogy with 'stringE'
intE :: Integral a => a -> LHsExpr GhcPs
intE :: forall a. Integral a => a -> LHsExpr GhcPs
intE = HsLit GhcPs -> LHsExpr GhcPs
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt forall a. HasDefaultExt a => a
defExt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> IntegralLit
mkIntegralLit

{-------------------------------------------------------------------------------
  Types
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.parensT'
parensT :: LHsType GhcPs -> LHsType GhcPs
parensT :: XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
parensT = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. HasDefaultExt a => a
defExt

-- | Equivalent of 'Language.Haskell.TH.Lib.litT'
litT :: HsTyLit -> LHsType GhcPs
litT :: HsTyLit -> XRec GhcPs (HsType GhcPs)
litT = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit forall a. HasDefaultExt a => a
defExt

-- | Equivalent of 'Language.Haskell.TH.Lib.varT'
varT :: HasCallStack => LRdrName -> LHsType GhcPs
varT :: HasCallStack => LRdrName -> XRec GhcPs (HsType GhcPs)
varT LRdrName
name
  | LRdrName -> Bool
isTypeVar LRdrName
name = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. HasDefaultExt a => a
defExt PromotionFlag
NotPromoted (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name))
  | Bool
otherwise      = forall a. HasCallStack => String -> a
error String
"varT: incorrect name type"

-- | Inverse to 'varT'
viewVarT :: LHsType GhcPs -> Maybe LRdrName
viewVarT :: XRec GhcPs (HsType GhcPs) -> Maybe LRdrName
viewVarT (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (forall a e. LocatedAn a e -> Located e
reLoc -> LRdrName
name))) | LRdrName -> Bool
isTypeVar LRdrName
name = forall a. a -> Maybe a
Just LRdrName
name
viewVarT XRec GhcPs (HsType GhcPs)
_otherwise = forall a. Maybe a
Nothing

pattern VarT :: HasCallStack => () => LRdrName -> LHsType GhcPs
pattern $bVarT :: HasCallStack => LRdrName -> XRec GhcPs (HsType GhcPs)
$mVarT :: forall {r}.
HasCallStack =>
XRec GhcPs (HsType GhcPs) -> (LRdrName -> r) -> ((# #) -> r) -> r
VarT name <- (viewVarT -> Just name)
  where
    VarT = HasCallStack => LRdrName -> XRec GhcPs (HsType GhcPs)
varT

-- | Equivalent of 'Language.Haskell.TH.Lib.conT'
conT :: HasCallStack => LRdrName -> LHsType GhcPs
conT :: HasCallStack => LRdrName -> XRec GhcPs (HsType GhcPs)
conT LRdrName
name
  | LRdrName -> Bool
isTypeCon LRdrName
name = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. HasDefaultExt a => a
defExt PromotionFlag
NotPromoted (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name))
  | Bool
otherwise      = forall a. HasCallStack => String -> a
error String
"varT: incorrect name type"

-- | Inverse to 'conT'
viewConT :: LHsType GhcPs -> Maybe LRdrName
viewConT :: XRec GhcPs (HsType GhcPs) -> Maybe LRdrName
viewConT (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (forall a e. LocatedAn a e -> Located e
reLoc -> LRdrName
name))) | LRdrName -> Bool
isTypeCon LRdrName
name = forall a. a -> Maybe a
Just LRdrName
name
viewConT XRec GhcPs (HsType GhcPs)
_otherwise = forall a. Maybe a
Nothing

pattern ConT :: HasCallStack => () => LRdrName -> LHsType GhcPs
pattern $bConT :: HasCallStack => LRdrName -> XRec GhcPs (HsType GhcPs)
$mConT :: forall {r}.
HasCallStack =>
XRec GhcPs (HsType GhcPs) -> (LRdrName -> r) -> ((# #) -> r) -> r
ConT name <- (viewConT -> Just name)
  where
    ConT = HasCallStack => LRdrName -> XRec GhcPs (HsType GhcPs)
conT

-- | Equivalent of 'Language.Haskell.TH.Lib.appT'
appT :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
appT :: XRec GhcPs (HsType GhcPs)
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
appT = forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy

-- | Equivalent of 'Language.Haskell.TH.Lib.listT'
--
-- Signature by analogy with 'Language.Haskell.TH.Lib.listE'.
listT :: [LHsType GhcPs] -> LHsType GhcPs
listT :: [XRec GhcPs (HsType GhcPs)] -> XRec GhcPs (HsType GhcPs)
listT [XRec GhcPs (HsType GhcPs)]
ts = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc [XRec GhcPs (HsType GhcPs)]
ts forall a b. (a -> b) -> a -> b
$ forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy forall a. HasDefaultExt a => a
defExt PromotionFlag
IsPromoted [XRec GhcPs (HsType GhcPs)]
ts

{-------------------------------------------------------------------------------
  .. without direct equivalent
-------------------------------------------------------------------------------}

-- | By analogy with 'stringE'
stringT :: String -> LHsType GhcPs
stringT :: String -> XRec GhcPs (HsType GhcPs)
stringT = HsTyLit -> XRec GhcPs (HsType GhcPs)
litT forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
fsLit

-- | By analogy with 'appsE'
appsT :: LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT :: XRec GhcPs (HsType GhcPs)
-> [XRec GhcPs (HsType GhcPs)] -> XRec GhcPs (HsType GhcPs)
appsT = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' XRec GhcPs (HsType GhcPs)
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
appT

-- | Function type
--
-- TH only provides 'Language.Haskell.TH.Lib.arrowT'.
funT :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT :: XRec GhcPs (HsType GhcPs)
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
funT XRec GhcPs (HsType GhcPs)
a XRec GhcPs (HsType GhcPs)
b = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
a (XFunTy GhcPs
-> XRec GhcPs (HsType GhcPs)
-> XRec GhcPs (HsType GhcPs)
-> HsType GhcPs
hsFunTy forall a. HasDefaultExt a => a
defExt XRec GhcPs (HsType GhcPs)
a XRec GhcPs (HsType GhcPs)
b)

-- | Tuple type
--
-- TH only provides 'Language.Haskell.TH.Lib.tupleT'.
-- Signature by analogy with 'tupE'.
tupT :: NonEmpty (LHsType GhcPs) -> LHsType GhcPs
tupT :: NonEmpty (XRec GhcPs (HsType GhcPs)) -> XRec GhcPs (HsType GhcPs)
tupT NonEmpty (XRec GhcPs (HsType GhcPs))
ts = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc NonEmpty (XRec GhcPs (HsType GhcPs))
ts forall a b. (a -> b) -> a -> b
$ forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy forall a. HasDefaultExt a => a
defExt (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (XRec GhcPs (HsType GhcPs))
ts)

{-------------------------------------------------------------------------------
  Patterns
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.varP'
varP :: LRdrName -> LPat GhcPs
varP :: LRdrName -> LPat GhcPs
varP LRdrName
name = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name (forall p. XVarPat p -> LIdP p -> Pat p
VarPat forall a. HasDefaultExt a => a
defExt (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name))

-- | Equivalent of 'Language.Haskell.TH.Lib.conP'
conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs
#if __GLASGOW_HASKELL__ >= 902
conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs
conP LRdrName
con [LPat GhcPs]
args = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
con (LRdrName -> HsConPatDetails GhcPs -> Pat GhcPs
conPat LRdrName
con (forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] [LPat GhcPs]
args))
#else
conP con args = inheritLoc con (conPat con (PrefixCon args))
#endif

-- | Equivalent of 'Language.Haskell.TH.Lib.bangP'
bangP :: LPat GhcPs -> LPat GhcPs
bangP :: LPat GhcPs -> LPat GhcPs
bangP LPat GhcPs
p = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LPat GhcPs
p forall a b. (a -> b) -> a -> b
$ forall p. XBangPat p -> LPat p -> Pat p
BangPat forall a. HasDefaultExt a => a
defExt LPat GhcPs
p

-- | Equivalent of 'Language.Haskell.TH.Lib.listP'
listP :: [LPat GhcPs] -> LPat GhcPs
listP :: [LPat GhcPs] -> LPat GhcPs
listP [LPat GhcPs]
xs = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc [LPat GhcPs]
xs forall a b. (a -> b) -> a -> b
$ forall p. XListPat p -> [LPat p] -> Pat p
ListPat forall a. HasDefaultExt a => a
defExt [LPat GhcPs]
xs

-- | Equivalent of 'Language.Haskell.TH.Lib.wildP'
wildP :: LPat GhcPs
wildP :: LPat GhcPs
wildP = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc SrcSpan
noSrcSpan (forall p. XWildPat p -> Pat p
WildPat forall a. HasDefaultExt a => a
defExt)

{-------------------------------------------------------------------------------
  Strictness
-------------------------------------------------------------------------------}

-- | Approximate equivalent of 'Language.Haskell.TH.Lib.bangType'
--
-- The GHC API has no equivalent of 'Language.Haskell.TH.Syntax.BangType'.
bangType :: LHsType GhcPs -> LHsType GhcPs
bangType :: XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
bangType XRec GhcPs (HsType GhcPs)
t = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
t forall a b. (a -> b) -> a -> b
$
    forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy forall a. HasDefaultExt a => a
defExt (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
SrcStrict) XRec GhcPs (HsType GhcPs)
t

{-------------------------------------------------------------------------------
  Class contexts
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.equalP'
equalP :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
equalP :: XRec GhcPs (HsType GhcPs)
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
equalP XRec GhcPs (HsType GhcPs)
x XRec GhcPs (HsType GhcPs)
y = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
x forall a b. (a -> b) -> a -> b
$
    forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
LHsType (GhcPass p)
-> LocatedN (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy
#if __GLASGOW_HASKELL__ >= 904
      NotPromoted
#endif
      XRec GhcPs (HsType GhcPs)
x
      (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
x RdrName
eqTyCon_RDR)
      XRec GhcPs (HsType GhcPs)
y

{-------------------------------------------------------------------------------
  Constructors
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.rec'
--
-- NOTE: The GHC AST (but not TH) supports declaring multiple record fields
-- with the same type. We do not support this here (since we follow TH).
recC :: LRdrName -> [(LRdrName, LHsType GhcPs)] -> LConDecl GhcPs
recC :: LRdrName
-> [(LRdrName, XRec GhcPs (HsType GhcPs))] -> LConDecl GhcPs
recC = [LRdrName]
-> [XRec GhcPs (HsType GhcPs)]
-> LRdrName
-> [(LRdrName, XRec GhcPs (HsType GhcPs))]
-> LConDecl GhcPs
forallRecC [] []

-- | Inverse to 'recC'
viewRecC :: LConDecl GhcPs -> Maybe (LRdrName, [(LRdrName, LHsType GhcPs)])
viewRecC :: LConDecl GhcPs
-> Maybe (LRdrName, [(LRdrName, XRec GhcPs (HsType GhcPs))])
viewRecC
    (L SrcSpanAnnA
_
       ConDeclH98 {
           con_name :: forall pass. ConDecl pass -> LIdP pass
con_name   = LIdP GhcPs
conName
#if __GLASGOW_HASKELL__ >= 902
         , con_forall :: forall pass. ConDecl pass -> Bool
con_forall = Bool
False
#else
         , con_forall = L _ False
#endif
         , con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = []
         , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (XRec GhcPs [XRec GhcPs (HsType GhcPs)])
Nothing
         , con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args   = RecCon (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
fields)
         }
    ) = (forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
conName ,) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LConDeclField GhcPs -> Maybe (LRdrName, XRec GhcPs (HsType GhcPs))
viewRecField [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
fields
  where
    viewRecField :: LConDeclField GhcPs -> Maybe (LRdrName, LHsType GhcPs)
    viewRecField :: LConDeclField GhcPs -> Maybe (LRdrName, XRec GhcPs (HsType GhcPs))
viewRecField
        (L SrcSpanAnnA
_
           ConDeclField {
               cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names = [L SrcSpan
_ FieldOcc GhcPs
fieldName]
             , cd_fld_type :: forall pass. ConDeclField pass -> LBangType pass
cd_fld_type  = XRec GhcPs (HsType GhcPs)
ty
             }
        ) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (FieldOcc GhcPs -> LRdrName
viewFieldOcc FieldOcc GhcPs
fieldName, XRec GhcPs (HsType GhcPs)
ty)
    viewRecField LConDeclField GhcPs
_otherwise = forall a. Maybe a
Nothing

    viewFieldOcc :: FieldOcc GhcPs -> LRdrName
    viewFieldOcc :: FieldOcc GhcPs -> LRdrName
viewFieldOcc (FieldOcc XCFieldOcc GhcPs
_ (forall a e. LocatedAn a e -> Located e
reLoc -> LRdrName
name)) = LRdrName
name
#if __GLASGOW_HASKELL__ < 900
    viewFieldOcc _ = panic "viewFieldOcc"
#endif
viewRecC LConDecl GhcPs
_otherwise = forall a. Maybe a
Nothing

pattern RecC :: LRdrName -> [(LRdrName, LHsType GhcPs)] -> LConDecl GhcPs
pattern $bRecC :: LRdrName
-> [(LRdrName, XRec GhcPs (HsType GhcPs))] -> LConDecl GhcPs
$mRecC :: forall {r}.
LConDecl GhcPs
-> (LRdrName -> [(LRdrName, XRec GhcPs (HsType GhcPs))] -> r)
-> ((# #) -> r)
-> r
RecC conName args <- (viewRecC -> Just (conName, args))
  where
    RecC = LRdrName
-> [(LRdrName, XRec GhcPs (HsType GhcPs))] -> LConDecl GhcPs
recC

-- | Equivalent of the combination of 'Language.Haskell.TH.Lib.forallC' and
-- 'Language.Haskell.TH.Lib.recC'.
forallRecC ::
     [LRdrName]                  -- ^ @forallC@ argument: bound type variables
  -> [LHsType GhcPs]             -- ^ @forallC@ argument: context
  -> LRdrName                    -- ^ @recC@ argument: record constructor name
  -> [(LRdrName, LHsType GhcPs)] -- ^ @recC@ argument: record fields
  -> LConDecl GhcPs
forallRecC :: [LRdrName]
-> [XRec GhcPs (HsType GhcPs)]
-> LRdrName
-> [(LRdrName, XRec GhcPs (HsType GhcPs))]
-> LConDecl GhcPs
forallRecC [LRdrName]
vars [XRec GhcPs (HsType GhcPs)]
ctxt LRdrName
conName [(LRdrName, XRec GhcPs (HsType GhcPs))]
args = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
conName forall a b. (a -> b) -> a -> b
$ ConDeclH98 {
      con_ext :: XConDeclH98 GhcPs
con_ext    = forall a. HasDefaultExt a => a
defExt
    , con_name :: LIdP GhcPs
con_name   = forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
conName
    , con_forall :: Bool
con_forall = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
conName Bool
True
    , con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs = forall a b. (a -> b) -> [a] -> [b]
map (LHsTyVarBndr GhcPs -> LHsTyVarBndr Specificity GhcPs
setDefaultSpecificity forall b c a. (b -> c) -> (a -> b) -> a -> c
. LRdrName -> LHsTyVarBndr GhcPs
mkBndr) [LRdrName]
vars
    , con_mb_cxt :: Maybe (XRec GhcPs [XRec GhcPs (HsType GhcPs)])
con_mb_cxt = forall a. a -> Maybe a
Just (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
conName [XRec GhcPs (HsType GhcPs)]
ctxt)
    , con_args :: HsConDetails
  Void
  (HsScaled GhcPs (XRec GhcPs (HsType GhcPs)))
  (XRec GhcPs [LConDeclField GhcPs])
con_args   = forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LRdrName -> XRec GhcPs (HsType GhcPs) -> LConDeclField GhcPs
mkRecField) [(LRdrName, XRec GhcPs (HsType GhcPs))]
args)
    , con_doc :: Maybe LHsDocString
con_doc    = forall a. Maybe a
Nothing
    }
  where
    mkBndr :: LRdrName -> LHsTyVarBndr GhcPs
    mkBndr :: LRdrName -> LHsTyVarBndr GhcPs
mkBndr LRdrName
name = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
userTyVar forall a. HasDefaultExt a => a
defExt LRdrName
name

    mkRecField :: LRdrName -> LHsType GhcPs -> LConDeclField GhcPs
    mkRecField :: LRdrName -> XRec GhcPs (HsType GhcPs) -> LConDeclField GhcPs
mkRecField LRdrName
name XRec GhcPs (HsType GhcPs)
ty = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$ ConDeclField {
          cd_fld_ext :: XConDeclField GhcPs
cd_fld_ext   = forall a. HasDefaultExt a => a
defExt
        , cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names = [forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc forall a b. (a -> b) -> a -> b
$ forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name]
        , cd_fld_type :: XRec GhcPs (HsType GhcPs)
cd_fld_type  = XRec GhcPs (HsType GhcPs)
ty
        , cd_fld_doc :: Maybe LHsDocString
cd_fld_doc   = forall a. Maybe a
Nothing
        }

{-------------------------------------------------------------------------------
  Type variable binders
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.kindedTV'
kindedTV :: LRdrName -> LHsType GhcPs -> LHsTyVarBndr GhcPs
kindedTV :: LRdrName -> XRec GhcPs (HsType GhcPs) -> LHsTyVarBndr GhcPs
kindedTV LRdrName
name XRec GhcPs (HsType GhcPs)
ty = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name (XKindedTyVar GhcPs
-> Located (IdP GhcPs)
-> XRec GhcPs (HsType GhcPs)
-> HsTyVarBndr GhcPs
kindedTyVar forall a. HasDefaultExt a => a
defExt LRdrName
name XRec GhcPs (HsType GhcPs)
ty)

{-------------------------------------------------------------------------------
  .. without direct equivalent
-------------------------------------------------------------------------------}

tyVarBndrName :: LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName :: LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName = HsTyVarBndr GhcPs -> LRdrName
hsTyVarLName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc

{-------------------------------------------------------------------------------
  Top-level declarations
-------------------------------------------------------------------------------}

-- | Equivalent of 'Language.Haskell.TH.Lib.sigD'
sigD :: LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD :: LRdrName -> XRec GhcPs (HsType GhcPs) -> LHsDecl GhcPs
sigD LRdrName
name XRec GhcPs (HsType GhcPs)
ty = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
SigD forall a. HasDefaultExt a => a
defExt Sig GhcPs
sig
  where
    sig :: Sig GhcPs
    sig :: Sig GhcPs
sig = forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. HasDefaultExt a => a
defExt [forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name] forall a b. (a -> b) -> a -> b
$ forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC forall a. HasDefaultExt a => a
defExt (XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
implicitBndrs XRec GhcPs (HsType GhcPs)
ty)

-- | Equivalent of 'Language.Haskell.TH.Lib.valD'
--
-- Currently this offers a simplified API only.
valD :: LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD :: LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
fnName LHsExpr GhcPs
body = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
fnName forall a b. (a -> b) -> a -> b
$
    forall p. XValD p -> HsBind p -> HsDecl p
ValD forall a. HasDefaultExt a => a
defExt (forall l e. GenLocated l e -> e
unLoc (LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs
simpleBinding LRdrName
fnName LHsExpr GhcPs
body))

-- | Equivalent of 'Language.Haskell.TH.Lib.dataD'
dataD ::
     LRdrName                  -- ^ Datatype name
  -> [LHsTyVarBndr GhcPs]      -- ^ Type arguments
  -> [LConDecl GhcPs]          -- ^ Constructors
  -> [LHsDerivingClause GhcPs] -- ^ Deriving clauses
  -> LHsDecl GhcPs
dataD :: LRdrName
-> [LHsTyVarBndr GhcPs]
-> [LConDecl GhcPs]
-> [LHsDerivingClause GhcPs]
-> LHsDecl GhcPs
dataD LRdrName
typeName [LHsTyVarBndr GhcPs]
tyVars [LConDecl GhcPs]
cons [LHsDerivingClause GhcPs]
derivs = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
typeName forall a b. (a -> b) -> a -> b
$
    forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$ DataDecl {
        tcdDExt :: XDataDecl GhcPs
tcdDExt     = forall a. HasDefaultExt a => a
defExt
      , tcdLName :: LIdP GhcPs
tcdLName    = forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
typeName
      , tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars   = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
tyVars
      , tcdFixity :: LexicalFixity
tcdFixity   = LexicalFixity
Prefix
      , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn {
            dd_ext :: XCHsDataDefn GhcPs
dd_ext     = forall a. HasDefaultExt a => a
defExt
          , dd_ND :: NewOrData
dd_ND      = NewOrData
DataType
#if __GLASGOW_HASKELL__ >= 902
          , dd_ctxt :: Maybe (XRec GhcPs [XRec GhcPs (HsType GhcPs)])
dd_ctxt    = forall a. Maybe a
Nothing
#else
          , dd_ctxt    = inheritLoc typeName []
#endif
          , dd_cType :: Maybe (XRec GhcPs CType)
dd_cType   = forall a. Maybe a
Nothing
          , dd_kindSig :: Maybe (XRec GhcPs (HsType GhcPs))
dd_kindSig = forall a. Maybe a
Nothing
          , dd_cons :: [LConDecl GhcPs]
dd_cons    = [LConDecl GhcPs]
cons
          , dd_derivs :: [LHsDerivingClause GhcPs]
dd_derivs  = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
typeName [LHsDerivingClause GhcPs]
derivs
          }
      }

-- | Inverse to 'dataD'
viewDataD ::
     LHsDecl GhcPs
  -> Maybe (
         LRdrName
       , [LHsTyVarBndr GhcPs]
       , [LConDecl GhcPs]
       , [LHsDerivingClause GhcPs]
       )
viewDataD :: LHsDecl GhcPs
-> Maybe
     (LRdrName, [LHsTyVarBndr GhcPs], [LConDecl GhcPs],
      [LHsDerivingClause GhcPs])
viewDataD
    (L SrcSpanAnnA
_
       (TyClD
         XTyClD GhcPs
_
         DataDecl {
             tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName    = LIdP GhcPs
typeName
           , tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars   = HsQTvs {hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr GhcPs]
tyVars}
           , tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity   = LexicalFixity
Prefix
           , tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn {
                   dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND      = NewOrData
DataType
#if __GLASGOW_HASKELL__ >= 902
                 , dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt    = Maybe (XRec GhcPs [XRec GhcPs (HsType GhcPs)])
Nothing
#else
                 , dd_ctxt    = L _ []
#endif
                 , dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType   = Maybe (XRec GhcPs CType)
Nothing
                 , dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (XRec GhcPs (HsType GhcPs))
Nothing
                 , dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons    = [LConDecl GhcPs]
cons
#if __GLASGOW_HASKELL__ >= 902
                 , dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs  = [LHsDerivingClause GhcPs]
derivs
#else
                 , dd_derivs  = L _ derivs
#endif
                 }
           }
       )
    ) = forall a. a -> Maybe a
Just (forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
typeName, [LHsTyVarBndr GhcPs]
tyVars, [LConDecl GhcPs]
cons, [LHsDerivingClause GhcPs]
derivs)
viewDataD LHsDecl GhcPs
_otherwise = forall a. Maybe a
Nothing

pattern DataD ::
     LRdrName
  -> [LHsTyVarBndr GhcPs]
  -> [LConDecl GhcPs]
  -> [LHsDerivingClause GhcPs]
  -> LHsDecl GhcPs
pattern $bDataD :: LRdrName
-> [LHsTyVarBndr GhcPs]
-> [LConDecl GhcPs]
-> [LHsDerivingClause GhcPs]
-> LHsDecl GhcPs
$mDataD :: forall {r}.
LHsDecl GhcPs
-> (LRdrName
    -> [LHsTyVarBndr GhcPs]
    -> [LConDecl GhcPs]
    -> [LHsDerivingClause GhcPs]
    -> r)
-> ((# #) -> r)
-> r
DataD typeName tyVars cons derivs <-
          (viewDataD -> Just (typeName, tyVars, cons, derivs))
  where
    DataD = LRdrName
-> [LHsTyVarBndr GhcPs]
-> [LConDecl GhcPs]
-> [LHsDerivingClause GhcPs]
-> LHsDecl GhcPs
dataD

-- | Equivalent of 'Language.Haskell.TH.derivClaus'
derivClause ::
     Maybe (LDerivStrategy GhcPs)
  -> NonEmpty (LHsType GhcPs)
  -> LHsDerivingClause GhcPs
derivClause :: Maybe (LDerivStrategy GhcPs)
-> NonEmpty (XRec GhcPs (HsType GhcPs)) -> LHsDerivingClause GhcPs
derivClause Maybe (LDerivStrategy GhcPs)
strat NonEmpty (XRec GhcPs (HsType GhcPs))
tys = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc NonEmpty (XRec GhcPs (HsType GhcPs))
tys forall a b. (a -> b) -> a -> b
$
    forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> LDerivClauseTys pass
-> HsDerivingClause pass
HsDerivingClause forall a. HasDefaultExt a => a
defExt Maybe (LDerivStrategy GhcPs)
strat forall a b. (a -> b) -> a -> b
$ forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc NonEmpty (XRec GhcPs (HsType GhcPs))
tys forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 902
      forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$
#endif
      forall a b. (a -> b) -> [a] -> [b]
map XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
implicitBndrs (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (XRec GhcPs (HsType GhcPs))
tys)

-- | Inverse of 'derivClause'
viewDerivClause ::
     LHsDerivingClause GhcPs
  -> (Maybe (LDerivStrategy GhcPs), [LHsType GhcPs])
#if __GLASGOW_HASKELL__ >= 902
viewDerivClause :: LHsDerivingClause GhcPs
-> (Maybe (LDerivStrategy GhcPs), [XRec GhcPs (HsType GhcPs)])
viewDerivClause (L SrcSpan
_ (HsDerivingClause XCHsDerivingClause GhcPs
_ Maybe (LDerivStrategy GhcPs)
mStrat (L SrcSpanAnnC
_ (DctMulti XDctMulti GhcPs
_ [LHsSigType GhcPs]
tys)))) =
    (Maybe (LDerivStrategy GhcPs)
mStrat, forall a b. (a -> b) -> [a] -> [b]
map LHsSigType GhcPs -> XRec GhcPs (HsType GhcPs)
viewImplicitBndrs [LHsSigType GhcPs]
tys)
viewDerivClause (L SrcSpan
_ (HsDerivingClause XCHsDerivingClause GhcPs
_ Maybe (LDerivStrategy GhcPs)
mStrat (L SrcSpanAnnC
_ (DctSingle XDctSingle GhcPs
_ LHsSigType GhcPs
ty)))) =
    (Maybe (LDerivStrategy GhcPs)
mStrat, forall a b. (a -> b) -> [a] -> [b]
map LHsSigType GhcPs -> XRec GhcPs (HsType GhcPs)
viewImplicitBndrs [LHsSigType GhcPs
ty])
#else
viewDerivClause (L _ (HsDerivingClause _ mStrat (L _ tys))) =
    (mStrat, map viewImplicitBndrs tys)
#endif
#if __GLASGOW_HASKELL__ < 900
viewDerivClause _ = panic "viewDerivClause"
#endif

pattern DerivClause ::
     Maybe (LDerivStrategy GhcPs)
  -> NonEmpty (LHsType GhcPs)
  -> LHsDerivingClause GhcPs
pattern $bDerivClause :: Maybe (LDerivStrategy GhcPs)
-> NonEmpty (XRec GhcPs (HsType GhcPs)) -> LHsDerivingClause GhcPs
$mDerivClause :: forall {r}.
LHsDerivingClause GhcPs
-> (Maybe (LDerivStrategy GhcPs)
    -> NonEmpty (XRec GhcPs (HsType GhcPs)) -> r)
-> ((# #) -> r)
-> r
DerivClause strat tys <-
          (viewDerivClause -> (strat, NE.nonEmpty -> Just tys))
  where
    DerivClause = Maybe (LDerivStrategy GhcPs)
-> NonEmpty (XRec GhcPs (HsType GhcPs)) -> LHsDerivingClause GhcPs
derivClause

-- | Equivalent of 'Language.Haskell.TH.Lib.instanceD'
--
-- Unlike in TH, the regular bindings and associated types are separate args.
instanceD ::
     [LHsType GhcPs]            -- ^ Context
  -> LHsType GhcPs              -- ^ Head
  -> [(LRdrName, LHsExpr GhcPs)] -- ^ Bindings
  -> [LTyFamInstDecl GhcPs]     -- ^ Associated types
  -> LHsDecl GhcPs
instanceD :: [XRec GhcPs (HsType GhcPs)]
-> XRec GhcPs (HsType GhcPs)
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD [XRec GhcPs (HsType GhcPs)]
ctxt XRec GhcPs (HsType GhcPs)
hd [(LRdrName, LHsExpr GhcPs)]
binds [LTyFamInstDecl GhcPs]
assocTypes = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
hd forall a b. (a -> b) -> a -> b
$
    forall p. XInstD p -> InstDecl p -> HsDecl p
InstD forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$ forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$ ClsInstDecl {
        cid_ext :: XCClsInstDecl GhcPs
cid_ext           = forall a. HasDefaultExt a => a
defExt
      , cid_poly_ty :: LHsSigType GhcPs
cid_poly_ty       = XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
implicitBndrs ([XRec GhcPs (HsType GhcPs)]
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
qualT [XRec GhcPs (HsType GhcPs)]
ctxt XRec GhcPs (HsType GhcPs)
hd)
      , cid_binds :: LHsBinds GhcPs
cid_binds         = forall a. [a] -> Bag a
listToBag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs
simpleBinding) [(LRdrName, LHsExpr GhcPs)]
binds
      , cid_sigs :: [LSig GhcPs]
cid_sigs          = []
      , cid_tyfam_insts :: [LTyFamInstDecl GhcPs]
cid_tyfam_insts   = [LTyFamInstDecl GhcPs]
assocTypes
      , cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_datafam_insts = []
      , cid_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
cid_overlap_mode  = forall a. Maybe a
Nothing
      }
  where
    qualT :: [LHsType GhcPs] -> LHsType GhcPs -> LHsType GhcPs
    qualT :: [XRec GhcPs (HsType GhcPs)]
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
qualT []        XRec GhcPs (HsType GhcPs)
a = XRec GhcPs (HsType GhcPs)
a
    qualT ctx :: [XRec GhcPs (HsType GhcPs)]
ctx@(XRec GhcPs (HsType GhcPs)
c:[XRec GhcPs (HsType GhcPs)]
_) XRec GhcPs (HsType GhcPs)
a = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
c forall a b. (a -> b) -> a -> b
$
        forall pass.
XQualTy pass
-> Maybe (LHsContext pass) -> LHsType pass -> HsType pass
HsQualTy
          forall a. HasDefaultExt a => a
defExt
#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904
          (forall a. a -> Maybe a
Just (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
c [XRec GhcPs (HsType GhcPs)]
ctx))
#else
          (inheritLoc c ctx)
#endif
          XRec GhcPs (HsType GhcPs)
a

-- | Equivalent of 'Language.Haskell.TH.Lib.classD'
classD ::
     [LHsType GhcPs]            -- ^ Class context
  -> LRdrName                    -- ^ Class name
  -> [LHsTyVarBndr GhcPs]       -- ^ Type variables
  -> [(LRdrName, LHsType GhcPs)] -- ^ Method signatures
  -> LHsDecl GhcPs
classD :: [XRec GhcPs (HsType GhcPs)]
-> LRdrName
-> [LHsTyVarBndr GhcPs]
-> [(LRdrName, XRec GhcPs (HsType GhcPs))]
-> LHsDecl GhcPs
classD = \[XRec GhcPs (HsType GhcPs)]
ctx LRdrName
name [LHsTyVarBndr GhcPs]
clsVars [(LRdrName, XRec GhcPs (HsType GhcPs))]
sigs -> forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$
    forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$ ClassDecl {
        tcdCExt :: XClassDecl GhcPs
tcdCExt   = forall a. HasDefaultExt a => a
defExt
#if __GLASGOW_HASKELL__ >= 902
      , tcdCtxt :: Maybe (XRec GhcPs [XRec GhcPs (HsType GhcPs)])
tcdCtxt   = forall a. a -> Maybe a
Just (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name [XRec GhcPs (HsType GhcPs)]
ctx)
#else
      , tcdCtxt   = inheritLoc name ctx
#endif
      , tcdLName :: LIdP GhcPs
tcdLName  = forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name
      , tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
clsVars
      , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
      , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs    = []
      , tcdSigs :: [LSig GhcPs]
tcdSigs   = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LRdrName -> XRec GhcPs (HsType GhcPs) -> LSig GhcPs
classOpSig) [(LRdrName, XRec GhcPs (HsType GhcPs))]
sigs
      , tcdMeths :: LHsBinds GhcPs
tcdMeths  = forall a. Bag a
emptyBag
      , tcdATs :: [LFamilyDecl GhcPs]
tcdATs    = []
      , tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = []
      , tcdDocs :: [LDocDecl GhcPs]
tcdDocs   = []
      }
  where
    classOpSig :: LRdrName -> LHsType GhcPs -> LSig GhcPs
    classOpSig :: LRdrName -> XRec GhcPs (HsType GhcPs) -> LSig GhcPs
classOpSig LRdrName
name XRec GhcPs (HsType GhcPs)
ty = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
name forall a b. (a -> b) -> a -> b
$
        forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig forall a. HasDefaultExt a => a
defExt Bool
False [forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name] (XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
implicitBndrs XRec GhcPs (HsType GhcPs)
ty)

-- | Approximate equivalent of 'Language.Haskell.TH.Lib.tySynEqn'
tySynEqn ::
     LRdrName         -- ^ Type family name
  -> [LHsType GhcPs] -- ^ Equation LHS
  -> LHsType GhcPs   -- ^ Equation RHS
  -> LTyFamInstDecl GhcPs
tySynEqn :: LRdrName
-> [XRec GhcPs (HsType GhcPs)]
-> XRec GhcPs (HsType GhcPs)
-> LTyFamInstDecl GhcPs
tySynEqn LRdrName
name [XRec GhcPs (HsType GhcPs)]
pats XRec GhcPs (HsType GhcPs)
val = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
val forall a b. (a -> b) -> a -> b
$
    forall pass.
XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl
#if __GLASGOW_HASKELL__ >= 902
      forall a. HasDefaultExt a => a
defExt forall a b. (a -> b) -> a -> b
$
#else
      $ implicitBndrs $
#endif
        forall pass rhs.
XCFamEqn pass rhs
-> LIdP pass
-> HsOuterFamEqnTyVarBndrs pass
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn forall a. HasDefaultExt a => a
defExt
               (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name)
#if __GLASGOW_HASKELL__ >= 902
               (forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
HsOuterImplicit forall a. HasDefaultExt a => a
defExt)
#else
               Nothing
#endif
               (forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [XRec GhcPs (HsType GhcPs)]
pats)
               LexicalFixity
Prefix
               XRec GhcPs (HsType GhcPs)
val

{-------------------------------------------------------------------------------
  Pragmas

  NOTE: We work with 'LRdrName' everywhere, but 'AnnProvenance' /already/ wraps
  the @name@ type in @Located@.
-------------------------------------------------------------------------------}

type AnnProvenancePs = AnnProvenance
#if __GLASGOW_HASKELL__ >= 902
    GhcPs
#else
    RdrName
#endif

-- | Equivalent of 'Language.Haskell.TH.Lib.typeAnnotation'
typeAnnotation :: LRdrName -> AnnProvenancePs
typeAnnotation :: LRdrName -> AnnProvenancePs
typeAnnotation LRdrName
name = forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
name)

-- | Inverse to 'typeAnnotation'
viewTypeAnnotation :: AnnProvenancePs -> Maybe LRdrName
viewTypeAnnotation :: AnnProvenancePs -> Maybe LRdrName
viewTypeAnnotation (TypeAnnProvenance LIdP GhcPs
name) = forall a. a -> Maybe a
Just (forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
name)
viewTypeAnnotation AnnProvenancePs
_otherwise               = forall a. Maybe a
Nothing

pattern TypeAnnotation :: LRdrName -> AnnProvenancePs
pattern $bTypeAnnotation :: LRdrName -> AnnProvenancePs
$mTypeAnnotation :: forall {r}. AnnProvenancePs -> (LRdrName -> r) -> ((# #) -> r) -> r
TypeAnnotation name <- (viewTypeAnnotation -> Just name)
  where
    TypeAnnotation = LRdrName -> AnnProvenancePs
typeAnnotation

-- | Equivalent of 'Language.Haskell.TH.Lib.pragAnnD'
pragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs
pragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs
pragAnnD AnnProvenancePs
prov LHsExpr GhcPs
value =
    forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance pass
-> XRec pass (HsExpr pass)
-> AnnDecl pass
HsAnnotation
      forall a. HasDefaultExt a => a
defExt
      SourceText
NoSourceText
      AnnProvenancePs
prov
      LHsExpr GhcPs
value

viewPragAnnD :: AnnDecl GhcPs -> (AnnProvenancePs, LHsExpr GhcPs)
viewPragAnnD :: AnnDecl GhcPs -> (AnnProvenancePs, LHsExpr GhcPs)
viewPragAnnD (HsAnnotation XHsAnnotation GhcPs
_ SourceText
_ AnnProvenancePs
prov LHsExpr GhcPs
value) = (AnnProvenancePs
prov, LHsExpr GhcPs
value)
#if __GLASGOW_HASKELL__ < 900
viewPragAnnD _ = panic "viewPragAnnD"
#endif

pattern PragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs
pattern $bPragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs
$mPragAnnD :: forall {r}.
AnnDecl GhcPs
-> (AnnProvenancePs -> LHsExpr GhcPs -> r) -> ((# #) -> r) -> r
PragAnnD prov value <- (viewPragAnnD -> (prov, value))
  where
    PragAnnD = AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs
pragAnnD

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ >= 902
implicitBndrs :: LHsType GhcPs -> LHsSigType GhcPs
implicitBndrs :: XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
implicitBndrs XRec GhcPs (HsType GhcPs)
t = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc XRec GhcPs (HsType GhcPs)
t (forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig forall a. HasDefaultExt a => a
defExt (forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
HsOuterImplicit forall a. HasDefaultExt a => a
defExt) XRec GhcPs (HsType GhcPs)
t)

viewImplicitBndrs :: LHsSigType GhcPs -> LHsType GhcPs
viewImplicitBndrs :: LHsSigType GhcPs -> XRec GhcPs (HsType GhcPs)
viewImplicitBndrs (L SrcSpanAnnA
_ (HsSig XHsSig GhcPs
_ HsOuterSigTyVarBndrs GhcPs
_ XRec GhcPs (HsType GhcPs)
ty)) = XRec GhcPs (HsType GhcPs)
ty

#else
implicitBndrs :: a -> HsImplicitBndrs GhcPs a
implicitBndrs a = HsIB defExt a

viewImplicitBndrs :: HsImplicitBndrs GhcPs a -> a
viewImplicitBndrs (HsIB _ a) = a
#if __GLASGOW_HASKELL__ < 900
viewImplicitBndrs _ = panic "viewImplicitBndrs"
#endif
#endif

-- | Simple binding (without patterns)
simpleBinding :: LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs
simpleBinding :: LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs
simpleBinding LRdrName
fnName LHsExpr GhcPs
body = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
fnName forall a b. (a -> b) -> a -> b
$
    LRdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
mkFunBind LRdrName
fnName [LMatch GhcPs (LHsExpr GhcPs)
match]
  where
    grhs :: GRHSs GhcPs (LHsExpr GhcPs)
    grhs :: GRHSs GhcPs (LHsExpr GhcPs)
grhs = LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
simpleGHRSs LHsExpr GhcPs
body

    match :: LMatch GhcPs (LHsExpr GhcPs)
    match :: LMatch GhcPs (LHsExpr GhcPs)
match = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LRdrName
fnName forall a b. (a -> b) -> a -> b
$
        forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match forall a. HasDefaultExt a => a
defExt
              (forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs (forall e ann. Located e -> LocatedAn ann e
reLocA LRdrName
fnName) LexicalFixity
Prefix SrcStrictness
NoSrcStrict)
              []
              GRHSs GhcPs (LHsExpr GhcPs)
grhs

-- | Simple guarded RHS (no guards)
simpleGHRSs :: LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
simpleGHRSs :: LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
simpleGHRSs LHsExpr GhcPs
body =
    forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs forall a. HasDefaultExt a => a
defExt
          [forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
body forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. HasDefaultExt a => a
defExt [] LHsExpr GhcPs
body]
          (forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc LHsExpr GhcPs
body forall a b. (a -> b) -> a -> b
$ forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds forall a. HasDefaultExt a => a
defExt)