import BasicTypes ( Version, initialVersion,
Fixity(..), FixityDirection(..), isMarkedStrict )
import TcRnMonad
+import Type ( TyThing(..) )
+import Class ( classATs )
import PrelNames ( gHC_PRIM )
import PrelInfo ( ghcPrimExports )
-- 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
= 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
; 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
(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
mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName, SynTyConRhs(..),
- AlgTyConParent(..) )
+ AlgTyConParent(..), setTyConArgPoss )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
import Util ( zipWithEqual, equalLength, splitAtList )
import DynFlags ( DynFlag(..), isOneShot )
+import List ( elemIndex)
+import Maybe ( catMaybes )
import Monad ( liftM )
\end{code}
; 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
; 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)
; 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
= 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
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')
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
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)
tcdTyPats = Nothing, tcdKindSig = sig,
tcdCons = [], tcdDerivs = Nothing},
delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context') } }
+ extractHsCtxtTyNames context')
+ } }
where
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"
; 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
-- 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})
projects / ghc-hetmet.git / commitdiff