\begin{code}
module TcIface (
tcImportDecl, typecheckIface,
- tcIfaceKind, loadImportedInsts, loadImportedRules,
+ loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
#include "HsVersions.h"
tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
tcIfaceDataCon, tcIfaceLclId,
newIfaceName, newIfaceNames )
-import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
+import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
+ mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
-import Type ( Kind, openTypeKind, liftedTypeKind,
- unliftedTypeKind, mkArrowKind, splitTyConApp,
+import Type ( liftedTypeKind, splitTyConApp,
mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
setArityInfo, setInlinePragInfo, setCafInfo,
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
-import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
+import TyCon ( AlgTyConRhs(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
import TysWiredIn ( tupleCon )
import Var ( TyVar, mkTyVar, tyVarKind )
import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName,
- isWiredInName, wiredInNameTyThing_maybe, nameParent )
+ isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe )
import NameEnv
import OccName ( OccName )
import Module ( Module, ModuleName, moduleName )
import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, dropList, equalLength, zipLazy )
import Maybes ( expectJust )
-import CmdLineOpts ( DynFlag(..) )
+import CmdLineOpts ( DynFlag(..), dopt )
\end{code}
This module takes
selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl)
-- Use nameParent to get the parent name of the thing
selectDecl eps@(EPS { eps_decls = Pool decls_map n_in n_out}) name
- = case lookupNameEnv decls_map main_name of
+ = case lookupNameEnv decls_map name of {
+ -- This first lookup will usually fail for subordinate names, because
+ -- the relevant decl is the parent decl.
+ -- But, if we export a data type decl abstractly, its selectors
+ -- get separate type signatures in the interface file
+ Just decl -> let
+ decls' = delFromNameEnv decls_map name
+ in
+ (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ;
+
+ Nothing ->
+ case nameParent_maybe name of {
+ Nothing -> (eps, Nothing ) ; -- No "parent"
+ Just main_name -> -- Has a parent; try that
+
+ case lookupNameEnv decls_map main_name of {
+ Just decl -> let
+ decls' = delFromNameEnv decls_map main_name
+ in
+ (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ;
Nothing -> (eps, Nothing)
- Just decl -> (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl)
- where
- main_name = nameParent name
- decls' = delFromNameEnv decls_map main_name
+ }}}
\end{code}
%************************************************************************
; info <- tcIdInfo name ty info
; return (AnId (mkVanillaGlobal name ty info)) }
-tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name,
+tcIfaceDecl (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
ifCons = rdr_cons,
ifVrcs = arg_vrcs, ifRec = is_rec,
; tycon <- fixM ( \ tycon -> do
{ cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
- ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons
+ ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons
arg_vrcs is_rec want_generic
; return tycon
})
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0 [])) }
-tcIfaceDataCons tycon tyvars ctxt Unknown
- = returnM Unknown
-
-tcIfaceDataCons tycon tyvars ctxt (DataCons cs)
- = mappM tc_con_decl cs `thenM` \ data_cons ->
- returnM (DataCons data_cons)
+tcIfaceDataCons tycon tyvars ctxt if_cons
+ = case if_cons of
+ IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; return (mkNewTyConRhs data_con) }
where
tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls)
= bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
; eps_var <- getEpsVar
; eps <- readMutVar eps_var
+ -- For interest: report the no-type-constructor case.
+ -- Don't report when -fallow-undecidable-instances is on, because then
+ -- we call loadImportedInsts when looking up even predicates like (C a)
+ -- But without undecidable instances it's rare to see C (a b) and
+ -- somethat interesting
+{- (comment out; happens a lot in some code)
+#ifdef DEBUG
+ ; dflags <- getDOpts
+ ; WARN( not (dopt Opt_AllowUndecidableInstances dflags) && null tc_gates,
+ ptext SLIT("Interesting! No tycons in Inst:")
+ <+> pprClassPred cls tys )
+ return ()
+#endif
+-}
-- Suck in the instances
; let { (inst_pool', iface_insts)
- = WARN( null tc_gates, ptext SLIT("Interesting! No tycons in Inst:")
- <+> pprClassPred cls tys )
- selectInsts (eps_insts eps) cls_gate tc_gates }
+ = selectInsts (eps_insts eps) cls_gate tc_gates }
-- Empty => finish up rapidly, without writing to eps
; if null iface_insts then
%************************************************************************
\begin{code}
-tcIfaceKind :: IfaceKind -> Kind
-tcIfaceKind IfaceOpenTypeKind = openTypeKind
-tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind
-tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind
-tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2)
-
------------------------------------------
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
where
(occs,kinds) = unzip bndrs
-mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
+mk_iface_tyvar name kind = mkTyVar name kind
\end{code}
projects / ghc-hetmet.git / blobdiff