Skip to content

Commit

Permalink
Revert "Checkpoint, working on RnSource"
Browse files Browse the repository at this point in the history
This reverts commit 3358270.
  • Loading branch information
Richard Eisenberg committed Jun 11, 2013
1 parent 508d235 commit 780d4b9
Showing 1 changed file with 41 additions and 25 deletions.
66 changes: 41 additions & 25 deletions compiler/rename/RnSource.lhs
Expand Up @@ -499,11 +499,11 @@ rnFamInstLHS :: HsDocContext
-> Maybe (Name, [Name])
-> Located RdrName
-> [LHsType RdrName]
-> RnM (Located Name, HsWithBndrs [LHsType Name], FreeVars)
-> RnM (???)
rnFamInstLHS doc mb_cls tycon pats
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstLHS" (ppr tycon)
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
(kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
Expand All @@ -518,10 +518,6 @@ rnFamInstLHS doc mb_cls tycon pats
bindLocalNamesFV tv_names $
rnLHsTypes doc pats
; return ( tycon'
, HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
, fvs `addOneFV` unLoc tycon' )
rnFamInstDecl :: HsDocContext
-> Maybe (Name, [Name])
-> Located RdrName
Expand All @@ -530,20 +526,41 @@ rnFamInstDecl :: HsDocContext
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (Located Name, HsWithBndrs [LHsType Name], rhs', FreeVars)
rnFamInstDecl doc mb_cls tycon pats payload rnPayload
= do { (tycon', pats', pats_fvs) <- rnFamInstLHS doc mb_cls tycon pats
; let HsWB { hswb_kvs = kv_names, hswb_tvs = tv_names } = pats'
; (payload', rhs_fvs)
<- bindLocalNamesFV kv_names $
bindLocalNamesFV tv_names $
do { (payload', rhs_fvs) <- rnPayload doc payload
; let bad_tvs = case mb_cls of
Nothing -> []
Just (_,cls_tvs) -> filter is_bad cls_tvs
is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs
; unless (null bad_tvs) (badAssocRhs bad_tvs)
; return (payload', rhs_fvs) }
; return (tycon', pats', payload', pats_fvs `plusFV` rhs_fvs) }
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
(kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
; rdr_env <- getLocalRdrEnv
; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
-- All the free vars of the family patterns
-- with a sensible binding location
; ((pats', payload'), fvs)
<- bindLocalNamesFV kv_names $
bindLocalNamesFV tv_names $
do { (pats', pat_fvs) <- rnLHsTypes doc pats
; (payload', rhs_fvs) <- rnPayload doc payload
-- See Note [Renaming associated types]
; let bad_tvs = case mb_cls of
Nothing -> []
Just (_,cls_tvs) -> filter is_bad cls_tvs
is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs
; unless (null bad_tvs) (badAssocRhs bad_tvs)
; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
; let all_fvs = fvs `addOneFV` unLoc tycon'
; return (tycon',
HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names },
payload',
all_fvs) }
-- type instance => use, hence addOneFV
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl RdrName
Expand All @@ -559,12 +576,11 @@ rnTyFamInstDecl Nothing (TyFamInstBranched { tfid_eqns = eqns, tfid_space = mspa
; return (TyFamInstBranched { tfid_eqns = eqns'
, tfid_space = space'
, tfid_fvs = fvs }, fvs) }
where rn_space Nothing = (Nothing, emptyFVs)
where rn_space Nothing = (Nothing, emptyFVs)
rn_space (Just (TyFamInstSpace { tfis_tycon = tycon
, tfis_pats = pats }))
= do { (tycon', pats', fvs) <- rnFamInstLHS ??? Nothing tycon pats
; return (TyFamInstSpace { tfis_tycon = tycon'
, tfis_pats = pats' }, fvs) }
= do { tycon' <- lookupFamInstName Nothing tycon
; let loc
rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn RdrName
Expand Down

0 comments on commit 780d4b9

Please sign in to comment.