Commit f975b0b1 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent b407bd77
......@@ -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
......
......@@ -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)
......
......@@ -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,
......
......@@ -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
......
......@@ -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
~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
------------------------------