[ghc-hetmet.git] / ghc / compiler / types / InstEnv.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[InstEnv]{Utilities for typechecking instance declarations}

The bits common to TcInstDcls and TcDeriv.

\begin{code}
module InstEnv (
        DFunId, OverlapFlag(..),
        Instance(..), pprInstance, pprInstances, 
        instanceHead, mkLocalInstance, mkImportedInstance,
        instanceDFunId, setInstanceDFunId, instanceRoughTcs,

        InstEnv, emptyInstEnv, extendInstEnv, 
        extendInstEnvList, lookupInstEnv, instEnvElts,
        classInstances, 
        instanceCantMatch, roughMatchTcs
    ) where

#include "HsVersions.h"

import Class            ( Class )
import Var              ( Id, TyVar, isTcTyVar )
import VarSet
import Name             ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom, nameModule )
import OccName          ( OccName )
import NameSet          ( unionNameSets, unitNameSet, nameSetToList )
import Type             ( TvSubst )
import TcType           ( Type, PredType, tcEqType,
                          tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar,
                          pprThetaArrow, pprClassPred,
                          tyClsNamesOfType, tcSplitTyConApp_maybe
                        )
import TyCon            ( tyConName )
import Unify            ( tcMatchTys, tcUnifyTys, BindFlag(..) )
import Outputable
import UniqFM           ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
import Id               ( idType, idName )
import SrcLoc           ( pprDefnLoc )
import Maybe            ( isJust, isNothing )
\end{code}


%************************************************************************
%*                                                                      *
\subsection{The key types}
%*                                                                      *
%************************************************************************

\begin{code}
type DFunId = Id
data Instance 
  = Instance { is_cls  :: Name          -- Class name
        
                -- Used for "rough matching"; see note below
             , is_tcs  :: [Maybe Name]  -- Top of type args

                -- Used for "proper matching"; see note
             , is_tvs  :: TyVarSet      -- Template tyvars for full match
             , is_tys  :: [Type]        -- Full arg types

             , is_dfun :: DFunId
             , is_flag :: OverlapFlag

             , is_orph :: Maybe OccName }

-- The "rough-match" fields
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- The is_cls, is_args fields allow a "rough match" to be done
-- without poking inside the DFunId.  Poking the DFunId forces
-- us to suck in all the type constructors etc it involves,
-- which is a total waste of time if it has no chance of matching
-- So the Name, [Maybe Name] fields allow us to say "definitely
-- does not match", based only on the Name.
--
-- In is_tcs, 
--     Nothing  means that this type arg is a type variable
--
--     (Just n) means that this type arg is a
--              TyConApp with a type constructor of n.
--              This is always a real tycon, never a synonym!
--              (Two different synonyms might match, but two
--              different real tycons can't.)
--              NB: newtypes are not transparent, though!
--
-- The "proper-match" fields
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- The is_tvs, is_tys fields are simply cahced values, pulled
-- out (lazily) from the dfun id. They are cached here simply so 
-- that we don't need to decompose the DFunId each time we want 
-- to match it.  The hope is that the fast-match fields mean
-- that we often never poke th proper-match fields
--
-- However, note that:
--  * is_tvs must be a superset of the free vars of is_tys
--
--  * The is_dfun must itself be quantified over exactly is_tvs
--    (This is so that we can use the matching substitution to
--     instantiate the dfun's context.)
--
-- The "orphan" field
-- ~~~~~~~~~~~~~~~~~~
-- An instance is an orphan if its head (after the =>) mentions
-- nothing defined in this module.  
--
--    Just n    The head mentions n, which is defined in this module
--              This is used for versioning; the instance decl is
--              considered part of the defn of n when computing versions
--
--    Nothing   The head mentions nothing defined in this modle
--
-- If a module contains any orphans, then its interface file is read 
-- regardless, so that its instances are not missed. 
-- 
-- Functional dependencies worsen the situation a bit. Consider
--      class C a b | a -> b
-- In some other module we might have
--    module M where
--      data T = ...
--      instance C Int T where ...
-- This isn't considered an orphan, so we will only read M's interface
-- if something from M is used (e.g. T).  So there's a risk we'll
-- miss the improvement from the instance.  Workaround: import M.

instanceDFunId :: Instance -> DFunId
instanceDFunId = is_dfun

setInstanceDFunId :: Instance -> DFunId -> Instance
setInstanceDFunId ispec dfun
   = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) )
        -- We need to create the cached fields afresh from
        -- the new dfun id.  In particular, the is_tvs in
        -- the Instance must match those in the dfun!
        -- We assume that the only thing that changes is
        -- the quantified type variables, so the other fields
        -- are ok; hence the assert
     ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
   where 
     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)

