Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
f1080bc8
Commit
f1080bc8
authored
Oct 13, 2000
by
simonpj
Browse files
[project @ 2000-10-13 15:08:10 by simonpj]
Mainly typechecking instance decls
parent
064a65d9
Changes
8
Hide whitespace changes
Inline
Side-by-side
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, tcTopBinds
AndThen
,
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, simpleInstInfo
TyCon,
buil
dInst
ance
Env )
import TcInstUtil ( InstInfo(..), pprInstInfo,
simpleDFunClass
TyCon,
exten
dInstEnv )
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_info
s ->
solveDerivEqns inst_
env
_in eqns
`thenTc` \ new_
dfun
s ->
-- 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_info
s
method_binds_s = map (gen_bind (tcGST env)) new_
dfun
s
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_info
s `zip` rn_method_binds_s) `thenNF_Tc` \
really_
new_inst_infos ->
mapNF_Tc gen_inst_info (new_
dfun
s `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_info
s, new_solns) ->
= checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_
dfun
s, new_solns) ->
if (current_solns == new_solns) then
returnTc new_
inst_info
s
returnTc new_
dfun
s
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_info
s, canonicalised_next_solns)
returnTc (new_
dfun
s, 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
return
NF_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) ->
return
Tc [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,
buil
dInst
ance
Env,
InstEnv, emptyInstEnv,
exten
dInstEnv,
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