diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -12,11 +12,11 @@ reify, -- :: Name -> Q Info location, -- :: Q Location runIO, -- :: IO a -> Q a - isClassInstance, - classInstances, + lookupTypeName, lookupValueName, + isInstance, reifyInstances, -- * Names - Name, + Name, NameSpace, -- Abstract mkName, -- :: String -> Name newName, -- :: String -> Q Name nameBase, -- :: Name -> String @@ -31,8 +31,7 @@ Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), Pat(..), FieldExp, FieldPat, Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..), - InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), - ClassInstance(..), Loc(..), + InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), Loc(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, -- * Library functions @@ -46,7 +45,8 @@ intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, charL, stringL, stringPrimL, -- *** Patterns - litP, varP, tupP, conP, infixP, tildeP, bangP, asP, wildP, recP, + litP, varP, tupP, conP, uInfixP, parensP, infixP, + tildeP, bangP, asP, wildP, recP, listP, sigP, viewP, fieldPat, @@ -54,7 +54,8 @@ normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, global, varE, conE, litE, appE, infixE, infixApp, sectionL, sectionR, + dyn, global, varE, conE, litE, appE, uInfixE, parensE, + infixE, infixApp, sectionL, sectionR, lamE, lam1E, tupE, condE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, -- **** Ranges 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 @@ -73,6 +73,14 @@ infixP p1 n p2 = do p1' <- p1 p2' <- p2 return (InfixP p1' n p2') +uInfixP :: PatQ -> Name -> PatQ -> PatQ +uInfixP p1 n p2 = do p1' <- p1 + p2' <- p2 + return (UInfixP p1' n p2') +parensP :: PatQ -> PatQ +parensP p = do p' <- p + return (ParensP p') + tildeP :: PatQ -> PatQ tildeP p = do p' <- p return (TildeP p') @@ -200,6 +208,13 @@ appE :: ExpQ -> ExpQ -> ExpQ appE x y = do { a <- x; b <- y; return (AppE a b)} +parensE :: ExpQ -> ExpQ +parensE x = do { x' <- x; return (ParensE x') } + +uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ +uInfixE x s y = do { x' <- x; s' <- s; y' <- y; + return (UInfixE x' s' y') } + infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; return (InfixE (Just a) s' (Just b))} @@ -457,9 +472,10 @@ t' <- t return $ SigT t' k -isStrict, notStrict :: Q Strict +isStrict, notStrict, unpacked :: Q Strict isStrict = return $ IsStrict notStrict = return $ NotStrict +unpacked = return Unpacked strictType :: Q Strict -> TypeQ -> StrictTypeQ strictType = liftM2 (,) 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 @@ -6,7 +6,7 @@ -- be "public" functions. The main module TH -- re-exports them all. -import Text.PrettyPrint.HughesPJ (render) +import Text.PrettyPrint (render) import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Data.Char ( toLower ) @@ -16,9 +16,10 @@ nestDepth = 4 type Precedence = Int -appPrec, opPrec, noPrec :: Precedence -appPrec = 2 -- Argument of a function application -opPrec = 1 -- Argument of an infix operator +appPrec, unopPrec, opPrec, noPrec :: Precedence +appPrec = 3 -- Argument of a function application +opPrec = 2 -- Argument of an infix operator +unopPrec = 1 -- Argument of an unresolved infix operator noPrec = 0 -- Others parensIf :: Bool -> Doc -> Doc @@ -44,8 +45,9 @@ ------------------------------ instance Ppr Info where - ppr (ClassI d is) = ppr d $$ vcat (map ppr is) - ppr (TyConI d) = ppr d + 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) = text "Primitive" <+> (if is_unlifted then text "unlifted" else empty) @@ -63,15 +65,6 @@ = vcat [ppr_sig v ty, pprFixity v fix, case mb_d of { Nothing -> empty; Just d -> ppr d }] -instance Ppr ClassInstance where - ppr (ClassInstance { ci_dfun = _dfun, - ci_tvs = _tvs, - ci_cxt = cxt, - ci_cls = cls, - ci_tys = tys }) - = text "instance" <+> pprCxt cxt - <+> ppr cls <+> sep (map pprParendType tys) - ppr_sig :: Name -> Type -> Doc ppr_sig v ty = ppr v <+> text "::" <+> ppr ty @@ -98,6 +91,11 @@ pprExp i (LitE l) = pprLit i l pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1 <+> pprExp appPrec e2 +pprExp _ (ParensE e) = parens (pprExp noPrec e) +pprExp i (UInfixE e1 op e2) + = parensIf (i > unopPrec) $ pprExp unopPrec e1 + <+> pprInfixExp op + <+> pprExp unopPrec e2 pprExp i (InfixE (Just e1) op (Just e2)) = parensIf (i >= opPrec) $ pprExp opPrec e1 <+> pprInfixExp op @@ -194,6 +192,11 @@ pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s <+> sep (map (pprPat appPrec) ps) +pprPat _ (ParensP p) = parens $ pprPat noPrec p +pprPat i (UInfixP p1 n p2) + = parensIf (i > unopPrec) (pprPat unopPrec p1 <+> + pprName' Infix n <+> + pprPat unopPrec p2) pprPat i (InfixP p1 n p2) = parensIf (i >= opPrec) (pprPat opPrec p1 <+> pprName' Infix n <+> @@ -374,6 +377,7 @@ -- Prints with parens if not already atomic pprStrictType (IsStrict, t) = char '!' <> pprParendType t pprStrictType (NotStrict, t) = pprParendType t +pprStrictType (Unpacked, t) = text "{-# UNPACK #-} !" <> pprParendType t ------------------------------ pprParendType :: Type -> Doc 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,6 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} --- | Monadic front-end to Text.PrettyPrint.HughesPJ +-- | Monadic front-end to Text.PrettyPrint module Language.Haskell.TH.PprLib ( @@ -37,7 +37,7 @@ import Language.Haskell.TH.Syntax (Name(..), showName', NameFlavour(..), NameIs(..)) -import qualified Text.PrettyPrint.HughesPJ as HPJ +import qualified Text.PrettyPrint as HPJ import Control.Monad (liftM, liftM2) import Data.Map ( Map ) import qualified Data.Map as Map ( lookup, insert, empty ) @@ -208,7 +208,7 @@ d2' <- d2 return (HPJ.hang d1' n d2') --- punctuate uses the same definition as Text.PrettyPrint.HughesPJ +-- punctuate uses the same definition as Text.PrettyPrint punctuate _ [] = [] punctuate p (d:ds) = go d ds where diff --git a/Language/Haskell/TH/Quote.hs b/Language/Haskell/TH/Quote.hs --- a/Language/Haskell/TH/Quote.hs +++ b/Language/Haskell/TH/Quote.hs @@ -25,8 +25,24 @@ case antiQ t of Nothing -> case constrRep constr of - AlgConstr _ -> - appCon con conArgs + AlgConstr _ -> + appCon (mkCon conName) conArgs + where + conName :: Name + conName = + case showConstr constr of + "(:)" -> Name (mkOccName ":") NameS + con@"[]" -> Name (mkOccName con) NameS + con@('(':_) -> Name (mkOccName con) NameS + con -> mkNameG_d (tyConPackage tycon) + (tyConModule tycon) + con + where + tycon :: TyCon + tycon = (typeRepTyCon . typeOf) t + + conArgs :: [Q q] + conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t IntConstr n -> mkLit $ integerL n FloatConstr n -> @@ -36,15 +52,6 @@ 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 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 @@ -24,18 +24,20 @@ Quasi(..), Lift(..), liftString, Q, runQ, - report, recover, reify, - location, runIO, - isClassInstance, classInstances, + report, recover, reify, + lookupTypeName, lookupValueName, + location, runIO, addDependentFile, + isInstance, reifyInstances, -- * Names Name(..), mkName, newName, nameBase, nameModule, showName, showName', NameIs(..), -- * The algebraic data types + -- $infix Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt, Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..), - Range(..), Lit(..), Pat(..), FieldExp, FieldPat, ClassInstance(..), + Range(..), Lit(..), Pat(..), FieldExp, FieldPat, Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..), InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..), Info(..), Loc(..), CharPos, @@ -57,6 +59,7 @@ import Language.Haskell.TH.Syntax.Internals import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex) import qualified Data.Data as Data +import Control.Applicative( Applicative(..) ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad (liftM) @@ -69,7 +72,7 @@ -- ----------------------------------------------------- -class (Monad m, Functor m) => Quasi m where +class (Monad m, Applicative m) => Quasi m where qNewName :: String -> m Name -- ^ Fresh names @@ -81,16 +84,21 @@ -> m a -- ^ Recover from the monadic 'fail' -- Inspect the type-checker's environment - qReify :: Name -> m Info - qClassInstances :: Name -> [Type] -> m [ClassInstance] - -- Is (cls tys) an instance? - -- Returns list of matching witnesses + qLookupName :: Bool -> String -> m (Maybe Name) + -- True <=> type namespace, False <=> value namespace + qReify :: Name -> m Info + qReifyInstances :: Name -> [Type] -> m [Dec] + -- Is (n tys) an instance? + -- Returns list of matching instance Decs + -- (with empty sub-Decs) + -- Works for classes and type functions qLocation :: m Loc qRunIO :: IO a -> m a -- ^ Input/output (dangerous) + qAddDependentFile :: FilePath -> m () ----------------------------------------------------- -- The IO instance of Quasi @@ -111,10 +119,12 @@ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + qLookupName _ _ = badIO "lookupName" qReify _ = badIO "reify" - qClassInstances _ _ = badIO "classInstances" + qReifyInstances _ _ = badIO "classInstances" qLocation = badIO "currentLocation" qRecover _ _ = badIO "recover" -- Maybe we could fix this? + qAddDependentFile _ = badIO "addDependentFile" qRunIO m = m @@ -148,6 +158,10 @@ instance Functor Q where fmap f (Q x) = Q (fmap f x) +instance Applicative Q where + pure x = Q (pure x) + Q f <*> Q x = Q (f <*> x) + ---------------------------------------------------- -- Packaged versions for the programmer, hiding the Quasi-ness newName :: String -> Q Name @@ -161,17 +175,26 @@ -> Q a recover (Q r) (Q m) = Q (qRecover r m) +-- We don't export lookupName; the Bool isn't a great API +-- Instead we export lookupTypeName, lookupValueName +lookupName :: Bool -> String -> Q (Maybe Name) +lookupName ns s = Q (qLookupName ns s) + +lookupTypeName, lookupValueName :: String -> Q (Maybe Name) +lookupTypeName s = Q (qLookupName True s) +lookupValueName s = Q (qLookupName False s) + -- | 'reify' looks up information about the 'Name' reify :: Name -> Q Info reify v = Q (qReify v) -- | 'classInstances' looks up instaces of a class -classInstances :: Name -> [Type] -> Q [ClassInstance] -classInstances cls tys = Q (qClassInstances cls tys) +reifyInstances :: Name -> [Type] -> Q [Dec] +reifyInstances cls tys = Q (qReifyInstances cls tys) -isClassInstance :: Name -> [Type] -> Q Bool -isClassInstance cls tys = do { dfuns <- classInstances cls tys - ; return (not (null dfuns)) } +isInstance :: Name -> [Type] -> Q Bool +isInstance nm tys = do { decs <- reifyInstances nm tys + ; return (not (null decs)) } -- | 'location' gives you the 'Location' at which this -- computation is spliced. @@ -188,14 +211,23 @@ 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. +-- Expects an absolute file path. +addDependentFile :: FilePath -> Q () +addDependentFile fp = Q (qAddDependentFile fp) + instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qClassInstances = classInstances - qLocation = location - qRunIO = runIO + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyInstances = reifyInstances + qLookupName = lookupName + qLocation = location + qRunIO = runIO + qAddDependentFile = addDependentFile ---------------------------------------------------- @@ -360,16 +392,12 @@ 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 | 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 + -- Need the namespace too to be sure which + -- thing we are naming deriving ( Typeable ) -- | @@ -576,7 +604,6 @@ = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod) where occ = mkOccName ('(' : replicate n_commas ',' ++ ")") - -- XXX Should it be GHC.Unit for 0 commas? tup_mod = mkModName "GHC.Tuple" -- Unboxed tuple data and type constructors @@ -626,7 +653,7 @@ -- and a list of its instances ClassI Dec -- Declaration of the class - [ClassInstance] -- The instances of that class + [InstanceDec] -- The instances of that class | ClassOpI Name -- The class op itself @@ -634,8 +661,13 @@ Name -- Name of the parent class Fixity - | TyConI Dec + | TyConI + Dec + | FamilyI -- Type/data families + Dec + [InstanceDec] + | PrimTyConI -- Ones that can't be expressed with a data type -- decl, such as (->), Int# Name @@ -661,15 +693,12 @@ Type -- What it is bound to deriving( Show, Data, Typeable ) --- | 'ClassInstance' desribes a single instance of a class -data ClassInstance - = ClassInstance { - ci_dfun :: Name, -- The witness - ci_tvs :: [TyVarBndr], - ci_cxt :: Cxt, - ci_cls :: Name, - ci_tys :: [Type] - } deriving( Show, Data, Typeable ) +-- | 'InstanceDec' desribes a single instance of a class or type function +-- It is just a 'Dec', but guaranteed to be one of the following: +-- InstanceD (with empty [Dec]) +-- DataInstD or NewtypeInstD (with empty derived [Name]) +-- TySynInstD +type InstanceDec = Dec data Fixity = Fixity Int FixityDirection deriving( Eq, Show, Data, Typeable ) @@ -689,6 +718,68 @@ -- ----------------------------------------------------- +{- $infix #infix# +Note [Unresolved infix] +~~~~~~~~~~~~~~~~~~~~~~~ + +When implementing antiquotation for quasiquoters, one often wants +to parse strings into expressions: + +> parse :: String -> Maybe 'Exp' + +But how should we parse @a + b * c@? If we don't know the fixities of +@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a ++ b) * c@. + +In cases like this, use 'UInfixE' or 'UInfixP', which stand for +\"unresolved infix expression\" and \"unresolved infix pattern\". When +the compiler is given a splice containing a tree of @UInfixE@ +applications such as + +> UInfixE +> (UInfixE e1 op1 e2) +> op2 +> (UInfixE e3 op3 e4) + +it will look up and the fixities of the relevant operators and +reassociate the tree as necessary. + + * trees will not be reassociated across 'ParensE' or 'ParensP', + which are of use for parsing expressions like + + > (a + b * c) + d * e + + * 'InfixE' and 'InfixP' expressions are never reassociated. + + * The 'UInfixE' constructor doesn't support sections. Sections + such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer + sections such as @(a + b * c -)@, use an 'InfixE' constructor for the + outer-most section, and use 'UInfixE' constructors for all + other operators: + + > InfixE + > Just (UInfixE ...a + b * c...) + > op + > Nothing + + Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered + into 'Exp's differently: + + > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b) + > -- will result in a fixity error if (+) is left-infix + > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b) + > -- no fixity errors + + * Quoted expressions such as + + > [| a * b + c |] :: Q Exp + > [p| a : b : c |] :: Q Pat + + will never contain 'UInfixE', 'UInfixP', 'ParensE', or 'ParensP' + constructors. + +-} + data Lit = CharL Char | StringL String | IntegerL Integer -- ^ Used for overloaded and non-overloaded @@ -715,6 +806,12 @@ | UnboxedTupP [Pat] -- ^ @{ (# p1,p2 #) }@ | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@ | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ + | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ + -- + -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" + | ParensP Pat -- ^ @{(p)}@ + -- + -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" | TildeP Pat -- ^ @{ ~p }@ | BangP Pat -- ^ @{ !p }@ | AsP Name Pat -- ^ @{ x \@ p }@ @@ -756,6 +853,12 @@ -- Maybe there should be a var-or-con type? -- Or maybe we should leave it to the String itself? + | UInfixE Exp Exp Exp -- ^ @{x + y}@ + -- + -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" + | ParensE Exp -- ^ @{ (e) }@ + -- + -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" | LamE [Pat] Exp -- ^ @{ \ p1 p2 -> e }@ | TupE [Exp] -- ^ @{ (e1,e2) } @ | UnboxedTupE [Exp] -- ^ @{ (# e1,e2 #) } @ @@ -862,7 +965,7 @@ | EqualP Type Type -- ^ @F a ~ Bool@ deriving( Show, Eq, Data, Typeable ) -data Strict = IsStrict | NotStrict +data Strict = IsStrict | NotStrict | Unpacked deriving( Show, Eq, Data, Typeable ) data Con = NormalC Name [StrictType] -- ^ @C Int a@ 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.6.0.0 +version: 2.7.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org