Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/65c019407134fcb0c6b7c9d2038ba07c52e2a6c2 >--------------------------------------------------------------- commit 65c019407134fcb0c6b7c9d2038ba07c52e2a6c2 Author: Simon Peyton Jones <[email protected]> Date: Fri Jul 15 21:15:43 2011 +0100 Extend Template Haskell to support the UNPACk pragma on data constructors (Work done by mikhail.vorozhtsov.) >--------------------------------------------------------------- compiler/deSugar/DsMeta.hs | 13 ++++++++----- compiler/hsSyn/Convert.lhs | 1 + 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 3988105..7538e31 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 7b0d8c4..49cd0d3 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 97ad485..b3abe84 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
