-- Copyright 2019 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module provides combinators for constructing Haskell declarations.
module GHC.SourceGen.Decl
    ( HsDecl'
      -- * Type declarations
    , type'
    , newtype'
    , data'
      -- ** Data constructors
    , ConDecl'
    , prefixCon
    , infixCon
    , recordCon
    , Field
    , field
    , strict
    , lazy
      -- ** Deriving clauses
    , HsDerivingClause'
    , deriving'
    , derivingStock
    , derivingAnyclass
    , derivingNewtype
#if MIN_VERSION_ghc(8,6,0)
    , derivingVia
#endif
    , standaloneDeriving
    , standaloneDerivingStock
    , standaloneDerivingNewtype
    , standaloneDerivingAnyclass
      -- * Class declarations
    , class'
    , ClassDecl
    , funDep
      -- * Instance declarations
    , instance'
    , RawInstDecl
    , HasTyFamInst(..)
    , tyFamInst
      -- * Pattern synonyms
    , patSynSigs
    , patSynSig
    , patSynBind
    ) where

#if MIN_VERSION_ghc(9,0,0)
import GHC (LexicalFixity(Prefix))
import GHC.Data.Bag (listToBag)

#if MIN_VERSION_ghc(9,6,0)
import GHC (GhcPs, LayoutInfo (NoLayoutInfo))
#else
import GHC.Types.SrcLoc (LayoutInfo(NoLayoutInfo))
#endif

#else
import BasicTypes (LexicalFixity(Prefix))
import Bag (listToBag)
#endif
#if !MIN_VERSION_ghc(8,6,0)
import BasicTypes (DerivStrategy(..))
#endif
import GHC.Hs.Binds
import GHC.Hs.Decls

import GHC.Hs.Type
    ( ConDeclField(..)
    , FieldOcc(..)
    , HsConDetails(..)
#if !MIN_VERSION_ghc(9,2,0)
    , HsImplicitBndrs (..)
#endif
#if MIN_VERSION_ghc(9,2,0)
    , HsOuterTyVarBndrs (..)
#endif
    , HsSrcBang(..)
    , HsType(..)
    , LHsType
#if MIN_VERSION_ghc(8,6,0)
    , HsWildCardBndrs (..)
#endif
#if MIN_VERSION_ghc(8,8,0)
    , HsArg(..)
#endif
    , SrcStrictness(..)
    , SrcUnpackedness(..)
#if MIN_VERSION_ghc(9,0,0)
    , hsUnrestricted
#endif
    )

#if MIN_VERSION_ghc(9,2,0)
import GHC.Parser.Annotation (AnnSortKey(..), EpAnn(..))
#elif MIN_VERSION_ghc(8,10,0)
import GHC.Hs.Extension (NoExtField(NoExtField))
#elif MIN_VERSION_ghc(8,6,0)
import GHC.Hs.Extension (NoExt(NoExt))
#else
import PlaceHolder (PlaceHolder(..))
#endif

import GHC.SourceGen.Binds.Internal
import GHC.SourceGen.Lit.Internal (noSourceText)
import GHC.SourceGen.Name
import GHC.SourceGen.Name.Internal
import GHC.SourceGen.Syntax.Internal
import GHC.SourceGen.Type.Internal
import GHC.Hs

-- | A definition that can appear in the body of a @class@ declaration.
--
-- 'ClassDecl' definitions may be constructed using 'funDep' or using the
-- instance of 'HasValBind'.  For more details, see the documentation of
-- that function, and of "GHC.SourceGen.Binds" overall.
data ClassDecl
    = ClassSig Sig'
    | ClassDefaultMethod HsBind'
    | ClassFunDep [RdrNameStr] [RdrNameStr]
    -- TODO: type families

instance HasValBind ClassDecl where
    sigB :: Sig' -> ClassDecl
sigB = Sig' -> ClassDecl
ClassSig
    bindB :: HsBind' -> ClassDecl
bindB = HsBind' -> ClassDecl
ClassDefaultMethod

-- | A functional dependency for a class.
--
-- > | a, b -> c
-- > =====
-- > funDep ["a", "b"] ["c"]
--
-- > class Ident a b | a -> b, b -> a where
-- >   ident :: a -> b
-- > =====
-- > class' [] "Ident" ["a", "b"]
-- >    [ funDep ["a"] ["b"]
-- >    , funDep ["b"] ["a"]
-- >    , typeSig "ident" $ var "a" --> var "b"
-- >    ]
funDep :: [RdrNameStr] -> [RdrNameStr] -> ClassDecl
funDep :: [RdrNameStr] -> [RdrNameStr] -> ClassDecl
funDep = [RdrNameStr] -> [RdrNameStr] -> ClassDecl
ClassFunDep

