<commit_before>%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

TcInstDecls: Typechecking instance declarations

\begin{code}
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where

#include "HsVersions.h"

import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl
import TcRnMonad       
import TcMType
import TcType
import Inst
import InstEnv
import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
import TcHsType
import TcUnify
import TcSimplify
import Type
import Coercion
import TyCon
import DataCon
import Class
import Var
import MkId
import Name
import NameSet
import DynFlags
import SrcLoc
import ListSetOps
import Util
import Outputable
import Bag
import BasicTypes
import HscTypes
import FastString

import Data.Maybe
import Control.Monad hiding (zipWithM_, mapAndUnzipM)
import Data.List
\end{code}

Typechecking instance declarations is done in two passes. The first
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.

This pre-processed info includes the as-yet-unprocessed bindings
inside the instance declaration.  These are type-checked in the second
pass, when the class-instance envs and GVE contain all the info from
all the instance and value decls.  Indeed that's the reason we need
two passes over the instance decls.

Here is the overall algorithm.
Assume that we have an instance declaration

    instance c => k (t tvs) where b

\begin{enumerate}
\item
$LIE_c$ is the LIE for the context of class $c$
\item
$betas_bar$ is the free variables in the class method type, excluding the
   class variable
\item
$LIE_cop$ is the LIE constraining a particular class method
\item
$tau_cop$ is the tau type of a class method
\item
$LIE_i$ is the LIE for the context of instance $i$
\item
$X$ is the instance constructor tycon
\item
$gammas_bar$ is the set of type variables of the instance
\item
$LIE_iop$ is the LIE for a particular class method instance
\item
$tau_iop$ is the tau type for this instance of a class method
\item
$alpha$ is the class variable
\item
$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
\item
$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
\end{enumerate}

ToDo: Update the list above with names actually in the code.

\begin{enumerate}
\item
First, make the LIEs for the class and instance contexts, which means
instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
and make LIElistI and LIEI.
\item
Then process each method in turn.
\item
order the instance methods according to the ordering of the class methods
\item
express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
\item
Create final dictionary function from bindings generated already
\begin{pseudocode}
df = lambda inst_tyvars
       lambda LIEI
	 let Bop1
	     Bop2
	     ...
	     Bopn
	 and dbinds_super
	      in <op1,op2,...,opn,sd1,...,sdm>
\end{pseudocode}
Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
\end{enumerate}


%************************************************************************
%*									*
\subsection{Extracting instance decls}
%*									*
%************************************************************************

Gather up the instance declarations from their various sources

\begin{code}
tcInstDecls1	-- Deal with both source-code and imported instance decls
   :: [LTyClDecl Name]		-- For deriving stuff
   -> [LInstDecl Name]		-- Source code instance decls
   -> [LDerivDecl Name]		-- Source code stand-alone deriving decls
   -> TcM (TcGblEnv,		-- The full inst env
	   [InstInfo],		-- Source-code instance decls to process; 
				-- contains all dfuns for this module
	   HsValBinds Name)	-- Supporting bindings for derived instances

tcInstDecls1 tycl_decls inst_decls deriv_decls
  = checkNoErrs $
    do {        -- Stop if addInstInfos etc discovers any errors
		-- (they recover, so that we get more than one error each
		-- round) 

		-- (1) Do class instance declarations and instances of indexed
		--     types 
       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
       ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
       ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls

       ; let { (local_infos,
	        at_tycons)     = unzip local_info_tycons
	     ; local_info      = concat local_infos
	     ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
	     ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls 
	     ; implicit_things = concatMap implicitTyThings at_idx_tycon
	     }

	        -- (2) Add the tycons of indexed types and their implicit
	        --     tythings to the global environment
       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {

	        -- (3) Instances from generic class declarations
       ; generic_inst_info <- getGenericInstances clas_decls

	        -- Next, construct the instance environment so far, consisting
	        -- of 
		--   a) local instance decls
		--   b) generic instances
		--   c) local family instance decls
       ; addInsts local_info         $ do {
       ; addInsts generic_inst_info  $ do {
       ; addFamInsts at_idx_tycon    $ do {

	        -- (4) Compute instances from "deriving" clauses; 
		-- This stuff computes a context for the derived instance
		-- decl, so it needs to know about all the instances possible
       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
       ; addInsts deriv_inst_info   $ do {

       ; gbl_env <- getGblEnv
       ; returnM (gbl_env, 
		  generic_inst_info ++ deriv_inst_info ++ local_info,
		  deriv_binds) 
    }}}}}}
  where
    -- Make sure that toplevel type instance are not for associated types.
    -- !!!TODO: Need to perform this check for the TyThing of type functions,
    --		too.
    tcIdxTyInstDeclTL ldecl@(L loc decl) =
      do { tything <- tcIdxTyInstDecl ldecl
	 ; setSrcSpan loc $
	     when (isAssocFamily tything) $
	       addErr $ assocInClassErr (tcdName decl)
	 ; return tything
	 }
    isAssocFamily (Just (ATyCon tycon)) =
      case tyConFamInst_maybe tycon of
        Nothing       -> panic "isAssocFamily: no family?!?"
	Just (fam, _) -> isTyConAssoc fam
    isAssocFamily (Just _	      ) = panic "isAssocFamily: no tycon?!?"
    isAssocFamily Nothing               = False

