diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-15 21:15:43 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-15 21:15:43 +0100 |
| commit | 65c019407134fcb0c6b7c9d2038ba07c52e2a6c2 (patch) | |
| tree | e5feaa7b92186353b5057e058fa09e3172982bc3 /compiler | |
| parent | 2450eca2c0596eade8dce7d85c7e87bcc848d135 (diff) | |
| download | haskell-65c019407134fcb0c6b7c9d2038ba07c52e2a6c2.tar.gz | |
Extend Template Haskell to support the UNPACk pragma on data constructors
(Work done by mikhail.vorozhtsov.)
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 13 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 1 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.lhs | 5 |
3 files changed, 12 insertions, 7 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 3988105e90..7538e310ce 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 7b0d8c4f0d..49cd0d3575 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -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) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 97ad485e6a..b3abe84c32 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -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 |