From cdb01ba27de9a4aeb7cff6a3682a38c482ca6ae2 Mon Sep 17 00:00:00 2001 From: igloo Date: Tue, 18 Feb 2003 16:23:36 +0000 Subject: [PATCH] [project @ 2003-02-18 16:23:35 by igloo] Support strictness annotations on data declarations and support the record and infix constructors. Also tweaked the pretty printer a bit. --- ghc/compiler/deSugar/DsMeta.hs | 62 +++++++++++++++++++++++++++++++--------- ghc/compiler/hsSyn/Convert.lhs | 18 ++++++++++-- 2 files changed, 64 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index d4b14d4..0b58d3d 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -74,6 +74,8 @@ import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) import Outputable import FastString ( mkFastString ) + +import Monad ( zipWithM ) ----------------------------------------------------------------------------- dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr @@ -257,15 +259,15 @@ repInstD (InstDecl ty binds _ _ loc) repC :: ConDecl Name -> DsM (Core M.Cons) repC (ConDecl con [] [] details loc) = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences] - arg_tys <- mapM (repBangTy con) (hsConArgs details) ; - arg_tys1 <- coreList typeTyConName arg_tys ; - repConstr con1 arg_tys1 } + repConstr con1 details } -repBangTy con (BangType NotMarkedStrict ty) = repTy ty -repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) } - where - msg = ptext SLIT("Ignoring stricness on argument of constructor") - <+> quotes (ppr con) +repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ))) +repBangTy (BangType str ty) = do MkC s <- rep2 strName [] + MkC t <- repTy ty + rep2 strictTypeName [s, t] + where strName = case str of + NotMarkedStrict -> nonstrictName + _ -> strictName ------------------------------------------------------- -- Deriving clause @@ -999,8 +1001,23 @@ repProto (MkC s) (MkC ty) = rep2 protoName [s, ty] repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt) repCtxt (MkC tys) = rep2 ctxtName [tys] -repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons) -repConstr (MkC con) (MkC tys) = rep2 constrName [con, tys] +repConstr :: Core String -> HsConDetails Name (BangType Name) + -> DsM (Core M.Cons) +repConstr con (PrefixCon ps) + = do arg_tys <- mapM repBangTy ps + arg_tys1 <- coreList strTypeTyConName arg_tys + rep2 constrName [unC con, unC arg_tys1] +repConstr con (RecCon ips) + = do arg_vs <- mapM lookupOcc (map fst ips) + arg_tys <- mapM repBangTy (map snd ips) + arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) + arg_vs arg_tys + arg_vtys' <- coreList varStrTypeTyConName arg_vtys + rep2 recConstrName [unC con, unC arg_vtys'] +repConstr con (InfixCon st1 st2) + = do arg1 <- repBangTy st1 + arg2 <- repBangTy st2 + rep2 infixConstrName [unC arg1, unC con, unC arg2] ------------ Types ------------------- @@ -1134,11 +1151,13 @@ templateHaskellNames matchName, clauseName, funName, valName, tySynDName, dataDName, classDName, instName, protoName, tforallName, tvarName, tconName, tappName, arrowTyConName, tupleTyConName, listTyConName, namedTyConName, - ctxtName, constrName, + ctxtName, constrName, recConstrName, infixConstrName, exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName, stmtTyConName, consTyConName, typeTyConName, + strTypeTyConName, varStrTypeTyConName, qTyConName, expTyConName, matTyConName, clsTyConName, - decTyConName, typTyConName ] + decTyConName, typTyConName, strictTypeName, varStrictTypeName, + strictName, nonstrictName ] varQual = mk_known_key_name OccName.varName @@ -1227,6 +1246,8 @@ ctxtName = varQual FSLIT("ctxt") ctxtIdKey -- data Con = ... constrName = varQual FSLIT("constr") constrIdKey +recConstrName = varQual FSLIT("recConstr") recConstrIdKey +infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey exprTyConName = tcQual FSLIT("Expr") exprTyConKey declTyConName = tcQual FSLIT("Decl") declTyConKey @@ -1236,6 +1257,8 @@ clseTyConName = tcQual FSLIT("Clse") clseTyConKey stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey consTyConName = tcQual FSLIT("Cons") consTyConKey typeTyConName = tcQual FSLIT("Type") typeTyConKey +strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey +varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey qTyConName = tcQual FSLIT("Q") qTyConKey expTyConName = tcQual FSLIT("Exp") expTyConKey @@ -1244,6 +1267,11 @@ typTyConName = tcQual FSLIT("Typ") typTyConKey matTyConName = tcQual FSLIT("Mat") matTyConKey clsTyConName = tcQual FSLIT("Cls") clsTyConKey +strictTypeName = varQual FSLIT("strictType") strictTypeKey +varStrictTypeName = varQual FSLIT("varStrictType") varStrictTypeKey +strictName = varQual FSLIT("strict") strictKey +nonstrictName = varQual FSLIT("nonstrict") nonstrictKey + -- TyConUniques available: 100-119 -- Check in PrelNames if you want to change this @@ -1261,6 +1289,8 @@ consTyConKey = mkPreludeTyConUnique 110 typeTyConKey = mkPreludeTyConUnique 111 typTyConKey = mkPreludeTyConUnique 112 decTyConKey = mkPreludeTyConUnique 113 +varStrTypeTyConKey = mkPreludeTyConUnique 114 +strTypeTyConKey = mkPreludeTyConUnique 115 @@ -1339,7 +1369,13 @@ rationalLIdKey = mkPreludeMiscIdUnique 262 sigExpIdKey = mkPreludeMiscIdUnique 263 +strictTypeKey = mkPreludeMiscIdUnique 264 +strictKey = mkPreludeMiscIdUnique 265 +nonstrictKey = mkPreludeMiscIdUnique 266 +varStrictTypeKey = mkPreludeMiscIdUnique 267 +recConstrIdKey = mkPreludeMiscIdUnique 268 +infixConstrIdKey = mkPreludeMiscIdUnique 269 -- %************************************************************************ -- %* * @@ -1349,4 +1385,4 @@ sigExpIdKey = mkPreludeMiscIdUnique 263 -- It is rather usatisfactory that we don't have a SrcLoc addDsWarn :: SDoc -> DsM () -addDsWarn msg = dsWarn (noSrcLoc, msg) \ No newline at end of file +addDsWarn msg = dsWarn (noSrcLoc, msg) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 3d9996f..e6e3a2a 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -60,11 +60,23 @@ cvt_top (Data tc tvs constrs derivs) (DataCons (map mk_con constrs)) (mk_derivs derivs) loc0) where - mk_con (Constr c tys) + mk_con (Constr c strtys) = ConDecl (cName c) noExistentials noContext - (PrefixCon (map mk_arg tys)) loc0 + (PrefixCon (map mk_arg strtys)) loc0 + mk_con (RecConstr c varstrtys) + = ConDecl (cName c) noExistentials noContext + (RecCon (map mk_id_arg varstrtys)) loc0 + mk_con (InfixConstr st1 c st2) + = ConDecl (cName c) noExistentials noContext + (InfixCon (mk_arg st1) (mk_arg st2)) loc0 + + mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty) + mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty) - mk_arg ty = BangType NotMarkedStrict (cvtType ty) + mk_id_arg (i, Strict, ty) + = (vName i, BangType MarkedUserStrict (cvtType ty)) + mk_id_arg (i, NonStrict, ty) + = (vName i, BangType NotMarkedStrict (cvtType ty)) mk_derivs [] = Nothing mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] -- 1.7.10.4