typecheck/TcClassDcl.lhs

% % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % Typechecking class declarations \begin{code}

module TcClassDcl ( tcClassSigs, tcClassDecl2, 
		    findMethodBind, instantiateMethod, tcInstanceMethodBody,
		    mkGenericDefMethBind,
		    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
		  ) where

#include "HsVersions.h"

import HsSyn
import TcEnv
import TcPat( addInlinePrags )
import TcBinds
import TcUnify
import TcHsType
import TcMType
import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
import Class
import Id
import Name
import NameEnv
import NameSet
import Var
import Outputable
import DynFlags
import ErrUtils
import SrcLoc
import Maybes
import BasicTypes
import Bag
import FastString

import Control.Monad

\end{code} Dictionary handling ~~~~~~~~~~~~~~~~~~~ Every class implicitly declares a new data type, corresponding to dictionaries of that class. So, for example: class (D a) => C a where op1 :: a -> a op2 :: forall b. Ord b => a -> b -> b would implicitly declare data CDict a = CDict (D a) (a -> a) (forall b. Ord b => a -> b -> b) (We could use a record decl, but that means changing more of the existing apparatus. One step at at time!) For classes with just one superclass+method, we use a newtype decl instead: class C a where op :: forallb. a -> b -> b generates newtype CDict a = CDict (forall b. a -> b -> b) Now DictTy in Type is just a form of type synomym: DictTy c t = TyConTy CDict `AppTy` t Death to "ExpandingDicts". %************************************************************************ %* * Type-checking the class op signatures %* * %************************************************************************ \begin{code}

tcClassSigs :: Name	             -- Name of the class
	    -> [LSig Name]
	    -> LHsBinds Name
	    -> TcM ([TcMethInfo],    -- Exactly one for each method
                    NameEnv Type)    -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
  = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
       ; let gen_dm_env = mkNameEnv gen_dm_prs

       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs

       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
       ; sequence_ [ failWithTc (badMethodErr clas n)
                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
		   -- Value binding for non class-method (ie no TypeSig)

       ; sequence_ [ failWithTc (badGenericMethod clas n)
                   | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
		   -- Generic signature without value binding

       ; return (op_info, gen_dm_env) }
  where
    vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig    nm ty) <- sigs]
    gen_sigs     = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
    dm_bind_names :: [Name]	-- These ones have a value binding in the class decl
    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]

    tc_sig genop_env (op_names, op_hs_ty)
      = do { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
           ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
           where
             f nm | nm `elemNameEnv` genop_env = GenericDM
                  | nm `elem` dm_bind_names    = VanillaDM
                  | otherwise                  = NoDM

    tc_gen_sig (op_names, gen_hs_ty)
      = do { gen_op_ty <- tcHsKindedType gen_hs_ty
           ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }

\end{code} %************************************************************************ %* * Class Declarations %* * %************************************************************************ \begin{code}

tcClassDecl2 :: LTyClDecl Name		-- The class declaration
	     -> TcM (LHsBinds Id)

tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, 
				tcdMeths = default_binds}))
  = recoverM (return emptyLHsBinds)	$
    setSrcSpan loc		   	$
    do  { clas <- tcLookupLocatedClass class_name

	-- We make a separate binding for each default method.
	-- At one time I used a single AbsBinds for all of them, thus
	-- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
	-- But that desugars into
	--	ds = \d -> (..., ..., ...)
	--	dm1 = \d -> case ds d of (a,b,c) -> a
	-- And since ds is big, it doesn't get inlined, so we don't get good
	-- default methods.  Better to make separate AbsBinds for each
	; let
	      (tyvars, _, _, op_items) = classBigSig clas
              prag_fn     = mkPragFun sigs default_binds
	      sig_fn	  = mkSigFun sigs
              clas_tyvars = tcSuperSkolTyVars tyvars
	      pred  	  = mkClassPred clas (mkTyVarTys clas_tyvars)
	; this_dict <- newEvVar pred

	; traceTc "TIM2" (ppr sigs)
	; let tc_dm = tcDefMeth clas clas_tyvars
				this_dict default_binds 
	      			sig_fn prag_fn

	; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                      mapM tc_dm op_items

	; return (unionManyBags dm_binds) }

tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
    
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
          -> SigFun -> PragFun -> ClassOpItem
          -> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- This is incompatible with Hugs, which expects a polymorphic 
-- default method for every class op, regardless of whether or not 
-- the programmer supplied an explicit default decl for the class.  
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
  = case dm_info of
      NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
                               ; return emptyBag }
      DefMeth dm_name    -> tc_dm dm_name 
      GenDefMeth dm_name -> tc_dm dm_name 
  where
    sel_name      = idName sel_id
    prags         = prag_fn sel_name
    dm_sig_fn  _  = sig_fn sel_name
    dm_bind       = findMethodBind sel_name binds_in
	            `orElse` pprPanic "tcDefMeth" (ppr sel_id)

    -- Eg.   class C a where
    --          op :: forall b. Eq b => a -> [b] -> a
    --		gen_op :: a -> a
    -- 		generic gen_op :: D a => a -> a
    -- The "local_dm_ty" is precisely the type in the above
    -- type signatures, ie with no "forall a. C a =>" prefix

    tc_dm dm_name 
      = do { dm_id <- tcLookupId dm_name
	   ; local_dm_name <- newLocalName sel_name
 	     -- Base the local_dm_name on the selector name, because
 	     -- type errors from tcInstanceMethodBody come from here

           ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
	         local_dm_id = mkLocalId local_dm_name local_dm_ty

           ; dm_id_w_inline <- addInlinePrags dm_id prags
           ; spec_prags     <- tcSpecPrags dm_id prags

           ; warnTc (not (null spec_prags))
                    (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
                     <+> quotes (ppr sel_name))

           ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
                                             dm_id_w_inline local_dm_id dm_sig_fn 
                                             IsDefaultMethod dm_bind

           ; return (unitBag tc_bind) }

---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
                     -> Id -> Id
          	     -> SigFun -> TcSpecPrags -> LHsBind Name 
          	     -> TcM (LHsBind Id)
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
                     meth_id local_meth_id
		     meth_sig_fn specs 
                     (L loc bind)
  = do	{       -- Typecheck the binding, first extending the envt
		-- so that when tcInstSig looks up the local_meth_id to find
		-- its signature, we'll find it in the environment
          let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
                             -- Substitute the local_meth_name for the binder
			     -- NB: the binding is always a FunBind
        ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) 
	; (ev_binds, (tc_bind, _)) 
               <- checkConstraints skol_info tyvars dfun_ev_vars $
		  tcExtendIdEnv [local_meth_id] $
	          tcPolyBinds TopLevel meth_sig_fn no_prag_fn 
		  	     NonRecursive NonRecursive
		  	     [lm_bind]

        ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
                                   , abs_ev_binds = ev_binds
                                   , abs_binds = tc_bind }

        ; return (L loc full_bind) } 
  where
    no_prag_fn  _ = []		-- No pragmas for local_meth_id; 
    		    		-- they are all for meth_id

\end{code} \begin{code}

