diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -6,39 +6,66 @@ -} module Language.Haskell.TH( -- * The monad and its operations - Q, runQ, - report, -- :: Bool -> String -> Q () + Q, + runQ, + -- ** Administration: errors, locations and IO + reportError, -- :: String -> Q () + reportWarning, -- :: String -> Q () + report, -- :: Bool -> String -> Q () recover, -- :: Q a -> Q a -> Q a - reify, -- :: Name -> Q Info - location, -- :: Q Location + location, -- :: Q Loc + Loc(..), runIO, -- :: IO a -> Q a - lookupTypeName, lookupValueName, - isInstance, reifyInstances, + -- ** Querying the compiler + -- *** Reify + reify, -- :: Name -> Q Info + Info(..), + InstanceDec, + ParentName, + Arity, + Unlifted, + -- *** Name lookup + lookupTypeName, -- :: String -> Q (Maybe Name) + lookupValueName, -- :: String -> Q (Maybe Name) + -- *** Instance lookup + reifyInstances, + isInstance, -- * 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 -- preferred to these constructors, since they compose better with -- quotations (@[| |]@) and splices (@$( ... )@) - Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..), Cxt, - Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..), - Range(..), Lit(..), Pat(..), FieldExp, FieldPat, + + -- ** Declarations + Dec(..), Con(..), Clause(..), Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..), - InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), Loc(..), + Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), + FunDep(..), FamFlavour(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, + -- ** Expressions + Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), + -- ** Patterns + Pat(..), FieldExp, FieldPat, + -- ** Types + Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred(..), -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, CxtQ, PredQ, MatchQ, ClauseQ, BodyQ, - GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ, - InlineSpecQ, + InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, ClauseQ, + BodyQ, GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ, + RuleBndrQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -51,30 +78,36 @@ 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, tupE, condE, letE, caseE, appsE, + infixE, infixApp, sectionL, sectionR, + lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, -- ***** Ranges with more indirection arithSeqE, - fromR, fromThenR, fromToR, fromThenToR, + fromR, fromThenR, fromToR, fromThenToR, -- **** Statements doE, compE, bindS, letS, noBindS, parS, -- *** Types - forallT, varT, conT, appT, arrowT, listT, tupleT, sigT, + forallT, varT, conT, appT, arrowT, listT, tupleT, sigT, litT, + promotedT, promotedTupleT, promotedNilT, promotedConsT, + -- **** Type literals + numTyLit, strTyLit, -- **** Strictness isStrict, notStrict, strictType, varStrictType, -- **** Class Contexts - cxt, classP, equalP, normalC, recC, infixC, + cxt, classP, equalP, normalC, recC, infixC, forallC, + -- *** Kinds + varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, + -- *** Top Level Declarations -- **** Data valD, funD, tySynD, dataD, newtypeD, @@ -82,18 +115,17 @@ classD, instanceD, sigD, -- **** Type Family / Data Family familyNoKindD, familyKindD, dataInstD, - newtypeInstD, tySynInstD, + newtypeInstD, tySynInstD, typeFam, dataFam, -- **** Foreign Function Interface (FFI) cCall, stdCall, unsafe, safe, forImpD, -- **** Pragmas - -- | Just inline supported so far - inlineSpecNoPhase, inlineSpecPhase, - pragInlD, pragSpecD, + ruleVar, typedRuleVar, + pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, -- * Pretty-printer Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType - + ) where import Language.Haskell.TH.Syntax 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 @@ -9,6 +9,7 @@ import Language.Haskell.TH.Syntax import Control.Monad( liftM, liftM2 ) +import Data.Word( Word8 ) ---------------------------------------------------------- -- * Type synonyms @@ -22,6 +23,7 @@ type DecsQ = Q [Dec] type ConQ = Q Con type TypeQ = Q Type +type TyLitQ = Q TyLit type CxtQ = Q Cxt type PredQ = Q Pred type MatchQ = Q Match @@ -33,7 +35,7 @@ type StrictTypeQ = Q StrictType type VarStrictTypeQ = Q VarStrictType type FieldExpQ = Q FieldExp -type InlineSpecQ = Q InlineSpec +type RuleBndrQ = Q RuleBndr ---------------------------------------------------------- -- * Lowercase pattern syntax functions @@ -53,7 +55,7 @@ charL = CharL stringL :: String -> Lit stringL = StringL -stringPrimL :: String -> Lit +stringPrimL :: [Word8] -> Lit stringPrimL = StringPrimL rationalL :: Rational -> Lit rationalL = RationalL @@ -240,6 +242,9 @@ lam1E :: PatQ -> ExpQ -> ExpQ lam1E p e = lamE [p] e +lamCaseE :: [MatchQ] -> ExpQ +lamCaseE ms = sequence ms >>= return . LamCaseE + tupE :: [ExpQ] -> ExpQ tupE es = do { es1 <- sequence es; return (TupE es1)} @@ -249,6 +254,9 @@ condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} +multiIfE :: [Q (Guard, Exp)] -> ExpQ +multiIfE alts = sequence alts >>= return . MultiIfE + letE :: [DecQ] -> ExpQ -> ExpQ letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } @@ -354,25 +362,45 @@ = do ty' <- ty return $ ForeignD (ImportF cc s str n ty') -pragInlD :: Name -> InlineSpecQ -> DecQ -pragInlD n ispec +infixLD :: Int -> Name -> DecQ +infixLD prec nm = return (InfixD (Fixity prec InfixL) nm) + +infixRD :: Int -> Name -> DecQ +infixRD prec nm = return (InfixD (Fixity prec InfixR) nm) + +infixND :: Int -> Name -> DecQ +infixND prec nm = return (InfixD (Fixity prec InfixN) nm) + +pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ +pragInlD name inline rm phases + = return $ PragmaD $ InlineP name inline rm phases + +pragSpecD :: Name -> TypeQ -> Phases -> DecQ +pragSpecD n ty phases = do - ispec1 <- ispec - return $ PragmaD (InlineP n ispec1) + ty1 <- ty + return $ PragmaD $ SpecialiseP n ty1 Nothing phases -pragSpecD :: Name -> TypeQ -> DecQ -pragSpecD n ty +pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ +pragSpecInlD n ty inline phases = do ty1 <- ty - return $ PragmaD (SpecialiseP n ty1 Nothing) + return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases -pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ -pragSpecInlD n ty ispec +pragSpecInstD :: TypeQ -> DecQ +pragSpecInstD ty = do ty1 <- ty - ispec1 <- ispec - return $ PragmaD (SpecialiseP n ty1 (Just ispec1)) + return $ PragmaD $ SpecialiseInstP ty1 +pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ +pragRuleD n bndrs lhs rhs phases + = do + bndrs1 <- sequence bndrs + lhs1 <- lhs + rhs1 <- rhs + return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases + familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing @@ -460,6 +488,9 @@ listT :: TypeQ listT = return ListT +litT :: TyLitQ -> TypeQ +litT l = fmap LitT l + tupleT :: Int -> TypeQ tupleT i = return (TupleT i) @@ -472,6 +503,18 @@ t' <- t return $ SigT t' k +promotedT :: Name -> TypeQ +promotedT = return . PromotedT + +promotedTupleT :: Int -> TypeQ +promotedTupleT i = return (PromotedTupleT i) + +promotedNilT :: TypeQ +promotedNilT = return PromotedNilT + +promotedConsT :: TypeQ +promotedConsT = return PromotedConsT + isStrict, notStrict, unpacked :: Q Strict isStrict = return $ IsStrict notStrict = return $ NotStrict @@ -484,6 +527,17 @@ varStrictType v st = do (s, t) <- st return (v, s, t) +-- * Type Literals + +numTyLit :: Integer -> TyLitQ +numTyLit n = if n >= 0 then return (NumTyLit n) + else fail ("Negative type-level number: " ++ show n) + +strTyLit :: String -> TyLitQ +strTyLit s = return (StrTyLit s) + + + ------------------------------------------------------------------------------- -- * Kind @@ -493,11 +547,29 @@ kindedTV :: Name -> Kind -> TyVarBndr kindedTV = KindedTV +varK :: Name -> Kind +varK = VarT + +conK :: Name -> Kind +conK = ConT + +tupleK :: Int -> Kind +tupleK = TupleT + +arrowK :: Kind +arrowK = ArrowT + +listK :: Kind +listK = ListT + +appK :: Kind -> Kind -> Kind +appK = AppT + starK :: Kind -starK = StarK +starK = StarT -arrowK :: Kind -> Kind -> Kind -arrowK = ArrowK +constraintK :: Kind +constraintK = ConstraintT ------------------------------------------------------------------------------- -- * Callconv @@ -515,17 +587,6 @@ interruptible = Interruptible ------------------------------------------------------------------------------- --- * 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 @@ -537,6 +598,14 @@ typeFam, dataFam :: FamFlavour typeFam = TypeFam dataFam = DataFam + +------------------------------------------------------------------------------- +-- * RuleBndr +ruleVar :: Name -> RuleBndrQ +ruleVar = return . RuleVar + +typedRuleVar :: Name -> TypeQ -> RuleBndrQ +typedRuleVar n ty = ty >>= return . TypedRuleVar n -------------------------------------------------------------- -- * Useful helper function 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 @@ -9,7 +9,8 @@ import Text.PrettyPrint (render) import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax -import Data.Char ( toLower ) +import Data.Word ( Word8 ) +import Data.Char ( toLower, chr ) import GHC.Show ( showMultiLineString ) nestDepth :: Int @@ -105,6 +106,8 @@ <+> pprMaybeExp noPrec me2 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) <+> text "->" <+> ppr e +pprExp i (LamCaseE ms) = parensIf (i > noPrec) + $ text "\\case" $$ nest nestDepth (ppr ms) pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es -- Nesting in Cond is to avoid potential problems in do statments @@ -112,6 +115,12 @@ = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, nest 1 $ text "then" <+> ppr true, nest 1 $ text "else" <+> ppr false] +pprExp i (MultiIfE alts) + = parensIf (i > noPrec) $ vcat $ + case alts of + [] -> [text "if {}"] + (alt : alts') -> text "if" <+> pprGuarded arrow alt + : map (nest 3 . pprGuarded arrow) alts' pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds $$ text " in" <+> ppr e pprExp i (CaseE e ms) @@ -153,13 +162,19 @@ $$ where_clause ds ------------------------------ +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) $$ + nest nestDepth (eqDoc <+> ppr expr) + +------------------------------ pprBody :: Bool -> Body -> Doc -pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs - where eqd = if eq then text "=" else text "->" - do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e - do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss) - $$ nest nestDepth (eqd <+> ppr e) -pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e +pprBody eq body = case body of + GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs + NormalB e -> eqDoc <+> ppr e + where eqDoc | eq = equals + | otherwise = arrow ------------------------------ pprLit :: Precedence -> Lit -> Doc @@ -173,9 +188,12 @@ pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) pprLit _ (CharL c) = text (show c) pprLit _ (StringL s) = pprString s -pprLit _ (StringPrimL s) = pprString s <> char '#' +pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat +bytesToString :: [Word8] -> String +bytesToString = map (chr . fromIntegral) + pprString :: String -> Doc -- Print newlines as newlines with Haskell string escape notation, -- not as '\n'. For other non-printables use regular escape notation. @@ -235,9 +253,10 @@ $$ 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 _ (SigD f t) = ppr f <+> text "::" <+> ppr t +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 flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind where @@ -323,35 +342,54 @@ ------------------------------ instance Ppr Pragma where - ppr (InlineP n (InlineSpec inline conlike activation)) + ppr (InlineP n inline rm phases) = text "{-#" - <+> (if inline then text "INLINE" else text "NOINLINE") - <+> (if conlike then text "CONLIKE" else empty) - <+> ppr_activation activation + <+> ppr inline + <+> ppr rm + <+> ppr phases <+> 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 (SpecialiseP n ty inline phases) + = text "{-# SPECIALISE" + <+> maybe empty ppr inline + <+> ppr phases + <+> sep [ ppr n <+> text "::" + , nest 2 $ ppr ty ] + <+> text "#-}" + ppr (SpecialiseInstP inst) + = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}" + ppr (RuleP n bndrs lhs rhs phases) + = sep [ text "{-# RULES" <+> pprString n <+> ppr phases + , nest 4 $ ppr_forall <+> ppr lhs + , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ] + where ppr_forall | null bndrs = empty + | otherwise = text "forall" + <+> fsep (map ppr bndrs) + <+> char '.' -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 Inline where + ppr NoInline = text "NOINLINE" + ppr Inline = text "INLINE" + ppr Inlinable = text "INLINABLE" ------------------------------ +instance Ppr RuleMatch where + ppr ConLike = text "CONLIKE" + ppr FunLike = empty + +------------------------------ +instance Ppr Phases where + ppr AllPhases = empty + ppr (FromPhase i) = brackets $ int i + ppr (BeforePhase i) = brackets $ char '~' <> int i + +------------------------------ +instance Ppr RuleBndr where + ppr (RuleVar n) = ppr n + ppr (TypedRuleVar n ty) = parens $ ppr n <+> text "::" <+> ppr ty + +------------------------------ instance Ppr Clause where ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs $$ where_clause ds @@ -381,14 +419,22 @@ ------------------------------ pprParendType :: Type -> Doc -pprParendType (VarT v) = ppr v -pprParendType (ConT c) = ppr c -pprParendType (TupleT 0) = text "()" -pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) -pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma -pprParendType ArrowT = parens (text "->") -pprParendType ListT = text "[]" -pprParendType other = parens (ppr other) +pprParendType (VarT v) = ppr v +pprParendType (ConT c) = ppr c +pprParendType (TupleT 0) = text "()" +pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) +pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma +pprParendType ArrowT = parens (text "->") +pprParendType ListT = text "[]" +pprParendType (LitT l) = pprTyLit l +pprParendType (PromotedT c) = text "'" <> ppr c +pprParendType (PromotedTupleT 0) = text "'()" +pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) +pprParendType PromotedNilT = text "'[]" +pprParendType PromotedConsT = text "(':)" +pprParendType StarT = char '*' +pprParendType ConstraintT = text "Constraint" +pprParendType other = parens (ppr other) instance Ppr Type where ppr (ForallT tvars ctxt ty) @@ -402,6 +448,8 @@ pprTyApp (ListT, [arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) | length args == n = parens (sep (punctuate comma (map ppr args))) +pprTyApp (PromotedTupleT n, args) + | 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 @@ -416,19 +464,18 @@ where go (AppT t1 t2) args = go t1 (t2:args) go ty args = (ty, args) +pprTyLit :: TyLit -> Doc +pprTyLit (NumTyLit n) = integer n +pprTyLit (StrTyLit s) = text (show s) + +instance Ppr TyLit where + ppr = pprTyLit + ------------------------------ 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 @@ -462,4 +509,7 @@ hashParens :: Doc -> Doc hashParens d = text "(# " <> d <> text " #)" + +quoteParens :: Doc -> Doc +quoteParens d = text "'(" <> d <> text ")" 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 @@ -10,7 +10,7 @@ -- * Primitive Documents empty, - semi, comma, colon, space, equals, + semi, comma, colon, space, equals, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- * Converting values into documents @@ -63,6 +63,7 @@ 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 @@ -163,6 +164,7 @@ colon = return HPJ.colon space = return HPJ.space equals = return HPJ.equals +arrow = return $ HPJ.text "->" lparen = return HPJ.lparen rparen = return HPJ.rparen lbrack = return HPJ.lbrack 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 @@ -31,9 +31,9 @@ conName :: Name conName = case showConstr constr of - "(:)" -> Name (mkOccName ":") NameS - con@"[]" -> Name (mkOccName con) NameS - con@('(':_) -> Name (mkOccName con) NameS + "(:)" -> Name (mkOccName ":") (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types")) + con@"[]" -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types")) + con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Tuple")) con -> mkNameG_d (tyConPackage tycon) (tyConModule tycon) con 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 @@ -20,43 +20,10 @@ -- ----------------------------------------------------------------------------- -module Language.Haskell.TH.Syntax( - Quasi(..), Lift(..), liftString, - - Q, runQ, - 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, - Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..), - InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..), - Info(..), Loc(..), CharPos, - Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, - - -- * Internal functions - returnQ, bindQ, sequenceQ, - NameFlavour(..), NameSpace (..), - mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU, - tupleTypeName, tupleDataName, - unboxedTupleTypeName, unboxedTupleDataName, - OccName, mkOccName, occString, - ModName, mkModName, modString, - PkgName, mkPkgName, pkgString - ) where +module Language.Haskell.TH.Syntax where import GHC.Base ( Int(..), Int#, (<#), (==#) ) -import Language.Haskell.TH.Syntax.Internals import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex) import qualified Data.Data as Data import Control.Applicative( Applicative(..) ) @@ -65,6 +32,7 @@ import Control.Monad (liftM) import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha ) +import Data.Word ( Word8 ) ----------------------------------------------------- -- @@ -146,6 +114,17 @@ newtype Q a = Q { unQ :: forall m. Quasi m => m a } +-- \"Runs\" the 'Q' monad. Normal users of Template Haskell +-- should not need this function, as the splice brackets @$( ... )@ +-- are the usual way of running a 'Q' computation. +-- +-- This function is primarily used in GHC internals, and for debugging +-- splices by running them in 'IO'. +-- +-- Note that many functions in 'Q', such as 'reify' and other compiler +-- queries, are not supported when running 'Q' in 'IO'; these operations +-- simply fail at runtime. Indeed, the only operations guaranteed to succeed +-- are 'newName', 'runIO', 'reportError' and 'reportWarning'. runQ :: Quasi m => Q a -> m a runQ (Q m) = m @@ -164,14 +143,61 @@ ---------------------------------------------------- -- Packaged versions for the programmer, hiding the Quasi-ness + +{- | +Generate a fresh name, which cannot be captured. + +For example, this: + +@f = $(do + nm1 <- newName \"x\" + let nm2 = 'mkName' \"x\" + return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1))) + )@ + +will produce the splice + +>f = \x0 -> \x -> x0 + +In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@, +and is not captured by the binding @VarP nm2@. + +Although names generated by @newName@ cannot /be captured/, they can +/capture/ other names. For example, this: + +>g = $(do +> nm1 <- newName "x" +> let nm2 = mkName "x" +> return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2))) +> ) + +will produce the splice + +>g = \x -> \x0 -> x0 + +since the occurrence @VarE nm2@ is captured by the innermost binding +of @x@, namely @VarP nm1@. +-} newName :: String -> Q Name newName s = Q (qNewName s) +-- | Report an error (True) or warning (False), +-- but carry on; use 'fail' to stop. report :: Bool -> String -> Q () report b s = Q (qReport b s) +{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -recover :: Q a -- ^ recover with this one - -> Q a -- ^ failing action +-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. +reportError :: String -> Q () +reportError = report True + +-- | Report a warning to the user, and carry on. +reportWarning :: String -> Q () +reportWarning = report False + +-- | Recover from errors raised by 'reportError' or 'fail'. +recover :: Q a -- ^ handler to invoke on failure + -> Q a -- ^ computation to run -> Q a recover (Q r) (Q m) = Q (qRecover r m) @@ -180,24 +206,100 @@ lookupName :: Bool -> String -> Q (Maybe Name) lookupName ns s = Q (qLookupName ns s) -lookupTypeName, lookupValueName :: String -> Q (Maybe Name) +-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. +lookupTypeName :: String -> Q (Maybe Name) lookupTypeName s = Q (qLookupName True s) + +-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. +lookupValueName :: String -> Q (Maybe Name) lookupValueName s = Q (qLookupName False s) --- | 'reify' looks up information about the 'Name' +{- +Note [Name lookup] +~~~~~~~~~~~~~~~~~~ +-} +{- $namelookup #namelookup# +The functions 'lookupTypeName' and 'lookupValueName' provide +a way to query the current splice's context for what names +are in scope. The function 'lookupTypeName' queries the type +namespace, whereas 'lookupValueName' queries the value namespace, +but the functions are otherwise identical. + +A call @lookupValueName s@ will check if there is a value +with name @s@ in scope at the current splice's location. If +there is, the @Name@ of this value is returned; +if not, then @Nothing@ is returned. + +The returned name cannot be \"captured\". +For example: + +> f = "global" +> g = $( do +> Just nm <- lookupValueName "f" +> [| let f = "local" in $( varE nm ) |] + +In this case, @g = \"global\"@; the call to @lookupValueName@ +returned the global @f@, and this name was /not/ captured by +the local definition of @f@. + +The lookup is performed in the context of the /top-level/ splice +being run. For example: + +> f = "global" +> g = $( [| let f = "local" in +> $(do +> Just nm <- lookupValueName "f" +> varE nm +> ) |] ) + +Again in this example, @g = \"global\"@, because the call to +@lookupValueName@ queries the context of the outer-most @$(...)@. + +Operators should be queried without any surrounding parentheses, like so: + +> lookupValueName "+" + +Qualified names are also supported, like so: + +> lookupValueName "Prelude.+" +> lookupValueName "Prelude.map" + +-} + + +{- | 'reify' looks up information about the 'Name'. + +It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName' +to ensure that we are reifying from the right namespace. For instance, in this context: + +> data D = D + +which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.) +To ensure we get information about @D@-the-value, use 'lookupValueName': + +> do +> Just nm <- lookupValueName "D" +> reify nm + +and to get information about @D@-the-type, use 'lookupTypeName'. +-} reify :: Name -> Q Info reify v = Q (qReify v) --- | 'classInstances' looks up instaces of a class -reifyInstances :: Name -> [Type] -> Q [Dec] +{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, +if @nm@ is the name of a type class, then all instances of this class at the types @tys@ +are returned. Alternatively, if @nm@ is the name of a data family or type family, +all instances of this family at the types @tys@ are returned. +-} +reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys) +-- | Is the list of instances returned by 'reifyInstances' nonempty? 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. +-- | The location at which this computation is spliced. location :: Q Loc location = Q qLocation @@ -334,6 +436,15 @@ -- Names and uniques ----------------------------------------------------- +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) + mkModName :: String -> ModName mkModName s = ModName s @@ -362,8 +473,7 @@ ----------------------------------------------------- -- Names ----------------------------------------------------- - --- | +-- -- For "global" names ('NameG') we need a totally unique name, -- so we must include the name-space of the thing -- @@ -387,6 +497,63 @@ -- The 'map' will be a NameG, and 'x' wil be a NameL -- -- These Names should never appear in a binding position in a TH syntax tree + +{- $namecapture #namecapture# +Much of 'Name' API is concerned with the problem of /name capture/, which +can be seen in the following example. + +> f expr = [| let x = 0 in $expr |] +> ... +> g x = $( f [| x |] ) +> h y = $( f [| y |] ) + +A naive desugaring of this would yield: + +> g x = let x = 0 in x +> h y = let x = 0 in y + +All of a sudden, @g@ and @h@ have different meanings! In this case, +we say that the @x@ in the RHS of @g@ has been /captured/ +by the binding of @x@ in @f@. + +What we actually want is for the @x@ in @f@ to be distinct from the +@x@ in @g@, so we get the following desugaring: + +> g x = let x' = 0 in x +> h y = let x' = 0 in y + +which avoids name capture as desired. + +In the general case, we say that a @Name@ can be captured if +the thing it refers to can be changed by adding new declarations. +-} + +{- | +An abstract type representing names in the syntax tree. + +'Name's can be constructed in several ways, which come with different +name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for +an explanation of name capture): + + * the built-in syntax @'f@ and @''T@ can be used to construct names, + The expression @'f@ gives a @Name@ which refers to the value @f@ + currently in scope, and @''T@ gives a @Name@ which refers to the + type @T@ currently in scope. These names can never be captured. + + * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and + @''T@ respectively, but the @Name@s are looked up at the point + where the current splice is being run. These names can never be + captured. + + * 'newName' monadically generates a new name, which can never + be captured. + + * 'mkName' generates a capturable name. + +Names constructed using @newName@ and @mkName@ may be used in bindings +(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 NameFlavour @@ -451,17 +618,42 @@ type Uniq = Int --- | Base, unqualified name. +-- | The name without its module prefix nameBase :: Name -> String nameBase (Name occ _) = occString occ +-- | Module prefix of a name, if it exists nameModule :: Name -> Maybe String nameModule (Name _ (NameQ m)) = Just (modString m) nameModule (Name _ (NameG _ _ m)) = Just (modString m) nameModule _ = Nothing +{- | +Generate a capturable name. Occurrences of such names will be +resolved according to the Haskell scoping rules at the occurrence +site. + +For example: + +> f = [| pi + $(varE (mkName "pi")) |] +> ... +> g = let pi = 3 in $f + +In this case, @g@ is desugared to + +> g = Prelude.pi + 3 + +Note that @mkName@ may be used with qualified names: + +> mkName "Prelude.pi" + +See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could +be rewritten using 'dyn' as + +> f = [| pi + $(dyn "pi") |] +-} mkName :: String -> Name --- ^ The string can have a '.', thus "Foo.baz", +-- The string can have a '.', thus "Foo.baz", -- giving a dynamically-bound qualified name, -- in which case we want to generate a NameQ -- @@ -588,8 +780,10 @@ show = showName -- Tuple data and type constructors -tupleDataName :: Int -> Name -- ^ Data constructor -tupleTypeName :: Int -> Name -- ^ Type constructor +-- | Tuple data constructor +tupleDataName :: Int -> Name +-- | Tuple type constructor +tupleTypeName :: Int -> Name tupleDataName 0 = mk_tup_name 0 DataName tupleDataName 1 = error "tupleDataName 1" @@ -607,8 +801,10 @@ tup_mod = mkModName "GHC.Tuple" -- Unboxed tuple data and type constructors -unboxedTupleDataName :: Int -> Name -- ^ Data constructor -unboxedTupleTypeName :: Int -> Name -- ^ Type constructor +-- | Unboxed tuple data constructor +unboxedTupleDataName :: Int -> Name +-- | Unboxed tuple type constructor +unboxedTupleTypeName :: Int -> Name unboxedTupleDataName 0 = error "unboxedTupleDataName 0" unboxedTupleDataName 1 = error "unboxedTupleDataName 1" @@ -638,7 +834,7 @@ , loc_start :: CharPos , loc_end :: CharPos } -type CharPos = (Int, Int) -- Line and character position +type CharPos = (Int, Int) -- ^ Line and character position ----------------------------------------------------- @@ -649,55 +845,88 @@ -- | Obtained from 'reify' in the 'Q' Monad. data Info - = -- | A class is reified to its declaration - -- and a list of its instances - ClassI - Dec -- Declaration of the class - [InstanceDec] -- The instances of that class - + = + -- | A class, with a list of its visible instances + ClassI + Dec + [InstanceDec] + + -- | A class method | ClassOpI - Name -- The class op itself - Type -- Type of the class-op (fully polymoprhic) - Name -- Name of the parent class - Fixity - + Name + Type + ParentName + Fixity + + -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate | TyConI Dec - | FamilyI -- Type/data families + -- | A type or data family, with a list of its visible instances + | FamilyI Dec [InstanceDec] - - | PrimTyConI -- Ones that can't be expressed with a data type - -- decl, such as (->), Int# - Name - Int -- Arity - Bool -- False => lifted type; True => unlifted - + + -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. Examples: @(->)@, @Int#@. + | PrimTyConI + Name + Arity + Unlifted + + -- | A data constructor | DataConI - Name -- The data con itself - Type -- Type of the constructor (fully polymorphic) - Name -- Name of the parent TyCon - Fixity + Name + Type + ParentName + Fixity + {- | + A \"value\" variable (as opposed to a type variable, see 'TyVarI'). + + The @Maybe Dec@ field contains @Just@ the declaration which + defined the variable -- including the RHS of the declaration -- + or else @Nothing@, in the case where the RHS is unavailable to + the compiler. At present, this value is _always_ @Nothing@: + returning the RHS has not yet been implemented because of + lack of interest. + -} | VarI - Name -- The variable itself - Type - (Maybe Dec) -- Nothing for lambda-bound variables, and - -- for anything else TH can't figure out - -- E.g. [| let x = 1 in $(do { d <- reify 'x; .. }) |] - Fixity + Name + Type + (Maybe Dec) + Fixity + {- | + A type variable. + + The @Type@ field contains the type which underlies the variable. + 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 ) --- | 'InstanceDec' desribes a single instance of a class or type function +{- | +In 'ClassOpI' and 'DataConI', name of the parent class or type +-} +type ParentName = Name + +-- | In 'PrimTyConI', arity of the type constructor +type Arity = Int + +-- | In 'PrimTyConI', is the type constructor unlifted? +type Unlifted = Bool + +-- | '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 +-- +-- * 'InstanceD' (with empty @['Dec']@) +-- +-- * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@) +-- +-- * 'TySynInstD' type InstanceDec = Dec data Fixity = Fixity Int FixityDirection @@ -705,27 +934,24 @@ data FixityDirection = InfixL | InfixR | InfixN deriving( Eq, Show, Data, Typeable ) +-- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) maxPrecedence :: Int maxPrecedence = (9::Int) +-- | Default fixity: @infixl 9@ defaultFixity :: Fixity defaultFixity = Fixity maxPrecedence InfixL ------------------------------------------------------ --- --- The main syntax data types --- ------------------------------------------------------ - -{- $infix #infix# +{- Note [Unresolved infix] ~~~~~~~~~~~~~~~~~~~~~~~ - +-} +{- $infix #infix# When implementing antiquotation for quasiquoters, one often wants to parse strings into expressions: -> parse :: String -> Maybe 'Exp' +> 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 @@ -780,6 +1006,12 @@ -} +----------------------------------------------------- +-- +-- The main syntax data types +-- +----------------------------------------------------- + data Lit = CharL Char | StringL String | IntegerL Integer -- ^ Used for overloaded and non-overloaded @@ -791,7 +1023,7 @@ | WordPrimL Integer | FloatPrimL Rational | DoublePrimL Rational - | StringPrimL String -- ^ A primitive C-style string, type Addr# + | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# deriving( Show, Eq, Data, Typeable ) -- We could add Int, Float, Double etc, as we do in HsLit, @@ -808,10 +1040,10 @@ | 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" + -- See "Language.Haskell.TH.Syntax#infix" | ParensP Pat -- ^ @{(p)}@ -- - -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" + -- See "Language.Haskell.TH.Syntax#infix" | TildeP Pat -- ^ @{ ~p }@ | BangP Pat -- ^ @{ !p }@ | AsP Name Pat -- ^ @{ x \@ p }@ @@ -830,15 +1062,6 @@ -- ^ @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. translation: --- --- > [ f x | x <- xs ] --- --- > 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 @ @@ -846,7 +1069,7 @@ | AppE Exp Exp -- ^ @{ f x }@ | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@ - -- + -- It's a bit gruesome to use an Exp as the -- operator, but how else can we distinguish -- constructors from non-constructors? @@ -855,18 +1078,30 @@ | UInfixE Exp Exp Exp -- ^ @{x + y}@ -- - -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" + -- See "Language.Haskell.TH.Syntax#infix" | ParensE Exp -- ^ @{ (e) }@ -- - -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" + -- See "Language.Haskell.TH.Syntax#infix" | LamE [Pat] Exp -- ^ @{ \ p1 p2 -> e }@ + | LamCaseE [Match] -- ^ @{ \case m1; m2 }@ | TupE [Exp] -- ^ @{ (e1,e2) } @ | UnboxedTupE [Exp] -- ^ @{ (# e1,e2 #) } @ | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@ + | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@ - | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@ + | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@ + -- + -- The result expression of the comprehension is + -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'. + -- + -- E.g. translation: + -- + -- > [ f x | x <- xs ] + -- + -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))] + | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@ | ListE [ Exp ] -- ^ @{ [1,2,3] }@ | SigE Exp Type -- ^ @{ e :: t }@ @@ -879,13 +1114,15 @@ -- Omitted: implicit parameters data Body - = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2 | e3 = e4 } where ds@ + = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2 + -- | e3 = e4 } + -- where ds@ | NormalB Exp -- ^ @f p { = e } where ds@ deriving( Show, Eq, Data, Typeable ) data Guard - = NormalG Exp - | PatG [Stmt] + = NormalG Exp -- ^ @f x { | odd x } = x@ + | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@ deriving( Show, Eq, Data, Typeable ) data Stmt @@ -914,10 +1151,13 @@ | InstanceD Cxt Type [Dec] -- ^ @{ instance Show w => Show [w] -- where ds }@ | SigD Name Type -- ^ @{ length :: [a] -> Int }@ - | ForeignD Foreign + | ForeignD Foreign -- ^ @{ foreign import ... } + --{ foreign export ... }@ + | InfixD Fixity Name -- ^ @{ infix 3 foo }@ + -- | pragmas - | PragmaD Pragma -- ^ @{ {-# INLINE [1] foo #-} }@ + | PragmaD Pragma -- ^ @{ {\-# INLINE [1] foo #-\} }@ -- | type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | FamilyD FamFlavour Name @@ -949,16 +1189,30 @@ data Safety = Unsafe | Safe | Interruptible deriving( Show, Eq, Data, Typeable ) -data Pragma = InlineP Name InlineSpec - | SpecialiseP Name Type (Maybe InlineSpec) +data Pragma = InlineP Name Inline RuleMatch Phases + | SpecialiseP Name Type (Maybe Inline) Phases + | SpecialiseInstP Type + | RuleP String [RuleBndr] Exp Exp Phases 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 ) +data Inline = NoInline + | Inline + | Inlinable + deriving (Show, Eq, Data, Typeable) +data RuleMatch = ConLike + | FunLike + deriving (Show, Eq, Data, Typeable) + +data Phases = AllPhases + | FromPhase Int + | BeforePhase Int + deriving (Show, Eq, Data, Typeable) + +data RuleBndr = RuleVar Name + | TypedRuleVar Name Type + deriving (Show, Eq, Data, Typeable) + type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ data Pred = ClassP Name [Type] -- ^ @Eq (Int, a)@ @@ -977,24 +1231,73 @@ type StrictType = (Strict, Type) type VarStrictType = (Name, Strict, Type) -data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall . -> @ +data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ -> \@ + | AppT Type Type -- ^ @T a b@ + | SigT Type Kind -- ^ @t :: k@ | VarT Name -- ^ @a@ | ConT Name -- ^ @T@ + | PromotedT Name -- ^ @'T@ + + -- See Note [Representing concrete syntax in types] | TupleT Int -- ^ @(,), (,,), etc.@ | UnboxedTupleT Int -- ^ @(#,#), (#,,#), etc.@ | ArrowT -- ^ @->@ | ListT -- ^ @[]@ - | AppT Type Type -- ^ @T a b@ - | SigT Type Kind -- ^ @t :: k@ + | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ + | PromotedNilT -- ^ @'[]@ + | PromotedConsT -- ^ @(':)@ + | StarT -- ^ @*@ + | ConstraintT -- ^ @Constraint@ + | LitT TyLit -- ^ @0,1,2, etc.@ 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 ) +data TyLit = NumTyLit Integer -- ^ @2@ + | StrTyLit String -- ^ @"Hello"@ + deriving ( Show, Eq, Data, Typeable ) + +-- | To avoid duplication between kinds and types, they +-- are defined to be the same. Naturally, you would never +-- have a type be 'StarT' and you would never have a kind +-- be 'SigT', but many of the other constructors are shared. +-- Note that the kind @Bool@ is denoted with 'ConT', not +-- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT', +-- not 'PromotedTupleT'. + +type Kind = Type + +{- Note [Representing concrete syntax in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Haskell has a rich concrete syntax for types, including + t1 -> t2, (t1,t2), [t], and so on +In TH we represent all of this using AppT, with a distinguished +type construtor at the head. So, + Type TH representation + ----------------------------------------------- + t1 -> t2 ArrowT `AppT` t2 `AppT` t2 + [t] ListT `AppT` t + (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 +these special TH constructors. For example + [] t ConT "[]" `AppT` t + (->) t ConT "->" `AppT` t +In this way we can faithfully represent in TH whether the original +HsType used concrete syntax or not. + +The one case that doesn't fit this pattern is that of promoted lists + '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2 +but it's very smelly because there really is no type constructor +corresponding to PromotedListT. So we encode HsExplicitListTy with +PromotedConsT and PromotedNilT (which *do* have underlying type +constructors): + '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT` + (PromotedConsT `AppT` IO `AppT` PromotedNilT) +-} ----------------------------------------------------- -- Internal helper functions diff --git a/Language/Haskell/TH/Syntax/Internals.hs b/Language/Haskell/TH/Syntax/Internals.hs deleted file mode 100644 --- a/Language/Haskell/TH/Syntax/Internals.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# 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) 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.7.0.0 +version: 2.8.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -13,7 +13,6 @@ build-depends: base >= 4.2 && < 5, pretty, containers exposed-modules: - Language.Haskell.TH.Syntax.Internals Language.Haskell.TH.Syntax Language.Haskell.TH.PprLib Language.Haskell.TH.Ppr