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 @@ -21,7 +21,7 @@ StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, - FamilyResultSigQ, + FamilyResultSigQ, DerivStrategyQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -79,7 +79,9 @@ -- *** Top Level Declarations -- **** Data valD, funD, tySynD, dataD, newtypeD, - derivClause, DerivClause(..), DerivStrategy(..), + derivClause, DerivClause(..), + stockStrategy, anyclassStrategy, newtypeStrategy, + viaStrategy, DerivStrategy(..), -- **** Class classD, instanceD, instanceWithOverlapD, Overlap(..), sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, @@ -140,6 +142,9 @@ , kindSig , tyVarSig + , derivClause + , standaloneDerivWithStrategyD + , Role , InjectivityAnn ) @@ -262,3 +267,17 @@ tyVarSig :: TyVarBndr -> FamilyResultSig tyVarSig = TyVarSig + +------------------------------------------------------------------------------- +-- * Top Level Declarations + +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause mds p = do + p' <- cxt p + return $ DerivClause mds p' + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mds ctxt ty = do + ctxt' <- ctxt + ty' <- ty + return $ StandaloneDerivD mds ctxt' ty' diff --git a/Language/Haskell/TH/Lib/Internal.hs b/Language/Haskell/TH/Lib/Internal.hs --- a/Language/Haskell/TH/Lib/Internal.hs +++ b/Language/Haskell/TH/Lib/Internal.hs @@ -57,6 +57,7 @@ type PatSynDirQ = Q PatSynDir type PatSynArgsQ = Q PatSynArgs type FamilyResultSigQ = Q FamilyResultSig +type DerivStrategyQ = Q DerivStrategy -- must be defined here for DsMeta to find it type Role = TH.Role @@ -533,12 +534,13 @@ standaloneDerivD :: CxtQ -> TypeQ -> DecQ standaloneDerivD = standaloneDerivWithStrategyD Nothing -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ -standaloneDerivWithStrategyD ds ctxtq tyq = +standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mdsq ctxtq tyq = do + mds <- sequenceA mdsq ctxt <- ctxtq ty <- tyq - return $ StandaloneDerivD ds ctxt ty + return $ StandaloneDerivD mds ctxt ty defaultSigD :: Name -> TypeQ -> DecQ defaultSigD n tyq = @@ -570,9 +572,22 @@ cxt :: [PredQ] -> CxtQ cxt = sequence -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ -derivClause ds p = do p' <- cxt p - return $ DerivClause ds p' +derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ +derivClause mds p = do mds' <- sequenceA mds + p' <- cxt p + return $ DerivClause mds' p' + +stockStrategy :: DerivStrategyQ +stockStrategy = pure StockStrategy + +anyclassStrategy :: DerivStrategyQ +anyclassStrategy = pure AnyclassStrategy + +newtypeStrategy :: DerivStrategyQ +newtypeStrategy = pure NewtypeStrategy + +viaStrategy :: TypeQ -> DerivStrategyQ +viaStrategy = fmap ViaStrategy normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys 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 @@ -20,10 +20,11 @@ nestDepth = 4 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 +appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence +appPrec = 4 -- Argument of a function application +opPrec = 3 -- Argument of an infix operator +unopPrec = 2 -- Argument of an unresolved infix operator +sigPrec = 1 -- Argument of an explicit type signature noPrec = 0 -- Others parensIf :: Bool -> Doc -> Doc @@ -194,7 +195,8 @@ ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) -pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t +pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e + <+> dcolon <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ @@ -219,9 +221,14 @@ ------------------------------ instance Ppr Match where - ppr (Match p rhs ds) = ppr p <+> pprBody False rhs + ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs $$ where_clause ds +pprMatchPat :: Pat -> Doc +-- Everything except pattern signatures bind more tightly than (->) +pprMatchPat p@(SigP {}) = parens (ppr p) +pprMatchPat p = ppr p + ------------------------------ pprGuarded :: Doc -> (Guard, Exp) -> Doc pprGuarded eqDoc (guard, expr) = case guard of @@ -381,11 +388,12 @@ = pprPatSynSig name ty ppr_deriv_strategy :: DerivStrategy -> Doc -ppr_deriv_strategy ds = text $ +ppr_deriv_strategy ds = case ds of - StockStrategy -> "stock" - AnyclassStrategy -> "anyclass" - NewtypeStrategy -> "newtype" + StockStrategy -> text "stock" + AnyclassStrategy -> text "anyclass" + NewtypeStrategy -> text "newtype" + ViaStrategy ty -> text "via" <+> pprParendType ty ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ @@ -445,8 +453,16 @@ ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt) - = text "deriving" <+> maybe empty ppr_deriv_strategy ds + = text "deriving" <+> pp_strat_before <+> ppr_cxt_preds ctxt + <+> pp_strat_after + where + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case ds of + Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) + _ -> (maybe empty ppr_deriv_strategy ds, empty) ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs 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 @@ -84,9 +84,11 @@ qAddDependentFile :: FilePath -> m () + qAddTempFile :: String -> m FilePath + qAddTopDecls :: [Dec] -> m () - qAddForeignFile :: ForeignSrcLang -> String -> m () + qAddForeignFilePath :: ForeignSrcLang -> String -> m () qAddModFinalizer :: Q () -> m () @@ -128,8 +130,9 @@ qLocation = badIO "currentLocation" qRecover _ _ = badIO "recover" -- Maybe we could fix this? qAddDependentFile _ = badIO "addDependentFile" + qAddTempFile _ = badIO "addTempFile" qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFile _ _ = badIO "addForeignFile" + qAddForeignFilePath _ _ = badIO "addForeignFilePath" qAddModFinalizer _ = badIO "addModFinalizer" qAddCorePlugin _ = badIO "addCorePlugin" qGetQ = badIO "getQ" @@ -445,11 +448,23 @@ addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) +-- | Obtain a temporary file path with the given suffix. The compiler will +-- delete this file after compilation. +addTempFile :: String -> Q FilePath +addTempFile suffix = Q (qAddTempFile suffix) + -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) +-- | +addForeignFile :: ForeignSrcLang -> String -> Q () +addForeignFile = addForeignSource +{-# DEPRECATED addForeignFile + "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" + #-} -- deprecated in 8.6 + -- | 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 @@ -463,13 +478,31 @@ -- -- > {-# LANGUAGE CPP #-} -- > ... --- > addForeignFile LangC $ unlines +-- > addForeignSource LangC $ unlines -- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ -- > , ... -- > ] -addForeignFile :: ForeignSrcLang -> String -> Q () -addForeignFile lang str = Q (qAddForeignFile lang str) +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path +-- | Same as 'addForeignSource', but expects to receive a path pointing to the +-- foreign file instead of a 'String' of its contents. Consider using this in +-- conjunction with 'addTempFile'. +-- +-- This is a good alternative to 'addForeignSource' when you are trying to +-- directly link in an object file. +addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () +addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) + -- | 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. -- @@ -524,8 +557,9 @@ qLookupName = lookupName qLocation = location qAddDependentFile = addDependentFile + qAddTempFile = addTempFile qAddTopDecls = addTopDecls - qAddForeignFile = addForeignFile + qAddForeignFilePath = addForeignFilePath qAddModFinalizer = addModFinalizer qAddCorePlugin = addCorePlugin qGetQ = getQ @@ -697,8 +731,8 @@ falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Base" "Nothing" -justName = mkNameG DataName "base" "GHC.Base" "Just" +nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" +justName = mkNameG DataName "base" "GHC.Maybe" "Just" leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left" @@ -1709,6 +1743,7 @@ data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance | AnyclassStrategy -- ^ @-XDeriveAnyClass@ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy Type -- ^ @-XDerivingVia@ deriving( Show, Eq, Ord, Data, Generic ) -- | A Pattern synonym's type. Note that a pattern synonym's *fully* diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,23 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.14.0.0 *August 2018* + + * Introduce an `addForeignFilePath` function, as well as a corresponding + `qAddForeignFile` class method to `Quasi`. Unlike `addForeignFile`, which + takes the contents of the file as an argument, `addForeignFilePath` takes + as an argument a path pointing to a foreign file. A new `addForeignSource` + function has also been added which takes a file's contents as an argument. + + The old `addForeignFile` function is now deprecated in favor of + `addForeignSource`, and the `qAddForeignFile` method of `Quasi` has been + removed entirely. + + * Introduce an `addTempFile` function, as well as a corresponding + `qAddTempFile` method to `Quasi`, which requests a temporary file of + a given suffix. + + * Add a `ViaStrategy` constructor to `DerivStrategy`. + ## 2.13.0.0 *March 2018* * Bundled with GHC 8.4.1 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.13.0.0 +version: 2.14.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -51,8 +51,8 @@ Language.Haskell.TH.Lib.Map build-depends: - base >= 4.9 && < 4.12, - ghc-boot-th == 8.4.*, + base >= 4.9 && < 4.13, + ghc-boot-th == 8.6.*, pretty == 1.1.* ghc-options: -Wall