instanceRoughTcs :: Instance -> [Maybe Name]
instanceRoughTcs = is_tcs
\end{code}

\begin{code}
instance NamedThing Instance where
   getName ispec = getName (is_dfun ispec)

instance Outputable Instance where
   ppr = pprInstance

pprInstance :: Instance -> SDoc
-- Prints the Instance as an instance declaration
pprInstance ispec@(Instance { is_flag = flag })
  = hang (ptext SLIT("instance") <+> ppr flag
          <+> sep [pprThetaArrow theta, pprClassPred clas tys])
        2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc ispec)))
  where
    (_, theta, clas, tys) = instanceHead ispec
        -- Print without the for-all, which the programmer doesn't write

pprInstances :: [Instance] -> SDoc
pprInstances ispecs = vcat (map pprInstance ispecs)

instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type])
instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec))

mkLocalInstance :: DFunId -> OverlapFlag -> Instance
-- Used for local instances, where we can safely pull on the DFunId
mkLocalInstance dfun oflag
  = Instance {  is_flag = oflag, is_dfun = dfun,
                is_tvs = mkVarSet tvs, is_tys = tys,
                is_cls = cls_name, is_tcs = roughMatchTcs tys,
                is_orph = orph }
  where
    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
    mod = nameModule (idName dfun)
    cls_name = getName cls
    tycl_names = foldr (unionNameSets . tyClsNamesOfType) 
                       (unitNameSet cls_name) tys
    orph = case filter (nameIsLocalOrFrom mod) (nameSetToList tycl_names) of
                []     -> Nothing
                (n:ns) -> Just (getOccName n)

mkImportedInstance :: Name -> [Maybe Name] -> Maybe OccName
                   -> DFunId -> OverlapFlag -> Instance
-- Used for imported instances, where we get the rough-match stuff
-- from the interface file
mkImportedInstance cls mb_tcs orph dfun oflag
  = Instance {  is_flag = oflag, is_dfun = dfun,
                is_tvs = mkVarSet tvs, is_tys = tys,
                is_cls = cls, is_tcs = mb_tcs, is_orph = orph }
  where
    (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)

roughMatchTcs :: [Type] -> [Maybe Name]
roughMatchTcs tys = map rough tys
  where
    rough ty = case tcSplitTyConApp_maybe ty of
                  Just (tc,_) -> Just (tyConName tc)
                  Nothing     -> Nothing

instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
-- possibly be instantiated to actual, nor vice versa; 
-- False is non-committal
instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as
instanceCantMatch ts            as            =  False  -- Safe

---------------------------------------------------
data OverlapFlag
  = NoOverlap   -- This instance must not overlap another

  | OverlapOk   -- Silently ignore this instance if you find a 
                -- more specific one that matches the constraint
                -- you are trying to resolve
                --
                -- Example: constraint (Foo [Int])
                --          instances  (Foo [Int])
                --                     (Foo [a])        OverlapOk
                -- Since the second instance has the OverlapOk flag,
                -- the first instance will be chosen (otherwise 
                -- its ambiguous which to choose)

  | Incoherent  -- Like OverlapOk, but also ignore this instance 
                -- if it doesn't match the constraint you are
                -- trying to resolve, but could match if the type variables
                -- in the constraint were instantiated
                --
                -- Example: constraint (Foo [b])
                --          instances  (Foo [Int])      Incoherent
                --                     (Foo [a])
                -- Without the Incoherent flag, we'd complain that
                -- instantiating 'b' would change which instance 
                -- was chosen

instance Outputable OverlapFlag where
   ppr NoOverlap  = empty
   ppr OverlapOk  = ptext SLIT("[overlap ok]")
   ppr Incoherent = ptext SLIT("[incoherent]")
\end{code}