assocInClassErr name = 
  ptext SLIT("Associated type") <+> quotes (ppr name) <+> 
  ptext SLIT("must be inside a class instance")

addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
  = tcExtendLocalInstEnv (map iSpec infos) thing_inside

addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
  = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
  where
    mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
    mkLocalFamInstTyThing tything	 = pprPanic "TcInstDcls.addFamInsts"
						    (ppr tything)
\end{code}

\begin{code}
tcLocalInstDecl1 :: LInstDecl Name 
		 -> TcM ([InstInfo], [TyThing])	-- [] if there was an error
	-- A source-file instance declaration
	-- Type-check all the stuff before the "where"
	--
	-- We check for respectable instance type, and context
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
  =	-- Prime error recovery, set source location
    recoverM (returnM ([], []))		$
    setSrcSpan loc			$
    addErrCtxt (instDeclCtxt1 poly_ty)	$

    do	{ is_boot <- tcIsHsBoot
	; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
		  badBootDeclErr

	; (tyvars, theta, tau) <- tcHsInstHead poly_ty
	
	-- Next, process any associated types.
	; idx_tycons <- mappM tcIdxTyInstDecl ats

	-- Now, check the validity of the instance.
	; (clas, inst_tys) <- checkValidInstHead tau
	; checkValidInstance tyvars theta clas inst_tys
	; checkValidAndMissingATs clas (tyvars, inst_tys) 
				  (zip ats idx_tycons)

	-- Finally, construct the Core representation of the instance.
	-- (This no longer includes the associated types.)
	; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
	; overlap_flag <- getOverlapFlag
	; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
	      ispec          = mkLocalInstance dfun overlap_flag

	; return ([InstInfo { iSpec  = ispec, 
			      iBinds = VanillaInst binds uprags }],
		  catMaybes idx_tycons)
        }
  where
    -- We pass in the source form and the type checked form of the ATs.  We
    -- really need the source form only to be able to produce more informative
    -- error messages.
    checkValidAndMissingATs :: Class
			    -> ([TyVar], [TcType])     -- instance types
			    -> [(LTyClDecl Name,       -- source form of AT
			         Maybe TyThing)]       -- Core form of AT
			    -> TcM ()
    checkValidAndMissingATs clas inst_tys ats
      = do { -- Issue a warning for each class AT that is not defined in this
	     -- instance.
	   ; let classDefATs = listToNameSet . map tyConName . classATs $ clas
                 definedATs  = listToNameSet . map (tcdName.unLoc.fst)  $ ats
		 omitted     = classDefATs `minusNameSet` definedATs
	   ; warn <- doptM Opt_WarnMissingMethods
	   ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
	   
	     -- Ensure that all AT indexes that correspond to class parameters
	     -- coincide with the types in the instance head.  All remaining
	     -- AT arguments must be variables.  Also raise an error for any
	     -- type instances that are not associated with this class.
	   ; mapM_ (checkIndexes clas inst_tys) ats
	   }

    checkIndexes _    _        (hsAT, Nothing)             = 
      return ()	   -- skip, we already had an error here
    checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = 
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
      checkIndexes' clas inst_tys hsAT 
		    (tyConTyVars tycon, 
		     snd . fromJust . tyConFamInst_maybe $ tycon)
    checkIndexes _ _ _ = panic "checkIndexes"

    checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
      = let atName = tcdName . unLoc $ hsAT
	in<commit_msg>Make warnings come out in deterministic order<commit_after>%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

TcInstDecls: Typechecking instance declarations

\begin{code}
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where

#include "HsVersions.h"

