template-haskell 2.3.0.1 → 2.4.0.0
raw patch · 7 files changed
+434/−124 lines, 7 filesdep −packedstringdep ~base
Dependencies removed: packedstring
Dependency ranges changed: base
Files
- Language/Haskell/TH.hs +16/−11
- Language/Haskell/TH/Lib.hs +113/−7
- Language/Haskell/TH/Ppr.hs +137/−39
- Language/Haskell/TH/Quote.hs +1/−3
- Language/Haskell/TH/Syntax.hs +114/−50
- Language/Haskell/TH/Syntax/Internals.hs +29/−0
- template-haskell.cabal +24/−14
Language/Haskell/TH.hs view
@@ -18,19 +18,21 @@ tupleTypeName, tupleDataName, -- Int -> Name -- The algebraic data types- Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), - Clause(..), Body(..), Guard(..), Stmt(..), Range(..),- Lit(..), Pat(..), FieldExp, FieldPat, - Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..),- Info(..), Loc(..),+ Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..), Cxt,+ Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..),+ Range(..), Lit(..), Pat(..), FieldExp, FieldPat, + Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),+ InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), Loc(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, -- Library functions- InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, MatchQ, ClauseQ, BodyQ, GuardQ,- StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,+ InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, PredQ, MatchQ, ClauseQ, BodyQ,+ GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,+ InlineSpecQ, intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, charL, stringL,- litP, varP, tupP, conP, infixP, tildeP, asP, wildP, recP, listP, sigP,+ litP, varP, tupP, conP, infixP, tildeP, bangP, asP, wildP, recP,+ listP, sigP, fieldPat, bindS, letS, noBindS, parS, fromR, fromThenR, fromToR, fromThenToR, @@ -40,10 +42,13 @@ fromE, fromThenE, fromToE, fromThenToE, listE, sigE, recConE, recUpdE, stringE, fieldExp, valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,- cxt, normalC, recC, infixC,- forallT, varT, conT, appT, arrowT, listT, tupleT,+ pragInlD, pragSpecD, familyNoKindD, familyKindD, dataInstD,+ newtypeInstD, tySynInstD, + cxt, classP, equalP, normalC, recC, infixC,+ forallT, varT, conT, appT, arrowT, listT, tupleT, sigT, isStrict, notStrict, strictType, varStrictType,- cCall, stdCall, unsafe, safe, threadsafe,+ cCall, stdCall, unsafe, safe, threadsafe, + inlineSpecNoPhase, inlineSpecPhase, typeFam, dataFam, -- Pretty-printer Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
Language/Haskell/TH/Lib.hs view
@@ -21,6 +21,7 @@ type ConQ = Q Con type TypeQ = Q Type type CxtQ = Q Cxt+type PredQ = Q Pred type MatchQ = Q Match type ClauseQ = Q Clause type BodyQ = Q Body@@ -30,6 +31,7 @@ type StrictTypeQ = Q StrictType type VarStrictTypeQ = Q VarStrictType type FieldExpQ = Q FieldExp+type InlineSpecQ = Q InlineSpec ---------------------------------------------------------- -- Lowercase pattern syntax functions@@ -68,6 +70,9 @@ tildeP :: PatQ -> PatQ tildeP p = do p' <- p return (TildeP p')+bangP :: PatQ -> PatQ+bangP p = do p' <- p+ return (BangP p') asP :: Name -> PatQ -> PatQ asP n p = do p' <- p return (AsP n p')@@ -277,24 +282,24 @@ ; return (FunD nm cs1) } -tySynD :: Name -> [Name] -> TypeQ -> DecQ+tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [Name] -> [ConQ] -> [Name] -> DecQ+dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ dataD ctxt tc tvs cons derivs = do ctxt1 <- ctxt cons1 <- sequence cons return (DataD ctxt1 tc tvs cons1 derivs) -newtypeD :: CxtQ -> Name -> [Name] -> ConQ -> [Name] -> DecQ+newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ newtypeD ctxt tc tvs con derivs = do ctxt1 <- ctxt con1 <- con return (NewtypeD ctxt1 tc tvs con1 derivs) -classD :: CxtQ -> Name -> [Name] -> [FunDep] -> [DecQ] -> DecQ+classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ classD ctxt cls tvs fds decs = do decs1 <- sequence decs@@ -317,9 +322,70 @@ = do ty' <- ty return $ ForeignD (ImportF cc s str n ty') -cxt :: [TypeQ] -> CxtQ+pragInlD :: Name -> InlineSpecQ -> DecQ+pragInlD n ispec + = do+ ispec1 <- ispec + return $ PragmaD (InlineP n ispec1)++pragSpecD :: Name -> TypeQ -> DecQ+pragSpecD n ty+ = do+ ty1 <- ty+ return $ PragmaD (SpecialiseP n ty1 Nothing)++pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ+pragSpecInlD n ty ispec + = do+ ty1 <- ty+ ispec1 <- ispec+ return $ PragmaD (SpecialiseP n ty1 (Just ispec1))++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 =+ do+ ctxt1 <- ctxt+ tys1 <- sequence tys+ cons1 <- sequence cons+ return (DataInstD ctxt1 tc tys1 cons1 derivs)++newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ+newtypeInstD ctxt tc tys con derivs =+ do+ ctxt1 <- ctxt+ tys1 <- sequence tys+ con1 <- con+ return (NewtypeInstD ctxt1 tc tys1 con1 derivs)++tySynInstD :: Name -> [TypeQ] -> TypeQ -> DecQ+tySynInstD tc tys rhs = + do + tys1 <- sequence tys+ rhs1 <- rhs+ return (TySynInstD tc tys1 rhs1)++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 @@ -331,14 +397,14 @@ st2' <- st2 return $ InfixC st1' con st2' -forallC :: [Name] -> CxtQ -> ConQ -> ConQ+forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ forallC ns ctxt con = liftM2 (ForallC ns) ctxt con ------------------------------------------------------------------------------- -- Type -forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ+forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ forallT tvars ctxt ty = do ctxt1 <- ctxt ty1 <- ty@@ -365,6 +431,12 @@ tupleT :: Int -> TypeQ tupleT i = return (TupleT i) +sigT :: TypeQ -> Kind -> TypeQ+sigT t k+ = do+ t' <- t+ return $ SigT t' k+ isStrict, notStrict :: Q Strict isStrict = return $ IsStrict notStrict = return $ NotStrict@@ -377,6 +449,21 @@ return (v, s, t) -------------------------------------------------------------------------------+-- Kind++plainTV :: Name -> TyVarBndr+plainTV = PlainTV++kindedTV :: Name -> Kind -> TyVarBndr+kindedTV = KindedTV++starK :: Kind+starK = StarK++arrowK :: Kind -> Kind -> Kind+arrowK = ArrowK++------------------------------------------------------------------------------- -- Callconv cCall, stdCall :: Callconv@@ -392,11 +479,29 @@ threadsafe = Threadsafe -------------------------------------------------------------------------------+-- InlineSpec++inlineSpecNoPhase :: Bool -> Bool -> InlineSpecQ+inlineSpecNoPhase inline conlike+ = return $ InlineSpec inline conlike Nothing++inlineSpecPhase :: Bool -> Bool -> Bool -> Int -> InlineSpecQ+inlineSpecPhase inline conlike beforeFrom phase+ = return $ InlineSpec inline conlike (Just (beforeFrom, phase))++------------------------------------------------------------------------------- -- FunDep funDep :: [Name] -> [Name] -> FunDep funDep = FunDep +-------------------------------------------------------------------------------+-- FamFlavour++typeFam, dataFam :: FamFlavour+typeFam = TypeFam+dataFam = DataFam+ -------------------------------------------------------------- -- Useful helper functions @@ -416,6 +521,7 @@ let {(env, [p1', p2']) = combine [r1, r2]}; return (env, InfixP p1' n p2') } rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) } +rename (BangP p) = do { (env,p2) <- rename p; return(env,BangP p2) } rename (AsP s p) = do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) } rename WildP = return([],WildP)
Language/Haskell/TH/Ppr.hs view
@@ -181,6 +181,7 @@ pprName' Infix n <+> pprPat opPrec p2) pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p+pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@" <> pprPat appPrec p pprPat _ WildP = text "_"@@ -193,42 +194,84 @@ ------------------------------ instance Ppr Dec where- ppr (FunD f cs) = vcat $ map (\c -> ppr f <+> ppr c) cs- ppr (ValD p r ds) = ppr p <+> pprBody True r- $$ where_clause ds- ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) - <+> text "=" <+> ppr rhs- ppr (DataD ctxt t xs cs decs)- = text "data"- <+> pprCxt ctxt- <+> ppr t <+> hsep (map ppr xs)- <+> sep (pref $ map ppr cs)- $$ if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)- where pref :: [Doc] -> [Doc]- pref [] = [char '='] -- Can't happen in H98- pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds- ppr (NewtypeD ctxt t xs c decs)- = text "newtype"- <+> pprCxt ctxt- <+> ppr t <+> hsep (map ppr xs)- <+> char '=' <+> ppr c- $$ if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)- ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt- <+> ppr c <+> hsep (map ppr xs) <+> ppr fds- $$ where_clause ds- ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i- $$ where_clause ds- ppr (SigD f t) = ppr f <+> text "::" <+> ppr t- ppr (ForeignD f) = ppr f+ ppr = ppr_dec True +ppr_dec :: Bool -- declaration on the toplevel?+ -> Dec + -> Doc+ppr_dec _ (FunD f cs) = vcat $ map (\c -> ppr 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_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 _ (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+ $$ where_clause ds+ppr_dec _ (SigD f t) = ppr f <+> text "::" <+> ppr t+ppr_dec _ (ForeignD f) = ppr f+ppr_dec _ (PragmaD p) = ppr p+ppr_dec isTop (FamilyD flav tc tvs k) + = ppr flav <+> 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+ 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+ where+ maybeInst | isTop = text "instance"+ | otherwise = empty+ppr_dec isTop (TySynInstD tc tys rhs) + = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs+ where+ maybeInst | isTop = text "instance"+ | otherwise = empty++ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc+ppr_data maybeInst ctxt t argsDoc cs decs+ = text "data" <+> maybeInst+ <+> pprCxt ctxt+ <+> ppr t <+> argsDoc+ <+> sep (pref $ map ppr cs)+ $$ if null decs+ then empty+ else nest nestDepth+ $ text "deriving"+ <+> parens (hsep $ punctuate comma $ map ppr decs)+ where + pref :: [Doc] -> [Doc]+ 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+ = text "newtype" <+> maybeInst+ <+> pprCxt ctxt+ <+> ppr t <+> argsDoc+ <+> char '=' <+> ppr c+ $$ if null 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+ = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs+ ------------------------------ instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)@@ -236,6 +279,11 @@ ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs)) ------------------------------+instance Ppr FamFlavour where+ ppr DataFam = text "data"+ ppr TypeFam = text "type"++------------------------------ instance Ppr Foreign where ppr (ImportF callconv safety impent as typ) = text "foreign import"@@ -252,6 +300,36 @@ <+> text "::" <+> ppr typ ------------------------------+instance Ppr Pragma where+ ppr (InlineP n (InlineSpec inline conlike activation))+ = text "{-#"+ <+> (if inline then text "INLINE" else text "NOINLINE")+ <+> (if conlike then text "CONLIKE" else empty)+ <+> ppr_activation activation + <+> ppr n+ <+> text "#-}"+ ppr (SpecialiseP n ty Nothing)+ = sep [ text "{-# SPECIALISE" + , ppr n <+> text "::"+ , ppr ty+ , text "#-}"+ ]+ ppr (SpecialiseP n ty (Just (InlineSpec inline _conlike activation)))+ = sep [ text "{-# SPECIALISE" <+> + (if inline then text "INLINE" else text "NOINLINE") <+>+ ppr_activation activation+ , ppr n <+> text "::"+ , ppr ty+ , text "#-}"+ ]+ where++ppr_activation :: Maybe (Bool, Int) -> Doc+ppr_activation (Just (beforeFrom, i))+ = brackets $ (if beforeFrom then empty else char '~') <+> int i+ppr_activation Nothing = empty++------------------------------ instance Ppr Clause where ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs $$ where_clause ds@@ -289,10 +367,11 @@ pprParendType other = parens (ppr other) instance Ppr Type where- ppr (ForallT tvars ctxt ty) = - text "forall" <+> hsep (map ppr tvars) <+> text "."+ ppr (ForallT tvars ctxt ty)+ = text "forall" <+> hsep (map ppr tvars) <+> text "." <+> pprCxt ctxt <+> ppr ty- ppr ty = pprTyApp (split ty)+ ppr (SigT ty k) = ppr ty <+> text "::" <+> ppr k+ ppr ty = pprTyApp (split ty) pprTyApp :: (Type, [Type]) -> Doc pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]@@ -305,6 +384,7 @@ -- Everything except forall and (->) binds more tightly than (->) pprFunArgType ty@(ForallT {}) = parens (ppr ty) pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)+pprFunArgType ty@(SigT _ _) = parens (ppr ty) pprFunArgType ty = ppr ty split :: Type -> (Type, [Type]) -- Split into function and args@@ -313,12 +393,30 @@ go ty args = (ty, args) ------------------------------+instance Ppr TyVarBndr where+ ppr (PlainTV nm) = ppr nm+ ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k)++instance Ppr Kind where+ ppr StarK = char '*'+ ppr (ArrowK k1 k2) = pprArrowArgKind k1 <+> text "->" <+> ppr k2++pprArrowArgKind :: Kind -> Doc+pprArrowArgKind k@(ArrowK _ _) = parens (ppr k)+pprArrowArgKind k = ppr k++------------------------------ pprCxt :: Cxt -> Doc pprCxt [] = empty pprCxt [t] = ppr t <+> text "=>" pprCxt ts = parens (hsep $ 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@@ -333,7 +431,7 @@ ------------------------------ where_clause :: [Dec] -> Doc where_clause [] = empty-where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)+where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds) showtextl :: Show a => a -> Doc showtextl = text . map toLower . show
Language/Haskell/TH/Quote.hs view
@@ -28,10 +28,8 @@ mkLit $ integerL n FloatConstr n -> mkLit $ rationalL (toRational n)- StringConstr (c:_) ->+ CharConstr c -> mkLit $ charL c- StringConstr [] ->- fail "StringConstr with no name" where constr :: Constr constr = toConstr t
Language/Haskell/TH/Syntax.hs view
@@ -1,9 +1,10 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}--- The above warning supression flag is a temporary kludge.+-- The -fno-warn-warnings-deprecations flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings -- for details+ ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Syntax@@ -19,7 +20,7 @@ ----------------------------------------------------------------------------- module Language.Haskell.TH.Syntax(- Quasi(..), Lift(..), + Quasi(..), Lift(..), liftString, Q, runQ, report, recover, reify,@@ -30,11 +31,11 @@ showName, showName', NameIs(..), -- The algebraic data types- Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), - Clause(..), Body(..), Guard(..), Stmt(..), Range(..),- Lit(..), Pat(..), FieldExp, FieldPat, - Strict(..), Foreign(..), Callconv(..), Safety(..),- StrictType, VarStrictType, FunDep(..),+ Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt,+ Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..),+ Range(..), Lit(..), Pat(..), FieldExp, FieldPat, + Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),+ InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..), Info(..), Loc(..), CharPos, Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, @@ -48,13 +49,13 @@ PkgName, mkPkgName, pkgString ) where -import Data.PackedString import GHC.Base ( Int(..), Int#, (<#), (==#) ) -import Data.Data (Data(..), Typeable, mkConstr, mkDataType)+import Language.Haskell.TH.Syntax.Internals+import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex) import qualified Data.Data as Data import Data.IORef-import GHC.IOBase ( unsafePerformIO )+import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad (liftM) import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha )@@ -224,6 +225,10 @@ instance Lift a => Lift [a] where lift xs = do { xs' <- mapM lift xs; return (ListE xs') } +liftString :: String -> Q Exp+-- Used in TcExpr to short-circuit the lifting for strings+liftString s = return (LitE (StringL s))+ instance (Lift a, Lift b) => Lift (a, b) where lift (a, b) = liftM TupE $ sequence [lift a, lift b]@@ -277,35 +282,29 @@ -- Names and uniques ----------------------------------------------------- -type ModName = PackedString -- Module name- mkModName :: String -> ModName-mkModName s = packString s+mkModName s = ModName s modString :: ModName -> String-modString m = unpackPS m+modString (ModName m) = m -type PkgName = PackedString -- package name- mkPkgName :: String -> PkgName-mkPkgName s = packString s+mkPkgName s = PkgName s pkgString :: PkgName -> String-pkgString m = unpackPS m+pkgString (PkgName m) = m ----------------------------------------------------- -- OccName ----------------------------------------------------- -type OccName = PackedString- mkOccName :: String -> OccName-mkOccName s = packString s+mkOccName s = OccName s occString :: OccName -> String-occString occ = unpackPS occ+occString (OccName occ) = occ -----------------------------------------------------@@ -345,8 +344,29 @@ -- 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 seperately from GHC itself.+--+-- This instance cannot be derived automatically due to bug #2701 instance Data NameFlavour where- gunfold = error "gunfold"+ 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@@ -618,16 +638,17 @@ data Pat = LitP Lit -- { 5 or 'c' }- | VarP Name -- { x }+ | VarP Name -- { x } | TupP [Pat] -- { (p1,p2) }- | ConP Name [Pat] -- data T1 = C1 t1 t2; {C1 p1 p1} = e + | ConP Name [Pat] -- data T1 = C1 t1 t2; {C1 p1 p1} = e | InfixP Pat Name Pat -- foo ({x :+ y}) = e | TildeP Pat -- { ~p }- | AsP Name Pat -- { x @ p }+ | BangP Pat -- { !p }+ | AsP Name Pat -- { x @ p } | WildP -- { _ }- | RecP Name [FieldPat] -- f (Pt { pointx = x }) = g x+ | RecP Name [FieldPat] -- f (Pt { pointx = x }) = g x | ListP [ Pat ] -- { [1,2,3] }- | SigP Pat Type -- p :: t+ | SigP Pat Type -- { p :: t } deriving( Show, Eq, Data, Typeable ) type FieldPat = (Name,Pat)@@ -639,9 +660,14 @@ -- f { p1 p2 = body where decs } deriving( Show, Eq, Data, Typeable ) +-- | The 'CompE' constructor represents a list comprehension, and +-- takes a ['Stmt']. The result expression of the comprehension is+-- the *last* of these, and should be a 'NoBindS'.+-- E.g. [ f x | x <- xs ] is represented by+-- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))] data Exp - = VarE Name -- { x }- | ConE Name -- data T1 = C1 t1 t2; p = {C1} e1 e2 + = VarE Name -- { x }+ | ConE Name -- data T1 = C1 t1 t2; p = {C1} e1 e2 | LitE Lit -- { 5 or 'c'} | AppE Exp Exp -- { f x } @@ -661,7 +687,7 @@ | CompE [Stmt] -- { [ (x,y) | x <- xs, y <- ys ] } | ArithSeqE Range -- { [ 1 ,2 .. 10 ] } | ListE [ Exp ] -- { [1,2,3] }- | SigE Exp Type -- e :: t+ | 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 )@@ -694,24 +720,41 @@ data Dec = FunD Name [Clause] -- { f p1 p2 = b where decs } | ValD Pat Body [Dec] -- { p = b where decs }- | DataD Cxt Name [Name] + | DataD Cxt Name [TyVarBndr] [Con] [Name] -- { data Cxt x => T x = A x | B (T x) -- deriving (Z,W)}- | NewtypeD Cxt Name [Name] + | NewtypeD Cxt Name [TyVarBndr] Con [Name] -- { newtype Cxt x => T x = A (B x) -- deriving (Z,W)}- | TySynD Name [Name] Type -- { type T x = (x,x) }- | ClassD Cxt Name [Name] [FunDep] [Dec]- -- { class Eq a => Ord a where ds }+ | 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 } | SigD Name Type -- { length :: [a] -> Int } | ForeignD Foreign+ -- pragmas+ | 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 :: * }+ + | DataInstD Cxt Name [Type]+ [Con] [Name] -- { 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)}+ | TySynInstD Name [Type] Type -- { type instance T (Maybe x) = (x,x) } deriving( Show, Eq, Data, Typeable ) data FunDep = FunDep [Name] [Name] deriving( Show, Eq, Data, Typeable ) +data FamFlavour = TypeFam | DataFam+ deriving( Show, Eq, Data, Typeable )+ data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type deriving( Show, Eq, Data, Typeable )@@ -722,29 +765,50 @@ data Safety = Unsafe | Safe | Threadsafe deriving( Show, Eq, Data, Typeable ) -type Cxt = [Type] -- (Eq a, Ord b)+data Pragma = InlineP Name InlineSpec+ | SpecialiseP Name Type (Maybe InlineSpec)+ deriving( Show, Eq, Data, Typeable ) +data InlineSpec + = InlineSpec Bool -- False: no inline; True: inline + Bool -- False: fun-like; True: constructor-like+ (Maybe (Bool, Int)) -- False: before phase; True: from phase+ deriving( Show, Eq, Data, Typeable )++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 )+ data Strict = IsStrict | NotStrict deriving( Show, Eq, Data, Typeable ) -data Con = NormalC Name [StrictType]- | RecC Name [VarStrictType]- | InfixC StrictType Name StrictType- | ForallC [Name] Cxt Con+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 ) type StrictType = (Strict, Type) type VarStrictType = (Name, Strict, Type) --- FIXME: Why this special status for "List" (even tuples might be handled--- differently)? -=chak-data Type = ForallT [Name] Cxt Type -- forall <vars>. <ctxt> -> <type>- | VarT Name -- a- | ConT Name -- T- | TupleT Int -- (,), (,,), etc.- | ArrowT -- ->- | ListT -- []- | AppT Type Type -- T a b+data Type = ForallT [TyVarBndr] Cxt Type -- forall <vars>. <ctxt> -> <type>+ | VarT Name -- a+ | ConT Name -- T+ | TupleT Int -- (,), (,,), etc.+ | ArrowT -- ->+ | ListT -- []+ | AppT Type Type -- T a b+ | SigT Type Kind -- t :: k+ deriving( Show, Eq, Data, Typeable )++data TyVarBndr = PlainTV Name -- a+ | KindedTV Name Kind -- (a :: k)+ deriving( Show, Eq, Data, Typeable )++data Kind = StarK -- '*'+ | ArrowK Kind Kind -- k1 -> k2 deriving( Show, Eq, Data, Typeable ) -----------------------------------------------------
+ Language/Haskell/TH/Syntax/Internals.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.Syntax.Internals+-- Copyright : (c) The University of Glasgow 2009+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Abstract syntax definitions for Template Haskell.+--+-----------------------------------------------------------------------------++module Language.Haskell.TH.Syntax.Internals (+ ModName(..), PkgName(..), OccName(..)+ ) where++import Data.Data++newtype ModName = ModName String -- Module name+ deriving (Eq,Ord,Typeable,Data)++newtype PkgName = PkgName String -- package name+ deriving (Eq,Ord,Typeable,Data)++newtype OccName = OccName String+ deriving (Eq,Ord,Typeable,Data)
template-haskell.cabal view
@@ -1,22 +1,32 @@ name: template-haskell-version: 2.3.0.1+version: 2.4.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org+bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=Template%20Haskell description: Facilities for manipulating Haskell source code using Template Haskell. build-type: Simple-build-depends: base, pretty, packedstring, containers-exposed-modules:- Language.Haskell.TH.Syntax,- Language.Haskell.TH.PprLib,- Language.Haskell.TH.Ppr,- Language.Haskell.TH.Lib,- Language.Haskell.TH.Quote,- Language.Haskell.TH-extensions: MagicHash, PatternGuards, PolymorphicComponents,- DeriveDataTypeable, TypeSynonymInstances--- We need to set the package name to template-haskell (without a--- version number) as it's magic.-ghc-options: -package-name template-haskell+Cabal-Version: >= 1.6++Library+ build-depends: base >= 3 && < 5,+ pretty, containers+ exposed-modules:+ Language.Haskell.TH.Syntax.Internals+ Language.Haskell.TH.Syntax+ Language.Haskell.TH.PprLib+ Language.Haskell.TH.Ppr+ Language.Haskell.TH.Lib+ Language.Haskell.TH.Quote+ Language.Haskell.TH+ extensions: MagicHash, PatternGuards, PolymorphicComponents,+ DeriveDataTypeable, TypeSynonymInstances+ -- We need to set the package name to template-haskell (without a+ -- version number) as it's magic.+ ghc-options: -package-name template-haskell++source-repository head+ type: darcs+ location: http://darcs.haskell.org/packages/template-haskell/