[project @ 1996-07-25 20:43:49 by partain]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcInstDcls.lhs
index 0f1a61a..5194f9e 100644 (file)
@@ -13,53 +13,55 @@ module TcInstDcls (
     ) where
 
 
-import Ubiq
+IMP_Ubiq()
 
 import HsSyn           ( InstDecl(..), FixityDecl, Sig(..),
                          SpecInstSig(..), HsBinds(..), Bind(..),
                          MonoBinds(..), GRHSsAndBinds, Match, 
                          InPat(..), OutPat(..), HsExpr(..), HsLit(..),
-                         Stmt, Qual, ArithSeqInfo, Fake,
+                         Stmt, Qualifier, ArithSeqInfo, Fake,
                          PolyType(..), MonoType )
-import RnHsSyn         ( RenamedHsBinds(..), RenamedMonoBinds(..),
+import RnHsSyn         ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
                          RenamedInstDecl(..), RenamedFixityDecl(..),
                          RenamedSig(..), RenamedSpecInstSig(..),
                          RnName(..){-incl instance Outputable-}
                        )
-import TcHsSyn         ( TcIdOcc(..), TcHsBinds(..),
-                         TcMonoBinds(..), TcExpr(..), tcIdType,
+import TcHsSyn         ( TcIdOcc(..), SYN_IE(TcHsBinds),
+                         SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
                          mkHsTyLam, mkHsTyApp,
                          mkHsDictLam, mkHsDictApp )
 
 
 import TcMonad         hiding ( rnMtoTcM )
 import GenSpecEtc      ( checkSigTyVars )
-import Inst            ( Inst, InstOrigin(..), InstanceMapper(..),
-                         newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import Inst            ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
+                         newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
 import TcBinds         ( tcPragmaSigs )
 import TcDeriv         ( tcDeriving )
-import TcEnv           ( tcLookupClass, tcTyVarScope, newLocalId )
+import TcEnv           ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import SpecEnv         ( SpecEnv )
 import TcGRHSs         ( tcGRHSsAndBinds )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcKind          ( TcKind, unifyKind )
 import TcMatches       ( tcMatchesFun )
 import TcMonoType      ( tcContext, tcMonoTypeKind )
-import TcSimplify      ( tcSimplifyAndCheck, tcSimplifyThetas )
-import TcType          ( TcType(..), TcTyVar(..),
-                         tcInstSigTyVars, tcInstType, tcInstTheta
+import TcSimplify      ( tcSimplifyAndCheck )
+import TcType          ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), 
+                         tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
                        )
-import Unify           ( unifyTauTy )
+import Unify           ( unifyTauTy, unifyTauTyLists )
 
 
 import Bag             ( emptyBag, unitBag, unionBags, unionManyBags,
                          concatBag, foldBag, bagToList )
-import CmdLineOpts     ( opt_GlasgowExts, opt_CompilingPrelude,
+import CmdLineOpts     ( opt_GlasgowExts, opt_CompilingGhcInternals,
                          opt_OmitDefaultInstanceMethods,
-                         opt_SpecialiseOverloaded )
+                         opt_SpecialiseOverloaded
+                       )
 import Class           ( GenClass, GenClassOp, 
                          isCcallishClass, classBigSig,
                          classOps, classOpLocalType,
-                         classOpTagByString
+                         classOpTagByString_maybe
                          )
 import Id              ( GenId, idType, isDefaultMethodId_maybe )
 import ListSetOps      ( minusList )
@@ -72,13 +74,13 @@ import PprType              ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
                        )
 import PprStyle
 import Pretty
-import RnUtils         ( RnEnv(..) )
+import RnUtils         ( SYN_IE(RnEnv) )
 import TyCon           ( isSynTyCon, derivedFor )
-import Type            ( GenType(..),  ThetaType(..), mkTyVarTys,
+import Type            ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
                          splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
-                         getTyCon_maybe, maybeBoxedPrimType
+                         getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
                        )
-import TyVar           ( GenTyVar, mkTyVarSet )
+import TyVar           ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique )
 import Util            ( zipEqual, panic )
