<commit_before>%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[TcDefaults]{Typechecking \tr{default} declarations}

\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

module TcDefaults ( tcDefaults ) where

#include "HsVersions.h"

import HsSyn
import Name
import Class
import TcRnMonad
import TcEnv
import TcHsType
import TcSimplify
import TcType
import PrelNames
import DynFlags
import SrcLoc
import Maybe
import Outputable
import FastString
\end{code}

\begin{code}
tcDefaults :: [LDefaultDecl Name]
	   -> TcM (Maybe [Type])    -- Defaulting types to heave
				    -- into Tc monad for later use
				    -- in Disambig.

tcDefaults [] 
  = getDeclaredDefaultTys	-- No default declaration, so get the
				-- default types from the envt; 
				-- i.e. use the curent ones
				-- (the caller will put them back there)
	-- It's important not to return defaultDefaultTys here (which
	-- we used to do) because in a TH program, tcDefaults [] is called
	-- repeatedly, once for each group of declarations between top-level
	-- splices.  We don't want to carefully set the default types in
	-- one group, only for the next group to ignore them and install
	-- defaultDefaultTys

tcDefaults [L locn (DefaultDecl [])]
  = return (Just [])		-- Default declaration specifying no types

tcDefaults [L locn (DefaultDecl mono_tys)]
  = setSrcSpan locn 			$
    addErrCtxt defaultDeclCtxt		$
    do	{ ovl_str <- doptM Opt_OverloadedStrings
	; num_class    <- tcLookupClass numClassName
	; is_str_class <- tcLookupClass isStringClassName
	; let deflt_clss | ovl_str   = [num_class, is_str_class]
			 | otherwise = [num_class]

	; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
    
	; return (Just tau_tys) }

tcDefaults decls@(L locn (DefaultDecl _) : _)
  = setSrcSpan locn $
    failWithTc (dupDefaultDeclErr decls)


tc_default_ty deflt_clss hs_ty 
 = do	{ ty <- tcHsSigType DefaultDeclCtxt hs_ty
	; checkTc (isTauTy ty) (polyDefErr hs_ty)

	-- Check that the type is an instance of at least one of the deflt_clss
	; oks <- mapM (check_instance ty) deflt_clss
	; checkTc (or oks) (badDefaultTy ty deflt_clss)
	; return ty }

check_instance :: Type -> Class -> TcM Bool
  -- Check that ty is an instance of cls
  -- We only care about whether it worked or not; return a boolean
check_instance ty cls
  = do	{ (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]])
	; return (isJust mb_res) }
    
defaultDeclCtxt = ptext SLIT("When checking the types in a default declaration")

dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  = hang (ptext SLIT("Multiple default declarations"))
      4  (vcat (map pp dup_things))
  where
    pp (L locn (DefaultDecl _)) = ptext SLIT("here was another default declaration") <+> ppr locn

polyDefErr ty 
  = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty) 

badDefaultTy ty deflt_clss
  = hang (ptext SLIT("The default type") <+> quotes (ppr ty) <+> ptext SLIT("is not an instance of"))
       2 (foldr1 (\a b -> a <+> ptext SLIT("or") <+> b) (map (quotes. ppr) deflt_clss))
\end{code}
<commit_msg>(F)SLIT -> (f)sLit in TcDefaults<commit_after>%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[TcDefaults]{Typechecking \tr{default} declarations}

\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

module TcDefaults ( tcDefaults ) where

import HsSyn
import Name
import Class
import TcRnMonad
import TcEnv
import TcHsType
import TcSimplify
import TcType
import PrelNames
import DynFlags
import SrcLoc
import Maybe
import Outputable
import FastString
\end{code}

\begin{code}
tcDefaults :: [LDefaultDecl Name]
	   -> TcM (Maybe [Type])    -- Defaulting types to heave
				    -- into Tc monad for later use
				    -- in Disambig.

tcDefaults [] 
  = getDeclaredDefaultTys	-- No default declaration, so get the
				-- default types from the envt; 
				-- i.e. use the curent ones
				-- (the caller will put them back there)
	-- It's important not to return defaultDefaultTys here (which
	-- we used to do) because in a TH program, tcDefaults [] is called
	-- repeatedly, once for each group of declarations between top-level
	-- splices.  We don't want to carefully set the default types in
	-- one group, only for the next group to ignore them and install
	-- defaultDefaultTys

tcDefaults [L locn (DefaultDecl [])]
  = return (Just [])		-- Default declaration specifying no types

tcDefaults [L locn (DefaultDecl mono_tys)]
  = setSrcSpan locn 			$
    addErrCtxt defaultDeclCtxt		$
    do	{ ovl_str <- doptM Opt_OverloadedStrings
	; num_class    <- tcLookupClass numClassName
	; is_str_class <- tcLookupClass isStringClassName
	; let deflt_clss | ovl_str   = [num_class, is_str_class]
			 | otherwise = [num_class]

	; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
    
	; return (Just tau_tys) }

tcDefaults decls@(L locn (DefaultDecl _) : _)
  = setSrcSpan locn $
    failWithTc (dupDefaultDeclErr decls)


tc_default_ty deflt_clss hs_ty 
 = do	{ ty <- tcHsSigType DefaultDeclCtxt hs_ty
	; checkTc (isTauTy ty) (polyDefErr hs_ty)

	-- Check that the type is an instance of at least one of the deflt_clss
	; oks <- mapM (check_instance ty) deflt_clss
	; checkTc (or oks) (badDefaultTy ty deflt_clss)
	; return ty }

check_instance :: Type -> Class -> TcM Bool
  -- Check that ty is an instance of cls
  -- We only care about whether it worked or not; return a boolean
check_instance ty cls
  = do	{ (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]])
	; return (isJust mb_res) }
    
defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration")

dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  = hang (ptext (sLit "Multiple default declarations"))
      4  (vcat (map pp dup_things))
  where
    pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn

polyDefErr ty 
  = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty) 

badDefaultTy ty deflt_clss
  = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
       2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))
\end{code}

{'fraction_non_alphanumeric': 0.09516772572779666, 'fraction_numerical': 0.00472883109206443, 'mean_word_length': 3.607215793056501, 'pattern_counts': {'":': 0, '<': 29, '<?xml version=': 0, '>': 24, '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': '3847025', 'n_tokens_mistral': 2432, 'n_tokens_neox': 2259, 'n_words': 800}