Look through type synonyms when deciding if something is a type literal.
[ghc.git] / compiler / types / InstEnv.lhs
index 21e1acd..569697c 100644 (file)
@@ -10,8 +10,8 @@ The bits common to TcInstDcls and TcDeriv.
 module InstEnv (
         DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult,
         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, 
-        instanceHead, mkLocalInstance, mkImportedInstance,
-        instanceDFunId, setInstanceDFunId, instanceRoughTcs,
+        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
+        instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
 
         InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, 
         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
@@ -48,29 +48,47 @@ import Data.Maybe       ( isJust, isNothing )
 
 \begin{code}
 data ClsInst 
-  = ClsInst { is_cls  :: Name  -- Class name
-
-                -- Used for "rough matching"; see Note [Rough-match field]
+  = ClsInst {   -- Used for "rough matching"; see Note [Rough-match field]
                 -- INVARIANT: is_tcs = roughMatchTcs is_tys
+               is_cls_nm :: Name  -- Class name
              , is_tcs  :: [Maybe Name]  -- Top of type args
 
                 -- Used for "proper matching"; see Note [Proper-match fields]
-             , is_tvs  :: TyVarSet      -- Template tyvars for full match
-             , is_tys  :: [Type]        -- Full arg types
+             , is_tvs  :: [TyVar]       -- Fresh template tyvars for full match
+                                        -- See Note [Template tyvars are fresh]
+             , is_cls  :: Class         -- The real class
+             , is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)
                 -- INVARIANT: is_dfun Id has type 
                 --      forall is_tvs. (...) => is_cls is_tys
+                -- (modulo alpha conversion)
 
              , is_dfun :: DFunId -- See Note [Haddock assumptions]
+                    -- See Note [Silent superclass arguments] in TcInstDcls
+                    -- for how to map the DFun's type back to the source
+                    -- language instance decl
+
              , is_flag :: OverlapFlag   -- See detailed comments with
                                         -- the decl of BasicTypes.OverlapFlag
     }
   deriving (Data, Typeable)
 \end{code}
 
+Note [Template tyvars are fresh]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The is_tvs field of a ClsInst has *completely fresh* tyvars.  
+That is, they are
+  * distinct from any other ClsInst
+  * distinct from any tyvars free in predicates that may
+    be looked up in the class instance environment
+Reason for freshness: we use unification when checking for overlap
+etc, and that requires the tyvars to be distinct.
+
+The invariant is checked by the ASSERT in lookupInstEnv'.
+
 Note [Rough-match field]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The is_cls, is_tcs fields allow a "rough match" to be done
-without poking inside the DFunId.  Poking the DFunId forces
+The is_cls_nm, is_tcs 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
@@ -88,18 +106,17 @@ In is_tcs,
 
 Note [Proper-match fields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
-The is_tvs, is_tys fields are simply cached values, pulled
+The is_tvs, is_cls, is_tys fields are simply cached 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
+that we often never poke the 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.)
+ * is_tvs, is_tys may be alpha-renamed compared to the ones in
+   the dfun Id
 
 Note [Haddock assumptions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -120,19 +137,9 @@ being equal to
 instanceDFunId :: ClsInst -> DFunId
 instanceDFunId = is_dfun
 
-setInstanceDFunId :: ClsInst -> DFunId -> ClsInst
-setInstanceDFunId ispec dfun
-   = ASSERT2( idType dfun `eqType` idType (is_dfun ispec)
-            , ppr dfun $$ ppr (idType dfun) $$ ppr (is_dfun ispec) $$ ppr (idType (is_dfun ispec)) )
-        -- We need to create the cached fields afresh from
-        -- the new dfun id.  In particular, the is_tvs in
-        -- the ClsInst 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)
+tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
+tidyClsInstDFun tidy_dfun ispec
+  = ispec { is_dfun = tidy_dfun (is_dfun ispec) }
 
 instanceRoughTcs :: ClsInst -> [Maybe Name]
 instanceRoughTcs = is_tcs
@@ -155,40 +162,53 @@ pprInstance ispec
 pprInstanceHdr :: ClsInst -> SDoc
 -- Prints the ClsInst as an instance declaration
 pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
-  = ptext (sLit "instance") <+> ppr flag <+> pprSigmaType (idType dfun)
-        -- Print without the for-all, which the programmer doesn't write
+  = getPprStyle $ \ sty ->
+    let theta_to_print
+          | debugStyle sty = theta
+          | otherwise = drop (dfunNSilent dfun) theta
+          -- See Note [Silent superclass arguments] in TcInstDcls
+    in ptext (sLit "instance") <+> ppr flag
+       <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
+  where
+    (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
+       -- Print without the for-all, which the programmer doesn't write
 
 pprInstances :: [ClsInst] -> SDoc
 pprInstances ispecs = vcat (map pprInstance ispecs)
 
-instanceHead :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
-instanceHead ispec = (tvs, theta, cls, tys)
+instanceHead :: ClsInst -> ([TyVar], Class, [Type])
+-- Returns the head, using the fresh tyavs from the ClsInst
+instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun })
+   = (tvs, cls, tys)
    where
-     (tvs, theta, tau) = tcSplitSigmaTy (idType dfun)
-     (cls, tys)        = tcSplitDFunHead tau
-     dfun              = is_dfun ispec
+     (_, _, cls, _) = tcSplitDFunTy (idType dfun)
 