@@ -231,8 +233,7 @@ tcInstDecl1 mod_name
     if (not from_here && (clas `derivedFor` inst_tycon)
                      && all isTyVarTy arg_tys)
     then
-       if not opt_CompilingPrelude && maybeToBool inst_mod &&
-          mod_name == expectJust "inst_mod" inst_mod
+       if mod_name == inst_mod
        then
                -- Imported instance came from this module;
                -- discard and derive fresh instance
@@ -368,7 +369,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
     let
        sc_theta'        = super_classes `zip` repeat inst_ty'
        origin           = InstanceDeclOrigin
-       mk_method sel_id = newMethodId sel_id inst_ty' origin locn
+       mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
     in
         -- Create dictionary Ids from the specified instance contexts.
     newDicts origin sc_theta'          `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
@@ -381,6 +382,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 
         -- Collect available Insts
     let
+       inst_tyvars_set' = mkTyVarSet inst_tyvars'
+
        avail_insts      -- These insts are in scope; quite a few, eh?
          = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) 
 
@@ -390,8 +393,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
            else
                makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id 
     in
-    processInstBinds clas mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
-                                               `thenTc` \ (insts_needed, method_mbinds) ->
+    tcExtendGlobalTyVars inst_tyvars_set' (
+       processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
+    )                                  `thenTc` \ (insts_needed, method_mbinds) ->
     let
        -- Create the dict and method binds
        dict_bind
@@ -400,7 +404,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
        dict_and_method_binds
            = dict_bind `AndMonoBinds` method_mbinds
 
-       inst_tyvars_set' = mkTyVarSet inst_tyvars'
     in
        -- Check the overloading constraints of the methods and superclasses
     tcAddErrCtxt (bindSigCtxt meth_ids) (
@@ -447,54 +450,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 \end{code}
 
-@mkMethodId@ manufactures an id for a local method.
-It's rather turgid stuff, because there are two cases:
-
-  (a) For methods with no local polymorphism, we can make an Inst of the 
-      class-op selector function and a corresp InstId; 
-      which is good because then other methods which call
-      this one will do so directly.
-
-  (b) For methods with local polymorphism, we can't do this.  For example,
-
-        class Foo a where
-               op :: (Num b) => a -> b -> a
-
-      Here the type of the class-op-selector is
-
-       forall a b. (Foo a, Num b) => a -> b -> a
-
-      The locally defined method at (say) type Float will have type
-
-       forall b. (Num b) => Float -> b -> Float
-
-      and the one is not an instance of the other.
-
-      So for these we just make a local (non-Inst) id with a suitable type.
-
-How disgusting.
-
-\begin{code}
-newMethodId sel_id inst_ty origin loc
-  = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
-       (_:meth_theta) = sel_theta      -- The local theta is all except the
-                                       -- first element of the context
-    in 
-       case sel_tyvars of
-       -- Ah! a selector for a class op with no local polymorphism
-       -- Build an Inst for this
-       [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty]
-
-       -- Ho! a selector for a class op with local polymorphism.
-       -- Just make a suitably typed local id for this
-       (clas_tyvar:local_tyvars) -> 
-               tcInstType [(clas_tyvar,inst_ty)]
-                          (mkSigmaTy local_tyvars meth_theta sel_tau)
-                                                               `thenNF_Tc` \ method_ty ->
-               newLocalId (getLocalName sel_id) method_ty      `thenNF_Tc` \ meth_id ->
-               returnNF_Tc (emptyLIE, meth_id)
-\end{code}
-
 The next function makes a default method which calls the global default method, at
 the appropriate instance type.
 
@@ -511,22 +466,13 @@ makeInstanceDeclDefaultMethodExpr
        -> NF_TcM s (TcExpr s)
 
 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
-  = newDicts origin op_theta           `thenNF_Tc` \ (op_lie,op_dicts) ->
-
-       -- def_op_id = /\ op_tyvars -> \ op_dicts ->
-       --                defm_id inst_ty op_tyvars this_dict op_dicts
-    returnNF_Tc (
-      mkHsTyLam op_tyvars (
-      mkHsDictLam op_dicts (
-      mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
-                            (inst_ty :  mkTyVarTys op_tyvars))
-                 (this_dict : op_dicts)
-      )))
+  =
+       -- def_op_id = defm_id inst_ty this_dict
+    returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
  where
     idx            = tag - 1
     meth_id = meth_ids !! idx
     defm_id = defm_ids  !! idx
