import CmdLineOpts ( DynFlag(..), dopt )
-import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
- MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
+import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
+ MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
-import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
-import HsPat ( InPat (..) )
-import HsMatches ( Match (..) )
-import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
- extractHsTyVars )
+import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
+ RenamedTyClDecl, RenamedHsType,
+ extractHsTyVars, maybeGenericMatch
+ )
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
- tcExtendTyVarEnvForMeths, TyThing (..),
+ tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
extendInstEnv )
-import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
+import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
- ModDetails(..) )
-
-import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
- foldBag, Bag, listToBag
+ ModDetails(..), PackageInstEnv, PersistentRenamerState
)
+
+import Bag ( unionManyBags )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
-import Maybes ( maybeToBool, expectJust )
+import Maybes ( maybeToBool )
import MkId ( mkDictFunId )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint, pprPred )
import TyCon ( TyCon, isSynTyCon, tyConDerivings )
-import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy_maybe,
- splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
+import Type ( mkTyVarTys, splitDFunTy, isTyVarTy,
+ splitTyConApp_maybe, splitDictTy,
+ splitAlgTyConApp_maybe,
unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
getClassTys_maybe
)
import VarSet ( mkVarSet, varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
-import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv,
- plusNameEnv_C, nameEnvElts )
-import FiniteMap ( mapFM )
+import Name ( Name )
import SrcLoc ( SrcLoc )
-import RnHsSyn -- ( RenamedMonoBinds )
import VarSet ( varSetElems )
-import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( NewOrData(..), Fixity )
import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C,
equivClassesByUniq, minusList
)
-import List ( intersect, (\\), partition )
+import List ( partition )
import Outputable
\end{code}
Gather up the instance declarations from their various sources
\begin{code}
-tcInstDecls1 :: PersistentCompilerState
+tcInstDecls1 :: PackageInstEnv
+ -> PersistentRenamerState
-> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
-> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
-> [TyCon]
-> [RenamedHsDecl]
- -> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds)
+ -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
imported_inst_info
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
- addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ inst_env1 ->
+ addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
addInstInfos inst_env3 generic_inst_info `thenNF_Tc` \ inst_env4 ->
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
- tcDeriving (pcs_PRS pcs) mod inst_env4 get_fixity local_tycons
- `thenTc` \ (deriv_inst_info, deriv_binds) ->
- addInstInfos inst_env4 deriv_inst_info
- `thenNF_Tc` \ final_inst_env ->
+ tcDeriving prs mod inst_env4 get_fixity local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
- returnTc (pcs { pcs_insts = inst_env1 },
+ returnTc (inst_env1,
final_inst_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
deriv_binds)
-- Type-check all the stuff before the "where"
tcHsSigType poly_ty `thenTc` \ poly_ty' ->
let
- (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
- (clas, inst_tys) = case splitDictTy_maybe dict_ty of
- Just ct -> ct
- Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
+ (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
in
(case maybe_dfun_name of
returnTc gen_inst_info
get_generics mod decl@(ClassDecl context class_name tyvar_names
- fundeps class_sigs def_methods pragmas
+ fundeps class_sigs def_methods
name_list loc)
| null groups
= returnTc [] -- The comon case:
-- Instantiate the instance decl with tc-style type variables
tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
- (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
+ (clas, inst_tys') = splitDictTy dict_ty'
origin = InstanceDeclOrigin
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
where
(name, loc, thing)
= case decl of
- (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class")
- (TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ _ loc _ _) -> (name, loc, "newtype")
- (TyData DataType _ name _ _ _ _ _ loc _ _) -> (name, loc, "data type")
+ (ClassDecl _ name _ _ _ _ _ loc) -> (name, loc, "class")
+ (TySynonym name _ _ loc) -> (name, loc, "type synonym")
+ (TyData NewType _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
+ (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr name)]
projects / ghc-hetmet.git / blobdiff