diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -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, diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -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) } diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -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 [] diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs --- a/Language/Haskell/TH/PprLib.hs +++ b/Language/Haskell/TH/PprLib.hs @@ -1,4 +1,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 diff --git a/Language/Haskell/TH/Quote.hs b/Language/Haskell/TH/Quote.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Quote.hs @@ -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 diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -1,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 diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -1,5 +1,5 @@ name: template-haskell -version: 2.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