module Language.Haskell.Tools.AST.Gen.Decls where
import qualified Name as GHC
import Data.List
import Data.String
import Data.Function (on)
import Control.Reference
import Language.Haskell.Tools.AST
import Language.Haskell.Tools.AST.ElementTypes
import Language.Haskell.Tools.AST.Gen.Utils
import Language.Haskell.Tools.AST.Gen.Names
import Language.Haskell.Tools.Transform
mkTypeDecl :: DeclHead dom -> Type dom -> Decl dom
mkTypeDecl dh typ = mkAnn (child <> " :: " <> child) $ UTypeDecl dh typ
mkStandaloneDeriving :: Maybe (OverlapPragma dom) -> InstanceRule dom -> Decl dom
mkStandaloneDeriving overlap instRule = mkAnn ("deriving instance" <> child <> child)
$ UDerivDecl (mkAnnMaybe (after " " opt) overlap) instRule
mkFixityDecl :: FixitySignature dom -> Decl dom
mkFixityDecl = mkAnn child . UFixityDecl
mkDefaultDecl :: [Type dom] -> Decl dom
mkDefaultDecl = mkAnn ("default (" <> child <> ")") . UDefaultDecl . mkAnnList (separatedBy ", " list)
mkTypeSigDecl :: TypeSignature dom -> Decl dom
mkTypeSigDecl = mkAnn child . UTypeSigDecl
mkValueBinding :: ValueBind dom -> Decl dom
mkValueBinding = mkAnn child . UValueBinding
mkSpliceDecl :: Splice dom -> Decl dom
mkSpliceDecl = mkAnn child . USpliceDecl
mkDataDecl :: DataOrNewtypeKeyword dom -> Maybe (Context dom) -> DeclHead dom -> [ConDecl dom] -> Maybe (Deriving dom) -> Decl dom
mkDataDecl keyw ctx dh cons derivs
= mkAnn (child <> " " <> child <> child <> child <> child)
$ UDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh
(mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs)
mkGADTDataDecl :: DataOrNewtypeKeyword dom -> Maybe (Context dom) -> DeclHead dom -> Maybe (KindConstraint dom)
-> [GadtConDecl dom] -> Maybe (Deriving dom) -> Decl dom
mkGADTDataDecl keyw ctx dh kind cons derivs
= mkAnn (child <> " " <> child <> child <> child <> child <> child)
$ UGDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh
(mkAnnMaybe (after " " opt) kind) (mkAnnList (after " = " $ separatedBy " | " list) cons)
(mkAnnMaybe (after " deriving " opt) derivs)
mkGadtConDecl :: [Name dom] -> Type dom -> GadtConDecl dom
mkGadtConDecl names typ = mkAnn (child <> " :: " <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names)
(mkAnn child $ UGadtNormalType typ)
mkGadtRecordConDecl :: [Name dom] -> [FieldDecl dom] -> Type dom -> GadtConDecl dom
mkGadtRecordConDecl names flds typ
= mkAnn (child <> " :: " <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names)
$ mkAnn (child <> " -> " <> child)
$ UGadtRecordType (mkAnnList (after "{ " $ separatedBy ", " $ followedBy " }" list) flds) typ
mkConDecl :: Name dom -> [Type dom] -> ConDecl dom
mkConDecl name args = mkAnn (child <> child) $ UConDecl name (mkAnnList (after " " $ separatedBy " " $ list) args)
mkRecordConDecl :: Name dom -> [FieldDecl dom] -> ConDecl dom
mkRecordConDecl name fields
= mkAnn (child <> " { " <> child <> " }") $ URecordDecl name (mkAnnList (separatedBy ", " list) fields)
mkInfixConDecl :: Type dom -> Operator dom -> Type dom -> ConDecl dom
mkInfixConDecl lhs op rhs = mkAnn (child <> " " <> child <> " " <> child) $ UInfixConDecl lhs op rhs
mkFieldDecl :: [Name dom] -> Type dom -> FieldDecl dom
mkFieldDecl names typ = mkAnn (child <> " :: " <> child) $ UFieldDecl (mkAnnList (separatedBy ", " list) names) typ
mkDeriving :: [InstanceHead dom] -> Deriving dom
mkDeriving [deriv] = mkAnn child $ UDerivingOne deriv
mkDeriving derivs = mkAnn ("(" <> child <> ")") $ UDerivings (mkAnnList (separatedBy ", " list) derivs)
mkDataKeyword :: DataOrNewtypeKeyword dom
mkDataKeyword = mkAnn "data" UDataKeyword
mkNewtypeKeyword :: DataOrNewtypeKeyword dom
mkNewtypeKeyword = mkAnn "newtype" UNewtypeKeyword
mkClassDecl :: Maybe (Context dom) -> DeclHead dom -> [FunDep dom] -> Maybe (ClassBody dom) -> Decl dom
mkClassDecl ctx dh funDeps body
= let fdeps = case funDeps of [] -> Nothing
_ -> Just $ mkAnn child $ UFunDeps $ mkAnnList (separatedBy ", " list) funDeps
in mkAnn ("class " <> child <> child <> child <> child)
$ UClassDecl (mkAnnMaybe (followedBy " " opt) ctx) dh (mkAnnMaybe (after " | " opt) fdeps) (mkAnnMaybe opt body)
mkClassBody :: [ClassElement dom] -> ClassBody dom
mkClassBody = mkAnn (" where " <> child) . UClassBody . mkAnnList (indented list)
mkClassElemSig :: TypeSignature dom -> ClassElement dom
mkClassElemSig = mkAnn child . UClsSig
mkClassElemDef :: ValueBind dom -> ClassElement dom
mkClassElemDef = mkAnn child . UClsDef
mkClassElemTypeFam :: DeclHead dom -> Maybe (TypeFamilySpec dom) -> ClassElement dom
mkClassElemTypeFam dh tfSpec = mkAnn ("type " <> child) $ UClsTypeFam (mkAnn (child <> child) $ UTypeFamily dh (mkAnnMaybe opt tfSpec))
mkClassElemDataFam :: DeclHead dom -> Maybe (KindConstraint dom) -> ClassElement dom
mkClassElemDataFam dh kind = mkAnn ("data " <> child) $ UClsTypeFam (mkAnn (child <> child) $ UDataFamily dh (mkAnnMaybe opt kind))
mkClsDefaultType :: DeclHead dom -> Type dom -> ClassElement dom
mkClsDefaultType dh typ = mkAnn ("type " <> child <> " = " <> child) $ UClsTypeDef dh typ
mkClsDefaultSig :: Name dom -> Type dom -> ClassElement dom
mkClsDefaultSig dh typ = mkAnn ("default " <> child <> " :: " <> child) $ UClsDefSig dh typ
mkFunDep :: [Name dom] -> [Name dom] -> FunDep dom
mkFunDep lhss rhss = mkAnn (child <> " -> " <> child)
$ UFunDep (mkAnnList (separatedBy ", " list) lhss) (mkAnnList (separatedBy ", " list) rhss)
mkClsMinimal :: MinimalFormula dom -> ClassElement dom
mkClsMinimal = mkAnn ("{-# MINIMAL " <> child <> " #-}") . UClsMinimal
mkMinimalName :: Name dom -> MinimalFormula dom
mkMinimalName = mkAnn child . UMinimalName
mkMinimalParen :: MinimalFormula dom -> MinimalFormula dom
mkMinimalParen = mkAnn ("(" <> child <> ")") . UMinimalParen
mkMinimalOr :: [MinimalFormula dom] -> MinimalFormula dom
mkMinimalOr = mkAnn child . UMinimalOr . mkAnnList (separatedBy " | " list)
mkMinimalAnd :: [MinimalFormula dom] -> MinimalFormula dom
mkMinimalAnd = mkAnn child . UMinimalAnd . mkAnnList (separatedBy ", " list)
mkNameDeclHead :: Name dom -> DeclHead dom
mkNameDeclHead = mkAnn child . UDeclHead
mkParenDeclHead :: DeclHead dom -> DeclHead dom
mkParenDeclHead = mkAnn child . UDHParen
mkDeclHeadApp :: DeclHead dom -> TyVar dom -> DeclHead dom
mkDeclHeadApp dh tv = mkAnn (child <> " " <> child) $ UDHApp dh tv
mkInfixDeclHead :: TyVar dom -> Operator dom -> TyVar dom -> DeclHead dom
mkInfixDeclHead lhs op rhs = mkAnn (child <> " " <> child <> " " <> child) $ UDHInfix lhs op rhs
mkInstanceDecl :: Maybe (OverlapPragma dom) -> InstanceRule dom -> Maybe (InstBody dom) -> Decl dom
mkInstanceDecl overlap instRule body = mkAnn ("instance " <> child <> child <> child)
$ UInstDecl (mkAnnMaybe (after " " opt) overlap) instRule (mkAnnMaybe opt body)
mkInstanceRule :: Maybe (Context dom) -> InstanceHead dom -> InstanceRule dom
mkInstanceRule ctx ih
= mkAnn (child <> child <> child) $ UInstanceRule (mkAnnMaybe (after " " opt) Nothing) (mkAnnMaybe (after " " opt) ctx) ih
mkInstanceHead :: Name dom -> InstanceHead dom
mkInstanceHead = mkAnn child . UInstanceHeadCon
mkInfixInstanceHead :: Type dom -> Name dom -> InstanceHead dom
mkInfixInstanceHead typ n = mkAnn (child <> child) $ UInstanceHeadInfix typ n
mkParenInstanceHead :: InstanceHead dom -> InstanceHead dom
mkParenInstanceHead = mkAnn ("(" <> child <> ")") . UInstanceHeadParen
mkAppInstanceHead :: InstanceHead dom -> Type dom -> InstanceHead dom
mkAppInstanceHead fun arg = mkAnn (child <> " " <> child) $ UInstanceHeadApp fun arg
mkInstanceBody :: [InstBodyDecl dom] -> InstBody dom
mkInstanceBody = mkAnn (" where " <> child) . UInstBody . mkAnnList (indented list)
mkInstanceBind :: ValueBind dom -> InstBodyDecl dom
mkInstanceBind = mkAnn child . UInstBodyNormalDecl
mkInstanceTypeSig :: TypeSignature dom -> InstBodyDecl dom
mkInstanceTypeSig = mkAnn child . UInstBodyTypeSig
mkInstanceTypeFamilyDef :: TypeEqn dom -> InstBodyDecl dom
mkInstanceTypeFamilyDef = mkAnn child . UInstBodyTypeDecl
mkInstanceDataFamilyDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> [ConDecl dom] -> Maybe (Deriving dom) -> InstBodyDecl dom
mkInstanceDataFamilyDef keyw instRule cons derivs
= mkAnn (child <> " " <> child <> child <> child)
$ UInstBodyDataDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons)
(mkAnnMaybe (after " deriving " opt) derivs)
mkInstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom]
-> Maybe (Deriving dom) -> InstBodyDecl dom
mkInstanceDataFamilyGADTDef keyw instRule kind cons derivs
= mkAnn (child <> " " <> child <> child <> child)
$ UInstBodyGadtDataDecl mkDataKeyword instRule (mkAnnMaybe opt kind) (mkAnnList (after " = " $ separatedBy " | " list) cons)
(mkAnnMaybe (after " deriving " opt) derivs)
mkInstanceSpecializePragma :: Type dom -> InstBodyDecl dom
mkInstanceSpecializePragma = mkAnn ("{-# SPECIALIZE " <> child <> " #-}") . USpecializeInstance
mkEnableOverlap :: OverlapPragma dom
mkEnableOverlap = mkAnn "{-# OVERLAP #-}" UEnableOverlap
mkDisableOverlap :: OverlapPragma dom
mkDisableOverlap = mkAnn "{-# NO_OVERLAP #-}" UDisableOverlap
mkOverlappable :: OverlapPragma dom
mkOverlappable = mkAnn "{-# OVERLAPPABLE #-}" UOverlappable
mkOverlapping :: OverlapPragma dom
mkOverlapping = mkAnn "{-# OVERLAPPING #-}" UOverlapping
mkOverlaps :: OverlapPragma dom
mkOverlaps = mkAnn "{-# OVERLAPS #-}" UOverlaps
mkIncoherentOverlap :: OverlapPragma dom
mkIncoherentOverlap = mkAnn "{-# INCOHERENT #-}" UIncoherentOverlap
mkRoleDecl :: QualifiedName dom -> [Role dom] -> Decl dom
mkRoleDecl name roles
= mkAnn ("type role " <> child <> child) $ URoleDecl name $ mkAnnList (separatedBy " " $ after " " list) roles
mkNominalRole :: Role dom
mkNominalRole = mkAnn "nominal" UNominal
mkRepresentationalRole :: Role dom
mkRepresentationalRole = mkAnn "representational" URepresentational
mkPhantomRole :: Role dom
mkPhantomRole = mkAnn "phantom" UPhantom
mkForeignImport :: CallConv dom -> Maybe (Safety dom) -> Name dom -> Type dom -> Decl dom
mkForeignImport cc safety name typ = mkAnn (child <> child <> " " <> child <> " :: " <> child)
$ UForeignImport cc (mkAnnMaybe (after " " opt) safety) name typ
mkForeignExport :: CallConv dom -> Name dom -> Type dom -> Decl dom
mkForeignExport cc name typ = mkAnn (child <> " " <> child <> " :: " <> child) $ UForeignExport cc name typ
mkStdCall :: CallConv dom
mkStdCall = mkAnn "stdcall" UStdCall
mkCCall :: CallConv dom
mkCCall = mkAnn "ccall" UCCall
mkCApi :: CallConv dom
mkCApi = mkAnn "capi" UCApi
mkUnsafe :: Safety dom
mkUnsafe = mkAnn "unsafe" UUnsafe
mkTypeFamily :: DeclHead dom -> Maybe (TypeFamilySpec dom) -> Decl dom
mkTypeFamily dh famSpec = mkAnn child $ UTypeFamilyDecl (mkAnn (child <> child) $ UTypeFamily dh (mkAnnMaybe (after " " opt) famSpec))
mkClosedTypeFamily :: DeclHead dom -> Maybe (KindConstraint dom) -> [TypeEqn dom] -> Decl dom
mkClosedTypeFamily dh kind typeqs = mkAnn (child <> child <> " where " <> child)
$ UClosedTypeFamilyDecl dh (mkAnnMaybe (after " " opt) kind) (mkAnnList (indented list) typeqs)
mkDataFamily :: DeclHead dom -> Maybe (KindConstraint dom) -> Decl dom
mkDataFamily dh kind = mkAnn child $ UTypeFamilyDecl (mkAnn (child <> child) $ UDataFamily dh (mkAnnMaybe (after " " opt) kind))
mkTypeFamilyKindSpec :: KindConstraint dom -> TypeFamilySpec dom
mkTypeFamilyKindSpec = mkAnn child . UTypeFamilyKind
mkTypeFamilyInjectivitySpec :: Name dom -> [Name dom] -> TypeFamilySpec dom
mkTypeFamilyInjectivitySpec res dependent
= mkAnn child (UTypeFamilyInjectivity $ mkAnn (child <> " -> " <> child) $ UInjectivityAnn res (mkAnnList (separatedBy " " list) dependent))
mkTypeEqn :: Type dom -> Type dom -> TypeEqn dom
mkTypeEqn lhs rhs = mkAnn (child <> " = " <> child) $ UTypeEqn lhs rhs
mkTypeInstance :: InstanceRule dom -> Type dom -> Decl dom
mkTypeInstance instRule typ = mkAnn ("type instance " <> child <> " = " <> child) $ UTypeInstDecl instRule typ
mkDataInstance :: DataOrNewtypeKeyword dom -> InstanceRule dom -> [ConDecl dom] -> Maybe (Deriving dom) -> Decl dom
mkDataInstance keyw instRule cons derivs
= mkAnn (child <> " instance " <> child <> " = " <> child <> child)
$ UDataInstDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons)
(mkAnnMaybe (after " deriving " opt) derivs)
mkGadtDataInstance :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Decl dom
mkGadtDataInstance keyw instRule kind cons
= mkAnn (child <> " instance " <> child <> child <> " where " <> child)
$ UGDataInstDecl keyw instRule (mkAnnMaybe (after " " opt) kind) (mkAnnList (indented list) cons)
mkPatternSynonym :: PatSynLhs dom -> PatSynRhs dom -> Decl dom
mkPatternSynonym lhs rhs = mkAnn child $ UPatternSynonymDecl $ mkAnn ("pattern " <> child <> " " <> child)
$ UPatternSynonym lhs rhs
mkConPatSyn :: Name dom -> [Name dom] -> PatSynLhs dom
mkConPatSyn con args = mkAnn (child <> child) $ UNormalPatSyn con $ mkAnnList (after " " $ separatedBy " " list) args
mkInfixPatSyn :: Name dom -> Operator dom -> Name dom -> PatSynLhs dom
mkInfixPatSyn lhs op rhs = mkAnn (child <> " " <> child <> " " <> child) $ UInfixPatSyn lhs op rhs
mkRecordPatSyn :: Name dom -> [Name dom] -> PatSynLhs dom
mkRecordPatSyn con args
= mkAnn (child <> child) $ URecordPatSyn con $ mkAnnList (after "{ " $ separatedBy ", " $ followedBy " }" list) args
mkSymmetricPatSyn :: Pattern dom -> PatSynRhs dom
mkSymmetricPatSyn = mkAnn ("= " <> child) . flip UBidirectionalPatSyn (mkAnnMaybe opt Nothing)
mkOneWayPatSyn :: Pattern dom -> PatSynRhs dom
mkOneWayPatSyn = mkAnn ("<- " <> child) . UOneDirectionalPatSyn
mkTwoWayPatSyn :: Pattern dom -> [Match dom] -> PatSynRhs dom
mkTwoWayPatSyn pat match = mkAnn ("<- " <> child <> child) $ UBidirectionalPatSyn pat $ mkAnnMaybe (after " where " opt)
$ Just $ mkAnn child $ UPatSynWhere $ mkAnnList (indented list) match
mkPatternSignatureDecl :: PatternSignature dom -> Decl dom
mkPatternSignatureDecl = mkAnn child . UPatTypeSigDecl
mkPatternSignature :: Name dom -> Type dom -> PatternSignature dom
mkPatternSignature name typ = mkAnn (child <> " :: " <> child) $ UPatternTypeSignature name typ
mkPragmaDecl :: TopLevelPragma dom -> Decl dom
mkPragmaDecl = mkAnn child . UPragmaDecl
mkRulePragma :: [Rule dom] -> TopLevelPragma dom
mkRulePragma = mkAnn ("{-# RULES " <> child <> " #-}") . URulePragma . mkAnnList (separatedBy ", " list)
mkDeprPragma :: [Name dom] -> String -> TopLevelPragma dom
mkDeprPragma defs msg = mkAnn ("{-# DEPRECATED " <> child <> " " <> child <> " #-}")
$ UDeprPragma (mkAnnList (separatedBy ", " list) defs) $ mkAnn ("\"" <> child <> "\"") $ UStringNode msg
mkWarningPragma :: [Name dom] -> String -> TopLevelPragma dom
mkWarningPragma defs msg = mkAnn ("{-# WARNING " <> child <> " " <> child <> " #-}")
$ UWarningPragma (mkAnnList (separatedBy ", " list) defs) $ mkAnn ("\"" <> child <> "\"") $ UStringNode msg
mkAnnPragma :: AnnotationSubject dom -> Expr dom -> TopLevelPragma dom
mkAnnPragma subj ann = mkAnn ("{-# ANN " <> child <> " " <> child <> " #-}") $ UAnnPragma subj ann
mkInlinePragma :: Maybe (ConlikeAnnot dom) -> Maybe (PhaseControl dom) -> Name dom -> TopLevelPragma dom
mkInlinePragma conlike phase name
= mkAnn ("{-# INLINE " <> child <> child <> child <> " #-}")
$ UInlinePragma (mkAnnMaybe (followedBy " " opt) conlike) (mkAnnMaybe (followedBy " " opt) phase) name
mkNoInlinePragma :: Maybe (ConlikeAnnot dom) -> Maybe (PhaseControl dom) -> Name dom -> TopLevelPragma dom
mkNoInlinePragma conlike phase name
= mkAnn ("{-# NOINLINE " <> child <> child <> child <> " #-}")
$ UNoInlinePragma (mkAnnMaybe (followedBy " " opt) conlike) (mkAnnMaybe (followedBy " " opt) phase) name
mkInlinablePragma :: Maybe (PhaseControl dom) -> Name dom -> TopLevelPragma dom
mkInlinablePragma phase name
= mkAnn ("{-# INLINEABLE " <> child <> child <> " #-}")
$ UInlinablePragma (mkAnnMaybe (followedBy " " opt) phase) name
mkLinePragma :: Int -> Maybe (StringNode dom) -> TopLevelPragma dom
mkLinePragma line filename
= mkAnn ("{-# LINE " <> child <> child <> " #-}")
$ ULinePragma (mkAnn child $ LineNumber line) (mkAnnMaybe (after " " opt) filename)
mkSpecializePragma :: Maybe (PhaseControl dom) -> Name dom -> [Type dom] -> TopLevelPragma dom
mkSpecializePragma phase def specTypes
= mkAnn ("{-# SPECIALIZE " <> child <> child <> " " <> child <> " #-}")
$ USpecializePragma (mkAnnMaybe (after " " opt) phase) def $ mkAnnList (separatedBy ", " list) specTypes
mkPhaseControlFrom :: Integer -> PhaseControl dom
mkPhaseControlFrom phaseNum
= mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt Nothing) (mkAnn child $ PhaseNumber phaseNum)
mkPhaseControlUntil :: Integer -> PhaseControl dom
mkPhaseControlUntil phaseNum
= mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt $ Just $ mkAnn "~" PhaseInvert)
(mkAnn child $ PhaseNumber phaseNum)
mkRewriteRule :: String -> Maybe (PhaseControl dom) -> [TyVar dom] -> Expr dom -> Expr dom -> Rule dom
mkRewriteRule name phase vars lhs rhs
= mkAnn (child <> " " <> child <> child <> child <> " = " <> child)
$ URule (mkAnn ("\"" <> child <> "\"") $ UStringNode name) (mkAnnMaybe (followedBy " " opt) phase)
(mkAnnList (after "forall " $ separatedBy " " $ followedBy ". " list) vars) lhs rhs
mkNameAnnotation :: Name dom -> AnnotationSubject dom
mkNameAnnotation name = mkAnn child $ UNameAnnotation name
mkTypeAnnotation :: Name dom -> AnnotationSubject dom
mkTypeAnnotation name = mkAnn ("type " <> child) $ UTypeAnnotation name
mkModuleAnnotation :: AnnotationSubject dom
mkModuleAnnotation = mkAnn "module" UModuleAnnotation
mkConlikeAnnotation :: ConlikeAnnot dom
mkConlikeAnnotation = mkAnn "CONLIKE" UConlikeAnnot