diff options
author | RyanGlScott <ryan.gl.scott@gmail.com> | 2015-12-22 11:25:59 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-12-22 13:22:29 +0100 |
commit | f975b0b10b2971d00b6e1986e0a2af2bf759a4f4 (patch) | |
tree | 8b890f6e8058bb0a625a409de70f107101048d8d | |
parent | b407bd775d9241023b4694b3142a756df0082ea2 (diff) | |
download | haskell-f975b0b10b2971d00b6e1986e0a2af2bf759a4f4.tar.gz |
Rework Template Haskell's handling of strictness
Currently, Template Haskell's treatment of strictness is not enough to
cover all possible combinations of unpackedness and strictness. In
addition, it isn't equipped to deal with new features (such as
`-XStrictData`) which can change a datatype's fields' strictness during
compilation.
To address this, I replaced TH's `Strict` datatype with
`SourceUnpackedness` and `SourceStrictness` (which give the programmer a
more complete toolkit to configure a datatype field's strictness than
just `IsStrict`, `IsLazy`, and `Unpack`). I also added the ability to
reify a constructor fields' strictness post-compilation through the
`reifyConStrictness` function.
Fixes #10697.
Test Plan: ./validate
Reviewers: simonpj, goldfire, bgamari, austin
Reviewed By: goldfire, bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1603
GHC Trac Issues: #10697
37 files changed, 622 insertions, 224 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 0c72a9f266..f56f446a12 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -637,18 +637,27 @@ repC (L _ (ConDeclGADT { con_names = cons where gadtDetails = gadtDeclDetails res_ty -repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) +repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) +repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] +repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] +repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] + +repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ) +repSrcStrictness SrcLazy = rep2 sourceLazyName [] +repSrcStrictness SrcStrict = rep2 sourceStrictName [] +repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] + +repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ)) repBangTy ty = do - MkC s <- rep2 str [] + MkC u <- repSrcUnpackedness su' + MkC s <- repSrcStrictness ss' + MkC b <- rep2 bangName [u, s] MkC t <- repLTy ty' - rep2 strictTypeName [s, t] + rep2 bangTypeName [b, t] where - (str, ty') = case ty of - L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty) - -> (unpackedName, ty) - L _ (HsBangTy (HsSrcBang _ _ SrcStrict) ty) - -> (isStrictName, ty) - _ -> (notStrictName, ty) + (su', ss', ty') = case ty of + L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty) + _ -> (NoSrcUnpack, NoSrcStrict, ty) ------------------------------------------------------- -- Deriving clause @@ -1955,18 +1964,18 @@ repConstr :: HsConDeclDetails Name -> [Core TH.Name] -> DsM (Core TH.ConQ) repConstr (PrefixCon ps) Nothing [con] - = do arg_tys <- repList strictTypeQTyConName repBangTy ps + = do arg_tys <- repList bangTypeQTyConName repBangTy ps rep2 normalCName [unC con, unC arg_tys] repConstr (PrefixCon ps) (Just res_ty) cons - = do arg_tys <- repList strictTypeQTyConName repBangTy ps + = do arg_tys <- repList bangTypeQTyConName repBangTy ps (res_n, idx) <- repGadtReturnTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n , unC idx] repConstr (RecCon (L _ ips)) resTy cons = do args <- concatMapM rep_ip ips - arg_vtys <- coreList varStrictTypeQTyConName args + arg_vtys <- coreList varBangTypeQTyConName args case resTy of Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] Just res_ty -> do @@ -1980,7 +1989,7 @@ repConstr (RecCon (L _ ips)) resTy cons rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a) rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) ; MkC ty <- repBangTy t - ; rep2 varStrictTypeName [v,ty] } + ; rep2 varBangTypeName [v,ty] } repConstr (InfixCon st1 st2) Nothing [con] = do arg1 <- repBangTy st1 diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 6c35a25876..4b79922863 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -503,16 +503,24 @@ cvtConstr (RecGadtC c varstrtys ty idx) ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty) ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } -cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) -cvt_arg (NotStrict, ty) = cvtType ty -cvt_arg (IsStrict, ty) +cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness +cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack +cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack +cvtSrcUnpackedness SourceUnpack = SrcUnpack + +cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness +cvtSrcStrictness NoSourceStrictness = NoSrcStrict +cvtSrcStrictness SourceLazy = SrcLazy +cvtSrcStrictness SourceStrict = SrcStrict + +cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName) +cvt_arg (Bang su ss, ty) = do { ty' <- cvtType ty - ; returnL $ HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcStrict) ty' } -cvt_arg (Unpacked, ty) - = do { ty' <- cvtType ty - ; returnL $ HsBangTy (HsSrcBang Nothing SrcUnpack SrcStrict) ty' } + ; let su' = cvtSrcUnpackedness su + ; let ss' = cvtSrcStrictness ss + ; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' } -cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName) +cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName) cvt_id_arg (i, str, ty) = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index d683b1a9b4..392aeda1ff 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -73,14 +73,18 @@ templateHaskellNames = [ roleAnnotDName, -- Cxt cxtName, - -- Strict - isStrictName, notStrictName, unpackedName, + -- SourceUnpackedness + noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, + -- SourceStrictness + noSourceStrictnessName, sourceLazyName, sourceStrictName, -- Con normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, - -- StrictType - strictTypeName, - -- VarStrictType - varStrictTypeName, + -- Bang + bangName, + -- BangType + bangTypeName, + -- VarBangType + varBangTypeName, -- Type forallTName, varTName, conTName, appTName, equalityTName, tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, @@ -130,8 +134,8 @@ templateHaskellNames = [ -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, - stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, - varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, + stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName, + varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, @@ -349,11 +353,17 @@ roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey cxtName :: Name cxtName = libFun (fsLit "cxt") cxtIdKey --- data Strict = ... -isStrictName, notStrictName, unpackedName :: Name -isStrictName = libFun (fsLit "isStrict") isStrictKey -notStrictName = libFun (fsLit "notStrict") notStrictKey -unpackedName = libFun (fsLit "unpacked") unpackedKey +-- data SourceUnpackedness = ... +noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name +noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey +sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey +sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey + +-- data SourceStrictness = ... +noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name +noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey +sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey +sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey -- data Con = ... normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name @@ -364,13 +374,17 @@ forallCName = libFun (fsLit "forallC" ) forallCIdKey gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey --- type StrictType = ... -strictTypeName :: Name -strictTypeName = libFun (fsLit "strictType") strictTKey +-- data Bang = ... +bangName :: Name +bangName = libFun (fsLit "bang") bangIdKey + +-- type BangType = ... +bangTypeName :: Name +bangTypeName = libFun (fsLit "bangType") bangTKey --- type VarStrictType = ... -varStrictTypeName :: Name -varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey +-- type VarBangType = ... +varBangTypeName :: Name +varBangTypeName = libFun (fsLit "varBangType") varBangTKey -- data Type = ... forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, @@ -479,8 +493,8 @@ typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, - decQTyConName, conQTyConName, strictTypeQTyConName, - varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, + decQTyConName, conQTyConName, bangTypeQTyConName, + varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName, patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey @@ -490,8 +504,8 @@ stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey decQTyConName = libTc (fsLit "DecQ") decQTyConKey decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] conQTyConName = libTc (fsLit "ConQ") conQTyConKey -strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey -varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey +bangTypeQTyConName = libTc (fsLit "BangTypeQ") bangTypeQTyConKey +varBangTypeQTyConName = libTc (fsLit "VarBangTypeQ") varBangTypeQTyConKey typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey patQTyConName = libTc (fsLit "PatQ") patQTyConKey @@ -550,7 +564,7 @@ liftClassKey = mkPreludeClassUnique 200 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, - decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, + decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, @@ -569,8 +583,8 @@ conQTyConKey = mkPreludeTyConUnique 210 typeQTyConKey = mkPreludeTyConUnique 211 typeTyConKey = mkPreludeTyConUnique 212 decTyConKey = mkPreludeTyConUnique 213 -varStrictTypeQTyConKey = mkPreludeTyConUnique 214 -strictTypeQTyConKey = mkPreludeTyConUnique 215 +bangTypeQTyConKey = mkPreludeTyConUnique 214 +varBangTypeQTyConKey = mkPreludeTyConUnique 215 fieldExpTyConKey = mkPreludeTyConUnique 216 fieldPatTyConKey = mkPreludeTyConUnique 217 nameTyConKey = mkPreludeTyConUnique 218 @@ -796,11 +810,17 @@ defaultSigDIdKey = mkPreludeMiscIdUnique 357 cxtIdKey :: Unique cxtIdKey = mkPreludeMiscIdUnique 360 --- data Strict = ... -isStrictKey, notStrictKey, unpackedKey :: Unique -isStrictKey = mkPreludeMiscIdUnique 363 -notStrictKey = mkPreludeMiscIdUnique 364 -unpackedKey = mkPreludeMiscIdUnique 365 +-- data SourceUnpackedness = ... +noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique +noSourceUnpackednessKey = mkPreludeMiscIdUnique 361 +sourceNoUnpackKey = mkPreludeMiscIdUnique 362 +sourceUnpackKey = mkPreludeMiscIdUnique 363 + +-- data SourceStrictness = ... +noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique +noSourceStrictnessKey = mkPreludeMiscIdUnique 364 +sourceLazyKey = mkPreludeMiscIdUnique 365 +sourceStrictKey = mkPreludeMiscIdUnique 366 -- data Con = ... normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, @@ -812,13 +832,17 @@ forallCIdKey = mkPreludeMiscIdUnique 373 gadtCIdKey = mkPreludeMiscIdUnique 374 recGadtCIdKey = mkPreludeMiscIdUnique 375 --- type StrictType = ... -strictTKey :: Unique -strictTKey = mkPreludeMiscIdUnique 376 +-- data Bang = ... +bangIdKey :: Unique +bangIdKey = mkPreludeMiscIdUnique 376 + +-- type BangType = ... +bangTKey :: Unique +bangTKey = mkPreludeMiscIdUnique 377 --- type VarStrictType = ... -varStrictTKey :: Unique -varStrictTKey = mkPreludeMiscIdUnique 377 +-- type VarBangType = ... +varBangTKey :: Unique +varBangTKey = mkPreludeMiscIdUnique 378 -- data Type = ... forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 9cce515e8f..e3b4fa8c7e 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -815,6 +815,10 @@ instance TH.Quasi TcM where qReifyRoles = reifyRoles qReifyAnnotations = reifyAnnotations qReifyModule = reifyModule + qReifyConStrictness nm = do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } -- For qRecover, discard error messages if -- the recovery action is chosen. Otherwise @@ -1335,7 +1339,9 @@ reifyDataCon isGadtDataCon tys dc -- used for GADTs data constructors (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, _) = dataConFullSig dc - stricts = map reifyStrict (dataConSrcBangs dc) + (srcUnpks, srcStricts) + = mapAndUnzip reifySourceBang (dataConSrcBangs dc) + dcdBangs = zipWith TH.Bang srcUnpks srcStricts fields = dataConFieldLabels dc name = reifyName dc r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs @@ -1350,21 +1356,21 @@ reifyDataCon isGadtDataCon tys dc ; let main_con | not (null fields) && not isGadtDataCon = TH.RecC name (zip3 (map reifyFieldLabel fields) - stricts r_arg_tys) + dcdBangs r_arg_tys) | not (null fields) = TH.RecGadtC [name] (zip3 (map (reifyName . flSelector) fields) - stricts r_arg_tys) r_ty_name idx_tys + dcdBangs r_arg_tys) r_ty_name idx_tys | dataConIsInfix dc = ASSERT( length arg_tys == 2 ) TH.InfixC (s1,r_a1) name (s2,r_a2) | isGadtDataCon - = TH.GadtC [name] (stricts `zip` r_arg_tys) r_ty_name + = TH.GadtC [name] (dcdBangs `zip` r_arg_tys) r_ty_name idx_tys | otherwise - = TH.NormalC name (stricts `zip` r_arg_tys) + = TH.NormalC name (dcdBangs `zip` r_arg_tys) [r_a1, r_a2] = r_arg_tys - [s1, s2] = stricts + [s1, s2] = dcdBangs (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs , g_theta ) | otherwise = ( ex_tvs, theta ) @@ -1373,7 +1379,7 @@ reifyDataCon isGadtDataCon tys dc { cxt <- reifyCxt theta' ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing ; return (TH.ForallC ex_tvs'' cxt main_con) } - ; ASSERT( length arg_tys == length stricts ) + ; ASSERT( length arg_tys == length dcdBangs ) ret_con } -- Note [Reifying GADT data constructors] @@ -1759,11 +1765,24 @@ reifyFixity name conv_dir BasicTypes.InfixL = TH.InfixL conv_dir BasicTypes.InfixN = TH.InfixN -reifyStrict :: DataCon.HsSrcBang -> TH.Strict -reifyStrict (HsSrcBang _ _ SrcLazy) = TH.NotStrict -reifyStrict (HsSrcBang _ _ NoSrcStrict) = TH.NotStrict -reifyStrict (HsSrcBang _ SrcUnpack SrcStrict) = TH.Unpacked -reifyStrict (HsSrcBang _ _ SrcStrict) = TH.IsStrict +reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness +reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness +reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack +reifyUnpackedness SrcUnpack = TH.SourceUnpack + +reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness +reifyStrictness NoSrcStrict = TH.NoSourceStrictness +reifyStrictness SrcStrict = TH.SourceStrict +reifyStrictness SrcLazy = TH.SourceLazy + +reifySourceBang :: DataCon.HsSrcBang + -> (TH.SourceUnpackedness, TH.SourceStrictness) +reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) + +reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness +reifyDecidedStrictness HsLazy = TH.DecidedLazy +reifyDecidedStrictness HsStrict = TH.DecidedStrict +reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack ------------------------------ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst index 2437abf813..caa1d897a8 100644 --- a/docs/users_guide/7.12.1-notes.rst +++ b/docs/users_guide/7.12.1-notes.rst @@ -323,6 +323,9 @@ Template Haskell is enabled in the ``Q`` monad. Similarly, ``extsEnabled`` can be used to list all enabled language extensions. +- One can now reify the strictness information of a constructors' fields using + Template Haskell's ``reifyConStrictness`` function, which takes into account + whether flags such as `-XStrictData` or `-funbox-strict-fields` are enabled. Runtime system ~~~~~~~~~~~~~~ diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 5406854f31..37c9f0c209 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -158,6 +158,7 @@ data Message a where ReifyRoles :: TH.Name -> Message (THResult [TH.Role]) ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString]) ReifyModule :: TH.Module -> Message (THResult TH.ModuleInfo) + ReifyConStrictness :: TH.Name -> Message (THResult [TH.DecidedStrictness]) AddDependentFile :: FilePath -> Message (THResult ()) AddTopDecls :: [TH.Dec] -> Message (THResult ()) @@ -291,12 +292,13 @@ getMessage = do 35 -> Msg <$> ReifyRoles <$> get 36 -> Msg <$> (ReifyAnnotations <$> get <*> get) 37 -> Msg <$> ReifyModule <$> get - 38 -> Msg <$> AddDependentFile <$> get - 39 -> Msg <$> AddTopDecls <$> get - 40 -> Msg <$> (IsExtEnabled <$> get) - 41 -> Msg <$> return ExtsEnabled - 42 -> Msg <$> return QDone - 43 -> Msg <$> QException <$> get + 38 -> Msg <$> ReifyConStrictness <$> get + 39 -> Msg <$> AddDependentFile <$> get + 40 -> Msg <$> AddTopDecls <$> get + 41 -> Msg <$> (IsExtEnabled <$> get) + 42 -> Msg <$> return ExtsEnabled + 43 -> Msg <$> return QDone + 44 -> Msg <$> QException <$> get _ -> Msg <$> QFail <$> get putMessage :: Message a -> Put @@ -339,13 +341,14 @@ putMessage m = case m of ReifyRoles a -> putWord8 35 >> put a ReifyAnnotations a b -> putWord8 36 >> put a >> put b ReifyModule a -> putWord8 37 >> put a - AddDependentFile a -> putWord8 38 >> put a - AddTopDecls a -> putWord8 39 >> put a - IsExtEnabled a -> putWord8 40 >> put a - ExtsEnabled -> putWord8 41 - QDone -> putWord8 42 - QException a -> putWord8 43 >> put a - QFail a -> putWord8 44 >> put a + ReifyConStrictness a -> putWord8 38 >> put a + AddDependentFile a -> putWord8 39 >> put a + AddTopDecls a -> putWord8 40 >> put a + IsExtEnabled a -> putWord8 41 >> put a + ExtsEnabled -> putWord8 42 + QDone -> putWord8 43 + QException a -> putWord8 44 >> put a + QFail a -> putWord8 45 >> put a -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs index 0121da9426..f379dbc546 100644 --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -118,6 +118,7 @@ instance TH.Quasi GHCiQ where where typerep = typeOf (undefined :: a) qReifyModule m = ghcCmd (ReifyModule m) + qReifyConStrictness name = ghcCmd (ReifyConStrictness name) qLocation = fromMaybe noLoc . qsLocation <$> getState qRunIO m = GHCiQ $ \s -> fmap (,s) m qAddDependentFile file = ghcCmd (AddDependentFile file) diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs index 41187fdef9..6183a3d26f 100644 --- a/libraries/ghci/GHCi/TH/Binary.hs +++ b/libraries/ghci/GHCi/TH/Binary.hs @@ -45,7 +45,10 @@ instance Binary TH.Pragma instance Binary TH.Safety instance Binary TH.Callconv instance Binary TH.Foreign -instance Binary TH.Strict +instance Binary TH.Bang +instance Binary TH.SourceUnpackedness +instance Binary TH.SourceStrictness +instance Binary TH.DecidedStrictness instance Binary TH.FixityDirection instance Binary TH.OccName instance Binary TH.Con diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 66d507cf9d..19882868b0 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -41,6 +41,8 @@ module Language.Haskell.TH( reifyRoles, -- *** Annotation lookup reifyAnnotations, AnnLookup(..), + -- *** Constructor strictness lookup + reifyConStrictness, -- * Typed expressions TExp, unType, @@ -66,7 +68,8 @@ module Language.Haskell.TH( -- ** Declarations Dec(..), Con(..), Clause(..), - Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..), + SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..), + Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, @@ -80,9 +83,10 @@ module Language.Haskell.TH( -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, ClauseQ, - BodyQ, GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ, - RuleBndrQ, TySynEqnQ, + 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 @@ -119,7 +123,9 @@ module Language.Haskell.TH( -- **** Type literals numTyLit, strTyLit, -- **** Strictness - isStrict, notStrict, strictType, varStrictType, + noSourceUnpackedness, sourceNoUnpack, sourceUnpack, + noSourceStrictness, sourceLazy, sourceStrict, + bang, bangType, varBangType, strictType, varStrictType, -- **** Class Contexts cxt, classP, equalP, -- **** Constructors diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 737b9d42c7..ef928e8a36 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -18,31 +18,38 @@ import Data.Word( Word8 ) -- * Type synonyms ---------------------------------------------------------- -type InfoQ = Q Info -type PatQ = Q Pat -type FieldPatQ = Q FieldPat -type ExpQ = Q Exp -type TExpQ a = Q (TExp a) -type DecQ = Q Dec -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 -type ClauseQ = Q Clause -type BodyQ = Q Body -type GuardQ = Q Guard -type StmtQ = Q Stmt -type RangeQ = Q Range -type StrictTypeQ = Q StrictType -type VarStrictTypeQ = Q VarStrictType -type FieldExpQ = Q FieldExp -type RuleBndrQ = Q RuleBndr -type TySynEqnQ = Q TySynEqn -type Role = TH.Role -- must be defined here for DsMeta to find it -type InjectivityAnn = TH.InjectivityAnn +type InfoQ = Q Info +type PatQ = Q Pat +type FieldPatQ = Q FieldPat +type ExpQ = Q Exp +type TExpQ a = Q (TExp a) +type DecQ = Q Dec +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 +type ClauseQ = Q Clause +type BodyQ = Q Body +type GuardQ = Q Guard +type StmtQ = Q Stmt +type RangeQ = Q Range +type SourceStrictnessQ = Q SourceStrictness +type SourceUnpackednessQ = Q SourceUnpackedness +type BangQ = Q Bang +type BangTypeQ = Q BangType +type VarBangTypeQ = Q VarBangType +type StrictTypeQ = Q StrictType +type VarStrictTypeQ = Q VarStrictType +type FieldExpQ = Q FieldExp +type RuleBndrQ = Q RuleBndr +type TySynEqnQ = Q TySynEqn + +-- must be defined here for DsMeta to find it +type Role = TH.Role +type InjectivityAnn = TH.InjectivityAnn ---------------------------------------------------------- -- * Lowercase pattern syntax functions @@ -529,13 +536,13 @@ tySynEqn lhs rhs = cxt :: [PredQ] -> CxtQ cxt = sequence -normalC :: Name -> [StrictTypeQ] -> ConQ +normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys -recC :: Name -> [VarStrictTypeQ] -> ConQ +recC :: Name -> [VarBangTypeQ] -> ConQ recC con varstrtys = liftM (RecC con) $ sequence varstrtys -infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ +infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ infixC st1 con st2 = do st1' <- st1 st2' <- st2 return $ InfixC st1' con st2' @@ -644,17 +651,37 @@ promotedNilT = return PromotedNilT promotedConsT :: TypeQ promotedConsT = return PromotedConsT -isStrict, notStrict, unpacked :: Q Strict -isStrict = return $ IsStrict -notStrict = return $ NotStrict -unpacked = return Unpacked +noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ +noSourceUnpackedness = return NoSourceUnpackedness +sourceNoUnpack = return SourceNoUnpack +sourceUnpack = return SourceUnpack +noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ +noSourceStrictness = return NoSourceStrictness +sourceLazy = return SourceLazy +sourceStrict = return SourceStrict + +bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ +bang u s = do u' <- u + s' <- s + return (Bang u' s') + +bangType :: BangQ -> TypeQ -> BangTypeQ +bangType = liftM2 (,) + +varBangType :: Name -> BangTypeQ -> VarBangTypeQ +varBangType v bt = do (b, t) <- bt + return (v, b, t) + +{-# DEPRECATED strictType + "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} strictType :: Q Strict -> TypeQ -> StrictTypeQ -strictType = liftM2 (,) +strictType = bangType +{-# DEPRECATED varStrictType + "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ -varStrictType v st = do (s, t) <- st - return (v, s, t) +varStrictType = varBangType -- * Type Literals diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index bf240f4ec5..d02ad0a30a 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -497,14 +497,14 @@ instance Ppr Clause where ------------------------------ instance Ppr Con where - ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts) + ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts) ppr (RecC c vsts) - = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts)) + = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) - ppr (InfixC st1 c st2) = pprStrictType st1 + ppr (InfixC st1 c st2) = pprBangType st1 <+> pprName' Infix c - <+> pprStrictType st2 + <+> pprBangType st2 ppr (ForallC ns ctxt (GadtC c sts ty idx)) = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx @@ -529,27 +529,69 @@ pprForall ns ctxt pprRecFields :: [(Name, Strict, Type)] -> Name -> [Type] -> Doc pprRecFields vsts ty idx - = braces (sep (punctuate comma $ map pprVarStrictType vsts)) + = braces (sep (punctuate comma $ map pprVarBangType vsts)) <+> arrow <+> ppr ty <+> sep (map ppr idx) pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc pprGadtRHS [] ty idx = ppr ty <+> sep (map ppr idx) pprGadtRHS sts ty idx - = sep (punctuate (space <> arrow) (map pprStrictType sts)) + = sep (punctuate (space <> arrow) (map pprBangType sts)) <+> arrow <+> ppr ty <+> sep (map ppr idx) ------------------------------ -pprVarStrictType :: (Name, Strict, Type) -> Doc +pprVarBangType :: VarBangType -> Doc -- Slight infelicity: with print non-atomic type with parens -pprVarStrictType (v, str, t) = ppr v <+> dcolon <+> pprStrictType (str, t) +pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t) + +------------------------------ +pprBangType :: BangType -> Doc +-- Make sure we print +-- +-- Con {-# UNPACK #-} a +-- +-- rather than +-- +-- Con {-# UNPACK #-}a +-- +-- when there's no strictness annotation. If there is a strictness annotation, +-- it's okay to not put a space between it and the type. +pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t +pprBangType (bt, t) = ppr bt <> pprParendType t + +------------------------------ +instance Ppr Bang where + ppr (Bang su ss) = ppr su <+> ppr ss + +------------------------------ +instance Ppr SourceUnpackedness where + ppr NoSourceUnpackedness = empty + ppr SourceNoUnpack = text "{-# NOUNPACK #-}" + ppr SourceUnpack = text "{-# UNPACK #-}" + +------------------------------ +instance Ppr SourceStrictness where + ppr NoSourceStrictness = empty + ppr SourceLazy = char '~' + ppr SourceStrict = char '!' + +------------------------------ +instance Ppr DecidedStrictness where + ppr DecidedLazy = empty + ppr DecidedStrict = char '!' + ppr DecidedUnpack = text "{-# UNPACK #-} !" + +------------------------------ +{-# DEPRECATED pprVarStrictType + "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-} +pprVarStrictType :: (Name, Strict, Type) -> Doc +pprVarStrictType = pprVarBangType ------------------------------ +{-# DEPRECATED pprStrictType + "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-} pprStrictType :: (Strict, Type) -> Doc --- Prints with parens if not already atomic -pprStrictType (IsStrict, t) = char '!' <> pprParendType t -pprStrictType (NotStrict, t) = pprParendType t -pprStrictType (Unpacked, t) = text "{-# UNPACK #-} !" <> pprParendType t +pprStrictType = pprBangType ------------------------------ pprParendType :: Type -> Doc diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index b333b006b6..d10fb3c0a5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -76,9 +76,10 @@ class (Applicative m, Monad m) => Quasi m where -- Returns list of matching instance Decs -- (with empty sub-Decs) -- Works for classes and type functions - qReifyRoles :: Name -> m [Role] - qReifyAnnotations :: Data a => AnnLookup -> m [a] - qReifyModule :: Module -> m ModuleInfo + qReifyRoles :: Name -> m [Role] + qReifyAnnotations :: Data a => AnnLookup -> m [a] + qReifyModule :: Module -> m ModuleInfo + qReifyConStrictness :: Name -> m [DecidedStrictness] qLocation :: m Loc @@ -117,22 +118,23 @@ instance Quasi IO where qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyFixity _ = badIO "reifyFixity" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qAddDependentFile _ = badIO "addDependentFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddModFinalizer _ = badIO "addModFinalizer" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" - qIsExtEnabled _ = badIO "isExtEnabled" - qExtsEnabled = badIO "extsEnabled" + qLookupName _ _ = badIO "lookupName" + qReify _ = badIO "reify" + qReifyFixity _ = badIO "reifyFixity" + qReifyInstances _ _ = badIO "reifyInstances" + qReifyRoles _ = badIO "reifyRoles" + qReifyAnnotations _ = badIO "reifyAnnotations" + qReifyModule _ = badIO "reifyModule" + qReifyConStrictness _ = badIO "reifyConStrictness" + qLocation = badIO "currentLocation" + qRecover _ _ = badIO "recover" -- Maybe we could fix this? + qAddDependentFile _ = badIO "addDependentFile" + qAddTopDecls _ = badIO "addTopDecls" + qAddModFinalizer _ = badIO "addModFinalizer" + qGetQ = badIO "getQ" + qPutQ _ = badIO "putQ" + qIsExtEnabled _ = badIO "isExtEnabled" + qExtsEnabled = badIO "extsEnabled" qRunIO m = m @@ -391,6 +393,21 @@ reifyAnnotations an = Q (qReifyAnnotations an) reifyModule :: Module -> Q ModuleInfo reifyModule m = Q (qReifyModule m) +-- | @reifyConStrictness nm@ looks up the strictness information for the fields +-- of the constructor with the name @nm@. Note that the strictness information +-- that 'reifyConStrictness' returns may not correspond to what is written in +-- the source code. For example, in the following data declaration: +-- +-- @ +-- data Pair a = Pair a a +-- @ +-- +-- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most +-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the +-- @-XStrictData@ language extension was enabled. +reifyConStrictness :: Name -> Q [DecidedStrictness] +reifyConStrictness n = Q (qReifyConStrictness n) + -- | Is the list of instances returned by 'reifyInstances' nonempty? isInstance :: Name -> [Type] -> Q Bool isInstance nm tys = do { decs <- reifyInstances nm tys @@ -451,25 +468,26 @@ extsEnabled :: Q [Extension] extsEnabled = Q qExtsEnabled instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qLookupName = lookupName - qLocation = location - qRunIO = runIO - qAddDependentFile = addDependentFile - qAddTopDecls = addTopDecls - qAddModFinalizer = addModFinalizer - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyFixity = reifyFixity + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness = reifyConStrictness + qLookupName = lookupName + qLocation = location + qRunIO = runIO + qAddDependentFile = addDependentFile + qAddTopDecls = addTopDecls + qAddModFinalizer = addModFinalizer + qGetQ = getQ + qPutQ = putQ + qIsExtEnabled = isExtEnabled + qExtsEnabled = extsEnabled ---------------------------------------------------- @@ -1593,22 +1611,39 @@ type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ -- be tuples of other constraints. type Pred = Type -data Strict = IsStrict | NotStrict | Unpacked - deriving( Show, Eq, Ord, Data, Typeable, Generic ) - -data Con = NormalC Name [StrictType] -- ^ @C Int a@ - | RecC Name [VarStrictType] -- ^ @C { v :: Int, w :: a }@ - | InfixC StrictType Name StrictType -- ^ @Int :+ a@ - | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ - | GadtC [Name] [StrictType] - Name -- See Note [GADT return type] - [Type] -- Indices of the type constructor - -- ^ @C :: a -> b -> T b Int@ - | RecGadtC [Name] [VarStrictType] - Name -- See Note [GADT return type] - [Type] -- Indices of the type constructor - -- ^ @C :: { v :: Int } -> T b Int@ - deriving( Show, Eq, Ord, Data, Typeable, Generic ) +data SourceUnpackedness + = NoSourceUnpackedness -- ^ @C a@ + | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ + | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ + deriving (Show, Eq, Ord, Data, Typeable, Generic) + +data SourceStrictness = NoSourceStrictness -- ^ @C a@ + | SourceLazy -- ^ @C {~}a@ + | SourceStrict -- ^ @C {!}a@ + deriving (Show, Eq, Ord, Data, Typeable, Generic) + +-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' +-- refers to the strictness that the compiler chooses for a data constructor +-- field, which may be different from what is written in source code. See +-- 'reifyConStrictness' for more information. +data DecidedStrictness = DecidedLazy + | DecidedStrict + | DecidedUnpack + deriving (Show, Eq, Ord, Data, Typeable, Generic) + +data Con = NormalC Name [BangType] -- ^ @C Int a@ + | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ + | InfixC BangType Name BangType -- ^ @Int :+ a@ + | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ + | GadtC [Name] [BangType] + Name -- See Note [GADT return type] + [Type] -- Indices of the type constructor + -- ^ @C :: a -> b -> T b Int@ + | RecGadtC [Name] [VarBangType] + Name -- See Note [GADT return type] + [Type] -- Indices of the type constructor + -- ^ @C :: { v :: Int } -> T b Int@ + deriving (Show, Eq, Ord, Data, Typeable, Generic) -- Note [GADT return type] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1621,8 +1656,23 @@ data Con = NormalC Name [StrictType] -- ^ @C Int a@ -- data T a where -- MkT :: S Int -type StrictType = (Strict, Type) -type VarStrictType = (Name, Strict, Type) +data Bang = Bang SourceUnpackedness SourceStrictness + -- ^ @C { {\-\# UNPACK \#-\} !}a@ + deriving (Show, Eq, Ord, Data, Typeable, Generic) + +type BangType = (Bang, Type) +type VarBangType = (Name, Bang, Type) + +-- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'. +type Strict = Bang + +-- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by +-- 'BangType'. +type StrictType = BangType + +-- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by +-- 'VarBangType'. +type VarStrictType = VarBangType data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<type\>@ | AppT Type Type -- ^ @T a b@ diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 33419b34ec..9564e95678 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -25,6 +25,18 @@ * Add `TypeFamilyHead` for common elements of `OpenTypeFamilyD` and `ClosedTypeFamilyD` (#10902) + * The `Strict` datatype was split among different datatypes: three for + writing the strictness information of data constructors' fields as denoted + 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) + + * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness` + values for its fields (#10697) + * TODO: document API changes and important bugfixes diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs index e97fdcea9a..d3c85ba9ec 100644 --- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs @@ -7,7 +7,10 @@ import Language.Haskell.TH.Syntax -- Splice in a datatype with field... $(return [DataD [] (mkName "R") [] Nothing - [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) + [RecC (mkName "MkR") [( mkName "foo" + , Bang NoSourceUnpackedness NoSourceStrictness + , ConT ''Int + )]] []]) -- New TH story means reify only sees R if we do this: $(return []) diff --git a/testsuite/tests/rts/T7919A.hs b/testsuite/tests/rts/T7919A.hs index 4dc013aeff..ddbdb04750 100644 --- a/testsuite/tests/rts/T7919A.hs +++ b/testsuite/tests/rts/T7919A.hs @@ -20,7 +20,9 @@ largeData = (dataName) [] Nothing - [normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))] + [normalC dataName + (replicate size (((,) <$> bang noSourceUnpackedness + noSourceStrictness) `ap` [t| Int |]))] (cxt []) conE' :: Name -> [ExpQ] -> ExpQ diff --git a/testsuite/tests/th/T10697_decided_1.hs b/testsuite/tests/th/T10697_decided_1.hs new file mode 100644 index 0000000000..241cec3d38 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +data T = T {-# UNPACK #-} !Int !Int Int + +$(return []) + +main :: IO () +main = putStrLn $(reifyConStrictness 'T >>= stringE . show) diff --git a/testsuite/tests/th/T10697_decided_1.stdout b/testsuite/tests/th/T10697_decided_1.stdout new file mode 100644 index 0000000000..b0dd4a284a --- /dev/null +++ b/testsuite/tests/th/T10697_decided_1.stdout @@ -0,0 +1 @@ +[DecidedStrict,DecidedStrict,DecidedLazy] diff --git a/testsuite/tests/th/T10697_decided_2.hs b/testsuite/tests/th/T10697_decided_2.hs new file mode 100644 index 0000000000..241cec3d38 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +data T = T {-# UNPACK #-} !Int !Int Int + +$(return []) + +main :: IO () +main = putStrLn $(reifyConStrictness 'T >>= stringE . show) diff --git a/testsuite/tests/th/T10697_decided_2.stdout b/testsuite/tests/th/T10697_decided_2.stdout new file mode 100644 index 0000000000..c4cfc4ab79 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_2.stdout @@ -0,0 +1 @@ +[DecidedStrict,DecidedStrict,DecidedStrict] diff --git a/testsuite/tests/th/T10697_decided_3.hs b/testsuite/tests/th/T10697_decided_3.hs new file mode 100644 index 0000000000..241cec3d38 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +data T = T {-# UNPACK #-} !Int !Int Int + +$(return []) + +main :: IO () +main = putStrLn $(reifyConStrictness 'T >>= stringE . show) diff --git a/testsuite/tests/th/T10697_decided_3.stdout b/testsuite/tests/th/T10697_decided_3.stdout new file mode 100644 index 0000000000..ae59571a61 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_3.stdout @@ -0,0 +1 @@ +[DecidedUnpack,DecidedUnpack,DecidedUnpack] diff --git a/testsuite/tests/th/T10697_source.hs b/testsuite/tests/th/T10697_source.hs new file mode 100644 index 0000000000..4dfa410168 --- /dev/null +++ b/testsuite/tests/th/T10697_source.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE StrictData, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH +import T10697_sourceUtil + +$([d|data A1 = A1 Int {- No unpackedness, no strictness -}|]) +$([d|data A2 = A2 !Int {- No unpackedness, strict -}|]) +$([d|data A3 = A3 ~Int {- No unpackedness, lazy -}|]) +$([d|data A4 = A4 {-# NOUNPACK #-} Int {- NOUNPACK, no strictness -}|]) +$([d|data A5 = A5 {-# NOUNPACK #-} !Int {- NOUNPACK, strict -}|]) +$([d|data A6 = A6 {-# NOUNPACK #-} ~Int {- NOUNPACK, lazy -}|]) +$([d|data A7 = A7 {-# UNPACK #-} Int {- UNPACK, no strictness -}|]) +$([d|data A8 = A8 {-# UNPACK #-} !Int {- UNPACK, strict -}|]) +$([d|data A9 = A9 {-# UNPACK #-} ~Int {- UNPACK, lazy -}|]) + +$(do b1 <- newName "B1" + b2 <- newName "B2" + b3 <- newName "B3" + b4 <- newName "B4" + b5 <- newName "B5" + b6 <- newName "B6" + b7 <- newName "B7" + b8 <- newName "B8" + b9 <- newName "B9" + c1 <- newName "C1" + c2 <- newName "C2" + c3 <- newName "C3" + c4 <- newName "C4" + c5 <- newName "C5" + c6 <- newName "C6" + c7 <- newName "C7" + c8 <- newName "C8" + c9 <- newName "C9" + + d1 <- makeSimpleDatatype b1 c1 noSourceUnpackedness noSourceStrictness + d2 <- makeSimpleDatatype b2 c2 noSourceUnpackedness sourceStrict + d3 <- makeSimpleDatatype b3 c3 noSourceUnpackedness sourceLazy + d4 <- makeSimpleDatatype b4 c4 sourceNoUnpack noSourceStrictness + d5 <- makeSimpleDatatype b5 c5 sourceNoUnpack sourceStrict + d6 <- makeSimpleDatatype b6 c6 sourceNoUnpack sourceLazy + d7 <- makeSimpleDatatype b7 c7 sourceUnpack noSourceStrictness + d8 <- makeSimpleDatatype b8 c8 sourceUnpack sourceStrict + d9 <- makeSimpleDatatype b9 c9 sourceUnpack sourceLazy + return [d1, d2, d3, d4, d5, d6, d7, d8, d9]) + +main :: IO () +main = mapM_ print [ $(checkBang ''E1 noSourceUnpackedness noSourceStrictness) + , $(checkBang ''E2 noSourceUnpackedness sourceStrict) + , $(checkBang ''E3 noSourceUnpackedness sourceLazy) + , $(checkBang ''E4 sourceNoUnpack noSourceStrictness) + , $(checkBang ''E5 sourceNoUnpack sourceStrict) + , $(checkBang ''E6 sourceNoUnpack sourceLazy) + , $(checkBang ''E7 sourceUnpack noSourceStrictness) + , $(checkBang ''E8 sourceUnpack sourceStrict) + , $(checkBang ''E9 sourceUnpack sourceLazy) + ] diff --git a/testsuite/tests/th/T10697_source.stdout b/testsuite/tests/th/T10697_source.stdout new file mode 100644 index 0000000000..c4dc445159 --- /dev/null +++ b/testsuite/tests/th/T10697_source.stdout @@ -0,0 +1,9 @@ +True +True +True +True +True +True +True +True +True diff --git a/testsuite/tests/th/T10697_sourceUtil.hs b/testsuite/tests/th/T10697_sourceUtil.hs new file mode 100644 index 0000000000..048a422b99 --- /dev/null +++ b/testsuite/tests/th/T10697_sourceUtil.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE StrictData, TemplateHaskell #-} +module T10697_sourceUtil where + +import Language.Haskell.TH + +makeSimpleDatatype :: Name + -> Name + -> SourceUnpackednessQ + -> SourceStrictnessQ + -> Q Dec +makeSimpleDatatype tyName conName srcUpk srcStr = + dataD (cxt []) tyName [] Nothing [normalC conName + [bangType (bang srcUpk srcStr) (conT ''Int)]] (cxt []) + +checkBang :: Name + -> SourceUnpackednessQ + -> SourceStrictnessQ + -> ExpQ +checkBang n srcUpk1 srcStr1 = do + TyConI (DataD _ _ _ _ [NormalC _ [(Bang srcUpk2 srcStr2, _)]] _) <- reify n + srcUpk1' <- srcUpk1 + srcStr1' <- srcStr1 + if srcUpk1' == srcUpk2 && srcStr1' == srcStr2 + then [| True |] + else [| False |] + +data E1 = E1 Int -- No unpackedness, no strictness +data E2 = E2 !Int -- No unpackedness, strict +data E3 = E3 ~Int -- No unpackedness, lazy +data E4 = E4 {-# NOUNPACK #-} Int -- NOUNPACK, no strictness +data E5 = E5 {-# NOUNPACK #-} !Int -- NOUNPACK, strict +data E6 = E6 {-# NOUNPACK #-} ~Int -- NOUNPACK, lazy +data E7 = E7 {-# UNPACK #-} Int -- UNPACK, no strictness +data E8 = E8 {-# UNPACK #-} !Int -- UNPACK, strict +data E9 = E9 {-# UNPACK #-} ~Int -- UNPACK, lazy diff --git a/testsuite/tests/th/T10819_Lib.hs b/testsuite/tests/th/T10819_Lib.hs index 94f352efe7..2be00b4a51 100644 --- a/testsuite/tests/th/T10819_Lib.hs +++ b/testsuite/tests/th/T10819_Lib.hs @@ -2,6 +2,6 @@ module T10819_Lib where import Language.Haskell.TH.Syntax -doSomeTH s tp drv = return [NewtypeD [] n [] Nothing - (NormalC n [(NotStrict, ConT tp)]) drv] +doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] where n = mkName s diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs index f01c5b9769..75b852ff07 100644 --- a/testsuite/tests/th/T10828.hs +++ b/testsuite/tests/th/T10828.hs @@ -33,16 +33,28 @@ $( return [ PlainTV (mkName "a") ] (Just StarT) [ GadtC [(mkName "MkT")] - [ (NotStrict, VarT (mkName "a")) - , (NotStrict, VarT (mkName "a"))] + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + ] ( mkName "T" ) [ VarT (mkName "a") ] , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ RecGadtC [(mkName "MkC")] - [ (mkName "foo", NotStrict, VarT (mkName "a")) - , (mkName "bar", NotStrict, VarT (mkName "b"))] + [ ( mkName "foo" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( mkName "bar" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "b") + ) + ] ( mkName "T" ) [ ConT (mkName "Int") ] ] [] ]) diff --git a/testsuite/tests/th/T10828a.hs b/testsuite/tests/th/T10828a.hs index 8bf13cfb04..c3108c3e38 100644 --- a/testsuite/tests/th/T10828a.hs +++ b/testsuite/tests/th/T10828a.hs @@ -11,7 +11,12 @@ $( return [ PlainTV (mkName "a") ] (Just StarT) [ NormalC (mkName "MkT") - [ (NotStrict, VarT (mkName "a")) - , (NotStrict, VarT (mkName "a"))] + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + ] ] [] ]) diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs index 55d8889009..ac4f6a28e5 100644 --- a/testsuite/tests/th/T10828b.hs +++ b/testsuite/tests/th/T10828b.hs @@ -10,16 +10,30 @@ $( return [ DataD [] (mkName "T") [ PlainTV (mkName "a") ] (Just StarT) - [ NormalC (mkName "MkT") - [ (NotStrict, VarT (mkName "a")) - , (NotStrict, VarT (mkName "a"))] + [ NormalC + (mkName "MkT") + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + ] , ForallC [PlainTV (mkName "a")] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ - RecGadtC [(mkName "MkC")] - [ (mkName "foo", NotStrict, VarT (mkName "a")) - , (mkName "bar", NotStrict, VarT (mkName "b"))] - ( mkName "T" ) - [ ConT (mkName "Int") ] + RecGadtC + [ (mkName "MkC")] + [ ( mkName "foo" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( mkName "bar" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "b") + ) + ] + ( mkName "T" ) + [ ConT (mkName "Int") ] ] [] ]) diff --git a/testsuite/tests/th/T5290.hs b/testsuite/tests/th/T5290.hs index 50ad2d500c..2215ef1075 100644 --- a/testsuite/tests/th/T5290.hs +++ b/testsuite/tests/th/T5290.hs @@ -5,4 +5,5 @@ module T5290 where import Language.Haskell.TH $( let n = mkName "T" - in return [DataD [] n [] Nothing [NormalC n [(Unpacked,ConT ''Int)]] []] ) + in return [DataD [] n [] Nothing + [NormalC n [(Bang SourceUnpack SourceStrict,ConT ''Int)]] []] ) diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr index d6996d0799..19c962a9a0 100644 --- a/testsuite/tests/th/T5290.stderr +++ b/testsuite/tests/th/T5290.stderr @@ -1,7 +1,13 @@ -T5290.hs:(7,4)-(8,75): Splicing declarations +T5290.hs:(7,4)-(9,77): Splicing declarations let n = mkName "T" in return - [DataD [] n [] Nothing [NormalC n [(Unpacked, ConT ''Int)]] []] + [DataD + [] + n + [] + Nothing + [NormalC n [(Bang SourceUnpack SourceStrict, ConT ''Int)]] + []] ======> data T = T {-# UNPACK #-} !Int diff --git a/testsuite/tests/th/T5665a.hs b/testsuite/tests/th/T5665a.hs index b34131e974..2b558271b3 100644 --- a/testsuite/tests/th/T5665a.hs +++ b/testsuite/tests/th/T5665a.hs @@ -2,6 +2,6 @@ module T5665a where import Language.Haskell.TH -doSomeTH s tp = return [NewtypeD [] n [] Nothing - (NormalC n [(NotStrict, ConT tp)]) []] +doSomeTH s tp = return [NewtypeD [] n [] Nothing (NormalC n + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) []] where n = mkName s diff --git a/testsuite/tests/th/T5984_Lib.hs b/testsuite/tests/th/T5984_Lib.hs index a929086dd2..d8913cd8f3 100644 --- a/testsuite/tests/th/T5984_Lib.hs +++ b/testsuite/tests/th/T5984_Lib.hs @@ -5,10 +5,11 @@ module T5984_Lib where import Language.Haskell.TH nt :: Q [Dec] -nt = return [NewtypeD [] foo [] Nothing - (NormalC foo [(NotStrict, ConT ''Int)]) []] +nt = return [NewtypeD [] foo [] Nothing (NormalC foo + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]) []] where foo = mkName "Foo" dt :: Q [Dec] -dt = return [DataD [] bar [] Nothing [NormalC bar [(NotStrict, ConT ''Int)]] []] +dt = return [DataD [] bar [] Nothing [NormalC bar + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]] []] where bar = mkName "Bar" diff --git a/testsuite/tests/th/T7532.hs b/testsuite/tests/th/T7532.hs index 3a641ea97a..a7604710f5 100644 --- a/testsuite/tests/th/T7532.hs +++ b/testsuite/tests/th/T7532.hs @@ -8,4 +8,4 @@ import T7532a instance C Bool where data D Bool = MkD -$(bang) +$(bang') diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr index 3e57bb8955..baaf04f3f5 100644 --- a/testsuite/tests/th/T7532.stderr +++ b/testsuite/tests/th/T7532.stderr @@ -3,8 +3,8 @@ instance C Bool where data D Bool = T7532.MkD -T7532.hs:11:3-6: Splicing declarations - bang +T7532.hs:11:3-7: Splicing declarations + bang' ======> instance C Int where data D Int = T diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs index 42976b393c..901e27a1bf 100644 --- a/testsuite/tests/th/T7532a.hs +++ b/testsuite/tests/th/T7532a.hs @@ -8,8 +8,8 @@ import Language.Haskell.TH class C a where data D a -bang :: DecsQ -bang = return [ +bang' :: DecsQ +bang' = return [ InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [ DataInstD [] ''D [ConT ''Int] Nothing [ NormalC (mkName "T") []] []]] diff --git a/testsuite/tests/th/TH_genExLib.hs b/testsuite/tests/th/TH_genExLib.hs index 5e1ee0bfc0..25091c4ecf 100644 --- a/testsuite/tests/th/TH_genExLib.hs +++ b/testsuite/tests/th/TH_genExLib.hs @@ -16,5 +16,6 @@ genAnyClass name decls where anyName = mkName ("Any" ++ nameBase name ++ "1111") constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $ - NormalC anyName [(NotStrict, VarT var_a)] + NormalC anyName + [(Bang NoSourceUnpackedness NoSourceStrictness, VarT var_a)] var_a = mkName "a" diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 5a55b6f0da..9d00d8e856 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -358,6 +358,15 @@ test('T10306', normal, compile, ['-v0']) test('T10596', normal, compile, ['-v0']) test('T10620', normal, compile_and_run, ['-v0']) test('T10638', normal, compile_fail, ['-v0']) +test('T10697_decided_1', normal, compile_and_run, ['-v0']) +test('T10697_decided_2', normal, compile_and_run, ['-XStrictData -v0']) +test('T10697_decided_3', normal, + compile_and_run, + ['-XStrictData -funbox-strict-fields -O2 -v0']) +test('T10697_source', + extra_clean(['T10697_sourceUtil.hi', 'T10697_sourceUtil.o']), + multimod_compile_and_run, + ['T10697_source', '-w ' + config.ghc_th_way_flags]) test('T10704', extra_clean(['T10704a.o','T10704a.hi']), multimod_compile_and_run, |