Commit 1b5c8ce0 authored by igloo's avatar igloo

[project @ 2003-03-16 14:15:21 by igloo]

Support for contexts on data types and records from Derek Elkins.
parent 527a0c8e
......@@ -200,15 +200,16 @@ in repTyClD and repC.
repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
repTyClD (TyData { tcdND = DataType, tcdCtxt = cxt,
tcdName = tc, tcdTyVars = tvs,
tcdCons = DataCons cons, tcdDerivs = mb_derivs })
= do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
dec <- addTyVarBinds tvs $ \bndrs -> do {
cons1 <- mapM repC cons ;
cxt1 <- repContext cxt ;
cons1 <- mapM repC cons ;
cons2 <- coreList consTyConName cons1 ;
derivs1 <- repDerivs mb_derivs ;
repData tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
return $ Just dec }
repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
......@@ -469,8 +470,14 @@ repE (ExplicitPArr ty es) =
repE (ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repEs es; repTup xs }
| otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
repE (RecordCon c flds)
= do { x <- lookupOcc c;
fs <- repFields flds;
repRecCon x fs }
repE (RecordUpd e flds)
= do { x <- repE e;
fs <- repFields flds;
repRecUpd x fs }
repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
repE (ArithSeqIn aseq) =
......@@ -540,6 +547,13 @@ repGuards other
= do { x <- repE e1; y <- repE e2; return (x, y) }
process other = panic "Non Haskell 98 guarded body"
repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FldE])
repFields flds = do
fnames <- mapM lookupOcc (map fst flds)
es <- mapM repE (map snd flds)
fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
coreList fieldTyConName fs
-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
......@@ -717,7 +731,11 @@ repP (ConPatIn dc details)
= do { con_str <- lookupOcc dc
; case details of
PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
RecCon pairs -> error "No records in template haskell yet"
RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
; ps <- sequence $ map repP (map snd pairs)
; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
; fps' <- coreList fieldPTyConName fps
; repPrec con_str fps' }
InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
}
repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
......@@ -880,6 +898,9 @@ repPtup (MkC ps) = rep2 ptupName [ps]
repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
repPrec :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt)
repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
repPtilde :: Core M.Patt -> DsM (Core M.Patt)
repPtilde (MkC p) = rep2 ptildeName [p]
......@@ -933,6 +954,12 @@ repListExp (MkC es) = rep2 listExpName [es]
repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr)
repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr)
repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
......@@ -986,8 +1013,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
repData :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
repTySyn :: Core String -> Core [String] -> Core M.Type -> DsM (Core M.Decl)
repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
......@@ -1160,6 +1187,8 @@ templateHaskellNames
strTypeTyConName, varStrTypeTyConName,
qTyConName, expTyConName, matTyConName, clsTyConName,
decTyConName, typTyConName, strictTypeName, varStrictTypeName,
recConName, recUpdName, precName,
fieldName, fieldTyConName, fieldPName, fieldPTyConName,
strictName, nonstrictName ]
......@@ -1184,6 +1213,7 @@ pconName = varQual FSLIT("pcon") pconIdKey
ptildeName = varQual FSLIT("ptilde") ptildeIdKey
paspatName = varQual FSLIT("paspat") paspatIdKey
pwildName = varQual FSLIT("pwild") pwildIdKey
precName = varQual FSLIT("prec") precIdKey
varName = varQual FSLIT("var") varIdKey
conName = varQual FSLIT("con") conIdKey
litName = varQual FSLIT("lit") litIdKey
......@@ -1201,6 +1231,8 @@ caseEName = varQual FSLIT("caseE") caseEIdKey
infixAppName = varQual FSLIT("infixApp") infixAppIdKey
sectionLName = varQual FSLIT("sectionL") sectionLIdKey
sectionRName = varQual FSLIT("sectionR") sectionRIdKey
recConName = varQual FSLIT("recCon") recConIdKey
recUpdName = varQual FSLIT("recUpd") recUpdIdKey
guardedName = varQual FSLIT("guarded") guardedIdKey
normalName = varQual FSLIT("normal") normalIdKey
bindStName = varQual FSLIT("bindSt") bindStIdKey
......@@ -1262,7 +1294,10 @@ consTyConName = tcQual FSLIT("Cons") consTyConKey
typeTyConName = tcQual FSLIT("Type") typeTyConKey
strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey
varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey
fieldTyConName = tcQual FSLIT("FldE") fieldTyConKey
fieldPTyConName = tcQual FSLIT("FldP") fieldPTyConKey
qTyConName = tcQual FSLIT("Q") qTyConKey
expTyConName = tcQual FSLIT("Exp") expTyConKey
decTyConName = tcQual FSLIT("Dec") decTyConKey
......@@ -1275,6 +1310,9 @@ varStrictTypeName = varQual FSLIT("varStrictType") varStrictTypeKey
strictName = varQual FSLIT("strict") strictKey
nonstrictName = varQual FSLIT("nonstrict") nonstrictKey
fieldName = varQual FSLIT("field") fieldKey
fieldPName = varQual FSLIT("fieldP") fieldPKey
-- TyConUniques available: 100-119
-- Check in PrelNames if you want to change this
......@@ -1294,6 +1332,8 @@ typTyConKey = mkPreludeTyConUnique 112
decTyConKey = mkPreludeTyConUnique 113
varStrTypeTyConKey = mkPreludeTyConUnique 114
strTypeTyConKey = mkPreludeTyConUnique 115
fieldTyConKey = mkPreludeTyConUnique 116
fieldPTyConKey = mkPreludeTyConUnique 117
......@@ -1380,6 +1420,13 @@ varStrictTypeKey = mkPreludeMiscIdUnique 267
recConstrIdKey = mkPreludeMiscIdUnique 268
infixConstrIdKey = mkPreludeMiscIdUnique 269
recConIdKey = mkPreludeMiscIdUnique 270
recUpdIdKey = mkPreludeMiscIdUnique 271
precIdKey = mkPreludeMiscIdUnique 272
fieldKey = mkPreludeMiscIdUnique 273
fieldPKey = mkPreludeMiscIdUnique 274
-- %************************************************************************
-- %* *
-- Other utilities
......
......@@ -54,9 +54,9 @@ cvt_top d@(Fun _ _) = Left $ ValD (cvtd d)
cvt_top (TySyn tc tvs rhs)
= Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)
cvt_top (Data tc tvs constrs derivs)
cvt_top (Data ctxt tc tvs constrs derivs)
= Left $ TyClD (mkTyData DataType
(noContext, tconName tc, cvt_tvs tvs)
(cvt_context ctxt, tconName tc, cvt_tvs tvs)
(DataCons (map mk_con constrs))
(mk_derivs derivs) loc0)
where
......@@ -65,7 +65,7 @@ cvt_top (Data tc tvs constrs derivs)
(PrefixCon (map mk_arg strtys)) loc0
mk_con (RecConstr c varstrtys)
= ConDecl (cName c) noExistentials noContext
(RecCon (map mk_id_arg varstrtys)) loc0
(Hs.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
......@@ -185,6 +185,8 @@ cvt (Infix Nothing s (Just y)) = SectionR (cvt s) (cvt y)
cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (cvt s)
cvt (Infix Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
cvt (SigExp e t) = ExprWithTySig (cvt e) (cvtType t)
cvt (Meta.RecCon c flds) = RecordCon (cName c) (map (\(x,y) -> (vName x, cvt y)) flds)
cvt (RecUpd e flds) = RecordUpd (cvt e) (map (\(x,y) -> (vName x, cvt y)) flds)
cvtdecs :: [Meta.Dec] -> HsBinds RdrName
cvtdecs [] = EmptyBinds
......@@ -272,6 +274,7 @@ cvtp (Pcon s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps))
cvtp (Ptilde p) = LazyPat (cvtp p)
cvtp (Paspat s p) = AsPat (vName s) (cvtp p)
cvtp Pwild = WildPat void
cvtp (Prec c fs) = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs)
-----------------------------------------------------------
-- Types and type variables
......
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