import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl
import TcRnMonad       
import TcMType
import TcType
import Inst
import InstEnv
import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
import TcHsType
import TcUnify
import TcSimplify
import Type
import Coercion
import TyCon
import DataCon
import Class
import Var
import MkId
import Name
import NameSet
import DynFlags
import SrcLoc
import ListSetOps
import Util
import Outputable
import Bag
import BasicTypes
import HscTypes
import FastString

import Data.Maybe
import Control.Monad hiding (zipWithM_, mapAndUnzipM)
import Data.List
\end{code}

Typechecking instance declarations is done in two passes. The first
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.

This pre-processed info includes the as-yet-unprocessed bindings
inside the instance declaration.  These are type-checked in the second
pass, when the class-instance envs and GVE contain all the info from
all the instance and value decls.  Indeed that's the reason we need
two passes over the instance decls.

Here is the overall algorithm.
Assume that we have an instance declaration

    instance c => k (t tvs) where b

\begin{enumerate}
\item
$LIE_c$ is the LIE for the context of class $c$
\item
$betas_bar$ is the free variables in the class method type, excluding the
   class variable
\item
$LIE_cop$ is the LIE constraining a particular class method
\item
$tau_cop$ is the tau type of a class method
\item
$LIE_i$ is the LIE for the context of instance $i$
\item
$X$ is the instance constructor tycon
\item
$gammas_bar$ is the set of type variables of the instance
\item
$LIE_iop$ is the LIE for a particular class method instance
\item
$tau_iop$ is the tau type for this instance of a class method
\item
$alpha$ is the class variable
\item
$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
\item
$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
\end{enumerate}

ToDo: Update the list above with names actually in the code.

\begin{enumerate}
\item
First, make the LIEs for the class and instance contexts, which means
instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
and make LIElistI and LIEI.
\item
Then process each method in turn.
\item
order the instance methods according to the ordering of the class methods
\item
express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
\item
Create final dictionary function from bindings generated already
\begin{pseudocode}
df = lambda inst_tyvars
       lambda LIEI
	 let Bop1
	     Bop2
	     ...
	     Bopn
	 and dbinds_super
	      in <op1,op2,...,opn,sd1,...,sdm>
\end{pseudocode}
Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
\end{enumerate}


%************************************************************************
%*									*
\subsection{Extracting instance decls}
%*									*
%************************************************************************

Gather up the instance declarations from their various sources

\begin{code}
tcInstDecls1	-- Deal with both source-code and imported instance decls
   :: [LTyClDecl Name]		-- For deriving stuff
   -> [LInstDecl Name]		-- Source code instance decls
   -> [LDerivDecl Name]		-- Source code stand-alone deriving decls
   -> TcM (TcGblEnv,		-- The full inst env
	   [InstInfo],		-- Source-code instance decls to process; 
				-- contains all dfuns for this module
	   HsValBinds Name)	-- Supporting bindings for derived instances

tcInstDecls1 tycl_decls inst_decls deriv_decls
  = checkNoErrs $
    do {        -- Stop if addInstInfos etc discovers any errors
		-- (they recover, so that we get more than one error each
		-- round) 

		-- (1) Do class instance declarations and instances of indexed
		--     types 
       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
       ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
       ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls

       ; let { (local_infos,
	        at_tycons)     = unzip local_info_tycons
	     ; local_info      = concat local_infos
	     ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
	     ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls 
	     ; implicit_things = concatMap implicitTyThings at_idx_tycon
	     }

	        -- (2) Add the tycons of indexed types and their implicit
	        --     tythings to the global environment
       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {

	        -- (3) Instances from generic class declarations
       ; generic_inst_info <- getGenericInstances clas_decls

	        -- Next, construct the instance environment so far, consisting
	        -- of 
		--   a) local instance decls
		--   b) generic instances
		--   c) local family instance decls
       ; addInsts local_info         $ do {
       ; addInsts generic_inst_info  $ do {
       ; addFamInsts at_idx_tycon    $ do {

	        -- (4) Compute instances from "deriving" clauses; 
		-- This stuff computes a context for the derived instance
		-- decl, so it needs to know about all the instances possible
       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
       ; addInsts deriv_inst_info   $ do {

       ; gbl_env <- getGblEnv
       ; returnM (gbl_env, 
		  generic_inst_info ++ deriv_inst_info ++ local_info,
		  deriv_binds) 
    }}}}}}
  where
    -- Make sure that toplevel type instance are not for associated types.
    -- !!!TODO: Need to perform this check for the TyThing of type functions,
    --		too.
    tcIdxTyInstDeclTL ldecl@(L loc decl) =
      do { tything <- tcIdxTyInstDecl ldecl
	 ; setSrcSpan loc $
	     when (isAssocFamily tything) $
	       addErr $ assocInClassErr (tcdName decl)
	 ; return tything
	 }
    isAssocFamily (Just (ATyCon tycon)) =
      case tyConFamInst_maybe tycon of
        Nothing       -> panic "isAssocFamily: no family?!?"
	Just (fam, _) -> isTyConAssoc fam
    isAssocFamily (Just _	      ) = panic "isAssocFamily: no tycon?!?"
    isAssocFamily Nothing               = False