Note [Overlapping instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Overlap is permitted, but only in such a way that one can make
a unique choice when looking up.  That is, overlap is only permitted if
one template matches the other, or vice versa.  So this is ok:

  [a]  [Int]

but this is not

  (Int,a)  (b,Int)

If overlap is permitted, the list is kept most specific first, so that
the first lookup is the right choice.


For now we just use association lists.

\subsection{Avoiding a problem with overlapping}

Consider this little program:

\begin{pseudocode}
     class C a        where c :: a
     class C a => D a where d :: a

     instance C Int where c = 17
     instance D Int where d = 13

     instance C a => C [a] where c = [c]
     instance ({- C [a], -} D a) => D [a] where d = c

     instance C [Int] where c = [37]

     main = print (d :: [Int])
\end{pseudocode}

What do you think `main' prints  (assuming we have overlapping instances, and
all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
the `C [Int]' instance is more specific).

Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
doesn't even compile!  What's going on!?

What hugs complains about is the `D [a]' instance decl.

\begin{pseudocode}
     ERROR "mj.hs" (line 10): Cannot build superclass instance
     *** Instance            : D [a]
     *** Context supplied    : D a
     *** Required superclass : C [a]
\end{pseudocode}

You might wonder what hugs is complaining about.  It's saying that you
need to add `C [a]' to the context of the `D [a]' instance (as appears
in comments).  But there's that `C [a]' instance decl one line above
that says that I can reduce the need for a `C [a]' instance to the
need for a `C a' instance, and in this case, I already have the
necessary `C a' instance (since we have `D a' explicitly in the
context, and `C' is a superclass of `D').

Unfortunately, the above reasoning indicates a premature commitment to the
generic `C [a]' instance.  I.e., it prematurely rules out the more specific
instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
add the context that hugs suggests (uncomment the `C [a]'), effectively
deferring the decision about which instance to use.

Now, interestingly enough, 4.04 has this same bug, but it's covered up
in this case by a little known `optimization' that was disabled in
4.06.  Ghc-4.04 silently inserts any missing superclass context into
an instance declaration.  In this case, it silently inserts the `C
[a]', and everything happens to work out.

(See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
`Mark Jones', although Mark claims no credit for the `optimization' in
question, and would rather it stopped being called the `Mark Jones
optimization' ;-)

So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
something else out with ghc-4.04.  Let's add the following line:

    d' :: D a => [a]
    d' = c

Everyone raise their hand who thinks that `d :: [Int]' should give a
different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
`optimization' only applies to instance decls, not to regular
bindings, giving inconsistent behavior.

Old hugs had this same bug.  Here's how we fixed it: like GHC, the
list of instances for a given class is ordered, so that more specific
instances come before more generic ones.  For example, the instance
list for C might contain:
    ..., C Int, ..., C a, ...  
When we go to look for a `C Int' instance we'll get that one first.
But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
pass the `C Int' instance, and keep going.  But if `b' is
unconstrained, then we don't know yet if the more specific instance
will eventually apply.  GHC keeps going, and matches on the generic `C
a'.  The fix is to, at each step, check to see if there's a reverse
match, and if so, abort the search.  This prevents hugs from
prematurely chosing a generic instance when a more specific one
exists.

--Jeff

BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
this test.  Suppose the instance envt had
    ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
(still most specific first)
Now suppose we are looking for (C x y Int), where x and y are unconstrained.
        C x y Int  doesn't match the template {a,b} C a a b
but neither does 
        C a a b  match the template {x,y} C x y Int
But still x and y might subsequently be unified so they *do* match.

Simple story: unify, don't match.


%************************************************************************
%*                                                                      *
                InstEnv, ClsInstEnv
%*                                                                      *
%************************************************************************

A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a
ClsInstEnv mapping is the dfun for that instance.

If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then

        forall a b, C t1 t2 t3  can be constructed by dfun

or, to put it another way, we have

        instance (...) => C t1 t2 t3,  witnessed by dfun

\begin{code}
---------------------------------------------------
type InstEnv = UniqFM ClsInstEnv        -- Maps Class to instances for that class

data ClsInstEnv 
  = ClsIE [Instance]    -- The instances for a particular class, in any order
          Bool          -- True <=> there is an instance of form C a b c
                        --      If *not* then the common case of looking up
                        --      (C a b c) can fail immediately

-- INVARIANTS:
--  * The is_tvs are distinct in each Instance
--      of a ClsInstEnv (so we can safely unify them)

-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
--      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
-- The "a" in the pattern must be one of the forall'd variables in
-- the dfun type.

emptyInstEnv :: InstEnv
emptyInstEnv = emptyUFM

instEnvElts :: InstEnv -> [Instance]
instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts]

classInstances :: (InstEnv,InstEnv) -> Class -> [Instance]
classInstances (pkg_ie, home_ie) cls 
  = get home_ie ++ get pkg_ie
  where
    get env = case lookupUFM env cls of
                Just (ClsIE insts _) -> insts
                Nothing              -> []

extendInstEnvList :: InstEnv -> [Instance] -> InstEnv
extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs

extendInstEnv :: InstEnv -> Instance -> InstEnv
extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs })
  = addToUFM_C add inst_env cls_nm (ClsIE [ins_item] ins_tyvar)
  where
    add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts)
                                              (ins_tyvar || cur_tyvar)
    ins_tyvar = not (any isJust mb_tcs)
\end{code}                    


%************************************************************************
%*                                                                      *
\subsection{Looking up an instance}
%*                                                                      *
%************************************************************************

@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
the env is kept ordered, the first match must be the only one.  The
thing we are looking up can have an arbitrary "flexi" part.

\begin{code}
lookupInstEnv :: (InstEnv       -- External package inst-env
                 ,InstEnv)      -- Home-package inst-env
              -> Class -> [Type]                -- What we are looking for
              -> ([(TvSubst, Instance)],        -- Successful matches
                  [Instance])                   -- These don't match but do unify
        -- The second component of the tuple happens when we look up
        --      Foo [a]
        -- in an InstEnv that has entries for
        --      Foo [Int]
        --      Foo [b]
        -- Then which we choose would depend on the way in which 'a'
        -- is instantiated.  So we report that Foo [b] is a match (mapping b->a)
        -- but Foo [Int] is a unifier.  This gives the caller a better chance of
        -- giving a suitable error messagen

lookupInstEnv (pkg_ie, home_ie) cls tys
  = (pruned_matches, all_unifs)
  where
    rough_tcs  = roughMatchTcs tys
    all_tvs    = all isNothing rough_tcs
    (home_matches, home_unifs) = lookup home_ie 
    (pkg_matches,  pkg_unifs)  = lookup pkg_ie  
    all_matches = home_matches ++ pkg_matches
    all_unifs   = home_unifs   ++ pkg_unifs
    pruned_matches 
        | null all_unifs = foldr insert_overlapping [] all_matches
        | otherwise      = all_matches  -- Non-empty unifs is always an error situation,
                                        -- so don't attempt to pune the matches

    --------------
    lookup env = case lookupUFM env cls of
                   Nothing -> ([],[])   -- No instances for this class
                   Just (ClsIE insts has_tv_insts)
                        | all_tvs && not has_tv_insts
                        -> ([],[])      -- Short cut for common case
                        -- The thing we are looking up is of form (C a b c), and
                        -- the ClsIE has no instances of that form, so don't bother to search
        
                        | otherwise
                        -> find [] [] insts

    --------------
    find ms us [] = (ms, us)
    find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, 
                                 is_tys = tpl_tys, is_flag = oflag,
                                 is_dfun = dfun }) : rest)
        -- Fast check for no match, uses the "rough match" fields
      | instanceCantMatch rough_tcs mb_tcs
      = find ms us rest

      | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
      = find ((subst,item):ms) us rest

        -- Does not match, so next check whether the things unify
        -- See Note [overlapping instances] above
      | Incoherent <- oflag
      = find ms us rest

      | otherwise
      = ASSERT2( not (tyVarsOfTypes tys `intersectsVarSet` tpl_tvs),
                       (ppr cls <+> ppr tys <+> ppr all_tvs) $$
                       (ppr dfun <+> ppr tpl_tvs <+> ppr tpl_tys)
                )
                -- Unification will break badly if the variables overlap
                -- They shouldn't because we allocate separate uniques for them
        case tcUnifyTys bind_fn tpl_tys tys of
            Just _   -> find ms (item:us) rest
            Nothing  -> find ms us         rest

---------------
bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
           | otherwise                             = BindMe
        -- The key_tys can contain skolem constants, and we can guarantee that those
        -- are never going to be instantiated to anything, so we should not involve
        -- them in the unification test.  Example:
        --      class Foo a where { op :: a -> Int }
        --      instance Foo a => Foo [a]       -- NB overlap
        --      instance Foo [Int]              -- NB overlap
        --      data T = forall a. Foo a => MkT a
        --      f :: T -> Int
        --      f (MkT x) = op [x,x]
        -- The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd
        -- complain, saying that the choice of instance depended on the instantiation
        -- of 'a'; but of course it isn't *going* to be instantiated.
        --
        -- We do this only for pattern-bound skolems.  For example we reject
        --      g :: forall a => [a] -> Int
        --      g x = op x
        -- on the grounds that the correct instance depends on the instantiation of 'a'

---------------
insert_overlapping :: (TvSubst, Instance) -> [(TvSubst, Instance)] 
                   -> [(TvSubst, Instance)]
-- Add a new solution, knocking out strictly less specific ones
insert_overlapping new_item [] = [new_item]
insert_overlapping new_item (item:items)
  | new_beats_old && old_beats_new = item : insert_overlapping new_item items
        -- Duplicate => keep both for error report
  | new_beats_old = insert_overlapping new_item items
        -- Keep new one
  | old_beats_new = item : items
        -- Keep old one
  | otherwise     = item : insert_overlapping new_item items
        -- Keep both
  where
    new_beats_old = new_item `beats` item
    old_beats_new = item `beats` new_item

    (_, instA) `beats` (_, instB)
        = overlap_ok && 
          isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
                -- A beats B if A is more specific than B, and B admits overlap
                -- I.e. if B can be instantiated to match A
        where
          overlap_ok = case is_flag instB of
                        NoOverlap -> False
                        other     -> True
\end{code}