template-haskell 2.9.0.0 → 2.10.0.0
raw patch · 9 files changed
+567/−382 lines, 9 filesdep −containersdep ~base
Dependencies removed: containers
Dependency ranges changed: base
Files
- Language/Haskell/TH.hs +65/−64
- Language/Haskell/TH/Lib.hs +57/−17
- Language/Haskell/TH/Lib/Map.hs +108/−0
- Language/Haskell/TH/Ppr.hs +69/−38
- Language/Haskell/TH/PprLib.hs +37/−39
- Language/Haskell/TH/Quote.hs +1/−1
- Language/Haskell/TH/Syntax.hs +196/−211
- changelog.md +22/−0
- template-haskell.cabal +12/−12
Language/Haskell/TH.hs view
@@ -5,52 +5,52 @@ -} module Language.Haskell.TH(- -- * The monad and its operations- Q,- runQ,+ -- * The monad and its operations+ Q,+ runQ, -- ** Administration: errors, locations and IO- reportError, -- :: String -> Q ()- reportWarning, -- :: String -> Q ()- report, -- :: Bool -> String -> Q ()- recover, -- :: Q a -> Q a -> Q a- location, -- :: Q Loc- Loc(..),- runIO, -- :: IO a -> Q a- -- ** Querying the compiler- -- *** Reify- reify, -- :: Name -> Q Info- reifyModule,- thisModule,- Info(..), ModuleInfo(..),- InstanceDec,- ParentName,- Arity,- Unlifted,- -- *** Name lookup- lookupTypeName, -- :: String -> Q (Maybe Name)- lookupValueName, -- :: String -> Q (Maybe Name)- -- *** Instance lookup- reifyInstances,- isInstance,+ reportError, -- :: String -> Q ()+ reportWarning, -- :: String -> Q ()+ report, -- :: Bool -> String -> Q ()+ recover, -- :: Q a -> Q a -> Q a+ location, -- :: Q Loc+ Loc(..),+ runIO, -- :: IO a -> Q a+ -- ** Querying the compiler+ -- *** Reify+ reify, -- :: Name -> Q Info+ reifyModule,+ thisModule,+ Info(..), ModuleInfo(..),+ InstanceDec,+ ParentName,+ Arity,+ Unlifted,+ -- *** Name lookup+ lookupTypeName, -- :: String -> Q (Maybe Name)+ lookupValueName, -- :: String -> Q (Maybe Name)+ -- *** Instance lookup+ reifyInstances,+ isInstance, -- *** Roles lookup reifyRoles, -- *** Annotation lookup reifyAnnotations, AnnLookup(..), - -- * Typed expressions- TExp, unType,+ -- * Typed expressions+ TExp, unType, - -- * Names- Name, NameSpace, -- Abstract- -- ** Constructing names- mkName, -- :: String -> Name- newName, -- :: String -> Q Name- -- ** Deconstructing names- nameBase, -- :: Name -> String- nameModule, -- :: Name -> Maybe String- -- ** Built-in names- tupleTypeName, tupleDataName, -- Int -> Name- unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name+ -- * Names+ Name, NameSpace, -- Abstract+ -- ** Constructing names+ mkName, -- :: String -> Name+ newName, -- :: String -> Q Name+ -- ** Deconstructing names+ nameBase, -- :: Name -> String+ nameModule, -- :: Name -> Maybe String+ -- ** Built-in names+ tupleTypeName, tupleDataName, -- Int -> Name+ unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name -- * The algebraic data types -- | The lowercase versions (/syntax operators/) of these constructors are@@ -58,17 +58,17 @@ -- quotations (@[| |]@) and splices (@$( ... )@) -- ** Declarations- Dec(..), Con(..), Clause(..), - Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),- Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),- FunDep(..), FamFlavour(..), TySynEqn(..),- Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,+ Dec(..), Con(..), Clause(..),+ Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),+ Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),+ FunDep(..), FamFlavour(..), TySynEqn(..),+ Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), -- ** Patterns Pat(..), FieldExp, FieldPat, -- ** Types- Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred(..), Syntax.Role(..),+ Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), -- * Library functions -- ** Abbreviations@@ -78,22 +78,22 @@ -- ** Constructors lifted to 'Q' -- *** Literals- intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,- charL, stringL, stringPrimL,+ intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,+ charL, stringL, stringPrimL, -- *** Patterns- litP, varP, tupP, conP, uInfixP, parensP, infixP,- tildeP, bangP, asP, wildP, recP,- listP, sigP, viewP,- fieldPat,+ litP, varP, tupP, conP, uInfixP, parensP, infixP,+ tildeP, bangP, asP, wildP, recP,+ listP, sigP, viewP,+ fieldPat, -- *** Pattern Guards- normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,+ normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions- dyn, global, varE, conE, litE, appE, uInfixE, parensE,- infixE, infixApp, sectionL, sectionR,- lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE,- listE, sigE, recConE, recUpdE, stringE, fieldExp,+ dyn, global, 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, -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, @@ -105,26 +105,26 @@ bindS, letS, noBindS, parS, -- *** Types- forallT, varT, conT, appT, arrowT, listT, tupleT, sigT, litT,+ forallT, varT, conT, appT, arrowT, equalityT, listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT, promotedConsT, -- **** Type literals numTyLit, strTyLit, -- **** Strictness- isStrict, notStrict, strictType, varStrictType,+ isStrict, notStrict, strictType, varStrictType, -- **** Class Contexts cxt, classP, equalP, normalC, recC, infixC, forallC, -- *** Kinds- varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,+ varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, -- *** Roles nominalR, representationalR, phantomR, inferR, -- *** Top Level Declarations -- **** Data- valD, funD, tySynD, dataD, newtypeD,+ valD, funD, tySynD, dataD, newtypeD, -- **** Class- classD, instanceD, sigD,+ classD, instanceD, sigD, standaloneDerivD, defaultSigD, -- **** Role annotations roleAnnotD, -- **** Type Family / Data Family@@ -133,12 +133,14 @@ newtypeInstD, tySynInstD, typeFam, dataFam, tySynEqn, -- **** Foreign Function Interface (FFI)- cCall, stdCall, unsafe, safe, forImpD,+ cCall, stdCall, cApi, prim, javaScript,+ unsafe, safe, forImpD, -- **** Pragmas ruleVar, typedRuleVar, pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,+ pragLineD, - -- * Pretty-printer+ -- * Pretty-printer Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType ) where@@ -146,4 +148,3 @@ import Language.Haskell.TH.Syntax as Syntax import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr-
Language/Haskell/TH/Lib.hs view
@@ -171,7 +171,7 @@ patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) patGE ss e = do { ss' <- sequence ss;- e' <- e;+ e' <- e; return (PatG ss', e') } -------------------------------------------------------------------------------@@ -296,6 +296,10 @@ fieldExp :: Name -> ExpQ -> Q (Name, Exp) fieldExp s e = do { e' <- e; return (s,e') } +-- | @staticE x = [| static x |]@+staticE :: ExpQ -> ExpQ+staticE = fmap StaticE+ -- ** 'arithSeqE' Shortcuts fromE :: ExpQ -> ExpQ fromE x = do { a <- x; return (ArithSeqE (FromR a)) }@@ -413,6 +417,9 @@ exp1 <- expr return $ PragmaD $ AnnP target exp1 +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 @@ -456,6 +463,19 @@ roleAnnotD :: Name -> [Role] -> DecQ roleAnnotD name roles = return $ RoleAnnotD name roles +standaloneDerivD :: CxtQ -> TypeQ -> DecQ+standaloneDerivD ctxtq tyq =+ do+ ctxt <- ctxtq+ ty <- tyq+ return $ StandaloneDerivD ctxt ty++defaultSigD :: Name -> TypeQ -> DecQ+defaultSigD n tyq =+ do+ ty <- tyq+ return $ DefaultSigD n ty+ tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ tySynEqn lhs rhs = do@@ -466,19 +486,6 @@ cxt :: [PredQ] -> CxtQ cxt = sequence -classP :: Name -> [TypeQ] -> PredQ-classP cla tys- = do- tys1 <- sequence tys- return (ClassP cla tys1)--equalP :: TypeQ -> TypeQ -> PredQ-equalP tleft tright- = do- tleft1 <- tleft- tright1 <- tright- return (EqualP tleft1 tright1)- normalC :: Name -> [StrictTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys @@ -536,6 +543,25 @@ t' <- t return $ SigT t' k +equalityT :: TypeQ+equalityT = return EqualityT++{-# 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+ = do+ tysl <- sequence tys+ return (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 :: TypeQ -> TypeQ -> PredQ+equalP tleft tright+ = do+ tleft1 <- tleft+ tright1 <- tright+ eqT <- equalityT+ return (foldl AppT eqT [tleft1, tright1])+ promotedT :: Name -> TypeQ promotedT = return . PromotedT @@ -616,9 +642,12 @@ ------------------------------------------------------------------------------- -- * Callconv -cCall, stdCall :: Callconv-cCall = CCall-stdCall = StdCall+cCall, stdCall, cApi, prim, javaScript :: Callconv+cCall = CCall+stdCall = StdCall+cApi = CApi+prim = Prim+javaScript = JavaScript ------------------------------------------------------------------------------- -- * Safety@@ -648,6 +677,17 @@ typedRuleVar :: Name -> TypeQ -> RuleBndrQ typedRuleVar n ty = ty >>= return . TypedRuleVar n++-------------------------------------------------------------------------------+-- * AnnTarget+valueAnnotation :: Name -> AnnTarget+valueAnnotation = ValueAnnotation++typeAnnotation :: Name -> AnnTarget+typeAnnotation = TypeAnnotation++moduleAnnotation :: AnnTarget+moduleAnnotation = ModuleAnnotation -------------------------------------------------------------- -- * Useful helper function
+ Language/Haskell/TH/Lib/Map.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BangPatterns #-}++-- 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++data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)+ | Tip++type Size = Int++empty :: Map k a+empty = Tip+{-# INLINE empty #-}++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip+{-# INLINE singleton #-}++size :: Map k a -> Int+size Tip = 0+size (Bin sz _ _ _ _) = sz+{-# INLINE size #-}++lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+ where+ go _ Tip = Nothing+ go !k (Bin _ kx x l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> Just x+{-# INLINABLE lookup #-}+++insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+ where+ go :: Ord k => k -> a -> Map k a -> Map k a+ go !kx x Tip = singleton kx x+ go !kx x (Bin sz ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go kx x l) r+ GT -> balanceR ky y l (go kx x r)+ EQ -> Bin sz kx x l r+{-# INLINABLE insert #-}++balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case r of+ Tip -> case l of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+ (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++ (Bin rs _ _ _ _) -> case l of+ Tip -> Bin (1+rs) k x Tip r++ (Bin ls lk lx ll lr)+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+ (_, _) -> error "Failure in Data.Map.balanceL"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceL #-}++balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls _ _ _ _) -> case r of+ Tip -> Bin (1+ls) k x l Tip++ (Bin rs rk rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balanceR"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceR #-}++delta,ratio :: Int+delta = 3+ratio = 2
Language/Haskell/TH/Ppr.hs view
@@ -50,21 +50,21 @@ 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) + 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 fix) + <+> (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) + ppr (DataConI v ty tc fix) = text "Constructor from" <+> ppr tc <> colon <+> vcat [ppr_sig v ty, pprFixity v fix] 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 fix)+ = vcat [ppr_sig v ty, pprFixity v fix, case mb_d of { Nothing -> empty; Just d -> ppr d }] ppr_sig :: Name -> Type -> Doc@@ -95,9 +95,9 @@ isSymOcc :: Name -> Bool isSymOcc n- = case nameBase n of + = case nameBase n of [] -> True -- Empty name; weird- (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c) + (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c) -- c.f. OccName.startsVarSym in GHC itself isSymbolASCII :: Char -> Bool@@ -158,7 +158,7 @@ pprStms [] = empty pprStms [s] = ppr s pprStms ss = braces $ sep $ punctuate semi $ map ppr ss- + pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' pprExp _ (CompE ss) = text "[" <> ppr s@@ -172,6 +172,8 @@ pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> 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 pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)@@ -197,7 +199,7 @@ pprGuarded :: Doc -> (Guard, Exp) -> Doc pprGuarded eqDoc (guard, expr) = case guard of NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr- PatG stmts -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$ + PatG stmts -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$ nest nestDepth (eqDoc <+> ppr expr) ------------------------------@@ -209,6 +211,9 @@ | otherwise = arrow ------------------------------+instance Ppr Lit where+ ppr = pprLit noPrec+ pprLit :: Precedence -> Lit -> Doc pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0) (integer x <> char '#')@@ -222,14 +227,14 @@ pprLit _ (StringL s) = pprString s pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' pprLit i (RationalL rat) = parensIf (i > noPrec) $- integer (numerator rat) <+> char '/' + integer (numerator rat) <+> char '/' <+> integer (denominator rat) bytesToString :: [Word8] -> String bytesToString = map (chr . fromIntegral) pprString :: String -> Doc--- Print newlines as newlines with Haskell string escape notation, +-- 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)) @@ -271,18 +276,18 @@ ppr = ppr_dec True ppr_dec :: Bool -- declaration on the toplevel?- -> Dec + -> Dec -> Doc ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds-ppr_dec _ (TySynD t xs rhs) +ppr_dec _ (TySynD t xs rhs) = ppr_tySyn empty t (hsep (map ppr xs)) rhs-ppr_dec _ (DataD ctxt t xs cs decs) +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 _ (ClassD ctxt c xs fds ds) +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@@ -291,7 +296,7 @@ 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_dec isTop (FamilyD flav tc tvs k) = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind where maybeFamily | isTop = text "family"@@ -299,12 +304,12 @@ maybeKind | (Just k') <- k = text "::" <+> ppr k' | otherwise = empty-ppr_dec isTop (DataInstD ctxt tc tys cs decs) +ppr_dec isTop (DataInstD ctxt tc tys cs decs) = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs where maybeInst | isTop = text "instance" | otherwise = empty-ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) +ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs where maybeInst | isTop = text "instance"@@ -327,18 +332,24 @@ ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) +ppr_dec _ (StandaloneDerivD cxt ty)+ = hsep [ text "deriving instance", pprCxt cxt, ppr ty ]++ppr_dec _ (DefaultSigD n ty)+ = hsep [ text "default", pprPrefixOcc n, text "::", ppr ty ]+ ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc ppr_data maybeInst ctxt t argsDoc cs decs = sep [text "data" <+> maybeInst- <+> pprCxt ctxt- <+> ppr t <+> argsDoc,+ <+> pprCxt ctxt+ <+> ppr t <+> argsDoc, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty else nest nestDepth $ text "deriving" <+> parens (hsep $ punctuate comma $ map ppr decs)]- where + where pref :: [Doc] -> [Doc] pref [] = [] -- No constructors; can't happen in H98 pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds@@ -346,14 +357,14 @@ ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc ppr_newtype maybeInst ctxt t argsDoc c decs = sep [text "newtype" <+> maybeInst- <+> pprCxt ctxt- <+> ppr t <+> argsDoc,+ <+> pprCxt ctxt+ <+> ppr t <+> argsDoc, nest 2 (char '=' <+> ppr c), if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)]+ then empty+ else nest nestDepth+ $ text "deriving"+ <+> parens (hsep $ punctuate comma $ map ppr decs)] ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs@@ -417,6 +428,8 @@ where target1 ModuleAnnotation = text "module" target1 (TypeAnnotation t) = text "type" <+> ppr t target1 (ValueAnnotation v) = ppr v+ ppr (LineP line file)+ = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}" ------------------------------ instance Ppr Inline where@@ -485,17 +498,30 @@ pprParendType PromotedConsT = text "(':)" pprParendType StarT = char '*' pprParendType ConstraintT = text "Constraint"+pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) pprParendType other = parens (ppr other) instance Ppr Type where ppr (ForallT tvars ctxt ty) = text "forall" <+> hsep (map ppr tvars) <+> text "." <+> sep [pprCxt ctxt, ppr ty]- ppr (SigT ty k) = ppr ty <+> text "::" <+> ppr k- ppr ty = pprTyApp (split ty)+ ppr ty = pprTyApp (split ty)+ -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)+ -- See Note [Pretty-printing kind signatures] +{- 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 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)))@@ -503,7 +529,7 @@ | length args == n = quoteParens (sep (punctuate comma (map ppr args))) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) -pprFunArgType :: Type -> Doc -- Should really use a precedence argument+pprFunArgType :: Type -> Doc -- Should really use a precedence argument -- Everything except forall and (->) binds more tightly than (->) pprFunArgType ty@(ForallT {}) = parens (ppr ty) pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)@@ -540,11 +566,6 @@ pprCxt ts = parens (sep $ punctuate comma $ map ppr ts) <+> text "=>" -------------------------------instance Ppr Pred where- ppr (ClassP cla tys) = ppr cla <+> sep (map pprParendType tys)- ppr (EqualP ty1 ty2) = pprFunArgType ty1 <+> char '~' <+> pprFunArgType ty2-------------------------------- instance Ppr Range where ppr = brackets . pprRange where pprRange :: Range -> Doc@@ -570,3 +591,13 @@ 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 ]
Language/Haskell/TH/PprLib.hs view
@@ -1,35 +1,35 @@-{-# LANGUAGE FlexibleInstances, MagicHash #-}+{-# LANGUAGE FlexibleInstances #-} -- | Monadic front-end to Text.PrettyPrint module Language.Haskell.TH.PprLib ( - -- * The document type+ -- * The document type Doc, -- Abstract, instance of Show PprM, - -- * Primitive Documents+ -- * Primitive Documents empty, semi, comma, colon, space, equals, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, - -- * Converting values into documents+ -- * Converting values into documents text, char, ptext, int, integer, float, double, rational, - -- * Wrapping documents in delimiters+ -- * Wrapping documents in delimiters parens, brackets, braces, quotes, doubleQuotes, - -- * Combining documents+ -- * Combining documents (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, fsep, fcat, - nest,+ nest, hang, punctuate, - -- * Predicates on documents- isEmpty,+ -- * Predicates on documents+ isEmpty, to_HPJ_Doc, pprName, pprName' ) where@@ -38,11 +38,9 @@ import Language.Haskell.TH.Syntax (Name(..), showName', NameFlavour(..), NameIs(..)) import qualified Text.PrettyPrint as HPJ-import Control.Applicative (Applicative(..)) import Control.Monad (liftM, liftM2, ap)-import Data.Map ( Map )-import qualified Data.Map as Map ( lookup, insert, empty )-import GHC.Base (Int(..))+import Language.Haskell.TH.Lib.Map ( Map )+import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) infixl 6 <> infixl 6 <+>@@ -58,23 +56,23 @@ 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-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+empty :: Doc; -- ^ An empty document+semi :: Doc; -- ^ A ';' character+comma :: Doc; -- ^ A ',' character+colon :: Doc; -- ^ A ':' character+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+text :: String -> Doc+ptext :: String -> Doc+char :: Char -> Doc int :: Int -> Doc integer :: Integer -> Doc float :: Float -> Doc@@ -82,11 +80,11 @@ 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 @\"...\"@+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 @@ -97,7 +95,7 @@ ($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no -- overlap it \"dovetails\" the two-($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing.+($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. vcat :: [Doc] -> Doc; -- ^List version of '$$' cat :: [Doc] -> Doc; -- ^ Either hcat or vcat@@ -110,7 +108,7 @@ -- GHC-specific ones. -hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@+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]@ @@ -125,10 +123,10 @@ pprName' :: NameIs -> Name -> Doc pprName' ni n@(Name o (NameU _))- = PprM $ \s@(fm, i@(I# i'))+ = PprM $ \s@(fm, i) -> let (n', s') = case Map.lookup n fm of Just d -> (d, s)- Nothing -> let n'' = Name o (NameU i')+ 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@@ -142,7 +140,7 @@ data Name = Name OccName NameFlavour data NameFlavour- | NameU Int# -- A unique local name+ | NameU Int# -- A unique local name -} to_HPJ_Doc :: Doc -> HPJ.Doc
Language/Haskell/TH/Quote.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} module Language.Haskell.TH.Quote(- QuasiQuoter(..),+ QuasiQuoter(..), dataToQa, dataToExpQ, dataToPatQ, quoteFile ) where
Language/Haskell/TH/Syntax.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-}+{-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents,+ RoleAnnotations, DeriveGeneric, FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -16,35 +17,39 @@ module Language.Haskell.TH.Syntax where -import GHC.Exts-import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)-import qualified Data.Data as Data+import Data.Data (Data(..), Typeable )+#if __GLASGOW_HASKELL__ < 709 import Control.Applicative( Applicative(..) )+#endif import Data.IORef-import System.IO.Unsafe ( unsafePerformIO )+import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad (liftM)-import System.IO ( hPutStrLn, stderr )+import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper )-import Data.Word ( Word8 )+import Data.Int+import Data.Word+import Data.Ratio+import Numeric.Natural+import GHC.Generics ( Generic ) ----------------------------------------------------- ----- The Quasi class+-- The Quasi class -- ----------------------------------------------------- -class (Monad m, Applicative m) => Quasi m where+class Monad m => Quasi m where qNewName :: String -> m Name- -- ^ Fresh names+ -- ^ Fresh names - -- Error reporting and recovery- qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False)- -- ...but carry on; use 'fail' to stop+ -- 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'+ -> m a -- ^ Recover from the monadic 'fail' - -- Inspect the type-checker's environment+ -- Inspect the type-checker's environment qLookupName :: Bool -> String -> m (Maybe Name) -- True <=> type namespace, False <=> value namespace qReify :: Name -> m Info@@ -73,7 +78,7 @@ qPutQ :: Typeable a => a -> m () -------------------------------------------------------- The IO instance of Quasi+-- The IO instance of Quasi -- -- This instance is used only when running a Q -- computation in the IO monad, usually just to@@ -97,8 +102,8 @@ qReifyRoles _ = badIO "reifyRoles" qReifyAnnotations _ = badIO "reifyAnnotations" qReifyModule _ = badIO "reifyModule"- qLocation = badIO "currentLocation"- qRecover _ _ = badIO "recover" -- Maybe we could fix this?+ qLocation = badIO "currentLocation"+ qRecover _ _ = badIO "recover" -- Maybe we could fix this? qAddDependentFile _ = badIO "addDependentFile" qAddTopDecls _ = badIO "addTopDecls" qAddModFinalizer _ = badIO "addModFinalizer"@@ -108,8 +113,8 @@ qRunIO m = m badIO :: String -> IO a-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")- ; fail "Template Haskell failure" }+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 Int@@ -119,7 +124,7 @@ ----------------------------------------------------- ----- The Q monad+-- The Q monad -- ----------------------------------------------------- @@ -154,7 +159,7 @@ ----------------------------------------------------- ----- The TExp type+-- The TExp type -- ----------------------------------------------------- @@ -369,15 +374,22 @@ -- 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--- necesarily flushed when the compiler finishes running, so you should+-- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a runIO m = Q (qRunIO m) -- | Record external files that runIO is using (dependent upon).--- The compiler can then recognize that it should re-compile the file using this TH when the external file changes.--- Note that ghc -M will still not know about these dependencies - it does not execute TH.+-- 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) @@ -400,17 +412,17 @@ putQ x = Q (qPutQ x) instance Quasi Q where- qNewName = newName- qReport = report- qRecover = recover- qReify = reify+ qNewName = newName+ qReport = report+ qRecover = recover+ qReify = reify qReifyInstances = reifyInstances qReifyRoles = reifyRoles qReifyAnnotations = reifyAnnotations qReifyModule = reifyModule qLookupName = lookupName- qLocation = location- qRunIO = runIO+ qLocation = location+ qRunIO = runIO qAddDependentFile = addDependentFile qAddTopDecls = addTopDecls qAddModFinalizer = addModFinalizer@@ -434,19 +446,59 @@ ----------------------------------------------------- ----- The Lift class+-- The Lift class -- ----------------------------------------------------- class Lift t where lift :: t -> Q Exp +-- If you add any instances here, consider updating test th/TH_Lift instance Lift Integer where lift x = return (LitE (IntegerL x)) instance Lift Int where- lift x= return (LitE (IntegerL (fromIntegral x)))+ lift x = return (LitE (IntegerL (fromIntegral x))) +instance Lift Int8 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Int16 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Int32 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Int64 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Word where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Word8 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Word16 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Word32 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Word64 where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Lift Natural where+ lift x = return (LitE (IntegerL (fromIntegral x)))++instance Integral a => Lift (Ratio a) where+ lift x = return (LitE (RationalL (toRational x)))++instance Lift Float where+ lift x = return (LitE (RationalL (toRational x)))++instance Lift Double where+ lift x = return (LitE (RationalL (toRational x)))+ instance Lift Char where lift x = return (LitE (CharL x)) @@ -469,6 +521,9 @@ -- Used in TcExpr to short-circuit the lifting for strings liftString s = return (LitE (StringL s)) +instance Lift () where+ lift () = return (ConE (tupleDataName 0))+ instance (Lift a, Lift b) => Lift (a, b) where lift (a, b) = liftM TupE $ sequence [lift a, lift b]@@ -510,8 +565,8 @@ falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name-nothingName = mkNameG DataName "base" "Data.Maybe" "Nothing"-justName = mkNameG DataName "base" "Data.Maybe" "Just"+nothingName = mkNameG DataName "base" "GHC.Base" "Nothing"+justName = mkNameG DataName "base" "GHC.Base" "Just" leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left"@@ -519,21 +574,21 @@ -------------------------------------------------------- Names and uniques+-- Names and uniques ----------------------------------------------------- -newtype ModName = ModName String -- Module name- deriving (Show,Eq,Ord,Typeable,Data)+newtype ModName = ModName String -- Module name+ deriving (Show,Eq,Ord,Typeable,Data,Generic) -newtype PkgName = PkgName String -- package name- deriving (Show,Eq,Ord,Typeable,Data)+newtype PkgName = PkgName String -- package name+ deriving (Show,Eq,Ord,Typeable,Data,Generic) -- | Obtained from 'reifyModule' and 'thisModule'. data Module = Module PkgName ModName -- package qualified module name- deriving (Show,Eq,Ord,Typeable,Data)+ deriving (Show,Eq,Ord,Typeable,Data,Generic) newtype OccName = OccName String- deriving (Show,Eq,Ord,Typeable,Data)+ deriving (Show,Eq,Ord,Typeable,Data,Generic) mkModName :: String -> ModName mkModName s = ModName s@@ -550,7 +605,7 @@ -------------------------------------------------------- OccName+-- OccName ----------------------------------------------------- mkOccName :: String -> OccName@@ -561,7 +616,7 @@ -------------------------------------------------------- Names+-- Names ----------------------------------------------------- -- -- For "global" names ('NameG') we need a totally unique name,@@ -644,67 +699,29 @@ (such as @let x = ...@ or @\x -> ...@), but names constructed using @lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not. -}-data Name = Name OccName NameFlavour deriving (Typeable, Data)+data Name = Name OccName NameFlavour deriving (Typeable, 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 Int# -- ^ A unique local name- | NameL Int# -- ^ Local name bound outside of the TH AST+ | NameU !Int -- ^ A unique local name+ | NameL !Int -- ^ 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 ( Typeable )---- |--- Although the NameFlavour type is abstract, the Data instance is not. The reason for this--- is that currently we use Data to serialize values in annotations, and in order for that to--- work for Template Haskell names introduced via the 'x syntax we need gunfold on NameFlavour--- to work. Bleh!------ The long term solution to this is to use the binary package for annotation serialization and--- then remove this instance. However, to do _that_ we need to wait on binary to become stable, since--- boot libraries cannot be upgraded separately from GHC itself.------ This instance cannot be derived automatically due to bug #2701-instance Data NameFlavour where- gfoldl _ z NameS = z NameS- gfoldl k z (NameQ mn) = z NameQ `k` mn- gfoldl k z (NameU i) = z (\(I# i') -> NameU i') `k` (I# i)- gfoldl k z (NameL i) = z (\(I# i') -> NameL i') `k` (I# i)- gfoldl k z (NameG ns p m) = z NameG `k` ns `k` p `k` m- gunfold k z c = case constrIndex c of- 1 -> z NameS- 2 -> k $ z NameQ- 3 -> k $ z (\(I# i) -> NameU i)- 4 -> k $ z (\(I# i) -> NameL i)- 5 -> k $ k $ k $ z NameG- _ -> error "gunfold: NameFlavour"- toConstr NameS = con_NameS- toConstr (NameQ _) = con_NameQ- toConstr (NameU _) = con_NameU- toConstr (NameL _) = con_NameL- toConstr (NameG _ _ _) = con_NameG- dataTypeOf _ = ty_NameFlavour--con_NameS, con_NameQ, con_NameU, con_NameL, con_NameG :: Data.Constr-con_NameS = mkConstr ty_NameFlavour "NameS" [] Data.Prefix-con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Data.Prefix-con_NameU = mkConstr ty_NameFlavour "NameU" [] Data.Prefix-con_NameL = mkConstr ty_NameFlavour "NameL" [] Data.Prefix-con_NameG = mkConstr ty_NameFlavour "NameG" [] Data.Prefix--ty_NameFlavour :: Data.DataType-ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"- [con_NameS, con_NameQ, con_NameU,- con_NameL, con_NameG]+ -- Need the namespace too to be sure which+ -- thing we are naming+ deriving ( Typeable, Data, Eq, Ord, 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 )+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 ) type Uniq = Int @@ -758,20 +775,20 @@ = 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 -- Trac #8633- -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")- -- This rather bizarre case actually happened; (.&.) is in Data.Bits+ 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 -- Trac #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, + -- 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@@ -787,11 +804,11 @@ -- | Only used internally mkNameU :: String -> Uniq -> Name-mkNameU s (I# u) = Name (mkOccName s) (NameU u)+mkNameU s u = Name (mkOccName s) (NameU u) -- | Only used internally mkNameL :: String -> Uniq -> Name-mkNameL s (I# u) = Name (mkOccName s) (NameL u)+mkNameL s u = Name (mkOccName s) (NameL u) -- | Used for 'x etc, but not available to the programmer mkNameG :: NameSpace -> String -> String -> String -> Name@@ -803,45 +820,6 @@ mkNameG_tc = mkNameG TcClsName mkNameG_d = mkNameG DataName -instance Eq Name where- v1 == v2 = cmpEq (v1 `compare` v2)--instance Ord Name where- (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`- (o1 `compare` o2)--instance Eq NameFlavour where- f1 == f2 = cmpEq (f1 `compare` f2)--instance Ord NameFlavour where- -- NameS < NameQ < NameU < NameL < NameG- NameS `compare` NameS = EQ- NameS `compare` _ = LT-- (NameQ _) `compare` NameS = GT- (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2- (NameQ _) `compare` _ = LT-- (NameU _) `compare` NameS = GT- (NameU _) `compare` (NameQ _) = GT- (NameU u1) `compare` (NameU u2) | isTrue# (u1 <# u2) = LT- | isTrue# (u1 ==# u2) = EQ- | otherwise = GT- (NameU _) `compare` _ = LT-- (NameL _) `compare` NameS = GT- (NameL _) `compare` (NameQ _) = GT- (NameL _) `compare` (NameU _) = GT- (NameL u1) `compare` (NameL u2) | isTrue# (u1 <# u2) = LT- | isTrue# (u1 ==# u2) = EQ- | otherwise = GT- (NameL _) `compare` _ = LT-- (NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp`- (p1 `compare` p2) `thenCmp`- (m1 `compare` m2)- (NameG _ _ _) `compare` _ = GT- data NameIs = Alone | Applied | Infix showName :: Name -> String@@ -858,18 +836,18 @@ | 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+ -- 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 (I# u)- Name occ (NameL u) -> occString occ ++ "_" ++ show (I# u)+ Name occ (NameU u) -> occString occ ++ "_" ++ show u+ Name occ (NameL u) -> occString occ ++ "_" ++ show u pnam = classify nms @@ -930,22 +908,23 @@ -------------------------------------------------------- Locations+-- Locations ----------------------------------------------------- data Loc = Loc { loc_filename :: String- , loc_package :: String- , loc_module :: String- , loc_start :: CharPos- , loc_end :: CharPos }+ , loc_package :: String+ , loc_module :: String+ , loc_start :: CharPos+ , loc_end :: CharPos }+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) -type CharPos = (Int, Int) -- ^ Line and character position+type CharPos = (Int, Int) -- ^ Line and character position ----------------------------------------------------- ----- The Info returned by reification+-- The Info returned by reification -- ----------------------------------------------------- @@ -1010,16 +989,16 @@ 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, Data, Typeable )+ | TyVarI -- Scoped type variable+ Name+ Type -- What it is bound to+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) -- | Obtained from 'reifyModule' in the 'Q' Monad. data ModuleInfo = -- | Contains the import list of the module. ModuleInfo [Module]- deriving( Show, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) {- | In 'ClassOpI' and 'DataConI', name of the parent class or type@@ -1043,9 +1022,9 @@ type InstanceDec = Dec data Fixity = Fixity Int FixityDirection- deriving( Eq, Show, Data, Typeable )+ deriving( Eq, Ord, Show, Data, Typeable, Generic ) data FixityDirection = InfixL | InfixR | InfixN- deriving( Eq, Show, Data, Typeable )+ deriving( Eq, Ord, Show, Data, Typeable, Generic ) -- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) maxPrecedence :: Int@@ -1121,7 +1100,7 @@ ----------------------------------------------------- ----- The main syntax data types+-- The main syntax data types -- ----------------------------------------------------- @@ -1136,8 +1115,8 @@ | WordPrimL Integer | FloatPrimL Rational | DoublePrimL Rational- | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#- deriving( Show, Eq, Data, Typeable )+ | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) -- We could add Int, Float, Double etc, as we do in HsLit, -- but that could complicate the@@ -1165,15 +1144,15 @@ | ListP [ Pat ] -- ^ @{ [1,2,3] }@ | SigP Pat Type -- ^ @{ p :: t }@ | ViewP Exp Pat -- ^ @{ e -> p }@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) type FieldPat = (Name,Pat) data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Clause = Clause [Pat] Body [Dec] -- ^ @f { p1 p2 = body where decs }@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Exp = VarE Name -- ^ @{ x }@@@ -1220,7 +1199,8 @@ | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@- deriving( Show, Eq, Data, Typeable )+ | StaticE Exp -- ^ @{ static e }@+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) type FieldExp = (Name,Exp) @@ -1231,23 +1211,23 @@ -- | e3 = e4 } -- where ds@ | NormalB Exp -- ^ @f p { = e } where ds@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Guard = NormalG Exp -- ^ @f x { | odd x } = x@ | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Stmt = BindS Pat Exp | LetS [ Dec ] | NoBindS Exp | ParS [[Stmt]]- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Range = FromR Exp | FromThenR Exp Exp | FromToR Exp Exp | FromThenToR Exp Exp Exp- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@@@ -1290,74 +1270,79 @@ [TySynEqn] -- ^ @{ type family F a b :: * where ... }@ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@- deriving( Show, Eq, Data, Typeable )+ | 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 ) -- | 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. data TySynEqn = TySynEqn [Type] Type- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data FunDep = FunDep [Name] [Name]- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data FamFlavour = TypeFam | DataFam- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) -data Callconv = CCall | StdCall- deriving( Show, Eq, Data, Typeable )+-- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs+data Callconv = CCall | StdCall | CApi | Prim | JavaScript+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Safety = Unsafe | Safe | Interruptible- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases | SpecialiseInstP Type | RuleP String [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp- deriving( Show, Eq, Data, Typeable )+ | LineP Int String+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data Inline = NoInline | Inline | Inlinable- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq, Ord, Data, Typeable, Generic) data RuleMatch = ConLike | FunLike- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq, Ord, Data, Typeable, Generic) data Phases = AllPhases | FromPhase Int | BeforePhase Int- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq, Ord, Data, Typeable, Generic) data RuleBndr = RuleVar Name | TypedRuleVar Name Type- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq, Ord, Data, Typeable, Generic) data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq, Ord, Data, Typeable, Generic) type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ -data Pred = ClassP Name [Type] -- ^ @Eq (Int, a)@- | EqualP Type Type -- ^ @F a ~ Bool@- deriving( Show, Eq, Data, Typeable )+-- | 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 data Strict = IsStrict | NotStrict | Unpacked- deriving( Show, Eq, Data, Typeable )+ 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, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) type StrictType = (Strict, Type) type VarStrictType = (Name, Strict, Type)@@ -1373,6 +1358,7 @@ | TupleT Int -- ^ @(,), (,,), etc.@ | UnboxedTupleT Int -- ^ @(#,#), (#,,#), etc.@ | ArrowT -- ^ @->@+ | EqualityT -- ^ @~@ | ListT -- ^ @[]@ | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ | PromotedNilT -- ^ @'[]@@@ -1380,27 +1366,27 @@ | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @"Hello"@- deriving ( Show, Eq, Data, Typeable )+ deriving ( Show, Eq, Ord, Data, Typeable, Generic ) -- | Role annotations data Role = NominalR -- ^ @nominal@ | RepresentationalR -- ^ @representational@ | PhantomR -- ^ @phantom@ | InferR -- ^ @_@- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) -- | Annotation target for reifyAnnotations data AnnLookup = AnnLookupModule Module | AnnLookupName Name- deriving( Show, Eq, Data, Typeable )+ deriving( Show, Eq, Ord, Data, Typeable, Generic ) -- | To avoid duplication between kinds and types, they -- are defined to be the same. Naturally, you would never@@ -1422,7 +1408,7 @@ ----------------------------------------------- t1 -> t2 ArrowT `AppT` t2 `AppT` t2 [t] ListT `AppT` t- (t1,t2) TupleT 2 `AppT` t1 `AppT` t2+ (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@@ -1443,7 +1429,7 @@ -} -------------------------------------------------------- Internal helper functions+-- Internal helper functions ----------------------------------------------------- cmpEq :: Ordering -> Bool@@ -1453,4 +1439,3 @@ thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _ = o1-
+ changelog.md view
@@ -0,0 +1,22 @@+# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)++## 2.10.0.0 *Mar 2015*++ * Bundled with GHC 7.10.1+ * Remove build-dependency on `containers` package+ * Make `Pred` a type synonym of `Type`, and deprecate `classP`/`equalP` (#7021)+ * Add support for `LINE` pragma via `prageLineD` and `LineP`+ * Replace `Int#` with `!Int` in `NameFlavour` constructors+ * Derive `Generic` for TH types (#9527)+ * Add `standaloneDerivD` (#8100)+ * Add support for generic default signatures via `defaultSigD` (#9064)+ * Add `Lift` instances for `()` and `Rational`+ * Derive new `Show` and `Data` instances for `Loc`+ * Derive `Eq` instances for `Loc`, `Info`, and `ModuleInfo`+ * Make calling conventions available in template haskell consistent+ with those from GHC (#9703)+ * Add support for `-XStaticValues` via `staticE`+ * Add `Ord` instances to TH types+ * Merge some instances from `th-orphans` (`Ppr` instances for `Lit`+ and `Loc` as well as `Lift` instances for numeric types+ * Put parens around `(ty :: kind)` when pretty-printing TH syntax
template-haskell.cabal view
@@ -1,6 +1,6 @@ name: template-haskell-version: 2.9.0.0--- GHC 7.6.1 released with 2.8.0.0+version: 2.10.0.0+-- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE category: Template Haskell@@ -16,14 +16,12 @@ See <http://www.haskell.org/haskellwiki/Template_Haskell> for more information. -source-repository head- type: git- location: http://git.haskell.org/packages/template-haskell.git+extra-source-files: changelog.md -source-repository this+source-repository head type: git- location: http://git.haskell.org/packages/template-haskell.git- tag: template-haskell-2.9.0.0-release+ location: http://git.haskell.org/ghc.git+ subdir: libraries/template-haskell Library default-language: Haskell2010@@ -46,11 +44,13 @@ Language.Haskell.TH.Quote Language.Haskell.TH.Syntax + other-modules:+ Language.Haskell.TH.Lib.Map+ build-depends:- base == 4.7.*,- containers == 0.5.*,+ base == 4.8.*, pretty == 1.1.* - -- We need to set the package name to template-haskell (without a+ -- We need to set the package key to template-haskell (without a -- version number) as it's magic.- ghc-options: -Wall -package-name template-haskell+ ghc-options: -Wall -this-package-key template-haskell