#include "HsVersions.h"
import HsSyn
-import TcBinds ( tcSpecSigs )
+import TcBinds ( mkPragFun, tcPrags, badBootDeclErr )
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
-import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr,
+import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead,
+ checkInstTermination, instTypeErr,
checkAmbiguity, SourceTyCtxt(..) )
import TcType ( mkClassPred, tyVarsOfType,
tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
-import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
+import Inst ( tcInstClassOp, newDicts, instToId, showLIE,
+ getOverlapFlag, tcExtendLocalInstEnv )
+import InstEnv ( mkLocalInstance, instanceDFunId )
import TcDeriv ( tcDeriving )
-import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv,
- InstInfo(..), InstBindings(..),
+import TcEnv ( InstInfo(..), InstBindings(..),
newDFunName, tcExtendIdEnv
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
-import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
+import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, substTys )
import DataCon ( classDataCon )
import Class ( classBigSig )
import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Name ( Name, getSrcLoc )
-import NameSet ( unitNameSet, emptyNameSet )
-import UnicodeUtil ( stringToUtf8 )
import Maybe ( catMaybes )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import ListSetOps ( minusList )
import Outputable
import Bag
+import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
import FastString
\end{code}
-> TcM (TcGblEnv, -- The full inst env
[InstInfo], -- Source-code instance decls to process;
-- contains all dfuns for this module
- [HsBindGroup Name]) -- Supporting bindings for derived instances
+ HsValBinds Name) -- Supporting bindings for derived instances
tcInstDecls1 tycl_decls inst_decls
= checkNoErrs $
clas_decls = filter (isClassDecl.unLoc) tycl_decls
in
-- (2) Instances from generic class declarations
- getGenericInstances clas_decls `thenM` \ generic_inst_info ->
+ getGenericInstances clas_decls `thenM` \ generic_inst_info ->
-- Next, construct the instance environment so far, consisting of
-- a) local instance decls
addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
- = tcExtendLocalInstEnv (map iDFunId infos) thing_inside
+ = tcExtendLocalInstEnv (map iSpec infos) thing_inside
\end{code}
\begin{code}
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
- -- but only do this for non-imported instance decls.
- -- Imported ones should have been checked already, and may indeed
- -- contain something illegal in normal Haskell, notably
- -- instance CCallable [Char]
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
= -- Prime error recovery, set source location
recoverM (returnM Nothing) $
checkValidTheta InstThetaCtxt theta `thenM_`
checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_`
checkValidInstHead tau `thenM` \ (clas,inst_tys) ->
+ checkInstTermination theta inst_tys `thenM_`
checkTc (checkInstFDs theta clas inst_tys)
(instTypeErr (pprClassPred clas inst_tys) msg) `thenM_`
newDFunName clas inst_tys (srcSpanStart loc) `thenM` \ dfun_name ->
- returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys,
- iBinds = VanillaInst binds uprags }))
+ getOverlapFlag `thenM` \ overlap_flag ->
+ let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
+ ispec = mkLocalInstance dfun overlap_flag
+ in
+
+ tcIsHsBoot `thenM` \ is_boot ->
+ checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
+ badBootDeclErr `thenM_`
+
+ returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags }))
where
msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
\end{code}
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
- -> TcM (TcLclEnv, LHsBinds Id)
+ -> TcM (LHsBinds Id, TcLclEnv)
-- (a) From each class declaration,
-- generate any default-method bindings
-- (b) From each instance decl
; inst_binds_s <- mappM tcInstDecl2 inst_decls
-- Done
- ; tcl_env <- getLclEnv
- ; returnM (tcl_env, unionManyBags dm_binds_s `unionBags`
- unionManyBags inst_binds_s) }
+ ; let binds = unionManyBags dm_binds_s `unionBags`
+ unionManyBags inst_binds_s
+ ; tcl_env <- getLclEnv -- Default method Ids in here
+ ; returnM (binds, tcl_env) }
\end{code}
======= New documentation starts here (Sept 92) ==============
\begin{code}
tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
-tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
- = -- Prime error recovery
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
+ = let
+ dfun_id = instanceDFunId ispec
+ rigid_info = InstSkol dfun_id
+ inst_ty = idType dfun_id
+ in
+ -- Prime error recovery
recoverM (returnM emptyLHsBinds) $
setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-- Instantiate the instance decl with skolem constants
- let
- rigid_info = InstSkol dfun_id
- inst_ty = idType dfun_id
- in
tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
-- These inst_tyvars' scope over the 'where' part
-- Those tyvars are inside the dfun_id's type, which is a bit
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
- ------------------
-- Typecheck the methods
let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
op_items binds `thenM` \ (meth_ids, meth_binds) ->
-- Figure out bindings for the superclass context
- tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
- `thenM` \ (sc_binds_inner, sc_binds_outer) ->
-
- -- It's possible that the superclass stuff might have done unification
+ -- Don't include this_dict in the 'givens', else
+ -- sc_dicts get bound by just selecting from this_dict!!
+ addErrCtxt superClassCtxt
+ (tcSimplifySuperClasses inst_tyvars'
+ dfun_arg_dicts
+ sc_dicts) `thenM` \ sc_binds ->
+
+ -- It's possible that the superclass stuff might unified one
+ -- of the inst_tyavars' with something in the envt
checkSigTyVars inst_tyvars' `thenM_`
- -- Deal with 'SPECIALISE instance' pragmas by making them
- -- look like SPECIALISE pragmas for the dfun
+ -- Deal with 'SPECIALISE instance' pragmas
let
- uprags = case binds of
- VanillaInst _ uprags -> uprags
- other -> []
- spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty)
- | L loc (SpecInstSig ty) <- uprags ]
+ specs = case binds of
+ VanillaInst _ prags -> filter isSpecInstLSig prags
+ other -> []
in
- tcExtendGlobalValEnv [dfun_id] (
- tcExtendTyVarEnv inst_tyvars' $
- tcSpecSigs spec_prags
- ) `thenM` \ prag_binds ->
-
+ tcPrags dfun_id specs `thenM` \ prags ->
+
-- Create the result bindings
let
dict_constr = classDataCon clas
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
- inlines | null dfun_arg_dicts = emptyNameSet
- | otherwise = unitNameSet (idName dfun_id)
+ inline_prag | null dfun_arg_dicts = []
+ | otherwise = [InlinePrag (Inline AlwaysActive True)]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
-- Often it means we can do the method selection, and then
-- See Note [Inline dfuns] below
dict_rhs
- | null scs_and_meths
- = -- Blatant special case for CCallable, CReturnable
- -- If the dictionary is empty then we should never
- -- select anything from it, so we make its RHS just
- -- emit an error message. This in turn means that we don't
- -- mention the constructor, which doesn't exist for CCallable, CReturnable
- -- Hardly beautiful, but only three extra lines.
- nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID)
- [idType this_dict_id])
- (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
-
- | otherwise -- The common case
= mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
dict_bind = noLoc (VarBind this_dict_id dict_rhs)
- all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds)
+ all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
main_bind = noLoc $ AbsBinds
inst_tyvars'
(map instToId dfun_arg_dicts)
- [(inst_tyvars', dfun_id, this_dict_id)]
- inlines all_binds
+ [(inst_tyvars', dfun_id, this_dict_id,
+ inline_prag ++ prags)]
+ all_binds
in
showLIE (text "instance") `thenM_`
- returnM (unitBag main_bind `unionBags`
- prag_binds `unionBags`
- sc_binds_outer)
+ returnM (unitBag main_bind)
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
-- The trouble is that the 'meth_inst' for op, which is 'available', also
-- looks like 'op at Int'. But they are not the same.
let
+ prag_fn = mkPragFun uprags
all_insts = avail_insts ++ catMaybes meth_insts
- tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts uprags
+ tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn
meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]
in
subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars')
\end{code}
-Note: [Superclass loops]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We have to be very, very careful when generating superclasses, lest we
-accidentally build a loop. Here's an example:
-
- class S a
-
- class S a => C a where { opc :: a -> a }
- class S b => D b where { opd :: b -> b }
-
- instance C Int where
- opc = opd
-
- instance D Int where
- opd = opc
-
-From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
-Simplifying, we may well get:
- $dfCInt = :C ds1 (opd dd)
- dd = $dfDInt
- ds1 = $p1 dd
-Notice that we spot that we can extract ds1 from dd.
-
-Alas! Alack! We can do the same for (instance D Int):
-
- $dfDInt = :D ds2 (opc dc)
- dc = $dfCInt
- ds2 = $p1 dc
-
-And now we've defined the superclass in terms of itself.
-
-
-Solution: treat the superclass context separately, and simplify it
-all the way down to nothing on its own. Don't toss any 'free' parts
-out to be simplified together with other bits of context.
-Hence the tcSimplifyTop below.
-
-At a more basic level, don't include this_dict in the context wrt
-which we simplify sc_dicts, else sc_dicts get bound by just selecting
-from this_dict!!
-
-\begin{code}
-tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
- = addErrCtxt superClassCtxt $
- getLIE (tcSimplifyCheck doc inst_tyvars'
- dfun_arg_dicts
- sc_dicts) `thenM` \ (sc_binds1, sc_lie) ->
-
- -- We must simplify this all the way down
- -- lest we build superclass loops
- -- See Note [Superclass loops] above
- tcSimplifyTop sc_lie `thenM` \ sc_binds2 ->
-
- returnM (sc_binds1, sc_binds2)
-
- where
- doc = ptext SLIT("instance declaration superclass context")
-\end{code}
-
------------------------------
[Inline dfuns] Inlining dfuns unconditionally
projects / ghc-hetmet.git / blobdiff