content: {-
  (c) The University of Glasgow 2006
  (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  
  
  Typechecking class declarations
  -}
  {-# LANGUAGE CPP #-}
  
  module Eta.TypeCheck.TcClassDcl ( tcClassSigs, tcClassDecl2,
                      findMethodBind, instantiateMethod, tcInstanceMethodBody,
                      tcClassMinimalDef,
                      HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
                      tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
                    ) where
  
  import Eta.HsSyn.HsSyn
  import Eta.TypeCheck.TcEnv
  import Eta.TypeCheck.TcPat( addInlinePrags )
  import Eta.TypeCheck.TcEvidence( HsWrapper, idHsWrapper )
  import Eta.TypeCheck.TcBinds
  import Eta.TypeCheck.TcUnify
  import Eta.TypeCheck.TcHsType
  import Eta.TypeCheck.TcMType
  import Eta.Types.Type     ( getClassPredTys_maybe )
  import Eta.TypeCheck.TcType
  import Eta.TypeCheck.TcRnMonad
  import Eta.Iface.BuildTyCl( TcMethInfo )
  import Eta.Types.Class
  import Eta.BasicTypes.Id
  import Eta.BasicTypes.Name
  import Eta.BasicTypes.NameEnv
  import Eta.BasicTypes.NameSet
  import Eta.BasicTypes.Var
  import Eta.Utils.Outputable
  import Eta.BasicTypes.SrcLoc
  import Eta.Utils.Maybes
  import Eta.BasicTypes.BasicTypes
  import Eta.Utils.Bag
  import Eta.Utils.FastString
  import Eta.Utils.BooleanFormula
  import Eta.Utils.Util
  import Eta.Main.DynFlags
  import Control.Monad
  
  #include "HsVersions.h"
  
  {-
  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
  *                                                                      *
  ************************************************************************
  -}
  
  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 { traceTc "tcClassSigs 1" (ppr clas)
  
         ; 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
  
         ; traceTc "tcClassSigs 2" (ppr clas)
         ; 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 { traceTc "ClsSig 1" (ppr op_names)
             ; op_ty <- tcClassSigType op_hs_ty   -- Class tyvars already in scope
             ; traceTc "ClsSig 2" (ppr op_names)
             ; 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 <- tcClassSigType gen_hs_ty
             ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
  
  {-
  ************************************************************************
  *                                                                      *
                  Class Declarations
  *                                                                      *
  ************************************************************************
  -}
  
  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      = mkHsSigFun sigs
                clas_tyvars = snd (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
            -> HsSigFun -> 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 hs_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_bind,bndr_loc) = 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 <- setSrcSpan bndr_loc (newLocalName sel_name)
               -- Base the local_dm_name on the selector name, because
               -- type errors from tcInstanceMethodBody come from here
  
             ; dm_id_w_inline <- addInlinePrags dm_id prags
             ; spec_prags     <- tcSpecPrags dm_id prags
  
             ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
                   hs_ty       = lookupHsSig hs_sig_fn sel_name
                                 `orElse` pprPanic "tc_dm" (ppr sel_name)
  
             ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
             ; warnTc NoReason (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_sig idHsWrapper
                                               IsDefaultMethod dm_bind
  
             ; return (unitBag tc_bind) }
  
  ---------------
  tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
                       -> Id -> TcSigInfo
                       -> HsWrapper  -- See Note [Instance method signatures] in TcInstDcls
                       -> TcSpecPrags -> LHsBind Name
                       -> TcM (LHsBind Id)
  tcInstanceMethodBody skol_info tyvars dfun_ev_vars
                       meth_id local_meth_sig wrapper
                       specs (L loc bind)
    = do  { let local_meth_id = case local_meth_sig of
                    TcSigInfo{ sig_id = meth_id } -> meth_id
                    _ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
                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
          ; (ev_binds, (tc_bind, _, _))
                 <- checkConstraints skol_info tyvars dfun_ev_vars $
                    tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
  
          ; let export = ABE { abe_wrap = wrapper, abe_poly = meth_id
                             , abe_mono = local_meth_id, abe_prags = specs }
                full_bind = AbsBinds { abs_tvs      = tyvars
                                     , abs_ev_vars  = dfun_ev_vars
                                     , abs_exports  = [export]
                                     , 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
  
  ---------------
  tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
  tcClassMinimalDef _clas sigs op_info
    = case findMinimalDef sigs of
        Nothing -> return defMindef
        Just mindef -> do
          -- Warn if the given mindef does not imply the default one
          -- That is, the given mindef should at least ensure that the
          -- class ops without default methods are required, since we
          -- have no way to fill them in otherwise
          whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
                     (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
          return mindef
    where
      -- By default require all methods without a default
      -- implementation whose names don't start with '_'
      defMindef :: ClassMinimalDef
      defMindef = mkAnd [ mkVar name
                        | (name, NoDM, _) <- op_info
                        , not (startsWithUnderscore (getOccName name)) ]
  
  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
  
  
  ---------------------------
  type HsSigFun = NameEnv (LHsType Name)
  
  emptyHsSigs :: HsSigFun
  emptyHsSigs = emptyNameEnv
  
  mkHsSigFun :: [LSig Name] -> HsSigFun
  mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
                              | L _ (TypeSig ns hs_ty _ _) <- sigs
                              , L _ n <- ns ]
  
  lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
  lookupHsSig = lookupNameEnv
  
  ---------------------------
  findMethodBind  :: Name                 -- Selector name
                  -> LHsBinds Name        -- A group of bindings
                  -> Maybe (LHsBind Name, SrcSpan)
                  -- Returns the binding, and the binding
                  -- site of the method binder
  findMethodBind sel_name binds
    = foldlBag mplus Nothing (mapBag f binds)
    where
      f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
        | op_name == sel_name
               = Just (bind, bndr_loc)
      f _other = Nothing
  
  ---------------------------
  findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
  findMinimalDef = firstJusts . map toMinimalDef
    where
      toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
      toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf)
      toMinimalDef _                       = Nothing
  
  {-
  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.
  
  
  ************************************************************************
  *                                                                      *
                  Error messages
  *                                                                      *
  ************************************************************************
  -}
  
  tcMkDeclCtxt :: TyClDecl Name -> SDoc
  tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
                        ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
  
  tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
  tcAddDeclCtxt decl thing_inside
    = addErrCtxt (tcMkDeclCtxt decl) thing_inside
  
  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)]
  
  {-
  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"))
  
  warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
  warningMinimalDefIncomplete mindef
    = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
           , nest 2 (pprBooleanFormulaNice mindef)
           , ptext (sLit "but there is no default implementation.") ]
  