extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc,
newIfaceName, newIfaceNames, ifaceExportNames )
-import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
- mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
+import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon,
+ buildClass,
+ mkAbstractTyConRhs, mkOpenDataTyConRhs,
+ mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
liftedTypeKindTyCon, unliftedTypeKindTyCon,
openTypeKindTyCon, argTypeKindTyCon,
- ubxTupleKindTyCon,
- mkTyVarTys, ThetaType )
+ ubxTupleKindTyCon, ThetaType )
import TypeRep ( Type(..), PredType(..) )
-import TyCon ( TyCon, tyConName )
+import TyCon ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
- emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
+ emptyModDetails, lookupTypeEnv, lookupType,
+ typeEnvIds, mkDetailsFamInstCache )
import InstEnv ( Instance(..), mkImportedInstance )
import CoreSyn
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, dataConRepFSInstPat )
import CoreUnfold
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
-import DataCon ( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys )
+import DataCon ( DataCon, dataConWorkId )
import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
-import Var ( TyVar, mkTyVar, tyVarKind )
+import Var ( TyVar, mkTyVar )
import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
nameOccName, wiredInNameTyThing_maybe )
import NameEnv
-import OccName ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace )
+import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace,
+ pprNameSpace, occNameFS )
import FastString ( FastString )
import Module ( Module, moduleName )
import UniqFM ( lookupUFM )
-import UniqSupply ( initUs_ )
+import UniqSupply ( initUs_, uniqsFromSupply )
import Outputable
import ErrUtils ( Message )
import Maybes ( MaybeErr(..) )
import SrcLoc ( noSrcLoc )
-import Util ( zipWithEqual, equalLength, splitAtList )
+import Util ( zipWithEqual, equalLength )
import DynFlags ( DynFlag(..), isOneShot )
+import List ( elemIndex)
+import Maybe ( catMaybes )
\end{code}
This module takes
; exports <- ifaceExportNames (mi_exports iface)
-- Finished
- ; return (ModDetails { md_types = type_env,
- md_insts = dfuns,
- md_rules = rules,
- md_exports = exports })
+ ; return $ ModDetails { md_types = type_env
+ , md_insts = dfuns
+ , md_fam_insts = mkDetailsFamInstCache type_env
+ , md_rules = rules
+ , md_exports = exports
+ }
}
\end{code}
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
- ifGeneric = want_generic })
+ ifGeneric = want_generic,
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+ ; famInst <-
+ case mb_family of
+ Nothing -> return Nothing
+ Just (IfaceFamInst { ifFamInstTyCon = fam
+ , ifFamInstTys = tys
+ }) ->
+ do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys)
+ }
+ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
- cons is_rec want_generic gadt_syn
+ cons is_rec want_generic gadt_syn famInst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
}}
tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifSynRhs = rdr_rhs_ty})
+ ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_ty <- tcIfaceType rdr_rhs_ty
- ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
+ ; rhs_tyki <- tcIfaceType rdr_rhs_ty
+ ; let rhs = if isOpen then OpenSynTyCon rhs_tyki
+ else SynonymTyCon rhs_tyki
+ ; 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
tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfOpenDataTyCon -> return mkOpenDataTyConRhs
+ IfOpenNewTyCon -> return mkOpenNewTyConRhs
IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
tcIfaceEqSpec spec
= mapM do_item spec
where
- do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
+ do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
; ty <- tcIfaceType if_ty
; return (tv,ty) }
\end{code}
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
tcIfaceDataAlt con inst_tys arg_strs rhs
- = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs)
- ; let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs
- ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs
- ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs
- ; let ex_tvs = [ mkTyVar name (tyVarKind tv)
- | (name,tv) <- tyvar_names `zip` dataConExTyVars con ]
- arg_tys = dataConInstArgTys con (inst_tys ++ mkTyVarTys ex_tvs)
- arg_ids = ASSERT2( equalLength id_names arg_tys,
- ppr (con, tyvar_names++id_names, rhs) $$ ppr ex_tvs $$ ppr arg_tys )
- zipWith mkLocalId id_names arg_tys
-
- ; rhs' <- extendIfaceTyVarEnv ex_tvs $
+ = do { us <- newUniqueSupply
+ ; let uniqs = uniqsFromSupply us
+ ; let (ex_tvs, co_tvs, arg_ids)
+ = dataConRepFSInstPat arg_strs uniqs con inst_tys
+ all_tvs = ex_tvs ++ co_tvs
+
+ ; rhs' <- extendIfaceTyVarEnv all_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
- ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
+ ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
\end{code}
mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind
; return (mkTyVar name kind)
}
-
-mk_iface_tyvar name kind = mkTyVar name kind
\end{code}
projects / ghc-hetmet.git / blobdiff