Skip to content

Commit

Permalink
Move free-var info from InstDecl to FamInstDecl
Browse files Browse the repository at this point in the history
  • Loading branch information
Simon Peyton Jones committed Apr 20, 2012
1 parent c163e38 commit c284511
Show file tree
Hide file tree
Showing 7 changed files with 63 additions and 52 deletions.
5 changes: 3 additions & 2 deletions compiler/deSugar/DsMeta.hs
View file
Expand Up @@ -323,11 +323,12 @@ repFamilyFlavour DataFamily = rep2 dataFamName []
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repInstD (L loc (FamInstD fi_decl))
repInstD (L loc (FamInstD { lid_inst = fi_decl }))
= do { dec <- repFamInstD fi_decl
; return (loc, dec) }

repInstD (L loc (ClsInstD ty binds prags ats))
repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = prags, cid_fam_insts = ats }))
= do { dec <- addTyVarBinds tvs $ \_ ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
Expand Down
36 changes: 19 additions & 17 deletions compiler/hsSyn/Convert.lhs
View file
Expand Up @@ -164,8 +164,8 @@ cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TyDecl { tcdLName = tc'
, tcdTyVars = tvs'
, tcdTyDefn = TySynonym rhs' placeHolderNames }) }
, tcdTyVars = tvs', tcdFVs = placeHolderNames
, tcdTyDefn = TySynonym rhs' }) }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
Expand All @@ -174,10 +174,9 @@ cvtDec (DataD ctxt tc tvs constrs derivs)
; let defn = TyData { td_ND = DataType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = cons', td_derivs = derivs'
, td_fvs = placeHolderNames }
, td_cons = cons', td_derivs = derivs' }
; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyDefn = defn }) }
, tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
Expand All @@ -186,10 +185,9 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
; let defn = TyData { td_ND = NewType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = [con'], td_derivs = derivs'
, td_fvs = placeHolderNames }
, td_cons = [con'], td_derivs = derivs' }
; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyDefn = defn }) }
, tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
Expand All @@ -198,7 +196,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
; returnL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
, tcdATs = fams', tcdATDefs = ats', tcdDocs = [] }
, tcdATs = fams', tcdATDefs = ats', tcdDocs = []
, tcdFVs = placeHolderNames }
-- no docs in TH ^^
}
Expand Down Expand Up @@ -232,8 +231,9 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
, td_kindSig = Nothing
, td_cons = cons', td_derivs = derivs' }
; returnL $ InstD $ FamInstD $
FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } }
; returnL $ InstD $ FamInstD
{ lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
, fid_defn = defn, fid_fvs = placeHolderNames } }}
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
Expand All @@ -243,14 +243,16 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = [con'], td_derivs = derivs' }
; returnL $ InstD $ FamInstD $
FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } }
; returnL $ InstD $ FamInstD
{ lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
, fid_defn = defn, fid_fvs = placeHolderNames } } }
cvtDec (TySynInstD tc tys rhs)
= do { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
; returnL $ InstD $ FamInstD $
FamInstDecl { fid_tycon = tc', fid_pats = tys', fid_defn = TySynonym rhs' } }
; returnL $ InstD $ FamInstD
{ lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = tys'
, fid_defn = TySynonym rhs', fid_fvs = placeHolderNames } } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
Expand Down Expand Up @@ -300,8 +302,8 @@ is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d)
is_fam_decl decl = Right decl
is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName)
is_fam_inst (L loc (Hs.InstD (FamInstD d))) = Left (L loc d)
is_fam_inst decl = Right decl
is_fam_inst (L loc (Hs.InstD (FamInstD { lid_inst = d }))) = Left (L loc d)
is_fam_inst decl = Right decl
is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
Expand Down
8 changes: 4 additions & 4 deletions compiler/hsSyn/HsDecls.lhs
View file
Expand Up @@ -809,7 +809,8 @@ data FamInstDecl name
= FamInstDecl
{ fid_tycon :: Located name
, fid_pats :: HsBndrSig [LHsType name] -- ^ Type patterns (with bndrs)
, fid_defn :: HsTyDefn name } -- Type or data family instance
, fid_defn :: HsTyDefn name -- Type or data family instance
, fid_fvs :: NameSet }
deriving( Typeable, Data )
type LInstDecl name = Located (InstDecl name)
Expand All @@ -821,11 +822,10 @@ data InstDecl name -- Both class and family instances
, cid_binds :: LHsBinds name
, cid_sigs :: [LSig name] -- User-supplied pragmatic info
, cid_fam_insts :: [LFamInstDecl name] -- Family instances for associated types
, lid_fvs :: NameSet }
}
| FamInstD -- type/data family instance
{ lid_inst :: FamInstDecl name
, lid_fvs :: NameSet }
{ lid_inst :: FamInstDecl name }
deriving (Data, Typeable)
\end{code}