-    (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id)
 
 makeInstanceDeclNoDefaultExpr
        :: InstOrigin s
@@ -534,38 +480,32 @@ makeInstanceDeclNoDefaultExpr
        -> [Id]
        -> TcType s
        -> Class
-       -> Maybe Module
+       -> Module
        -> Int
        -> NF_TcM s (TcExpr s)
 
 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
-  = newDicts origin op_theta           `thenNF_Tc` \ (op_lie, op_dicts) ->
-
+  = 
        -- Produce a warning if the default instance method
        -- has been omitted when one exists in the class
     warnTc (not err_defm_ok)
           (omitDefaultMethodWarn clas_op clas_name inst_ty)
                                        `thenNF_Tc_`
-    returnNF_Tc (mkHsTyLam op_tyvars (
-                mkHsDictLam op_dicts (
-                HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau])
-                    (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
+    returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
+                      (HsLitOut (HsString (_PK_ error_msg)) stringTy))
   where
     idx            = tag - 1
     meth_id = meth_ids  !! idx
     clas_op = (classOps clas) !! idx
     defm_id = defm_ids  !! idx
-    (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
 
     Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 
-    mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m }
-
-    error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
+    error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
                ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
                ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
 
-    clas_name = nameOf (origName clas)
+    clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
 \end{code}
 
 
@@ -589,7 +529,6 @@ do differs between instance and class decls.
 processInstBinds
        :: Class
        -> (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
-       -> [TcTyVar s]                     -- Tyvars for this instance decl
        -> LIE s                           -- available Insts
        -> [TcIdOcc s]                     -- Local method ids in tag order
                                           --   (instance tyvars are free in their types)
@@ -597,10 +536,10 @@ processInstBinds
        -> TcM s (LIE s,                   -- These are required
                  TcMonoBinds s)
 
-processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
+processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
   =
         -- Process the explicitly-given method bindings
-    processInstBinds1 clas inst_tyvars avail_insts method_ids monobinds
+    processInstBinds1 clas avail_insts method_ids monobinds
                        `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 
         -- Find the methods not handled, and make default method bindings for them.
@@ -622,7 +561,6 @@ processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids m
 \begin{code}
 processInstBinds1
        :: Class
-       -> [TcTyVar s]          -- Tyvars for this instance decl
        -> LIE s                -- available Insts
        -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
        -> RenamedMonoBinds
@@ -630,13 +568,13 @@ processInstBinds1
                  LIE s,        -- These are required
                  TcMonoBinds s)
 
-processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds
+processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
   = returnTc ([], emptyLIE, EmptyMonoBinds)
 
-processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
-  = processInstBinds1 clas inst_tyvars avail_insts method_ids mb1
+processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
+  = processInstBinds1 clas avail_insts method_ids mb1
                                 `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
-    processInstBinds1 clas inst_tyvars avail_insts method_ids mb2
+    processInstBinds1 clas avail_insts method_ids mb2
                                 `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
     returnTc (op_tags1 ++ op_tags2,
              dicts1 `unionBags` dicts2,
@@ -644,7 +582,7 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
 \end{code}
 
 \begin{code}
-processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
+processInstBinds1 clas avail_insts method_ids mbind
   =
     -- Find what class op is being defined here.  The complication is
     -- that we could have a PatMonoBind or a FunMonoBind.  If the
@@ -664,18 +602,17 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
 
     -- Make a method id for the method
     let
-       tag       = classOpTagByString clas occ
-       method_id = method_ids !! (tag-1)
+       maybe_tag  = classOpTagByString_maybe clas occ
+       (Just tag) = maybe_tag
+       method_id  = method_ids !! (tag-1)
+       method_ty  = tcIdType method_id
     in
+    -- check that the method mentioned is actually in the class:
+    checkMaybeTc maybe_tag (instMethodNotInClassErr occ clas) `thenTc_`
 
-    -- The "method" might be a RealId, when processInstBinds is used by
-    -- TcClassDcls:buildDefaultMethodBinds to make default-method bindings
-    (case method_id of
-       TcId id   -> returnNF_Tc (idType id)
-       RealId id -> tcInstType [] (idType id)
-    )          `thenNF_Tc` \ method_ty ->
+    tcInstTcType method_ty             `thenNF_Tc` \ (method_tyvars, method_rho) ->
     let
-       (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
+       (method_theta, method_tau) = splitRhoTy method_rho
     in
     newDicts origin method_theta       `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 
@@ -694,15 +631,23 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
                -- The latter is needed just so we can return an AbsBinds wrapped
                -- up inside a MonoBinds.
 
+
+               -- Make the method_tyvars into signature tyvars so they
+               -- won't get unified with anything.
+       tcInstSigTyVars method_tyvars           `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
+       unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars)        `thenTc_`
+
        newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
        newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
        let
-           inst_method_tyvars = inst_tyvars ++ method_tyvars
+           sig_tyvar_set = mkTyVarSet sig_tyvars
        in
                -- Typecheck the method
        tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 
                -- Check the overloading part of the signature.
+
+       -- =========== POSSIBLE BUT NOT DONE =================
                -- Simplify everything fully, even though some
                -- constraints could "really" be left to the next
                -- level out. The case which forces this is
@@ -711,13 +656,23 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
                --
                -- Here we must simplify constraints on "a" to catch all
                -- the Bar-ish things.
+
+               -- We don't do this because it's currently illegal Haskell (not sure why),
+               -- and because the local type of the method would have a context at
+               -- the front with no for-all, which confuses the hell out of everything!
+       -- ====================================================
+
        tcAddErrCtxt (methodSigCtxt op method_ty) (
+           checkSigTyVars
+               sig_tyvars method_tau                           `thenTc_`
+
          tcSimplifyAndCheck
-               (mkTyVarSet inst_method_tyvars)
+               sig_tyvar_set
                (method_dicts `plusLIE` avail_insts)
                lieIop
        )                                        `thenTc` \ (f_dicts, dict_binds) ->
 
+
        returnTc ([tag],
                  f_dicts,
                  VarMonoBind method_id
@@ -904,12 +859,11 @@ scrutiniseInstanceType from_here clas inst_tau
   = failTc (instTypeErr inst_tau)
 
        -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
-  | from_here
+  | not from_here
   = returnTc (inst_tycon,arg_tys)
 
        -- TYVARS CHECK
   | not (all isTyVarTy arg_tys ||
-         not from_here        ||
         opt_GlasgowExts)
   = failTc (instTypeErr inst_tau)
 
@@ -926,8 +880,9 @@ scrutiniseInstanceType from_here clas inst_tau
        -- A user declaration of a CCallable/CReturnable instance
        -- must be for a "boxed primitive" type.
     isCcallishClass clas
-    && not opt_CompilingPrelude                -- which allows anything
-    && maybeToBool (maybeBoxedPrimType inst_tau)
+    && not (maybeToBool (maybeBoxedPrimType inst_tau)
+           || opt_CompilingGhcInternals) -- this lets us get up to mischief;
+                                    -- e.g., instance CCallable ()
   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 
   | otherwise
@@ -957,9 +912,7 @@ derivingWhenInstanceImportedErr inst_mod clas tycon sty
   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
          4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
   where
-    pp_mod = case inst_mod of
-              Nothing -> ppPStr SLIT("the standard Prelude")
-              Just  m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"]
+    pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
 
 nonBoxedPrimCCallErr clas inst_ty sty
   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
@@ -971,6 +924,10 @@ omitDefaultMethodWarn clas_op clas_name inst_ty sty
           ppr sty clas_op, ppStr "in instance",
           ppPStr clas_name, pprParendGenType sty inst_ty]
 
+instMethodNotInClassErr occ clas sty
+  = ppHang (ppStr "Instance mentions a method not in the class")
+        4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `",
+                      ppPStr occ, ppStr "'"])
 
 patMonoBindsCtxt pbind sty
   = ppHang (ppStr "In a pattern binding:")