From f1080bc82f87317ffa59cffef08b322d7354bb29 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 13 Oct 2000 15:08:10 +0000 Subject: [PATCH] [project @ 2000-10-13 15:08:10 by simonpj] Mainly typechecking instance decls --- ghc/compiler/main/HscTypes.lhs | 14 +- ghc/compiler/typecheck/TcBinds.lhs | 16 +- ghc/compiler/typecheck/TcDeriv.lhs | 165 ++++++--------- ghc/compiler/typecheck/TcInstDcls.lhs | 141 ++++++++----- ghc/compiler/typecheck/TcInstUtil.lhs | 144 ++++++------- ghc/compiler/typecheck/TcModule.lhs | 356 ++++++++++++++++----------------- ghc/compiler/typecheck/TcMonad.lhs | 20 +- ghc/compiler/types/Type.lhs | 12 +- 8 files changed, 428 insertions(+), 440 deletions(-) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index cb91e51..c3cdf64 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -63,8 +63,8 @@ data ModDetails deprecEnv :: NameEnv DeprecTxt, typeEnv :: TypeEnv, - instEnv :: InstEnv, - ruleEnv :: RuleEnv -- Domain may include Id from other modules + mdInsts :: [DFunId], -- Dfun-ids for the instances in this module + mdRules :: RuleEnv -- Domain may include Id from other modules } emptyModDetails :: Module -> ModDetails @@ -75,10 +75,9 @@ emptyModDetails mod fixityEnv = emptyNameEnv, deprecEnv = emptyNameEnv, typeEnv = emptyNameEnv, - instEnv = emptyInstEnv, - ruleEnv = emptyRuleEnv + mdInsts = [], + mdRules = emptyRuleEnv } -emptyRuleEnv = panic "emptyRuleEnv" \end{code} Symbol tables map modules to ModDetails: @@ -178,9 +177,12 @@ type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name c -- not on construction type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class +type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class +type DFunId = Id type RuleEnv = IdEnv [CoreRule] + +emptyRuleEnv = emptyVarEnv \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index f308e33..971be99 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,7 +4,7 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, +module TcBinds ( tcBindsAndThen, tcTopBinds,y tcSpecSigs, tcBindWithSigs ) where #include "HsVersions.h" @@ -95,14 +95,22 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBindsAndThen, tcBindsAndThen +tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE) +tcTopBinds binds + = tc_binds_and_then TopLevel glue binds $ + tcGetEnv `thenNF_Tc` \ env -> + returnTc ((EmptyMonoBinds, env), emptyLIE) + where + glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing) + + +tcBindsAndThen :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator -> RenamedHsBinds -> TcM (thing, LIE) -> TcM (thing, LIE) -tcTopBindsAndThen = tc_binds_and_then TopLevel -tcBindsAndThen = tc_binds_and_then NotTopLevel +tcBindsAndThen = tc_binds_and_then NotTopLevel tc_binds_and_then top_lvl combiner EmptyBinds do_next = do_next diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 75f8d34..80d6b10 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -18,7 +18,7 @@ import CmdLineOpts ( opt_D_dump_deriv ) import TcMonad import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv, newDFunName ) import TcGenDeriv -- Deriv stuff -import TcInstUtil ( InstInfo(..), pprInstInfo, instInfoClass, simpleInstInfoTyCon, buildInstanceEnv ) +import TcInstUtil ( InstInfo(..), pprInstInfo, simpleDFunClassTyCon, extendInstEnv ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) @@ -141,10 +141,9 @@ this by simplifying the RHS to a form in which So, here are the synonyms for the ``equation'' structures: \begin{code} -type DerivEqn = (Class, TyCon, [TyVar], DerivRhs) - -- The tyvars bind all the variables in the RHS - -- NEW: it's convenient to re-use InstInfo - -- We'll "panic" out some fields... +type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs) + -- The Name is the name for the DFun we'll build + -- The tyvars bind all the variables in the RHS type DerivRhs = [(Class, [TauType])] -- Same as a ThetaType! @@ -185,24 +184,24 @@ context to the instance decl. The "offending classes" are \begin{code} tcDeriving :: PersistentRenamerState -> Module -- name of module under scrutiny - -> Bag InstInfo -- What we already know about instances - -> TcM (Bag InstInfo, -- The generated "instance decls". - RenamedHsBinds) -- Extra generated bindings + -> InstEnv -- What we already know about instances + -> TcM ([InstInfo], -- The generated "instance decls". + RenamedHsBinds) -- Extra generated bindings -tcDeriving prs mod inst_decl_infos_in - = recoverTc (returnTc (emptyBag, EmptyBinds)) $ +tcDeriving prs mod inst_env_in local_tycons + = recoverTc (returnTc ([], EmptyBinds)) $ -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns `thenTc` \ eqns -> + makeDerivEqns local_tycons `thenTc` \ eqns -> if null eqns then - returnTc (emptyBag, EmptyBinds) + returnTc ([], EmptyBinds) else -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. - solveDerivEqns inst_decl_infos_in eqns `thenTc` \ new_inst_infos -> + solveDerivEqns inst_env_in eqns `thenTc` \ new_dfuns -> -- Now augment the InstInfos, adding in the rather boring -- actual-code-to-do-the-methods binds. We may also need to @@ -210,14 +209,13 @@ tcDeriving prs mod inst_decl_infos_in -- "con2tag" and/or "tag2con" functions. We do these -- separately. - gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc -> - + gen_taggery_Names new_dfuns `thenTc` \ nm_alist_etc -> tcGetEnv `thenNF_Tc` \ env -> let extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list - method_binds_s = map (gen_bind (tcGST env)) new_inst_infos + method_binds_s = map (gen_bind (tcGST env)) new_dfuns mbinders = collectLocatedMonoBinders extra_mbinds -- Rename to get RenamedBinds. @@ -231,26 +229,28 @@ tcDeriving prs mod inst_decl_infos_in returnRn (rn_method_binds_s, rn_extra_binds) ) in - mapNF_Tc gen_inst_info (new_inst_infos `zip` rn_method_binds_s) `thenNF_Tc` \ really_new_inst_infos -> + mapNF_Tc gen_inst_info (new_dfuns `zip` rn_method_binds_s) `thenNF_Tc` \ new_inst_infos -> ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances" - (ddump_deriving really_new_inst_infos rn_extra_binds)) `thenTc_` + (ddump_deriving new_inst_infos rn_extra_binds)) `thenTc_` - returnTc (listToBag really_new_inst_infos, rn_extra_binds) + returnTc (new_inst_infos, rn_extra_binds) where ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc ddump_deriving inst_infos extra_binds = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds where - -- Paste the dfun id and method binds into the InstInfo - gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, meth_binds) - = newDFunName mod clas tys locn `thenNF_Tc` \ dfun_name -> - let - dfun_id = mkDictFunId dfun_name clas tyvars tys inst_decl_theta - in - returnNF_Tc (InstInfo clas tyvars tys inst_decl_theta - dfun_id meth_binds locn []) + -- Make a Real dfun instead of the dummy one we have so far + gen_inst_info (dfun, binds) + = InstInfo { iLocal = True, + iClass = clas, iTyVars = tyvars, + iTys = tys, iTheta = theta, + iDFunId = dfun, iBinds = binds, + iLoc = getSrcLoc dfun, iPrags = [] } + where + (tyvars, theta, tau) = splitSigmaTy dfun + (clas, tys) = splitDictTy tau rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' -- Ignore the free vars returned @@ -279,15 +279,11 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: TcM [DerivEqn] +makeDerivEqns :: Module -> [TyCon] -> TcM [DerivEqn] -makeDerivEqns - = tcGetEnv `thenNF_Tc` \ env -> - let - local_data_tycons = filter (\tc -> isLocallyDefined tc && isAlgTyCon tc) - (getEnvTyCons env) - - think_about_deriving = need_deriving local_data_tycons +makeDerivEqns this_mod local_tycons + = let + think_about_deriving = need_deriving local_tycons (derive_these, _) = removeDups cmp_deriv think_about_deriving in if null local_data_tycons then @@ -319,7 +315,8 @@ makeDerivEqns = case chk_out clas tycon of Just err -> addErrTc err `thenNF_Tc_` returnNF_Tc Nothing - Nothing -> returnNF_Tc (Just (clas, tycon, tyvars, constraints)) + Nothing -> newDFunName this_mod clas tys locn `thenNF_Tc` \ dfun_name -> + returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints)) where clas_key = classKey clas tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ??? @@ -383,12 +380,12 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -solveDerivEqns :: Bag InstInfo +solveDerivEqns :: InstEnv -> [DerivEqn] - -> TcM [InstInfo] -- Solns in same order as eqns. - -- This bunch is Absolutely minimal... + -> TcM [DFunId] -- Solns in same order as eqns. + -- This bunch is Absolutely minimal... -solveDerivEqns inst_decl_infos_in orig_eqns +solveDerivEqns inst_env_in orig_eqns = iterateDeriv initial_solutions where -- The initial solutions for the equations claim that each @@ -402,11 +399,11 @@ solveDerivEqns inst_decl_infos_in orig_eqns -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. -- It fails if any iteration fails - iterateDeriv :: [DerivSoln] ->TcM [InstInfo] + iterateDeriv :: [DerivSoln] ->TcM [DFunId] iterateDeriv current_solns - = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_inst_infos, new_solns) -> + = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_dfuns, new_solns) -> if (current_solns == new_solns) then - returnTc new_inst_infos + returnTc new_dfuns else iterateDeriv new_solns @@ -415,70 +412,39 @@ solveDerivEqns inst_decl_infos_in orig_eqns = -- Extend the inst info from the explicit instance decls -- with the current set of solutions, giving a - add_solns inst_decl_infos_in orig_eqns current_solns - `thenNF_Tc` \ (new_inst_infos, inst_env) -> + add_solns inst_env_in orig_eqns current_solns `thenNF_Tc` \ (new_dfuns, inst_env) -> -- Simplify each RHS - tcSetInstEnv inst_env ( listTc [ tcAddErrCtxt (derivCtxt tc) $ tcSimplifyThetas deriv_rhs - | (_,tc,_,deriv_rhs) <- orig_eqns ] + | (_, _,tc,_,deriv_rhs) <- orig_eqns ] ) `thenTc` \ next_solns -> -- Canonicalise the solutions, so they compare nicely - let canonicalised_next_solns - = [ sortLt (<) next_soln | next_soln <- next_solns ] + let canonicalised_next_solns = [ sortLt (<) next_soln | next_soln <- next_solns ] in - returnTc (new_inst_infos, canonicalised_next_solns) + returnTc (new_dfuns, canonicalised_next_solns) \end{code} \begin{code} -add_solns :: Bag InstInfo -- The global, non-derived ones +add_solns :: InstEnv -- The global, non-derived ones -> [DerivEqn] -> [DerivSoln] - -> NF_TcM ([InstInfo], -- The new, derived ones - InstEnv) + -> ([DFunId], InstEnv) -- the eqns and solns move "in lockstep"; we have the eqns -- because we need the LHS info for addClassInstance. -add_solns inst_infos_in eqns solns - - = discardErrsTc (buildInstanceEnv all_inst_infos) `thenNF_Tc` \ inst_env -> - -- We do the discard-errs so that we don't get repeated error messages - -- about duplicate instances. - -- They'll appear later, when we do the top-level buildInstanceEnv. - - returnNF_Tc (new_inst_infos, inst_env) +add_solns inst_env_in eqns solns + = (new_dfuns, inst_env) where - new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns - - all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos - - mk_deriv_inst_info (clas, tycon, tyvars, _) theta - = InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] - theta' - dummy_dfun_id - (my_panic "binds") (getSrcLoc tycon) - (my_panic "upragmas") - where - dummy_dfun_id - = mkVanillaId (getName tycon) dummy_dfun_ty - -- The name is getSrcLoc'd in an error message - - theta' = classesToPreds theta - dummy_dfun_ty = mkSigmaTy tyvars theta' voidTy - -- All we need from the dfun is its "theta" part, used during - -- equation simplification (tcSimplifyThetas). The final - -- dfun_id will have the superclass dictionaries as arguments too, - -- but that'll be added after the equations are solved. For now, - -- it's enough just to make a dummy dfun with the simple theta part. - -- - -- The part after the theta is dummied here as voidTy; actually it's - -- (C (T a b)), but it doesn't seem worth constructing it. - -- We can't leave it as a panic because to get the theta part we - -- have to run down the type! - - my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (hsep [char ':', ppr clas, ppr tycon]) + new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun eqns solns + (inst_env, _) = extendInstEnv inst_env_in + -- Ignore the errors about duplicate instances. + -- We don't want repeated error messages + -- They'll appear later, when we do the top-level extendInstEnvs + + mk_deriv_dfun (dfun_name clas, tycon, tyvars, _) theta + = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] theta \end{code} %************************************************************************ @@ -547,7 +513,7 @@ the renamer. What a great hack! -- Generate the method bindings for the required instance -- (paired with class name, as we need that when generating dict -- names.) -gen_bind :: GlobalSymbolTable -> InstInfo -> RdrNameMonoBinds +gen_bind :: GlobalSymbolTable -> DFunId -> RdrNameMonoBinds gen_bind fixities inst | not (isLocallyDefined tycon) = EmptyMonoBinds | clas `hasKey` showClassKey = gen_Show_binds fixities tycon @@ -563,8 +529,7 @@ gen_bind fixities inst (classKey clas) tycon where - clas = instInfoClass inst - tycon = simpleInstInfoTyCon inst + (clas, tycon) = simpleDFunClassTyCon dfun \end{code} @@ -601,18 +566,16 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -gen_taggery_Names :: [InstInfo] +gen_taggery_Names :: [DFunId] -> TcM [(RdrName, -- for an assoc list - TyCon, -- related tycon - TagThingWanted)] + TyCon, -- related tycon + TagThingWanted)] -gen_taggery_Names inst_infos - = --pprTrace "gen_taggery:\n" (vcat [hsep [ppr c, ppr t] | (c,t) <- all_CTs]) $ - foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> +gen_taggery_Names dfuns + = foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> foldlTc do_tag2con names_so_far tycons_of_interest where - all_CTs = [ (instInfoClass info, simpleInstInfoTyCon info) | info <- inst_infos ] - + all_CTs = map simplDFunClassTyCon dfuns all_tycons = map snd all_CTs (tycons_of_interest, _) = removeDups compare all_tycons diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index bf2382c..e2dd2b0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -163,49 +163,74 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. Gather up the instance declarations from their various sources \begin{code} -tcInstDecls1 :: PersistentRenamerState +tcInstDecls1 :: PersistentCompilerState + -> HomeSymbolTable -- Contains instances -> TcEnv -- Contains IdInfo for dfun ids - -> [RenamedHsDecl] -> Module -- Module for deriving - -> FixityEnv -- For derivings - -> RnNameSupply -- For renaming derivings - -> TcM (Bag InstInfo, - RenamedHsBinds) - -tcInstDecls1 prs unf_env decls mod - = -- (1) Do the ordinary instance declarations - mapNF_Tc (tcInstDecl1 mod unf_env) - [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags -> - let - decl_inst_info = unionManyBags inst_info_bags - in - -- (2) Instances from "deriving" clauses; note that we only do derivings - -- for things in this module; we ignore deriving decls from - -- interfaces! - tcDeriving prs mod decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds) -> - - -- (3) Instances from generic class declarations - mapTc (getGenericInstances mod) - [cl_decl | TyClD cl_decl <- decls, isClassDecl cl_decl] `thenTc` \ cls_inst_info -> + -> [RenamedHsDecl] + -> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds) +tcInstDecls1 pcs hst unf_env this_mod decls mod + = let + inst_decls = [inst_decl | InstD inst_decl <- decls] + clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl cl_decl] + in + -- (1) Do the ordinary instance declarations + mapNF_Tc (tcInstDecl1 mod) inst_decls `thenNF_Tc` \ inst_infos -> + + -- (2) Instances from generic class declarations + getGenericInstances mod clas_decls `thenTc` \ generic_inst_info -> + + -- Next, consruct the instance environment so far, consisting of + -- a) cached non-home-package InstEnv (gotten from pcs) pcsInsts pcs + -- b) imported instance decls (not in the home package) inst_env1 + -- c) other modules in this package (gotten from hst) inst_env2 + -- d) local instance decls inst_env3 + -- e) generic instances inst_env4 + -- The result of (b) replaces the cached InstEnv in the PCS let - generic_insts = concat cls_inst_info - full_inst_info = deriv_inst_info `unionBags` - unionManyBags inst_info_bags `unionBags` - (listToBag generic_insts) + (local_inst_info, imported_inst_info) = partition isLocalInst (concat inst_infos) + generic_inst_info = concat generic_inst_infos -- All local + + imported_dfuns = map (tcAddImportedIdInfo unf_env . instInfoDFun) imported_inst_info + hst_dfuns = foldModuleEnv ((++) . mdInsts) [] hst + in + addInstDFuns (pcsInsts pcs) 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 -> in - ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances" - (vcat (map pprInstInfo generic_insts))) `thenNF_Tc_` - (returnTc (full_inst_info, deriv_binds)) + -- (3) Compute instances from "deriving" clauses; + -- note that we only do derivings for things in this module; + -- 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 (pcsPRS pcs) this_mod inst_env4 local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) -> + addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> + + returnTc (pcs { pcsInsts = inst_env1 }, + final_inst_env, + generic_inst_info ++ deriv_inst_info ++ local_inst_info, + deriv_binds) + +addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv +addInstInfos inst_env infos = addInstDfuns inst_env (map iDFun infos) + +addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv +addInstDFuns dfuns infos + = addErrsTc errs `thenNF_Tc_` + returnTc inst_env' + where + (inst_env', errs) = extendInstEnv env dfuns \end{code} \begin{code} -tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM (Bag InstInfo) +tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM [InstInfo] -- Deal with a single instance declaration tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) = -- Prime error recovery, set source location - recoverNF_Tc (returnNF_Tc emptyBag) $ + recoverNF_Tc (returnNF_Tc []) $ tcAddSrcLoc src_loc $ -- Type-check all the stuff before the "where" @@ -230,17 +255,17 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) -- Make the dfun id and return it newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> - returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys theta) + returnNF_Tc (True, mkDictFunId dfun_name clas tyvars inst_tys theta) Just dfun_name -> -- An interface-file instance declaration - -- Make the dfun id and add info from interface file - let - dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta - in - returnNF_Tc (tcAddImportedIdInfo unf_env dfun_id) - ) `thenNF_Tc` \ dfun_id -> - - returnTc (unitBag (InstInfo clas tyvars inst_tys theta dfun_id binds src_loc uprags)) + -- Make the dfun id + returnNF_Tc (False, mkDictFunId dfun_name clas tyvars inst_tys theta) + ) `thenNF_Tc` \ (is_local, dfun_id) -> + + returnTc [InstInfo { iLocal = is_local, + iClass = clas, iTyVars = tyvars, iTys = inst_tys, + iTheta = theta, iDFunId = dfun_id, + iBinds = binds, iLoc = src_loc, iPrags = uprags }] \end{code} @@ -275,14 +300,25 @@ gives rise to the instance declarations \begin{code} -getGenericInstances :: Module -> RenamedTyClDecl -> TcM [InstInfo] -getGenericInstances mod decl@(ClassDecl context class_name tyvar_names - fundeps class_sigs def_methods pragmas - name_list loc) +getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo] +getGenericInstances mod class_decls + = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos -> + let + gen_inst_info = concat gen_inst_infos + in + ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances" + (vcat (map pprInstInfo gen_inst_info))) `thenNF_Tc_` + returnTc gen_inst_info + +get_generics mod decl@(ClassDecl context class_name tyvar_names + fundeps class_sigs def_methods pragmas + name_list loc) | null groups - = returnTc [] -- The comon case + = returnTc [] -- The comon case: + -- no generic default methods, or + -- its an imported class decl (=> has no methods at all) - | otherwise + | otherwise -- A local class decl with generic default methods = recoverNF_Tc (returnNF_Tc []) $ tcAddDeclCtxt decl $ tcLookupClass class_name `thenTc` \ clas -> @@ -361,8 +397,10 @@ mkGenericInstance mod clas loc (hs_ty, binds) dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta in - returnTc (InstInfo clas tyvars inst_tys inst_theta dfun_id binds loc []) - -- The "[]" means "no pragmas" + returnTc (InstInfo { iLocal = True, + iClass = clas, iTyVars = tyvars, iTys = inst_tys, + iTheta = inst_theta, iDFunId = dfun_id, iBinds = binds, + iLoc = loc, iPrags = [] }) \end{code} @@ -454,10 +492,9 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) -tcInstDecl2 (InstInfo clas inst_tyvars inst_tys - inst_decl_theta - dfun_id monobinds - locn uprags) +tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, + iTheta = inst_decl_theta, iDFunId = dfun_id, + iBinds = monobinds, iLoc = locn, iPrags = uprags }) | not (isLocallyDefined dfun_id) = returnNF_Tc (emptyLIE, EmptyMonoBinds) diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 5b5569b..bc30d93 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -8,10 +8,10 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module TcInstUtil ( InstInfo(..), pprInstInfo, - instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon, + simpleInstInfoTy, simpleInstInfoTyCon, -- Instance environment - InstEnv, emptyInstEnv, buildInstanceEnv, + InstEnv, emptyInstEnv, extendInstEnv, lookupInstEnv, InstLookupResult(..), classInstEnv, classDataCon ) where @@ -52,27 +52,25 @@ The InstInfo type summarises the information in an instance declaration \begin{code} data InstInfo - = InstInfo - Class -- Class, k - [TyVar] -- Type variables, tvs - [Type] -- The types at which the class is being instantiated - ThetaType -- inst_decl_theta: the original context, c, from the - -- instance declaration. It constrains (some of) - -- the TyVars above - Id -- The dfun id - RenamedMonoBinds -- Bindings, b - SrcLoc -- Source location assoc'd with this instance's defn - [RenamedSig] -- User pragmas recorded for generating specialised instances - -pprInstInfo (InstInfo clas tvs tys inst_decl_theta _ mbinds _ _) - = vcat [ptext SLIT("InstInfo:") <+> ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas tys)), - nest 4 (ppr mbinds)] - -instInfoClass :: InstInfo -> Class -instInfoClass (InstInfo clas _ _ _ _ _ _ _) = clas + = InstInfo { + iClass :: Class, -- Class, k + iTyVars :: [TyVar], -- Type variables, tvs + iTys :: [Type], -- The types at which the class is being instantiated + iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the + -- instance declaration. It constrains (some of) + -- the TyVars above + iLocal :: Bool, -- True <=> it's defined in this module + iDFunId :: DFunId, -- The dfun id + iBinds :: RenamedMonoBinds, -- Bindings, b + iLoc :: SrcLoc -- Source location assoc'd with this instance's defn + iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances + } + +pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), + nest 4 (ppr (iBinds info))] simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy (InstInfo _ _ [ty] _ _ _ _ _) = ty +simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, @@ -80,6 +78,9 @@ simpleInstInfoTyCon :: InstInfo -> TyCon simpleInstInfoTyCon inst = case splitTyConApp_maybe (simpleInstInfoTy inst) of Just (tycon, _) -> tycon + +isLocalInst :: InstInfo -> Bool +isLocalInst info = iLocal info \end{code} @@ -87,6 +88,15 @@ A tiny function which doesn't belong anywhere else. It makes a nasty mutual-recursion knot if you put it in Class. \begin{code} +simpleDFunClassTyCon :: DFunId -> (Class, TyCon) +simpleDFunClassTyCon dfun + = (clas, tycon) + where + (_,_,dict_ty) = splitSigmaTy (idType dfun) + (clas, [ty]) = splitDictTy dict_ty + tycon = case splitTyConApp_maybe ty of + Just (tycon,_) -> tycon + classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr @@ -94,57 +104,6 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of %************************************************************************ %* * -\subsection{Converting instance info into suitable InstEnvs} -%* * -%************************************************************************ - -\begin{code} -buildInstanceEnv :: Bag InstInfo -> NF_TcM InstEnv - -buildInstanceEnv info = --pprTrace "BuildInstanceEnv" (ppr info) - foldrNF_Tc addClassInstance emptyInstEnv (bagToList info) -\end{code} - -@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ -based on information from a single instance declaration. It complains -about any overlap with an existing instance. - -\begin{code} -addClassInstance - :: InstInfo - -> InstEnv - -> NF_TcM InstEnv - -addClassInstance - (InstInfo clas inst_tyvars inst_tys _ - dfun_id _ src_loc _) - inst_env - = -- Add the instance to the class's instance environment - case addToInstEnv opt_AllowOverlappingInstances - inst_env clas inst_tyvars inst_tys dfun_id of - Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id) - (tys', dfun_id')) - `thenNF_Tc_` - returnNF_Tc inst_env - - Succeeded inst_env' -> returnNF_Tc inst_env' -\end{code} - -\begin{code} -dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2) - -- Overlapping/duplicate instances for given class; msg could be more glamourous - = hang (ptext SLIT("Duplicate or overlapping instance declarations")) - 4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1), - nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])]) - where - ppr_loc dfun - | isLocallyDefined dfun = ptext SLIT("defined at") <+> ppr (getSrcLoc dfun) - | otherwise = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun))) -\end{code} - - -%************************************************************************ -%* * \subsection{Instance environments: InstEnv and ClsInstEnv} %* * %************************************************************************ @@ -355,20 +314,43 @@ True => overlap is permitted, but only if one template matches the other; not if they unify but neither is \begin{code} -addToInstEnv :: Bool -- True <=> overlap permitted - -> InstEnv -- Envt - -> Class -> [TyVar] -> [Type] -> Id -- New item - -> MaybeErr InstEnv -- Success... - ([Type], Id) -- Failure: Offending overlap +extendInstEnv :: InstEnv -> [DFunId] -> (InstEnv, [Message]) + -- Similar, but all we have is the DFuns +extendInstEnvWithDFuns env infos + = go env [] infos + where + go env msgs [] = (env, msgs) + go env msgs (dfun:dfuns) = case addToInstEnv inst_env dfun of + Succeeded new_env -> go new_env msgs dfuns + Failed dfun' -> go env (msg:msgs) infos + where + msg = dupInstErr dfun dfun' + -addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value +dupInstErr dfun1 dfun2 + -- Overlapping/duplicate instances for given class; msg could be more glamourous + = hang (ptext SLIT("Duplicate or overlapping instance declarations:")) + 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2) + where + ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> ppr tau + where + (_,_,tau) = splitSigmaTy (idType dfun) + +addToInstEnv :: InstEnv -> DFunId + -> MaybeErr InstEnv -- Success... + DFunId -- Failure: Offending overlap + +addToInstEnv inst_env dfun_id = case insert_into (classInstEnv inst_env clas) of Failed stuff -> Failed stuff Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env) where + (ins_tvs, _, dict_ty) = splitSigmaTy (idType dfun_id) + (clas, ins_tys) = splitDictTy dict_ty + ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, value) + ins_item = (ins_tv_set, ins_tys, dfun_id) insert_into [] = returnMaB [ins_item] insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest) @@ -378,9 +360,9 @@ addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value -- (b) they unify, and any sort of overlap is prohibited, -- (c) they unify but neither is more specific than t'other | identical - || (unifiable && not overlap_ok) + || (unifiable && not opt_AllowOverlappingInstances) || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) - = failMaB (tpl_tys, val) + = failMaB val -- New item is an instance of current item, so drop it here | ins_item_more_specific = returnMaB (ins_item : env) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 2058e29..62da34d 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -22,7 +22,7 @@ import TcHsSyn ( TypecheckedMonoBinds, import TcMonad import Inst ( emptyLIE, plusLIE ) -import TcBinds ( tcTopBindsAndThen ) +import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal_maybe, @@ -33,7 +33,7 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcInstUtil ( buildInstanceEnv, InstInfo ) +import TcInstUtil ( InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyDecls ( mkImplicitDataBinds ) @@ -58,7 +58,7 @@ import Maybes ( maybeToBool ) import Util import BasicTypes ( EP(..) ) import Bag ( Bag, isEmptyBag ) -import Outputable +vimport Outputable \end{code} @@ -71,8 +71,8 @@ data TcResults tc_pcs :: PersistentCompilerState, -- Augmented with imported information, -- (but not stuff from this module) tc_env :: TypeEnv, -- The TypeEnv just for the stuff from this module + tc_insts :: [DFunId], -- Instances, just for this module tc_binds :: TypecheckedMonoBinds, - tc_insts :: InstEnv, -- Instances, just for this module tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. tc_rules :: [TypecheckedRuleDecl], -- Transformation rules } @@ -84,204 +84,188 @@ typecheckModule -> RenamedHsModule -> IO (Maybe (PersistentCompilerState, TcResults)) -typecheckModule pcs hst mod - = do { us <- mkSplitUniqSupply 'a' ; +typecheckModule pcs hst (HsModule mod_name _ _ _ decls _ src_loc) + = do { env <- initTcEnv global_symbol_table global_inst_env ; - env <- initTcEnv global_symbol_table global_inst_env ; - - (maybe_result, warns, errs) <- initTc us env (tcModule (pcsPRS pcs) mod) + (_, (maybe_result, warns, errs)) <- initTc env src_loc tc_module printErrorsAndWarnings errs warns ; - case maybe_result of { - Nothing -> return Nothing ; - Just results -> do { - - dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ; - dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) ; + printTcDumps maybe_result ; if isEmptyBag errs then return Nothing - else - - let groups :: FiniteMap Module TypeEnv - groups = groupTyThings (nameEnvElts (tc_env results)) - - local_type_env :: TypeEnv - local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv - - new_pst :: PackageSymbolTable - new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod) - ; - return (Just (pcs {pcsPST = new_pst}, - results {tc_env = local_type_env})) - }}} + else + return result + } where + this_mod = mkThisModule global_symbol_table = pcsPST pcs `plusModuleEnv` hst - global_inst_env = foldModuleEnv (plusInstEnv . instEnv) (pcsInsts pcs) gst - -- For now, make the total instance envt by simply - -- folding together all the instances we can find anywhere + tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst this_mod decls unf_env) \end{code} The internal monster: \begin{code} -tcModule :: PersistentRenamerState - -> RenamedHsModule -- input - -> TcM TcResults -- output - -tcModule prs (HsModule mod_name _ _ _ decls _ src_loc) - = tcAddSrcLoc src_loc $ -- record where we're starting - - fixTc (\ ~(unf_env ,_) -> - -- (unf_env :: TcEnv) is used for type-checking interface pragmas - -- which is done lazily [ie failure just drops the pragma - -- without having any global-failure effect]. - -- - -- unf_env is also used to get the pragama info - -- for imported dfuns and default methods - - -- Type-check the type and class decls - tcTyAndClassDecls unf_env decls `thenTc` \ env -> - tcSetEnv env $ - - -- Typecheck the instance decls, includes deriving - tcInstDecls1 prs unf_env decls - (mkThisModule mod_name) `thenTc` \ (inst_info, deriv_binds) -> +tcModule :: PersistentCompilerState + -> HomeSymbolTable + -> Module + -> [RenamedHsDecl] + -> TcEnv -- The knot-tied environment + -> TcM TcResults + + -- (unf_env :: TcEnv) is used for type-checking interface pragmas + -- which is done lazily [ie failure just drops the pragma + -- without having any global-failure effect]. + -- + -- unf_env is also used to get the pragama info + -- for imported dfuns and default methods + +tcModule pcs hst this_mod decls unf_env + = -- Type-check the type and class decls + tcTyAndClassDecls unf_env decls `thenTc` \ env -> + tcSetEnv env $ + let + classes = tcEnvClasses env + tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes + local_classes = filter isLocallyDefined classes + local_tycons = [ tc | tc <- tycons, + isLocallyDefined tc, + not (isClassTyCon tc) + ] + -- For local_tycons, filter out the ones derived from classes + -- Otherwise the latter show up in interface files + in + + -- Typecheck the instance decls, includes deriving + tcInstDecls1 pcs hst unf_env this_mod + local_tycons decls `thenTc` \ (pcs_with_insts, inst_env, inst_info, deriv_binds) -> + tcSetInstEnv inst_env $ + + -- Default declarations + tcDefaults decls `thenTc` \ defaulting_tys -> + tcSetDefaultTys defaulting_tys $ + + -- Interface type signatures + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + -- We must do this before mkImplicitDataBinds (which comes next), since + -- the latter looks up unpackCStringId, for example, which is usually + -- imported + tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> + tcExtendGlobalValEnv sig_ids $ + + -- Create any necessary record selector Ids and their bindings + -- "Necessary" includes data and newtype declarations + -- We don't create bindings for dictionary constructors; + -- they are always fully applied, and the bindings are just there + -- to support partial applications + mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) -> + mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> + + -- Extend the global value environment with + -- (a) constructors + -- (b) record selectors + -- (c) class op selectors + -- (d) default-method ids... where? I can't see where these are + -- put into the envt, and I'm worried that the zonking phase + -- will find they aren't there and complain. + tcExtendGlobalValEnv data_ids $ + tcExtendGlobalValEnv cls_ids $ + + -- Foreign import declarations next + tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> + tcExtendGlobalValEnv fo_ids $ + + -- Value declarations next. + -- We also typecheck any extra binds that came out of the "deriving" process + tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) -> + tcSetEnv env $ - buildInstanceEnv inst_info `thenNF_Tc` \ inst_env -> - - tcSetInstEnv inst_env $ - let - classes = tcEnvClasses env - tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes - local_classes = filter isLocallyDefined classes - local_tycons = [ tc | tc <- tycons, - isLocallyDefined tc, - not (isClassTyCon tc) - ] - -- For local_tycons, filter out the ones derived from classes - -- Otherwise the latter show up in interface files - in - - -- Default declarations - tcDefaults decls `thenTc` \ defaulting_tys -> - tcSetDefaultTys defaulting_tys $ - - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - -- We must do this before mkImplicitDataBinds (which comes next), since - -- the latter looks up unpackCStringId, for example, which is usually - -- imported - tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - - -- Create any necessary record selector Ids and their bindings - -- "Necessary" includes data and newtype declarations - -- We don't create bindings for dictionary constructors; - -- they are always fully applied, and the bindings are just there - -- to support partial applications - mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) -> - mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> - - -- Extend the global value environment with - -- (a) constructors - -- (b) record selectors - -- (c) class op selectors - -- (d) default-method ids... where? I can't see where these are - -- put into the envt, and I'm worried that the zonking phase - -- will find they aren't there and complain. - tcExtendGlobalValEnv data_ids $ - tcExtendGlobalValEnv cls_ids $ - - -- foreign import declarations next. - tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> - tcExtendGlobalValEnv fo_ids $ - - -- Value declarations next. - -- We also typecheck any extra binds that came out of the "deriving" process - tcTopBindsAndThen - (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing)) - (get_val_decls decls `ThenBinds` deriv_binds) - ( tcGetEnv `thenNF_Tc` \ env -> - returnTc ((EmptyMonoBinds, env), emptyLIE) - ) `thenTc` \ ((val_binds, final_env), lie_valdecls) -> - tcSetEnv final_env $ - - -- foreign export declarations next. - tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> - - -- Second pass over class and instance declarations, - -- to compile the bindings themselves. - tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> - tcRules decls `thenNF_Tc` \ (lie_rules, rules) -> - - - -- Deal with constant or ambiguous InstIds. How could - -- there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) - let - lie_alldecls = lie_valdecls `plusLIE` - lie_instdecls `plusLIE` - lie_clasdecls `plusLIE` - lie_fodecls `plusLIE` - lie_rules - in - tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> - - -- Check that Main defines main - (if mod_name == mAIN_Name then - tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main -> - case maybe_main of - Just (AnId _) -> returnTc () - other -> addErrTc noMainErr - else - returnTc () - ) `thenTc_` - - -- Backsubstitution. This must be done last. - -- Even tcSimplifyTop may do some unification. - let - all_binds = imp_data_binds `AndMonoBinds` - imp_cls_binds `AndMonoBinds` - val_binds `AndMonoBinds` - inst_binds `AndMonoBinds` - cls_dm_binds `AndMonoBinds` - const_inst_binds `AndMonoBinds` - foe_binds - in - zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) -> - tcSetEnv really_final_env $ - -- zonkTopBinds puts all the top-level Ids into the tcGEnv - - zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> - zonkRules rules `thenNF_Tc` \ rules' -> - - returnTc (really_final_env, - (TcResults { tc_env = tcGEnv really_final_env, - tc_binds = all_binds', - tc_insts = inst_info, - tc_fords = foi_decls ++ foe_decls', - tc_rules = rules' - })) - - -- End of outer fix loop - ) `thenTc` \ (final_env, stuff) -> - returnTc stuff - -get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] + -- Foreign export declarations next + tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> + + -- Second pass over class and instance declarations, + -- to compile the bindings themselves. + tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> + tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> + tcRules decls `thenNF_Tc` \ (lie_rules, rules) -> + + -- Deal with constant or ambiguous InstIds. How could + -- there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism + -- restriction, and no subsequent decl instantiates its + -- type. (Usually, ambiguous type variables are resolved + -- during the generalisation step.) + let + lie_alldecls = lie_valdecls `plusLIE` + lie_instdecls `plusLIE` + lie_clasdecls `plusLIE` + lie_fodecls `plusLIE` + lie_rules + in + tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> + + -- Check that Main defines main + checkMain this_mod `thenTc_` + + -- Backsubstitution. This must be done last. + -- Even tcSimplifyTop may do some unification. + let + all_binds = imp_data_binds `AndMonoBinds` + imp_cls_binds `AndMonoBinds` + val_binds `AndMonoBinds` + inst_binds `AndMonoBinds` + cls_dm_binds `AndMonoBinds` + const_inst_binds `AndMonoBinds` + foe_binds + in + zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) -> + tcSetEnv final_env $ + -- zonkTopBinds puts all the top-level Ids into the tcGEnv + zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> + zonkRules rules `thenNF_Tc` \ rules' -> + + + let groups :: FiniteMap Module TypeEnv + groups = groupTyThings (nameEnvElts (tcGEnv final_env)) + + local_type_env :: TypeEnv + local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv + + new_pst :: PackageSymbolTable + new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod) + + final_pcs :: PersistentCompilerState + final_pcs = pcs_with_insts {pcsPST = new_pst} + in + returnTc (really_final_env, + TcResults { tc_pcs = final_pcs, + tc_env = local_type_env, + tc_binds = all_binds', + tc_insts = map instInfoDfunId inst_infos, + tc_fords = foi_decls ++ foe_decls', + tc_rules = rules' + })) + +get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \end{code} \begin{code} +checkMain :: Module -> TcM () +checkMain this_mod + | moduleName this_mod == mAIN_Name + = tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main -> + case maybe_main of + Just (AnId _) -> returnTc () + other -> addErrTc noMainErr + + | otherwise = returnTc () + noMainErr = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name), ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] @@ -295,6 +279,12 @@ noMainErr %************************************************************************ \begin{code} +printTcDump Nothing = return () +printTcDump (Just results) + = do { dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ; + dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) + } + dump_tc results = vcat [ppr (tc_binds results), pp_rules (tc_rules results), diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 6f151db..f104fbe 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -21,7 +21,7 @@ module TcMonad( listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, - failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc, + failTc, failWithTc, addErrTc, addErrsTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc, addErrTcM, addInstErrTcM, failWithTcM, tcGetEnv, tcSetEnv, @@ -123,15 +123,14 @@ type TcRef a = IORef a \end{code} \begin{code} --- initEnv is passed in to avoid module recursion between TcEnv & TcMonad. - -initTc :: UniqSupply - -> (TcRef (UniqFM a) -> TcEnv) +initTc :: TcEnv + -> SrcLoc -> TcM r -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg) -initTc us initenv do_this +initTc tc_env src_loc do_this = do { + us <- mkSplitUniqSupply 'a' ; us_var <- newIORef us ; dfun_var <- newIORef emptyFM ; errs_var <- newIORef (emptyBag,emptyBag) ; @@ -139,12 +138,11 @@ initTc us initenv do_this let init_down = TcDown [] us_var dfun_var - noSrcLoc + src_loc [] errs_var - init_env = initenv tvs_var ; - maybe_res <- catch (do { res <- do_this init_down init_env ; + maybe_res <- catch (do { res <- do_this init_down env ; return (Just res)}) (\_ -> return Nothing) ; @@ -303,6 +301,10 @@ failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg) addErrTc :: Message -> NF_TcM () addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg) +addErrsTc :: [Message] -> NF_TcM () +addErrsTc [] = returnNF_Tc () +addErrsTc err_msgs = listNF_Tc_ (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc () + -- The 'M' variants do the TidyEnv bit failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail failWithTcM env_and_msg diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index b3134f5..a3fd008 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -33,7 +33,7 @@ module Type ( -- Predicates and the like mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, - splitDictTy_maybe, isDictTy, predRepTy, + splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, mkSynTy, isSynTy, deNoteType, @@ -689,10 +689,14 @@ splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty splitPredTy_maybe (PredTy p) = Just p splitPredTy_maybe other = Nothing +splitDictTy :: Type -> (Class, [Type]) +splitDictTy (NoteTy _ ty) = splitDictTy ty +splitDictTy (PredTy (Class clas tys)) = (clas, tys) + splitDictTy_maybe :: Type -> Maybe (Class, [Type]) -splitDictTy_maybe ty = case splitPredTy_maybe ty of - Just p -> getClassTys_maybe p - Nothing -> Nothing +splitDictTy_maybe (NoteTy _ ty) = splitDictTy ty +splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys) +splitDictTy_maybe other = Nothing getClassTys_maybe :: PredType -> Maybe ClassPred getClassTys_maybe (Class clas tys) = Just (clas, tys) -- 1.7.10.4