--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+%
+\section[InstEnv]{Instance environments}
+
+\begin{code}
+#include "HsVersions.h"
+
+module InstEnv (
+ -- these types could use some abstractification (??? ToDo)
+ ClassInstEnv(..), -- OLD: IdInstEnv(..),
+ InstTemplate, InstTy,
+ MethodInstInfo(..), -- needs to be exported? (ToDo)
+ InstanceMapper(..), -- widely-used synonym
+
+-- instMethod, instTemplate, -- no need to export
+ addClassInst, {- NOT USED addConstMethInst, -}
+ lookupInst,
+ lookupClassInstAtSimpleType,
+ lookupNoBindInst,
+
+ MatchEnv(..), -- mk more abstract (??? ToDo)
+ nullMEnv,
+-- mkMEnv, lookupMEnv, insertMEnv, -- no need to export
+
+ -- and to make the interface self-sufficient...
+ Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id,
+ Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon,
+ UniType, SplitUniqSupply, SpecInfo
+ ) where
+
+IMPORT_Trace -- ToDo: rm (debugging)
+
+import AbsPrel ( intTyCon, --wordTyCon, addrTyCon,
+ floatTyCon, doubleTyCon, charDataCon, intDataCon,
+ wordDataCon, addrDataCon, floatDataCon,
+ doubleDataCon,
+ intPrimTyCon, doublePrimTyCon
+ )
+import AbsSyn -- TypecheckedExpr, etc.
+import AbsUniType
+import Id
+import IdInfo
+import Inst
+import Maybes -- most of it
+import Outputable ( isExported )
+import PlainCore -- PlainCoreExpr, etc.
+import Pretty
+import PrimKind -- rather grubby import (ToDo?)
+import SplitUniq
+import Util
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[InstEnv-types]{Type declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+type InstanceMapper
+ = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
+
+type ClassInstEnv = MatchEnv UniType InstTemplate -- Instances of dicts
+--OLD: type IdInstEnv = MatchEnv [UniType] InstTemplate -- Instances of ids
+
+data InstTemplate
+ = MkInstTemplate
+ Id -- A fully polymorphic Id; it is the function
+ -- which produces the Id instance or dict from
+ -- the pieces specified by the rest of the
+ -- template. Its SrcLoc tells where the
+ -- instance was defined.
+ [UniType] -- Apply it to these types, suitably instantiated
+ [InstTy] -- and instances of these things
+
+type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance
+\end{code}
+
+There is an important consistency constraint between the @MatchEnv@s
+in and the @InstTemplate@s inside them: the @UniType@(s) which is/are
+the key for the @MatchEnv@ must contain only @TyVarTemplates@, and
+these must be a superset of the @TyVarTemplates@ mentioned in the
+corresponding @InstTemplate@.
+
+Reason: the lookup process matches the key against the desired value,
+returning a substitution which is used to instantiate the template.
+
+\begin{code}
+data InstTy
+ = DictTy Class UniType
+ | MethodTy Id [UniType]
+\end{code}
+
+ MkInstTemplate f tvs insts
+
+says that, given a particular mapping of type variables tvs to some
+types tys, the value which is the required instance is
+
+ f tys (insts [tys/tvs])
+
+
+@instMethod@ is used if there is no instance for a method; then it is
+expressed in terms of the corresponding dictionary (or possibly, in a
+wired-in case only, dictionaries).
+
+\begin{code}
+instMethod :: SplitUniqSupply
+ -> InstOrigin
+ -> Id -> [UniType]
+ -> (TypecheckedExpr, [Inst])
+
+instMethod uniqs orig id tys
+ = (mkDictApp (mkTyApp (Var id) tys) dicts,
+ insts)
+ where
+ (tyvars, theta, tau_ty) = splitType (getIdUniType id)
+ tenv = tyvars `zipEqual` tys
+ insts = mk_dict_insts uniqs theta
+ dicts = map mkInstId insts
+
+ mk_dict_insts us [] = []
+ mk_dict_insts us ((clas, ty) : rest)
+ = case splitUniqSupply us of { (s1, s2) ->
+ (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig)
+ : mk_dict_insts s2 rest
+ }
+\end{code}
+
+@instTemplate@ is used if there is an instance for a method or dictionary.
+
+\begin{code}
+instTemplate :: SplitUniqSupply
+ -> InstOrigin
+ -> [(TyVarTemplate, UniType)]
+ -> InstTemplate
+ -> (TypecheckedExpr, [Inst])
+
+instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys)
+ = (mkDictApp (mkTyApp (Var id) ty_args) ids, -- ToDo: not strictly a dict app
+ -- for Method inst_tys
+ insts)
+ where
+ ty_args = map (instantiateTy tenv) ty_tmpls
+ insts = mk_insts uniqs inst_tys
+ ids = map mkInstId insts
+
+ mk_insts us [] = []
+ mk_insts us (inst_ty : rest)
+ = case splitUniqSupply us of { (s1, s2) ->
+ let
+ uniq = getSUnique s1
+ in
+ (case inst_ty of
+ DictTy clas ty -> Dict uniq clas (instantiateTy tenv ty) orig
+ MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig
+ ) : mk_insts s2 rest
+ }
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[InstEnv-adding]{Adding new class instances}
+%* *
+%************************************************************************
+
+@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.
+
+Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from
+scratch here, rather than passing them in. This means a small amount
+of duplication (no big deal) and that we can't attach a single
+canonical unfolding; but they don't have a slot for unfoldings
+anyway... This could be improved. (We do, however, snaffle in the
+pragma info from the interface...)
+
+{\em Random notes}
+
+\begin{verbatim}
+class Foo a where
+ fop :: Ord b => a -> b -> b -> a
+
+instance Foo Int where
+ fop x y z = if y<z then x else fop x z y
+
+instance Foo a => Foo [a] where
+ fop [] y z = []
+ fop (x:xs) y z = [fop x y z]
+\end{verbatim}
+
+
+For the Int instance we add to the ??? envt
+\begin{verbatim}
+ (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b]
+\end{verbatim}
+
+If there are no type variables, @addClassInstance@ adds constant
+instances for those class ops not mentioned in the class-op details
+(possibly using the pragma info that was passed in). This MUST
+be the same decision as that by @tcInstDecls2@ about whether to
+generate constant methods. NB: A slightly more permissive version
+would base the decision on the context being empty, but there is
+slightly more admin associated and the benefits are very slight; the
+context is seldom empty unless there are no tyvars involved.
+
+Note: the way of specifying class-op instance details is INADEQUATE
+for polymorphic class ops. That just means you can't specify clever
+instances for them via this function.
+
+\begin{code}
+addClassInst
+ :: Class -- class in question (for err msg only)
+ -> ClassInstEnv -- Incoming envt
+ -> UniType -- The instance type
+ -> Id -- Dict fun id to apply
+ -> [TyVarTemplate] -- Types to which (after instantiation) to apply the dfun
+ -> ThetaType -- Dicts to which to apply the dfun
+ -> SrcLoc -- associated SrcLoc (for err msg only)
+ -> MaybeErr
+ ClassInstEnv -- Success
+ (Class, (UniType, SrcLoc), -- Failure: the overlapping pair
+ (UniType, SrcLoc))
+
+addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn
+ = case (insertMEnv matchTy inst_env inst_ty dict_template) of
+ Succeeded inst_env' -> Succeeded inst_env'
+ Failed (ty', MkInstTemplate id' _ _)
+ -> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id'))
+ where
+ dict_template = MkInstTemplate dfun_id
+ (map mkTyVarTemplateTy inst_tyvars)
+ (unzipWith DictTy dfun_theta)
+\end{code}
+
+============ NOT USED =============
+@addConstMethInst@ panics on overlap, because @addClassInst@ has already found
+any overlap.
+
+\begin{pseudocode}
+addConstMethInst :: IdInstEnv
+ -> UniType -- The instance type
+ -> Id -- The constant method
+ -> [TyVarTemplate] -- Apply method to these (as above)
+ -> IdInstEnv
+
+addConstMethInst inst_env inst_ty meth_id inst_tyvars
+ = case (insertMEnv matchTys inst_env [inst_ty] template) of
+ Succeeded inst_env' -> inst_env'
+ Failed (tys', MkInstTemplate id' _ _) ->
+ pprPanic "addConstMethInst:"
+ (ppSep [ppr PprDebug meth_id,
+ ppr PprDebug inst_ty,
+ ppr PprDebug id'])
+ where
+ template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) []
+ -- Constant method just needs to be applied to tyvars
+ -- (which are usually empty)
+\end{pseudocode}
+
+@mkIdInstEnv@ is useful in the simple case where we've a list of
+@(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of
+some other Id (in which the resulting IdInstEnv will doubtless be
+embedded. There's no messing about with type variables or
+dictionaries here.
+
+\begin{code}
+{- OLD:
+mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv
+
+mkIdInstEnv [] = nullMEnv
+mkIdInstEnv ((tys,id) : rest)
+ = let
+ inst_env = mkIdInstEnv rest
+ in
+ case (insertMEnv matchTys inst_env tys template) of
+ Succeeded inst_env' -> inst_env'
+ Failed _ -> panic "Failed in mkIdInstEnv"
+ where
+ template = MkInstTemplate id [] []
+-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[InstEnv-lookup]{Performing lookup}
+%* *
+%************************************************************************
+
+\begin{code}
+lookupInst :: SplitUniqSupply
+ -> Inst
+ -> Maybe (TypecheckedExpr,
+ [Inst])
+
+lookupInst uniqs (Dict _ clas ty orig)
+ = if isTyVarTy ty then
+ Nothing -- No instances of a class at a type variable
+ else
+ case (lookupMEnv matchTy inst_env ty) of
+ Nothing -> Nothing
+ Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ)
+ where
+ inst_env
+ = case orig of
+
+ -- During deriving and instance specialisation operations
+ -- we can't get the instances of the class from inside the
+ -- class, because the latter ain't ready yet. Instead we
+ -- find a mapping from classes to envts inside the dict origin.
+ -- (A Simon hack [WDP])
+
+ DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas)
+
+ InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas)
+
+ -- Usually we just get the instances of the class from
+ -- inside the class itself.
+
+ other -> getClassInstEnv clas
+
+lookupInst uniqs (Method _ id tys orig)
+ = if (all isTyVarTy tys) then
+ general_case -- Instance types are all type variables, so there can't be
+ -- a special instance for this method
+
+ else -- Get the inst env from the Id, and look up in it
+ case (lookupSpecEnv (getIdSpecialisation id) tys) of
+ Nothing -> general_case
+ Just (spec_id, types_left, num_dicts_to_toss)
+ -> Just (instMethod uniqs orig spec_id types_left)
+ where
+ general_case = Just (instMethod uniqs orig id tys)
+\end{code}
+
+Now "overloaded" literals: the plain truth is that the compiler
+is intimately familiar w/ the types Int, Integer, Float, and Double;
+for everything else, we actually conjure up an appropriately-applied
+fromInteger/fromRational, as the Haskell report suggests.
+
+\begin{code}
+lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig)
+ = Just (
+ case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms
+ Just (tycon, [], _)
+ | tycon == intPrimTyCon -> (intprim_lit, [])
+ | tycon == doublePrimTyCon -> (doubleprim_lit, [])
+ | tycon == intTyCon -> (int_lit, [])
+ | tycon == doubleTyCon -> (double_lit, [])
+ | tycon == floatTyCon -> (float_lit, [])
+-- | tycon == wordTyCon -> (word_lit, [])
+-- | tycon == addrTyCon -> (addr_lit, [])
+
+ _{-otherwise-} ->
+
+ if (i >= toInteger minInt && i <= toInteger maxInt) then
+ -- It's overloaded but small enough to fit into an Int
+
+ let u2 = getSUnique uniqs
+ method = Method u2 from_int [ty] orig
+ in
+ (App (Var (mkInstId method)) int_lit, [method])
+
+ else
+ -- Alas, it is overloaded and a big literal!
+
+ let u2 = getSUnique uniqs
+ method = Method u2 from_integer [ty] orig
+ in
+ (App (Var (mkInstId method)) (Lit (IntLit i)), [method])
+ )
+ where
+#if __GLASGOW_HASKELL__ <= 22
+ iD = ((fromInteger i) :: Double)
+#else
+ iD = ((fromInteger i) :: Rational)
+#endif
+ intprim_lit = Lit (IntPrimLit i)
+ doubleprim_lit = Lit (DoublePrimLit iD)
+ int_lit = App (Var intDataCon) intprim_lit
+ double_lit = App (Var doubleDataCon) doubleprim_lit
+ float_lit = App (Var floatDataCon) (Lit (FloatPrimLit iD))
+-- word_lit = App (Var wordDataCon) intprim_lit
+-- addr_lit = App (Var addrDataCon) intprim_lit
+
+lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig)
+ = Just (
+ case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms
+ Just (tycon, [], _)
+ | tycon == doublePrimTyCon -> (doubleprim_lit, [])
+ | tycon == doubleTyCon -> (double_lit, [])
+ | tycon == floatTyCon -> (float_lit, [])
+
+ _ {-otherwise-} -> -- gotta fromRational it...
+ --pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) (
+ let
+ u2 = getSUnique uniqs
+ method = Method u2 from_rational [ty] orig
+ in
+ (App (Var (mkInstId method)) (Lit (FracLit f)), [method])
+ --)
+ )
+ where
+#if __GLASGOW_HASKELL__ <= 22
+ fD = ((fromRational f) :: Double)
+#else
+ fD = f
+#endif
+ doubleprim_lit = Lit (DoublePrimLit fD)
+ double_lit = App (Var doubleDataCon) doubleprim_lit
+ float_lit = App (Var floatDataCon) (Lit (FloatPrimLit fD))
+\end{code}
+
+There is a second, simpler interface, when you want an instance
+of a class at a given nullary type constructor. It just returns
+the appropriate dictionary if it exists. It is used only when resolving
+ambiguous dictionaries.
+
+\begin{code}
+lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id
+
+lookupClassInstAtSimpleType clas ty
+ = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
+ Nothing -> Nothing
+ Just (_,_,MkInstTemplate dict [] []) -> Just dict
+\end{code}
+
+Notice in the above that the type constructors in the default list
+should all have arity zero, so there should be no type variables
+or thetas in the instance declaration.
+
+There's yet a third interface for Insts which need no binding.
+They are used to record constraints on type variables, notably
+for CCall arguments and results.
+
+\begin{code}
+lookupNoBindInst :: SplitUniqSupply
+ -> Inst
+ -> Maybe [Inst]
+
+lookupNoBindInst uniqs (Dict _ clas ty orig)
+ = if isTyVarTy ty then
+ Nothing -- No instances of a class at a type variable
+ else
+ case (lookupMEnv matchTy inst_env ty) of
+ Nothing -> Nothing
+ Just (_,tenv,templ) ->
+ case (instTemplate uniqs orig tenv templ) of
+ (bottom_rhs, insts)
+ -> Just insts
+ -- The idea here is that the expression built by
+ -- instTemplate isn't relevant; indeed, it might well
+ -- be a place-holder bottom value.
+ where
+ inst_env = getClassInstEnv clas
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[MatchEnv]{Matching environments}
+%* *
+%************************************************************************
+
+``Matching'' environments allow you to bind a template to a value;
+when you look up in it, you supply a value which is matched against
+the template.
+
+\begin{code}
+type MatchEnv key value = [(key, value)]
+\end{code}
+
+For now we just use association lists. The list is maintained sorted
+in order of {\em decreasing specificness} of @key@, so that the first
+match will be the most specific.
+
+\begin{code}
+nullMEnv :: MatchEnv a b
+nullMEnv = []
+
+mkMEnv :: [(key, value)] -> MatchEnv key value
+mkMEnv stuff = stuff
+\end{code}
+
+@lookupMEnv@ looks up in a @MatchEnv@.
+It
+simply takes the first match, should be the most specific.
+
+\begin{code}
+lookupMEnv :: (key {- template -} -> -- Matching function
+ key {- instance -} ->
+ Maybe match_info)
+ -> MatchEnv key value -- The envt
+ -> key -- Key
+ -> Maybe (key, -- Template
+ match_info, -- Match info returned by matching fn
+ value) -- Value
+
+lookupMEnv key_match alist key
+ = find alist
+ where
+ find [] = Nothing
+ find ((tpl, val) : rest)
+ = case key_match tpl key of
+ Nothing -> find rest
+ Just match_info -> Just (tpl, match_info, val)
+\end{code}
+
+@insertMEnv@ extends a match environment, checking for overlaps.
+
+\begin{code}
+insertMEnv :: (key {- template -} -> -- Matching function
+ key {- instance -} ->
+ Maybe match_info)
+ -> MatchEnv key value -- Envt
+ -> key -> value -- New item
+ -> MaybeErr (MatchEnv key value) -- Success...
+ (key, value) -- Failure: Offending overlap
+
+insertMEnv match_fn alist key value
+ = insert alist
+ where
+ -- insert has to put the new item in BEFORE any keys which are
+ -- LESS SPECIFIC than the new key, and AFTER any keys which are
+ -- MORE SPECIFIC The list is maintained in specific-ness order, so
+ -- we just stick it in either last, or just before the first key
+ -- of which the new key is an instance. We check for overlap at
+ -- that point.
+
+ insert [] = returnMaB [(key, value)]
+ insert ((t,v) : rest)
+ = case (match_fn t key) of
+ Nothing ->
+ -- New key is not an instance of this existing one, so
+ -- continue down the list.
+ insert rest `thenMaB` (\ rest' ->
+ returnMaB ((t,v):rest') )
+
+ Just match_info ->
+ -- New key *is* an instance of the old one, so check the
+ -- other way round in case of identity.
+
+ case (match_fn key t) of
+ Just _ -> failMaB (t,v)
+ -- Oops; overlap
+
+ Nothing -> returnMaB ((key,value):(t,v):rest)
+ -- All ok; insert here
+\end{code}
projects / ghc-hetmet.git / blobdiff