diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -26,9 +26,14 @@ ParentName, Arity, Unlifted, + -- *** Language extension lookup + Extension(..), + extsEnabled, isExtEnabled, -- *** Name lookup lookupTypeName, -- :: String -> Q (Maybe Name) lookupValueName, -- :: String -> Q (Maybe Name) + -- *** Fixity lookup + reifyFixity, -- *** Instance lookup reifyInstances, isInstance, @@ -36,6 +41,8 @@ reifyRoles, -- *** Annotation lookup reifyAnnotations, AnnLookup(..), + -- *** Constructor strictness lookup + reifyConStrictness, -- * Typed expressions TExp, unType, @@ -48,6 +55,8 @@ -- ** Deconstructing names nameBase, -- :: Name -> String nameModule, -- :: Name -> Maybe String + namePackage, -- :: Name -> Maybe String + nameSpace, -- :: Name -> Maybe NameSpace -- ** Built-in names tupleTypeName, tupleDataName, -- Int -> Name unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name @@ -59,9 +68,10 @@ -- ** Declarations Dec(..), Con(..), Clause(..), - Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..), + SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..), + Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), - FunDep(..), FamFlavour(..), TySynEqn(..), + FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), @@ -69,17 +79,19 @@ Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), + FamilyResultSig(..), Syntax.InjectivityAnn(..), -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, ClauseQ, - BodyQ, GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ, - RuleBndrQ, TySynEqnQ, + InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, + ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, + SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, + VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, -- ** Constructors lifted to 'Q' -- *** Literals intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, - charL, stringL, stringPrimL, + charL, stringL, stringPrimL, charPrimL, -- *** Patterns litP, varP, tupP, conP, uInfixP, parensP, infixP, tildeP, bangP, asP, wildP, recP, @@ -90,7 +102,7 @@ normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, global, varE, conE, litE, appE, uInfixE, parensE, staticE, + dyn, varE, conE, litE, appE, uInfixE, parensE, staticE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, @@ -105,14 +117,20 @@ bindS, letS, noBindS, parS, -- *** Types - forallT, varT, conT, appT, arrowT, equalityT, listT, tupleT, sigT, litT, - promotedT, promotedTupleT, promotedNilT, promotedConsT, + forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, + listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT, + promotedConsT, -- **** Type literals numTyLit, strTyLit, -- **** Strictness - isStrict, notStrict, strictType, varStrictType, + noSourceUnpackedness, sourceNoUnpack, sourceUnpack, + noSourceStrictness, sourceLazy, sourceStrict, + isStrict, notStrict, unpacked, + bang, bangType, varBangType, strictType, varStrictType, -- **** Class Contexts - cxt, classP, equalP, normalC, recC, infixC, forallC, + cxt, classP, equalP, + -- **** Constructors + normalC, recC, infixC, forallC, gadtC, recGadtC, -- *** Kinds varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, @@ -122,16 +140,18 @@ -- *** Top Level Declarations -- **** Data - valD, funD, tySynD, dataD, newtypeD, + valD, funD, tySynD, dataD, newtypeD, -- **** Class - classD, instanceD, sigD, standaloneDerivD, defaultSigD, + classD, instanceD, instanceWithOverlapD, Overlap(..), + sigD, standaloneDerivD, defaultSigD, + -- **** Role annotations roleAnnotD, -- **** Type Family / Data Family - familyNoKindD, familyKindD, dataInstD, - closedTypeFamilyNoKindD, closedTypeFamilyKindD, + dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, + familyNoKindD, familyKindD, closedTypeFamilyNoKindD, closedTypeFamilyKindD, newtypeInstD, tySynInstD, - typeFam, dataFam, tySynEqn, + typeFam, dataFam, tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, -- **** Foreign Function Interface (FFI) cCall, stdCall, cApi, prim, javaScript, unsafe, safe, forImpD, diff --git a/Language/Haskell/TH/LanguageExtensions.hs b/Language/Haskell/TH/LanguageExtensions.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/LanguageExtensions.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.LanguageExtensions +-- Copyright : (c) The University of Glasgow 2015 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Language extensions known to GHC +-- +----------------------------------------------------------------------------- + +module Language.Haskell.TH.LanguageExtensions + ( Extension(..) + ) where + +-- This module exists primarily to avoid inserting a massive list of language +-- extensions into the already quite large Haddocks for Language.Haskell.TH + +import GHC.LanguageExtensions.Type (Extension(..)) 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 @@ -2,12 +2,14 @@ -- TH.Lib contains lots of useful helper functions for -- generating and manipulating Template Haskell terms +{-# LANGUAGE CPP #-} + module Language.Haskell.TH.Lib where -- All of the exports from this module should -- be "public" functions. The main module TH -- re-exports them all. -import Language.Haskell.TH.Syntax hiding (Role) +import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import qualified Language.Haskell.TH.Syntax as TH import Control.Monad( liftM, liftM2 ) import Data.Word( Word8 ) @@ -16,31 +18,39 @@ -- * Type synonyms ---------------------------------------------------------- -type InfoQ = Q Info -type PatQ = Q Pat -type FieldPatQ = Q FieldPat -type ExpQ = Q Exp -type TExpQ a = Q (TExp a) -type DecQ = Q Dec -type DecsQ = Q [Dec] -type ConQ = Q Con -type TypeQ = Q Type -type TyLitQ = Q TyLit -type CxtQ = Q Cxt -type PredQ = Q Pred -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 StrictTypeQ = Q StrictType -type VarStrictTypeQ = Q VarStrictType -type FieldExpQ = Q FieldExp -type RuleBndrQ = Q RuleBndr -type TySynEqnQ = Q TySynEqn -type Role = TH.Role -- must be defined here for DsMeta to find it +type InfoQ = Q Info +type PatQ = Q Pat +type FieldPatQ = Q FieldPat +type ExpQ = Q Exp +type TExpQ a = Q (TExp a) +type DecQ = Q Dec +type DecsQ = Q [Dec] +type ConQ = Q Con +type TypeQ = Q Type +type TyLitQ = Q TyLit +type CxtQ = Q Cxt +type PredQ = Q Pred +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 +-- must be defined here for DsMeta to find it +type Role = TH.Role +type InjectivityAnn = TH.InjectivityAnn + ---------------------------------------------------------- -- * Lowercase pattern syntax functions ---------------------------------------------------------- @@ -57,6 +67,8 @@ integerL = IntegerL charL :: Char -> Lit charL = CharL +charPrimL :: Char -> Lit +charPrimL = CharPrimL stringL :: String -> Lit stringL = StringL stringPrimL :: [Word8] -> Lit @@ -199,11 +211,6 @@ dyn :: String -> ExpQ dyn s = return (VarE (mkName s)) -global :: Name -> ExpQ -{-# DEPRECATED global "Use varE instead" #-} --- Trac #8656; I have no idea why this function is duplicated -global s = return (VarE s) - varE :: Name -> ExpQ varE s = return (VarE s) @@ -300,6 +307,9 @@ staticE :: ExpQ -> ExpQ staticE = fmap StaticE +unboundVarE :: Name -> ExpQ +unboundVarE s = return (UnboundVarE s) + -- ** 'arithSeqE' Shortcuts fromE :: ExpQ -> ExpQ fromE x = do { a <- x; return (ArithSeqE (FromR a)) } @@ -335,19 +345,21 @@ tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ -dataD ctxt tc tvs cons derivs = +dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt cons1 <- sequence cons - return (DataD ctxt1 tc tvs cons1 derivs) + derivs1 <- derivs + return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ -newtypeD ctxt tc tvs con derivs = +newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt con1 <- con - return (NewtypeD ctxt1 tc tvs con1 derivs) + derivs1 <- derivs + return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ classD ctxt cls tvs fds decs = @@ -357,13 +369,18 @@ return $ ClassD ctxt1 cls tvs fds decs1 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceD ctxt ty decs = +instanceD = instanceWithOverlapD Nothing + +instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceWithOverlapD o ctxt ty decs = do ctxt1 <- ctxt decs1 <- sequence decs ty1 <- ty - return $ InstanceD ctxt1 ty1 decs1 + return $ InstanceD o ctxt1 ty1 decs1 + + sigD :: Name -> TypeQ -> DecQ sigD fun ty = liftM (SigD fun) $ ty @@ -420,27 +437,23 @@ pragLineD :: Int -> String -> DecQ pragLineD line file = return $ PragmaD $ LineP line file -familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ -familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing - -familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ -familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k) - -dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ -dataInstD ctxt tc tys cons derivs = +dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt tys1 <- sequence tys cons1 <- sequence cons - return (DataInstD ctxt1 tc tys1 cons1 derivs) + derivs1 <- derivs + return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ -newtypeInstD ctxt tc tys con derivs = +newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt tys1 <- sequence tys con1 <- con - return (NewtypeInstD ctxt1 tc tys1 con1 derivs) + derivs1 <- derivs + return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) tySynInstD :: Name -> TySynEqnQ -> DecQ tySynInstD tc eqn = @@ -448,17 +461,59 @@ eqn1 <- eqn return (TySynInstD tc eqn1) +dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ +dataFamilyD tc tvs kind + = return $ DataFamilyD tc tvs kind + +openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig + -> Maybe InjectivityAnn -> DecQ +openTypeFamilyD tc tvs res inj + = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) + +closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig + -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ +closedTypeFamilyD tc tvs result injectivity eqns = + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) + +-- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you +-- remove this check please also: +-- 1. remove deprecated functions +-- 2. remove CPP language extension from top of this module +-- 3. remove the FamFlavour data type from Syntax module +-- 4. make sure that all references to FamFlavour are gone from DsMeta, +-- Convert, TcSplice (follows from 3) +#if __GLASGOW_HASKELL__ > 800 +#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD +#endif + +{-# DEPRECATED familyNoKindD, familyKindD + "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-} +familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ +familyNoKindD flav tc tvs = + case flav of + TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) + DataFam -> return $ DataFamilyD tc tvs Nothing + +familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ +familyKindD flav tc tvs k = + case flav of + TypeFam -> + return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing) + DataFam -> return $ DataFamilyD tc tvs (Just k) + +{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD + "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-} closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ closedTypeFamilyNoKindD tc tvs eqns = - do - eqns1 <- sequence eqns - return (ClosedTypeFamilyD tc tvs Nothing eqns1) + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1) closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ closedTypeFamilyKindD tc tvs kind eqns = - do - eqns1 <- sequence eqns - return (ClosedTypeFamilyD tc tvs (Just kind) eqns1) + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing) + eqns1) roleAnnotD :: Name -> [Role] -> DecQ roleAnnotD name roles = return $ RoleAnnotD name roles @@ -486,13 +541,13 @@ cxt :: [PredQ] -> CxtQ cxt = sequence -normalC :: Name -> [StrictTypeQ] -> ConQ +normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys -recC :: Name -> [VarStrictTypeQ] -> ConQ +recC :: Name -> [VarBangTypeQ] -> ConQ recC con varstrtys = liftM (RecC con) $ sequence varstrtys -infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ +infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ infixC st1 con st2 = do st1' <- st1 st2' <- st2 return $ InfixC st1' con st2' @@ -500,7 +555,12 @@ forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ forallC ns ctxt con = liftM2 (ForallC ns) ctxt con +gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ +gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty +recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ +recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty + ------------------------------------------------------------------------------- -- * Type @@ -516,6 +576,20 @@ conT :: Name -> TypeQ conT = return . ConT +infixT :: TypeQ -> Name -> TypeQ -> TypeQ +infixT t1 n t2 = do t1' <- t1 + t2' <- t2 + return (InfixT t1' n t2') + +uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ +uInfixT t1 n t2 = do t1' <- t1 + t2' <- t2 + return (UInfixT t1' n t2') + +parensT :: TypeQ -> TypeQ +parensT t = do t' <- t + return (ParensT t') + appT :: TypeQ -> TypeQ -> TypeQ appT t1 t2 = do t1' <- t1 @@ -546,6 +620,9 @@ equalityT :: TypeQ equalityT = return EqualityT +wildCardT :: TypeQ +wildCardT = return WildCardT + {-# 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 :: Name -> [Q Type] -> Q Pred classP cla tys @@ -574,17 +651,51 @@ promotedConsT :: TypeQ promotedConsT = return PromotedConsT +noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ +noSourceUnpackedness = return NoSourceUnpackedness +sourceNoUnpack = return SourceNoUnpack +sourceUnpack = return SourceUnpack + +noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ +noSourceStrictness = return NoSourceStrictness +sourceLazy = return SourceLazy +sourceStrict = return SourceStrict + +{-# DEPRECATED isStrict + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} +{-# DEPRECATED notStrict + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} +{-# DEPRECATED unpacked + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang sourceUnpack sourceStrict'"] #-} isStrict, notStrict, unpacked :: Q Strict -isStrict = return $ IsStrict -notStrict = return $ NotStrict -unpacked = return Unpacked +isStrict = bang noSourceUnpackedness sourceStrict +notStrict = bang noSourceUnpackedness noSourceStrictness +unpacked = bang sourceUnpack sourceStrict +bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ +bang u s = do u' <- u + s' <- s + return (Bang u' s') + +bangType :: BangQ -> TypeQ -> BangTypeQ +bangType = liftM2 (,) + +varBangType :: Name -> BangTypeQ -> VarBangTypeQ +varBangType v bt = do (b, t) <- bt + return (v, b, t) + +{-# DEPRECATED strictType + "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} strictType :: Q Strict -> TypeQ -> StrictTypeQ -strictType = liftM2 (,) +strictType = bangType +{-# DEPRECATED varStrictType + "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ -varStrictType v st = do (s, t) <- st - return (v, s, t) +varStrictType = varBangType -- * Type Literals @@ -629,6 +740,24 @@ constraintK :: Kind constraintK = ConstraintT + +------------------------------------------------------------------------------- +-- * Type family result + +noSig :: FamilyResultSig +noSig = NoSig + +kindSig :: Kind -> FamilyResultSig +kindSig = KindSig + +tyVarSig :: TyVarBndr -> FamilyResultSig +tyVarSig = TyVarSig + +------------------------------------------------------------------------------- +-- * Injectivity annotation + +injectivityAnn :: Name -> [Name] -> InjectivityAnn +injectivityAnn = TH.InjectivityAnn ------------------------------------------------------------------------------- -- * Role 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 @@ -55,20 +55,18 @@ <+> (if is_unlifted then text "unlifted" else empty) <+> text "type constructor" <+> quotes (ppr name) <+> parens (text "arity" <+> int arity) - ppr (ClassOpI v ty cls fix) - = text "Class op from" <+> ppr cls <> colon <+> - vcat [ppr_sig v ty, pprFixity v fix] - ppr (DataConI v ty tc fix) - = text "Constructor from" <+> ppr tc <> colon <+> - vcat [ppr_sig v ty, pprFixity v fix] + 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 (TyVarI v ty) = text "Type variable" <+> ppr v <+> equals <+> ppr ty - ppr (VarI v ty mb_d fix) - = vcat [ppr_sig v ty, pprFixity v fix, + 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 = ppr v <+> text "::" <+> ppr ty +ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty pprFixity :: Name -> Fixity -> Doc pprFixity _ f | f == defaultFixity = empty @@ -130,8 +128,8 @@ <+> text "->" <+> ppr e pprExp i (LamCaseE ms) = parensIf (i > noPrec) $ text "\\case" $$ nest nestDepth (ppr ms) -pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es -pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es +pprExp _ (TupE es) = parens (commaSep es) +pprExp _ (UnboxedTupE es) = hashParens (commaSep es) -- Nesting in Cond is to avoid potential problems in do statments pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, @@ -148,7 +146,7 @@ where pprDecs [] = empty pprDecs [d] = ppr d - pprDecs ds = braces $ sep $ punctuate semi $ map ppr ds + pprDecs ds = braces (semiSep ds) pprExp i (CaseE e ms) = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" @@ -157,23 +155,24 @@ where pprStms [] = empty pprStms [s] = ppr s - pprStms ss = braces $ sep $ punctuate semi $ map ppr ss + pprStms ss = braces (semiSep ss) pprExp _ (CompE []) = text "<>" -- This will probably break with fixity declarations - would need a ';' pprExp _ (CompE ss) = text "[" <> ppr s <+> text "|" - <+> (sep $ punctuate comma $ map ppr ss') + <+> commaSep ss' <> text "]" where s = last ss ss' = init ss pprExp _ (ArithSeqE d) = ppr d -pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es -pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t +pprExp _ (ListE es) = brackets (commaSep es) +pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t pprExp _ (RecConE nm fs) = ppr 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 pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) @@ -185,10 +184,10 @@ ------------------------------ instance Ppr Stmt where ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e - ppr (LetS ds) = text "let" <+> ppr ds + ppr (LetS ds) = text "let" <+> (braces (semiSep ds)) ppr (NoBindS e) = ppr e ppr (ParS sss) = sep $ punctuate (text "|") - $ map (sep . punctuate comma . map ppr) sss + $ map commaSep sss ------------------------------ instance Ppr Match where @@ -224,6 +223,7 @@ (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 i (RationalL rat) = parensIf (i > noPrec) $ @@ -245,8 +245,8 @@ pprPat :: Precedence -> Pat -> Doc pprPat i (LitP l) = pprLit i l pprPat _ (VarP v) = pprName' Applied v -pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps -pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps +pprPat _ (TupP ps) = parens (commaSep ps) +pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s <+> sep (map (pprPat appPrec) ps) pprPat _ (ParensP p) = parens $ pprPat noPrec p @@ -267,8 +267,8 @@ = parens $ ppr nm <+> braces (sep $ punctuate comma $ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) -pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps -pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t +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 ------------------------------ @@ -283,34 +283,34 @@ $$ where_clause ds ppr_dec _ (TySynD t xs rhs) = ppr_tySyn empty t (hsep (map ppr xs)) rhs -ppr_dec _ (DataD ctxt t xs cs decs) - = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs -ppr_dec _ (NewtypeD ctxt t xs c decs) - = ppr_newtype empty ctxt t (sep (map ppr xs)) c decs +ppr_dec _ (DataD ctxt t xs ksig cs decs) + = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs +ppr_dec _ (NewtypeD ctxt t xs ksig c decs) + = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds -ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i +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 <+> text "::" <+> ppr t +ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec _ (ForeignD f) = ppr f ppr_dec _ (InfixD fx n) = pprFixity n fx ppr_dec _ (PragmaD p) = ppr p -ppr_dec isTop (FamilyD flav tc tvs k) - = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind +ppr_dec isTop (DataFamilyD tc tvs kind) + = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind where maybeFamily | isTop = text "family" | otherwise = empty - - maybeKind | (Just k') <- k = text "::" <+> ppr k' - | otherwise = empty -ppr_dec isTop (DataInstD ctxt tc tys cs decs) - = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs + maybeKind | (Just k') <- kind = dcolon <+> ppr k' + | otherwise = empty +ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs) + = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) - = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs +ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs) + = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs where maybeInst | isTop = text "instance" | otherwise = empty @@ -319,13 +319,15 @@ where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns) - = hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), maybeKind - , text "where" ]) +ppr_dec isTop (OpenTypeFamilyD tfhead) + = text "type" <+> maybeFamily <+> ppr_tf_head tfhead + where + maybeFamily | isTop = text "family" + | otherwise = empty +ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns) + = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where") nestDepth (vcat (map ppr_eqn eqns)) where - maybeKind | (Just k') <- mkind = text "::" <+> ppr k' - | otherwise = empty ppr_eqn (TySynEqn lhs rhs) = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs @@ -336,45 +338,79 @@ = hsep [ text "deriving instance", pprCxt cxt, ppr ty ] ppr_dec _ (DefaultSigD n ty) - = hsep [ text "default", pprPrefixOcc n, text "::", ppr ty ] + = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] -ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc -ppr_data maybeInst ctxt t argsDoc cs decs + +ppr_overlap :: Overlap -> Doc +ppr_overlap o = text $ + case o of + Overlaps -> "{-# OVERLAPS #-}" + Overlappable -> "{-# OVERLAPPABLE #-}" + Overlapping -> "{-# OVERLAPPING #-}" + Incoherent -> "{-# INCOHERENT #-}" + +ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc +ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc, + <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty else nest nestDepth - $ text "deriving" - <+> parens (hsep $ punctuate comma $ map ppr decs)] + $ text "deriving" <+> ppr_cxt_preds decs] where pref :: [Doc] -> [Doc] - pref [] = [] -- No constructors; can't happen in H98 - pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds + pref xs | isGadtDecl = xs + pref [] = [] -- No constructors; can't happen in H98 + pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc -ppr_newtype maybeInst ctxt t argsDoc c decs + 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_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc +ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc, + <+> ppr t <+> argsDoc <+> ksigDoc, nest 2 (char '=' <+> ppr c), if null decs then empty else nest nestDepth - $ text "deriving" - <+> parens (hsep $ punctuate comma $ map ppr decs)] + $ text "deriving" <+> ppr_cxt_preds decs] + where + ksigDoc = case ksig of + Nothing -> empty + Just k -> dcolon <+> ppr k ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs +ppr_tf_head :: TypeFamilyHead -> Doc +ppr_tf_head (TypeFamilyHead tc tvs res inj) + = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj + where + maybeInj | (Just inj') <- inj = ppr inj' + | otherwise = empty + ------------------------------ instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) ppr_list [] = empty - ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs)) + ppr_list xs = char '|' <+> commaSep xs ------------------------------ instance Ppr FamFlavour where @@ -382,6 +418,17 @@ ppr TypeFam = text "type" ------------------------------ +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) = + char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) + +------------------------------ instance Ppr Foreign where ppr (ImportF callconv safety impent as typ) = text "foreign import" @@ -389,13 +436,13 @@ <+> showtextl safety <+> text (show impent) <+> ppr as - <+> text "::" <+> ppr typ + <+> dcolon <+> ppr typ ppr (ExportF callconv expent as typ) = text "foreign export" <+> showtextl callconv <+> text (show expent) <+> ppr as - <+> text "::" <+> ppr typ + <+> dcolon <+> ppr typ ------------------------------ instance Ppr Pragma where @@ -410,7 +457,7 @@ = text "{-# SPECIALISE" <+> maybe empty ppr inline <+> ppr phases - <+> sep [ ppr n <+> text "::" + <+> sep [ ppr n <+> dcolon , nest 2 $ ppr ty ] <+> text "#-}" ppr (SpecialiseInstP inst) @@ -451,7 +498,7 @@ ------------------------------ instance Ppr RuleBndr where ppr (RuleVar n) = ppr n - ppr (TypedRuleVar n ty) = parens $ ppr n <+> text "::" <+> ppr ty + ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty ------------------------------ instance Ppr Clause where @@ -460,26 +507,105 @@ ------------------------------ instance Ppr Con where - ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts) + ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts) + ppr (RecC c vsts) - = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts)) - ppr (InfixC st1 c st2) = pprStrictType st1 + = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) + + ppr (InfixC st1 c st2) = pprBangType st1 <+> pprName' Infix c - <+> pprStrictType st2 - ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns) - <+> char '.' <+> sep [pprCxt ctxt, ppr con] + <+> pprBangType st2 + ppr (ForallC ns ctxt (GadtC c sts ty)) + = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + <+> pprGadtRHS sts ty + + ppr (ForallC ns ctxt (RecGadtC c vsts ty)) + = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + <+> pprRecFields vsts ty + + ppr (ForallC ns ctxt con) + = pprForall ns ctxt <+> ppr con + + ppr (GadtC c sts ty) + = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty + + ppr (RecGadtC c vsts ty) + = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty + +commaSepApplied :: [Name] -> Doc +commaSepApplied = commaSepWith (pprName' Applied) + +pprForall :: [TyVarBndr] -> Cxt -> Doc +pprForall ns ctxt + = text "forall" <+> hsep (map ppr ns) + <+> char '.' <+> pprCxt ctxt + +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 + ------------------------------ -pprVarStrictType :: (Name, Strict, Type) -> Doc +pprVarBangType :: VarBangType -> Doc -- Slight infelicity: with print non-atomic type with parens -pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t) +pprVarBangType (v, bang, t) = ppr 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 --- Prints with parens if not already atomic -pprStrictType (IsStrict, t) = char '!' <> pprParendType t -pprStrictType (NotStrict, t) = pprParendType t -pprStrictType (Unpacked, t) = text "{-# UNPACK #-} !" <> pprParendType t +pprStrictType = pprBangType ------------------------------ pprParendType :: Type -> Doc @@ -499,8 +625,19 @@ pprParendType StarT = char '*' pprParendType ConstraintT = text "Constraint" pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) +pprParendType WildCardT = char '_' +pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y) +pprParendType t@(UInfixT {}) = parens (pprUInfixT t) +pprParendType (ParensT t) = ppr t +pprParendType tuple | (TupleT n, args) <- split tuple + , length args == n + = parens (commaSep args) pprParendType other = parens (ppr other) +pprUInfixT :: Type -> Doc +pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y +pprUInfixT t = ppr t + instance Ppr Type where ppr (ForallT tvars ctxt ty) = text "forall" <+> hsep (map ppr tvars) <+> text "." @@ -517,16 +654,15 @@ type instance F Int = (Bool :: *) So we always print a SigT with parens (see Trac #10050). -} - pprTyApp :: (Type, [Type]) -> Doc pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] pprTyApp (EqualityT, [arg1, arg2]) = sep [pprFunArgType arg1 <+> text "~", ppr arg2] pprTyApp (ListT, [arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) - | length args == n = parens (sep (punctuate comma (map ppr args))) + | length args == n = parens (commaSep args) pprTyApp (PromotedTupleT n, args) - | length args == n = quoteParens (sep (punctuate comma (map ppr args))) + | length args == n = quoteParens (commaSep args) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) pprFunArgType :: Type -> Doc -- Should really use a precedence argument @@ -551,7 +687,7 @@ ------------------------------ instance Ppr TyVarBndr where ppr (PlainTV nm) = ppr nm - ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k) + ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k) instance Ppr Role where ppr NominalR = text "nominal" @@ -562,9 +698,13 @@ ------------------------------ pprCxt :: Cxt -> Doc pprCxt [] = empty -pprCxt [t] = ppr t <+> text "=>" -pprCxt ts = parens (sep $ punctuate comma $ map ppr ts) <+> text "=>" +pprCxt ts = ppr_cxt_preds ts <+> text "=>" +ppr_cxt_preds :: Cxt -> Doc +ppr_cxt_preds [] = empty +ppr_cxt_preds [t] = ppr t +ppr_cxt_preds ts = parens (commaSep ts) + ------------------------------ instance Ppr Range where ppr = brackets . pprRange @@ -601,3 +741,18 @@ , parens $ int start_ln <> comma <> int start_col , text "-" , parens $ int end_ln <> comma <> int end_col ] + +-- 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 = sep . punctuate comma . map 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 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,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP, FlexibleInstances #-} -- | Monadic front-end to Text.PrettyPrint @@ -10,7 +10,7 @@ -- * Primitive Documents empty, - semi, comma, colon, space, equals, arrow, + semi, comma, colon, dcolon, space, equals, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- * Converting values into documents @@ -21,13 +21,13 @@ parens, brackets, braces, quotes, doubleQuotes, -- * Combining documents - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, nest, hang, punctuate, - + -- * Predicates on documents isEmpty, @@ -41,6 +41,9 @@ 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 ) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative( Applicative(..) ) +#endif infixl 6 <> infixl 6 <+> @@ -60,6 +63,7 @@ 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 @@ -94,8 +98,8 @@ 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. + -- overlap it \"dovetails\" the two +($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. vcat :: [Doc] -> Doc; -- ^List version of '$$' cat :: [Doc] -> Doc; -- ^ Either hcat or vcat @@ -108,9 +112,9 @@ -- 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]@ - +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" @@ -150,11 +154,11 @@ fmap = liftM instance Applicative PprM where - pure = return + pure x = PprM $ \s -> (x, s) (<*>) = ap instance Monad PprM where - return x = PprM $ \s -> (x, s) + return = pure m >>= k = PprM $ \s -> let (x, s') = runPprM m s in runPprM (k x) s' @@ -168,6 +172,7 @@ 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 "->" @@ -222,4 +227,3 @@ where go d' [] = [d'] go d' (e:es) = (d' <> p) : go e es - 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,75 +1,44 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{- | +Module : Language.Haskell.TH.Quote +Description : Quasi-quoting support for Template Haskell + +Template Haskell supports quasiquoting, which permits users to construct +program fragments by directly writing concrete syntax. A quasiquoter is +essentially a function with takes a string to a Template Haskell AST. +This module defines the 'QuasiQuoter' datatype, which specifies a +quasiquoter @q@ which can be invoked using the syntax +@[q| ... string to parse ... |]@ when the @QuasiQuotes@ language +extension is enabled, and some utility functions for manipulating +quasiquoters. Nota bene: this package does not define any parsers, +that is up to you. +-} module Language.Haskell.TH.Quote( QuasiQuoter(..), - dataToQa, dataToExpQ, dataToPatQ, - quoteFile + quoteFile, + -- * For backwards compatibility + dataToQa, dataToExpQ, dataToPatQ ) where -import Data.Data -import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp, - quotePat :: String -> Q Pat, - quoteType :: String -> Q Type, - quoteDec :: String -> Q [Dec] } - -dataToQa :: forall a k q. Data a - => (Name -> k) - -> (Lit -> Q q) - -> (k -> [Q q] -> Q q) - -> (forall b . Data b => b -> Maybe (Q q)) - -> a - -> Q q -dataToQa mkCon mkLit appCon antiQ t = - case antiQ t of - Nothing -> - case constrRep constr of - AlgConstr _ -> - appCon (mkCon conName) conArgs - where - conName :: Name - conName = - 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")) - con -> mkNameG_d (tyConPackage tycon) - (tyConModule tycon) - con - where - tycon :: TyCon - tycon = (typeRepTyCon . typeOf) t - - conArgs :: [Q 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 - --- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same --- value. It takes a function to handle type-specific cases. -dataToExpQ :: Data a - => (forall b . Data b => b -> Maybe (Q Exp)) - -> a - -> Q Exp -dataToExpQ = dataToQa conE litE (foldl appE) - --- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same --- value. It takes a function to handle type-specific cases. -dataToPatQ :: Data a - => (forall b . Data b => b -> Maybe (Q Pat)) - -> a - -> Q Pat -dataToPatQ = dataToQa id litP conP +-- | 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 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,6 +1,17 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents, - RoleAnnotations, DeriveGeneric, FlexibleInstances #-} +{-# LANGUAGE CPP, DeriveDataTypeable, + DeriveGeneric, FlexibleInstances, DefaultSignatures, + RankNTypes, RoleAnnotations, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} + +#if MIN_VERSION_base(4,8,0) +#define HAS_NATURAL +#endif + +#if MIN_VERSION_base(4,9,0) +# define HAS_MONADFAIL 1 +#endif + ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Syntax @@ -15,9 +26,13 @@ -- ----------------------------------------------------------------------------- -module Language.Haskell.TH.Syntax where +module Language.Haskell.TH.Syntax + ( module Language.Haskell.TH.Syntax + -- * Language extensions + , module Language.Haskell.TH.LanguageExtensions + ) where -import Data.Data (Data(..), Typeable ) +import Data.Data hiding (Fixity(..)) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative( Applicative(..) ) #endif @@ -29,16 +44,29 @@ import Data.Int import Data.Word import Data.Ratio -import Numeric.Natural import GHC.Generics ( Generic ) +import GHC.Lexeme ( startsVarSym, startsVarId ) +import Language.Haskell.TH.LanguageExtensions +#ifdef HAS_NATURAL +import Numeric.Natural +#endif + +#if HAS_MONADFAIL +import qualified Control.Monad.Fail as Fail +#endif + ----------------------------------------------------- -- -- The Quasi class -- ----------------------------------------------------- -class Monad m => Quasi m where +#if HAS_MONADFAIL +class Fail.MonadFail m => Quasi m where +#else +class (Applicative m, Monad m) => Quasi m where +#endif qNewName :: String -> m Name -- ^ Fresh names @@ -53,14 +81,16 @@ qLookupName :: Bool -> String -> m (Maybe Name) -- True <=> type namespace, False <=> value namespace qReify :: Name -> m Info + qReifyFixity :: Name -> m (Maybe Fixity) 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 + qReifyRoles :: Name -> m [Role] + qReifyAnnotations :: Data a => AnnLookup -> m [a] + qReifyModule :: Module -> m ModuleInfo + qReifyConStrictness :: Name -> m [DecidedStrictness] qLocation :: m Loc @@ -77,6 +107,9 @@ qPutQ :: Typeable a => a -> m () + qIsExtEnabled :: Extension -> m Bool + qExtsEnabled :: m [Extension] + ----------------------------------------------------- -- The IO instance of Quasi -- @@ -96,19 +129,23 @@ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qAddDependentFile _ = badIO "addDependentFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddModFinalizer _ = badIO "addModFinalizer" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" + qLookupName _ _ = badIO "lookupName" + qReify _ = badIO "reify" + qReifyFixity _ = 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? + qAddDependentFile _ = badIO "addDependentFile" + qAddTopDecls _ = badIO "addTopDecls" + qAddModFinalizer _ = badIO "addModFinalizer" + qGetQ = badIO "getQ" + qPutQ _ = badIO "putQ" + qIsExtEnabled _ = badIO "isExtEnabled" + qExtsEnabled = badIO "extsEnabled" qRunIO m = m @@ -145,17 +182,27 @@ runQ (Q m) = m instance Monad Q where - return x = Q (return x) Q m >>= k = Q (m >>= \x -> unQ (k x)) - Q m >> Q n = Q (m >> n) + (>>) = (*>) + + return = pure + +#if !HAS_MONADFAIL fail s = report True s >> Q (fail "Q monad failure") +#else + fail = Fail.fail +instance Fail.MonadFail Q where + fail s = report True s >> Q (Fail.fail "Q monad failure") +#endif + 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) ----------------------------------------------------- -- @@ -332,6 +379,15 @@ 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) + {- | @reifyInstances nm tys@ returns a list of visible instances 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, @@ -360,6 +416,21 @@ 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? isInstance :: Name -> [Type] -> Q Bool isInstance nm tys = do { decs <- reifyInstances nm tys @@ -403,31 +474,43 @@ addModFinalizer :: Q () -> Q () addModFinalizer act = Q (qAddModFinalizer (unQ act)) --- | Get state from the Q monad. +-- | Get state from the 'Q' monad. getQ :: Typeable a => Q (Maybe a) getQ = Q qGetQ --- | Replace the state in the Q monad. +-- | Replace the state in the 'Q' monad. 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 + instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qLookupName = lookupName - qLocation = location - qRunIO = runIO - qAddDependentFile = addDependentFile - qAddTopDecls = addTopDecls - qAddModFinalizer = addModFinalizer - qGetQ = getQ - qPutQ = putQ + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyFixity = reifyFixity + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness = reifyConStrictness + qLookupName = lookupName + qLocation = location + qRunIO = runIO + qAddDependentFile = addDependentFile + qAddTopDecls = addTopDecls + qAddModFinalizer = addModFinalizer + qGetQ = getQ + qPutQ = putQ + qIsExtEnabled = isExtEnabled + qExtsEnabled = extsEnabled ---------------------------------------------------- @@ -450,8 +533,33 @@ -- ----------------------------------------------------- +-- | 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 (@[| ... |]@) but not +-- at the top level. As an example: +-- +-- > add1 :: Int -> Q Exp +-- > 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'. +-- +-- '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 class Lift t where + -- | Turn a value into a Template Haskell expression, suitable for use in + -- a splice. lift :: t -> Q Exp + default lift :: Data t => t -> Q Exp + lift = liftData -- If you add any instances here, consider updating test th/TH_Lift instance Lift Integer where @@ -487,8 +595,10 @@ instance Lift Word64 where lift x = return (LitE (IntegerL (fromIntegral x))) +#ifdef HAS_NATURAL instance Lift Natural where lift x = return (LitE (IntegerL (fromIntegral x))) +#endif instance Integral a => Lift (Ratio a) where lift x = return (LitE (RationalL (toRational x))) @@ -572,7 +682,124 @@ leftName = mkNameG DataName "base" "Data.Either" "Left" rightName = mkNameG DataName "base" "Data.Either" "Right" +----------------------------------------------------- +-- +-- 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 a k q. Data a + => (Name -> k) + -> (Lit -> Q q) + -> (k -> [Q q] -> Q q) + -> (forall b . Data b => b -> Maybe (Q q)) + -> a + -> Q 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")) + -- It is possible for a Data instance to be defined such + -- that toConstr uses a Constr defined using a function, + -- not a data constructor. In such a case, we must take + -- care to build the Name using mkNameG_v (for values), + -- not mkNameG_d (for data constructors). + -- See Trac #10796. + 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 :: [Q 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 + +-- | 'dataToExpQ' converts a value to a 'Q 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 :: Data a + => (forall b . Data b => b -> Maybe (Q Exp)) + -> a + -> Q 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 Trac #10796. + varOrConE s = + case nameSpace s of + Just VarName -> return (VarE s) + Just DataName -> return (ConE s) + _ -> fail $ "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 :: Data a => a -> Q Exp +liftData = dataToExpQ (const Nothing) + +-- | 'dataToPatQ' converts a value to a 'Q 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 :: Data a + => (forall b . Data b => b -> Maybe (Q Pat)) + -> a + -> Q 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') + _ -> fail $ "Can't construct a pattern from name " + ++ showName n + ----------------------------------------------------- -- Names and uniques ----------------------------------------------------- @@ -715,26 +942,78 @@ -- An original name (occurrences only, not binders) -- Need the namespace too to be sure which -- thing we are naming - deriving ( Typeable, Data, Eq, Ord, Generic ) + deriving ( Typeable, 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. - deriving( Eq, Ord, Data, Typeable, Generic ) + deriving( Eq, Ord, Show, Data, Typeable, Generic ) type Uniq = Int --- | The name without its module prefix +-- | 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 +-- | 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 @@ -815,6 +1094,9 @@ 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 @@ -941,7 +1223,6 @@ Name Type ParentName - Fixity -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate | TyConI @@ -964,7 +1245,6 @@ Name Type ParentName - Fixity {- | A \"value\" variable (as opposed to a type variable, see 'TyVarI'). @@ -980,7 +1260,6 @@ Name Type (Maybe Dec) - Fixity {- | A type variable. @@ -1049,10 +1328,9 @@ @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a + b) * c@. -In cases like this, use 'UInfixE' or 'UInfixP', which stand for -\"unresolved infix expression\" and \"unresolved infix pattern\". When -the compiler is given a splice containing a tree of @UInfixE@ -applications such as +In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for +\"unresolved infix expression/pattern/type\", respectively. When the compiler +is given a splice containing a tree of @UInfixE@ applications such as > UInfixE > (UInfixE e1 op1 e2) @@ -1062,12 +1340,12 @@ it will look up and the fixities of the relevant operators and reassociate the tree as necessary. - * trees will not be reassociated across 'ParensE' or 'ParensP', + * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT', which are of use for parsing expressions like > (a + b * c) + d * e - * 'InfixE' and 'InfixP' expressions are never reassociated. + * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated. * The 'UInfixE' constructor doesn't support sections. Sections such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer @@ -1092,9 +1370,10 @@ > [| a * b + c |] :: Q Exp > [p| a : b : c |] :: Q Pat + > [t| T + T |] :: Q Type - will never contain 'UInfixE', 'UInfixP', 'ParensE', or 'ParensP' - constructors. + will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE', + 'ParensP', or 'ParensT' constructors. -} @@ -1116,18 +1395,19 @@ | FloatPrimL Rational | DoublePrimL Rational | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# + | CharPrimL Char deriving( Show, Eq, Ord, Data, Typeable, Generic ) -- We could add Int, Float, Double etc, as we do in HsLit, -- but that could complicate the - -- suppposedly-simple TH.Syntax literal type + -- supposedly-simple TH.Syntax literal type -- | Pattern in Haskell given in @{}@ data Pat - = LitP Lit -- ^ @{ 5 or 'c' }@ + = LitP Lit -- ^ @{ 5 or \'c\' }@ | VarP Name -- ^ @{ x }@ | TupP [Pat] -- ^ @{ (p1,p2) }@ - | UnboxedTupP [Pat] -- ^ @{ (# p1,p2 #) }@ + | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@ | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@ | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ @@ -1157,7 +1437,7 @@ data Exp = VarE Name -- ^ @{ x }@ | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @ - | LitE Lit -- ^ @{ 5 or 'c'}@ + | LitE Lit -- ^ @{ 5 or \'c\'}@ | AppE Exp Exp -- ^ @{ f x }@ | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@ @@ -1174,10 +1454,10 @@ | ParensE Exp -- ^ @{ (e) }@ -- -- See "Language.Haskell.TH.Syntax#infix" - | LamE [Pat] Exp -- ^ @{ \ p1 p2 -> e }@ - | LamCaseE [Match] -- ^ @{ \case m1; m2 }@ + | LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@ + | LamCaseE [Match] -- ^ @{ \\case m1; m2 }@ | TupE [Exp] -- ^ @{ (e1,e2) } @ - | UnboxedTupE [Exp] -- ^ @{ (# e1,e2 #) } @ + | UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @ | 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 }@ @@ -1200,6 +1480,7 @@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ | StaticE Exp -- ^ @{ static e }@ + | UnboundVarE Name -- ^ @{ _x }@ (hole) deriving( Show, Eq, Ord, Data, Typeable, Generic ) type FieldExp = (Name,Exp) @@ -1233,16 +1514,20 @@ = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ | DataD Cxt Name [TyVarBndr] - [Con] [Name] -- ^ @{ data Cxt x => T x = A x | B (T x) + (Maybe Kind) -- Kind signature (allowed only for GADTs) + [Con] Cxt + -- ^ @{ data Cxt x => T x = A x | B (T x) -- deriving (Z,W)}@ | NewtypeD Cxt Name [TyVarBndr] - Con [Name] -- ^ @{ newtype Cxt x => T x = A (B x) - -- deriving (Z,W)}@ + (Maybe Kind) -- Kind signature + Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x) + -- deriving (Z,W Q)}@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ - | InstanceD Cxt Type [Dec] -- ^ @{ instance Show w => Show [w] - -- where ds }@ + | InstanceD (Maybe Overlap) Cxt Type [Dec] + -- ^ @{ instance {\-\# OVERLAPS \#-\} + -- Show w => Show [w] where ds }@ | SigD Name Type -- ^ @{ length :: [a] -> Int }@ | ForeignD Foreign -- ^ @{ foreign import ... } --{ foreign export ... }@ @@ -1250,30 +1535,54 @@ | InfixD Fixity Name -- ^ @{ infix 3 foo }@ -- | pragmas - | PragmaD Pragma -- ^ @{ {\-# INLINE [1] foo #-\} }@ + | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@ - -- | type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') - | FamilyD FamFlavour Name - [TyVarBndr] (Maybe Kind) -- ^ @{ type family T a b c :: * }@ + -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD') + | DataFamilyD Name [TyVarBndr] + (Maybe Kind) + -- ^ @{ data family T a b c :: * }@ | DataInstD Cxt Name [Type] - [Con] [Name] -- ^ @{ data instance Cxt x => T [x] = A x - -- | B (T x) - -- deriving (Z,W)}@ + (Maybe Kind) -- Kind signature + [Con] Cxt -- ^ @{ data instance Cxt x => T [x] + -- = A x | B (T x) deriving (Z,W)}@ + | NewtypeInstD Cxt Name [Type] - Con [Name] -- ^ @{ newtype instance Cxt x => T [x] = A (B x) - -- deriving (Z,W)}@ + (Maybe Kind) -- Kind signature + Con Cxt -- ^ @{ newtype instance Cxt x => T [x] + -- = A (B x) deriving (Z,W)}@ | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ - | ClosedTypeFamilyD Name - [TyVarBndr] (Maybe Kind) - [TySynEqn] -- ^ @{ type family F a b :: * where ... }@ + -- | 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 Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@ | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ deriving( Show, Eq, Ord, Data, Typeable, 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 'Overlappable' and 'Overlappable', and + -- pick an arbitrary one if multiple choices are + -- available. + deriving( Show, Eq, Ord, Data, Typeable, Generic ) + +-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. +-- By analogy with 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] FamilyResultSig (Maybe InjectivityAnn) + deriving( Show, Eq, Ord, Data, Typeable, Generic ) + -- | One equation of a type family instance or closed type family. The -- arguments are the left-hand-side type patterns and the right-hand-side -- result. @@ -1335,28 +1644,99 @@ -- be tuples of other constraints. type Pred = Type -data Strict = IsStrict | NotStrict | Unpacked - deriving( Show, Eq, Ord, Data, Typeable, Generic ) +data SourceUnpackedness + = NoSourceUnpackedness -- ^ @C a@ + | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ + | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ + deriving (Show, Eq, Ord, Data, Typeable, Generic) -data Con = NormalC Name [StrictType] -- ^ @C Int a@ - | RecC Name [VarStrictType] -- ^ @C { v :: Int, w :: a }@ - | InfixC StrictType Name StrictType -- ^ @Int :+ a@ - | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) +data SourceStrictness = NoSourceStrictness -- ^ @C a@ + | SourceLazy -- ^ @C {~}a@ + | SourceStrict -- ^ @C {!}a@ + deriving (Show, Eq, Ord, Data, Typeable, Generic) -type StrictType = (Strict, Type) -type VarStrictType = (Name, Strict, Type) +-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' +-- refers to the strictness that the compiler chooses for a data constructor +-- field, which may be different from what is written in source code. See +-- 'reifyConStrictness' for more information. +data DecidedStrictness = DecidedLazy + | DecidedStrict + | DecidedUnpack + deriving (Show, Eq, Ord, Data, Typeable, Generic) +data Con = NormalC Name [BangType] -- ^ @C Int a@ + | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ + | InfixC BangType Name BangType -- ^ @Int :+ a@ + | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ + | GadtC [Name] [BangType] + Type -- See Note [GADT return type] + -- ^ @C :: a -> b -> T b Int@ + | RecGadtC [Name] [VarBangType] + Type -- See Note [GADT return type] + -- ^ @C :: { v :: Int } -> T b Int@ + deriving (Show, Eq, Ord, Data, Typeable, 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, Typeable, 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 + data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ -> \@ | AppT Type Type -- ^ @T a b@ | 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" + | ParensT Type -- ^ @(T)@ -- See Note [Representing concrete syntax in types] | TupleT Int -- ^ @(,), (,,), etc.@ - | UnboxedTupleT Int -- ^ @(#,#), (#,,#), etc.@ + | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ | ArrowT -- ^ @->@ | EqualityT -- ^ @~@ | ListT -- ^ @[]@ @@ -1366,11 +1746,22 @@ | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ + | WildCardT -- ^ @_, deriving( Show, Eq, Ord, Data, Typeable, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@ deriving( Show, Eq, Ord, Data, Typeable, Generic ) + +-- | Type family result signature +data FamilyResultSig = NoSig -- ^ no signature + | KindSig Kind -- ^ @k@ + | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@ + deriving( Show, Eq, Ord, Data, Typeable, Generic ) + +-- | Injectivity annotation +data InjectivityAnn = InjectivityAnn Name [Name] + deriving ( Show, Eq, Ord, Data, Typeable, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @"Hello"@ diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,55 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.11.0.0 *TBA* + + * Bundled with GHC 8.0.1 + + * The compiler can now resolve infix operator fixities in types on its own. + The `UInfixT` constructor of `Type` is analoguous to `UInfixE` for expressions + and can contain a tree of infix type applications which will be reassociated + according to the fixities of the operators. The `ParensT` constructor can be + used to explicitly group expressions. + + * Add `namePackage` and `nameSpace` + + * Make `dataToQa` and `dataToExpQ` able to handle `Data` instances whose + `toConstr` implementation relies on a function instead of a data + constructor (#10796) + + * Add `Show` instances for `NameFlavour` and `NameSpace` + + * Remove `FamilyD` and `FamFlavour`. Add `DataFamilyD` and `OpenTypeFamilyD` + as the representation of data families and open type families + respectively. (#6018) + + * Add `TypeFamilyHead` for common elements of `OpenTypeFamilyD` and + `ClosedTypeFamilyD` (#10902) + + * The `Strict` datatype was split among different datatypes: three for + writing the strictness information of data constructors' fields as denoted + in Haskell source code (`SourceUnpackedness` and `SourceStrictness`, as + well as `Bang`), and one for strictness information after a constructor is + compiled (`DecidedStrictness`). `Strict`, `StrictType` and `VarStrictType` + have been deprecated in favor of `Bang`, `BangType` and `VarBangType`, and + three functions (`isStrict`, `isLazy`, and `unpack`) were removed because + they no longer serve any use in this new design. (#10697) + + * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness` + values for its fields (#10697) + + * The `ClassOpI`, `DataConI`, and `VarI` constructors no longer have a + `Fixity` field. Instead, all `Fixity` information for a given `Name` is + now determined through the `reifyFixity` function, which returns `Just` the + fixity if there is an explicit fixity declaration for that `Name`, and + `Nothing` otherwise (#10704 and #11345) + + * Add `MonadFail Q` instance for GHC 8.0 and later (#11661) + + * TODO: document API changes and important bugfixes + + * Add support for OVERLAP(S/PED/PING) pragmas on instances + + ## 2.10.0.0 *Mar 2015* * Bundled with GHC 7.10.1 diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -1,5 +1,5 @@ name: template-haskell -version: 2.10.0.0 +version: 2.11.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -26,15 +26,15 @@ Library default-language: Haskell2010 other-extensions: + BangPatterns + CPP + DefaultSignatures DeriveDataTypeable + DeriveGeneric FlexibleInstances - MagicHash - PolymorphicComponents RankNTypes RoleAnnotations ScopedTypeVariables - TemplateHaskell - UnboxedTuples exposed-modules: Language.Haskell.TH @@ -43,14 +43,24 @@ Language.Haskell.TH.PprLib Language.Haskell.TH.Quote Language.Haskell.TH.Syntax + Language.Haskell.TH.LanguageExtensions other-modules: Language.Haskell.TH.Lib.Map build-depends: - base == 4.8.*, - pretty == 1.1.* + base >= 4.7 && < 4.10, + ghc-boot-th == 8.0.*, + pretty == 1.1.* - -- We need to set the package key to template-haskell (without a + -- We need to set the unit ID to template-haskell (without a -- version number) as it's magic. - ghc-options: -Wall -this-package-key template-haskell + ghc-options: -Wall + + if impl( ghc >= 7.11 ) + ghc-options: -this-unit-id template-haskell + else + if impl( ghc >= 7.9 ) + ghc-options: -this-package-key template-haskell + else + ghc-options: -package-name template-haskell