Commit 4bc7e718 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Unbreak the stage-2 compiler (record-type changes)

parent 5e8d76a6
......@@ -613,8 +613,8 @@ repGuards other
g <- repPatGE (nonEmptyCoreList ss') rhs'
return (gs, g)
repFields :: [HsRecField Name (LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
repFields flds
repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
= do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
; es <- mapM repLE (map hsRecFieldArg flds)
; fs <- zipWithM repFieldExp fnames es
......@@ -814,9 +814,10 @@ repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
RecCon rec -> do { let flds = rec_flds rec
; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
; ps <- sequence $ map repLP (map hsRecFieldArg flds)
; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
; fps' <- coreList fieldPatQTyConName fps
; repPrec con_str fps' }
......@@ -1185,15 +1186,15 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
repCtxt (MkC tys) = rep2 cxtName [tys]
repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
repConstr :: Core TH.Name -> HsConDeclDetails Name
-> DsM (Core TH.ConQ)
repConstr con (PrefixCon ps)
= do arg_tys <- mapM repBangTy ps
arg_tys1 <- coreList strictTypeQTyConName arg_tys
rep2 normalCName [unC con, unC arg_tys1]
repConstr con (RecCon ips)
= do arg_vs <- mapM lookupLOcc (map hsRecFieldId ips)
arg_tys <- mapM repBangTy (map hsRecFieldArg ips)
= do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
arg_tys <- mapM repBangTy (map cd_fld_type ips)
arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
arg_vs arg_tys
arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
......
......@@ -185,9 +185,10 @@ cvtConstr (ForallC tvs ctxt con)
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
cvt_arg (NotStrict, ty) = cvtType ty
cvt_id_arg (i, str, ty) = do { i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return (mkRecField i' ty') }
cvt_id_arg (i, str, ty)
= do { i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
......@@ -364,12 +365,14 @@ cvtl e = wrapL (cvt e)
; return $ ExprWithTySig e' t' }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM cvtFld flds
; return $ RecordCon c' noPostTcExpr flds' }
; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds' <- mapM cvtFld flds
; return $ RecordUpd e' flds' [] [] [] }
; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (mkHsRecField v' e') }
cvtFld (v,e)
= do { v' <- vNameL v; e' <- cvtl e
; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
......@@ -452,11 +455,13 @@ cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
cvtp TH.WildP = return $ WildPat void
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon fs' }
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField s' p') }
cvtPatFld (s,p)
= do { s' <- vNameL s; p' <- cvtPat p
; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
-----------------------------------------------------------
-- 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