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 ...@@ -435,8 +435,9 @@ repBangTy ty= do
rep2 strictTypeName [s, t] rep2 strictTypeName [s, t]
where where
(str, ty') = case ty of (str, ty') = case ty of
L _ (HsBangTy _ ty) -> (isStrictName, ty) L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty)
_ -> (notStrictName, ty) L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
------------------------------------------------------- -------------------------------------------------------
-- Deriving clause -- Deriving clause
...@@ -1778,7 +1779,7 @@ templateHaskellNames = [ ...@@ -1778,7 +1779,7 @@ templateHaskellNames = [
-- Pred -- Pred
classPName, equalPName, classPName, equalPName,
-- Strict -- Strict
isStrictName, notStrictName, isStrictName, notStrictName, unpackedName,
-- Con -- Con
normalCName, recCName, infixCName, forallCName, normalCName, recCName, infixCName, forallCName,
-- StrictType -- StrictType
...@@ -1998,9 +1999,10 @@ classPName = libFun (fsLit "classP") classPIdKey ...@@ -1998,9 +1999,10 @@ classPName = libFun (fsLit "classP") classPIdKey
equalPName = libFun (fsLit "equalP") equalPIdKey equalPName = libFun (fsLit "equalP") equalPIdKey
-- data Strict = ... -- data Strict = ...
isStrictName, notStrictName :: Name isStrictName, notStrictName, unpackedName :: Name
isStrictName = libFun (fsLit "isStrict") isStrictKey isStrictName = libFun (fsLit "isStrict") isStrictKey
notStrictName = libFun (fsLit "notStrict") notStrictKey notStrictName = libFun (fsLit "notStrict") notStrictKey
unpackedName = libFun (fsLit "unpacked") unpackedKey
-- data Con = ... -- data Con = ...
normalCName, recCName, infixCName, forallCName :: Name normalCName, recCName, infixCName, forallCName :: Name
...@@ -2280,9 +2282,10 @@ classPIdKey = mkPreludeMiscIdUnique 361 ...@@ -2280,9 +2282,10 @@ classPIdKey = mkPreludeMiscIdUnique 361
equalPIdKey = mkPreludeMiscIdUnique 362 equalPIdKey = mkPreludeMiscIdUnique 362
-- data Strict = ... -- data Strict = ...
isStrictKey, notStrictKey :: Unique isStrictKey, notStrictKey, unpackedKey :: Unique
isStrictKey = mkPreludeMiscIdUnique 363 isStrictKey = mkPreludeMiscIdUnique 363
notStrictKey = mkPreludeMiscIdUnique 364 notStrictKey = mkPreludeMiscIdUnique 364
unpackedKey = mkPreludeMiscIdUnique 365
-- data Con = ... -- data Con = ...
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
......
...@@ -336,6 +336,7 @@ cvtConstr (ForallC tvs ctxt con) ...@@ -336,6 +336,7 @@ cvtConstr (ForallC tvs ctxt con)
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
cvt_arg (NotStrict, ty) = cvtType 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 :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg (i, str, ty) cvt_id_arg (i, str, ty)
......
...@@ -1315,8 +1315,9 @@ reifyFixity name ...@@ -1315,8 +1315,9 @@ reifyFixity name
conv_dir BasicTypes.InfixN = TH.InfixN conv_dir BasicTypes.InfixN = TH.InfixN
reifyStrict :: BasicTypes.HsBang -> TH.Strict reifyStrict :: BasicTypes.HsBang -> TH.Strict
reifyStrict bang | isBanged bang = TH.IsStrict reifyStrict bang | bang == HsUnpack = TH.Unpacked
| otherwise = TH.NotStrict | isBanged bang = TH.IsStrict
| otherwise = TH.NotStrict
------------------------------ ------------------------------
noTH :: LitString -> SDoc -> TcM a 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