diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -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 diff --git a/Language/Haskell/TH/Lib/Internal.hs b/Language/Haskell/TH/Lib/Internal.hs deleted file mode 100644 --- a/Language/Haskell/TH/Lib/Internal.hs +++ /dev/null @@ -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 - ] diff --git a/Language/Haskell/TH/Lib/Map.hs b/Language/Haskell/TH/Lib/Map.hs deleted file mode 100644 --- a/Language/Haskell/TH/Lib/Map.hs +++ /dev/null @@ -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 diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -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 "<>" --- 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 "" -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 diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs --- a/Language/Haskell/TH/PprLib.hs +++ b/Language/Haskell/TH/PprLib.hs @@ -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 diff --git a/Language/Haskell/TH/Quote.hs b/Language/Haskell/TH/Quote.hs --- a/Language/Haskell/TH/Quote.hs +++ b/Language/Haskell/TH/Quote.hs @@ -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 } diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -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" --- 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" ||] ) ||]) --- 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 -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 = --- --- 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 @\@, 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: --- . -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 \. \ => \@ - | ForallVisT [TyVarBndr ()] Type -- ^ @forall \ -> \@ - | 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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` diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -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 diff --git a/vendored-filepath/System/FilePath.hs b/vendored-filepath/System/FilePath.hs --- a/vendored-filepath/System/FilePath.hs +++ b/vendored-filepath/System/FilePath.hs @@ -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