path: root/ghc/compiler/envs/InstEnv.lhs

%
% (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,
	mkInstSpecEnv,

	MatchEnv(..),	-- mk more abstract (??? ToDo)
	nullMEnv,
--	mkMEnv, lookupMEnv, matchMEnv, 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, SpecEnv
    ) 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

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}

\begin{code}
mkInstSpecEnv :: Class			-- class
	      -> UniType		-- instance type
	      -> [TyVarTemplate]	-- instance tyvars
	      -> ThetaType		-- superclasses dicts
	      -> SpecEnv		-- specenv for dfun of instance

mkInstSpecEnv clas inst_ty inst_tvs inst_theta
  = mkSpecEnv (catMaybes (map maybe_spec_info matches))
  where
    matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty

    maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
      = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
    maybe_spec_info (_, match_info, _)
      = Nothing

\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}

@matchEnv@ returns all more specidfic matches in a @MatchEnv@,
most specific first.

\begin{code}
matchMEnv :: (key {- template -} ->	-- Matching function
	      key {- instance -} ->
	      Maybe match_info)
	  -> MatchEnv key value		-- The envt
	  -> key			-- Key
	  -> [(key,
	       match_info,		-- Match info returned by matching fn
	       value)]			-- Value

matchMEnv key_match alist key
  = match alist
  where
    match [] = []
    match ((tpl, val) : rest)
      = case key_match tpl key of
	  Nothing -> case key_match key tpl of
		       Nothing         -> match rest
		       Just match_info -> (tpl, match_info, val) : match rest 
	  Just _  -> []
\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}