diff options
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, |