Skip to content

GitLab

Commit f1080bc8 authored by simonpj's avatar simonpj
Browse files
Options

[project @ 2000-10-13 15:08:10 by simonpj] 

Mainly typechecking instance decls
parent 064a65d9
Hide whitespace changes
Inline Side-by-side
Showing with 428 additions and 440 deletions
ghc/compiler/main/HscTypes.lhs
View file @ f1080bc8
......@@ -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}
......
ghc/compiler/typecheck/TcBinds.lhs
View file @ f1080bc8
......@@ -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
......
ghc/compiler/typecheck/TcDeriv.lhs
View file @ f1080bc8
......@@ -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
......
ghc/compiler/typecheck/TcInstDcls.lhs
View file @ f1080bc8
......@@ -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)
......
ghc/compiler/typecheck/TcInstUtil.lhs
View file @ f1080bc8
......@@ -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,62 +88,20 @@ 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