Commit a1899edb authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Fixed two bugs concerning fanilies

Mon Sep 18 19:34:38 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fixed two bugs concerning fanilies
  Mon Sep  4 20:59:49 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fixed two bugs concerning fanilies
parent 27897431
......@@ -35,6 +35,8 @@ import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..),
import BasicTypes ( Version, initialVersion,
Fixity(..), FixityDirection(..), isMarkedStrict )
import TcRnMonad
import Type ( TyThing(..) )
import Class ( classATs )
import PrelNames ( gHC_PRIM )
import PrelInfo ( ghcPrimExports )
......@@ -269,6 +271,10 @@ badDepMsg mod
-- each binder with the right package info in it
-- All subsequent lookups, including crucially lookups during typechecking
-- the declaration itself, will find the fully-glorious Name
--
-- We handle ATs specially. They are not main declarations, but also not
-- implict things (in particular, adding them to `implicitTyThings' would mess
-- things up in the renaming/type checking of source programs).
-----------------------------------------------------
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
......@@ -292,7 +298,9 @@ loadDecl ignore_prags mod (_version, decl)
= do { -- Populate the name cache with final versions of all
-- the names associated with the decl
main_name <- mk_new_bndr mod Nothing (ifName decl)
; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl)
; implicit_names <- mapM (mk_new_bndr mod (Just main_name))
(ifaceDeclSubBndrs decl)
; at_names <- mapM (mk_new_bndr mod Nothing) (atNames decl)
-- Typecheck the thing, lazily
-- NB. firstly, the laziness is there in case we never need the
......@@ -304,9 +312,13 @@ loadDecl ignore_prags mod (_version, decl)
; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
lookup n = case lookupOccEnv mini_env (getOccName n) of
Just thing -> thing
Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (stripped_decl) )
Nothing ->
pprPanic "loadDecl" (ppr main_name <+>
ppr n $$ ppr (stripped_decl))
; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names]
++ zip at_names (atThings thing)
}
-- We build a list from the *known* names, with (lookup n) thunks
-- as the TyThings. That way we can extend the PTE without poking the
-- thunks
......@@ -324,6 +336,12 @@ loadDecl ignore_prags mod (_version, decl)
(importedSrcLoc (showSDoc (ppr (moduleName mod))))
-- ToDo: qualify with the package name if necessary
atNames (IfaceClass {ifATs = ats}) = [ifName at | at <- ats]
atNames _ = []
atThings (AClass cla) = [ATyCon at | at <- classATs cla]
atThings _ = []
doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
discardDeclPrags :: IfaceDecl -> IfaceDecl
......
......@@ -31,7 +31,7 @@ import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName, SynTyConRhs(..),
AlgTyConParent(..) )
AlgTyConParent(..), setTyConArgPoss )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
......@@ -69,6 +69,8 @@ import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, equalLength, splitAtList )
import DynFlags ( DynFlag(..), isOneShot )
import List ( elemIndex)
import Maybe ( catMaybes )
import Monad ( liftM )
\end{code}
......@@ -393,8 +395,9 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
}
tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
ifFDs = rdr_fds, ifSigs = rdr_sigs,
tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
......@@ -403,7 +406,9 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mappM tc_sig rdr_sigs
; fds <- mappM tc_fd rdr_fds
; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
; ats' <- mappM tcIfaceDecl rdr_ats
; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
......@@ -420,6 +425,19 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
; tvs2' <- mappM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
-- For each AT argument compute the position of the corresponding class
-- parameter in the class head. This will later serve as a permutation
-- vector when checking the validity of instance declarations.
setTyThingPoss (ATyCon tycon) atTyVars =
let classTyVars = map fst tv_bndrs
poss = catMaybes
. map ((`elemIndex` classTyVars) . fst)
$ atTyVars
-- There will be no Nothing, as we already passed renaming
in
ATyCon (setTyConArgPoss tycon poss)
setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
......
......@@ -506,7 +506,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
do { tycon' <- if isIdxTyDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
; typats' <- rnTyPats data_doc typatsMaybe
; (derivs', deriv_fvs) <- rn_derivs derivs
......@@ -519,11 +521,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs) }
deriv_fvs `plusFV`
(if isIdxTyDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
| otherwise -- GADT
= ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
do { tycon' <- lookupLocatedTopBndrRn tycon
do { tycon' <- if isIdxTyDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
......@@ -537,8 +545,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = Nothing, tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
(if isIdxTyDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
where
is_vanilla = case condecls of -- Yuk
[] -> True
......@@ -561,15 +573,22 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
rnTyClDecl (tydecl@TyFunction {}) =
rnTySig tydecl bindTyVarsRn
rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
= bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
do { name' <- lookupLocatedTopBndrRn name
do { name' <- if isIdxTyDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
; typats' <- rnTyPats syn_doc typatsMaybe
; (ty', fvs) <- rnHsTypeFVs syn_doc ty
; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
tcdTyPats = typats', tcdSynRhs = ty'},
delFVs (map hsLTyVarName tyvars') fvs) }
delFVs (map hsLTyVarName tyvars') $
fvs `plusFV`
(if isIdxTyDecl tydecl
then unitFV (unLoc name') -- type instance => use
else emptyFVs))
}
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
......@@ -756,7 +775,8 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
tcdTyPats = Nothing, tcdKindSig = sig,
tcdCons = [], tcdDerivs = Nothing},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context') } }
extractHsCtxtTyNames context')
} }
where
rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
......@@ -767,7 +787,8 @@ rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
; tycon' <- lookupLocatedTopBndrRn tycon
; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
tcdIso = tcdIso tydecl, tcdKind = sig},
emptyFVs) } }
emptyFVs)
} }
ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
needOneIdx = text "Kind signature requires at least one type index"
......
......@@ -737,6 +737,9 @@ tcTyClDecl1 calc_isrec
; tvs2' <- mappM tcLookupTyVar tvs2 ;
; return (tvs1', tvs2') }
-- For each AT argument compute the position of the corresponding class
-- parameter in the class head. This will later serve as a permutation
-- vector when checking the validity of instance declarations.
setTyThingPoss [ATyCon tycon] atTyVars =
let classTyVars = hsLTyVarNames tvs
poss = catMaybes
......@@ -746,8 +749,7 @@ tcTyClDecl1 calc_isrec
-- There will be no Nothing, as we already passed renaming
in
ATyCon (setTyConArgPoss tycon poss)
setTyThingPoss _ _ = panic "setTyThingPoss"
setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss"
tcTyClDecl1 calc_isrec
(ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
......
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