Commit cdb01ba2 authored by igloo's avatar igloo

[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.
parent 47edb657
......@@ -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)
......@@ -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]
......
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