Expand Down
13 changes: 6 additions & 7 deletions compiler/parser/Parser.y.pp
View file
Expand Up @@ -652,29 +652,28 @@
: 'instance' inst_type where_inst
{ let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstD { cid_poly_ty = $2, cid_binds = binds
, cid_sigs = sigs, cid_fam_insts = ats
, lid_fvs = placeHolderNames }) }
, cid_sigs = sigs, cid_fam_insts = ats }) }

-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5
; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
; return (L loc (FamInstD { lid_inst = d })) } }

-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
Nothing (reverse (unLoc $4)) (unLoc $5)
; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
; return (L loc (FamInstD { lid_inst = d })) } }

-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
; return (L loc (FamInstD { lid_inst = d })) } }

-- Associated type family declarations
--
Expand Down Expand Up @@ -702,7 +701,7 @@
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
; return (L loc (InstD (FamInstD { lid_inst = fid, lid_fvs = placeHolderNames }))) } }
; return (L loc (InstD (FamInstD { lid_inst = fid }))) } }

-- Associated type instances
--
Expand Down Expand Up @@ -793,7 +792,7 @@
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl RdrName)) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD { lid_inst = unLoc $1, lid_fvs = placeHolderNames })))) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD { lid_inst = unLoc $1 })))) }
| decl { $1 }

decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
Expand Down
5 changes: 3 additions & 2 deletions compiler/parser/RdrHsSyn.lhs
View file
Expand Up @@ -146,7 +146,7 @@ mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
, fid_defn = defn })) }
, fid_defn = defn, fid_fvs = placeHolderNames })) }
mkDataDefn :: NewOrData
-> Maybe CType
Expand Down Expand Up @@ -182,7 +182,8 @@ mkFamInstSynonym :: SrcSpan
mkFamInstSynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
, fid_defn = TySynonym { td_synRhs = rhs }})) }
, fid_defn = TySynonym { td_synRhs = rhs }
, fid_fvs = placeHolderNames })) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
Expand Down
44 changes: 25 additions & 19 deletions compiler/rename/RnSource.lhs
View file
Expand Up @@ -424,16 +424,16 @@ patchCCallTarget packageId callTarget
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (FamInstD { lid_inst = fi })
= do { (fi', fvs) <- rnFamInstDecl Nothing fi
; return (FamInstD { lid_inst = fi', lid_fvs = fvs }, fvs) }
; return (FamInstD { lid_inst = fi' }, fvs) }
rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_fam_insts = ats })
-- Used for both source and interface file decls
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; case splitLHsInstDeclTy_maybe inst_ty' of {
Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
, cid_sigs = [], cid_fam_insts = []
, lid_fvs = inst_fvs }, inst_fvs) ;
, cid_sigs = [], cid_fam_insts = [] }
, inst_fvs) ;
Just (inst_tyvars, _, L _ cls,_) ->
do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
Expand Down Expand Up @@ -471,8 +471,7 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
`plusFV` spec_inst_fvs
`plusFV` inst_fvs
; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_fam_insts = ats'
, lid_fvs = all_fvs },
, cid_sigs = uprags', cid_fam_insts = ats' },
all_fvs) } } }
-- We return the renamed associated data type declarations so
-- that they can be entered into the list of type declarations
Expand All @@ -493,26 +492,33 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
(kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
; kv_names <- mkTyVarBndrNames mb_cls (map (L loc) kv_rdr_names)
; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) tv_rdr_names)
-- All the free vars of the family patterns
-- with a sensible binding location
; bindLocalNamesFV kv_names $
bindLocalNamesFV tv_names $
do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
; (defn', rhs_fvs) <- rnTyDefn tycon defn
-- 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)
; ((pats', defn'), fvs)
<- bindLocalNamesFV kv_names $
bindLocalNamesFV tv_names $
do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
; (defn', rhs_fvs) <- rnTyDefn tycon defn
-- 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', defn'), rhs_fvs `plusFV` pat_fvs) }
; let all_fvs = fvs `addOneFV` unLoc tycon'
; return ( FamInstDecl { fid_tycon = tycon'
, fid_pats = HsBSig pats' (kv_names, tv_names)
, fid_defn = defn' }
, (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon') } }
, fid_defn = defn', fid_fvs = all_fvs }
, all_fvs ) }
-- type instance => use, hence addOneFV
\end{code}

Expand Down
4 changes: 3 additions & 1 deletion compiler/typecheck/TcInstDcls.lhs
View file
Expand Up @@ -482,7 +482,9 @@ calcInstDeclCycles decls
-- get_uses extracts the *tycon or constructor* uses of the declaration
get_uses :: LInstDecl Name -> [Name]
get_uses decl = nameSetToList (lid_fvs (unLoc decl))
get_uses (L _ (FamInstD { lid_inst = fid })) = nameSetToList (fid_fvs fid)
get_uses (L _ (ClsInstD { cid_fam_insts = fids }))
= nameSetToList (foldr (unionNameSets . fid_fvs . unLoc) emptyNameSet fids)
cyclicDeclErr :: Outputable d => [Located d] -> TcRn ()
cyclicDeclErr inst_decls
Expand Down

0 comments on commit c284511

Please sign in to comment.