template-haskell 2.22.0.0 → 2.24.0.0
raw patch · 10 files changed
Files
- Language/Haskell/TH/Lib.hs +68/−3
- Language/Haskell/TH/Lib/Internal.hs +0/−1236
- Language/Haskell/TH/Lib/Map.hs +0/−111
- Language/Haskell/TH/Ppr.hs +90/−1074
- Language/Haskell/TH/PprLib.hs +51/−221
- Language/Haskell/TH/Quote.hs +12/−28
- Language/Haskell/TH/Syntax.hs +399/−2998
- changelog.md +16/−0
- template-haskell.cabal +7/−13
- vendored-filepath/System/FilePath.hs +0/−2
Language/Haskell/TH/Lib.hs view
@@ -45,6 +45,8 @@ lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE, typeE,+ forallE, forallVisE, constrainedE,+ -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, @@ -120,7 +122,9 @@ -- **** Pragmas ruleVar, typedRuleVar, valueAnnotation, typeAnnotation, moduleAnnotation,- pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,+ pragInlD, pragSpecD, pragSpecInlD,+ pragSpecED, pragSpecInlED,+ pragSpecInstD, pragRuleD, pragAnnD, pragLineD, pragCompleteD, -- **** Pattern Synonyms@@ -139,7 +143,7 @@ ) where -import Language.Haskell.TH.Lib.Internal hiding+import GHC.Boot.TH.Lib hiding ( tySynD , dataD , newtypeD@@ -179,7 +183,7 @@ , Role , InjectivityAnn )-import qualified Language.Haskell.TH.Lib.Internal as Internal+import qualified GHC.Boot.TH.Lib as Internal import Language.Haskell.TH.Syntax import Control.Applicative (Applicative(..))@@ -391,3 +395,64 @@ conP :: Quote m => Name -> [m Pat] -> m Pat conP n xs = Internal.conP n [] xs+++--------------------------------------------------------------------------------+-- * Constraint predicates (deprecated)++{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}+classP :: Quote m => Name -> [m Type] -> m Pred+classP cla tys+ = do+ tysl <- sequenceA tys+ pure (foldl AppT (ConT cla) tysl)++{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}+equalP :: Quote m => m Type -> m Type -> m Pred+equalP tleft tright+ = do+ tleft1 <- tleft+ tright1 <- tright+ eqT <- equalityT+ pure (foldl AppT eqT [tleft1, tright1])++--------------------------------------------------------------------------------+-- * Strictness queries (deprecated)+{-# DEPRECATED isStrict+ ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",+ "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}+{-# DEPRECATED notStrict+ ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",+ "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}+{-# DEPRECATED unpacked+ ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",+ "Example usage: 'bang sourceUnpack sourceStrict'"] #-}+isStrict, notStrict, unpacked :: Quote m => m Strict+isStrict = bang noSourceUnpackedness sourceStrict+notStrict = bang noSourceUnpackedness noSourceStrictness+unpacked = bang sourceUnpack sourceStrict++{-# DEPRECATED strictType+ "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}+strictType :: Quote m => m Strict -> m Type -> m StrictType+strictType = bangType++{-# DEPRECATED varStrictType+ "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}+varStrictType :: Quote m => Name -> m StrictType -> m VarStrictType+varStrictType = varBangType++--------------------------------------------------------------------------------+-- * Specialisation pragmas (backwards compatibility)++pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec+pragSpecD n ty phases+ = do+ ty1 <- ty+ pure $ PragmaD $ SpecialiseP n ty1 Nothing phases++pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec+pragSpecInlD n ty inline phases+ = do+ ty1 <- ty+ pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
− Language/Haskell/TH/Lib/Internal.hs
@@ -1,1236 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE Trustworthy #-}---- |--- Language.Haskell.TH.Lib.Internal exposes some additional functionality that--- is used internally in GHC's integration with Template Haskell. This is not a--- part of the public API, and as such, there are no API guarantees for this--- module from version to version.---- Why do we have both Language.Haskell.TH.Lib.Internal and--- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the--- former (which are tailored for GHC's use) need different type signatures--- than the ones in the latter. Syncing up the Internal type signatures would--- involve a massive amount of breaking changes, so for the time being, we--- relegate as many changes as we can to just the Internal module, where it--- is safe to break things.--module Language.Haskell.TH.Lib.Internal where--import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)-import qualified Language.Haskell.TH.Syntax as TH-import Control.Applicative(liftA, Applicative(..))-import qualified Data.Kind as Kind (Type)-import Data.Word( Word8 )-import Data.List.NonEmpty ( NonEmpty(..) )-import GHC.Exts (TYPE)-import Prelude hiding (Applicative(..))--------------------------------------------------------------- * Type synonyms--------------------------------------------------------------- | Representation-polymorphic since /template-haskell-2.17.0.0/.-type TExpQ :: TYPE r -> Kind.Type-type TExpQ a = Q (TExp a)--type CodeQ :: TYPE r -> Kind.Type-type CodeQ = Code Q--type InfoQ = Q Info-type PatQ = Q Pat-type FieldPatQ = Q FieldPat-type ExpQ = Q Exp-type DecQ = Q Dec-type DecsQ = Q [Dec]-type Decs = [Dec] -- Defined as it is more convenient to wire-in-type ConQ = Q Con-type TypeQ = Q Type-type KindQ = Q Kind-type TyLitQ = Q TyLit-type CxtQ = Q Cxt-type PredQ = Q Pred-type DerivClauseQ = Q DerivClause-type MatchQ = Q Match-type ClauseQ = Q Clause-type BodyQ = Q Body-type GuardQ = Q Guard-type StmtQ = Q Stmt-type RangeQ = Q Range-type SourceStrictnessQ = Q SourceStrictness-type SourceUnpackednessQ = Q SourceUnpackedness-type BangQ = Q Bang-type BangTypeQ = Q BangType-type VarBangTypeQ = Q VarBangType-type StrictTypeQ = Q StrictType-type VarStrictTypeQ = Q VarStrictType-type FieldExpQ = Q FieldExp-type RuleBndrQ = Q RuleBndr-type TySynEqnQ = Q TySynEqn-type PatSynDirQ = Q PatSynDir-type PatSynArgsQ = Q PatSynArgs-type FamilyResultSigQ = Q FamilyResultSig-type DerivStrategyQ = Q DerivStrategy---- must be defined here for DsMeta to find it-type Role = TH.Role-type InjectivityAnn = TH.InjectivityAnn--type TyVarBndrUnit = TyVarBndr ()-type TyVarBndrSpec = TyVarBndr Specificity-type TyVarBndrVis = TyVarBndr BndrVis--------------------------------------------------------------- * Lowercase pattern syntax functions-------------------------------------------------------------intPrimL :: Integer -> Lit-intPrimL = IntPrimL-wordPrimL :: Integer -> Lit-wordPrimL = WordPrimL-floatPrimL :: Rational -> Lit-floatPrimL = FloatPrimL-doublePrimL :: Rational -> Lit-doublePrimL = DoublePrimL-integerL :: Integer -> Lit-integerL = IntegerL-charL :: Char -> Lit-charL = CharL-charPrimL :: Char -> Lit-charPrimL = CharPrimL-stringL :: String -> Lit-stringL = StringL-stringPrimL :: [Word8] -> Lit-stringPrimL = StringPrimL-bytesPrimL :: Bytes -> Lit-bytesPrimL = BytesPrimL-rationalL :: Rational -> Lit-rationalL = RationalL--litP :: Quote m => Lit -> m Pat-litP l = pure (LitP l)--varP :: Quote m => Name -> m Pat-varP v = pure (VarP v)--tupP :: Quote m => [m Pat] -> m Pat-tupP ps = do { ps1 <- sequenceA ps; pure (TupP ps1)}--unboxedTupP :: Quote m => [m Pat] -> m Pat-unboxedTupP ps = do { ps1 <- sequenceA ps; pure (UnboxedTupP ps1)}--unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat-unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) }--conP :: Quote m => Name -> [m Type] -> [m Pat] -> m Pat-conP n ts ps = do ps' <- sequenceA ps- ts' <- sequenceA ts- pure (ConP n ts' ps')-infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat-infixP p1 n p2 = do p1' <- p1- p2' <- p2- pure (InfixP p1' n p2')-uInfixP :: Quote m => m Pat -> Name -> m Pat -> m Pat-uInfixP p1 n p2 = do p1' <- p1- p2' <- p2- pure (UInfixP p1' n p2')-parensP :: Quote m => m Pat -> m Pat-parensP p = do p' <- p- pure (ParensP p')--tildeP :: Quote m => m Pat -> m Pat-tildeP p = do p' <- p- pure (TildeP p')-bangP :: Quote m => m Pat -> m Pat-bangP p = do p' <- p- pure (BangP p')-asP :: Quote m => Name -> m Pat -> m Pat-asP n p = do p' <- p- pure (AsP n p')-wildP :: Quote m => m Pat-wildP = pure WildP-recP :: Quote m => Name -> [m FieldPat] -> m Pat-recP n fps = do fps' <- sequenceA fps- pure (RecP n fps')-listP :: Quote m => [m Pat] -> m Pat-listP ps = do ps' <- sequenceA ps- pure (ListP ps')-sigP :: Quote m => m Pat -> m Type -> m Pat-sigP p t = do p' <- p- t' <- t- pure (SigP p' t')-typeP :: Quote m => m Type -> m Pat-typeP t = do t' <- t- pure (TypeP t')-invisP :: Quote m => m Type -> m Pat-invisP t = do t' <- t- pure (InvisP t')-viewP :: Quote m => m Exp -> m Pat -> m Pat-viewP e p = do e' <- e- p' <- p- pure (ViewP e' p')---fieldPat :: Quote m => Name -> m Pat -> m FieldPat-fieldPat n p = do p' <- p- pure (n, p')------------------------------------------------------------------------------------- * Stmt--bindS :: Quote m => m Pat -> m Exp -> m Stmt-bindS p e = liftA2 BindS p e--letS :: Quote m => [m Dec] -> m Stmt-letS ds = do { ds1 <- sequenceA ds; pure (LetS ds1) }--noBindS :: Quote m => m Exp -> m Stmt-noBindS e = do { e1 <- e; pure (NoBindS e1) }--parS :: Quote m => [[m Stmt]] -> m Stmt-parS sss = do { sss1 <- traverse sequenceA sss; pure (ParS sss1) }--recS :: Quote m => [m Stmt] -> m Stmt-recS ss = do { ss1 <- sequenceA ss; pure (RecS ss1) }------------------------------------------------------------------------------------ * Range--fromR :: Quote m => m Exp -> m Range-fromR x = do { a <- x; pure (FromR a) }--fromThenR :: Quote m => m Exp -> m Exp -> m Range-fromThenR x y = do { a <- x; b <- y; pure (FromThenR a b) }--fromToR :: Quote m => m Exp -> m Exp -> m Range-fromToR x y = do { a <- x; b <- y; pure (FromToR a b) }--fromThenToR :: Quote m => m Exp -> m Exp -> m Exp -> m Range-fromThenToR x y z = do { a <- x; b <- y; c <- z;- pure (FromThenToR a b c) }----------------------------------------------------------------------------------- * Body--normalB :: Quote m => m Exp -> m Body-normalB e = do { e1 <- e; pure (NormalB e1) }--guardedB :: Quote m => [m (Guard,Exp)] -> m Body-guardedB ges = do { ges' <- sequenceA ges; pure (GuardedB ges') }------------------------------------------------------------------------------------ * Guard--normalG :: Quote m => m Exp -> m Guard-normalG e = do { e1 <- e; pure (NormalG e1) }--normalGE :: Quote m => m Exp -> m Exp -> m (Guard, Exp)-normalGE g e = do { g1 <- g; e1 <- e; pure (NormalG g1, e1) }--patG :: Quote m => [m Stmt] -> m Guard-patG ss = do { ss' <- sequenceA ss; pure (PatG ss') }--patGE :: Quote m => [m Stmt] -> m Exp -> m (Guard, Exp)-patGE ss e = do { ss' <- sequenceA ss;- e' <- e;- pure (PatG ss', e') }------------------------------------------------------------------------------------ * Match and Clause---- | Use with 'caseE'-match :: Quote m => m Pat -> m Body -> [m Dec] -> m Match-match p rhs ds = do { p' <- p;- r' <- rhs;- ds' <- sequenceA ds;- pure (Match p' r' ds') }---- | Use with 'funD'-clause :: Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause-clause ps r ds = do { ps' <- sequenceA ps;- r' <- r;- ds' <- sequenceA ds;- pure (Clause ps' r' ds') }-------------------------------------------------------------------------------- * Exp---- | Dynamically binding a variable (unhygienic)-dyn :: Quote m => String -> m Exp-dyn s = pure (VarE (mkName s))--varE :: Quote m => Name -> m Exp-varE s = pure (VarE s)--conE :: Quote m => Name -> m Exp-conE s = pure (ConE s)--litE :: Quote m => Lit -> m Exp-litE c = pure (LitE c)--appE :: Quote m => m Exp -> m Exp -> m Exp-appE x y = do { a <- x; b <- y; pure (AppE a b)}--appTypeE :: Quote m => m Exp -> m Type -> m Exp-appTypeE x t = do { a <- x; s <- t; pure (AppTypeE a s) }--parensE :: Quote m => m Exp -> m Exp-parensE x = do { x' <- x; pure (ParensE x') }--uInfixE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp-uInfixE x s y = do { x' <- x; s' <- s; y' <- y;- pure (UInfixE x' s' y') }--infixE :: Quote m => Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp-infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;- pure (InfixE (Just a) s' (Just b))}-infixE Nothing s (Just y) = do { s' <- s; b <- y;- pure (InfixE Nothing s' (Just b))}-infixE (Just x) s Nothing = do { a <- x; s' <- s;- pure (InfixE (Just a) s' Nothing)}-infixE Nothing s Nothing = do { s' <- s; pure (InfixE Nothing s' Nothing) }--infixApp :: Quote m => m Exp -> m Exp -> m Exp -> m Exp-infixApp x y z = infixE (Just x) y (Just z)-sectionL :: Quote m => m Exp -> m Exp -> m Exp-sectionL x y = infixE (Just x) y Nothing-sectionR :: Quote m => m Exp -> m Exp -> m Exp-sectionR x y = infixE Nothing x (Just y)--lamE :: Quote m => [m Pat] -> m Exp -> m Exp-lamE ps e = do ps' <- sequenceA ps- e' <- e- pure (LamE ps' e')---- | Single-arg lambda-lam1E :: Quote m => m Pat -> m Exp -> m Exp-lam1E p e = lamE [p] e---- | Lambda-case (@\case@)-lamCaseE :: Quote m => [m Match] -> m Exp-lamCaseE ms = LamCaseE <$> sequenceA ms---- | Lambda-cases (@\cases@)-lamCasesE :: Quote m => [m Clause] -> m Exp-lamCasesE ms = LamCasesE <$> sequenceA ms--tupE :: Quote m => [Maybe (m Exp)] -> m Exp-tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)}--unboxedTupE :: Quote m => [Maybe (m Exp)] -> m Exp-unboxedTupE es = do { es1 <- traverse sequenceA es; pure (UnboxedTupE es1)}--unboxedSumE :: Quote m => m Exp -> SumAlt -> SumArity -> m Exp-unboxedSumE e alt arity = do { e1 <- e; pure (UnboxedSumE e1 alt arity) }--condE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp-condE x y z = do { a <- x; b <- y; c <- z; pure (CondE a b c)}--multiIfE :: Quote m => [m (Guard, Exp)] -> m Exp-multiIfE alts = MultiIfE <$> sequenceA alts--letE :: Quote m => [m Dec] -> m Exp -> m Exp-letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) }--caseE :: Quote m => m Exp -> [m Match] -> m Exp-caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) }--doE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp-doE m ss = do { ss1 <- sequenceA ss; pure (DoE m ss1) }--mdoE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp-mdoE m ss = do { ss1 <- sequenceA ss; pure (MDoE m ss1) }--compE :: Quote m => [m Stmt] -> m Exp-compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) }--arithSeqE :: Quote m => m Range -> m Exp-arithSeqE r = do { r' <- r; pure (ArithSeqE r') }--listE :: Quote m => [m Exp] -> m Exp-listE es = do { es1 <- sequenceA es; pure (ListE es1) }--sigE :: Quote m => m Exp -> m Type -> m Exp-sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) }--recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp-recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) }--recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp-recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) }--stringE :: Quote m => String -> m Exp-stringE = litE . stringL--fieldExp :: Quote m => Name -> m Exp -> m (Name, Exp)-fieldExp s e = do { e' <- e; pure (s,e') }---- | @staticE x = [| static x |]@-staticE :: Quote m => m Exp -> m Exp-staticE = fmap StaticE--unboundVarE :: Quote m => Name -> m Exp-unboundVarE s = pure (UnboundVarE s)--labelE :: Quote m => String -> m Exp-labelE s = pure (LabelE s)--implicitParamVarE :: Quote m => String -> m Exp-implicitParamVarE n = pure (ImplicitParamVarE n)--getFieldE :: Quote m => m Exp -> String -> m Exp-getFieldE e f = do- e' <- e- pure (GetFieldE e' f)--projectionE :: Quote m => NonEmpty String -> m Exp-projectionE xs = pure (ProjectionE xs)--typedSpliceE :: Quote m => m Exp -> m Exp-typedSpliceE = fmap TypedSpliceE--typedBracketE :: Quote m => m Exp -> m Exp-typedBracketE = fmap TypedBracketE---- ** 'arithSeqE' Shortcuts-fromE :: Quote m => m Exp -> m Exp-fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }--fromThenE :: Quote m => m Exp -> m Exp -> m Exp-fromThenE x y = do { a <- x; b <- y; pure (ArithSeqE (FromThenR a b)) }--fromToE :: Quote m => m Exp -> m Exp -> m Exp-fromToE x y = do { a <- x; b <- y; pure (ArithSeqE (FromToR a b)) }--fromThenToE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp-fromThenToE x y z = do { a <- x; b <- y; c <- z;- pure (ArithSeqE (FromThenToR a b c)) }--typeE :: Quote m => m Type -> m Exp-typeE = fmap TypeE------------------------------------------------------------------------------------ * Dec--valD :: Quote m => m Pat -> m Body -> [m Dec] -> m Dec-valD p b ds =- do { p' <- p- ; ds' <- sequenceA ds- ; b' <- b- ; pure (ValD p' b' ds')- }--funD :: Quote m => Name -> [m Clause] -> m Dec-funD nm cs =- do { cs1 <- sequenceA cs- ; pure (FunD nm cs1)- }--tySynD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m Type -> m Dec-tySynD tc tvs rhs =- do { tvs1 <- sequenceA tvs- ; rhs1 <- rhs- ; pure (TySynD tc tvs1 rhs1)- }--dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con]- -> [m DerivClause] -> m Dec-dataD ctxt tc tvs ksig cons derivs =- do- ctxt1 <- ctxt- tvs1 <- sequenceA tvs- ksig1 <- sequenceA ksig- cons1 <- sequenceA cons- derivs1 <- sequenceA derivs- pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)--newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Con- -> [m DerivClause] -> m Dec-newtypeD ctxt tc tvs ksig con derivs =- do- ctxt1 <- ctxt- tvs1 <- sequenceA tvs- ksig1 <- sequenceA ksig- con1 <- con- derivs1 <- sequenceA derivs- pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)--typeDataD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con]- -> m Dec-typeDataD tc tvs ksig cons =- do- tvs1 <- sequenceA tvs- ksig1 <- sequenceA ksig- cons1 <- sequenceA cons- pure (TypeDataD tc tvs1 ksig1 cons1)--classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> [FunDep] -> [m Dec] -> m Dec-classD ctxt cls tvs fds decs =- do- tvs1 <- sequenceA tvs- decs1 <- sequenceA decs- ctxt1 <- ctxt- pure $ ClassD ctxt1 cls tvs1 fds decs1--instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec-instanceD = instanceWithOverlapD Nothing--instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec-instanceWithOverlapD o ctxt ty decs =- do- ctxt1 <- ctxt- decs1 <- sequenceA decs- ty1 <- ty- pure $ InstanceD o ctxt1 ty1 decs1----sigD :: Quote m => Name -> m Type -> m Dec-sigD fun ty = liftA (SigD fun) $ ty--kiSigD :: Quote m => Name -> m Kind -> m Dec-kiSigD fun ki = liftA (KiSigD fun) $ ki--forImpD :: Quote m => Callconv -> Safety -> String -> Name -> m Type -> m Dec-forImpD cc s str n ty- = do ty' <- ty- pure $ ForeignD (ImportF cc s str n ty')--infixLD :: Quote m => Int -> Name -> m Dec-infixLD prec = infixLWithSpecD prec NoNamespaceSpecifier--infixRD :: Quote m => Int -> Name -> m Dec-infixRD prec = infixRWithSpecD prec NoNamespaceSpecifier--infixND :: Quote m => Int -> Name -> m Dec-infixND prec = infixNWithSpecD prec NoNamespaceSpecifier--infixLWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec-infixLWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixL) ns_spec nm)--infixRWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec-infixRWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixR) ns_spec nm)--infixNWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec-infixNWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixN) ns_spec nm)--defaultD :: Quote m => [m Type] -> m Dec-defaultD tys = DefaultD <$> sequenceA tys--pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec-pragInlD name inline rm phases- = pure $ PragmaD $ InlineP name inline rm phases--pragOpaqueD :: Quote m => Name -> m Dec-pragOpaqueD name = pure $ PragmaD $ OpaqueP name--pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec-pragSpecD n ty phases- = do- ty1 <- ty- pure $ PragmaD $ SpecialiseP n ty1 Nothing phases--pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec-pragSpecInlD n ty inline phases- = do- ty1 <- ty- pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases--pragSpecInstD :: Quote m => m Type -> m Dec-pragSpecInstD ty- = do- ty1 <- ty- pure $ PragmaD $ SpecialiseInstP ty1--pragRuleD :: Quote m => String -> Maybe [m (TyVarBndr ())] -> [m RuleBndr] -> m Exp -> m Exp- -> Phases -> m Dec-pragRuleD n ty_bndrs tm_bndrs lhs rhs phases- = do- ty_bndrs1 <- traverse sequenceA ty_bndrs- tm_bndrs1 <- sequenceA tm_bndrs- lhs1 <- lhs- rhs1 <- rhs- pure $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases--pragAnnD :: Quote m => AnnTarget -> m Exp -> m Dec-pragAnnD target expr- = do- exp1 <- expr- pure $ PragmaD $ AnnP target exp1--pragLineD :: Quote m => Int -> String -> m Dec-pragLineD line file = pure $ PragmaD $ LineP line file--pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec-pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty--pragSCCFunD :: Quote m => Name -> m Dec-pragSCCFunD nm = pure $ PragmaD $ SCCP nm Nothing--pragSCCFunNamedD :: Quote m => Name -> String -> m Dec-pragSCCFunNamedD nm str = pure $ PragmaD $ SCCP nm (Just str)--dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con]- -> [m DerivClause] -> m Dec-dataInstD ctxt mb_bndrs ty ksig cons derivs =- do- ctxt1 <- ctxt- mb_bndrs1 <- traverse sequenceA mb_bndrs- ty1 <- ty- ksig1 <- sequenceA ksig- cons1 <- sequenceA cons- derivs1 <- sequenceA derivs- pure (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)--newtypeInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> m Con- -> [m DerivClause] -> m Dec-newtypeInstD ctxt mb_bndrs ty ksig con derivs =- do- ctxt1 <- ctxt- mb_bndrs1 <- traverse sequenceA mb_bndrs- ty1 <- ty- ksig1 <- sequenceA ksig- con1 <- con- derivs1 <- sequenceA derivs- pure (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)--tySynInstD :: Quote m => m TySynEqn -> m Dec-tySynInstD eqn =- do- eqn1 <- eqn- pure (TySynInstD eqn1)--dataFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Dec-dataFamilyD tc tvs kind =- do tvs' <- sequenceA tvs- kind' <- sequenceA kind- pure $ DataFamilyD tc tvs' kind'--openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig- -> Maybe InjectivityAnn -> m Dec-openTypeFamilyD tc tvs res inj =- do tvs' <- sequenceA tvs- res' <- res- pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)--closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig- -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec-closedTypeFamilyD tc tvs result injectivity eqns =- do tvs1 <- sequenceA tvs- result1 <- result- eqns1 <- sequenceA eqns- pure (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)--roleAnnotD :: Quote m => Name -> [Role] -> m Dec-roleAnnotD name roles = pure $ RoleAnnotD name roles--standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec-standaloneDerivD = standaloneDerivWithStrategyD Nothing--standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec-standaloneDerivWithStrategyD mdsq ctxtq tyq =- do- mds <- sequenceA mdsq- ctxt <- ctxtq- ty <- tyq- pure $ StandaloneDerivD mds ctxt ty--defaultSigD :: Quote m => Name -> m Type -> m Dec-defaultSigD n tyq =- do- ty <- tyq- pure $ DefaultSigD n ty---- | Pattern synonym declaration-patSynD :: Quote m => Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec-patSynD name args dir pat = do- args' <- args- dir' <- dir- pat' <- pat- pure (PatSynD name args' dir' pat')---- | Pattern synonym type signature-patSynSigD :: Quote m => Name -> m Type -> m Dec-patSynSigD nm ty =- do ty' <- ty- pure $ PatSynSigD nm ty'---- | Implicit parameter binding declaration. Can only be used in let--- and where clauses which consist entirely of implicit bindings.-implicitParamBindD :: Quote m => String -> m Exp -> m Dec-implicitParamBindD n e =- do- e' <- e- pure $ ImplicitParamBindD n e'--tySynEqn :: Quote m => (Maybe [m (TyVarBndr ())]) -> m Type -> m Type -> m TySynEqn-tySynEqn mb_bndrs lhs rhs =- do- mb_bndrs1 <- traverse sequenceA mb_bndrs- lhs1 <- lhs- rhs1 <- rhs- pure (TySynEqn mb_bndrs1 lhs1 rhs1)--cxt :: Quote m => [m Pred] -> m Cxt-cxt = sequenceA--derivClause :: Quote m => Maybe (m DerivStrategy) -> [m Pred] -> m DerivClause-derivClause mds p = do mds' <- sequenceA mds- p' <- cxt p- pure $ DerivClause mds' p'--stockStrategy :: Quote m => m DerivStrategy-stockStrategy = pure StockStrategy--anyclassStrategy :: Quote m => m DerivStrategy-anyclassStrategy = pure AnyclassStrategy--newtypeStrategy :: Quote m => m DerivStrategy-newtypeStrategy = pure NewtypeStrategy--viaStrategy :: Quote m => m Type -> m DerivStrategy-viaStrategy = fmap ViaStrategy--normalC :: Quote m => Name -> [m BangType] -> m Con-normalC con strtys = liftA (NormalC con) $ sequenceA strtys--recC :: Quote m => Name -> [m VarBangType] -> m Con-recC con varstrtys = liftA (RecC con) $ sequenceA varstrtys--infixC :: Quote m => m (Bang, Type) -> Name -> m (Bang, Type) -> m Con-infixC st1 con st2 = do st1' <- st1- st2' <- st2- pure $ InfixC st1' con st2'--forallC :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Con -> m Con-forallC ns ctxt con = do- ns' <- sequenceA ns- ctxt' <- ctxt- con' <- con- pure $ ForallC ns' ctxt' con'--gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con-gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty--recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con-recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty------------------------------------------------------------------------------------ * Type--forallT :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Type -> m Type-forallT tvars ctxt ty = do- tvars1 <- sequenceA tvars- ctxt1 <- ctxt- ty1 <- ty- pure $ ForallT tvars1 ctxt1 ty1--forallVisT :: Quote m => [m (TyVarBndr ())] -> m Type -> m Type-forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty--varT :: Quote m => Name -> m Type-varT = pure . VarT--conT :: Quote m => Name -> m Type-conT = pure . ConT--infixT :: Quote m => m Type -> Name -> m Type -> m Type-infixT t1 n t2 = do t1' <- t1- t2' <- t2- pure (InfixT t1' n t2')--uInfixT :: Quote m => m Type -> Name -> m Type -> m Type-uInfixT t1 n t2 = do t1' <- t1- t2' <- t2- pure (UInfixT t1' n t2')--promotedInfixT :: Quote m => m Type -> Name -> m Type -> m Type-promotedInfixT t1 n t2 = do t1' <- t1- t2' <- t2- pure (PromotedInfixT t1' n t2')--promotedUInfixT :: Quote m => m Type -> Name -> m Type -> m Type-promotedUInfixT t1 n t2 = do t1' <- t1- t2' <- t2- pure (PromotedUInfixT t1' n t2')--parensT :: Quote m => m Type -> m Type-parensT t = do t' <- t- pure (ParensT t')--appT :: Quote m => m Type -> m Type -> m Type-appT t1 t2 = do- t1' <- t1- t2' <- t2- pure $ AppT t1' t2'--appKindT :: Quote m => m Type -> m Kind -> m Type-appKindT ty ki = do- ty' <- ty- ki' <- ki- pure $ AppKindT ty' ki'--arrowT :: Quote m => m Type-arrowT = pure ArrowT--mulArrowT :: Quote m => m Type-mulArrowT = pure MulArrowT--listT :: Quote m => m Type-listT = pure ListT--litT :: Quote m => m TyLit -> m Type-litT l = fmap LitT l--tupleT :: Quote m => Int -> m Type-tupleT i = pure (TupleT i)--unboxedTupleT :: Quote m => Int -> m Type-unboxedTupleT i = pure (UnboxedTupleT i)--unboxedSumT :: Quote m => SumArity -> m Type-unboxedSumT arity = pure (UnboxedSumT arity)--sigT :: Quote m => m Type -> m Kind -> m Type-sigT t k- = do- t' <- t- k' <- k- pure $ SigT t' k'--equalityT :: Quote m => m Type-equalityT = pure EqualityT--wildCardT :: Quote m => m Type-wildCardT = pure WildCardT--implicitParamT :: Quote m => String -> m Type -> m Type-implicitParamT n t- = do- t' <- t- pure $ ImplicitParamT n t'--{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}-classP :: Quote m => Name -> [m Type] -> m Pred-classP cla tys- = do- tysl <- sequenceA tys- pure (foldl AppT (ConT cla) tysl)--{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}-equalP :: Quote m => m Type -> m Type -> m Pred-equalP tleft tright- = do- tleft1 <- tleft- tright1 <- tright- eqT <- equalityT- pure (foldl AppT eqT [tleft1, tright1])--promotedT :: Quote m => Name -> m Type-promotedT = pure . PromotedT--promotedTupleT :: Quote m => Int -> m Type-promotedTupleT i = pure (PromotedTupleT i)--promotedNilT :: Quote m => m Type-promotedNilT = pure PromotedNilT--promotedConsT :: Quote m => m Type-promotedConsT = pure PromotedConsT--noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: Quote m => m SourceUnpackedness-noSourceUnpackedness = pure NoSourceUnpackedness-sourceNoUnpack = pure SourceNoUnpack-sourceUnpack = pure SourceUnpack--noSourceStrictness, sourceLazy, sourceStrict :: Quote m => m SourceStrictness-noSourceStrictness = pure NoSourceStrictness-sourceLazy = pure SourceLazy-sourceStrict = pure SourceStrict--{-# DEPRECATED isStrict- ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",- "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}-{-# DEPRECATED notStrict- ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",- "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}-{-# DEPRECATED unpacked- ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",- "Example usage: 'bang sourceUnpack sourceStrict'"] #-}-isStrict, notStrict, unpacked :: Quote m => m Strict-isStrict = bang noSourceUnpackedness sourceStrict-notStrict = bang noSourceUnpackedness noSourceStrictness-unpacked = bang sourceUnpack sourceStrict--bang :: Quote m => m SourceUnpackedness -> m SourceStrictness -> m Bang-bang u s = do u' <- u- s' <- s- pure (Bang u' s')--bangType :: Quote m => m Bang -> m Type -> m BangType-bangType = liftA2 (,)--varBangType :: Quote m => Name -> m BangType -> m VarBangType-varBangType v bt = (\(b, t) -> (v, b, t)) <$> bt--{-# DEPRECATED strictType- "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}-strictType :: Quote m => m Strict -> m Type -> m StrictType-strictType = bangType--{-# DEPRECATED varStrictType- "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}-varStrictType :: Quote m => Name -> m StrictType -> m VarStrictType-varStrictType = varBangType---- * Type Literals---- MonadFail here complicates things (a lot) because it would mean we would--- have to emit a MonadFail constraint during typechecking if there was any--- chance the desugaring would use numTyLit, which in general is hard to--- predict.-numTyLit :: Quote m => Integer -> m TyLit-numTyLit n = if n >= 0 then pure (NumTyLit n)- else error ("Negative type-level number: " ++ show n)--strTyLit :: Quote m => String -> m TyLit-strTyLit s = pure (StrTyLit s)--charTyLit :: Quote m => Char -> m TyLit-charTyLit c = pure (CharTyLit c)------------------------------------------------------------------------------------ * Kind--plainTV :: Quote m => Name -> m (TyVarBndr ())-plainTV n = pure $ PlainTV n ()--plainInvisTV :: Quote m => Name -> Specificity -> m (TyVarBndr Specificity)-plainInvisTV n s = pure $ PlainTV n s--plainBndrTV :: Quote m => Name -> BndrVis -> m (TyVarBndr BndrVis)-plainBndrTV n v = pure $ PlainTV n v--kindedTV :: Quote m => Name -> m Kind -> m (TyVarBndr ())-kindedTV n = fmap (KindedTV n ())--kindedInvisTV :: Quote m => Name -> Specificity -> m Kind -> m (TyVarBndr Specificity)-kindedInvisTV n s = fmap (KindedTV n s)--kindedBndrTV :: Quote m => Name -> BndrVis -> m Kind -> m (TyVarBndr BndrVis)-kindedBndrTV n v = fmap (KindedTV n v)--specifiedSpec :: Specificity-specifiedSpec = SpecifiedSpec--inferredSpec :: Specificity-inferredSpec = InferredSpec--bndrReq :: BndrVis-bndrReq = BndrReq--bndrInvis :: BndrVis-bndrInvis = BndrInvis--varK :: Name -> Kind-varK = VarT--conK :: Name -> Kind-conK = ConT--tupleK :: Int -> Kind-tupleK = TupleT--arrowK :: Kind-arrowK = ArrowT--listK :: Kind-listK = ListT--appK :: Kind -> Kind -> Kind-appK = AppT--starK :: Quote m => m Kind-starK = pure StarT--constraintK :: Quote m => m Kind-constraintK = pure ConstraintT------------------------------------------------------------------------------------ * Type family result--noSig :: Quote m => m FamilyResultSig-noSig = pure NoSig--kindSig :: Quote m => m Kind -> m FamilyResultSig-kindSig = fmap KindSig--tyVarSig :: Quote m => m (TyVarBndr ()) -> m FamilyResultSig-tyVarSig = fmap TyVarSig------------------------------------------------------------------------------------ * Injectivity annotation--injectivityAnn :: Name -> [Name] -> InjectivityAnn-injectivityAnn = TH.InjectivityAnn------------------------------------------------------------------------------------ * Role--nominalR, representationalR, phantomR, inferR :: Role-nominalR = NominalR-representationalR = RepresentationalR-phantomR = PhantomR-inferR = InferR------------------------------------------------------------------------------------ * Callconv--cCall, stdCall, cApi, prim, javaScript :: Callconv-cCall = CCall-stdCall = StdCall-cApi = CApi-prim = Prim-javaScript = JavaScript------------------------------------------------------------------------------------ * Safety--unsafe, safe, interruptible :: Safety-unsafe = Unsafe-safe = Safe-interruptible = Interruptible------------------------------------------------------------------------------------ * FunDep--funDep :: [Name] -> [Name] -> FunDep-funDep = FunDep------------------------------------------------------------------------------------ * RuleBndr-ruleVar :: Quote m => Name -> m RuleBndr-ruleVar = pure . RuleVar--typedRuleVar :: Quote m => Name -> m Type -> m RuleBndr-typedRuleVar n ty = TypedRuleVar n <$> ty------------------------------------------------------------------------------------ * AnnTarget-valueAnnotation :: Name -> AnnTarget-valueAnnotation = ValueAnnotation--typeAnnotation :: Name -> AnnTarget-typeAnnotation = TypeAnnotation--moduleAnnotation :: AnnTarget-moduleAnnotation = ModuleAnnotation------------------------------------------------------------------------------------ * Pattern Synonyms (sub constructs)--unidir, implBidir :: Quote m => m PatSynDir-unidir = pure Unidir-implBidir = pure ImplBidir--explBidir :: Quote m => [m Clause] -> m PatSynDir-explBidir cls = do- cls' <- sequenceA cls- pure (ExplBidir cls')--prefixPatSyn :: Quote m => [Name] -> m PatSynArgs-prefixPatSyn args = pure $ PrefixPatSyn args--recordPatSyn :: Quote m => [Name] -> m PatSynArgs-recordPatSyn sels = pure $ RecordPatSyn sels--infixPatSyn :: Quote m => Name -> Name -> m PatSynArgs-infixPatSyn arg1 arg2 = pure $ InfixPatSyn arg1 arg2------------------------------------------------------------------- * Useful helper function--appsE :: Quote m => [m Exp] -> m Exp-appsE [] = error "appsE []"-appsE [x] = x-appsE (x:y:zs) = appsE ( (appE x y) : zs )---- | pure the Module at the place of splicing. Can be used as an--- input for 'reifyModule'.-thisModule :: Q Module-thisModule = do- loc <- location- pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)------------------------------------------------------------------- * Documentation combinators---- | Attaches Haddock documentation to the declaration provided. Unlike--- 'putDoc', the names do not need to be in scope when calling this function so--- it can be used for quoted declarations and anything else currently being--- spliced.--- Not all declarations can have documentation attached to them. For those that--- can't, 'withDecDoc' will return it unchanged without any side effects.-withDecDoc :: String -> Q Dec -> Q Dec-withDecDoc doc dec = do- dec' <- dec- case doc_loc dec' of- Just loc -> qAddModFinalizer $ qPutDoc loc doc- Nothing -> pure ()- pure dec'- where- doc_loc (FunD n _) = Just $ DeclDoc n- doc_loc (ValD (VarP n) _ _) = Just $ DeclDoc n- doc_loc (DataD _ n _ _ _ _) = Just $ DeclDoc n- doc_loc (NewtypeD _ n _ _ _ _) = Just $ DeclDoc n- doc_loc (TypeDataD n _ _ _) = Just $ DeclDoc n- doc_loc (TySynD n _ _) = Just $ DeclDoc n- doc_loc (ClassD _ n _ _ _) = Just $ DeclDoc n- doc_loc (SigD n _) = Just $ DeclDoc n- doc_loc (ForeignD (ImportF _ _ _ n _)) = Just $ DeclDoc n- doc_loc (ForeignD (ExportF _ _ n _)) = Just $ DeclDoc n- doc_loc (InfixD _ _ n) = Just $ DeclDoc n- doc_loc (DataFamilyD n _ _) = Just $ DeclDoc n- doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _)) = Just $ DeclDoc n- doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n- doc_loc (PatSynD n _ _ _) = Just $ DeclDoc n- doc_loc (PatSynSigD n _) = Just $ DeclDoc n-- -- For instances we just pass along the full type- doc_loc (InstanceD _ _ t _) = Just $ InstDoc t- doc_loc (DataInstD _ _ t _ _ _) = Just $ InstDoc t- doc_loc (NewtypeInstD _ _ t _ _ _) = Just $ InstDoc t- doc_loc (TySynInstD (TySynEqn _ t _)) = Just $ InstDoc t-- -- Declarations that can't have documentation attached to- -- ValDs that aren't a simple variable pattern- doc_loc (ValD _ _ _) = Nothing- doc_loc (KiSigD _ _) = Nothing- doc_loc (PragmaD _) = Nothing- doc_loc (RoleAnnotD _ _) = Nothing- doc_loc (StandaloneDerivD _ _ _) = Nothing- doc_loc (DefaultSigD _ _) = Nothing- doc_loc (ImplicitParamBindD _ _) = Nothing- doc_loc (DefaultD _) = Nothing---- | Variant of 'withDecDoc' that applies the same documentation to--- multiple declarations. Useful for documenting quoted declarations.-withDecsDoc :: String -> Q [Dec] -> Q [Dec]-withDecsDoc doc decs = decs >>= mapM (withDecDoc doc . pure)---- | Variant of 'funD' that attaches Haddock documentation.-funD_doc :: Name -> [Q Clause]- -> Maybe String -- ^ Documentation to attach to function- -> [Maybe String] -- ^ Documentation to attach to arguments- -> Q Dec-funD_doc nm cs mfun_doc arg_docs = do- qAddModFinalizer $ sequence_- [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]- let dec = funD nm cs- case mfun_doc of- Just fun_doc -> withDecDoc fun_doc dec- Nothing -> funD nm cs---- | Variant of 'dataD' that attaches Haddock documentation.-dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)- -> [(Q Con, Maybe String, [Maybe String])]- -- ^ List of constructors, documentation for the constructor, and- -- documentation for the arguments- -> [Q DerivClause]- -> Maybe String- -- ^ Documentation to attach to the data declaration- -> Q Dec-dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do- qAddModFinalizer $ mapM_ docCons cons_with_docs- let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs- maybe dec (flip withDecDoc dec) mdoc---- | Variant of 'newtypeD' that attaches Haddock documentation.-newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)- -> (Q Con, Maybe String, [Maybe String])- -- ^ The constructor, documentation for the constructor, and- -- documentation for the arguments- -> [Q DerivClause]- -> Maybe String- -- ^ Documentation to attach to the newtype declaration- -> Q Dec-newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do- qAddModFinalizer $ docCons con_with_docs- let dec = newtypeD ctxt tc tvs ksig con derivs- maybe dec (flip withDecDoc dec) mdoc---- | Variant of 'typeDataD' that attaches Haddock documentation.-typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)- -> [(Q Con, Maybe String, [Maybe String])]- -- ^ List of constructors, documentation for the constructor, and- -- documentation for the arguments- -> Maybe String- -- ^ Documentation to attach to the data declaration- -> Q Dec-typeDataD_doc tc tvs ksig cons_with_docs mdoc = do- qAddModFinalizer $ mapM_ docCons cons_with_docs- let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)- maybe dec (flip withDecDoc dec) mdoc---- | Variant of 'dataInstD' that attaches Haddock documentation.-dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)- -> [(Q Con, Maybe String, [Maybe String])]- -- ^ List of constructors, documentation for the constructor, and- -- documentation for the arguments- -> [Q DerivClause]- -> Maybe String- -- ^ Documentation to attach to the instance declaration- -> Q Dec-dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do- qAddModFinalizer $ mapM_ docCons cons_with_docs- let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)- derivs- maybe dec (flip withDecDoc dec) mdoc---- | Variant of 'newtypeInstD' that attaches Haddock documentation.-newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type- -> Maybe (Q Kind)- -> (Q Con, Maybe String, [Maybe String])- -- ^ The constructor, documentation for the constructor, and- -- documentation for the arguments- -> [Q DerivClause]- -> Maybe String- -- ^ Documentation to attach to the instance declaration- -> Q Dec-newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do- qAddModFinalizer $ docCons con_with_docs- let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs- maybe dec (flip withDecDoc dec) mdoc---- | Variant of 'patSynD' that attaches Haddock documentation.-patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat- -> Maybe String -- ^ Documentation to attach to the pattern synonym- -> [Maybe String] -- ^ Documentation to attach to the pattern arguments- -> Q Dec-patSynD_doc name args dir pat mdoc arg_docs = do- qAddModFinalizer $ sequence_- [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]- let dec = patSynD name args dir pat- maybe dec (flip withDecDoc dec) mdoc---- | Document a data/newtype constructor with its arguments.-docCons :: (Q Con, Maybe String, [Maybe String]) -> Q ()-docCons (c, md, arg_docs) = do- c' <- c- -- Attach docs to the constructors- sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ]- -- Attach docs to the arguments- case c' of- -- Record selector documentation isn't stored in the argument map,- -- but in the declaration map instead- RecC _ var_bang_types ->- sequence_ [ putDoc (DeclDoc nm) arg_doc- | (Just arg_doc, (nm, _, _)) <- zip arg_docs var_bang_types- ]- _ ->- sequence_ [ putDoc (ArgDoc nm i) arg_doc- | nm <- get_cons_names c'- , (i, Just arg_doc) <- zip [0..] arg_docs- ]
− Language/Haskell/TH/Lib/Map.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE Safe #-}---- This is a non-exposed internal module------ The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost--- verbatimely to avoid a dependency of 'template-haskell' on the containers package.------ [1] see https://hackage.haskell.org/package/containers-0.5.5.1------ The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.--module Language.Haskell.TH.Lib.Map- ( Map- , empty- , insert- , Language.Haskell.TH.Lib.Map.lookup- ) where--import Prelude--data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)- | Tip--type Size = Int--empty :: Map k a-empty = Tip-{-# INLINE empty #-}--singleton :: k -> a -> Map k a-singleton k x = Bin 1 k x Tip Tip-{-# INLINE singleton #-}--size :: Map k a -> Int-size Tip = 0-size (Bin sz _ _ _ _) = sz-{-# INLINE size #-}--lookup :: Ord k => k -> Map k a -> Maybe a-lookup = go- where- go _ Tip = Nothing- go !k (Bin _ kx x l r) = case compare k kx of- LT -> go k l- GT -> go k r- EQ -> Just x-{-# INLINABLE lookup #-}---insert :: Ord k => k -> a -> Map k a -> Map k a-insert = go- where- go :: Ord k => k -> a -> Map k a -> Map k a- go !kx x Tip = singleton kx x- go !kx x (Bin sz ky y l r) =- case compare kx ky of- LT -> balanceL ky y (go kx x l) r- GT -> balanceR ky y l (go kx x r)- EQ -> Bin sz kx x l r-{-# INLINABLE insert #-}--balanceL :: k -> a -> Map k a -> Map k a -> Map k a-balanceL k x l r = case r of- Tip -> case l of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip- (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)- (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)- (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))- | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)- | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)-- (Bin rs _ _ _ _) -> case l of- Tip -> Bin (1+rs) k x Tip r-- (Bin ls lk lx ll lr)- | ls > delta*rs -> case (ll, lr) of- (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)- | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)- | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)- (_, _) -> error "Failure in Data.Map.balanceL"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceL #-}--balanceR :: k -> a -> Map k a -> Map k a -> Map k a-balanceR k x l r = case l of- Tip -> case r of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r- (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr- (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)- (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))- | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr- | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-- (Bin ls _ _ _ _) -> case r of- Tip -> Bin (1+ls) k x l Tip-- (Bin rs rk rx rl rr)- | rs > delta*ls -> case (rl, rr) of- (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)- | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr- | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)- (_, _) -> error "Failure in Data.Map.balanceR"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceR #-}--delta,ratio :: Int-delta = 3-ratio = 2
Language/Haskell/TH/Ppr.hs view
@@ -1,1075 +1,91 @@ {-# LANGUAGE Safe #-}-{-# LANGUAGE LambdaCase #-}--- | contains a prettyprinter for the--- Template Haskell datatypes--module Language.Haskell.TH.Ppr where- -- All of the exports from this module should- -- be "public" functions. The main module TH- -- re-exports them all.--import Text.PrettyPrint (render)-import Language.Haskell.TH.PprLib-import Language.Haskell.TH.Syntax-import Data.Word ( Word8 )-import Data.Char ( toLower, chr)-import GHC.Show ( showMultiLineString )-import GHC.Lexeme( isVarSymChar )-import Data.Ratio ( numerator, denominator )-import Data.Foldable ( toList )-import Prelude hiding ((<>))--nestDepth :: Int-nestDepth = 4--type Precedence = Int-appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence-appPrec = 6 -- Argument of a function or type application-opPrec = 5 -- Argument of an infix operator-unopPrec = 4 -- Argument of an unresolved infix operator-funPrec = 3 -- Argument of a function arrow-qualPrec = 2 -- Forall-qualified type or result of a function arrow-sigPrec = 1 -- Argument of an explicit type signature-noPrec = 0 -- Others--parensIf :: Bool -> Doc -> Doc-parensIf True d = parens d-parensIf False d = d----------------------------------pprint :: Ppr a => a -> String-pprint x = render $ to_HPJ_Doc $ ppr x--class Ppr a where- ppr :: a -> Doc- ppr_list :: [a] -> Doc- ppr_list = vcat . map ppr--instance Ppr a => Ppr [a] where- ppr x = ppr_list x---------------------------------instance Ppr Name where- ppr v = pprName v---------------------------------instance Ppr Info where- ppr (TyConI d) = ppr d- ppr (ClassI d is) = ppr d $$ vcat (map ppr is)- ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)- ppr (PrimTyConI name arity is_unlifted)- = text "Primitive"- <+> (if is_unlifted then text "unlifted" else empty)- <+> text "type constructor" <+> quotes (ppr name)- <+> parens (text "arity" <+> int arity)- ppr (ClassOpI v ty cls)- = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty- ppr (DataConI v ty tc)- = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty- ppr (PatSynI nm ty) = pprPatSynSig nm ty- ppr (TyVarI v ty)- = text "Type variable" <+> ppr v <+> equals <+> ppr ty- ppr (VarI v ty mb_d)- = vcat [ppr_sig v ty,- case mb_d of { Nothing -> empty; Just d -> ppr d }]--ppr_sig :: Name -> Type -> Doc-ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty--pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc-pprFixity _ f _ | f == defaultFixity = empty-pprFixity v (Fixity i d) ns_spec- = ppr_fix d <+> int i <+> pprNamespaceSpecifier ns_spec <+> pprName' Infix v- where ppr_fix InfixR = text "infixr"- ppr_fix InfixL = text "infixl"- ppr_fix InfixN = text "infix"--pprNamespaceSpecifier :: NamespaceSpecifier -> Doc-pprNamespaceSpecifier NoNamespaceSpecifier = empty-pprNamespaceSpecifier TypeNamespaceSpecifier = text "type"-pprNamespaceSpecifier DataNamespaceSpecifier = text "data"---- | Pretty prints a pattern synonym type signature-pprPatSynSig :: Name -> PatSynType -> Doc-pprPatSynSig nm ty- = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty---- | Pretty prints a pattern synonym's type; follows the usual--- conventions to print a pattern synonym type compactly, yet--- unambiguously. See the note on 'PatSynType' and the section on--- pattern synonyms in the GHC user's guide for more information.-pprPatSynType :: PatSynType -> Doc-pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))- | null exTys, null provs = ppr (ForallT uniTys reqs ty'')- | null uniTys, null reqs = noreqs <+> ppr ty'- | null reqs = pprForallBndrs uniTys <+> noreqs <+> ppr ty'- | otherwise = ppr ty- where noreqs = text "() =>"- pprForallBndrs tvs = text "forall" <+> hsep (map ppr tvs) <+> text "."-pprPatSynType ty = ppr ty---------------------------------instance Ppr Module where- ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)--instance Ppr ModuleInfo where- ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)---------------------------------instance Ppr Exp where- ppr = pprExp noPrec--pprPrefixOcc :: Name -> Doc--- Print operators with parens around them-pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)--isSymOcc :: Name -> Bool-isSymOcc n- = case nameBase n of- [] -> True -- Empty name; weird- (c:_) -> isVarSymChar c- -- c.f. isVarSymChar in GHC itself--pprInfixExp :: Exp -> Doc-pprInfixExp (VarE v) = pprName' Infix v-pprInfixExp (ConE v) = pprName' Infix v-pprInfixExp (UnboundVarE v) = pprName' Infix v--- This case will only ever be reached in exceptional circumstances.--- For example, when printing an error message in case of a malformed expression.-pprInfixExp e = text "`" <> ppr e <> text "`"--pprExp :: Precedence -> Exp -> Doc-pprExp _ (VarE v) = pprName' Applied v-pprExp _ (ConE c) = pprName' Applied c-pprExp i (LitE l) = pprLit i l-pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1- <+> pprExp appPrec e2-pprExp i (AppTypeE e t)- = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t-pprExp _ (ParensE e) = parens (pprExp noPrec e)-pprExp i (UInfixE e1 op e2)- = parensIf (i > unopPrec) $ pprExp unopPrec e1- <+> pprInfixExp op- <+> pprExp unopPrec e2-pprExp i (InfixE (Just e1) op (Just e2))- = parensIf (i >= opPrec) $ pprExp opPrec e1- <+> pprInfixExp op- <+> pprExp opPrec e2-pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1- <+> pprInfixExp op- <+> pprMaybeExp noPrec me2-pprExp i (LamE [] e) = pprExp i e -- #13856-pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)- <+> text "->" <+> ppr e-pprExp i (LamCaseE ms)- = parensIf (i > noPrec) $ text "\\case" $$ braces (semiSep ms)-pprExp i (LamCasesE ms)- = parensIf (i > noPrec) $ text "\\cases" $$ braces (semi_sep ms)- where semi_sep = sep . punctuate semi . map (pprClause False)-pprExp i (TupE es)- | [Just e] <- es- = pprExp i (ConE (tupleDataName 1) `AppE` e)- | otherwise- = parens (commaSepWith (pprMaybeExp noPrec) es)-pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es)-pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity--- Nesting in Cond is to avoid potential problems in do statements-pprExp i (CondE guard true false)- = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,- nest 1 $ text "then" <+> ppr true,- nest 1 $ text "else" <+> ppr false]-pprExp i (MultiIfE alts)- = parensIf (i > noPrec) $ vcat $- case alts of- [] -> [text "if {}"]- (alt : alts') -> text "if" <+> pprGuarded arrow alt- : map (nest 3 . pprGuarded arrow) alts'-pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_- $$ text " in" <+> ppr e- where- pprDecs [] = empty- pprDecs [d] = ppr d- pprDecs ds = braces (semiSep ds)--pprExp i (CaseE e ms)- = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"- $$ braces (semiSep ms)-pprExp i (DoE m ss_) = parensIf (i > noPrec) $- pprQualifier m <> text "do" <+> pprStms ss_- where- pprQualifier Nothing = empty- pprQualifier (Just modName) = text (modString modName) <> char '.'- pprStms [] = empty- pprStms [s] = ppr s- pprStms ss = braces (semiSep ss)-pprExp i (MDoE m ss_) = parensIf (i > noPrec) $- pprQualifier m <> text "mdo" <+> pprStms ss_- where- pprQualifier Nothing = empty- pprQualifier (Just modName) = text (modString modName) <> char '.'- pprStms [] = empty- pprStms [s] = ppr s- pprStms ss = braces (semiSep ss)--pprExp _ (CompE []) = text "<<Empty CompExp>>"--- This will probably break with fixity declarations - would need a ';'-pprExp _ (CompE ss) =- if null ss'- -- If there are no statements in a list comprehension besides the last- -- one, we simply treat it like a normal list.- then text "[" <> ppr s <> text "]"- else text "[" <> ppr s- <+> bar- <+> commaSep ss'- <> text "]"- where s = last ss- ss' = init ss-pprExp _ (ArithSeqE d) = ppr d-pprExp _ (ListE es) = brackets (commaSep es)-pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e- <+> dcolon <+> pprType sigPrec t-pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)-pprExp i (StaticE e) = parensIf (i >= appPrec) $- text "static"<+> pprExp appPrec e-pprExp _ (UnboundVarE v) = pprName' Applied v-pprExp _ (LabelE s) = text "#" <> text s-pprExp _ (ImplicitParamVarE n) = text ('?' : n)-pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f)-pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs-pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]"-pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e-pprExp i (TypeE t) = parensIf (i > noPrec) $ text "type" <+> ppr t--pprFields :: [(Name,Exp)] -> Doc-pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)--pprMaybeExp :: Precedence -> Maybe Exp -> Doc-pprMaybeExp _ Nothing = empty-pprMaybeExp i (Just e) = pprExp i e---------------------------------instance Ppr Stmt where- ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e- ppr (LetS ds) = text "let" <+> (braces (semiSep ds))- ppr (NoBindS e) = ppr e- ppr (ParS sss) = sep $ punctuate bar- $ map commaSep sss- ppr (RecS ss) = text "rec" <+> (braces (semiSep ss))---------------------------------instance Ppr Match where- ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs- $$ where_clause ds--pprMatchPat :: Pat -> Doc--- Everything except pattern signatures bind more tightly than (->)-pprMatchPat p@(SigP {}) = parens (ppr p)-pprMatchPat p = ppr p---------------------------------pprGuarded :: Doc -> (Guard, Exp) -> Doc-pprGuarded eqDoc (guard, expr) = case guard of- NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr- PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$- nest nestDepth (eqDoc <+> ppr expr)---------------------------------pprBody :: Bool -> Body -> Doc-pprBody eq body = case body of- GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs- NormalB e -> eqDoc <+> ppr e- where eqDoc | eq = equals- | otherwise = arrow---------------------------------pprClause :: Bool -> Clause -> Doc-pprClause eqDoc (Clause ps rhs ds)- = hsep (map (pprPat appPrec) ps) <+> pprBody eqDoc rhs- $$ where_clause ds---------------------------------instance Ppr Lit where- ppr = pprLit noPrec--pprLit :: Precedence -> Lit -> Doc-pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)- (integer x <> char '#')-pprLit _ (WordPrimL x) = integer x <> text "##"-pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)- (float (fromRational x) <> char '#')-pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)- (double (fromRational x) <> text "##")-pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)-pprLit _ (CharL c) = text (show c)-pprLit _ (CharPrimL c) = text (show c) <> char '#'-pprLit _ (StringL s) = pprString s-pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'-pprLit _ (BytesPrimL {}) = pprString "<binary data>"-pprLit i (RationalL rat)- | withoutFactor 2 (withoutFactor 5 $ denominator rat) /= 1- -- if the denominator has prime factors other than 2 and 5- -- or can't be represented as Double, show as fraction- = parensIf (i > noPrec) $- integer (numerator rat) <+> char '/' <+> integer (denominator rat)- | rat /= 0 && (zeroes < -2 || zeroes > 6),- let (n, d) = properFraction (rat / magnitude)- -- if < 0.01 or >= 100_000_000, use scientific notation- = parensIf (i > noPrec && rat < 0)- (integer n- <> (if d == 0 then empty else char '.' <> decimals (abs d))- <> char 'e' <> integer zeroes)- | let (n, d) = properFraction rat- = parensIf (i > noPrec && rat < 0)- (integer n <> char '.'- <> if d == 0 then char '0' else decimals (abs d))- where zeroes :: Integer- zeroes = log10 (abs rat)- log10 :: Rational -> Integer- log10 x- | x >= 10 = 1 + log10 (x / 10)- | x < 1 = -1 + log10 (x * 10)- | otherwise = 0- magnitude :: Rational- magnitude = 10 ^^ zeroes- withoutFactor :: Integer -> Integer -> Integer- withoutFactor _ 0 = 0- withoutFactor p n- | (n', 0) <- divMod n p = withoutFactor p n'- | otherwise = n- -- | Expects the argument 0 <= x < 1- decimals :: Rational -> Doc- decimals x- | x == 0 = empty- | otherwise = integer n <> decimals d- where (n, d) = properFraction (x * 10)--bytesToString :: [Word8] -> String-bytesToString = map (chr . fromIntegral)--pprString :: String -> Doc--- Print newlines as newlines with Haskell string escape notation,--- not as '\n'. For other non-printables use regular escape notation.-pprString s = vcat (map text (showMultiLineString s))---------------------------------instance Ppr Pat where- ppr = pprPat noPrec--pprPat :: Precedence -> Pat -> Doc-pprPat i (LitP l) = pprLit i l-pprPat _ (VarP v) = pprName' Applied v-pprPat i (TupP ps)- | [_] <- ps- = pprPat i (ConP (tupleDataName 1) [] ps)- | otherwise- = parens (commaSep ps)-pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)-pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity-pprPat i (ConP s ts ps) = parensIf (i >= appPrec) $- pprName' Applied s- <+> sep (map (\t -> char '@' <> pprParendType t) ts)- <+> sep (map (pprPat appPrec) ps)-pprPat _ (ParensP p) = parens $ pprPat noPrec p-pprPat i (UInfixP p1 n p2)- = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>- pprName' Infix n <+>- pprPat unopPrec p2)-pprPat i (InfixP p1 n p2)- = parensIf (i >= opPrec) (pprPat opPrec p1 <+>- pprName' Infix n <+>- pprPat opPrec p2)-pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p-pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p-pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"- <> pprPat appPrec p-pprPat _ WildP = text "_"-pprPat _ (RecP nm fs)- = parens $ pprName' Applied nm- <+> braces (sep $ punctuate comma $- map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs)-pprPat _ (ListP ps) = brackets (commaSep ps)-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t-pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p-pprPat _ (TypeP t) = parens $ text "type" <+> ppr t-pprPat _ (InvisP t) = parens $ text "@" <+> ppr t---------------------------------instance Ppr Dec where- ppr = ppr_dec True--ppr_dec :: Bool -- ^ declaration on the toplevel?- -> Dec- -> Doc-ppr_dec isTop (FunD f cs) = layout $ map (\c -> pprPrefixOcc f <+> ppr c) cs- where- layout :: [Doc] -> Doc- layout = if isTop then vcat else semiSepWith id-ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r- $$ where_clause ds-ppr_dec _ (TySynD t xs rhs)- = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs-ppr_dec isTop (DataD ctxt t xs ksig cs decs)- = ppr_data isTop empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs-ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)- = ppr_newtype isTop empty ctxt (Just t) (sep (map ppr xs)) ksig c decs-ppr_dec isTop (TypeDataD t xs ksig cs)- = ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs []-ppr_dec _ (ClassD ctxt c xs fds ds)- = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds- $$ where_clause ds-ppr_dec _ (InstanceD o ctxt i ds) =- text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i- $$ where_clause ds-ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t-ppr_dec _ (KiSigD f k) = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k-ppr_dec _ (ForeignD f) = ppr f-ppr_dec _ (InfixD fx ns_spec n) = pprFixity n fx ns_spec-ppr_dec _ (DefaultD tys) =- text "default" <+> parens (sep $ punctuate comma $ map ppr tys)-ppr_dec _ (PragmaD p) = ppr p-ppr_dec isTop (DataFamilyD tc tvs kind)- = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind- where- maybeFamily | isTop = text "family"- | otherwise = empty- maybeKind | (Just k') <- kind = dcolon <+> ppr k'- | otherwise = empty-ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)- = ppr_data isTop (maybeInst <+> ppr_bndrs bndrs)- ctxt Nothing (ppr ty) ksig cs decs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)- = ppr_newtype isTop (maybeInst <+> ppr_bndrs bndrs)- ctxt Nothing (ppr ty) ksig c decs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs))- = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs)- Nothing (ppr ty) rhs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (OpenTypeFamilyD tfhead)- = text "type" <+> maybeFamily <+> ppr_tf_head tfhead- where- maybeFamily | isTop = text "family"- | otherwise = empty-ppr_dec _ (ClosedTypeFamilyD tfhead eqns)- = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")- nestDepth (vcat (map ppr_eqn eqns))- where- ppr_eqn (TySynEqn mb_bndrs lhs rhs)- = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs-ppr_dec _ (RoleAnnotD name roles)- = hsep [ text "type role", pprName' Applied name ] <+> hsep (map ppr roles)-ppr_dec _ (StandaloneDerivD ds cxt ty)- = hsep [ text "deriving"- , maybe empty ppr_deriv_strategy ds- , text "instance"- , pprCxt cxt- , ppr ty ]-ppr_dec _ (DefaultSigD n ty)- = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]-ppr_dec _ (PatSynD name args dir pat)- = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS- where- pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2- | otherwise = pprName' Applied name <+> ppr args- pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where")- nestDepth- (vcat $ (pprName' Applied name <+>) . ppr <$> cls)- | otherwise = ppr pat-ppr_dec _ (PatSynSigD name ty)- = pprPatSynSig name ty-ppr_dec _ (ImplicitParamBindD n e)- = hsep [text ('?' : n), text "=", ppr e]--ppr_deriv_strategy :: DerivStrategy -> Doc-ppr_deriv_strategy ds =- case ds of- StockStrategy -> text "stock"- AnyclassStrategy -> text "anyclass"- NewtypeStrategy -> text "newtype"- ViaStrategy ty -> text "via" <+> pprParendType ty--ppr_overlap :: Overlap -> Doc-ppr_overlap o = text $- case o of- Overlaps -> "{-# OVERLAPS #-}"- Overlappable -> "{-# OVERLAPPABLE #-}"- Overlapping -> "{-# OVERLAPPING #-}"- Incoherent -> "{-# INCOHERENT #-}"--ppr_data :: Bool -- ^ declaration on the toplevel?- -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]- -> Doc-ppr_data = ppr_typedef "data"--ppr_newtype :: Bool -- ^ declaration on the toplevel?- -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]- -> Doc-ppr_newtype isTop maybeInst ctxt t argsDoc ksig c decs- = ppr_typedef "newtype" isTop maybeInst ctxt t argsDoc ksig [c] decs--ppr_type_data :: Bool -- ^ declaration on the toplevel?- -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]- -> Doc-ppr_type_data = ppr_typedef "type data"--ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc-ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs- = sep [text data_or_newtype <+> maybeInst- <+> pprCxt ctxt- <+> case t of- Just n -> pprName' Applied n <+> argsDoc- Nothing -> argsDoc- <+> ksigDoc <+> maybeWhere,- nest nestDepth (layout (pref $ map ppr cs)),- if null decs- then empty- else nest nestDepth- $ vcat $ map ppr_deriv_clause decs]- where- pref :: [Doc] -> [Doc]- pref xs | isGadtDecl = xs- pref [] = [] -- No constructors; can't happen in H98- pref (d:ds) = (char '=' <+> d):map (bar <+>) ds-- layout :: [Doc] -> Doc- layout | isGadtDecl && not isTop = braces . semiSepWith id- | otherwise = vcat-- maybeWhere :: Doc- maybeWhere | isGadtDecl = text "where"- | otherwise = empty-- isGadtDecl :: Bool- isGadtDecl = not (null cs) && all isGadtCon cs- where isGadtCon (GadtC _ _ _ ) = True- isGadtCon (RecGadtC _ _ _) = True- isGadtCon (ForallC _ _ x ) = isGadtCon x- isGadtCon _ = False-- ksigDoc = case ksig of- Nothing -> empty- Just k -> dcolon <+> ppr k---ppr_deriv_clause :: DerivClause -> Doc-ppr_deriv_clause (DerivClause ds ctxt)- = text "deriving" <+> pp_strat_before- <+> ppr_cxt_preds appPrec ctxt- <+> pp_strat_after- where- -- @via@ is unique in that in comes /after/ the class being derived,- -- so we must special-case it.- (pp_strat_before, pp_strat_after) =- case ds of- Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via)- _ -> (maybe empty ppr_deriv_strategy ds, empty)--ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc-ppr_tySyn maybeInst t argsDoc rhs- = text "type" <+> maybeInst- <+> case t of- Just n -> pprName' Applied n <+> argsDoc- Nothing -> argsDoc- <+> text "=" <+> ppr rhs--ppr_tf_head :: TypeFamilyHead -> Doc-ppr_tf_head (TypeFamilyHead tc tvs res inj)- = pprName' Applied tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj- where- maybeInj | (Just inj') <- inj = ppr inj'- | otherwise = empty--ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc-ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."-ppr_bndrs Nothing = empty---------------------------------instance Ppr FunDep where- ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)- ppr_list [] = empty- ppr_list xs = bar <+> commaSep xs---------------------------------instance Ppr FamilyResultSig where- ppr NoSig = empty- ppr (KindSig k) = dcolon <+> ppr k- ppr (TyVarSig bndr) = text "=" <+> ppr bndr---------------------------------instance Ppr InjectivityAnn where- ppr (InjectivityAnn lhs rhs) =- bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)---------------------------------instance Ppr Foreign where- ppr (ImportF callconv safety impent as typ)- = text "foreign import"- <+> showtextl callconv- <+> showtextl safety- <+> text (show impent)- <+> pprName' Applied as- <+> dcolon <+> ppr typ- ppr (ExportF callconv expent as typ)- = text "foreign export"- <+> showtextl callconv- <+> text (show expent)- <+> pprName' Applied as- <+> dcolon <+> ppr typ---------------------------------instance Ppr Pragma where- ppr (InlineP n inline rm phases)- = text "{-#"- <+> ppr inline- <+> ppr rm- <+> ppr phases- <+> pprName' Applied n- <+> text "#-}"- ppr (OpaqueP n)- = text "{-# OPAQUE" <+> pprName' Applied n <+> text "#-}"- ppr (SpecialiseP n ty inline phases)- = text "{-# SPECIALISE"- <+> maybe empty ppr inline- <+> ppr phases- <+> sep [ pprName' Applied n <+> dcolon- , nest 2 $ ppr ty ]- <+> text "#-}"- ppr (SpecialiseInstP inst)- = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"- ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)- = sep [ text "{-# RULES" <+> pprString n <+> ppr phases- , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs- <+> ppr lhs- , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]- where ppr_ty_forall Nothing = empty- ppr_ty_forall (Just bndrs) = text "forall"- <+> fsep (map ppr bndrs)- <+> char '.'- ppr_tm_forall Nothing | null tm_bndrs = empty- ppr_tm_forall _ = text "forall"- <+> fsep (map ppr tm_bndrs)- <+> char '.'- ppr (AnnP tgt expr)- = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"- where target1 ModuleAnnotation = text "module"- target1 (TypeAnnotation t) = text "type" <+> pprName' Applied t- target1 (ValueAnnotation v) = pprName' Applied v- ppr (LineP line file)- = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"- ppr (CompleteP cls mty)- = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)- <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"- ppr (SCCP nm str)- = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}"---------------------------------instance Ppr Inline where- ppr NoInline = text "NOINLINE"- ppr Inline = text "INLINE"- ppr Inlinable = text "INLINABLE"---------------------------------instance Ppr RuleMatch where- ppr ConLike = text "CONLIKE"- ppr FunLike = empty---------------------------------instance Ppr Phases where- ppr AllPhases = empty- ppr (FromPhase i) = brackets $ int i- ppr (BeforePhase i) = brackets $ char '~' <> int i---------------------------------instance Ppr RuleBndr where- ppr (RuleVar n) = ppr n- ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty---------------------------------instance Ppr Clause where- ppr = pprClause True---------------------------------instance Ppr Con where- ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts)-- ppr (RecC c vsts)- = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))-- ppr (InfixC st1 c st2) = pprBangType st1- <+> pprName' Infix c- <+> pprBangType st2-- ppr (ForallC ns ctxt (GadtC cs sts ty))- = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt- <+> pprGadtRHS sts ty-- ppr (ForallC ns ctxt (RecGadtC cs vsts ty))- = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt- <+> pprRecFields vsts ty-- ppr (ForallC ns ctxt con)- = pprForall ns ctxt <+> ppr con-- ppr (GadtC cs sts ty)- = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty-- ppr (RecGadtC cs vsts ty)- = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty--instance Ppr PatSynDir where- ppr Unidir = text "<-"- ppr ImplBidir = text "="- ppr (ExplBidir _) = text "<-"- -- the ExplBidir's clauses are pretty printed together with the- -- entire pattern synonym; so only print the direction here.--instance Ppr PatSynArgs where- ppr (PrefixPatSyn args) = sep $ map ppr args- ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2- ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map (pprName' Applied) sels))--commaSepApplied :: [Name] -> Doc-commaSepApplied = commaSepWith (pprName' Applied)--pprForall :: [TyVarBndr Specificity] -> Cxt -> Doc-pprForall = pprForall' ForallInvis--pprForallVis :: [TyVarBndr ()] -> Cxt -> Doc-pprForallVis = pprForall' ForallVis--pprForall' :: PprFlag flag => ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc-pprForall' fvf tvs cxt- -- even in the case without any tvs, there could be a non-empty- -- context cxt (e.g., in the case of pattern synonyms, where there- -- are multiple forall binders and contexts).- | [] <- tvs = pprCxt cxt- | otherwise = text "forall" <+> hsep (map ppr tvs)- <+> separator <+> pprCxt cxt- where- separator = case fvf of- ForallVis -> text "->"- ForallInvis -> char '.'--pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc-pprRecFields vsts ty- = braces (sep (punctuate comma $ map pprVarBangType vsts))- <+> arrow <+> ppr ty--pprGadtRHS :: [(Strict, Type)] -> Type -> Doc-pprGadtRHS [] ty- = ppr ty-pprGadtRHS sts ty- = sep (punctuate (space <> arrow) (map pprBangType sts))- <+> arrow <+> ppr ty---------------------------------pprVarBangType :: VarBangType -> Doc--- Slight infelicity: with print non-atomic type with parens-pprVarBangType (v, bang, t) = pprName' Applied v <+> dcolon <+> pprBangType (bang, t)---------------------------------pprBangType :: BangType -> Doc--- Make sure we print------ Con {-# UNPACK #-} a------ rather than------ Con {-# UNPACK #-}a------ when there's no strictness annotation. If there is a strictness annotation,--- it's okay to not put a space between it and the type.-pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t-pprBangType (bt, t) = ppr bt <> pprParendType t---------------------------------instance Ppr Bang where- ppr (Bang su ss) = ppr su <+> ppr ss---------------------------------instance Ppr SourceUnpackedness where- ppr NoSourceUnpackedness = empty- ppr SourceNoUnpack = text "{-# NOUNPACK #-}"- ppr SourceUnpack = text "{-# UNPACK #-}"---------------------------------instance Ppr SourceStrictness where- ppr NoSourceStrictness = empty- ppr SourceLazy = char '~'- ppr SourceStrict = char '!'---------------------------------instance Ppr DecidedStrictness where- ppr DecidedLazy = empty- ppr DecidedStrict = char '!'- ppr DecidedUnpack = text "{-# UNPACK #-} !"---------------------------------{-# DEPRECATED pprVarStrictType- "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}-pprVarStrictType :: (Name, Strict, Type) -> Doc-pprVarStrictType = pprVarBangType---------------------------------{-# DEPRECATED pprStrictType- "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}-pprStrictType :: (Strict, Type) -> Doc-pprStrictType = pprBangType---------------------------------pprType :: Precedence -> Type -> Doc-pprType _ (VarT v) = pprName' Applied v--- `Applied` is used here instead of `ppr` because of infix names (#13887)-pprType _ (ConT c) = pprName' Applied c-pprType _ (TupleT 0) = text "()"-pprType p (TupleT 1) = pprType p (ConT (tupleTypeName 1))-pprType _ (TupleT n) = parens (hcat (replicate (n-1) comma))-pprType _ (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma-pprType _ (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar-pprType _ ArrowT = parens (text "->")-pprType _ MulArrowT = text "FUN"-pprType _ ListT = text "[]"-pprType _ (LitT l) = pprTyLit l-pprType _ (PromotedT c) = text "'" <> pprName' Applied c-pprType _ (PromotedTupleT 0) = text "'()"-pprType p (PromotedTupleT 1) = pprType p (PromotedT (tupleDataName 1))-pprType _ (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))-pprType _ PromotedNilT = text "'[]"-pprType _ PromotedConsT = text "'(:)"-pprType _ StarT = char '*'-pprType _ ConstraintT = text "Constraint"-pprType _ (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)-pprType _ WildCardT = char '_'-pprType p t@(InfixT {}) = pprInfixT p t-pprType p t@(UInfixT {}) = pprInfixT p t-pprType p t@(PromotedInfixT {}) = pprInfixT p t-pprType p t@(PromotedUInfixT {}) = pprInfixT p t-pprType _ (ParensT t) = parens (pprType noPrec t)-pprType p (ImplicitParamT n ty) =- parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty-pprType _ EqualityT = text "(~)"-pprType p (ForallT tvars ctxt ty) =- parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty]-pprType p (ForallVisT tvars ty) =- parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty]-pprType p t@AppT{} = pprTyApp p (split t)-pprType p t@AppKindT{} = pprTyApp p (split t)---------------------------------pprParendType :: Type -> Doc-pprParendType = pprType appPrec--pprInfixT :: Precedence -> Type -> Doc-pprInfixT p = \case- InfixT x n y -> with x n y "" opPrec- UInfixT x n y -> with x n y "" unopPrec- PromotedInfixT x n y -> with x n y "'" opPrec- PromotedUInfixT x n y -> with x n y "'" unopPrec- t -> pprParendType t- where- with x n y prefix p' =- parensIf- (p >= p')- (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y)--instance Ppr Type where- ppr = pprType noPrec-instance Ppr TypeArg where- ppr (TANormal ty) = ppr ty- ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)--pprParendTypeArg :: TypeArg -> Doc-pprParendTypeArg (TANormal ty) = pprParendType ty-pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)--isStarT :: Type -> Bool-isStarT StarT = True-isStarT _ = False--{- Note [Pretty-printing kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC's parser only recognises a kind signature in a type when there are-parens around it. E.g. the parens are required here:- f :: (Int :: *)- type instance F Int = (Bool :: *)-So we always print a SigT with parens (see #10050). -}--pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc-pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])- | p >= funPrec = parens (pprTyApp noPrec app)- | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2]- | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]-pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =- parensIf (p >= funPrec) $- sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->",- pprType qualPrec arg2]-pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) =- parensIf (p >= funPrec) $- sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]-pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) =- parensIf (p >= opPrec) $- sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2]-pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg)-pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args)-pprTyApp _ (TupleT n, args)- | length args == n, Just args' <- traverse fromTANormal args- = parens (commaSep args')-pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args)-pprTyApp _ (PromotedTupleT n, args)- | length args == n, Just args' <- traverse fromTANormal args- = quoteParens (commaSep args')-pprTyApp p (fun, args) =- parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args)--fromTANormal :: TypeArg -> Maybe Type-fromTANormal (TANormal arg) = Just arg-fromTANormal (TyArg _) = Nothing---- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->).-pprFunArgType :: Type -> Doc-pprFunArgType = pprType funPrec--data ForallVisFlag = ForallVis -- forall a -> {...}- | ForallInvis -- forall a. {...}- deriving Show--data TypeArg = TANormal Type- | TyArg Kind--split :: Type -> (Type, [TypeArg]) -- Split into function and args-split t = go t []- where go (AppT t1 t2) args = go t1 (TANormal t2:args)- go (AppKindT ty ki) args = go ty (TyArg ki:args)- go ty args = (ty, args)--pprTyLit :: TyLit -> Doc-pprTyLit (NumTyLit n) = integer n-pprTyLit (StrTyLit s) = text (show s)-pprTyLit (CharTyLit c) = text (show c)--instance Ppr TyLit where- ppr = pprTyLit---------------------------------class PprFlag flag where- pprTyVarBndr :: (TyVarBndr flag) -> Doc--instance PprFlag () where- pprTyVarBndr (PlainTV nm ()) = ppr nm- pprTyVarBndr (KindedTV nm () k) = parens (ppr nm <+> dcolon <+> ppr k)--instance PprFlag Specificity where- pprTyVarBndr (PlainTV nm SpecifiedSpec) = ppr nm- pprTyVarBndr (PlainTV nm InferredSpec) = braces (ppr nm)- pprTyVarBndr (KindedTV nm SpecifiedSpec k) = parens (ppr nm <+> dcolon <+> ppr k)- pprTyVarBndr (KindedTV nm InferredSpec k) = braces (ppr nm <+> dcolon <+> ppr k)--instance PprFlag BndrVis where- pprTyVarBndr (PlainTV nm vis) = pprBndrVis vis (ppr nm)- pprTyVarBndr (KindedTV nm vis k) = pprBndrVis vis (parens (ppr nm <+> dcolon <+> ppr k))--pprBndrVis :: BndrVis -> Doc -> Doc-pprBndrVis BndrReq d = d-pprBndrVis BndrInvis d = char '@' <> d--instance PprFlag flag => Ppr (TyVarBndr flag) where- ppr bndr = pprTyVarBndr bndr--instance Ppr Role where- ppr NominalR = text "nominal"- ppr RepresentationalR = text "representational"- ppr PhantomR = text "phantom"- ppr InferR = text "_"---------------------------------pprCxt :: Cxt -> Doc-pprCxt [] = empty-pprCxt ts = ppr_cxt_preds funPrec ts <+> text "=>"--ppr_cxt_preds :: Precedence -> Cxt -> Doc-ppr_cxt_preds _ [] = text "()"-ppr_cxt_preds p [t] = pprType p t-ppr_cxt_preds _ ts = parens (commaSep ts)---------------------------------instance Ppr Range where- ppr = brackets . pprRange- where pprRange :: Range -> Doc- pprRange (FromR e) = ppr e <+> text ".."- pprRange (FromThenR e1 e2) = ppr e1 <> text ","- <+> ppr e2 <+> text ".."- pprRange (FromToR e1 e2) = ppr e1 <+> text ".." <+> ppr e2- pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","- <+> ppr e2 <+> text ".."- <+> ppr e3---------------------------------where_clause :: [Dec] -> Doc-where_clause [] = empty-where_clause ds = nest nestDepth $ text "where" <+> braces (semiSepWith (ppr_dec False) ds)--showtextl :: Show a => a -> Doc-showtextl = text . map toLower . show--hashParens :: Doc -> Doc-hashParens d = text "(# " <> d <> text " #)"--quoteParens :: Doc -> Doc-quoteParens d = text "'(" <> d <> text ")"--------------------------------instance Ppr Loc where- ppr (Loc { loc_module = md- , loc_package = pkg- , loc_start = (start_ln, start_col)- , loc_end = (end_ln, end_col) })- = hcat [ text pkg, colon, text md, colon- , parens $ int start_ln <> comma <> int start_col- , text "-"- , parens $ int end_ln <> comma <> int end_col ]---- Takes a separator and a pretty-printing function and prints a list of things--- separated by the separator followed by space.-sepWith :: Doc -> (a -> Doc) -> [a] -> Doc-sepWith sepDoc pprFun = sep . punctuate sepDoc . map pprFun---- Takes a list of printable things and prints them separated by commas followed--- by space.-commaSep :: Ppr a => [a] -> Doc-commaSep = commaSepWith ppr---- Takes a list of things and prints them with the given pretty-printing--- function, separated by commas followed by space.-commaSepWith :: (a -> Doc) -> [a] -> Doc-commaSepWith pprFun = sepWith comma pprFun---- Takes a list of printable things and prints them separated by semicolons--- followed by space.-semiSep :: Ppr a => [a] -> Doc-semiSep = sep . punctuate semi . map ppr---- Takes a list of things and prints them with the given pretty-printing--- function, separated by semicolons followed by space.-semiSepWith :: (a -> Doc) -> [a] -> Doc-semiSepWith pprFun = sepWith semi pprFun---- Prints out the series of vertical bars that wraps an expression or pattern--- used in an unboxed sum.-unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc-unboxedSumBars d alt arity = hashParens $- bars (alt-1) <> d <> bars (arity - alt)- where- bars i = hsep (replicate i bar)---- Text containing the vertical bar character.-bar :: Doc-bar = char '|'++{- | contains a prettyprinter for the+Template Haskell datatypes+-}+module Language.Haskell.TH.Ppr (+ appPrec,+ bar,+ bytesToString,+ commaSep,+ commaSepApplied,+ commaSepWith,+ fromTANormal,+ funPrec,+ hashParens,+ isStarT,+ isSymOcc,+ nestDepth,+ noPrec,+ opPrec,+ parensIf,+ pprBangType,+ pprBndrVis,+ pprBody,+ pprClause,+ pprCtxWith,+ pprCxt,+ pprExp,+ pprFields,+ pprFixity,+ pprForall,+ pprForall',+ pprForallVis,+ pprFunArgType,+ pprGadtRHS,+ pprGuarded,+ pprInfixExp,+ pprInfixT,+ pprLit,+ pprMatchPat,+ pprMaybeExp,+ pprNamespaceSpecifier,+ pprParendType,+ pprParendTypeArg,+ pprPat,+ pprPatSynSig,+ pprPatSynType,+ pprPrefixOcc,+ pprRecFields,+ pprStrictType,+ pprString,+ pprTyApp,+ pprTyLit,+ pprType,+ pprVarBangType,+ pprVarStrictType,+ ppr_bndrs,+ ppr_ctx_preds_with,+ ppr_cxt_preds,+ ppr_data,+ ppr_dec,+ ppr_deriv_clause,+ ppr_deriv_strategy,+ ppr_newtype,+ ppr_overlap,+ ppr_sig,+ ppr_tf_head,+ ppr_tySyn,+ ppr_type_data,+ ppr_typedef,+ pprint,+ qualPrec,+ quoteParens,+ semiSep,+ semiSepWith,+ sepWith,+ showtextl,+ sigPrec,+ split,+ unboxedSumBars,+ unopPrec,+ where_clause,+ ForallVisFlag (..),+ Ppr (..),+ PprFlag (..),+ Precedence,+ TypeArg (..),+)+where++import GHC.Boot.TH.Ppr
Language/Haskell/TH/PprLib.hs view
@@ -1,226 +1,56 @@-{-# LANGUAGE FlexibleInstances, Safe #-}+{-# LANGUAGE Safe #-} -- | Monadic front-end to Text.PrettyPrint- module Language.Haskell.TH.PprLib (-- -- * The document type- Doc, -- Abstract, instance of Show- PprM,-- -- * Primitive Documents- empty,- semi, comma, colon, dcolon, space, equals, arrow,- lparen, rparen, lbrack, rbrack, lbrace, rbrace,-- -- * Converting values into documents- text, char, ptext,- int, integer, float, double, rational,-- -- * Wrapping documents in delimiters- parens, brackets, braces, quotes, doubleQuotes,-- -- * Combining documents- (<>), (<+>), hcat, hsep,- ($$), ($+$), vcat,- sep, cat,- fsep, fcat,- nest,- hang, punctuate,-- -- * Predicates on documents- isEmpty,-- to_HPJ_Doc, pprName, pprName'- ) where-+ ($$),+ ($+$),+ (<+>),+ (<>),+ arrow,+ braces,+ brackets,+ cat,+ char,+ colon,+ comma,+ dcolon,+ double,+ doubleQuotes,+ empty,+ equals,+ fcat,+ float,+ fsep,+ hang,+ hcat,+ hsep,+ int,+ integer,+ isEmpty,+ lbrace,+ lbrack,+ lparen,+ nest,+ parens,+ pprName,+ pprName',+ ptext,+ punctuate,+ quotes,+ rational,+ rbrace,+ rbrack,+ rparen,+ semi,+ sep,+ space,+ text,+ to_HPJ_Doc,+ vcat,+ Doc,+ PprM,+)+where -import Language.Haskell.TH.Syntax- (Uniq, Name(..), showName', NameFlavour(..), NameIs(..))-import qualified Text.PrettyPrint as HPJ-import Control.Monad (liftM, liftM2, ap)-import Language.Haskell.TH.Lib.Map ( Map )-import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) import Prelude hiding ((<>))--infixl 6 <>-infixl 6 <+>-infixl 5 $$, $+$---- ------------------------------------------------------------------------------ The interface---- The primitive Doc values--instance Show Doc where- show d = HPJ.render (to_HPJ_Doc d)--isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty--empty :: Doc; -- ^ An empty document-semi :: Doc; -- ^ A ';' character-comma :: Doc; -- ^ A ',' character-colon :: Doc; -- ^ A ':' character-dcolon :: Doc; -- ^ A "::" string-space :: Doc; -- ^ A space character-equals :: Doc; -- ^ A '=' character-arrow :: Doc; -- ^ A "->" string-lparen :: Doc; -- ^ A '(' character-rparen :: Doc; -- ^ A ')' character-lbrack :: Doc; -- ^ A '[' character-rbrack :: Doc; -- ^ A ']' character-lbrace :: Doc; -- ^ A '{' character-rbrace :: Doc; -- ^ A '}' character--text :: String -> Doc-ptext :: String -> Doc-char :: Char -> Doc-int :: Int -> Doc-integer :: Integer -> Doc-float :: Float -> Doc-double :: Double -> Doc-rational :: Rational -> Doc---parens :: Doc -> Doc; -- ^ Wrap document in @(...)@-brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@-braces :: Doc -> Doc; -- ^ Wrap document in @{...}@-quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@-doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@---- Combining @Doc@ values--(<>) :: Doc -> Doc -> Doc; -- ^Beside-hcat :: [Doc] -> Doc; -- ^List version of '<>'-(<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space-hsep :: [Doc] -> Doc; -- ^List version of '<+>'--($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no- -- overlap it \"dovetails\" the two-($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing.-vcat :: [Doc] -> Doc; -- ^List version of '$$'--cat :: [Doc] -> Doc; -- ^ Either hcat or vcat-sep :: [Doc] -> Doc; -- ^ Either hsep or vcat-fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat-fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep--nest :: Int -> Doc -> Doc; -- ^ Nested----- GHC-specific ones.--hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@-punctuate :: Doc -> [Doc] -> [Doc]- -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@---- ------------------------------------------------------------------------------ The "implementation"--type State = (Map Name Name, Uniq)-data PprM a = PprM { runPprM :: State -> (a, State) }--pprName :: Name -> Doc-pprName = pprName' Alone--pprName' :: NameIs -> Name -> Doc-pprName' ni n@(Name o (NameU _))- = PprM $ \s@(fm, i)- -> let (n', s') = case Map.lookup n fm of- Just d -> (d, s)- Nothing -> let n'' = Name o (NameU i)- in (n'', (Map.insert n n'' fm, i + 1))- in (HPJ.text $ showName' ni n', s')-pprName' ni n = text $ showName' ni n--{--instance Show Name where- show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u)- show (Name occ NameS) = occString occ- show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ--data Name = Name OccName NameFlavour--data NameFlavour- | NameU Int# -- A unique local name--}--to_HPJ_Doc :: Doc -> HPJ.Doc-to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0)--instance Functor PprM where- fmap = liftM--instance Applicative PprM where- pure x = PprM $ \s -> (x, s)- (<*>) = ap--instance Monad PprM where- m >>= k = PprM $ \s -> let (x, s') = runPprM m s- in runPprM (k x) s'--type Doc = PprM HPJ.Doc---- The primitive Doc values--isEmpty = liftM HPJ.isEmpty--empty = return HPJ.empty-semi = return HPJ.semi-comma = return HPJ.comma-colon = return HPJ.colon-dcolon = return $ HPJ.text "::"-space = return HPJ.space-equals = return HPJ.equals-arrow = return $ HPJ.text "->"-lparen = return HPJ.lparen-rparen = return HPJ.rparen-lbrack = return HPJ.lbrack-rbrack = return HPJ.rbrack-lbrace = return HPJ.lbrace-rbrace = return HPJ.rbrace--text = return . HPJ.text-ptext = return . HPJ.ptext-char = return . HPJ.char-int = return . HPJ.int-integer = return . HPJ.integer-float = return . HPJ.float-double = return . HPJ.double-rational = return . HPJ.rational---parens = liftM HPJ.parens-brackets = liftM HPJ.brackets-braces = liftM HPJ.braces-quotes = liftM HPJ.quotes-doubleQuotes = liftM HPJ.doubleQuotes---- Combining @Doc@ values--(<>) = liftM2 (HPJ.<>)-hcat = liftM HPJ.hcat . sequence-(<+>) = liftM2 (HPJ.<+>)-hsep = liftM HPJ.hsep . sequence--($$) = liftM2 (HPJ.$$)-($+$) = liftM2 (HPJ.$+$)-vcat = liftM HPJ.vcat . sequence--cat = liftM HPJ.cat . sequence-sep = liftM HPJ.sep . sequence-fcat = liftM HPJ.fcat . sequence-fsep = liftM HPJ.fsep . sequence--nest n = liftM (HPJ.nest n)--hang d1 n d2 = do d1' <- d1- d2' <- d2- return (HPJ.hang d1' n d2')---- punctuate uses the same definition as Text.PrettyPrint-punctuate _ [] = []-punctuate p (d:ds) = go d ds- where- go d' [] = [d']- go d' (e:es) = (d' <> p) : go e es+import GHC.Boot.TH.PprLib
Language/Haskell/TH/Quote.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, Safe #-}+{-# LANGUAGE Safe #-} {- | Module : Language.Haskell.TH.Quote Description : Quasi-quoting support for Template Haskell@@ -13,33 +13,17 @@ quasiquoters. Nota bene: this package does not define any parsers, that is up to you. -}-module Language.Haskell.TH.Quote(- QuasiQuoter(..),- quoteFile,- -- * For backwards compatibility- dataToQa, dataToExpQ, dataToPatQ- ) where+module Language.Haskell.TH.Quote+ ( QuasiQuoter(..)+ , quoteFile+ -- * For backwards compatibility+ , dataToQa, dataToExpQ, dataToPatQ+ ) where -import Language.Haskell.TH.Syntax-import Prelude+import GHC.Boot.TH.Syntax+import GHC.Boot.TH.Quote+import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ) --- | The 'QuasiQuoter' type, a value @q@ of this type can be used--- in the syntax @[q| ... string to parse ...|]@. In fact, for--- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters--- to be used in different splice contexts; if you are only interested--- in defining a quasiquoter to be used for expressions, you would--- define a 'QuasiQuoter' with only 'quoteExp', and leave the other--- fields stubbed out with errors.-data QuasiQuoter = QuasiQuoter {- -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@- quoteExp :: String -> Q Exp,- -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@- quotePat :: String -> Q Pat,- -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@- quoteType :: String -> Q Type,- -- | Quasi-quoter for declarations, invoked by top-level quotes- quoteDec :: String -> Q [Dec]- } -- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read -- the data out of a file. For example, suppose @asmq@ is an@@ -48,10 +32,10 @@ -- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead -- of the inline text quoteFile :: QuasiQuoter -> QuasiQuoter-quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) +quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd } where get :: (String -> Q a) -> String -> Q a- get old_quoter file_name = do { file_cts <- runIO (readFile file_name) + get old_quoter file_name = do { file_cts <- runIO (readFile file_name) ; addDependentFile file_name ; old_quoter file_cts }
Language/Haskell/TH/Syntax.hs view
@@ -1,2998 +1,399 @@-{-# LANGUAGE CPP, DeriveDataTypeable,- DeriveGeneric, FlexibleInstances, DefaultSignatures,- RankNTypes, RoleAnnotations, ScopedTypeVariables,- MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,- GADTs, UnboxedTuples, UnboxedSums, TypeOperators,- Trustworthy, DeriveFunctor, DeriveTraversable,- BangPatterns, RecordWildCards, ImplicitParams #-}--{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE StandaloneKindSignatures #-}---------------------------------------------------------------------------------- |--- Module : Language.Haskell.Syntax--- Copyright : (c) The University of Glasgow 2003--- License : BSD-style (see the file libraries/base/LICENSE)------ Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ Abstract syntax definitions for Template Haskell.-----------------------------------------------------------------------------------module Language.Haskell.TH.Syntax- ( module Language.Haskell.TH.Syntax- -- * Language extensions- , module Language.Haskell.TH.LanguageExtensions- , ForeignSrcLang(..)- -- * Notes- -- ** Unresolved Infix- -- $infix- ) where--import qualified Data.Fixed as Fixed-import Data.Data hiding (Fixity(..))-import Data.IORef-import System.IO.Unsafe ( unsafePerformIO )-import System.FilePath-import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )-import Control.Monad (liftM)-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Fix (MonadFix (..))-import Control.Applicative (Applicative(..))-import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)-import Control.Exception.Base (FixIOException (..))-import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)-import System.IO ( hPutStrLn, stderr )-import Data.Char ( isAlpha, isAlphaNum, isUpper, ord )-import Data.Int-import Data.List.NonEmpty ( NonEmpty(..) )-import Data.Void ( Void, absurd )-import Data.Word-import Data.Ratio-import GHC.CString ( unpackCString# )-import GHC.Generics ( Generic )-import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..),- TYPE, RuntimeRep(..), Levity(..), Multiplicity (..) )-import qualified Data.Kind as Kind (Type)-import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# )-import GHC.Ptr ( Ptr, plusPtr )-import GHC.Lexeme ( startsVarSym, startsVarId )-import GHC.ForeignSrcLang.Type-import Language.Haskell.TH.LanguageExtensions-import Numeric.Natural-import Prelude hiding (Applicative(..))-import Foreign.ForeignPtr-import Foreign.C.String-import Foreign.C.Types--import Data.Array.Byte (ByteArray(..))-import GHC.Exts- ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#- , isByteArrayPinned#, isTrue#, sizeofByteArray#, unsafeCoerce#, byteArrayContents#- , copyByteArray#, newPinnedByteArray#)-import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))-import GHC.ST (ST(..), runST)------------------------------------------------------------- The Quasi class-----------------------------------------------------------class (MonadIO m, MonadFail m) => Quasi m where- qNewName :: String -> m Name- -- ^ Fresh names-- -- Error reporting and recovery- qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False)- -- ...but carry on; use 'fail' to stop- qRecover :: m a -- ^ the error handler- -> m a -- ^ action which may fail- -> m a -- ^ Recover from the monadic 'fail'-- -- Inspect the type-checker's environment- qLookupName :: Bool -> String -> m (Maybe Name)- -- True <=> type namespace, False <=> value namespace- qReify :: Name -> m Info- qReifyFixity :: Name -> m (Maybe Fixity)- qReifyType :: Name -> m Type- qReifyInstances :: Name -> [Type] -> m [Dec]- -- Is (n tys) an instance?- -- Returns list of matching instance Decs- -- (with empty sub-Decs)- -- Works for classes and type functions- qReifyRoles :: Name -> m [Role]- qReifyAnnotations :: Data a => AnnLookup -> m [a]- qReifyModule :: Module -> m ModuleInfo- qReifyConStrictness :: Name -> m [DecidedStrictness]-- qLocation :: m Loc-- qRunIO :: IO a -> m a- qRunIO = liftIO- -- ^ Input/output (dangerous)- qGetPackageRoot :: m FilePath-- qAddDependentFile :: FilePath -> m ()-- qAddTempFile :: String -> m FilePath-- qAddTopDecls :: [Dec] -> m ()-- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()-- qAddModFinalizer :: Q () -> m ()-- qAddCorePlugin :: String -> m ()-- qGetQ :: Typeable a => m (Maybe a)-- qPutQ :: Typeable a => a -> m ()-- qIsExtEnabled :: Extension -> m Bool- qExtsEnabled :: m [Extension]-- qPutDoc :: DocLoc -> String -> m ()- qGetDoc :: DocLoc -> m (Maybe String)---------------------------------------------------------- The IO instance of Quasi------ This instance is used only when running a Q--- computation in the IO monad, usually just to--- print the result. There is no interesting--- type environment, so reification isn't going to--- work.-----------------------------------------------------------instance Quasi IO where- qNewName = newNameIO-- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)-- qLookupName _ _ = badIO "lookupName"- qReify _ = badIO "reify"- qReifyFixity _ = badIO "reifyFixity"- qReifyType _ = badIO "reifyFixity"- qReifyInstances _ _ = badIO "reifyInstances"- qReifyRoles _ = badIO "reifyRoles"- qReifyAnnotations _ = badIO "reifyAnnotations"- qReifyModule _ = badIO "reifyModule"- qReifyConStrictness _ = badIO "reifyConStrictness"- qLocation = badIO "currentLocation"- qRecover _ _ = badIO "recover" -- Maybe we could fix this?- qGetPackageRoot = badIO "getProjectRoot"- qAddDependentFile _ = badIO "addDependentFile"- qAddTempFile _ = badIO "addTempFile"- qAddTopDecls _ = badIO "addTopDecls"- qAddForeignFilePath _ _ = badIO "addForeignFilePath"- qAddModFinalizer _ = badIO "addModFinalizer"- qAddCorePlugin _ = badIO "addCorePlugin"- qGetQ = badIO "getQ"- qPutQ _ = badIO "putQ"- qIsExtEnabled _ = badIO "isExtEnabled"- qExtsEnabled = badIO "extsEnabled"- qPutDoc _ _ = badIO "putDoc"- qGetDoc _ = badIO "getDoc"--instance Quote IO where- newName = newNameIO--newNameIO :: String -> IO Name-newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))- ; pure (mkNameU s n) }--badIO :: String -> IO a-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")- ; fail "Template Haskell failure" }---- Global variable to generate unique symbols-counter :: IORef Uniq-{-# NOINLINE counter #-}-counter = unsafePerformIO (newIORef 0)-------------------------------------------------------------- The Q monad-----------------------------------------------------------newtype Q a = Q { unQ :: forall m. Quasi m => m a }---- \"Runs\" the 'Q' monad. Normal users of Template Haskell--- should not need this function, as the splice brackets @$( ... )@--- are the usual way of running a 'Q' computation.------ This function is primarily used in GHC internals, and for debugging--- splices by running them in 'IO'.------ Note that many functions in 'Q', such as 'reify' and other compiler--- queries, are not supported when running 'Q' in 'IO'; these operations--- simply fail at runtime. Indeed, the only operations guaranteed to succeed--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.-runQ :: Quasi m => Q a -> m a-runQ (Q m) = m--instance Monad Q where- Q m >>= k = Q (m >>= \x -> unQ (k x))- (>>) = (*>)--instance MonadFail Q where- fail s = report True s >> Q (fail "Q monad failure")--instance Functor Q where- fmap f (Q x) = Q (fmap f x)--instance Applicative Q where- pure x = Q (pure x)- Q f <*> Q x = Q (f <*> x)- Q m *> Q n = Q (m *> n)---- | @since 2.17.0.0-instance Semigroup a => Semigroup (Q a) where- (<>) = liftA2 (<>)---- | @since 2.17.0.0-instance Monoid a => Monoid (Q a) where- mempty = pure mempty---- | If the function passed to 'mfix' inspects its argument,--- the resulting action will throw a 'FixIOException'.------ @since 2.17.0.0-instance MonadFix Q where- -- We use the same blackholing approach as in fixIO.- -- See Note [Blackholing in fixIO] in System.IO in base.- mfix k = do- m <- runIO newEmptyMVar- ans <- runIO (unsafeDupableInterleaveIO- (readMVar m `catch` \BlockedIndefinitelyOnMVar ->- throwIO FixIOException))- result <- k ans- runIO (putMVar m result)- return result-------------------------------------------------------------- The Quote class--------------------------------------------------------------- | The 'Quote' class implements the minimal interface which is necessary for--- desugaring quotations.------ * The @Monad m@ superclass is needed to stitch together the different--- AST fragments.--- * 'newName' is used when desugaring binding structures such as lambdas--- to generate fresh names.------ Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`------ For many years the type of a quotation was fixed to be `Q Exp` but by--- more precisely specifying the minimal interface it enables the `Exp` to--- be extracted purely from the quotation without interacting with `Q`.-class Monad m => Quote m where- {- |- Generate a fresh name, which cannot be captured.-- For example, this:-- @f = $(do- nm1 <- newName \"x\"- let nm2 = 'mkName' \"x\"- return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))- )@-- will produce the splice-- >f = \x0 -> \x -> x0-- In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,- and is not captured by the binding @VarP nm2@.-- Although names generated by @newName@ cannot /be captured/, they can- /capture/ other names. For example, this:-- >g = $(do- > nm1 <- newName "x"- > let nm2 = mkName "x"- > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))- > )-- will produce the splice-- >g = \x -> \x0 -> x0-- since the occurrence @VarE nm2@ is captured by the innermost binding- of @x@, namely @VarP nm1@.- -}- newName :: String -> m Name--instance Quote Q where- newName s = Q (qNewName s)------------------------------------------------------------- The TExp type-----------------------------------------------------------type TExp :: TYPE r -> Kind.Type-type role TExp nominal -- See Note [Role of TExp]-newtype TExp a = TExp- { unType :: Exp -- ^ Underlying untyped Template Haskell expression- }--- ^ Typed wrapper around an 'Exp'.------ This is the typed representation of terms produced by typed quotes.------ Representation-polymorphic since /template-haskell-2.16.0.0/.---- | Discard the type annotation and produce a plain Template Haskell--- expression------ Representation-polymorphic since /template-haskell-2.16.0.0/.-unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp-unTypeQ m = do { TExp e <- m- ; return e }---- | Annotate the Template Haskell expression with a type------ This is unsafe because GHC cannot check for you that the expression--- really does have the type you claim it has.------ Representation-polymorphic since /template-haskell-2.16.0.0/.-unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .- Quote m => m Exp -> m (TExp a)-unsafeTExpCoerce m = do { e <- m- ; return (TExp e) }--{- Note [Role of TExp]-~~~~~~~~~~~~~~~~~~~~~~-TExp's argument must have a nominal role, not phantom as would-be inferred (#8459). Consider-- e :: Code Q Age- e = [|| MkAge 3 ||]-- foo = $(coerce e) + 4::Int--The splice will evaluate to (MkAge 3) and you can't add that to-4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}---- Code constructor-#if __GLASGOW_HASKELL__ >= 909-type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type- -- See Note [Foralls to the right in Code]-#else-type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type-#endif-type role Code representational nominal -- See Note [Role of TExp]-newtype Code m a = Code- { examineCode :: m (TExp a) -- ^ Underlying monadic value- }--- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed--- expressions allow for type-safe splicing via:------ - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if--- that expression has type @a@, then the quotation has type--- @Quote m => Code m a@------ - typed splices inside of typed quotes, written as @$$(...)@ where @...@--- is an arbitrary expression of type @Quote m => Code m a@------ Traditional expression quotes and splices let us construct ill-typed--- expressions:------ >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])--- GHC.Types.True GHC.Classes.== "foo"--- >>> GHC.Types.True GHC.Classes.== "foo"--- <interactive> error:--- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’--- • In the second argument of ‘(==)’, namely ‘"foo"’--- In the expression: True == "foo"--- In an equation for ‘it’: it = True == "foo"------ With typed expressions, the type error occurs when /constructing/ the--- Template Haskell expression:------ >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||])--- <interactive> error:--- • Couldn't match type ‘[Char]’ with ‘Bool’--- Expected type: Code Q Bool--- Actual type: Code Q [Char]--- • In the Template Haskell quotation [|| "foo" ||]--- In the expression: [|| "foo" ||]--- In the Template Haskell splice $$([|| "foo" ||])---{- Note [Foralls to the right in Code]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Code has the following type signature:- type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type--This allows us to write- data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#)-- tcodeq :: T (Code Q)- tcodeq = MkT [||5||] [||5#||]--If we used the slightly more straightforward signature- type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type--then the example above would become ill-typed. (See #23592 for some discussion.)--}---- | Unsafely convert an untyped code representation into a typed code--- representation.-unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .- Quote m => m Exp -> Code m a-unsafeCodeCoerce m = Code (unsafeTExpCoerce m)---- | Lift a monadic action producing code into the typed 'Code'--- representation-liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a-liftCode = Code---- | Extract the untyped representation from the typed representation-unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m- => Code m a -> m Exp-unTypeCode = unTypeQ . examineCode---- | Modify the ambient monad used during code generation. For example, you--- can use `hoistCode` to handle a state effect:--- @--- handleState :: Code (StateT Int Q) a -> Code Q a--- handleState = hoistCode (flip runState 0)--- @-hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m- => (forall x . m x -> n x) -> Code m a -> Code n a-hoistCode f (Code a) = Code (f a)----- | Variant of (>>=) which allows effectful computations to be injected--- into code generation.-bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m- => m a -> (a -> Code m b) -> Code m b-bindCode q k = liftCode (q >>= examineCode . k)---- | Variant of (>>) which allows effectful computations to be injected--- into code generation.-bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m- => m a -> Code m b -> Code m b-bindCode_ q c = liftCode ( q >> examineCode c)---- | A useful combinator for embedding monadic actions into 'Code'--- @--- myCode :: ... => Code m a--- myCode = joinCode $ do--- x <- someSideEffect--- return (makeCodeWith x)--- @-joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m- => m (Code m a) -> Code m a-joinCode = flip bindCode id--------------------------------------------------------- Packaged versions for the programmer, hiding the Quasi-ness----- | Report an error (True) or warning (False),--- but carry on; use 'fail' to stop.-report :: Bool -> String -> Q ()-report b s = Q (qReport b s)-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6---- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.-reportError :: String -> Q ()-reportError = report True---- | Report a warning to the user, and carry on.-reportWarning :: String -> Q ()-reportWarning = report False---- | Recover from errors raised by 'reportError' or 'fail'.-recover :: Q a -- ^ handler to invoke on failure- -> Q a -- ^ computation to run- -> Q a-recover (Q r) (Q m) = Q (qRecover r m)---- We don't export lookupName; the Bool isn't a great API--- Instead we export lookupTypeName, lookupValueName-lookupName :: Bool -> String -> Q (Maybe Name)-lookupName ns s = Q (qLookupName ns s)---- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.-lookupTypeName :: String -> Q (Maybe Name)-lookupTypeName s = Q (qLookupName True s)---- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.-lookupValueName :: String -> Q (Maybe Name)-lookupValueName s = Q (qLookupName False s)--{--Note [Name lookup]-~~~~~~~~~~~~~~~~~~--}-{- $namelookup #namelookup#-The functions 'lookupTypeName' and 'lookupValueName' provide-a way to query the current splice's context for what names-are in scope. The function 'lookupTypeName' queries the type-namespace, whereas 'lookupValueName' queries the value namespace,-but the functions are otherwise identical.--A call @lookupValueName s@ will check if there is a value-with name @s@ in scope at the current splice's location. If-there is, the @Name@ of this value is returned;-if not, then @Nothing@ is returned.--The returned name cannot be \"captured\".-For example:--> f = "global"-> g = $( do-> Just nm <- lookupValueName "f"-> [| let f = "local" in $( varE nm ) |]--In this case, @g = \"global\"@; the call to @lookupValueName@-returned the global @f@, and this name was /not/ captured by-the local definition of @f@.--The lookup is performed in the context of the /top-level/ splice-being run. For example:--> f = "global"-> g = $( [| let f = "local" in-> $(do-> Just nm <- lookupValueName "f"-> varE nm-> ) |] )--Again in this example, @g = \"global\"@, because the call to-@lookupValueName@ queries the context of the outer-most @$(...)@.--Operators should be queried without any surrounding parentheses, like so:--> lookupValueName "+"--Qualified names are also supported, like so:--> lookupValueName "Prelude.+"-> lookupValueName "Prelude.map"---}---{- | 'reify' looks up information about the 'Name'. It will fail with-a compile error if the 'Name' is not visible. A 'Name' is visible if it is-imported or defined in a prior top-level declaration group. See the-documentation for 'newDeclarationGroup' for more details.--It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'-to ensure that we are reifying from the right namespace. For instance, in this context:--> data D = D--which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)-To ensure we get information about @D@-the-value, use 'lookupValueName':--> do-> Just nm <- lookupValueName "D"-> reify nm--and to get information about @D@-the-type, use 'lookupTypeName'.--}-reify :: Name -> Q Info-reify v = Q (qReify v)--{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For-example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then-@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function-@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns-'Nothing', so you may assume @bar@ has 'defaultFixity'.--}-reifyFixity :: Name -> Q (Maybe Fixity)-reifyFixity nm = Q (qReifyFixity nm)--{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,-@reifyType 'not@ returns @Bool -> Bool@, and-@reifyType ''Bool@ returns @Type@.-This works even if there's no explicit signature and the type or kind is inferred.--}-reifyType :: Name -> Q Type-reifyType nm = Q (qReifyType nm)--{- | Template Haskell is capable of reifying information about types and-terms defined in previous declaration groups. Top-level declaration splices break up-declaration groups.--For an example, consider this code block. We define a datatype @X@ and-then try to call 'reify' on the datatype.--@-module Check where--data X = X- deriving Eq--$(do- info <- reify ''X- runIO $ print info- )-@--This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:--@-data X = X- deriving Eq--$(pure [])--$(do- info <- reify ''X- runIO $ print info- )-@--We provide 'newDeclarationGroup' as a means of documenting this behavior-and providing a name for the pattern.--Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:--@-data X = X- deriving Eq--newDeclarationGroup--$(do- info <- reify ''X- runIO $ print info- )-@---}-newDeclarationGroup :: Q [Dec]-newDeclarationGroup = pure []--{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible")-of @nm tys@. That is,-if @nm@ is the name of a type class, then all instances of this class at the types @tys@-are returned. Alternatively, if @nm@ is the name of a data family or type family,-all instances of this family at the types @tys@ are returned.--Note that this is a \"shallow\" test; the declarations returned merely have-instance heads which unify with @nm tys@, they need not actually be satisfiable.-- - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains- the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and- @B@ themselves implement 'Eq'-- - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available- instance of 'Show'--There is one edge case: @reifyInstances ''Typeable tys@ currently always-produces an empty list (no matter what @tys@ are given).--In principle, the *visible* instances are-* all instances defined in a prior top-level declaration group- (see docs on @newDeclarationGroup@), or-* all instances defined in any module transitively imported by the- module being compiled--However, actually searching all modules transitively below the one being-compiled is unreasonably expensive, so @reifyInstances@ will report only the-instance for modules that GHC has had some cause to visit during this-compilation. This is a shortcoming: @reifyInstances@ might fail to report-instances for a type that is otherwise unusued, or instances defined in a-different component. You can work around this shortcoming by explicitly importing the modules-whose instances you want to be visible. GHC issue <https://gitlab.haskell.org/ghc/ghc/-/issues/20529#note_388980 #20529>-has some discussion around this.---}-reifyInstances :: Name -> [Type] -> Q [InstanceDec]-reifyInstances cls tys = Q (qReifyInstances cls tys)--{- | @reifyRoles nm@ returns the list of roles associated with the parameters-(both visible and invisible) of-the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.-The returned list should never contain 'InferR'.--An invisible parameter to a tycon is often a kind parameter. For example, if-we have--@-type Proxy :: forall k. k -> Type-data Proxy a = MkProxy-@--and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' is-the role of the invisible @k@ parameter. Kind parameters are always nominal.--}-reifyRoles :: Name -> Q [Role]-reifyRoles nm = Q (qReifyRoles nm)---- | @reifyAnnotations target@ returns the list of annotations--- associated with @target@. Only the annotations that are--- appropriately typed is returned. So if you have @Int@ and @String@--- annotations for the same target, you have to call this function twice.-reifyAnnotations :: Data a => AnnLookup -> Q [a]-reifyAnnotations an = Q (qReifyAnnotations an)---- | @reifyModule mod@ looks up information about module @mod@. To--- look up the current module, call this function with the return--- value of 'Language.Haskell.TH.Lib.thisModule'.-reifyModule :: Module -> Q ModuleInfo-reifyModule m = Q (qReifyModule m)---- | @reifyConStrictness nm@ looks up the strictness information for the fields--- of the constructor with the name @nm@. Note that the strictness information--- that 'reifyConStrictness' returns may not correspond to what is written in--- the source code. For example, in the following data declaration:------ @--- data Pair a = Pair a a--- @------ 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most--- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the--- @-XStrictData@ language extension was enabled.-reifyConStrictness :: Name -> Q [DecidedStrictness]-reifyConStrictness n = Q (qReifyConStrictness n)---- | Is the list of instances returned by 'reifyInstances' nonempty?------ If you're confused by an instance not being visible despite being--- defined in the same module and above the splice in question, see the--- docs for 'newDeclarationGroup' for a possible explanation.-isInstance :: Name -> [Type] -> Q Bool-isInstance nm tys = do { decs <- reifyInstances nm tys- ; return (not (null decs)) }---- | The location at which this computation is spliced.-location :: Q Loc-location = Q qLocation---- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.--- Take care: you are guaranteed the ordering of calls to 'runIO' within--- a single 'Q' computation, but not about the order in which splices are run.------ Note: for various murky reasons, stdout and stderr handles are not--- necessarily flushed when the compiler finishes running, so you should--- flush them yourself.-runIO :: IO a -> Q a-runIO m = Q (qRunIO m)---- | Get the package root for the current package which is being compiled.--- This can be set explicitly with the -package-root flag but is normally--- just the current working directory.------ The motivation for this flag is to provide a principled means to remove the--- assumption from splices that they will be executed in the directory where the--- cabal file resides. Projects such as haskell-language-server can't and don't--- change directory when compiling files but instead set the -package-root flag--- appropriately.-getPackageRoot :: Q FilePath-getPackageRoot = Q qGetPackageRoot---- | The input is a filepath, which if relative is offset by the package root.-makeRelativeToProject :: FilePath -> Q FilePath-makeRelativeToProject fp | isRelative fp = do- root <- getPackageRoot- return (root </> fp)-makeRelativeToProject fp = return fp------ | Record external files that runIO is using (dependent upon).--- The compiler can then recognize that it should re-compile the Haskell file--- when an external file changes.------ Expects an absolute file path.------ Notes:------ * ghc -M does not know about these dependencies - it does not execute TH.------ * The dependency is based on file content, not a modification time-addDependentFile :: FilePath -> Q ()-addDependentFile fp = Q (qAddDependentFile fp)---- | Obtain a temporary file path with the given suffix. The compiler will--- delete this file after compilation.-addTempFile :: String -> Q FilePath-addTempFile suffix = Q (qAddTempFile suffix)---- | Add additional top-level declarations. The added declarations will be type--- checked along with the current declaration group.-addTopDecls :: [Dec] -> Q ()-addTopDecls ds = Q (qAddTopDecls ds)---- |-addForeignFile :: ForeignSrcLang -> String -> Q ()-addForeignFile = addForeignSource-{-# DEPRECATED addForeignFile- "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"- #-} -- deprecated in 8.6---- | Emit a foreign file which will be compiled and linked to the object for--- the current module. Currently only languages that can be compiled with--- the C compiler are supported, and the flags passed as part of -optc will--- be also applied to the C compiler invocation that will compile them.------ Note that for non-C languages (for example C++) @extern "C"@ directives--- must be used to get symbols that we can access from Haskell.------ To get better errors, it is recommended to use #line pragmas when--- emitting C files, e.g.------ > {-# LANGUAGE CPP #-}--- > ...--- > addForeignSource LangC $ unlines--- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__--- > , ...--- > ]-addForeignSource :: ForeignSrcLang -> String -> Q ()-addForeignSource lang src = do- let suffix = case lang of- LangC -> "c"- LangCxx -> "cpp"- LangObjc -> "m"- LangObjcxx -> "mm"- LangAsm -> "s"- LangJs -> "js"- RawObject -> "a"- path <- addTempFile suffix- runIO $ writeFile path src- addForeignFilePath lang path---- | Same as 'addForeignSource', but expects to receive a path pointing to the--- foreign file instead of a 'String' of its contents. Consider using this in--- conjunction with 'addTempFile'.------ This is a good alternative to 'addForeignSource' when you are trying to--- directly link in an object file.-addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)---- | Add a finalizer that will run in the Q monad after the current module has--- been type checked. This only makes sense when run within a top-level splice.------ The finalizer is given the local type environment at the splice point. Thus--- 'reify' is able to find the local definitions when executed inside the--- finalizer.-addModFinalizer :: Q () -> Q ()-addModFinalizer act = Q (qAddModFinalizer (unQ act))---- | Adds a core plugin to the compilation pipeline.------ @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc--- in the command line. The major difference is that the plugin module @m@--- must not belong to the current package. When TH executes, it is too late--- to tell the compiler that we needed to compile first a plugin module in the--- current package.-addCorePlugin :: String -> Q ()-addCorePlugin plugin = Q (qAddCorePlugin plugin)---- | Get state from the 'Q' monad. Note that the state is local to the--- Haskell module in which the Template Haskell expression is executed.-getQ :: Typeable a => Q (Maybe a)-getQ = Q qGetQ---- | Replace the state in the 'Q' monad. Note that the state is local to the--- Haskell module in which the Template Haskell expression is executed.-putQ :: Typeable a => a -> Q ()-putQ x = Q (qPutQ x)---- | Determine whether the given language extension is enabled in the 'Q' monad.-isExtEnabled :: Extension -> Q Bool-isExtEnabled ext = Q (qIsExtEnabled ext)---- | List all enabled language extensions.-extsEnabled :: Q [Extension]-extsEnabled = Q qExtsEnabled---- | Add Haddock documentation to the specified location. This will overwrite--- any documentation at the location if it already exists. This will reify the--- specified name, so it must be in scope when you call it. If you want to add--- documentation to something that you are currently splicing, you can use--- 'addModFinalizer' e.g.------ > do--- > let nm = mkName "x"--- > addModFinalizer $ putDoc (DeclDoc nm) "Hello"--- > [d| $(varP nm) = 42 |]------ The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as--- will the 'funD_doc' and other @_doc@ combinators.--- You most likely want to have the @-haddock@ flag turned on when using this.--- Adding documentation to anything outside of the current module will cause an--- error.-putDoc :: DocLoc -> String -> Q ()-putDoc t s = Q (qPutDoc t s)---- | Retrieves the Haddock documentation at the specified location, if one--- exists.--- It can be used to read documentation on things defined outside of the current--- module, provided that those modules were compiled with the @-haddock@ flag.-getDoc :: DocLoc -> Q (Maybe String)-getDoc n = Q (qGetDoc n)--instance MonadIO Q where- liftIO = runIO--instance Quasi Q where- qNewName = newName- qReport = report- qRecover = recover- qReify = reify- qReifyFixity = reifyFixity- qReifyType = reifyType- qReifyInstances = reifyInstances- qReifyRoles = reifyRoles- qReifyAnnotations = reifyAnnotations- qReifyModule = reifyModule- qReifyConStrictness = reifyConStrictness- qLookupName = lookupName- qLocation = location- qGetPackageRoot = getPackageRoot- qAddDependentFile = addDependentFile- qAddTempFile = addTempFile- qAddTopDecls = addTopDecls- qAddForeignFilePath = addForeignFilePath- qAddModFinalizer = addModFinalizer- qAddCorePlugin = addCorePlugin- qGetQ = getQ- qPutQ = putQ- qIsExtEnabled = isExtEnabled- qExtsEnabled = extsEnabled- qPutDoc = putDoc- qGetDoc = getDoc---------------------------------------------------------- The following operations are used solely in GHC.HsToCore.Quote when--- desugaring brackets. They are not necessary for the user, who can use--- ordinary return and (>>=) etc--sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]-sequenceQ = sequence-------------------------------------------------------------- The Lift class------------------------------------------------------------- | A 'Lift' instance can have any of its values turned into a Template--- Haskell expression. This is needed when a value used within a Template--- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or--- @[|| ... ||]@) but not at the top level. As an example:------ > add1 :: Int -> Code Q Int--- > add1 x = [|| x + 1 ||]------ Template Haskell has no way of knowing what value @x@ will take on at--- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.------ A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@--- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.--- It is additionally expected that @'lift' x ≡ 'unTypeCode' ('liftTyped' x)@.------ 'Lift' instances can be derived automatically by use of the @-XDeriveLift@--- GHC language extension:------ > {-# LANGUAGE DeriveLift #-}--- > module Foo where--- >--- > import Language.Haskell.TH.Syntax--- >--- > data Bar a = Bar1 a (Bar a) | Bar2 String--- > deriving Lift------ Representation-polymorphic since /template-haskell-2.16.0.0/.-class Lift (t :: TYPE r) where- -- | Turn a value into a Template Haskell expression, suitable for use in- -- a splice.- lift :: Quote m => t -> m Exp- default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp- lift = unTypeCode . liftTyped-- -- | Turn a value into a Template Haskell typed expression, suitable for use- -- in a typed splice.- --- -- @since 2.16.0.0- liftTyped :: Quote m => t -> Code m t----- If you add any instances here, consider updating test th/TH_Lift-instance Lift Integer where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL x))--instance Lift Int where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))---- | @since 2.16.0.0-instance Lift Int# where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntPrimL (fromIntegral (I# x))))--instance Lift Int8 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int16 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int32 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int64 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))---- | @since 2.16.0.0-instance Lift Word# where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (WordPrimL (fromIntegral (W# x))))--instance Lift Word where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word8 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word16 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word32 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word64 where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Natural where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift (Fixed.Fixed a) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (Fixed.MkFixed x) = do- ex <- lift x- return (ConE mkFixedName `AppE` ex)- where- mkFixedName = 'Fixed.MkFixed--instance Integral a => Lift (Ratio a) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (RationalL (toRational x)))--instance Lift Float where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (RationalL (toRational x)))---- | @since 2.16.0.0-instance Lift Float# where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (FloatPrimL (toRational (F# x))))--instance Lift Double where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (RationalL (toRational x)))---- | @since 2.16.0.0-instance Lift Double# where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (DoublePrimL (toRational (D# x))))--instance Lift Char where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (CharL x))---- | @since 2.16.0.0-instance Lift Char# where- liftTyped x = unsafeCodeCoerce (lift x)- lift x = return (LitE (CharPrimL (C# x)))--instance Lift Bool where- liftTyped x = unsafeCodeCoerce (lift x)-- lift True = return (ConE trueName)- lift False = return (ConE falseName)---- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at--- the given memory address.------ @since 2.16.0.0-instance Lift Addr# where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))---- |--- @since 2.19.0.0-instance Lift ByteArray where- liftTyped x = unsafeCodeCoerce (lift x)- lift (ByteArray b) = return- (AppE (AppE (VarE addrToByteArrayName) (LitE (IntegerL (fromIntegral len))))- (LitE (BytesPrimL (Bytes ptr 0 (fromIntegral len)))))- where- len# = sizeofByteArray# b- len = I# len#- pb :: ByteArray#- !(ByteArray pb)- | isTrue# (isByteArrayPinned# b) = ByteArray b- | otherwise = runST $ ST $- \s -> case newPinnedByteArray# len# s of- (# s', mb #) -> case copyByteArray# b 0# mb 0# len# s' of- s'' -> case unsafeFreezeByteArray# mb s'' of- (# s''', ret #) -> (# s''', ByteArray ret #)- ptr :: ForeignPtr Word8- ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb))--addrToByteArrayName :: Name-addrToByteArrayName = 'addrToByteArray--addrToByteArray :: Int -> Addr# -> ByteArray-addrToByteArray (I# len) addr = runST $ ST $- \s -> case newByteArray# len s of- (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of- s'' -> case unsafeFreezeByteArray# mb s'' of- (# s''', ret #) -> (# s''', ByteArray ret #)--instance Lift a => Lift (Maybe a) where- liftTyped x = unsafeCodeCoerce (lift x)-- lift Nothing = return (ConE nothingName)- lift (Just x) = liftM (ConE justName `AppE`) (lift x)--instance (Lift a, Lift b) => Lift (Either a b) where- liftTyped x = unsafeCodeCoerce (lift x)-- lift (Left x) = liftM (ConE leftName `AppE`) (lift x)- lift (Right y) = liftM (ConE rightName `AppE`) (lift y)--instance Lift a => Lift [a] where- liftTyped x = unsafeCodeCoerce (lift x)- lift xs = do { xs' <- mapM lift xs; return (ListE xs') }--liftString :: Quote m => String -> m Exp--- Used in GHC.Tc.Gen.Expr to short-circuit the lifting for strings-liftString s = return (LitE (StringL s))---- | @since 2.15.0.0-instance Lift a => Lift (NonEmpty a) where- liftTyped x = unsafeCodeCoerce (lift x)-- lift (x :| xs) = do- x' <- lift x- xs' <- lift xs- return (InfixE (Just x') (ConE nonemptyName) (Just xs'))---- | @since 2.15.0.0-instance Lift Void where- liftTyped = liftCode . absurd- lift = pure . absurd--instance Lift () where- liftTyped x = unsafeCodeCoerce (lift x)- lift () = return (ConE (tupleDataName 0))--instance (Lift a, Lift b) => Lift (a, b) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (a, b)- = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b]--instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (a, b, c)- = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]--instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (a, b, c, d)- = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c, lift d]--instance (Lift a, Lift b, Lift c, Lift d, Lift e)- => Lift (a, b, c, d, e) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (a, b, c, d, e)- = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b- , lift c, lift d, lift e ]--instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)- => Lift (a, b, c, d, e, f) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (a, b, c, d, e, f)- = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c- , lift d, lift e, lift f ]--instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)- => Lift (a, b, c, d, e, f, g) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (a, b, c, d, e, f, g)- = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c- , lift d, lift e, lift f, lift g ]---- | @since 2.16.0.0-instance Lift (# #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# #) = return (ConE (unboxedTupleTypeName 0))---- | @since 2.16.0.0-instance (Lift a) => Lift (# a #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a]---- | @since 2.16.0.0-instance (Lift a, Lift b) => Lift (# a, b #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a, b #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b]---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c)- => Lift (# a, b, c #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a, b, c #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d)- => Lift (# a, b, c, d #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a, b, c, d #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b- , lift c, lift d ]---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d, Lift e)- => Lift (# a, b, c, d, e #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a, b, c, d, e #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b- , lift c, lift d, lift e ]---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)- => Lift (# a, b, c, d, e, f #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a, b, c, d, e, f #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c- , lift d, lift e, lift f ]---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)- => Lift (# a, b, c, d, e, f, g #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift (# a, b, c, d, e, f, g #)- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c- , lift d, lift e, lift f- , lift g ]---- | @since 2.16.0.0-instance (Lift a, Lift b) => Lift (# a | b #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = case x of- (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2- (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c)- => Lift (# a | b | c #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = case x of- (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3- (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3- (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d)- => Lift (# a | b | c | d #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = case x of- (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4- (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4- (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4- (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d, Lift e)- => Lift (# a | b | c | d | e #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = case x of- (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5- (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5- (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5- (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5- (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)- => Lift (# a | b | c | d | e | f #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = case x of- (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6- (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6- (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6- (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6- (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6- (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6---- | @since 2.16.0.0-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)- => Lift (# a | b | c | d | e | f | g #) where- liftTyped x = unsafeCodeCoerce (lift x)- lift x- = case x of- (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7- (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7- (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7- (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7- (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7- (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7- (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7---- TH has a special form for literal strings,--- which we should take advantage of.--- NB: the lhs of the rule has no args, so that--- the rule will apply to a 'lift' all on its own--- which happens to be the way the type checker--- creates it.-{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}---trueName, falseName :: Name-trueName = 'True-falseName = 'False--nothingName, justName :: Name-nothingName = 'Nothing-justName = 'Just--leftName, rightName :: Name-leftName = 'Left-rightName = 'Right--nonemptyName :: Name-nonemptyName = '(:|)--oneName, manyName :: Name-oneName = 'One-manyName = 'Many------------------------------------------------------------- Generic Lift implementations------------------------------------------------------------- | 'dataToQa' is an internal utility function for constructing generic--- conversion functions from types with 'Data' instances to various--- quasi-quoting representations. See the source of 'dataToExpQ' and--- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@--- and @appQ@ are overloadable to account for different syntax for--- expressions and patterns; @antiQ@ allows you to override type-specific--- cases, a common usage is just @const Nothing@, which results in--- no overloading.-dataToQa :: forall m a k q. (Quote m, Data a)- => (Name -> k)- -> (Lit -> m q)- -> (k -> [m q] -> m q)- -> (forall b . Data b => b -> Maybe (m q))- -> a- -> m q-dataToQa mkCon mkLit appCon antiQ t =- case antiQ t of- Nothing ->- case constrRep constr of- AlgConstr _ ->- appCon (mkCon funOrConName) conArgs- where- funOrConName :: Name- funOrConName =- case showConstr constr of- "(:)" -> Name (mkOccName ":")- (NameG DataName- (mkPkgName "ghc-prim")- (mkModName "GHC.Types"))- con@"[]" -> Name (mkOccName con)- (NameG DataName- (mkPkgName "ghc-prim")- (mkModName "GHC.Types"))- con@('(':_) -> Name (mkOccName con)- (NameG DataName- (mkPkgName "ghc-prim")- (mkModName "GHC.Tuple"))-- -- Tricky case: see Note [Data for non-algebraic types]- fun@(x:_) | startsVarSym x || startsVarId x- -> mkNameG_v tyconPkg tyconMod fun- con -> mkNameG_d tyconPkg tyconMod con-- where- tycon :: TyCon- tycon = (typeRepTyCon . typeOf) t-- tyconPkg, tyconMod :: String- tyconPkg = tyConPackage tycon- tyconMod = tyConModule tycon-- conArgs :: [m q]- conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t- IntConstr n ->- mkLit $ IntegerL n- FloatConstr n ->- mkLit $ RationalL n- CharConstr c ->- mkLit $ CharL c- where- constr :: Constr- constr = toConstr t-- Just y -> y---{- Note [Data for non-algebraic types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Class Data was originally intended for algebraic data types. But-it is possible to use it for abstract types too. For example, in-package `text` we find-- instance Data Text where- ...- toConstr _ = packConstr-- packConstr :: Constr- packConstr = mkConstr textDataType "pack" [] Prefix--Here `packConstr` isn't a real data constructor, it's an ordinary-function. Two complications--* In such a case, we must take care to build the Name using- mkNameG_v (for values), not mkNameG_d (for data constructors).- See #10796.--* The pseudo-constructor is named only by its string, here "pack".- But 'dataToQa' needs the TyCon of its defining module, and has- to assume it's defined in the same module as the TyCon itself.- But nothing enforces that; #12596 shows what goes wrong if- "pack" is defined in a different module than the data type "Text".- -}---- | 'dataToExpQ' converts a value to a 'Exp' representation of the--- same value, in the SYB style. It is generalized to take a function--- override type-specific cases; see 'liftData' for a more commonly--- used variant.-dataToExpQ :: (Quote m, Data a)- => (forall b . Data b => b -> Maybe (m Exp))- -> a- -> m Exp-dataToExpQ = dataToQa varOrConE litE (foldl appE)- where- -- Make sure that VarE is used if the Constr value relies on a- -- function underneath the surface (instead of a constructor).- -- See #10796.- varOrConE s =- case nameSpace s of- Just VarName -> return (VarE s)- Just (FldName {}) -> return (VarE s)- Just DataName -> return (ConE s)- _ -> error $ "Can't construct an expression from name "- ++ showName s- appE x y = do { a <- x; b <- y; return (AppE a b)}- litE c = return (LitE c)---- | 'liftData' is a variant of 'lift' in the 'Lift' type class which--- works for any type with a 'Data' instance.-liftData :: (Quote m, Data a) => a -> m Exp-liftData = dataToExpQ (const Nothing)---- | 'dataToPatQ' converts a value to a 'Pat' representation of the same--- value, in the SYB style. It takes a function to handle type-specific cases,--- alternatively, pass @const Nothing@ to get default behavior.-dataToPatQ :: (Quote m, Data a)- => (forall b . Data b => b -> Maybe (m Pat))- -> a- -> m Pat-dataToPatQ = dataToQa id litP conP- where litP l = return (LitP l)- conP n ps =- case nameSpace n of- Just DataName -> do- ps' <- sequence ps- return (ConP n [] ps')- _ -> error $ "Can't construct a pattern from name "- ++ showName n---------------------------------------------------------- Names and uniques--------------------------------------------------------newtype ModName = ModName String -- Module name- deriving (Show,Eq,Ord,Data,Generic)--newtype PkgName = PkgName String -- package name- deriving (Show,Eq,Ord,Data,Generic)---- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'.-data Module = Module PkgName ModName -- package qualified module name- deriving (Show,Eq,Ord,Data,Generic)--newtype OccName = OccName String- deriving (Show,Eq,Ord,Data,Generic)--mkModName :: String -> ModName-mkModName s = ModName s--modString :: ModName -> String-modString (ModName m) = m---mkPkgName :: String -> PkgName-mkPkgName s = PkgName s--pkgString :: PkgName -> String-pkgString (PkgName m) = m----------------------------------------------------------- OccName--------------------------------------------------------mkOccName :: String -> OccName-mkOccName s = OccName s--occString :: OccName -> String-occString (OccName occ) = occ----------------------------------------------------------- Names------------------------------------------------------------ For "global" names ('NameG') we need a totally unique name,--- so we must include the name-space of the thing------ For unique-numbered things ('NameU'), we've got a unique reference--- anyway, so no need for name space------ For dynamically bound thing ('NameS') we probably want them to--- in a context-dependent way, so again we don't want the name--- space. For example:------ > let v = mkName "T" in [| data $v = $v |]------ Here we use the same Name for both type constructor and data constructor--------- NameL and NameG are bound *outside* the TH syntax tree--- either globally (NameG) or locally (NameL). Ex:------ > f x = $(h [| (map, x) |])------ The 'map' will be a NameG, and 'x' wil be a NameL------ These Names should never appear in a binding position in a TH syntax tree--{- $namecapture #namecapture#-Much of 'Name' API is concerned with the problem of /name capture/, which-can be seen in the following example.--> f expr = [| let x = 0 in $expr |]-> ...-> g x = $( f [| x |] )-> h y = $( f [| y |] )--A naive desugaring of this would yield:--> g x = let x = 0 in x-> h y = let x = 0 in y--All of a sudden, @g@ and @h@ have different meanings! In this case,-we say that the @x@ in the RHS of @g@ has been /captured/-by the binding of @x@ in @f@.--What we actually want is for the @x@ in @f@ to be distinct from the-@x@ in @g@, so we get the following desugaring:--> g x = let x' = 0 in x-> h y = let x' = 0 in y--which avoids name capture as desired.--In the general case, we say that a @Name@ can be captured if-the thing it refers to can be changed by adding new declarations.--}--{- |-An abstract type representing names in the syntax tree.--'Name's can be constructed in several ways, which come with different-name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for-an explanation of name capture):-- * the built-in syntax @'f@ and @''T@ can be used to construct names,- The expression @'f@ gives a @Name@ which refers to the value @f@- currently in scope, and @''T@ gives a @Name@ which refers to the- type @T@ currently in scope. These names can never be captured.-- * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and- @''T@ respectively, but the @Name@s are looked up at the point- where the current splice is being run. These names can never be- captured.-- * 'newName' monadically generates a new name, which can never- be captured.-- * 'mkName' generates a capturable name.--Names constructed using @newName@ and @mkName@ may be used in bindings-(such as @let x = ...@ or @\x -> ...@), but names constructed using-@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.--}-data Name = Name OccName NameFlavour deriving (Data, Eq, Generic)--instance Ord Name where- -- check if unique is different before looking at strings- (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`- (o1 `compare` o2)--data NameFlavour- = NameS -- ^ An unqualified name; dynamically bound- | NameQ ModName -- ^ A qualified name; dynamically bound- | NameU !Uniq -- ^ A unique local name- | NameL !Uniq -- ^ Local name bound outside of the TH AST- | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST:- -- An original name (occurrences only, not binders)- -- Need the namespace too to be sure which- -- thing we are naming- deriving ( Data, Eq, Ord, Show, Generic )--data NameSpace = VarName -- ^ Variables- | DataName -- ^ Data constructors- | TcClsName -- ^ Type constructors and classes; Haskell has them- -- in the same name space for now.- | FldName- { fldParent :: !String- -- ^ The textual name of the parent of the field.- --- -- - For a field of a datatype, this is the name of the first constructor- -- of the datatype (regardless of whether this constructor has this field).- -- - For a field of a pattern synonym, this is the name of the pattern synonym.- }- deriving( Eq, Ord, Show, Data, Generic )---- | @Uniq@ is used by GHC to distinguish names from each other.-type Uniq = Integer---- | The name without its module prefix.------ ==== __Examples__------ >>> nameBase ''Data.Either.Either--- "Either"--- >>> nameBase (mkName "foo")--- "foo"--- >>> nameBase (mkName "Module.foo")--- "foo"-nameBase :: Name -> String-nameBase (Name occ _) = occString occ---- | Module prefix of a name, if it exists.------ ==== __Examples__------ >>> nameModule ''Data.Either.Either--- Just "Data.Either"--- >>> nameModule (mkName "foo")--- Nothing--- >>> nameModule (mkName "Module.foo")--- Just "Module"-nameModule :: Name -> Maybe String-nameModule (Name _ (NameQ m)) = Just (modString m)-nameModule (Name _ (NameG _ _ m)) = Just (modString m)-nameModule _ = Nothing---- | A name's package, if it exists.------ ==== __Examples__------ >>> namePackage ''Data.Either.Either--- Just "base"--- >>> namePackage (mkName "foo")--- Nothing--- >>> namePackage (mkName "Module.foo")--- Nothing-namePackage :: Name -> Maybe String-namePackage (Name _ (NameG _ p _)) = Just (pkgString p)-namePackage _ = Nothing---- | Returns whether a name represents an occurrence of a top-level variable--- ('VarName'), data constructor ('DataName'), type constructor, or type class--- ('TcClsName'). If we can't be sure, it returns 'Nothing'.------ ==== __Examples__------ >>> nameSpace 'Prelude.id--- Just VarName--- >>> nameSpace (mkName "id")--- Nothing -- only works for top-level variable names--- >>> nameSpace 'Data.Maybe.Just--- Just DataName--- >>> nameSpace ''Data.Maybe.Maybe--- Just TcClsName--- >>> nameSpace ''Data.Ord.Ord--- Just TcClsName-nameSpace :: Name -> Maybe NameSpace-nameSpace (Name _ (NameG ns _ _)) = Just ns-nameSpace _ = Nothing--{- |-Generate a capturable name. Occurrences of such names will be-resolved according to the Haskell scoping rules at the occurrence-site.--For example:--> f = [| pi + $(varE (mkName "pi")) |]-> ...-> g = let pi = 3 in $f--In this case, @g@ is desugared to--> g = Prelude.pi + 3--Note that @mkName@ may be used with qualified names:--> mkName "Prelude.pi"--See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could-be rewritten using 'Language.Haskell.TH.Lib.dyn' as--> f = [| pi + $(dyn "pi") |]--}-mkName :: String -> Name--- The string can have a '.', thus "Foo.baz",--- giving a dynamically-bound qualified name,--- in which case we want to generate a NameQ------ Parse the string to see if it has a "." in it--- so we know whether to generate a qualified or unqualified name--- It's a bit tricky because we need to parse------ > Foo.Baz.x as Qual Foo.Baz x------ So we parse it from back to front-mkName str- = split [] (reverse str)- where- split occ [] = Name (mkOccName occ) NameS- split occ ('.':rev) | not (null occ)- , is_rev_mod_name rev- = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))- -- The 'not (null occ)' guard ensures that- -- mkName "&." = Name "&." NameS- -- The 'is_rev_mod' guards ensure that- -- mkName ".&" = Name ".&" NameS- -- mkName "^.." = Name "^.." NameS -- #8633- -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")- -- This rather bizarre case actually happened; (.&.) is in Data.Bits- split occ (c:rev) = split (c:occ) rev-- -- Recognises a reversed module name xA.yB.C,- -- with at least one component,- -- and each component looks like a module name- -- (i.e. non-empty, starts with capital, all alpha)- is_rev_mod_name rev_mod_str- | (compt, rest) <- break (== '.') rev_mod_str- , not (null compt), isUpper (last compt), all is_mod_char compt- = case rest of- [] -> True- (_dot : rest') -> is_rev_mod_name rest'- | otherwise- = False-- is_mod_char c = isAlphaNum c || c == '_' || c == '\''---- | Only used internally-mkNameU :: String -> Uniq -> Name-mkNameU s u = Name (mkOccName s) (NameU u)---- | Only used internally-mkNameL :: String -> Uniq -> Name-mkNameL s u = Name (mkOccName s) (NameL u)---- | Only used internally-mkNameQ :: String -> String -> Name-mkNameQ mn occ = Name (mkOccName occ) (NameQ (mkModName mn))---- | Used for 'x etc, but not available to the programmer-mkNameG :: NameSpace -> String -> String -> String -> Name-mkNameG ns pkg modu occ- = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))--mkNameS :: String -> Name-mkNameS n = Name (mkOccName n) NameS--mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name-mkNameG_v = mkNameG VarName-mkNameG_tc = mkNameG TcClsName-mkNameG_d = mkNameG DataName--mkNameG_fld :: String -- ^ package- -> String -- ^ module- -> String -- ^ parent (first constructor of parent type)- -> String -- ^ field name- -> Name-mkNameG_fld pkg modu con occ = mkNameG (FldName con) pkg modu occ--data NameIs = Alone | Applied | Infix--showName :: Name -> String-showName = showName' Alone--showName' :: NameIs -> Name -> String-showName' ni nm- = case ni of- Alone -> nms- Applied- | pnam -> nms- | otherwise -> "(" ++ nms ++ ")"- Infix- | pnam -> "`" ++ nms ++ "`"- | otherwise -> nms- where- -- For now, we make the NameQ and NameG print the same, even though- -- NameQ is a qualified name (so what it means depends on what the- -- current scope is), and NameG is an original name (so its meaning- -- should be independent of what's in scope.- -- We may well want to distinguish them in the end.- -- Ditto NameU and NameL- nms = case nm of- Name occ NameS -> occString occ- Name occ (NameQ m) -> modString m ++ "." ++ occString occ- Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ- Name occ (NameU u) -> occString occ ++ "_" ++ show u- Name occ (NameL u) -> occString occ ++ "_" ++ show u-- pnam = classify nms-- -- True if we are function style, e.g. f, [], (,)- -- False if we are operator style, e.g. +, :+- classify "" = False -- shouldn't happen; . operator is handled below- classify (x:xs) | isAlpha x || (x `elem` "_[]()") =- case dropWhile (/='.') xs of- (_:xs') -> classify xs'- [] -> True- | otherwise = False--instance Show Name where- show = showName---- Tuple data and type constructors--- | Tuple data constructor-tupleDataName :: Int -> Name--- | Tuple type constructor-tupleTypeName :: Int -> Name--tupleDataName n = mk_tup_name n DataName True-tupleTypeName n = mk_tup_name n TcClsName True---- Unboxed tuple data and type constructors--- | Unboxed tuple data constructor-unboxedTupleDataName :: Int -> Name--- | Unboxed tuple type constructor-unboxedTupleTypeName :: Int -> Name--unboxedTupleDataName n = mk_tup_name n DataName False-unboxedTupleTypeName n = mk_tup_name n TcClsName False--mk_tup_name :: Int -> NameSpace -> Bool -> Name-mk_tup_name n space boxed- = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod)- where- withParens thing- | boxed = "(" ++ thing ++ ")"- | otherwise = "(#" ++ thing ++ "#)"- tup_occ | n == 0, space == TcClsName = if boxed then "Unit" else "Unit#"- | n == 1 = if boxed then solo else unboxed_solo- | space == TcClsName = "Tuple" ++ show n ++ if boxed then "" else "#"- | otherwise = withParens (replicate n_commas ',')- n_commas = n - 1- tup_mod = mkModName (if boxed then "GHC.Tuple" else "GHC.Types")- solo- | space == DataName = "MkSolo"- | otherwise = "Solo"-- unboxed_solo- | space == DataName = "(# #)"- | otherwise = "Solo#"---- Unboxed sum data and type constructors--- | Unboxed sum data constructor-unboxedSumDataName :: SumAlt -> SumArity -> Name--- | Unboxed sum type constructor-unboxedSumTypeName :: SumArity -> Name--unboxedSumDataName alt arity- | alt > arity- = error $ prefix ++ "Index out of bounds." ++ debug_info-- | alt <= 0- = error $ prefix ++ "Alt must be > 0." ++ debug_info-- | arity < 2- = error $ prefix ++ "Arity must be >= 2." ++ debug_info-- | otherwise- = Name (mkOccName sum_occ)- (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))-- where- prefix = "unboxedSumDataName: "- debug_info = " (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")"-- -- Synced with the definition of mkSumDataConOcc in GHC.Builtin.Types- sum_occ = '(' : '#' : bars nbars_before ++ '_' : bars nbars_after ++ "#)"- bars i = replicate i '|'- nbars_before = alt - 1- nbars_after = arity - alt--unboxedSumTypeName arity- | arity < 2- = error $ "unboxedSumTypeName: Arity must be >= 2."- ++ " (arity: " ++ show arity ++ ")"-- | otherwise- = Name (mkOccName sum_occ)- (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))-- where- -- Synced with the definition of mkSumTyConOcc in GHC.Builtin.Types- sum_occ = "Sum" ++ show arity ++ "#"---------------------------------------------------------- Locations--------------------------------------------------------data Loc- = Loc { loc_filename :: String- , loc_package :: String- , loc_module :: String- , loc_start :: CharPos- , loc_end :: CharPos }- deriving( Show, Eq, Ord, Data, Generic )--type CharPos = (Int, Int) -- ^ Line and character position-------------------------------------------------------------- The Info returned by reification------------------------------------------------------------- | Obtained from 'reify' in the 'Q' Monad.-data Info- =- -- | A class, with a list of its visible instances- ClassI- Dec- [InstanceDec]-- -- | A class method- | ClassOpI- Name- Type- ParentName-- -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned- -- using 'PrimTyConI' or 'FamilyI' as appropriate. At present, this reified- -- declaration will never have derived instances attached to it (if you wish- -- to check for an instance, see 'reifyInstances').- | TyConI- Dec-- -- | A type or data family, with a list of its visible instances. A closed- -- type family is returned with 0 instances.- | FamilyI- Dec- [InstanceDec]-- -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'.- -- Examples: @(->)@, @Int#@.- | PrimTyConI- Name- Arity- Unlifted-- -- | A data constructor- | DataConI- Name- Type- ParentName-- -- | A pattern synonym- | PatSynI- Name- PatSynType-- {- |- A \"value\" variable (as opposed to a type variable, see 'TyVarI').-- The @Maybe Dec@ field contains @Just@ the declaration which- defined the variable - including the RHS of the declaration -- or else @Nothing@, in the case where the RHS is unavailable to- the compiler. At present, this value is /always/ @Nothing@:- returning the RHS has not yet been implemented because of- lack of interest.- -}- | VarI- Name- Type- (Maybe Dec)-- {- |- A type variable.-- The @Type@ field contains the type which underlies the variable.- At present, this is always @'VarT' theName@, but future changes- may permit refinement of this.- -}- | TyVarI -- Scoped type variable- Name- Type -- What it is bound to- deriving( Show, Eq, Ord, Data, Generic )---- | Obtained from 'reifyModule' in the 'Q' Monad.-data ModuleInfo =- -- | Contains the import list of the module.- ModuleInfo [Module]- deriving( Show, Eq, Ord, Data, Generic )--{- |-In 'ClassOpI' and 'DataConI', name of the parent class or type--}-type ParentName = Name---- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a--- particular data constructor. 'SumAlt's are one-indexed and should never--- exceed the value of its corresponding 'SumArity'. For example:------ * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2)------ * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2)-type SumAlt = Int---- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of--- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2.-type SumArity = Int---- | In 'PrimTyConI', arity of the type constructor-type Arity = Int---- | In 'PrimTyConI', is the type constructor unlifted?-type Unlifted = Bool---- | 'InstanceDec' describes a single instance of a class or type function.--- It is just a 'Dec', but guaranteed to be one of the following:------ * 'InstanceD' (with empty @['Dec']@)------ * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@)------ * 'TySynInstD'-type InstanceDec = Dec--data Fixity = Fixity Int FixityDirection- deriving( Eq, Ord, Show, Data, Generic )-data FixityDirection = InfixL | InfixR | InfixN- deriving( Eq, Ord, Show, Data, Generic )---- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)-maxPrecedence :: Int-maxPrecedence = (9::Int)---- | Default fixity: @infixl 9@-defaultFixity :: Fixity-defaultFixity = Fixity maxPrecedence InfixL---{--Note [Unresolved infix]-~~~~~~~~~~~~~~~~~~~~~~~--}-{- $infix #infix#--When implementing antiquotation for quasiquoters, one often wants-to parse strings into expressions:--> parse :: String -> Maybe Exp--But how should we parse @a + b * c@? If we don't know the fixities of-@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a-+ b) * c@.--In cases like this, use 'UInfixE', 'UInfixP', 'UInfixT', or 'PromotedUInfixT',-which stand for \"unresolved infix expression/pattern/type/promoted-constructor\", respectively. When the compiler is given a splice containing a-tree of @UInfixE@ applications such as--> UInfixE-> (UInfixE e1 op1 e2)-> op2-> (UInfixE e3 op3 e4)--it will look up and the fixities of the relevant operators and-reassociate the tree as necessary.-- * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT',- which are of use for parsing expressions like-- > (a + b * c) + d * e-- * 'InfixE', 'InfixP', 'InfixT', and 'PromotedInfixT' expressions are never- reassociated.-- * The 'UInfixE' constructor doesn't support sections. Sections- such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer- sections such as @(a + b * c -)@, use an 'InfixE' constructor for the- outer-most section, and use 'UInfixE' constructors for all- other operators:-- > InfixE- > Just (UInfixE ...a + b * c...)- > op- > Nothing-- Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered- into 'Exp's differently:-- > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b)- > -- will result in a fixity error if (+) is left-infix- > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b)- > -- no fixity errors-- * Quoted expressions such as-- > [| a * b + c |] :: Q Exp- > [p| a : b : c |] :: Q Pat- > [t| T + T |] :: Q Type-- will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'PromotedUInfixT',- 'InfixT', 'PromotedInfixT, 'ParensE', 'ParensP', or 'ParensT' constructors.---}------------------------------------------------------------- The main syntax data types-----------------------------------------------------------data Lit = CharL Char- | StringL String- | IntegerL Integer -- ^ Used for overloaded and non-overloaded- -- literals. We don't have a good way to- -- represent non-overloaded literals at- -- the moment. Maybe that doesn't matter?- | RationalL Rational -- Ditto- | IntPrimL Integer- | WordPrimL Integer- | FloatPrimL Rational- | DoublePrimL Rational- | StringPrimL [Word8] -- ^ A primitive C-style string, type 'Addr#'- | BytesPrimL Bytes -- ^ Some raw bytes, type 'Addr#':- | CharPrimL Char- deriving( Show, Eq, Ord, Data, Generic )-- -- We could add Int, Float, Double etc, as we do in HsLit,- -- but that could complicate the- -- supposedly-simple TH.Syntax literal type---- | Raw bytes embedded into the binary.------ Avoid using Bytes constructor directly as it is likely to change in the--- future. Use helpers such as `mkBytes` in Language.Haskell.TH.Lib instead.-data Bytes = Bytes- { bytesPtr :: ForeignPtr Word8 -- ^ Pointer to the data- , bytesOffset :: Word -- ^ Offset from the pointer- , bytesSize :: Word -- ^ Number of bytes-- -- Maybe someday:- -- , bytesAlignement :: Word -- ^ Alignement constraint- -- , bytesReadOnly :: Bool -- ^ Shall we embed into a read-only- -- -- section or not- -- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate- -- -- an uninitialized region- }- deriving (Data,Generic)---- We can't derive Show instance for Bytes because we don't want to show the--- pointer value but the actual bytes (similarly to what ByteString does). See--- #16457.-instance Show Bytes where- show b = unsafePerformIO $ withForeignPtr (bytesPtr b) $ \ptr ->- peekCStringLen ( ptr `plusPtr` fromIntegral (bytesOffset b)- , fromIntegral (bytesSize b)- )---- We can't derive Eq and Ord instances for Bytes because we don't want to--- compare pointer values but the actual bytes (similarly to what ByteString--- does). See #16457-instance Eq Bytes where- (==) = eqBytes--instance Ord Bytes where- compare = compareBytes--eqBytes :: Bytes -> Bytes -> Bool-eqBytes a@(Bytes fp off len) b@(Bytes fp' off' len')- | len /= len' = False -- short cut on length- | fp == fp' && off == off' = True -- short cut for the same bytes- | otherwise = compareBytes a b == EQ--compareBytes :: Bytes -> Bytes -> Ordering-compareBytes (Bytes _ _ 0) (Bytes _ _ 0) = EQ -- short cut for empty Bytes-compareBytes (Bytes fp1 off1 len1) (Bytes fp2 off2 len2) =- unsafePerformIO $- withForeignPtr fp1 $ \p1 ->- withForeignPtr fp2 $ \p2 -> do- i <- memcmp (p1 `plusPtr` fromIntegral off1)- (p2 `plusPtr` fromIntegral off2)- (fromIntegral (min len1 len2))- return $! (i `compare` 0) <> (len1 `compare` len2)--foreign import ccall unsafe "memcmp"- memcmp :: Ptr a -> Ptr b -> CSize -> IO CInt----- | Pattern in Haskell given in @{}@-data Pat- = LitP Lit -- ^ @{ 5 or \'c\' }@- | VarP Name -- ^ @{ x }@- | TupP [Pat] -- ^ @{ (p1,p2) }@- | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@- | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@- | ConP Name [Type] [Pat] -- ^ @data T1 = C1 t1 t2; {C1 \@ty1 p1 p2} = e@- | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@- | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@- --- -- See "Language.Haskell.TH.Syntax#infix"- | ParensP Pat -- ^ @{(p)}@- --- -- See "Language.Haskell.TH.Syntax#infix"- | TildeP Pat -- ^ @{ ~p }@- | BangP Pat -- ^ @{ !p }@- | AsP Name Pat -- ^ @{ x \@ p }@- | WildP -- ^ @{ _ }@- | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@- | ListP [ Pat ] -- ^ @{ [1,2,3] }@- | SigP Pat Type -- ^ @{ p :: t }@- | ViewP Exp Pat -- ^ @{ e -> p }@- | TypeP Type -- ^ @{ type p }@- | InvisP Type -- ^ @{ @p }@- deriving( Show, Eq, Ord, Data, Generic )--type FieldPat = (Name,Pat)--data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@- deriving( Show, Eq, Ord, Data, Generic )--data Clause = Clause [Pat] Body [Dec]- -- ^ @f { p1 p2 = body where decs }@- deriving( Show, Eq, Ord, Data, Generic )--data Exp- = VarE Name -- ^ @{ x }@- | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @- | LitE Lit -- ^ @{ 5 or \'c\'}@- | AppE Exp Exp -- ^ @{ f x }@- | AppTypeE Exp Type -- ^ @{ f \@Int }@-- | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@-- -- It's a bit gruesome to use an Exp as the operator when a Name- -- would suffice. Historically, Exp was used to make it easier to- -- distinguish between infix constructors and non-constructors.- -- This is a bit overkill, since one could just as well call- -- `startsConId` or `startsConSym` (from `GHC.Lexeme`) on a Name.- -- Unfortunately, changing this design now would involve lots of- -- code churn for consumers of the TH API, so we continue to use- -- an Exp as the operator and perform an extra check during conversion- -- to ensure that the Exp is a constructor or a variable (#16895).-- | UInfixE Exp Exp Exp -- ^ @{x + y}@- --- -- See "Language.Haskell.TH.Syntax#infix"- | ParensE Exp -- ^ @{ (e) }@- --- -- See "Language.Haskell.TH.Syntax#infix"- | LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@- | LamCaseE [Match] -- ^ @{ \\case m1; m2 }@- | LamCasesE [Clause] -- ^ @{ \\cases m1; m2 }@- | TupE [Maybe Exp] -- ^ @{ (e1,e2) } @- --- -- The 'Maybe' is necessary for handling- -- tuple sections.- --- -- > (1,)- --- -- translates to- --- -- > TupE [Just (LitE (IntegerL 1)),Nothing]-- | UnboxedTupE [Maybe Exp] -- ^ @{ (\# e1,e2 \#) } @- --- -- The 'Maybe' is necessary for handling- -- tuple sections.- --- -- > (# 'c', #)- --- -- translates to- --- -- > UnboxedTupE [Just (LitE (CharL 'c')),Nothing]-- | UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@- | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@- | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@- | LetE [Dec] Exp -- ^ @{ let { x=e1; y=e2 } in e3 }@- | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@- | DoE (Maybe ModName) [Stmt] -- ^ @{ do { p <- e1; e2 } }@ or a qualified do if- -- the module name is present- | MDoE (Maybe ModName) [Stmt] -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@ or a qualified- -- mdo if the module name is present- | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@- --- -- The result expression of the comprehension is- -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'.- --- -- E.g. translation:- --- -- > [ f x | x <- xs ]- --- -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]-- | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@- | ListE [ Exp ] -- ^ @{ [1,2,3] }@- | SigE Exp Type -- ^ @{ e :: t }@- | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@- | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@- | StaticE Exp -- ^ @{ static e }@- | UnboundVarE Name -- ^ @{ _x }@- --- -- This is used for holes or unresolved- -- identifiers in AST quotes. Note that- -- it could either have a variable name- -- or constructor name.- | LabelE String -- ^ @{ #x }@ ( Overloaded label )- | ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter )- | GetFieldE Exp String -- ^ @{ exp.field }@ ( Overloaded Record Dot )- | ProjectionE (NonEmpty String) -- ^ @(.x)@ or @(.x.y)@ (Record projections)- | TypedBracketE Exp -- ^ @[|| e ||]@- | TypedSpliceE Exp -- ^ @$$e@- | TypeE Type -- ^ @{ type t }@- deriving( Show, Eq, Ord, Data, Generic )--type FieldExp = (Name,Exp)---- Omitted: implicit parameters--data Body- = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2- -- | e3 = e4 }- -- where ds@- | NormalB Exp -- ^ @f p { = e } where ds@- deriving( Show, Eq, Ord, Data, Generic )--data Guard- = NormalG Exp -- ^ @f x { | odd x } = x@- | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@- deriving( Show, Eq, Ord, Data, Generic )--data Stmt- = BindS Pat Exp -- ^ @p <- e@- | LetS [ Dec ] -- ^ @{ let { x=e1; y=e2 } }@- | NoBindS Exp -- ^ @e@- | ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE')- | RecS [Stmt] -- ^ @rec { s1; s2 }@- deriving( Show, Eq, Ord, Data, Generic )--data Range = FromR Exp | FromThenR Exp Exp- | FromToR Exp Exp | FromThenToR Exp Exp Exp- deriving( Show, Eq, Ord, Data, Generic )--data Dec- = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@- | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@- | DataD Cxt Name [TyVarBndr BndrVis]- (Maybe Kind) -- Kind signature (allowed only for GADTs)- [Con] [DerivClause]- -- ^ @{ data Cxt x => T x = A x | B (T x)- -- deriving (Z,W)- -- deriving stock Eq }@- | NewtypeD Cxt Name [TyVarBndr BndrVis]- (Maybe Kind) -- Kind signature- Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x)- -- deriving (Z,W Q)- -- deriving stock Eq }@- | TypeDataD Name [TyVarBndr BndrVis]- (Maybe Kind) -- Kind signature (allowed only for GADTs)- [Con] -- ^ @{ type data T x = A x | B (T x) }@- | TySynD Name [TyVarBndr BndrVis] Type -- ^ @{ type T x = (x,x) }@- | ClassD Cxt Name [TyVarBndr BndrVis]- [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@- | InstanceD (Maybe Overlap) Cxt Type [Dec]- -- ^ @{ instance {\-\# OVERLAPS \#-\}- -- Show w => Show [w] where ds }@- | SigD Name Type -- ^ @{ length :: [a] -> Int }@- | KiSigD Name Kind -- ^ @{ type TypeRep :: k -> Type }@- | ForeignD Foreign -- ^ @{ foreign import ... }- --{ foreign export ... }@-- | InfixD Fixity NamespaceSpecifier Name- -- ^ @{ infix 3 data foo }@- | DefaultD [Type] -- ^ @{ default (Integer, Double) }@-- -- | pragmas- | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@-- -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD')- | DataFamilyD Name [TyVarBndr BndrVis]- (Maybe Kind)- -- ^ @{ data family T a b c :: * }@-- | DataInstD Cxt (Maybe [TyVarBndr ()]) Type- (Maybe Kind) -- Kind signature- [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x]- -- = A x | B (T x)- -- deriving (Z,W)- -- deriving stock Eq }@-- | NewtypeInstD Cxt (Maybe [TyVarBndr ()]) Type -- Quantified type vars- (Maybe Kind) -- Kind signature- Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]- -- = A (B x)- -- deriving (Z,W)- -- deriving stock Eq }@- | TySynInstD TySynEqn -- ^ @{ type instance ... }@-- -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')- | OpenTypeFamilyD TypeFamilyHead- -- ^ @{ type family T a b c = (r :: *) | r -> a b }@-- | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]- -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@-- | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@- | StandaloneDerivD (Maybe DerivStrategy) Cxt Type- -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@- | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@-- -- | Pattern Synonyms- | PatSynD Name PatSynArgs PatSynDir Pat- -- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or- -- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or- -- @{ pattern P v1 v2 .. vn <- p- -- where P v1 v2 .. vn = e }@ explicit bidirectional- --- -- also, besides prefix pattern synonyms, both infix and record- -- pattern synonyms are supported. See 'PatSynArgs' for details-- | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature.-- | ImplicitParamBindD String Exp- -- ^ @{ ?x = expr }@- --- -- Implicit parameter binding declaration. Can only be used in let- -- and where clauses which consist entirely of implicit bindings.- deriving( Show, Eq, Ord, Data, Generic )---- | A way to specify a namespace to look in when GHC needs to find--- a name's source-data NamespaceSpecifier- = NoNamespaceSpecifier -- ^ Name may be everything; If there are two- -- names in different namespaces, then consider both- | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a- -- data type, type alias, type family, type class,- -- or type variable- | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a- -- function, data constructor, or pattern synonym- deriving( Show, Eq, Ord, Data, Generic )---- | Varieties of allowed instance overlap.-data Overlap = Overlappable -- ^ May be overlapped by more specific instances- | Overlapping -- ^ May overlap a more general instance- | Overlaps -- ^ Both 'Overlapping' and 'Overlappable'- | Incoherent -- ^ Both 'Overlapping' and 'Overlappable', and- -- pick an arbitrary one if multiple choices are- -- available.- deriving( Show, Eq, Ord, Data, Generic )---- | A single @deriving@ clause at the end of a datatype.-data DerivClause = DerivClause (Maybe DerivStrategy) Cxt- -- ^ @{ deriving stock (Eq, Ord) }@- deriving( Show, Eq, Ord, Data, Generic )---- | What the user explicitly requests when deriving an instance.-data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance- | AnyclassStrategy -- ^ @-XDeriveAnyClass@- | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@- | ViaStrategy Type -- ^ @-XDerivingVia@- deriving( Show, Eq, Ord, Data, Generic )---- | A pattern synonym's type. Note that a pattern synonym's /fully/--- specified type has a peculiar shape coming with two forall--- quantifiers and two constraint contexts. For example, consider the--- pattern synonym------ > pattern P x1 x2 ... xn = <some-pattern>------ P's complete type is of the following form------ > pattern P :: forall universals. required constraints--- > => forall existentials. provided constraints--- > => t1 -> t2 -> ... -> tn -> t------ consisting of four parts:------ 1. the (possibly empty lists of) universally quantified type--- variables and required constraints on them.--- 2. the (possibly empty lists of) existentially quantified--- type variables and the provided constraints on them.--- 3. the types @t1@, @t2@, .., @tn@ of @x1@, @x2@, .., @xn@, respectively--- 4. the type @t@ of @\<some-pattern\>@, mentioning only universals.------ Pattern synonym types interact with TH when (a) reifying a pattern--- synonym, (b) pretty printing, or (c) specifying a pattern synonym's--- type signature explicitly:------ * Reification always returns a pattern synonym's /fully/ specified--- type in abstract syntax.------ * Pretty printing via 'Language.Haskell.TH.Ppr.pprPatSynType' abbreviates--- a pattern synonym's type unambiguously in concrete syntax: The rule of--- thumb is to print initial empty universals and the required--- context as @() =>@, if existentials and a provided context--- follow. If only universals and their required context, but no--- existentials are specified, only the universals and their--- required context are printed. If both or none are specified, so--- both (or none) are printed.------ * When specifying a pattern synonym's type explicitly with--- 'PatSynSigD' either one of the universals, the existentials, or--- their contexts may be left empty.------ See the GHC user's guide for more information on pattern synonyms--- and their types:--- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#pattern-synonyms>.-type PatSynType = Type---- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By--- analogy with "head" for type classes and type class instances as--- defined in /Type classes: an exploration of the design space/, the--- @TypeFamilyHead@ is defined to be the elements of the declaration--- between @type family@ and @where@.-data TypeFamilyHead =- TypeFamilyHead Name [TyVarBndr BndrVis] FamilyResultSig (Maybe InjectivityAnn)- deriving( Show, Eq, Ord, Data, Generic )---- | One equation of a type family instance or closed type family. The--- arguments are the left-hand-side type and the right-hand-side result.------ For instance, if you had the following type family:------ @--- type family Foo (a :: k) :: k where--- forall k (a :: k). Foo \@k a = a--- @------ The @Foo \@k a = a@ equation would be represented as follows:------ @--- 'TySynEqn' ('Just' ['PlainTV' k, 'KindedTV' a ('VarT' k)])--- ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a))--- ('VarT' a)--- @-data TySynEqn = TySynEqn (Maybe [TyVarBndr ()]) Type Type- deriving( Show, Eq, Ord, Data, Generic )--data FunDep = FunDep [Name] [Name]- deriving( Show, Eq, Ord, Data, Generic )--data Foreign = ImportF Callconv Safety String Name Type- | ExportF Callconv String Name Type- deriving( Show, Eq, Ord, Data, Generic )---- keep Callconv in sync with module ForeignCall in ghc/compiler/GHC/Types/ForeignCall.hs-data Callconv = CCall | StdCall | CApi | Prim | JavaScript- deriving( Show, Eq, Ord, Data, Generic )--data Safety = Unsafe | Safe | Interruptible- deriving( Show, Eq, Ord, Data, Generic )--data Pragma = InlineP Name Inline RuleMatch Phases- | OpaqueP Name- | SpecialiseP Name Type (Maybe Inline) Phases- | SpecialiseInstP Type- | RuleP String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases- | AnnP AnnTarget Exp- | LineP Int String- | CompleteP [Name] (Maybe Name)- -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@- | SCCP Name (Maybe String)- -- ^ @{ {\-\# SCC fun "optional_name" \#-} }@- deriving( Show, Eq, Ord, Data, Generic )--data Inline = NoInline- | Inline- | Inlinable- deriving (Show, Eq, Ord, Data, Generic)--data RuleMatch = ConLike- | FunLike- deriving (Show, Eq, Ord, Data, Generic)--data Phases = AllPhases- | FromPhase Int- | BeforePhase Int- deriving (Show, Eq, Ord, Data, Generic)--data RuleBndr = RuleVar Name- | TypedRuleVar Name Type- deriving (Show, Eq, Ord, Data, Generic)--data AnnTarget = ModuleAnnotation- | TypeAnnotation Name- | ValueAnnotation Name- deriving (Show, Eq, Ord, Data, Generic)--type Cxt = [Pred] -- ^ @(Eq a, Ord b)@---- | Since the advent of @ConstraintKinds@, constraints are really just types.--- Equality constraints use the 'EqualityT' constructor. Constraints may also--- be tuples of other constraints.-type Pred = Type---- | 'SourceUnpackedness' corresponds to unpack annotations found in the source code.------ This may not agree with the annotations returned by 'reifyConStrictness'.--- See 'reifyConStrictness' for more information.-data SourceUnpackedness- = NoSourceUnpackedness -- ^ @C a@- | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@- | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@- deriving (Show, Eq, Ord, Data, Generic)---- | 'SourceStrictness' corresponds to strictness annotations found in the source code.------ This may not agree with the annotations returned by 'reifyConStrictness'.--- See 'reifyConStrictness' for more information.-data SourceStrictness = NoSourceStrictness -- ^ @C a@- | SourceLazy -- ^ @C {~}a@- | SourceStrict -- ^ @C {!}a@- deriving (Show, Eq, Ord, Data, Generic)---- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'--- refers to the strictness annotations that the compiler chooses for a data constructor--- field, which may be different from what is written in source code.------ Note that non-unpacked strict fields are assigned 'DecidedLazy' when a bang would be inappropriate,--- such as the field of a newtype constructor and fields that have an unlifted type.------ See 'reifyConStrictness' for more information.-data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.- | DecidedStrict -- ^ Field inferred to have a bang.- | DecidedUnpack -- ^ Field inferred to be unpacked.- deriving (Show, Eq, Ord, Data, Generic)---- | A data constructor.------ The constructors for 'Con' can roughly be divided up into two categories:--- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and--- 'InfixC'), and those for constructors with GADT syntax ('GadtC' and--- 'RecGadtC'). The 'ForallC' constructor, which quantifies additional type--- variables and class contexts, can surround either variety of constructor.--- However, the type variables that it quantifies are different depending--- on what constructor syntax is used:------ * If a 'ForallC' surrounds a constructor with vanilla syntax, then the--- 'ForallC' will only quantify /existential/ type variables. For example:------ @--- data Foo a = forall b. MkFoo a b--- @------ In @MkFoo@, 'ForallC' will quantify @b@, but not @a@.------ * If a 'ForallC' surrounds a constructor with GADT syntax, then the--- 'ForallC' will quantify /all/ type variables used in the constructor.--- For example:------ @--- data Bar a b where--- MkBar :: (a ~ b) => c -> MkBar a b--- @------ In @MkBar@, 'ForallC' will quantify @a@, @b@, and @c@.------ Multiplicity annotations for data types are currently not supported--- in Template Haskell (i.e. all fields represented by Template Haskell--- will be linear).-data Con =- -- | @C Int a@- NormalC Name [BangType]-- -- | @C { v :: Int, w :: a }@- | RecC Name [VarBangType]-- -- | @Int :+ a@- | InfixC BangType Name BangType-- -- | @forall a. Eq a => C [a]@- | ForallC [TyVarBndr Specificity] Cxt Con-- -- @C :: a -> b -> T b Int@- | GadtC [Name]- -- ^ The list of constructors, corresponding to the GADT constructor- -- syntax @C1, C2 :: a -> T b@.- --- -- Invariant: the list must be non-empty.- [BangType] -- ^ The constructor arguments- Type -- ^ See Note [GADT return type]-- -- | @C :: { v :: Int } -> T b Int@- | RecGadtC [Name]- -- ^ The list of constructors, corresponding to the GADT record- -- constructor syntax @C1, C2 :: { fld :: a } -> T b@.- --- -- Invariant: the list must be non-empty.- [VarBangType] -- ^ The constructor arguments- Type -- ^ See Note [GADT return type]- deriving (Show, Eq, Ord, Data, Generic)---- Note [GADT return type]--- ~~~~~~~~~~~~~~~~~~~~~~~--- The return type of a GADT constructor does not necessarily match the name of--- the data type:------ type S = T------ data T a where--- MkT :: S Int--------- type S a = T------ data T a where--- MkT :: S Char Int--------- type Id a = a--- type S a = T------ data T a where--- MkT :: Id (S Char Int)--------- That is why we allow the return type stored by a constructor to be an--- arbitrary type. See also #11341--data Bang = Bang SourceUnpackedness SourceStrictness- -- ^ @C { {\-\# UNPACK \#-\} !}a@- deriving (Show, Eq, Ord, Data, Generic)--type BangType = (Bang, Type)-type VarBangType = (Name, Bang, Type)---- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'.-type Strict = Bang---- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by--- 'BangType'.-type StrictType = BangType---- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by--- 'VarBangType'.-type VarStrictType = VarBangType---- | A pattern synonym's directionality.-data PatSynDir- = Unidir -- ^ @pattern P x {<-} p@- | ImplBidir -- ^ @pattern P x {=} p@- | ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@- deriving( Show, Eq, Ord, Data, Generic )---- | A pattern synonym's argument type.-data PatSynArgs- = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@- | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@- | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@- deriving( Show, Eq, Ord, Data, Generic )--data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@- | ForallVisT [TyVarBndr ()] Type -- ^ @forall \<vars\> -> \<type\>@- | AppT Type Type -- ^ @T a b@- | AppKindT Type Kind -- ^ @T \@k t@- | SigT Type Kind -- ^ @t :: k@- | VarT Name -- ^ @a@- | ConT Name -- ^ @T@- | PromotedT Name -- ^ @'T@- | InfixT Type Name Type -- ^ @T + T@- | UInfixT Type Name Type -- ^ @T + T@- --- -- See "Language.Haskell.TH.Syntax#infix"- | PromotedInfixT Type Name Type -- ^ @T :+: T@- | PromotedUInfixT Type Name Type -- ^ @T :+: T@- --- -- See "Language.Haskell.TH.Syntax#infix"- | ParensT Type -- ^ @(T)@-- -- See Note [Representing concrete syntax in types]- | TupleT Int -- ^ @(,)@, @(,,)@, etc.- | UnboxedTupleT Int -- ^ @(\#,\#)@, @(\#,,\#)@, etc.- | UnboxedSumT SumArity -- ^ @(\#|\#)@, @(\#||\#)@, etc.- | ArrowT -- ^ @->@- | MulArrowT -- ^ @%n ->@- --- -- Generalised arrow type with multiplicity argument- | EqualityT -- ^ @~@- | ListT -- ^ @[]@- | PromotedTupleT Int -- ^ @'()@, @'(,)@, @'(,,)@, etc.- | PromotedNilT -- ^ @'[]@- | PromotedConsT -- ^ @'(:)@- | StarT -- ^ @*@- | ConstraintT -- ^ @Constraint@- | LitT TyLit -- ^ @0@, @1@, @2@, etc.- | WildCardT -- ^ @_@- | ImplicitParamT String Type -- ^ @?x :: t@- deriving( Show, Eq, Ord, Data, Generic )--data Specificity = SpecifiedSpec -- ^ @a@- | InferredSpec -- ^ @{a}@- deriving( Show, Eq, Ord, Data, Generic )---- | The @flag@ type parameter is instantiated to one of the following types:------ * 'Specificity' (examples: 'ForallC', 'ForallT')--- * 'BndrVis' (examples: 'DataD', 'ClassD', etc.)--- * '()', a catch-all type for other forms of binders, including 'ForallVisT', 'DataInstD', 'RuleP', and 'TyVarSig'----data TyVarBndr flag = PlainTV Name flag -- ^ @a@- | KindedTV Name flag Kind -- ^ @(a :: k)@- deriving( Show, Eq, Ord, Data, Generic, Functor, Foldable, Traversable )--data BndrVis = BndrReq -- ^ @a@- | BndrInvis -- ^ @\@a@- deriving( Show, Eq, Ord, Data, Generic )---- | Type family result signature-data FamilyResultSig = NoSig -- ^ no signature- | KindSig Kind -- ^ @k@- | TyVarSig (TyVarBndr ()) -- ^ @= r, = (r :: k)@- deriving( Show, Eq, Ord, Data, Generic )---- | Injectivity annotation-data InjectivityAnn = InjectivityAnn Name [Name]- deriving ( Show, Eq, Ord, Data, Generic )--data TyLit = NumTyLit Integer -- ^ @2@- | StrTyLit String -- ^ @\"Hello\"@- | CharTyLit Char -- ^ @\'C\'@, @since 4.16.0.0- deriving ( Show, Eq, Ord, Data, Generic )---- | Role annotations-data Role = NominalR -- ^ @nominal@- | RepresentationalR -- ^ @representational@- | PhantomR -- ^ @phantom@- | InferR -- ^ @_@- deriving( Show, Eq, Ord, Data, Generic )---- | Annotation target for reifyAnnotations-data AnnLookup = AnnLookupModule Module- | AnnLookupName Name- deriving( Show, Eq, Ord, Data, Generic )---- | To avoid duplication between kinds and types, they--- are defined to be the same. Naturally, you would never--- have a type be 'StarT' and you would never have a kind--- be 'SigT', but many of the other constructors are shared.--- Note that the kind @Bool@ is denoted with 'ConT', not--- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT',--- not 'PromotedTupleT'.--type Kind = Type--{- Note [Representing concrete syntax in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Haskell has a rich concrete syntax for types, including- t1 -> t2, (t1,t2), [t], and so on-In TH we represent all of this using AppT, with a distinguished-type constructor at the head. So,- Type TH representation- ------------------------------------------------ t1 -> t2 ArrowT `AppT` t2 `AppT` t2- [t] ListT `AppT` t- (t1,t2) TupleT 2 `AppT` t1 `AppT` t2- '(t1,t2) PromotedTupleT 2 `AppT` t1 `AppT` t2--But if the original HsSyn used prefix application, we won't use-these special TH constructors. For example- [] t ConT "[]" `AppT` t- (->) t ConT "->" `AppT` t-In this way we can faithfully represent in TH whether the original-HsType used concrete syntax or not.--The one case that doesn't fit this pattern is that of promoted lists- '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2-but it's very smelly because there really is no type constructor-corresponding to PromotedListT. So we encode HsExplicitListTy with-PromotedConsT and PromotedNilT (which *do* have underlying type-constructors):- '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT`- (PromotedConsT `AppT` IO `AppT` PromotedNilT)--}---- | A location at which to attach Haddock documentation.--- Note that adding documentation to a 'Name' defined oustide of the current--- module will cause an error.-data DocLoc- = ModuleDoc -- ^ At the current module's header.- | DeclDoc Name -- ^ At a declaration, not necessarily top level.- | ArgDoc Name Int -- ^ At a specific argument of a function, indexed by its- -- position.- | InstDoc Type -- ^ At a class or family instance.- deriving ( Show, Eq, Ord, Data, Generic )---------------------------------------------------------- Internal helper functions--------------------------------------------------------cmpEq :: Ordering -> Bool-cmpEq EQ = True-cmpEq _ = False--thenCmp :: Ordering -> Ordering -> Ordering-thenCmp EQ o2 = o2-thenCmp o1 _ = o1--get_cons_names :: Con -> [Name]-get_cons_names (NormalC n _) = [n]-get_cons_names (RecC n _) = [n]-get_cons_names (InfixC _ n _) = [n]-get_cons_names (ForallC _ _ con) = get_cons_names con--- GadtC can have multiple names, e.g--- > data Bar a where--- > MkBar1, MkBar2 :: a -> Bar a--- Will have one GadtC with [MkBar1, MkBar2] as names-get_cons_names (GadtC ns _ _) = ns-get_cons_names (RecGadtC ns _ _) = ns+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UnboxedTuples #-}++module Language.Haskell.TH.Syntax (+ Quote (..),+ Exp (..),+ Match (..),+ Clause (..),+ Q (..),+ Pat (..),+ Stmt (..),+ Con (..),+ Type (..),+ Dec (..),+ BangType,+ VarBangType,+ FieldExp,+ FieldPat,+ Name (..),+ FunDep (..),+ Pred,+ RuleBndr (..),+ TySynEqn (..),+ InjectivityAnn (..),+ Kind,+ Overlap (..),+ DerivClause (..),+ DerivStrategy (..),+ Code (..),+ ModName (..),+ addCorePlugin,+ addDependentFile,+ addForeignFile,+ addForeignFilePath,+ addForeignSource,+ addModFinalizer,+ addTempFile,+ addTopDecls,+ badIO,+ bindCode,+ bindCode_,+ cmpEq,+ compareBytes,+ counter,+ defaultFixity,+ eqBytes,+ extsEnabled,+ getDoc,+ getPackageRoot,+ getQ,+ get_cons_names,+ hoistCode,+ isExtEnabled,+ isInstance,+ joinCode,+ liftCode,+ location,+ lookupName,+ lookupTypeName,+ lookupValueName,+ manyName,+ maxPrecedence,+ memcmp,+ mkNameG,+ mkNameU,+ mkOccName,+ mkPkgName,+ mk_tup_name,+ mkName,+ mkNameG_v,+ mkNameG_d,+ mkNameG_tc,+ mkNameL,+ mkNameS,+ unTypeCode,+ mkModName,+ unsafeCodeCoerce,+ mkNameQ,+ mkNameG_fld,+ modString,+ nameBase,+ nameModule,+ namePackage,+ nameSpace,+ newDeclarationGroup,+ newNameIO,+ occString,+ oneName,+ pkgString,+ putDoc,+ putQ,+ recover,+ reify,+ reifyAnnotations,+ reifyConStrictness,+ reifyFixity,+ reifyInstances,+ reifyModule,+ reifyRoles,+ reifyType,+ report,+ reportError,+ reportWarning,+ runIO,+ sequenceQ,+ runQ,+ showName,+ showName',+ thenCmp,+ tupleDataName,+ tupleTypeName,+ unTypeQ,+ unboxedSumDataName,+ unboxedSumTypeName,+ unboxedTupleDataName,+ unboxedTupleTypeName,+ unsafeTExpCoerce,+ ForeignSrcLang (..),+ Extension (..),+ AnnLookup (..),+ AnnTarget (..),+ Arity,+ Bang (..),+ BndrVis (..),+ Body (..),+ Bytes (..),+ Callconv (..),+ CharPos,+ Cxt,+ DecidedStrictness (..),+ DocLoc (..),+ FamilyResultSig (..),+ Fixity (..),+ FixityDirection (..),+ Foreign (..),+ Guard (..),+ Info (..),+ Inline (..),+ InstanceDec,+ Lit (..),+ Loc (..),+ Module (..),+ ModuleInfo (..),+ NameFlavour (..),+ NameIs (..),+ NameSpace (..),+ NamespaceSpecifier (..),+ OccName (..),+ ParentName,+ PatSynArgs (..),+ PatSynDir (..),+ PatSynType,+ Phases (..),+ PkgName (..),+ Pragma (SpecialiseP, ..),+ Quasi (..),+ Range (..),+ Role (..),+ RuleMatch (..),+ Safety (..),+ SourceStrictness (..),+ SourceUnpackedness (..),+ Specificity (..),+ Strict,+ StrictType,+ SumAlt,+ SumArity,+ TExp (..),+ TyLit (..),+ TyVarBndr (..),+ TypeFamilyHead (..),+ Uniq,+ Unlifted,+ VarStrictType,+ makeRelativeToProject,+ liftString,+ Lift (..),+ dataToCodeQ,+ dataToExpQ,+ dataToPatQ,+ dataToQa,+ falseName,+ justName,+ leftName,+ liftData,+ liftDataTyped,+ nonemptyName,+ nothingName,+ rightName,+ trueName,+)+where++import GHC.Boot.TH.Lift+import GHC.Boot.TH.Syntax+import System.FilePath+import Data.Data hiding (Fixity(..))+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Lexeme ( startsVarSym, startsVarId )++-- This module completely re-exports 'GHC.Boot.TH.Syntax',+-- and exports additionally functions that depend on filepath.++-- |+addForeignFile :: ForeignSrcLang -> String -> Q ()+addForeignFile = addForeignSource+{-# DEPRECATED addForeignFile+ "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"+ #-} -- deprecated in 8.6++-- | The input is a filepath, which if relative is offset by the package root.+makeRelativeToProject :: FilePath -> Q FilePath+makeRelativeToProject fp | isRelative fp = do+ root <- getPackageRoot+ return (root </> fp)+makeRelativeToProject fp = return fp++trueName, falseName :: Name+trueName = 'True+falseName = 'False++nothingName, justName :: Name+nothingName = 'Nothing+justName = 'Just++leftName, rightName :: Name+leftName = 'Left+rightName = 'Right++nonemptyName :: Name+nonemptyName = '(:|)++-----------------------------------------------------+--+-- Generic Lift implementations+--+-----------------------------------------------------++-- | 'dataToQa' is an internal utility function for constructing generic+-- conversion functions from types with 'Data' instances to various+-- quasi-quoting representations. See the source of 'dataToExpQ' and+-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@+-- and @appQ@ are overloadable to account for different syntax for+-- expressions and patterns; @antiQ@ allows you to override type-specific+-- cases, a common usage is just @const Nothing@, which results in+-- no overloading.+dataToQa :: forall m a k q. (Quote m, Data a)+ => (Name -> k)+ -> (Lit -> m q)+ -> (k -> [m q] -> m q)+ -> (forall b . Data b => b -> Maybe (m q))+ -> a+ -> m q+dataToQa mkCon mkLit appCon antiQ t =+ case antiQ t of+ Nothing ->+ case constrRep constr of+ AlgConstr _ ->+ appCon (mkCon funOrConName) conArgs+ where+ funOrConName :: Name+ funOrConName =+ case showConstr constr of+ "(:)" -> Name (mkOccName ":")+ (NameG DataName+ (mkPkgName "ghc-internal")+ (mkModName "GHC.Internal.Types"))+ con@"[]" -> Name (mkOccName con)+ (NameG DataName+ (mkPkgName "ghc-internal")+ (mkModName "GHC.Internal.Types"))+ con@('(':_) -> Name (mkOccName con)+ (NameG DataName+ (mkPkgName "ghc-internal")+ (mkModName "GHC.Internal.Tuple"))++ -- Tricky case: see Note [Data for non-algebraic types]+ fun@(x:_) | startsVarSym x || startsVarId x+ -> mkNameG_v tyconPkg tyconMod fun+ con -> mkNameG_d tyconPkg tyconMod con++ where+ tycon :: TyCon+ tycon = (typeRepTyCon . typeOf) t++ tyconPkg, tyconMod :: String+ tyconPkg = tyConPackage tycon+ tyconMod = tyConModule tycon++ conArgs :: [m q]+ conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t+ IntConstr n ->+ mkLit $ IntegerL n+ FloatConstr n ->+ mkLit $ RationalL n+ CharConstr c ->+ mkLit $ CharL c+ where+ constr :: Constr+ constr = toConstr t++ Just y -> y+++{- Note [Data for non-algebraic types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Class Data was originally intended for algebraic data types. But+it is possible to use it for abstract types too. For example, in+package `text` we find++ instance Data Text where+ ...+ toConstr _ = packConstr++ packConstr :: Constr+ packConstr = mkConstr textDataType "pack" [] Prefix++Here `packConstr` isn't a real data constructor, it's an ordinary+function. Two complications++* In such a case, we must take care to build the Name using+ mkNameG_v (for values), not mkNameG_d (for data constructors).+ See #10796.++* The pseudo-constructor is named only by its string, here "pack".+ But 'dataToQa' needs the TyCon of its defining module, and has+ to assume it's defined in the same module as the TyCon itself.+ But nothing enforces that; #12596 shows what goes wrong if+ "pack" is defined in a different module than the data type "Text".+ -}++-- | A typed variant of 'dataToExpQ'.+dataToCodeQ :: (Quote m, Data a)+ => (forall b . Data b => b -> Maybe (Code m b))+ -> a -> Code m a+dataToCodeQ f = unsafeCodeCoerce . dataToExpQ (fmap unTypeCode . f)++-- | 'dataToExpQ' converts a value to a 'Exp' representation of the+-- same value, in the SYB style. It is generalized to take a function+-- override type-specific cases; see 'liftData' for a more commonly+-- used variant.+dataToExpQ :: (Quote m, Data a)+ => (forall b . Data b => b -> Maybe (m Exp))+ -> a+ -> m Exp+dataToExpQ = dataToQa varOrConE litE (foldl appE)+ where+ -- Make sure that VarE is used if the Constr value relies on a+ -- function underneath the surface (instead of a constructor).+ -- See #10796.+ varOrConE s =+ case nameSpace s of+ Just VarName -> return (VarE s)+ Just (FldName {}) -> return (VarE s)+ Just DataName -> return (ConE s)+ _ -> error $ "Can't construct an expression from name "+ ++ showName s+ appE x y = do { a <- x; b <- y; return (AppE a b)}+ litE c = return (LitE c)++-- | A typed variant of 'liftData'.+liftDataTyped :: (Quote m, Data a) => a -> Code m a+liftDataTyped = dataToCodeQ (const Nothing)++-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which+-- works for any type with a 'Data' instance.+liftData :: (Quote m, Data a) => a -> m Exp+liftData = dataToExpQ (const Nothing)++-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same+-- value, in the SYB style. It takes a function to handle type-specific cases,+-- alternatively, pass @const Nothing@ to get default behavior.+dataToPatQ :: (Quote m, Data a)+ => (forall b . Data b => b -> Maybe (m Pat))+ -> a+ -> m Pat+dataToPatQ = dataToQa id litP conP+ where litP l = return (LitP l)+ conP n ps =+ case nameSpace n of+ Just DataName -> do+ ps' <- sequence ps+ return (ConP n [] ps')+ _ -> error $ "Can't construct a pattern from name "+ ++ showName n++--------------------------------------------------------------------------------+-- Back-compat for Specialise pragmas++-- | Old-form specialise pragma @{ {\-\# SPECIALISE [INLINE] [phases] (var :: ty) #-} }@.+--+-- Subsumed by the more general 'SpecialiseEP' constructor.+pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma+pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
changelog.md view
@@ -1,5 +1,21 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.24.0.0++ * Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively.++ * Remove the `Language.Haskell.TH.Lib.Internal` module. This module has long been deprecated, and exposes compiler internals.+ Users should use `Language.Haskell.TH.Lib` instead, which exposes a more stable version of this API.++ * Remove `addrToByteArrayName` and `addrToByteArray` from `Language.Haskell.TH.Syntax`. These were part of the implementation of the `Lift ByteArray` instance and were accidentally exported because this module lacked an explicit export list. They have no usages on Hackage.++## 2.23.0.0++ * Extend `Exp` with `ForallE`, `ForallVisE`, `ConstraintedE`,+ introduce functions `forallE`, `forallVisE`, `constraintedE` (GHC Proposal #281).+ * `template-haskell` is no longer wired-in. All wired-in identifiers have been moved to `ghc-internal`.+ * `Lift` instances were added for the `template-haskell` AST.+ ## 2.22.0.0 * The kind of `Code` was changed from `forall r. (Type -> Type) -> TYPE r -> Type`
template-haskell.cabal view
@@ -3,7 +3,7 @@ -- template-haskell.cabal. name: template-haskell-version: 2.22.0.0+version: 2.24.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE@@ -49,16 +49,14 @@ Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions Language.Haskell.TH.CodeDo- Language.Haskell.TH.Lib.Internal - other-modules:- Language.Haskell.TH.Lib.Map- build-depends:- base >= 4.11 && < 4.21,- ghc-boot-th == 9.10.1,- ghc-prim,- pretty == 1.1.*+ base >= 4.11 && < 4.23,+ -- We don't directly depend on any of the modules from `ghc-internal`+ -- But we need to depend on it to work around a hadrian bug.+ -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25705+ ghc-internal == 9.1401.*,+ ghc-boot-th == 9.14.1 other-modules: System.FilePath@@ -69,7 +67,3 @@ ImplicitPrelude ghc-options: -Wall-- -- We need to set the unit ID to template-haskell (without a- -- version number) as it's magic.- ghc-options: -this-unit-id template-haskell
vendored-filepath/System/FilePath.hs view
@@ -1,9 +1,7 @@ -- Vendored from filepath v1.4.2.2 {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}-#endif {- | Module : System.FilePath Copyright : (c) Neil Mitchell 2005-2014