Fix recursive superclasses (again). Fixes Trac #4809.
[ghc-hetmet.git] / compiler / types / InstEnv.lhs
index 774808d..2d6a9eb 100644 (file)
@@ -15,7 +15,7 @@ module InstEnv (
 
        InstEnv, emptyInstEnv, extendInstEnv, 
        extendInstEnvList, lookupInstEnv, instEnvElts,
-       classInstances, 
+       classInstances, instanceBindFun,
        instanceCantMatch, roughMatchTcs
     ) where
 
@@ -45,7 +45,6 @@ import Data.Maybe     ( isJust, isNothing )
 %************************************************************************
 
 \begin{code}
-type DFunId = Id
 data Instance 
   = Instance { is_cls  :: Name         -- Class name
        
@@ -59,7 +58,7 @@ data Instance
                -- INVARIANT: is_dfun Id has type 
                --      forall is_tvs. (...) => is_cls is_tys
 
-            , is_dfun :: DFunId
+            , is_dfun :: DFunId -- See Note [Haddock assumptions]
             , is_flag :: OverlapFlag   -- See detailed comments with
                                        -- the decl of BasicTypes.OverlapFlag
     }
@@ -99,7 +98,20 @@ However, note that:
    (This is so that we can use the matching substitution to
     instantiate the dfun's context.)
 
+Note [Haddock assumptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+For normal user-written instances, Haddock relies on
 
+ * the SrcSpan of
+ * the Name of
+ * the is_dfun of
+ * an Instance
+
+being equal to
+
+  * the SrcSpan of
+  * the instance head type of
+  * the InstDecl used to construct the Instance.
 
 \begin{code}
 instanceDFunId :: Instance -> DFunId
@@ -116,7 +128,7 @@ setInstanceDFunId ispec dfun
        -- are ok; hence the assert
      ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
    where 
-     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
+     (tvs, _, tys) = tcSplitDFunTy (idType dfun)
 
 instanceRoughTcs :: Instance -> [Maybe Name]
 instanceRoughTcs = is_tcs
@@ -139,26 +151,37 @@ pprInstance ispec
 pprInstanceHdr :: Instance -> SDoc
 -- Prints the Instance as an instance declaration
 pprInstanceHdr ispec@(Instance { is_flag = flag })
-  = ptext (sLit "instance") <+> ppr flag
-    <+> sep [pprThetaArrow theta, pprClassPred clas tys]
+  = getPprStyle $ \ sty ->
+    let theta_to_print
+          | debugStyle sty = theta
+          | otherwise = drop (dfunNSilent dfun) theta
+    in ptext (sLit "instance") <+> ppr flag
+       <+> sep [pprThetaArrow theta_to_print, ppr res_ty]
   where
-    (_, theta, clas, tys) = instanceHead ispec
+    dfun = is_dfun ispec
+    (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
        -- 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))
+instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
+instanceHead ispec 
+   = (tvs, theta, cls, tys)
+   where
+     (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec))
+     (cls, tys) = tcSplitDFunHead tau
 
-mkLocalInstance :: DFunId -> OverlapFlag -> Instance
+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 = className cls, is_tcs = roughMatchTcs tys }
+                is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
-    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, cls, tys) = tcSplitDFunTy (idType dfun)
 
 mkImportedInstance :: Name -> [Maybe Name]
                   -> DFunId -> OverlapFlag -> Instance
@@ -169,7 +192,7 @@ mkImportedInstance cls mb_tcs dfun oflag
                is_tvs = mkVarSet tvs, is_tys = tys,
                is_cls = cls, is_tcs = mb_tcs }
   where
-    (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, tys) = tcSplitDFunTy (idType dfun)
 
 roughMatchTcs :: [Type] -> [Maybe Name]
 roughMatchTcs tys = map rough tys
@@ -337,6 +360,9 @@ data ClsInstEnv
                        --      If *not* then the common case of looking up
                        --      (C a b c) can fail immediately
 
+instance Outputable ClsInstEnv where
+  ppr (ClsIE is b) = ptext (sLit "ClsIE") <+> ppr b <+> pprInstances is
+
 -- INVARIANTS:
 --  * The is_tvs are distinct in each Instance
 --     of a ClsInstEnv (so we can safely unify them)
@@ -375,7 +401,7 @@ extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs })
 
 %************************************************************************
 %*                                                                     *
-\subsection{Looking up an instance}
+       Looking up an instance
 %*                                                                     *
 %************************************************************************
 
@@ -481,32 +507,11 @@ lookupInstEnv (pkg_ie, home_ie) cls 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
+        case tcUnifyTys instanceBindFun tpl_tys tys of
            Just _   -> find ms (item:us) rest
            Nothing  -> find ms us        rest
 
 ---------------
-bind_fn :: TyVar -> BindFlag
-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 :: InstMatch -> [InstMatch] -> [InstMatch]
 -- Add a new solution, knocking out strictly less specific ones
@@ -535,3 +540,40 @@ insert_overlapping new_item (item:items)
                        _         -> True
 \end{code}
 
+
+%************************************************************************
+%*                                                                     *
+       Binding decisions
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+instanceBindFun :: TyVar -> BindFlag
+instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem
+                   | otherwise                              = BindMe
+   -- Note [Binding when looking up instances]
+\end{code}
+
+Note [Binding when looking up instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When looking up in the instance environment, or family-instance environment,
+we are careful about multiple matches, as described above in 
+Note [Overlapping instances]
+
+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 isOverlappableTyVar 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'