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 ) ...@@ -74,6 +74,8 @@ import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
import Outputable import Outputable
import FastString ( mkFastString ) import FastString ( mkFastString )
import Monad ( zipWithM )
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
...@@ -257,15 +259,15 @@ repInstD (InstDecl ty binds _ _ loc) ...@@ -257,15 +259,15 @@ repInstD (InstDecl ty binds _ _ loc)
repC :: ConDecl Name -> DsM (Core M.Cons) repC :: ConDecl Name -> DsM (Core M.Cons)
repC (ConDecl con [] [] details loc) repC (ConDecl con [] [] details loc)
= do { con1 <- lookupOcc con ; -- See note [Binders and occurrences] = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
arg_tys <- mapM (repBangTy con) (hsConArgs details) ; repConstr con1 details }
arg_tys1 <- coreList typeTyConName arg_tys ;
repConstr con1 arg_tys1 }
repBangTy con (BangType NotMarkedStrict ty) = repTy ty repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ)))
repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) } repBangTy (BangType str ty) = do MkC s <- rep2 strName []
where MkC t <- repTy ty
msg = ptext SLIT("Ignoring stricness on argument of constructor") rep2 strictTypeName [s, t]
<+> quotes (ppr con) where strName = case str of
NotMarkedStrict -> nonstrictName
_ -> strictName
------------------------------------------------------- -------------------------------------------------------
-- Deriving clause -- Deriving clause
...@@ -999,8 +1001,23 @@ repProto (MkC s) (MkC ty) = rep2 protoName [s, ty] ...@@ -999,8 +1001,23 @@ repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt) repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt)
repCtxt (MkC tys) = rep2 ctxtName [tys] repCtxt (MkC tys) = rep2 ctxtName [tys]
repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons) repConstr :: Core String -> HsConDetails Name (BangType Name)
repConstr (MkC con) (MkC tys) = rep2 constrName [con, tys] -> 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 ------------------- ------------ Types -------------------
...@@ -1134,11 +1151,13 @@ templateHaskellNames ...@@ -1134,11 +1151,13 @@ templateHaskellNames
matchName, clauseName, funName, valName, tySynDName, dataDName, classDName, matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
instName, protoName, tforallName, tvarName, tconName, tappName, instName, protoName, tforallName, tvarName, tconName, tappName,
arrowTyConName, tupleTyConName, listTyConName, namedTyConName, arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
ctxtName, constrName, ctxtName, constrName, recConstrName, infixConstrName,
exprTyConName, declTyConName, pattTyConName, mtchTyConName, exprTyConName, declTyConName, pattTyConName, mtchTyConName,
clseTyConName, stmtTyConName, consTyConName, typeTyConName, clseTyConName, stmtTyConName, consTyConName, typeTyConName,
strTypeTyConName, varStrTypeTyConName,
qTyConName, expTyConName, matTyConName, clsTyConName, qTyConName, expTyConName, matTyConName, clsTyConName,
decTyConName, typTyConName ] decTyConName, typTyConName, strictTypeName, varStrictTypeName,
strictName, nonstrictName ]
varQual = mk_known_key_name OccName.varName varQual = mk_known_key_name OccName.varName
...@@ -1227,6 +1246,8 @@ ctxtName = varQual FSLIT("ctxt") ctxtIdKey ...@@ -1227,6 +1246,8 @@ ctxtName = varQual FSLIT("ctxt") ctxtIdKey
-- data Con = ... -- data Con = ...
constrName = varQual FSLIT("constr") constrIdKey constrName = varQual FSLIT("constr") constrIdKey
recConstrName = varQual FSLIT("recConstr") recConstrIdKey
infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey
exprTyConName = tcQual FSLIT("Expr") exprTyConKey exprTyConName = tcQual FSLIT("Expr") exprTyConKey
declTyConName = tcQual FSLIT("Decl") declTyConKey declTyConName = tcQual FSLIT("Decl") declTyConKey
...@@ -1236,6 +1257,8 @@ clseTyConName = tcQual FSLIT("Clse") clseTyConKey ...@@ -1236,6 +1257,8 @@ clseTyConName = tcQual FSLIT("Clse") clseTyConKey
stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
consTyConName = tcQual FSLIT("Cons") consTyConKey consTyConName = tcQual FSLIT("Cons") consTyConKey
typeTyConName = tcQual FSLIT("Type") typeTyConKey typeTyConName = tcQual FSLIT("Type") typeTyConKey
strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey
varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey
qTyConName = tcQual FSLIT("Q") qTyConKey qTyConName = tcQual FSLIT("Q") qTyConKey
expTyConName = tcQual FSLIT("Exp") expTyConKey expTyConName = tcQual FSLIT("Exp") expTyConKey
...@@ -1244,6 +1267,11 @@ typTyConName = tcQual FSLIT("Typ") typTyConKey ...@@ -1244,6 +1267,11 @@ typTyConName = tcQual FSLIT("Typ") typTyConKey
matTyConName = tcQual FSLIT("Mat") matTyConKey matTyConName = tcQual FSLIT("Mat") matTyConKey
clsTyConName = tcQual FSLIT("Cls") clsTyConKey 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 -- TyConUniques available: 100-119
-- Check in PrelNames if you want to change this -- Check in PrelNames if you want to change this
...@@ -1261,6 +1289,8 @@ consTyConKey = mkPreludeTyConUnique 110 ...@@ -1261,6 +1289,8 @@ consTyConKey = mkPreludeTyConUnique 110
typeTyConKey = mkPreludeTyConUnique 111 typeTyConKey = mkPreludeTyConUnique 111
typTyConKey = mkPreludeTyConUnique 112 typTyConKey = mkPreludeTyConUnique 112
decTyConKey = mkPreludeTyConUnique 113 decTyConKey = mkPreludeTyConUnique 113
varStrTypeTyConKey = mkPreludeTyConUnique 114
strTypeTyConKey = mkPreludeTyConUnique 115
...@@ -1339,7 +1369,13 @@ rationalLIdKey = mkPreludeMiscIdUnique 262 ...@@ -1339,7 +1369,13 @@ rationalLIdKey = mkPreludeMiscIdUnique 262
sigExpIdKey = mkPreludeMiscIdUnique 263 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 ...@@ -1349,4 +1385,4 @@ sigExpIdKey = mkPreludeMiscIdUnique 263
-- It is rather usatisfactory that we don't have a SrcLoc -- It is rather usatisfactory that we don't have a SrcLoc
addDsWarn :: SDoc -> DsM () addDsWarn :: SDoc -> DsM ()
addDsWarn msg = dsWarn (noSrcLoc, msg) addDsWarn msg = dsWarn (noSrcLoc, msg)
\ No newline at end of file
...@@ -60,11 +60,23 @@ cvt_top (Data tc tvs constrs derivs) ...@@ -60,11 +60,23 @@ cvt_top (Data tc tvs constrs derivs)
(DataCons (map mk_con constrs)) (DataCons (map mk_con constrs))
(mk_derivs derivs) loc0) (mk_derivs derivs) loc0)
where where
mk_con (Constr c tys) mk_con (Constr c strtys)
= ConDecl (cName c) noExistentials noContext = 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 [] = Nothing
mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] 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