Commit 65c01940 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Extend Template Haskell to support the UNPACk pragma on data constructors

(Work done by mikhail.vorozhtsov.)
parent 2450eca2
......@@ -435,8 +435,9 @@ repBangTy ty= do
rep2 strictTypeName [s, t]
where
(str, ty') = case ty of
L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty)
L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
......@@ -1778,7 +1779,7 @@ templateHaskellNames = [
-- Pred
classPName, equalPName,
-- Strict
isStrictName, notStrictName,
isStrictName, notStrictName, unpackedName,
-- Con
normalCName, recCName, infixCName, forallCName,
-- StrictType
......@@ -1998,9 +1999,10 @@ classPName = libFun (fsLit "classP") classPIdKey
equalPName = libFun (fsLit "equalP") equalPIdKey
-- data Strict = ...
isStrictName, notStrictName :: Name
isStrictName, notStrictName, unpackedName :: Name
isStrictName = libFun (fsLit "isStrict") isStrictKey
notStrictName = libFun (fsLit "notStrict") notStrictKey
unpackedName = libFun (fsLit "unpacked") unpackedKey
-- data Con = ...
normalCName, recCName, infixCName, forallCName :: Name
......@@ -2280,9 +2282,10 @@ classPIdKey = mkPreludeMiscIdUnique 361
equalPIdKey = mkPreludeMiscIdUnique 362
-- data Strict = ...
isStrictKey, notStrictKey :: Unique
isStrictKey, notStrictKey, unpackedKey :: Unique
isStrictKey = mkPreludeMiscIdUnique 363
notStrictKey = mkPreludeMiscIdUnique 364
unpackedKey = mkPreludeMiscIdUnique 365
-- data Con = ...
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
......
......@@ -336,6 +336,7 @@ cvtConstr (ForallC tvs ctxt con)
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
cvt_arg (NotStrict, ty) = cvtType ty
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg (i, str, ty)
......
......@@ -1315,8 +1315,9 @@ reifyFixity name
conv_dir BasicTypes.InfixN = TH.InfixN
reifyStrict :: BasicTypes.HsBang -> TH.Strict
reifyStrict bang | isBanged bang = TH.IsStrict
| otherwise = TH.NotStrict
reifyStrict bang | bang == HsUnpack = TH.Unpacked
| isBanged bang = TH.IsStrict
| otherwise = TH.NotStrict
------------------------------
noTH :: LitString -> SDoc -> TcM a
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment