From 1b5c8ce0a3565ec02a38325f82473f1e772d7afe Mon Sep 17 00:00:00 2001 From: igloo Date: Sun, 16 Mar 2003 14:15:22 +0000 Subject: [PATCH] [project @ 2003-03-16 14:15:21 by igloo] Support for contexts on data types and records from Derek Elkins. --- ghc/compiler/deSugar/DsMeta.hs | 65 ++++++++++++++++++++++++++++++++++------ ghc/compiler/hsSyn/Convert.lhs | 9 ++++-- 2 files changed, 62 insertions(+), 12 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index e655635..4c0d351 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index e6e3a2a..e31ed47 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -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 -- 1.7.10.4