instantiateMethod :: Class -> Id -> [TcType] -> TcType
-- Take a class operation, say  
--	op :: forall ab. C a => forall c. Ix c => (b,c) -> a
-- Instantiate it at [ty1,ty2]
-- Return the "local method type": 
--	forall c. Ix x => (ty2,c) -> ty1
instantiateMethod clas sel_id inst_tys
  = ASSERT( ok_first_pred ) local_meth_ty
  where
    (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
    rho_ty = ASSERT( length sel_tyvars == length inst_tys )
    	     substTyWith sel_tyvars inst_tys sel_rho

    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
    		`orElse` pprPanic "tcInstanceMethod" (ppr sel_id)

    ok_first_pred = case getClassPredTys_maybe first_pred of
		      Just (clas1, _tys) -> clas == clas1
                      Nothing -> False
	      -- The first predicate should be of form (C a b)
	      -- where C is the class in question


---------------------------
findMethodBind	:: Name  	        -- Selector name
          	-> LHsBinds Name 	-- A group of bindings
		-> Maybe (LHsBind Name)	-- The binding
findMethodBind sel_name binds
  = foldlBag mplus Nothing (mapBag f binds)
  where 
    f bind@(L _ (FunBind { fun_id = L _ op_name }))
             | op_name == sel_name
    	     = Just bind
    f _other = Nothing

\end{code} Note [Polymorphic methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider class Foo a where op :: forall b. Ord b => a -> b -> b -> b instance Foo c => Foo [c] where op = e When typechecking the binding 'op = e', we'll have a meth_id for op whose type is op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b So tcPolyBinds must be capable of dealing with nested polytypes; and so it is. See TcBinds.tcMonoBinds (with type-sig case). Note [Silly default-method bind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we pass the default method binding to the type checker, it must look like op2 = e not $dmop2 = e otherwise the "$dm" stuff comes out error messages. But we want the "$dm" to come out in the interface file. So we typecheck the former, and wrap it in a let, thus $dmop2 = let op2 = e in op2 This makes the error messages right. %************************************************************************ %* * Extracting generic instance declaration from class declarations %* * %************************************************************************ @getGenericInstances@ extracts the generic instance declarations from a class declaration. For exmaple class C a where op :: a -> a op{ x+y } (Inl v) = ... op{ x+y } (Inr v) = ... op{ x*y } (v :*: w) = ... op{ 1 } Unit = ... gives rise to the instance declarations instance C (x+y) where op (Inl v) = ... op (Inr v) = ... instance C (x*y) where op (v :*: w) = ... instance C 1 where op Unit = ... \begin{code}

mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id dm_name
  = 	-- A generic default method
    	-- If the method is defined generically, we only have to call the
        -- dm_name.
    do	{ dflags <- getDOpts
	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
		   (vcat [ppr clas <+> ppr inst_tys,
			  nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))

        ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
                                    [mkSimpleMatch [] rhs]) }
  where
    rhs = nlHsVar dm_name

\end{code} %************************************************************************ %* * Error messages %* * %************************************************************************ \begin{code}

tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
  = addErrCtxt ctxt thing_inside
  where
     thing | isClassDecl decl  = "class"
	   | isTypeDecl decl   = "type synonym" ++ maybeInst
	   | isDataDecl decl   = if tcdND decl == NewType 
				 then "newtype" ++ maybeInst
				 else "data type" ++ maybeInst
	   | isFamilyDecl decl = "family"
	   | otherwise         = panic "tcAddDeclCtxt/thing"

     maybeInst | isFamInstDecl decl = " instance"
	       | otherwise          = ""

     ctxt = hsep [ptext (sLit "In the"), text thing, 
		  ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]

badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr clas op
  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
	  ptext (sLit "does not have a method"), quotes (ppr op)]

badGenericMethod :: Outputable a => a -> Name -> SDoc
badGenericMethod clas op
  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
	  ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]

badATErr :: Class -> Name -> SDoc
badATErr clas at
  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
	  ptext (sLit "does not have an associated type"), quotes (ppr at)]

omittedATWarn :: Name -> SDoc
omittedATWarn at
  = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
{-
badGenericInstanceType :: LHsBinds Name -> SDoc
badGenericInstanceType binds
  = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
	  nest 2 (ppr binds)]

missingGenericInstances :: [Name] -> SDoc
missingGenericInstances missing
  = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
	  
dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
dupGenericInsts tc_inst_infos
  = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
	  nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
	  ptext (sLit "All the type patterns for a generic type constructor must be identical")
    ]
  where 
    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-}
badDmPrag :: Id -> Sig Name -> TcM ()
badDmPrag sel_id prag
  = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") 
              <+> quotes (ppr sel_id) 
              <+> ptext (sLit "lacks an accompanying binding"))

\end{code}