-- TODO:
-- - kinded variables
-- - fixity of declaration
-- - functional dependencies
-- - associated types

-- | A class declaration.
--
-- > class (Real a, Enum a) => Integral a where
-- >   divMod :: a -> a -> (a, a)
-- >   div :: a -> a -> a
-- >   div x y = fst (divMod x y)
-- > =====
-- > let a = var "a"
-- > in class'
-- >      [var "Real" @@ a, var "Enum" @@ a]
-- >      "Integral"
-- >      [bvar "a"]
-- >      [ typeSig "divMod" $ a --> a --> tuple [a, a]
-- >      , typeSig "div" $ a --> a --> a
-- >      , funBind "div"
-- >          $ match [bvar "x", bvar "y"]
-- >             $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")
-- >      ]
class'
    :: [HsType'] -- ^ Context
    -> OccNameStr -- ^ Class name
    -> [HsTyVarBndr'] -- ^ Type parameters
    -> [ClassDecl] -- ^ Class declarations
    -> HsDecl'
class' :: [HsType'] -> OccNameStr -> [HsTyVarBndr'] -> [ClassDecl] -> HsDecl'
class' [HsType']
context OccNameStr
name [HsTyVarBndr']
vars [ClassDecl]
decls
    = forall a. (NoExtField -> a) -> a
noExt forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD forall a b. (a -> b) -> a -> b
$ ClassDecl
            { tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = forall {a}. a -> Maybe a
toHsContext forall a b. (a -> b) -> a -> b
$ forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [HsType']
context
#if MIN_VERSION_ghc(9,6,0)
            , tcdLayout = NoLayoutInfo
            , tcdCExt = (EpAnnNotUsed, NoAnnSortKey)
#elif MIN_VERSION_ghc(9,2,0)
            , tcdCExt :: XClassDecl GhcPs
tcdCExt = (forall ann. EpAnn ann
EpAnnNotUsed, AnnSortKey
NoAnnSortKey, LayoutInfo
NoLayoutInfo)
#elif MIN_VERSION_ghc(9,0,0)
            , tcdCExt = NoLayoutInfo
#elif MIN_VERSION_ghc(8,10,0)
            , tcdCExt = NoExtField
#elif MIN_VERSION_ghc(8,6,0)
            , tcdCExt = NoExt
#else
            , tcdFVs = PlaceHolder
#endif
            , tcdLName :: LIdP GhcPs
tcdLName = RdrNameStr -> LocatedN RdrName
typeRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
name
            , tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = [HsTyVarBndr'] -> LHsQTyVars GhcPs
mkQTyVars [HsTyVarBndr']
vars
            , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
            , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = [ forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ [LIdP GhcPs] -> [LIdP GhcPs] -> FunDep GhcPs
funDep' (forall a b. (a -> b) -> [a] -> [b]
map RdrNameStr -> LocatedN RdrName
typeRdrName [RdrNameStr]
xs) (forall a b. (a -> b) -> [a] -> [b]
map RdrNameStr -> LocatedN RdrName
typeRdrName [RdrNameStr]
ys)
                       | ClassFunDep [RdrNameStr]
xs [RdrNameStr]
ys <- [ClassDecl]
decls
                       ]
            , tcdSigs :: [LSig GhcPs]
tcdSigs = [forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated Sig'
sig | ClassSig Sig'
sig <- [ClassDecl]
decls]
            , tcdMeths :: LHsBinds GhcPs
tcdMeths =
                forall a. [a] -> Bag a
listToBag [forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsBind'
bind | ClassDefaultMethod HsBind'
bind <- [ClassDecl]
decls]
            , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = []  -- Associated types
            , tcdATDefs :: [LTyFamDefltDecl GhcPs]
tcdATDefs = []  -- Associated type defaults
            , tcdDocs :: [LDocDecl GhcPs]
tcdDocs = []  -- Haddocks
            }
  where
#if MIN_VERSION_ghc(9,2,0)
    funDep' :: [LIdP GhcPs] -> [LIdP GhcPs] -> FunDep GhcPs
funDep' = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
FunDep
#else
    funDep' = (,)
#endif
#if MIN_VERSION_ghc(9,2,0)
    toHsContext :: a -> Maybe a
toHsContext = forall {a}. a -> Maybe a
Just
#else
    toHsContext = id
#endif

-- | A definition that can appear in the body of an @instance@ declaration.
--
-- 'RawInstDecl' definitions may be constructed using its class instances, e.g.,
-- 'HasValBind'.  For more details, see the documentation of those classes.
data RawInstDecl
    = InstSig Sig'
    | InstBind HsBind'
    | InstTyFam TyFamInstDecl'

instance HasValBind RawInstDecl where
    sigB :: Sig' -> RawInstDecl
sigB = Sig' -> RawInstDecl
InstSig
    bindB :: HsBind' -> RawInstDecl
bindB = HsBind' -> RawInstDecl
InstBind

-- | An instance declaration.
--
-- > instance Show Bool where
-- >   show :: Bool -> String -- Requires the InstanceSigs extension
-- >   show True = "True"
-- >   show False = "False"
-- > =====
-- > instance' (var "Show" @@ var "Bool")
-- >   [ typeSig "show" $ var "Bool" --> var "String"
-- >   , funBinds "show"
-- >       [ match [bvar "True"] $ string "True"
-- >       , match [bvar "False"] $ string "False"
-- >       ]
-- >   ]
instance' :: HsType' -> [RawInstDecl] -> HsDecl'
instance' :: HsType' -> [RawInstDecl] -> HsDecl'
instance' HsType'
ty [RawInstDecl]
decls = forall a. (NoExtField -> a) -> a
noExt forall p. XInstD p -> InstDecl p -> HsDecl p
InstD  forall a b. (a -> b) -> a -> b
$ forall a. (NoExtField -> a) -> a
noExt forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD forall a b. (a -> b) -> a -> b
$ ClsInstDecl
    { cid_poly_ty :: LHsSigType GhcPs
cid_poly_ty = HsType' -> LHsSigType GhcPs
sigType HsType'
ty
#if MIN_VERSION_ghc(9,2,0)
    , cid_ext :: XCClsInstDecl GhcPs
cid_ext = (forall ann. EpAnn ann
EpAnnNotUsed, AnnSortKey
NoAnnSortKey)
#elif MIN_VERSION_ghc(8,10,0)
    , cid_ext = NoExtField
#elif MIN_VERSION_ghc(8,6,0)
    , cid_ext = NoExt
#endif
    , cid_binds :: LHsBinds GhcPs
cid_binds = forall a. [a] -> Bag a
listToBag [forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsBind'
b | InstBind HsBind'
b <- [RawInstDecl]
decls]
    , cid_sigs :: [LSig GhcPs]
cid_sigs = [forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated Sig'
sig | InstSig Sig'
sig <- [RawInstDecl]
decls]
    , cid_tyfam_insts :: [LTyFamDefltDecl GhcPs]
cid_tyfam_insts = [forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ TyFamInstDecl'
t | InstTyFam TyFamInstDecl'
t <- [RawInstDecl]
decls]
    , cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_datafam_insts = []
    , cid_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
cid_overlap_mode = forall a. Maybe a
Nothing
    }

-- | Terms which can contain a type instance declaration.
--
-- To use this class, call 'tyFamInst'.
class HasTyFamInst t where
    tyFamInstD :: TyFamInstDecl' -> t

instance HasTyFamInst HsDecl' where
    tyFamInstD :: TyFamInstDecl' -> HsDecl'
tyFamInstD = forall a. (NoExtField -> a) -> a
noExt forall p. XInstD p -> InstDecl p -> HsDecl p
InstD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (NoExtField -> a) -> a
noExt forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD

instance HasTyFamInst RawInstDecl where
    tyFamInstD :: TyFamInstDecl' -> RawInstDecl
tyFamInstD = TyFamInstDecl' -> RawInstDecl
InstTyFam

-- | A type family instance.
--
-- > type Elt String = Char
-- > =====
-- > tyFamInst "Elt" [var "String"] (var "Char")
tyFamInst :: HasTyFamInst t => RdrNameStr -> [HsType'] -> HsType' -> t
tyFamInst :: forall t. HasTyFamInst t => RdrNameStr -> [HsType'] -> HsType' -> t
tyFamInst RdrNameStr
name [HsType']
params HsType'
ty = forall t. HasTyFamInst t => TyFamInstDecl' -> t
tyFamInstD
        forall a b. (a -> b) -> a -> b
$ FamEqn GhcPs (XRec GhcPs HsType') -> TyFamInstDecl'
tyFamInstDecl
        forall a b. (a -> b) -> a -> b
$ forall {pass} {rhs} {ann}.
(XCFamEqn pass rhs ~ EpAnn ann) =>
XRec pass (IdP pass)
-> HsOuterFamEqnTyVarBndrs pass
-> [XRec pass (HsType pass)]
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
famEqn
            (RdrNameStr -> LocatedN RdrName
typeRdrName RdrNameStr
name)
            forall {flag}. HsOuterTyVarBndrs flag GhcPs
eqn_bndrs
            (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [HsType']
params)
            LexicalFixity
Prefix
            (forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsType'
ty)
  where
#if MIN_VERSION_ghc(9,2,0)
    tyFamInstDecl :: FamEqn GhcPs (XRec GhcPs HsType') -> TyFamInstDecl'
tyFamInstDecl = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl
#else
    tyFamInstDecl = TyFamInstDecl . withPlaceHolder . noExt (withPlaceHolder HsIB)
#endif
#if MIN_VERSION_ghc(9,2,0)
    famEqn :: XRec pass (IdP pass)
-> HsOuterFamEqnTyVarBndrs pass
-> [XRec pass (HsType pass)]
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
famEqn XRec pass (IdP pass)
tycon HsOuterFamEqnTyVarBndrs pass
bndrs [XRec pass (HsType pass)]
pats = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass rhs.
XCFamEqn pass rhs
-> LIdP pass
-> HsOuterFamEqnTyVarBndrs pass
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn XRec pass (IdP pass)
tycon HsOuterFamEqnTyVarBndrs pass
bndrs (forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [XRec pass (HsType pass)]
pats)
#elif MIN_VERSION_ghc(8,8,0)
    famEqn tycon bndrs pats = noExt FamEqn tycon bndrs (map HsValArg pats)
#else
    famEqn tycon _ = noExt FamEqn tycon
#endif
#if MIN_VERSION_ghc(9,2,0)
    eqn_bndrs :: HsOuterTyVarBndrs flag GhcPs
eqn_bndrs = forall a. (NoExtField -> a) -> a
noExt forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
HsOuterImplicit
#else
    eqn_bndrs = Nothing
#endif

-- | Declares a type synonym.
--
-- > type A a b = B b a
-- > =====
-- > type' "A" [bvar "a", bvar "b"] $ var "B" @@ var "b" @@ var "a"
type' :: OccNameStr -> [HsTyVarBndr'] -> HsType' -> HsDecl'
type' :: OccNameStr -> [HsTyVarBndr'] -> HsType' -> HsDecl'
type' OccNameStr
name [HsTyVarBndr']
vars HsType'
t =
    forall a. (NoExtField -> a) -> a
noExt forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD forall a b. (a -> b) -> a -> b
$ forall a. a -> a
withPlaceHolder forall a b. (a -> b) -> a -> b
$ forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XSynDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl (RdrNameStr -> LocatedN RdrName
typeRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
name)
        ([HsTyVarBndr'] -> LHsQTyVars GhcPs
mkQTyVars [HsTyVarBndr']
vars)
        LexicalFixity
Prefix
        (forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsType'
t)

newOrDataType
    :: NewOrData
    -> OccNameStr
    -> [HsTyVarBndr']
    -> [ConDecl']
    -> [HsDerivingClause']
    -> HsDecl'
newOrDataType :: NewOrData
-> OccNameStr
-> [HsTyVarBndr']
-> [ConDecl']
-> [HsDerivingClause']
-> HsDecl'
newOrDataType NewOrData
newOrData OccNameStr
name [HsTyVarBndr']
vars [ConDecl']
conDecls [HsDerivingClause']
derivs
    = forall a. (NoExtField -> a) -> a
noExt forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD forall a b. (a -> b) -> a -> b
$ forall a. a -> a
withPlaceHolder forall a b. (a -> b) -> a -> b
$ forall a. a -> a
withPlaceHolder forall a b. (a -> b) -> a -> b
$
        forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XDataDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl (RdrNameStr -> LocatedN RdrName
typeRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
name)
            ([HsTyVarBndr'] -> LHsQTyVars GhcPs
mkQTyVars [HsTyVarBndr']
vars)
            LexicalFixity
Prefix
            forall a b. (a -> b) -> a -> b
$ forall a. (NoExtField -> a) -> a
noExt forall pass.
XCHsDataDefn pass
-> NewOrData
-> Maybe (LHsContext pass)
-> Maybe (XRec pass CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn
#if !MIN_VERSION_ghc(9,6,0)
                NewOrData
newOrData
#endif
                forall a. Maybe a
cxt
                forall a. Maybe a
Nothing
                forall a. Maybe a
Nothing
#if MIN_VERSION_ghc(9,6,0)
                (case newOrData of
                    NewType -> case conDecls of
                        [decl] -> NewTypeCon $ mkLocated decl
                        _ -> error "NewTypeCon with more than one decl"
                    DataType -> DataTypeCons False (map mkLocated conDecls)
                )  
#else
                (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [ConDecl']
conDecls)
#endif
#if MIN_VERSION_ghc(9,4,0)
                (toHsDeriving $ map mkLocated derivs)
#else
                (forall a. a -> a
toHsDeriving forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Located e
builtLoc [HsDerivingClause']
derivs)
#endif
  where
#if MIN_VERSION_ghc(9,2,0)
    cxt :: Maybe a
cxt = forall a. Maybe a
Nothing
#else
    cxt = builtLoc []
#endif
#if MIN_VERSION_ghc(9,2,0)
    toHsDeriving :: a -> a
toHsDeriving = forall a. a -> a
id
#else
    toHsDeriving = mkLocated
#endif

-- | A newtype declaration.
--
-- > newtype Const a b = Const a deriving Eq
-- > =====
-- > newtype' "Const" [bvar "a", bvar "b"]
-- >    (conDecl "Const" [var "a"])
-- >    [var "Show"]
newtype' :: OccNameStr -> [HsTyVarBndr'] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
newtype' :: OccNameStr
-> [HsTyVarBndr'] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
newtype' OccNameStr
name [HsTyVarBndr']
vars ConDecl'
conD = NewOrData
-> OccNameStr
-> [HsTyVarBndr']
-> [ConDecl']
-> [HsDerivingClause']
-> HsDecl'
newOrDataType NewOrData
NewType OccNameStr
name [HsTyVarBndr']
vars [ConDecl'
conD]

-- | A data declaration.
--
-- > data Either a b = Left a | Right b
-- >    deriving Show
-- > =====
-- > data' "Either" [bvar "a", bvar "b"]
-- >   [ conDecl "Left" [var "a"]
-- >   , conDecl "Right" [var "b"]
-- >   ]
-- >   [var "Show"]
data' :: OccNameStr -> [HsTyVarBndr'] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
data' :: OccNameStr
-> [HsTyVarBndr'] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
data' = NewOrData
-> OccNameStr
-> [HsTyVarBndr']
-> [ConDecl']
-> [HsDerivingClause']
-> HsDecl'
newOrDataType NewOrData
DataType

-- | Declares a Haskell-98-style prefix constructor for a data or type
-- declaration.
--
-- > Foo a Int
-- > =====
-- > prefixCon "Foo" [field (var "a"), field (var "Int")]
prefixCon :: OccNameStr -> [Field] -> ConDecl'
prefixCon :: OccNameStr -> [Field] -> ConDecl'
prefixCon OccNameStr
name [Field]
fields = OccNameStr -> HsConDeclDetails' -> ConDecl'
renderCon98Decl OccNameStr
name
    forall a b. (a -> b) -> a -> b
$ forall {arg} {tyarg} {rec}. [arg] -> HsConDetails tyarg arg rec
prefixCon' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a pass. a -> HsScaled pass a
hsUnrestricted forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> XRec GhcPs HsType'
renderField) [Field]
fields
  where
#if MIN_VERSION_ghc(9,2,0)
    prefixCon' :: [arg] -> HsConDetails tyarg arg rec
prefixCon' = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon []
#else
    prefixCon' = PrefixCon
#endif

-- | Declares a Haskell-98-style infix constructor for a data or type
-- declaration.
--
-- > A b :+: C d
-- > =====
-- > infixCon (field (var "A" @@ var "b")) ":+:" (field (Var "C" @@ var "d"))
infixCon :: Field -> OccNameStr -> Field -> ConDecl'
infixCon :: Field -> OccNameStr -> Field -> ConDecl'
infixCon Field
f OccNameStr
name Field
f' = OccNameStr -> HsConDeclDetails' -> ConDecl'
renderCon98Decl OccNameStr
name
    forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon (forall a pass. a -> HsScaled pass a
hsUnrestricted forall a b. (a -> b) -> a -> b
$ Field -> XRec GhcPs HsType'
renderField Field
f) (forall a pass. a -> HsScaled pass a
hsUnrestricted forall a b. (a -> b) -> a -> b
$ Field -> XRec GhcPs HsType'
renderField Field
f')

-- | Declares Haskell-98-style record constructor for a data or type
-- declaration.
--
-- > A { x :: B, y :: C }
-- > =====
-- > recordCon "A" [("x", var "B"), ("y", var "C")]
recordCon :: OccNameStr -> [(OccNameStr, Field)] -> ConDecl'
recordCon :: OccNameStr -> [(OccNameStr, Field)] -> ConDecl'
recordCon OccNameStr
name [(OccNameStr, Field)]
fields = OccNameStr -> HsConDeclDetails' -> ConDecl'
renderCon98Decl OccNameStr
name
    forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon forall a b. (a -> b) -> a -> b
$ forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {ann}.
(OccNameStr, Field)
-> GenLocated (SrcSpanAnn ann) (ConDeclField GhcPs)
mkLConDeclField [(OccNameStr, Field)]
fields
  where
    mkLConDeclField :: (OccNameStr, Field)
-> GenLocated (SrcSpanAnn ann) (ConDeclField GhcPs)
mkLConDeclField (OccNameStr
n, Field
f) =
        forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
ConDeclField
#if MIN_VERSION_ghc(9,4,0)
                        [mkLocated $ withPlaceHolder $ noExt FieldOcc $ valueRdrName $ unqual n]
#else
                        [forall e. e -> Located e
builtLoc forall a b. (a -> b) -> a -> b
$ forall a. a -> a
withPlaceHolder forall a b. (a -> b) -> a -> b
$ forall a. (NoExtField -> a) -> a
noExt forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc forall a b. (a -> b) -> a -> b
$ RdrNameStr -> LocatedN RdrName
valueRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
n]
#endif
                        (Field -> XRec GhcPs HsType'
renderField Field
f)
                        forall a. Maybe a
Nothing

-- | An individual argument of a data constructor.  Contains a type for the field,
-- and whether the field is strict or lazy.
data Field = Field
    { Field -> HsType'
fieldType :: HsType'
    , Field -> SrcStrictness
strictness :: SrcStrictness
    }

-- | A field with no explicit strictness annotations.
--
-- > A b
-- > =====
-- > field $ var "A" @@ var "b"
field :: HsType' -> Field
field :: HsType' -> Field
field HsType'
t = HsType' -> SrcStrictness -> Field
Field HsType'
t SrcStrictness
NoSrcStrict

-- | Give a field an explicit strictness annotation.  Overrides any such previous
-- annotations (for example, from 'lazy').
--
-- > !(A b)
-- > =====
-- > strict $ field $ var "A" @@ var "b"
strict :: Field -> Field
strict :: Field -> Field
strict Field
f = Field
f { strictness :: SrcStrictness
strictness = SrcStrictness
SrcStrict }

-- | Give a field an explicit laziness annotation.  This feature is useful in combination
-- with the @StrictData@ extension.  Overrides any such previous
-- annotations (for example, from 'strict').
--
-- > !(A b)
-- > =====
-- > strict $ field $ var "A" @@ var "b"
lazy :: Field -> Field
lazy :: Field -> Field
lazy Field
f = Field
f { strictness :: SrcStrictness
strictness = SrcStrictness
SrcLazy }

#if !MIN_VERSION_ghc(9,0,0)
hsUnrestricted :: a -> a
hsUnrestricted = id
#endif

renderField :: Field -> LHsType GhcPs
-- TODO: parenthesizeTypeForApp is an overestimate in the case of
-- rendering an infix or record type.
renderField :: Field -> XRec GhcPs HsType'
renderField Field
f = GenLocated (SrcSpanAnn AnnListItem) HsType'
-> GenLocated (SrcSpanAnn AnnListItem) HsType'
wrap forall a b. (a -> b) -> a -> b
$ XRec GhcPs HsType' -> XRec GhcPs HsType'
parenthesizeTypeForApp forall a b. (a -> b) -> a -> b
$ forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ Field -> HsType'
fieldType Field
f
  where
    wrap :: GenLocated (SrcSpanAnn AnnListItem) HsType'
-> GenLocated (SrcSpanAnn AnnListItem) HsType'
wrap = case Field -> SrcStrictness
strictness Field
f of
        SrcStrictness
NoSrcStrict -> forall a. a -> a
id
        SrcStrictness
s -> forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy forall a b. (a -> b) -> a -> b
$ forall a. (SourceText -> a) -> a
noSourceText SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SrcUnpackedness
NoSrcUnpack SrcStrictness
s)

renderCon98Decl :: OccNameStr -> HsConDeclDetails' -> ConDecl'
renderCon98Decl :: OccNameStr -> HsConDeclDetails' -> ConDecl'
renderCon98Decl OccNameStr
name HsConDeclDetails'
details =
    LIdP GhcPs
-> Bool
-> [XRec GhcPs (HsTyVarBndr Specificity GhcPs)]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails'
-> Maybe LHsDocString
-> ConDecl'
conDeclH98 (RdrNameStr -> LocatedN RdrName
typeRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
name) Bool
False [] forall a. Maybe a
Nothing HsConDeclDetails'
details forall a. Maybe a
Nothing
  where
#if MIN_VERSION_ghc(9,2,0)
    conDeclH98 :: LIdP GhcPs
-> Bool
-> [XRec GhcPs (HsTyVarBndr Specificity GhcPs)]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails'
-> Maybe LHsDocString
-> ConDecl'
conDeclH98 = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XConDeclH98 pass
-> LIdP pass
-> Bool
-> [LHsTyVarBndr Specificity pass]
-> Maybe (LHsContext pass)
-> HsConDeclH98Details pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98
#elif MIN_VERSION_ghc(8,6,0)
    conDeclH98 n = noExt ConDeclH98 n . builtLoc
#else
    conDeclH98 n _ _ = ConDeclH98 n Nothing
#endif

deriving' :: [HsType'] -> HsDerivingClause'
deriving' :: [HsType'] -> HsDerivingClause'
deriving' = Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay forall a. Maybe a
Nothing

derivingWay :: Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay :: Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay Maybe DerivStrategy'
way [HsType']
ts =
#if MIN_VERSION_ghc(9,4,0)
    withEpAnnNotUsed HsDerivingClause (fmap mkLocated way) $ mkLocated $ derivClauseTys $ map sigType ts
#else
    forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> LDerivClauseTys pass
-> HsDerivingClause pass
HsDerivingClause (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. e -> Located e
builtLoc Maybe DerivStrategy'
way) forall a b. (a -> b) -> a -> b
$ forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ forall {pass}.
(XDctSingle pass ~ NoExtField, XDctMulti pass ~ NoExtField) =>
[XRec pass (HsSigType pass)] -> DerivClauseTys pass
derivClauseTys forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map HsType' -> LHsSigType GhcPs
sigType [HsType']
ts
#endif
  where
#if MIN_VERSION_ghc(9,2,0)
    derivClauseTys :: [XRec pass (HsSigType pass)] -> DerivClauseTys pass
derivClauseTys [XRec pass (HsSigType pass)
x] = forall a. (NoExtField -> a) -> a
noExt forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XRec pass (HsSigType pass)
x
    derivClauseTys [XRec pass (HsSigType pass)]
xs = forall a. (NoExtField -> a) -> a
noExt forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti [XRec pass (HsSigType pass)]
xs
#else
    derivClauseTys = id
#endif

derivingStock :: [HsType'] -> HsDerivingClause'
derivingStock :: [HsType'] -> HsDerivingClause'
derivingStock = Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay (forall {a}. a -> Maybe a
Just DerivStrategy'
strat)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: DerivStrategy'
strat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy
#else
    strat = StockStrategy
#endif

derivingNewtype :: [HsType'] -> HsDerivingClause'
derivingNewtype :: [HsType'] -> HsDerivingClause'
derivingNewtype = Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay (forall {a}. a -> Maybe a
Just DerivStrategy'
strat)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: DerivStrategy'
strat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy
#else
    strat = NewtypeStrategy
#endif

derivingAnyclass :: [HsType'] -> HsDerivingClause'
derivingAnyclass :: [HsType'] -> HsDerivingClause'
derivingAnyclass = Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay (forall {a}. a -> Maybe a
Just DerivStrategy'
strat)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: DerivStrategy'
strat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy
#else
    strat = AnyclassStrategy
#endif

#if MIN_VERSION_ghc(8,6,0)
-- | A `DerivingVia` clause.
--
-- > deriving (Eq, Show) via T
-- > =====
-- > derivingVia (var "T") [var "Eq", var "Show"]
-- Available with @ghc>=8.6@.
derivingVia :: HsType' -> [HsType'] -> HsDerivingClause'
derivingVia :: HsType' -> [HsType'] -> HsDerivingClause'
derivingVia HsType'
t = Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
derivingWay (forall {a}. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GenLocated (SrcSpanAnn AnnListItem) (HsSigType GhcPs)
-> DerivStrategy'
strat forall a b. (a -> b) -> a -> b
$ HsType' -> LHsSigType GhcPs
sigType HsType'
t)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: GenLocated (SrcSpanAnn AnnListItem) (HsSigType GhcPs)
-> DerivStrategy'
strat = forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed EpAnn [AddEpAnn] -> LHsSigType GhcPs -> XViaStrategyPs
XViaStrategyPs
#else
    strat = ViaStrategy
#endif
#endif

standaloneDeriving :: HsType' -> HsDecl'
standaloneDeriving :: HsType' -> HsDecl'
standaloneDeriving = Maybe DerivStrategy' -> HsType' -> HsDecl'
standaloneDerivingWay forall a. Maybe a
Nothing

standaloneDerivingStock :: HsType' -> HsDecl'
standaloneDerivingStock :: HsType' -> HsDecl'
standaloneDerivingStock = Maybe DerivStrategy' -> HsType' -> HsDecl'
standaloneDerivingWay (forall {a}. a -> Maybe a
Just DerivStrategy'
strat)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: DerivStrategy'
strat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy
#else
    strat = StockStrategy
#endif

standaloneDerivingNewtype :: HsType' -> HsDecl'
standaloneDerivingNewtype :: HsType' -> HsDecl'
standaloneDerivingNewtype = Maybe DerivStrategy' -> HsType' -> HsDecl'
standaloneDerivingWay (forall {a}. a -> Maybe a
Just DerivStrategy'
strat)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: DerivStrategy'
strat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy
#else
    strat = NewtypeStrategy
#endif

standaloneDerivingAnyclass :: HsType' -> HsDecl'
standaloneDerivingAnyclass :: HsType' -> HsDecl'
standaloneDerivingAnyclass = Maybe DerivStrategy' -> HsType' -> HsDecl'
standaloneDerivingWay (forall {a}. a -> Maybe a
Just DerivStrategy'
strat)
  where
#if MIN_VERSION_ghc(9,2,0)
    strat :: DerivStrategy'
strat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy
#else
    strat = AnyclassStrategy
#endif

standaloneDerivingWay :: Maybe DerivStrategy' -> HsType' -> HsDecl'
standaloneDerivingWay :: Maybe DerivStrategy' -> HsType' -> HsDecl'
standaloneDerivingWay Maybe DerivStrategy'
way HsType'
ty = forall a. (NoExtField -> a) -> a
noExt forall p. XDerivD p -> DerivDecl p -> HsDecl p
DerivD DerivDecl GhcPs
derivDecl
  where derivDecl :: DerivDecl GhcPs
derivDecl =
#if MIN_VERSION_ghc(9,4,0)
          withEpAnnNotUsed DerivDecl (hsWC $ sigType ty) (fmap mkLocated way) Nothing
#else
          forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (XRec pass OverlapMode)
-> DerivDecl pass
DerivDecl (GenLocated (SrcSpanAnn AnnListItem) (HsSigType GhcPs)
-> HsWildCardBndrs
     GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsSigType GhcPs))
hsWC forall a b. (a -> b) -> a -> b
$ HsType' -> LHsSigType GhcPs
sigType HsType'
ty) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. e -> Located e
builtLoc Maybe DerivStrategy'
way) forall a. Maybe a
Nothing
#endif
        hsWC :: GenLocated (SrcSpanAnn AnnListItem) (HsSigType GhcPs)
-> HsWildCardBndrs
     GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsSigType GhcPs))
hsWC =
#if MIN_VERSION_ghc(8,6,0)
          forall a. (NoExtField -> a) -> a
noExt forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC
#else
          id
#endif

-- | Declares multiple pattern signatures of the same type.
--
-- > pattern F, G :: T
-- > =====
-- > patSynSigs ["F", "G"] $ var "T"
patSynSigs :: [OccNameStr] -> HsType' -> HsDecl'
patSynSigs :: [OccNameStr] -> HsType' -> HsDecl'
patSynSigs [OccNameStr]
names HsType'
t =
    forall t. HasValBind t => Sig' -> t
sigB forall a b. (a -> b) -> a -> b
$ forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig (forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr -> LocatedN RdrName
typeRdrName forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccNameStr -> RdrNameStr
unqual) [OccNameStr]
names)
        forall a b. (a -> b) -> a -> b
$ HsType' -> LHsSigType GhcPs
sigType HsType'
t

-- | Declares a pattern signature and its type.
--
-- > pattern F :: T
-- > =====
-- > patSynSigs "F" $ var "T"
patSynSig :: OccNameStr -> HsType' -> HsDecl'
patSynSig :: OccNameStr -> HsType' -> HsDecl'
patSynSig OccNameStr
n = [OccNameStr] -> HsType' -> HsDecl'
patSynSigs [OccNameStr
n]

-- TODO: patSynBidi, patSynUni

-- | Defines a pattern signature.
--
-- > pattern F a b = G b a
-- > =====
-- > patSynBind "F" ["a", "b"] $ conP "G" [bvar "b", bvar "a"]
patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl'
patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl'
patSynBind OccNameStr
n [OccNameStr]
ns Pat'
p = forall t. HasValBind t => HsBind' -> t
bindB forall a b. (a -> b) -> a -> b
$ forall a. (NoExtField -> a) -> a
noExt forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind
                    forall a b. (a -> b) -> a -> b
$ forall a. a -> a
withPlaceHolder (forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall idL idR.
XPSB idL idR
-> LIdP idL
-> HsPatSynDetails idR
-> LPat idR
-> HsPatSynDir idR
-> PatSynBind idL idR
PSB (RdrNameStr -> LocatedN RdrName
valueRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
n))
                        (forall {arg} {tyarg} {rec}. [arg] -> HsConDetails tyarg arg rec
prefixCon' (forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr -> LocatedN RdrName
valueRdrName forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccNameStr -> RdrNameStr
unqual) [OccNameStr]
ns))
                        (Pat' -> LPat'
builtPat Pat'
p)
                        forall id. HsPatSynDir id
ImplicitBidirectional
  where
#if MIN_VERSION_ghc(9,2,0)
    prefixCon' :: [arg] -> HsConDetails tyarg arg rec
prefixCon' = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon []
#else
    prefixCon' = PrefixCon
#endif