diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -20,10 +20,10 @@ -- *** Reify reify, -- :: Name -> Q Info reifyModule, - thisModule, Info(..), ModuleInfo(..), InstanceDec, ParentName, + SumAlt, SumArity, Arity, Unlifted, -- *** Language extension lookup @@ -60,6 +60,8 @@ -- ** Built-in names tupleTypeName, tupleDataName, -- Int -> Name unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name + unboxedSumTypeName, -- :: SumArity -> Name + unboxedSumDataName, -- :: SumAlt -> SumArity -> Name -- * The algebraic data types -- | The lowercase versions (/syntax operators/) of these constructors are @@ -73,94 +75,19 @@ Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, + PatSynDir(..), PatSynArgs(..), -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), -- ** Patterns Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), - FamilyResultSig(..), Syntax.InjectivityAnn(..), + FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, -- * Library functions - -- ** Abbreviations - InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, - ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, - SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, - VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, - - -- ** Constructors lifted to 'Q' - -- *** Literals - intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, - charL, stringL, stringPrimL, charPrimL, - -- *** Patterns - litP, varP, tupP, conP, uInfixP, parensP, infixP, - tildeP, bangP, asP, wildP, recP, - listP, sigP, viewP, - fieldPat, - - -- *** Pattern Guards - normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, - - -- *** Expressions - dyn, varE, conE, litE, appE, uInfixE, parensE, staticE, - 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, - -- **** Statements - doE, compE, - bindS, letS, noBindS, parS, - - -- *** Types - forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, - listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT, - promotedConsT, - -- **** Type literals - numTyLit, strTyLit, - -- **** Strictness - noSourceUnpackedness, sourceNoUnpack, sourceUnpack, - noSourceStrictness, sourceLazy, sourceStrict, - isStrict, notStrict, unpacked, - bang, bangType, varBangType, strictType, varStrictType, - -- **** Class Contexts - cxt, classP, equalP, - -- **** Constructors - normalC, recC, infixC, forallC, gadtC, recGadtC, - - -- *** Kinds - varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, - - -- *** Roles - nominalR, representationalR, phantomR, inferR, - - -- *** Top Level Declarations - -- **** Data - valD, funD, tySynD, dataD, newtypeD, - -- **** Class - classD, instanceD, instanceWithOverlapD, Overlap(..), - sigD, standaloneDerivD, defaultSigD, - - -- **** Role annotations - roleAnnotD, - -- **** Type Family / Data Family - dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, - familyNoKindD, familyKindD, closedTypeFamilyNoKindD, closedTypeFamilyKindD, - newtypeInstD, tySynInstD, - typeFam, dataFam, tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, - -- **** Foreign Function Interface (FFI) - cCall, stdCall, cApi, prim, javaScript, - unsafe, safe, forImpD, - -- **** Pragmas - ruleVar, typedRuleVar, - pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD, - pragLineD, + module Language.Haskell.TH.Lib, - -- * Pretty-printer + -- * Pretty-printer Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType ) where 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 @@ -4,11 +4,113 @@ {-# LANGUAGE CPP #-} -module Language.Haskell.TH.Lib where +module Language.Haskell.TH.Lib ( -- All of the exports from this module should -- be "public" functions. The main module TH -- re-exports them all. + -- * Library functions + -- ** Abbreviations + InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, + DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, + SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, + StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, + TySynEqnQ, PatSynDirQ, PatSynArgsQ, + + -- ** Constructors lifted to 'Q' + -- *** Literals + intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, + charL, stringL, stringPrimL, charPrimL, + -- *** Patterns + litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP, + infixP, tildeP, bangP, asP, wildP, recP, + listP, sigP, viewP, + fieldPat, + + -- *** Pattern Guards + normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, + + -- *** Expressions + dyn, varE, unboundVarE, conE, litE, appE, appTypeE, uInfixE, parensE, + staticE, infixE, infixApp, sectionL, sectionR, + lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, 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, + -- **** Statements + doE, compE, + bindS, letS, noBindS, parS, + + -- *** Types + forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, + listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, + promotedT, promotedTupleT, promotedNilT, promotedConsT, + -- **** Type literals + numTyLit, strTyLit, + -- **** Strictness + noSourceUnpackedness, sourceNoUnpack, sourceUnpack, + noSourceStrictness, sourceLazy, sourceStrict, + isStrict, notStrict, unpacked, + bang, bangType, varBangType, strictType, varStrictType, + -- **** Class Contexts + cxt, classP, equalP, + -- **** Constructors + normalC, recC, infixC, forallC, gadtC, recGadtC, + + -- *** Kinds + varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, + + -- *** Type variable binders + plainTV, kindedTV, + + -- *** Roles + nominalR, representationalR, phantomR, inferR, + + -- *** Top Level Declarations + -- **** Data + valD, funD, tySynD, dataD, newtypeD, + derivClause, DerivClause(..), DerivStrategy(..), + -- **** Class + classD, instanceD, instanceWithOverlapD, Overlap(..), + sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, + + -- **** Role annotations + roleAnnotD, + -- **** Type Family / Data Family + dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, + familyNoKindD, familyKindD, closedTypeFamilyNoKindD, closedTypeFamilyKindD, + newtypeInstD, tySynInstD, + typeFam, dataFam, tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, + + -- **** Fixity + infixLD, infixRD, infixND, + + -- **** Foreign Function Interface (FFI) + cCall, stdCall, cApi, prim, javaScript, + unsafe, safe, interruptible, forImpD, + + -- **** Functional dependencies + funDep, + + -- **** Pragmas + ruleVar, typedRuleVar, + valueAnnotation, typeAnnotation, moduleAnnotation, + pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD, + pragLineD, pragCompleteD, + + -- **** Pattern Synonyms + patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn, + infixPatSyn, recordPatSyn, + + -- ** Reify + thisModule + + ) where + import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import qualified Language.Haskell.TH.Syntax as TH import Control.Monad( liftM, liftM2 ) @@ -30,6 +132,7 @@ type TyLitQ = Q TyLit type CxtQ = Q Cxt type PredQ = Q Pred +type DerivClauseQ = Q DerivClause type MatchQ = Q Match type ClauseQ = Q Clause type BodyQ = Q Body @@ -46,6 +149,8 @@ type FieldExpQ = Q FieldExp type RuleBndrQ = Q RuleBndr type TySynEqnQ = Q TySynEqn +type PatSynDirQ = Q PatSynDir +type PatSynArgsQ = Q PatSynArgs -- must be defined here for DsMeta to find it type Role = TH.Role @@ -78,12 +183,19 @@ litP :: Lit -> PatQ litP l = return (LitP l) + varP :: Name -> PatQ varP v = return (VarP v) + tupP :: [PatQ] -> PatQ tupP ps = do { ps1 <- sequence ps; return (TupP ps1)} + unboxedTupP :: [PatQ] -> PatQ unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} + +unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ +unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } + conP :: Name -> [PatQ] -> PatQ conP n ps = do ps' <- sequence ps return (ConP n ps') @@ -223,6 +335,9 @@ appE :: ExpQ -> ExpQ -> ExpQ appE x y = do { a <- x; b <- y; return (AppE a b)} +appTypeE :: ExpQ -> TypeQ -> ExpQ +appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } + parensE :: ExpQ -> ExpQ parensE x = do { x' <- x; return (ParensE x') } @@ -264,6 +379,9 @@ unboxedTupE :: [ExpQ] -> ExpQ unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} +unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ +unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } + condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} @@ -345,20 +463,22 @@ tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] + -> DecQ dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt cons1 <- sequence cons - derivs1 <- derivs + derivs1 <- sequence derivs return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ] + -> DecQ newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt con1 <- con - derivs1 <- derivs + derivs1 <- sequence derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ @@ -437,22 +557,27 @@ pragLineD :: Int -> String -> DecQ pragLineD line file = return $ PragmaD $ LineP line file -dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +pragCompleteD :: [Name] -> Maybe Name -> DecQ +pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty + +dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] + -> DecQ dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt tys1 <- sequence tys cons1 <- sequence cons - derivs1 <- derivs + derivs1 <- sequence derivs return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] + -> DecQ newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt tys1 <- sequence tys con1 <- con - derivs1 <- derivs + derivs1 <- sequence derivs return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) tySynInstD :: Name -> TySynEqnQ -> DecQ @@ -483,7 +608,7 @@ -- 3. remove the FamFlavour data type from Syntax module -- 4. make sure that all references to FamFlavour are gone from DsMeta, -- Convert, TcSplice (follows from 3) -#if __GLASGOW_HASKELL__ > 800 +#if __GLASGOW_HASKELL__ >= 804 #error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD #endif @@ -519,11 +644,14 @@ roleAnnotD name roles = return $ RoleAnnotD name roles standaloneDerivD :: CxtQ -> TypeQ -> DecQ -standaloneDerivD ctxtq tyq = +standaloneDerivD = standaloneDerivWithStrategyD Nothing + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD ds ctxtq tyq = do ctxt <- ctxtq ty <- tyq - return $ StandaloneDerivD ctxt ty + return $ StandaloneDerivD ds ctxt ty defaultSigD :: Name -> TypeQ -> DecQ defaultSigD n tyq = @@ -531,6 +659,20 @@ ty <- tyq return $ DefaultSigD n ty +-- | Pattern synonym declaration +patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ +patSynD name args dir pat = do + args' <- args + dir' <- dir + pat' <- pat + return (PatSynD name args' dir' pat') + +-- | Pattern synonym type signature +patSynSigD :: Name -> TypeQ -> DecQ +patSynSigD nm ty = + do ty' <- ty + return $ PatSynSigD nm ty' + tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ tySynEqn lhs rhs = do @@ -541,6 +683,10 @@ cxt :: [PredQ] -> CxtQ cxt = sequence +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause ds p = do p' <- cxt p + return $ DerivClause ds p' + normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys @@ -611,6 +757,9 @@ unboxedTupleT :: Int -> TypeQ unboxedTupleT i = return (UnboxedTupleT i) +unboxedSumT :: SumArity -> TypeQ +unboxedSumT arity = return (UnboxedSumT arity) + sigT :: TypeQ -> Kind -> TypeQ sigT t k = do @@ -706,8 +855,6 @@ strTyLit :: String -> TyLitQ strTyLit s = return (StrTyLit s) - - ------------------------------------------------------------------------------- -- * Kind @@ -817,6 +964,27 @@ moduleAnnotation :: AnnTarget moduleAnnotation = ModuleAnnotation + +------------------------------------------------------------------------------- +-- * Pattern Synonyms (sub constructs) + +unidir, implBidir :: PatSynDirQ +unidir = return Unidir +implBidir = return ImplBidir + +explBidir :: [ClauseQ] -> PatSynDirQ +explBidir cls = do + cls' <- sequence cls + return (ExplBidir cls') + +prefixPatSyn :: [Name] -> PatSynArgsQ +prefixPatSyn args = return $ PrefixPatSyn args + +recordPatSyn :: [Name] -> PatSynArgsQ +recordPatSyn sels = return $ RecordPatSyn sels + +infixPatSyn :: Name -> Name -> PatSynArgsQ +infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 -------------------------------------------------------------- -- * 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 @@ -10,8 +10,9 @@ import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Data.Word ( Word8 ) -import Data.Char ( toLower, chr, ord, isSymbol ) +import Data.Char ( toLower, chr) import GHC.Show ( showMultiLineString ) +import GHC.Lexeme( startsVarSym ) import Data.Ratio ( numerator, denominator ) nestDepth :: Int @@ -19,10 +20,10 @@ type Precedence = Int 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 +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 parensIf True d = parens d @@ -59,6 +60,7 @@ = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty ppr (DataConI v ty tc) = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty + ppr (PatSynI nm ty) = pprPatSynSig nm ty ppr (TyVarI v ty) = text "Type variable" <+> ppr v <+> equals <+> ppr ty ppr (VarI v ty mb_d) @@ -75,7 +77,25 @@ ppr_fix InfixL = text "infixl" ppr_fix InfixN = text "infix" +-- | Pretty prints a pattern synonym type signature +pprPatSynSig :: Name -> PatSynType -> Doc +pprPatSynSig nm ty + = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty +-- | Pretty prints a pattern synonym's type; follows the usual +-- conventions to print a pattern synonym type compactly, yet +-- unambiguously. See the note on 'PatSynType' and the section on +-- pattern synonyms in the GHC user's guide for more information. +pprPatSynType :: PatSynType -> Doc +pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty'')) + | null exTys, null provs = ppr (ForallT uniTys reqs ty'') + | null uniTys, null reqs = noreqs <+> ppr ty' + | null reqs = forall uniTys <+> noreqs <+> ppr ty' + | otherwise = ppr ty + where noreqs = text "() =>" + forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "." +pprPatSynType ty = ppr ty + ------------------------------ instance Ppr Module where ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m) @@ -95,12 +115,9 @@ isSymOcc n = case nameBase n of [] -> True -- Empty name; weird - (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c) + (c:_) -> startsVarSym c -- c.f. OccName.startsVarSym in GHC itself -isSymbolASCII :: Char -> Bool -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" - pprInfixExp :: Exp -> Doc pprInfixExp (VarE v) = pprName' Infix v pprInfixExp (ConE v) = pprName' Infix v @@ -112,6 +129,8 @@ pprExp i (LitE l) = pprLit i l pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1 <+> pprExp appPrec e2 +pprExp i (AppTypeE e t) + = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t pprExp _ (ParensE e) = parens (pprExp noPrec e) pprExp i (UInfixE e1 op e2) = parensIf (i > unopPrec) $ pprExp unopPrec e1 @@ -130,6 +149,7 @@ $ text "\\case" $$ nest nestDepth (ppr ms) pprExp _ (TupE es) = parens (commaSep es) pprExp _ (UnboxedTupE es) = hashParens (commaSep es) +pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity -- Nesting in Cond is to avoid potential problems in do statments pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, @@ -165,7 +185,7 @@ -- one, we simply treat it like a normal list. then text "[" <> ppr s <> text "]" else text "[" <> ppr s - <+> text "|" + <+> bar <+> commaSep ss' <> text "]" where s = last ss @@ -191,7 +211,7 @@ ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e ppr (LetS ds) = text "let" <+> (braces (semiSep ds)) ppr (NoBindS e) = ppr e - ppr (ParS sss) = sep $ punctuate (text "|") + ppr (ParS sss) = sep $ punctuate bar $ map commaSep sss ------------------------------ @@ -202,8 +222,8 @@ ------------------------------ 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) $$ + NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr + PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$ nest nestDepth (eqDoc <+> ppr expr) ------------------------------ @@ -252,6 +272,7 @@ pprPat _ (VarP v) = pprName' Applied v pprPat _ (TupP ps) = parens (commaSep ps) pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) +pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s <+> sep (map (pprPat appPrec) ps) pprPat _ (ParensP p) = parens $ pprPat noPrec p @@ -335,16 +356,33 @@ where ppr_eqn (TySynEqn lhs rhs) = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs - ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) - -ppr_dec _ (StandaloneDerivD cxt ty) - = hsep [ text "deriving instance", pprCxt cxt, ppr ty ] - +ppr_dec _ (StandaloneDerivD ds cxt ty) + = hsep [ text "deriving" + , maybe empty ppr_deriv_strategy ds + , text "instance" + , pprCxt cxt + , ppr ty ] ppr_dec _ (DefaultSigD n ty) = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] +ppr_dec _ (PatSynD name args dir pat) + = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS + where + pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2 + | otherwise = ppr name <+> ppr args + pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where") + nestDepth (ppr name <+> ppr cls) + | otherwise = ppr pat +ppr_dec _ (PatSynSigD name ty) + = pprPatSynSig name ty +ppr_deriv_strategy :: DerivStrategy -> Doc +ppr_deriv_strategy ds = text $ + case ds of + StockStrategy -> "stock" + AnyclassStrategy -> "anyclass" + NewtypeStrategy -> "newtype" ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ @@ -354,7 +392,8 @@ Overlapping -> "{-# OVERLAPPING #-}" Incoherent -> "{-# INCOHERENT #-}" -ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc +ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] + -> Doc ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt @@ -363,12 +402,12 @@ if null decs then empty else nest nestDepth - $ text "deriving" <+> ppr_cxt_preds decs] + $ vcat $ map ppr_deriv_clause decs] where pref :: [Doc] -> [Doc] pref xs | isGadtDecl = xs pref [] = [] -- No constructors; can't happen in H98 - pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds + pref (d:ds) = (char '=' <+> d):map (bar <+>) ds maybeWhere :: Doc maybeWhere | isGadtDecl = text "where" @@ -385,7 +424,8 @@ Nothing -> empty Just k -> dcolon <+> ppr k -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc +ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause] + -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt @@ -394,12 +434,17 @@ if null decs then empty else nest nestDepth - $ text "deriving" <+> ppr_cxt_preds decs] + $ vcat $ map ppr_deriv_clause decs] where ksigDoc = case ksig of Nothing -> empty Just k -> dcolon <+> ppr k +ppr_deriv_clause :: DerivClause -> Doc +ppr_deriv_clause (DerivClause ds ctxt) + = text "deriving" <+> maybe empty ppr_deriv_strategy ds + <+> ppr_cxt_preds ctxt + ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs @@ -415,7 +460,7 @@ instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) ppr_list [] = empty - ppr_list xs = char '|' <+> commaSep xs + ppr_list xs = bar <+> commaSep xs ------------------------------ instance Ppr FamFlavour where @@ -431,7 +476,7 @@ ------------------------------ instance Ppr InjectivityAnn where ppr (InjectivityAnn lhs rhs) = - char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) + bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) ------------------------------ instance Ppr Foreign where @@ -482,6 +527,9 @@ target1 (ValueAnnotation v) = ppr v ppr (LineP line file) = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}" + ppr (CompleteP cls mty) + = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls) + <+> maybe empty (\ty -> dcolon <+> ppr ty) mty ------------------------------ instance Ppr Inline where @@ -538,13 +586,28 @@ ppr (RecGadtC c vsts ty) = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty +instance Ppr PatSynDir where + ppr Unidir = text "<-" + ppr ImplBidir = text "=" + ppr (ExplBidir _) = text "<-" + -- the ExplBidir's clauses are pretty printed together with the + -- entire pattern synonym; so only print the direction here. + +instance Ppr PatSynArgs where + ppr (PrefixPatSyn args) = sep $ map ppr args + ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2 + ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels)) + commaSepApplied :: [Name] -> Doc commaSepApplied = commaSepWith (pprName' Applied) pprForall :: [TyVarBndr] -> Cxt -> Doc -pprForall ns ctxt - = text "forall" <+> hsep (map ppr ns) - <+> char '.' <+> pprCxt ctxt +pprForall tvs cxt + -- even in the case without any tvs, there could be a non-empty + -- context cxt (e.g., in the case of pattern synonyms, where there + -- are multiple forall binders and contexts). + | [] <- tvs = pprCxt cxt + | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc pprRecFields vsts ty @@ -619,6 +682,7 @@ pprParendType (TupleT 0) = text "()" pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma +pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar pprParendType ArrowT = parens (text "->") pprParendType ListT = text "[]" pprParendType (LitT l) = pprTyLit l @@ -644,9 +708,7 @@ pprUInfixT t = ppr t instance Ppr Type where - ppr (ForallT tvars ctxt ty) - = text "forall" <+> hsep (map ppr tvars) <+> text "." - <+> sep [pprCxt ctxt, ppr ty] + ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] ppr ty = pprTyApp (split ty) -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) -- See Note [Pretty-printing kind signatures] @@ -761,3 +823,15 @@ -- followed by space. semiSep :: Ppr a => [a] -> Doc semiSep = sep . punctuate semi . map ppr + +-- Prints out the series of vertical bars that wraps an expression or pattern +-- used in an unboxed sum. +unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc +unboxedSumBars d alt arity = hashParens $ + bars (alt-1) <> d <> bars (arity - alt) + where + bars i = hsep (replicate i bar) + +-- Text containing the vertical bar character. +bar :: Doc +bar = char '|' 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,4 @@ -{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} -- | Monadic front-end to Text.PrettyPrint @@ -41,9 +41,6 @@ import Control.Monad (liftM, liftM2, ap) import Language.Haskell.TH.Lib.Map ( Map ) import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative( Applicative(..) ) -#endif infixl 6 <> infixl 6 <+> @@ -140,7 +137,7 @@ show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u) show (Name occ NameS) = occString occ show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ - + data Name = Name OccName NameFlavour data NameFlavour @@ -158,7 +155,6 @@ (<*>) = ap instance Monad PprM where - return = pure m >>= k = PprM $ \s -> let (x, s') = runPprM m s in runPprM (k x) s' 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,13 +1,10 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, DefaultSignatures, - RankNTypes, RoleAnnotations, ScopedTypeVariables #-} + RankNTypes, RoleAnnotations, ScopedTypeVariables, + Trustworthy #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} -#if MIN_VERSION_base(4,8,0) -#define HAS_NATURAL -#endif - #if MIN_VERSION_base(4,9,0) # define HAS_MONADFAIL 1 #endif @@ -30,12 +27,10 @@ ( module Language.Haskell.TH.Syntax -- * Language extensions , module Language.Haskell.TH.LanguageExtensions + , ForeignSrcLang(..) ) where import Data.Data hiding (Fixity(..)) -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative( Applicative(..) ) -#endif import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad (liftM) @@ -46,11 +41,9 @@ import Data.Ratio import GHC.Generics ( Generic ) import GHC.Lexeme ( startsVarSym, startsVarId ) +import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions - -#ifdef HAS_NATURAL import Numeric.Natural -#endif #if HAS_MONADFAIL import qualified Control.Monad.Fail as Fail @@ -65,7 +58,7 @@ #if HAS_MONADFAIL class Fail.MonadFail m => Quasi m where #else -class (Applicative m, Monad m) => Quasi m where +class Monad m => Quasi m where #endif qNewName :: String -> m Name -- ^ Fresh names @@ -101,6 +94,8 @@ qAddTopDecls :: [Dec] -> m () + qAddForeignFile :: ForeignSrcLang -> String -> m () + qAddModFinalizer :: Q () -> m () qGetQ :: Typeable a => m (Maybe a) @@ -122,9 +117,8 @@ ----------------------------------------------------- instance Quasi IO where - qNewName s = do { n <- readIORef counter - ; writeIORef counter (n+1) - ; return (mkNameU s n) } + qNewName s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) + ; pure (mkNameU s n) } qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) @@ -141,6 +135,7 @@ qRecover _ _ = badIO "recover" -- Maybe we could fix this? qAddDependentFile _ = badIO "addDependentFile" qAddTopDecls _ = badIO "addTopDecls" + qAddForeignFile _ _ = badIO "addForeignFile" qAddModFinalizer _ = badIO "addModFinalizer" qGetQ = badIO "getQ" qPutQ _ = badIO "putQ" @@ -184,9 +179,6 @@ instance Monad Q where Q m >>= k = Q (m >>= \x -> unQ (k x)) (>>) = (*>) - - return = pure - #if !HAS_MONADFAIL fail s = report True s >> Q (fail "Q monad failure") #else @@ -469,6 +461,26 @@ addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) +-- | Emit a foreign file which will be compiled and linked to the object for +-- the current module. Currently only languages that can be compiled with +-- the C compiler are supported, and the flags passed as part of -optc will +-- be also applied to the C compiler invocation that will compile them. +-- +-- Note that for non-C languages (for example C++) @extern "C"@ directives +-- must be used to get symbols that we can access from Haskell. +-- +-- To get better errors, it is reccomended to use #line pragmas when +-- emitting C files, e.g. +-- +-- > {-# LANGUAGE CPP #-} +-- > ... +-- > addForeignFile LangC $ unlines +-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ +-- > , ... +-- > ] +addForeignFile :: ForeignSrcLang -> String -> Q () +addForeignFile lang str = Q (qAddForeignFile lang str) + -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. -- @@ -512,6 +524,7 @@ qRunIO = runIO qAddDependentFile = addDependentFile qAddTopDecls = addTopDecls + qAddForeignFile = addForeignFile qAddModFinalizer = addModFinalizer qGetQ = getQ qPutQ = putQ @@ -601,10 +614,8 @@ instance Lift Word64 where lift x = return (LitE (IntegerL (fromIntegral x))) -#ifdef HAS_NATURAL instance Lift Natural where lift x = return (LitE (IntegerL (fromIntegral x))) -#endif instance Integral a => Lift (Ratio a) where lift x = return (LitE (RationalL (toRational x))) @@ -731,15 +742,12 @@ (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Tuple")) - -- It is possible for a Data instance to be defined such - -- that toConstr uses a Constr defined using a function, - -- not a data constructor. In such a case, we must take - -- care to build the Name using mkNameG_v (for values), - -- not mkNameG_d (for data constructors). - -- See Trac #10796. + + -- Tricky case: see Note [Data for non-algebraic types] fun@(x:_) | startsVarSym x || startsVarId x -> mkNameG_v tyconPkg tyconMod fun con -> mkNameG_d tyconPkg tyconMod con + where tycon :: TyCon tycon = (typeRepTyCon . typeOf) t @@ -762,6 +770,34 @@ Just y -> y + +{- Note [Data for non-algebraic types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class Data was originally intended for algebraic data types. But +it is possible to use it for abstract types too. For example, in +package `text` we find + + instance Data Text where + ... + toConstr _ = packConstr + + packConstr :: Constr + packConstr = mkConstr textDataType "pack" [] Prefix + +Here `packConstr` isn't a real data constructor, it's an ordinary +function. Two complications + +* In such a case, we must take care to build the Name using + mkNameG_v (for values), not mkNameG_d (for data constructors). + See Trac #10796. + +* The pseudo-constructor is named only by its string, here "pack". + But 'dataToQa' needs the TyCon of its defining module, and has + to assume it's defined in the same module as the TyCon itself. + But nothing enforces that; Trac #12596 shows what goes wrong if + "pack" is defined in a different module than the data type "Text". + -} + -- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the -- same value, in the SYB style. It is generalized to take a function -- override type-specific cases; see 'liftData' for a more commonly @@ -811,17 +847,17 @@ ----------------------------------------------------- newtype ModName = ModName String -- Module name - deriving (Show,Eq,Ord,Typeable,Data,Generic) + deriving (Show,Eq,Ord,Data,Generic) newtype PkgName = PkgName String -- package name - deriving (Show,Eq,Ord,Typeable,Data,Generic) + deriving (Show,Eq,Ord,Data,Generic) -- | Obtained from 'reifyModule' and 'thisModule'. data Module = Module PkgName ModName -- package qualified module name - deriving (Show,Eq,Ord,Typeable,Data,Generic) + deriving (Show,Eq,Ord,Data,Generic) newtype OccName = OccName String - deriving (Show,Eq,Ord,Typeable,Data,Generic) + deriving (Show,Eq,Ord,Data,Generic) mkModName :: String -> ModName mkModName s = ModName s @@ -932,7 +968,7 @@ (such as @let x = ...@ or @\x -> ...@), but names constructed using @lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not. -} -data Name = Name OccName NameFlavour deriving (Typeable, Data, Eq, Generic) +data Name = Name OccName NameFlavour deriving (Data, Eq, Generic) instance Ord Name where -- check if unique is different before looking at strings @@ -948,13 +984,13 @@ -- An original name (occurrences only, not binders) -- Need the namespace too to be sure which -- thing we are naming - deriving ( Typeable, Data, Eq, Ord, Show, Generic ) + deriving ( Data, Eq, Ord, Show, Generic ) data NameSpace = VarName -- ^ Variables | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. - deriving( Eq, Ord, Show, Data, Typeable, Generic ) + deriving( Eq, Ord, Show, Data, Generic ) type Uniq = Int @@ -1178,23 +1214,61 @@ -- | Unboxed tuple type constructor unboxedTupleTypeName :: Int -> Name -unboxedTupleDataName 0 = error "unboxedTupleDataName 0" -unboxedTupleDataName 1 = error "unboxedTupleDataName 1" -unboxedTupleDataName n = mk_unboxed_tup_name (n-1) DataName - -unboxedTupleTypeName 0 = error "unboxedTupleTypeName 0" -unboxedTupleTypeName 1 = error "unboxedTupleTypeName 1" -unboxedTupleTypeName n = mk_unboxed_tup_name (n-1) TcClsName +unboxedTupleDataName n = mk_unboxed_tup_name n DataName +unboxedTupleTypeName n = mk_unboxed_tup_name n TcClsName mk_unboxed_tup_name :: Int -> NameSpace -> Name -mk_unboxed_tup_name n_commas space - = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod) +mk_unboxed_tup_name n space + = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod) where - occ = mkOccName ("(#" ++ replicate n_commas ',' ++ "#)") - tup_mod = mkModName "GHC.Tuple" + tup_occ | n == 1 = "Unit#" -- See Note [One-tuples] in TysWiredIn + | otherwise = "(#" ++ replicate n_commas ',' ++ "#)" + n_commas = n - 1 + tup_mod = mkModName "GHC.Tuple" +-- Unboxed sum data and type constructors +-- | Unboxed sum data constructor +unboxedSumDataName :: SumAlt -> SumArity -> Name +-- | Unboxed sum type constructor +unboxedSumTypeName :: SumArity -> Name +unboxedSumDataName alt arity + | alt > arity + = error $ prefix ++ "Index out of bounds." ++ debug_info + | alt <= 0 + = error $ prefix ++ "Alt must be > 0." ++ debug_info + + | arity < 2 + = error $ prefix ++ "Arity must be >= 2." ++ debug_info + + | otherwise + = Name (mkOccName sum_occ) + (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) + + where + prefix = "unboxedSumDataName: " + debug_info = " (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")" + + -- Synced with the definition of mkSumDataConOcc in TysWiredIn + sum_occ = '(' : '#' : bars nbars_before ++ '_' : bars nbars_after ++ "#)" + bars i = replicate i '|' + nbars_before = alt - 1 + nbars_after = arity - alt + +unboxedSumTypeName arity + | arity < 2 + = error $ "unboxedSumTypeName: Arity must be >= 2." + ++ " (arity: " ++ show arity ++ ")" + + | otherwise + = Name (mkOccName sum_occ) + (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) + + where + -- Synced with the definition of mkSumTyConOcc in TysWiredIn + sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)" + ----------------------------------------------------- -- Locations ----------------------------------------------------- @@ -1205,7 +1279,7 @@ , loc_module :: String , loc_start :: CharPos , loc_end :: CharPos } - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) type CharPos = (Int, Int) -- ^ Line and character position @@ -1252,6 +1326,11 @@ Type ParentName + -- | A pattern synonym. + | PatSynI + Name + PatSynType + {- | A \"value\" variable (as opposed to a type variable, see 'TyVarI'). @@ -1277,19 +1356,32 @@ | TyVarI -- Scoped type variable Name Type -- What it is bound to - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- | Obtained from 'reifyModule' in the 'Q' Monad. data ModuleInfo = -- | Contains the import list of the module. ModuleInfo [Module] - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) {- | In 'ClassOpI' and 'DataConI', name of the parent class or type -} type ParentName = Name +-- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a +-- particular data constructor. 'SumAlt's are one-indexed and should never +-- exceed the value of its corresponding 'SumArity'. For example: +-- +-- * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2) +-- +-- * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2) +type SumAlt = Int + +-- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of +-- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2. +type SumArity = Int + -- | In 'PrimTyConI', arity of the type constructor type Arity = Int @@ -1307,9 +1399,9 @@ type InstanceDec = Dec data Fixity = Fixity Int FixityDirection - deriving( Eq, Ord, Show, Data, Typeable, Generic ) + deriving( Eq, Ord, Show, Data, Generic ) data FixityDirection = InfixL | InfixR | InfixN - deriving( Eq, Ord, Show, Data, Typeable, Generic ) + deriving( Eq, Ord, Show, Data, Generic ) -- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) maxPrecedence :: Int @@ -1402,7 +1494,7 @@ | DoublePrimL Rational | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# | CharPrimL Char - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- We could add Int, Float, Double etc, as we do in HsLit, -- but that could complicate the @@ -1410,41 +1502,43 @@ -- | Pattern in Haskell given in @{}@ data Pat - = LitP Lit -- ^ @{ 5 or \'c\' }@ - | VarP Name -- ^ @{ x }@ - | TupP [Pat] -- ^ @{ (p1,p2) }@ - | 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 "Language.Haskell.TH.Syntax#infix" - | ParensP Pat -- ^ @{(p)}@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | TildeP Pat -- ^ @{ ~p }@ - | BangP Pat -- ^ @{ !p }@ - | AsP Name Pat -- ^ @{ x \@ p }@ - | WildP -- ^ @{ _ }@ - | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@ - | ListP [ Pat ] -- ^ @{ [1,2,3] }@ - | SigP Pat Type -- ^ @{ p :: t }@ - | ViewP Exp Pat -- ^ @{ e -> p }@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + = LitP Lit -- ^ @{ 5 or \'c\' }@ + | VarP Name -- ^ @{ x }@ + | TupP [Pat] -- ^ @{ (p1,p2) }@ + | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@ + | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@ + | 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 "Language.Haskell.TH.Syntax#infix" + | ParensP Pat -- ^ @{(p)}@ + -- + -- See "Language.Haskell.TH.Syntax#infix" + | TildeP Pat -- ^ @{ ~p }@ + | BangP Pat -- ^ @{ !p }@ + | AsP Name Pat -- ^ @{ x \@ p }@ + | WildP -- ^ @{ _ }@ + | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@ + | ListP [ Pat ] -- ^ @{ [1,2,3] }@ + | SigP Pat Type -- ^ @{ p :: t }@ + | ViewP Exp Pat -- ^ @{ e -> p }@ + deriving( Show, Eq, Ord, Data, Generic ) type FieldPat = (Name,Pat) data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Clause = Clause [Pat] Body [Dec] -- ^ @f { p1 p2 = body where decs }@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Exp = VarE Name -- ^ @{ x }@ | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @ | LitE Lit -- ^ @{ 5 or \'c\'}@ | AppE Exp Exp -- ^ @{ f x }@ + | AppTypeE Exp Type -- ^ @{ f \@Int } | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@ @@ -1464,6 +1558,7 @@ | LamCaseE [Match] -- ^ @{ \\case m1; m2 }@ | TupE [Exp] -- ^ @{ (e1,e2) } @ | UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @ + | UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@ | 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 }@ @@ -1487,7 +1582,7 @@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ | StaticE Exp -- ^ @{ static e }@ | UnboundVarE Name -- ^ @{ _x }@ (hole) - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) type FieldExp = (Name,Exp) @@ -1498,36 +1593,38 @@ -- | e3 = e4 } -- where ds@ | NormalB Exp -- ^ @f p { = e } where ds@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Guard = NormalG Exp -- ^ @f x { | odd x } = x@ | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Stmt = BindS Pat Exp | LetS [ Dec ] | NoBindS Exp | ParS [[Stmt]] - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Range = FromR Exp | FromThenR Exp Exp | FromToR Exp Exp | FromThenToR Exp Exp Exp - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ | DataD Cxt Name [TyVarBndr] (Maybe Kind) -- Kind signature (allowed only for GADTs) - [Con] Cxt + [Con] [DerivClause] -- ^ @{ data Cxt x => T x = A x | B (T x) - -- deriving (Z,W)}@ + -- deriving (Z,W) + -- deriving stock Eq }@ | NewtypeD Cxt Name [TyVarBndr] (Maybe Kind) -- Kind signature - Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x) - -- deriving (Z,W Q)}@ + Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) + -- deriving (Z,W Q) + -- deriving stock Eq }@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ @@ -1550,14 +1647,18 @@ | DataInstD Cxt Name [Type] (Maybe Kind) -- Kind signature - [Con] Cxt -- ^ @{ data instance Cxt x => T [x] - -- = A x | B (T x) deriving (Z,W)}@ + [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] + -- = A x | B (T x) + -- deriving (Z,W) + -- deriving stock Eq }@ | NewtypeInstD Cxt Name [Type] - (Maybe Kind) -- Kind signature - Con Cxt -- ^ @{ newtype instance Cxt x => T [x] - -- = A (B x) deriving (Z,W)}@ - | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ + (Maybe Kind) -- Kind signature + Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] + -- = A (B x) + -- deriving (Z,W) + -- deriving stock Eq }@ + | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | OpenTypeFamilyD TypeFamilyHead @@ -1566,11 +1667,24 @@ | ClosedTypeFamilyD TypeFamilyHead [TySynEqn] -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@ - | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ - | StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@ - | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ + | StandaloneDerivD (Maybe DerivStrategy) Cxt Type + -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@ + | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ + -- | Pattern Synonyms + | PatSynD Name PatSynArgs PatSynDir Pat + -- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or + -- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or + -- @{ pattern P v1 v2 .. vn <- p + -- where P v1 v2 .. vn = e }@ explicit bidirectional + -- + -- also, besides prefix pattern synonyms, both infix and record + -- pattern synonyms are supported. See 'PatSynArgs' for details + + | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature. + deriving( Show, Eq, Ord, Data, Generic ) + -- | Varieties of allowed instance overlap. data Overlap = Overlappable -- ^ May be overlapped by more specific instances | Overlapping -- ^ May overlap a more general instance @@ -1578,39 +1692,97 @@ | Incoherent -- ^ Both 'Overlappable' and 'Overlappable', and -- pick an arbitrary one if multiple choices are -- available. - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) --- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. --- By analogy with with "head" for type classes and type class instances as +-- | A single @deriving@ clause at the end of a datatype. +data DerivClause = DerivClause (Maybe DerivStrategy) Cxt + -- ^ @{ deriving stock (Eq, Ord) }@ + deriving( Show, Eq, Ord, Data, Generic ) + +-- | What the user explicitly requests when deriving an instance. +data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance + | AnyclassStrategy -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + deriving( Show, Eq, Ord, Data, Generic ) + +-- | A Pattern synonym's type. Note that a pattern synonym's *fully* +-- specified type has a peculiar shape coming with two forall +-- quantifiers and two constraint contexts. For example, consider the +-- pattern synonym +-- +-- pattern P x1 x2 ... xn = +-- +-- P's complete type is of the following form +-- +-- forall universals. required constraints +-- => forall existentials. provided constraints +-- => t1 -> t2 -> ... -> tn -> t +-- +-- consisting of four parts: +-- +-- 1) the (possibly empty lists of) universally quantified type +-- variables and required constraints on them. +-- 2) the (possibly empty lists of) existentially quantified +-- type variables and the provided constraints on them. +-- 3) the types t1, t2, .., tn of x1, x2, .., xn, respectively +-- 4) the type t of , mentioning only universals. +-- +-- Pattern synonym types interact with TH when (a) reifying a pattern +-- synonym, (b) pretty printing, or (c) specifying a pattern synonym's +-- type signature explicitly: +-- +-- (a) Reification always returns a pattern synonym's *fully* specified +-- type in abstract syntax. +-- +-- (b) Pretty printing via 'pprPatSynType' abbreviates a pattern +-- synonym's type unambiguously in concrete syntax: The rule of +-- thumb is to print initial empty universals and the required +-- context as `() =>`, if existentials and a provided context +-- follow. If only universals and their required context, but no +-- existentials are specified, only the universals and their +-- required context are printed. If both or none are specified, so +-- both (or none) are printed. +-- +-- (c) When specifying a pattern synonym's type explicitly with +-- 'PatSynSigD' either one of the universals, the existentials, or +-- their contexts may be left empty. +-- +-- See the GHC user's guide for more information on pattern synonyms +-- and their types: https://downloads.haskell.org/~ghc/latest/docs/html/ +-- users_guide/syntax-extns.html#pattern-synonyms. +type PatSynType = Type + +-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By +-- analogy with "head" for type classes and type class instances as -- defined in /Type classes: an exploration of the design space/, the --- @TypeFamilyHead@ is defined to be the elements of the declaration between --- @type family@ and @where@. +-- @TypeFamilyHead@ is defined to be the elements of the declaration +-- between @type family@ and @where@. data TypeFamilyHead = TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn) - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- | One equation of a type family instance or closed type family. The -- arguments are the left-hand-side type patterns and the right-hand-side -- result. data TySynEqn = TySynEqn [Type] Type - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data FunDep = FunDep [Name] [Name] - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data FamFlavour = TypeFam | DataFam - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs data Callconv = CCall | StdCall | CApi | Prim | JavaScript - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Safety = Unsafe | Safe | Interruptible - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases @@ -1618,30 +1790,32 @@ | RuleP String [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP Int String - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + | CompleteP [Name] (Maybe Name) + -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@ + deriving( Show, Eq, Ord, Data, Generic ) data Inline = NoInline | Inline | Inlinable - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) data RuleMatch = ConLike | FunLike - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) data Phases = AllPhases | FromPhase Int | BeforePhase Int - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) data RuleBndr = RuleVar Name | TypedRuleVar Name Type - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ @@ -1654,12 +1828,12 @@ = NoSourceUnpackedness -- ^ @C a@ | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) data SourceStrictness = NoSourceStrictness -- ^ @C a@ | SourceLazy -- ^ @C {~}a@ | SourceStrict -- ^ @C {!}a@ - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) -- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' -- refers to the strictness that the compiler chooses for a data constructor @@ -1668,7 +1842,7 @@ data DecidedStrictness = DecidedLazy | DecidedStrict | DecidedUnpack - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) data Con = NormalC Name [BangType] -- ^ @C Int a@ | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ @@ -1680,7 +1854,7 @@ | RecGadtC [Name] [VarBangType] Type -- See Note [GADT return type] -- ^ @C :: { v :: Int } -> T b Int@ - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) -- Note [GADT return type] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1712,7 +1886,7 @@ data Bang = Bang SourceUnpackedness SourceStrictness -- ^ @C { {\-\# UNPACK \#-\} !}a@ - deriving (Show, Eq, Ord, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Data, Generic) type BangType = (Bang, Type) type VarBangType = (Name, Bang, Type) @@ -1728,6 +1902,20 @@ -- 'VarBangType'. type VarStrictType = VarBangType +-- | A pattern synonym's directionality. +data PatSynDir + = Unidir -- ^ @pattern P x {<-} p@ + | ImplBidir -- ^ @pattern P x {=} p@ + | ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@ + deriving( Show, Eq, Ord, Data, Generic ) + +-- | A pattern synonym's argument type. +data PatSynArgs + = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ + | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ + | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ + deriving( Show, Eq, Ord, Data, Generic ) + data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ -> \@ | AppT Type Type -- ^ @T a b@ | SigT Type Kind -- ^ @t :: k@ @@ -1743,6 +1931,7 @@ -- See Note [Representing concrete syntax in types] | TupleT Int -- ^ @(,), (,,), etc.@ | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ + | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ | ArrowT -- ^ @->@ | EqualityT -- ^ @~@ | ListT -- ^ @[]@ @@ -1753,37 +1942,37 @@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ | WildCardT -- ^ @_, - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- | Type family result signature data FamilyResultSig = NoSig -- ^ no signature | KindSig Kind -- ^ @k@ | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- | Injectivity annotation data InjectivityAnn = InjectivityAnn Name [Name] - deriving ( Show, Eq, Ord, Data, Typeable, Generic ) + deriving ( Show, Eq, Ord, Data, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @"Hello"@ - deriving ( Show, Eq, Ord, Data, Typeable, Generic ) + deriving ( Show, Eq, Ord, Data, Generic ) -- | Role annotations data Role = NominalR -- ^ @nominal@ | RepresentationalR -- ^ @representational@ | PhantomR -- ^ @phantom@ | InferR -- ^ @_@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- | Annotation target for reifyAnnotations data AnnLookup = AnnLookupModule Module | AnnLookupName Name - deriving( Show, Eq, Ord, Data, Typeable, Generic ) + deriving( Show, Eq, Ord, Data, Generic ) -- | To avoid duplication between kinds and types, they -- are defined to be the same. Naturally, you would never diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,14 +1,39 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) -## 2.11.1.0 Jan 2017 +## 2.12.0.0 *July 2017* - * Bundled with GHC 8.0.2 + * Bundled with GHC 8.2.1. - * Fix pretty-printing of list comprehensions with only one statement. Previously this was rendered as `[Foo|]` instead of `Foo]`. + * Add support for pattern synonyms. This introduces one new constructor to + `Info` (`PatSynI`), two new constructors to `Dec` (`PatSynD` and + `PatSynSigD`), and two new data types (`PatSynDir` and `PatSynArgs`), + among other changes. (#8761) + * Add support for unboxed sums. (#12478) -## 2.11.0.0 May 2016 + * Add support for visible type applications. (#12530) + * Add support for attaching deriving strategies to `deriving` statements + (#10598) + + * Add support for `COMPLETE` pragmas. (#13098) + + * `unboxedTupleTypeName` and `unboxedTupleDataName` now work for unboxed + 0-tuples and 1-tuples (#12977) + + * `Language.Haskell.TH` now reexports all of `Language.Haskell.TH.Lib`. + (#12992). This causes `Language.Haskell.TH` to export more types and + functions that it did before: + - `TExp`, `BangQ`, and `FieldExpQ` + - `unboxedTupP`, `unboxedTupE` and `unboundVarE` + - `infixLD`, `infixRD`, and `infixND` + - `unboxedTupleT` and `wildCardT` + - `plainTV` and `kindedTV` + - `interruptible` and `funDep` + - `valueAnnotation`, `typeAnnotation`, and `moduleAnnotation` + +## 2.11.0.0 *May 2016* + * Bundled with GHC 8.0.1 * The compiler can now resolve infix operator fixities in types on its own. @@ -37,9 +62,8 @@ in Haskell source code (`SourceUnpackedness` and `SourceStrictness`, as well as `Bang`), and one for strictness information after a constructor is compiled (`DecidedStrictness`). `Strict`, `StrictType` and `VarStrictType` - have been deprecated in favor of `Bang`, `BangType` and `VarBangType`, and - three functions (`isStrict`, `isLazy`, and `unpack`) were removed because - they no longer serve any use in this new design. (#10697) + have been deprecated in favor of `Bang`, `BangType` and `VarBangType`. + (#10697) * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness` values for its fields (#10697) @@ -51,8 +75,6 @@ `Nothing` otherwise (#10704 and #11345) * Add `MonadFail Q` instance for GHC 8.0 and later (#11661) - - * TODO: document API changes and important bugfixes * Add support for OVERLAP(S/PED/PING) pragmas on instances 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.11.1.0 +version: 2.12.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -49,8 +49,8 @@ Language.Haskell.TH.Lib.Map build-depends: - base >= 4.7 && < 4.10, - ghc-boot-th == 8.0.*, + base >= 4.8 && < 4.11, + ghc-boot-th == 8.2.*, pretty == 1.1.* -- We need to set the unit ID to template-haskell (without a