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

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