packages feed

template-haskell 2.2.0.0 → 2.3.0.0

raw patch · 7 files changed

+154/−60 lines, 7 filesnew-uploader

Files

Language/Haskell/TH.hs view
@@ -3,11 +3,11 @@ module Language.Haskell.TH( 	-- The monad and its operations 	Q, runQ, -	report,		-- :: Bool -> String -> Q ()-	recover, 	-- :: Q a -> Q a -> Q a-	reify, 		-- :: Name -> Q Info-	currentModule, 	-- :: Q String-	runIO, 		-- :: IO a -> Q a+	report,		  -- :: Bool -> String -> Q ()+	recover, 	  -- :: Q a -> Q a -> Q a+	reify, 		  -- :: Name -> Q Info+	location,	  -- :: Q Location+	runIO, 		  -- :: IO a -> Q a  	-- Names 	Name, @@ -22,13 +22,14 @@ 	Clause(..), Body(..), Guard(..), Stmt(..), Range(..), 	Lit(..), Pat(..), FieldExp, FieldPat,  	Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..),-	Info(..), +	Info(..), Loc(..), 	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,  	-- Library functions 	InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, MatchQ, ClauseQ, BodyQ, GuardQ, 	StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,-	intPrimL, floatPrimL, doublePrimL, integerL, charL, stringL, rationalL, +	intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,+	charL, stringL, 	litP, varP, tupP, conP, infixP, tildeP, asP, wildP, recP, listP, sigP, 	fieldPat, 	bindS, letS, noBindS, parS,
Language/Haskell/TH/Lib.hs view
@@ -37,6 +37,8 @@  intPrimL    :: Integer -> Lit intPrimL    = IntPrimL+wordPrimL    :: Integer -> Lit+wordPrimL    = WordPrimL floatPrimL  :: Rational -> Lit floatPrimL  = FloatPrimL doublePrimL :: Rational -> Lit@@ -422,6 +424,7 @@           (ss,ps) = unzip fs rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }    where g (es,ps) = return (es,ListP ps)+rename (SigP {}) = fail "rename: Don't know how to do SigP yet"  genpat :: Pat -> Q ((Name -> ExpQ), Pat) genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }
Language/Haskell/TH/Ppr.hs view
@@ -62,10 +62,11 @@       = vcat [ppr_sig v ty, pprFixity v fix,                case mb_d of { Nothing -> empty; Just d -> ppr d }] +ppr_sig :: Name -> Type -> Doc ppr_sig v ty = ppr v <+> text "::" <+> ppr ty  pprFixity :: Name -> Fixity -> Doc-pprFixity v f | f == defaultFixity = empty+pprFixity _ f | f == defaultFixity = empty pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v     where ppr_fix InfixR = text "infixr"           ppr_fix InfixL = text "infixl"@@ -155,6 +156,7 @@ pprLit :: Precedence -> Lit -> Doc pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)                                     (integer x <> char '#')+pprLit _ (WordPrimL x)    = integer x <> text "##" pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)                                     (float (fromRational x) <> char '#') pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)@@ -293,11 +295,17 @@     ppr ty = pprTyApp (split ty)  pprTyApp :: (Type, [Type]) -> Doc-pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2]+pprTyApp (ArrowT, [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))) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)++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)+pprFunArgType ty                              = ppr ty  split :: Type -> (Type, [Type])    -- Split into function and args split t = go t []
Language/Haskell/TH/PprLib.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fglasgow-exts #-}  -- Monadic front-end to Text.PrettyPrint.HughesPJ @@ -126,8 +125,8 @@  = PprM $ \s@(fm, i@(I# i'))         -> let (n', s') = case Map.lookup n fm of                          Just d -> (d, s)-                         Nothing -> let n' = Name o (NameU i')-                                    in (n', (Map.insert n n' fm, i + 1))+                         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 @@ -209,9 +208,9 @@                   return (HPJ.hang d1' n d2')  -- punctuate uses the same definition as Text.PrettyPrint.HughesPJ-punctuate p []     = []+punctuate _ []     = [] punctuate p (d:ds) = go d ds                    where-                     go d [] = [d]-                     go d (e:es) = (d <> p) : go e es+                     go d' [] = [d']+                     go d' (e:es) = (d' <> p) : go e es
+ Language/Haskell/TH/Quote.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+module Language.Haskell.TH.Quote(+	QuasiQuoter(..),+        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 }++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 con conArgs+            IntConstr n ->+                mkLit $ integerL n+            FloatConstr n ->+                mkLit $ rationalL (toRational n)+            StringConstr (c:_) ->+                mkLit $ charL c+            StringConstr [] ->+                fail "StringConstr with no name"+        where+          constr :: Constr+          constr = toConstr t+          constrName :: Constr -> String+          constrName k =+              case showConstr k of+                "(:)"  -> ":"+                name   -> name+          con :: k+          con = mkCon (mkName (constrName constr))+          conArgs :: [Q q]+          conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) 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
Language/Haskell/TH/Syntax.hs view
@@ -1,7 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-	-- Need GlaExts for the nested forall in defn of Q,-	-- and the deriving Data, Typeable-{-# OPTIONS_GHC -w #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See@@ -26,11 +23,11 @@  	Q, runQ,  	report,	recover, reify,-	currentModule, runIO,+	location, runIO,  	-- Names 	Name(..), mkName, newName, nameBase, nameModule,-    showName, showName', NameIs(..),+        showName, showName', NameIs(..),  	-- The algebraic data types 	Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), @@ -38,7 +35,7 @@ 	Lit(..), Pat(..), FieldExp, FieldPat,  	Strict(..), Foreign(..), Callconv(..), Safety(..), 	StrictType, VarStrictType, FunDep(..),-	Info(..), +	Info(..), Loc(..), CharPos, 	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,  	-- Internal functions@@ -54,8 +51,8 @@ import Data.PackedString import GHC.Base		( Int(..), Int#, (<#), (==#) ) -import Data.Generics (Data(..), Typeable, mkConstr, mkDataType)-import qualified Data.Generics as Generics+import Data.Data (Data(..), Typeable, mkConstr, mkDataType)+import qualified Data.Data as Data import Data.IORef import GHC.IOBase	( unsafePerformIO ) import Control.Monad (liftM)@@ -80,7 +77,7 @@   	-- Inspect the type-checker's environment   qReify :: Name -> m Info-  qCurrentModule :: m String+  qLocation :: m Loc  	-- Input/output (dangerous)   qRunIO :: IO a -> m a@@ -105,9 +102,9 @@   qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)   qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) -  qReify v       = badIO "reify"-  qCurrentModule = badIO "currentModule"-  qRecover a b   = badIO "recover"	-- Maybe we could fix this?+  qReify _     = badIO "reify"+  qLocation    = badIO "currentLocation"+  qRecover _ _ = badIO "recover" -- Maybe we could fix this?    qRunIO m = m   @@ -156,10 +153,10 @@ reify :: Name -> Q Info reify v = Q (qReify v) --- | 'currentModule' gives you the name of the module in which this +-- | 'location' gives you the 'Location' at which this -- computation is spliced.-currentModule :: Q String-currentModule = Q qCurrentModule+location :: Q Loc+location = Q qLocation  -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. -- Take care: you are guaranteed the ordering of calls to 'runIO' within @@ -172,12 +169,12 @@ runIO m = Q (qRunIO m)  instance Quasi Q where-  qNewName        = newName-  qReport 	 = report-  qRecover  	 = recover -  qReify    	 = reify-  qCurrentModule = currentModule-  qRunIO         = runIO+  qNewName  = newName+  qReport   = report+  qRecover  = recover +  qReify    = reify+  qLocation = location+  qRunIO    = runIO   ----------------------------------------------------@@ -357,11 +354,14 @@      toConstr (NameG _ _ _) = con_NameG      dataTypeOf _ = ty_NameFlavour -con_NameS = mkConstr ty_NameFlavour "NameS" [] Generics.Prefix-con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Generics.Prefix-con_NameU = mkConstr ty_NameFlavour "NameU" [] Generics.Prefix-con_NameL = mkConstr ty_NameFlavour "NameL" [] Generics.Prefix-con_NameG = mkConstr ty_NameFlavour "NameG" [] Generics.Prefix+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]@@ -378,9 +378,9 @@ nameBase (Name occ _) = occString occ  nameModule :: Name -> Maybe String-nameModule (Name _ (NameQ m))   = Just (modString m)+nameModule (Name _ (NameQ m))     = Just (modString m) nameModule (Name _ (NameG _ _ m)) = Just (modString m)-nameModule other_name		= Nothing+nameModule _                      = Nothing  mkName :: String -> Name -- The string can have a '.', thus "Foo.baz",@@ -414,8 +414,8 @@ mkNameL s (I# u) = Name (mkOccName s) (NameL u)  mkNameG :: NameSpace -> String -> String -> String -> Name	-- Used for 'x etc, but not available-mkNameG ns pkg mod occ 					-- to the programmer-  = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName mod))+mkNameG ns pkg modu occ 					-- to the programmer+  = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))  mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name mkNameG_v  = mkNameG VarName@@ -435,18 +435,18 @@ instance Ord NameFlavour where 	-- NameS < NameQ < NameU < NameL < NameG   NameS `compare` NameS = EQ-  NameS `compare` other = LT+  NameS `compare` _     = LT    (NameQ _)  `compare` NameS      = GT   (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2-  (NameQ _)  `compare` other      = LT+  (NameQ _)  `compare` _          = LT    (NameU _)  `compare` NameS      = GT   (NameU _)  `compare` (NameQ _)  = GT   (NameU u1) `compare` (NameU u2) | u1  <# u2 = LT 				  | u1 ==# u2 = EQ 				  | otherwise = GT-  (NameU _)  `compare` other = LT+  (NameU _)  `compare` _     = LT    (NameL _)  `compare` NameS      = GT   (NameL _)  `compare` (NameQ _)  = GT@@ -454,12 +454,12 @@   (NameL u1) `compare` (NameL u2) | u1  <# u2 = LT 				  | u1 ==# u2 = EQ 				  | otherwise = GT-  (NameL _)  `compare` other      = LT+  (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` other	  = GT+  (NameG _ _ _)    `compare` _ = GT  data NameIs = Alone | Applied | Infix @@ -484,11 +484,11 @@ 	-- 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 ns p 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 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)          pnam = classify nms @@ -516,15 +516,30 @@ tupleTypeName 1 = error "tupleTypeName 1" tupleTypeName n = mk_tup_name (n-1) TcClsName  +mk_tup_name :: Int -> NameSpace -> Name mk_tup_name n_commas space-  = Name occ (NameG space (mkPkgName "base") tup_mod)+  = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)   where     occ = mkOccName ('(' : replicate n_commas ',' ++ ")")-    tup_mod = mkModName "Data.Tuple"+    -- XXX Should it be GHC.Unit for 0 commas?+    tup_mod = mkModName "GHC.Tuple"   +-----------------------------------------------------+--		Locations+----------------------------------------------------- +data Loc+  = Loc { loc_filename :: String+	, loc_package  :: String+	, loc_module   :: String+	, loc_start    :: CharPos+	, loc_end      :: CharPos }++type CharPos = (Int, Int)	-- Line and character position++ ----------------------------------------------------- -- --	The Info returned by reification@@ -592,6 +607,7 @@                                 -- the moment. Maybe that doesn't matter?          | RationalL Rational   -- Ditto          | IntPrimL Integer+         | WordPrimL Integer          | FloatPrimL Rational          | DoublePrimL Rational     deriving( Show, Eq, Data, Typeable )@@ -741,5 +757,5 @@  thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2-thenCmp o1 o2 = o1+thenCmp o1 _  = o1
template-haskell.cabal view
@@ -1,5 +1,5 @@ name:		template-haskell-version:	2.2.0.0+version:	2.3.0.0 license:	BSD3 license-file:	LICENSE maintainer:	libraries@haskell.org@@ -12,7 +12,10 @@     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