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