assocInClassErr name = 
  ptext SLIT("Associated type") <+> quotes (ppr name) <+> 
  ptext SLIT("must be inside a class instance")

addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
  = tcExtendLocalInstEnv (map iSpec infos) thing_inside

addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
  = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
  where
    mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
    mkLocalFamInstTyThing tything	 = pprPanic "TcInstDcls.addFamInsts"
						    (ppr tything)
\end{code}

\begin{code}
tcLocalInstDecl1 :: LInstDecl Name 
		 -> TcM ([InstInfo], [TyThing])	-- [] if there was an error
	-- A source-file instance declaration
	-- Type-check all the stuff before the "where"
	--
	-- We check for respectable instance type, and context
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
  =	-- Prime error recovery, set source location
    recoverM (returnM ([], []))		$
    setSrcSpan loc			$
    addErrCtxt (instDeclCtxt1 poly_ty)	$

    do	{ is_boot <- tcIsHsBoot
	; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
		  badBootDeclErr

	; (tyvars, theta, tau) <- tcHsInstHead poly_ty
	
	-- Next, process any associated types.
	; idx_tycons <- mappM tcIdxTyInstDecl ats

	-- Now, check the validity of the instance.
	; (clas, inst_tys) <- checkValidInstHead tau
	; checkValidInstance tyvars theta clas inst_tys
	; checkValidAndMissingATs clas (tyvars, inst_tys) 
				  (zip ats idx_tycons)

	-- Finally, construct the Core representation of the instance.
	-- (This no longer includes the associated types.)
	; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
	; overlap_flag <- getOverlapFlag
	; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
	      ispec          = mkLocalInstance dfun overlap_flag

	; return ([InstInfo { iSpec  = ispec, 
			      iBinds = VanillaInst binds uprags }],
		  catMaybes idx_tycons)
        }
  where
    -- We pass in the source form and the type checked form of the ATs.  We
    -- really need the source form only to be able to produce more informative
    -- error messages.
    checkValidAndMissingATs :: Class
			    -> ([TyVar], [TcType])     -- instance types
			    -> [(LTyClDecl Name,       -- source form of AT
			         Maybe TyThing)]       -- Core form of AT
			    -> TcM ()
    checkValidAndMissingATs clas inst_tys ats
      = do { -- Issue a warning for each class AT that is not defined in this
	     -- instance.
	   ; let class_ats   = map tyConName (classATs clas)
                 defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
		 omitted     = filterOut (`elemNameSet` defined_ats) class_ats
	   ; warn <- doptM Opt_WarnMissingMethods
	   ; mapM_ (warnTc warn . omittedATWarn) omitted
	   
	     -- Ensure that all AT indexes that correspond to class parameters
	     -- coincide with the types in the instance head.  All remaining
	     -- AT arguments must be variables.  Also raise an error for any
	     -- type instances that are not associated with this class.
	   ; mapM_ (checkIndexes clas inst_tys) ats
	   }

    checkIndexes _    _        (hsAT, Nothing)             = 
      return ()	   -- skip, we already had an error here
    checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = 
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
      checkIndexes' clas inst_tys hsAT 
		    (tyConTyVars tycon, 
		     snd . fromJust . tyConFamInst_maybe $ tycon)
    checkIndexes _ _ _ = panic "checkIndexes"

    checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
      = let atName = tcdName . unLoc $ hsAT
	in
{'fraction_non_alphanumeric': 0.08612180436284671, 'fraction_numerical': 0.003257328990228013, 'mean_word_length': 3.0935353535353536, 'pattern_counts': {'":': 0, '<': 35, '<?xml version=': 0, '>': 37, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4311664', 'n_tokens_mistral': 6803, 'n_tokens_neox': 6370, 'n_words': 2268}