-mkLocalInstance :: DFunId
-                -> OverlapFlag
+instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])
+-- Decomposes the DFunId
+instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
+
+mkLocalInstance :: DFunId -> OverlapFlag
+                -> [TyVar] -> Class -> [Type]
                 -> ClsInst
 -- Used for local instances, where we can safely pull on the DFunId
-mkLocalInstance dfun oflag
-  = ClsInst {  is_flag = oflag, is_dfun = dfun,
-                is_tvs = mkVarSet tvs, is_tys = tys,
-                is_cls = className cls, is_tcs = roughMatchTcs tys }
-  where
-    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
+mkLocalInstance dfun oflag tvs cls tys
+  = ClsInst { is_flag = oflag, is_dfun = dfun
+            , is_tvs = tvs
+            , is_cls = cls, is_cls_nm = className cls
+            , is_tys = tys, is_tcs = roughMatchTcs tys }
 
 mkImportedInstance :: Name -> [Maybe Name]
                    -> DFunId -> OverlapFlag -> ClsInst
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
-mkImportedInstance cls mb_tcs dfun oflag
-  = ClsInst {  is_flag = oflag, is_dfun = dfun,
-                is_tvs = mkVarSet tvs, is_tys = tys,
-                is_cls = cls, is_tcs = mb_tcs }
+-- The bound tyvars of the dfun are guaranteed fresh, because
+-- the dfun has been typechecked out of the same interface file
+mkImportedInstance cls_nm mb_tcs dfun oflag
+  = ClsInst { is_flag = oflag, is_dfun = dfun
+            , is_tvs = tvs, is_tys = tys
+            , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs }
   where
-    (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
 roughMatchTcs :: [Type] -> [Maybe Name]
 roughMatchTcs tys = map rough tys
@@ -383,30 +403,28 @@ extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
 extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
 
 extendInstEnv :: InstEnv -> ClsInst -> InstEnv
-extendInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm })
+extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
   where
     add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)
 
 overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv
-overwriteInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm, is_tys = tys })
+overwriteInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm, is_tys = tys })
   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
   where
     add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts)
     
     rough_tcs  = roughMatchTcs tys
     replaceInst [] = [ins_item]
-    replaceInst (item@(ClsInst { is_tcs = mb_tcs,  is_tvs = tpl_tvs, 
-                                  is_tys = tpl_tys,
-                                  is_dfun = dfun }) : rest)
+    replaceInst (item@(ClsInst { is_tcs = mb_tcs,  is_tvs = tpl_tvs 
+                               , is_tys = tpl_tys }) : rest)
     -- Fast check for no match, uses the "rough match" fields
       | instanceCantMatch rough_tcs mb_tcs
       = item : replaceInst rest
 
-      | Just _ <- tcMatchTys tpl_tvs tpl_tys tys
-      = let (dfun_tvs, _) = tcSplitForAllTys (idType dfun)
-        in ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs )        -- Check invariant
-           ins_item : rest
+      | let tpl_tv_set = mkVarSet tpl_tvs
+      , Just _ <- tcMatchTys tpl_tv_set tpl_tys tys
+      = ins_item : rest
 
       | otherwise
       = item : replaceInst rest
@@ -440,7 +458,7 @@ type ClsInstLookupResult
 
 Note [DFunInstType: instantiating types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A successful match is an ClsInst, together with the types at which
+A successful match is a ClsInst, together with the types at which
         the dfun_id in the ClsInst should be instantiated
 The instantiating types are (Either TyVar Type)s because the dfun
 might have some tyvars that *only* appear in arguments
@@ -496,19 +514,14 @@ lookupInstEnv' ie cls tys
 
     --------------
     find ms us [] = (ms, us)
-    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs, 
-                                 is_tys = tpl_tys, is_flag = oflag,
-                                 is_dfun = dfun }) : rest)
+    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs
+                              , is_tys = tpl_tys, is_flag = oflag }) : 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
-      = let 
-            (dfun_tvs, _) = tcSplitForAllTys (idType dfun)
-        in 
-        ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs )   -- Check invariant
-        find ((item, map (lookup_tv subst) dfun_tvs) : ms) us rest
+      | Just subst <- tcMatchTys tpl_tv_set tpl_tys tys
+      = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest
 
         -- Does not match, so next check whether the things unify
         -- See Note [Overlapping instances] above
@@ -516,15 +529,18 @@ lookupInstEnv' ie cls tys
       = find ms us rest
 
       | otherwise
-      = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
+      = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tv_set,
                  (ppr cls <+> ppr tys <+> ppr all_tvs) $$
-                 (ppr dfun <+> ppr tpl_tvs <+> ppr tpl_tys)
+                 (ppr tpl_tvs <+> ppr tpl_tys)
                 )
                 -- Unification will break badly if the variables overlap
                 -- They shouldn't because we allocate separate uniques for them
+                -- See Note [Template tyvars are fresh]
         case tcUnifyTys instanceBindFun tpl_tys tys of
             Just _   -> find ms (item:us) rest
             Nothing  -> find ms us        rest
+      where
+        tpl_tv_set = mkVarSet tpl_tvs
 
     ----------------
     lookup_tv :: TvSubst -> TyVar -> DFunInstType
@@ -604,7 +620,7 @@ insert_overlapping new_item (item:items)
 
     (instA, _) `beats` (instB, _)
           = overlap_ok && 
-            isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
+            isJust (tcMatchTys (mkVarSet (is_tvs instB)) (is_tys instB) (is_tys instA))
                     -- A beats B if A is more specific than B,
                     -- (ie. if B can be instantiated to match A)
                     -- and overlap is permitted