<commit_before>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsExpr]{Matching expressions (Exprs)}

\begin{code}
module DsExpr ( dsExpr, dsLet ) where

#include "HsVersions.h"


import HsSyn		( failureFreePat,
			  HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
			  Stmt(..), HsMatchContext(..), HsDoContext(..), 
			  Match(..), HsBinds(..), MonoBinds(..), 
			  mkSimpleMatch 
			)
import TcHsSyn		( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPatType )

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
--     needs to see source types (newtypes etc), and sometimes not
--     So WATCH OUT; check each use of split*Ty functions.
-- Sigh.  This is a pain.

import TcType		( tcSplitAppTy, tcSplitFunTys, tcSplitTyConApp_maybe, tcTyConAppArgs,
			  isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type )
import Type		( splitFunTys )
import CoreSyn
import CoreUtils	( exprType, mkIfThenElse, bindNonRec )

import DsMonad
import DsBinds		( dsMonoBinds, AutoScc(..) )
import DsGRHSs		( dsGuarded )
import DsCCall		( dsCCall, resultWrapper )
import DsListComp	( dsListComp )
import DsUtils		( mkErrorAppDs, mkStringLit, mkStringLitFS, 
			  mkConsExpr, mkNilExpr, mkIntegerLit
			)
import Match		( matchWrapper, matchSimply )

import FieldLabel	( FieldLabel, fieldLabelTyCon )
import CostCentre	( mkUserCC )
import Id		( Id, idType, recordSelectorFieldLabel )
import PrelInfo		( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon		( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon		( isExistentialDataCon )
import Literal		( Literal(..) )
import TyCon		( tyConDataCons )
import TysWiredIn	( tupleCon, listTyCon, charDataCon, intDataCon )
import BasicTypes	( RecFlag(..), Boxity(..), ipNameName )
import Maybes		( maybeToBool )
import PrelNames	( hasKey, ratioTyConKey )
import Util		( zipEqual, zipWithEqual )
import Outputable

import Ratio 		( numerator, denominator )
\end{code}


%************************************************************************
%*									*
\subsection{dsLet}
%*									*
%************************************************************************

@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body
and transforming it into one for the let-bindings enclosing the body.

This may seem a bit odd, but (source) let bindings can contain unboxed
binds like
\begin{verbatim}
	C x# = e
\end{verbatim}
This must be transformed to a case expression and, if the type has
more than one constructor, may fail.

\begin{code}
dsLet :: TypecheckedHsBinds -> CoreExpr -> DsM CoreExpr

dsLet EmptyBinds body
  = returnDs body

dsLet (ThenBinds b1 b2) body
  = dsLet b2 body 	`thenDs` \ body' ->
    dsLet b1 body'
  
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE pragmas...
dsLet (MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body
  | or [isUnLiftedType (idType g) | (_, g, l) <- exports]
  = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
	-- Unlifted bindings are always non-recursive
	-- and are always a Fun or Pat monobind
	--
	-- ToDo: in some bizarre case it's conceivable that there
	--       could be dict binds in the 'binds'.  (See the notes
	--	 below.  Then pattern-match would fail.  Urk.)
    case binds of
      FunMonoBind fun _ matches loc
	-> putSrcLocDs loc			$
	   matchWrapper (FunRhs fun) matches 	`thenDs` \ (args, rhs) ->
	   ASSERT( null args )	-- Functions aren't lifted
	   returnDs (bindNonRec fun rhs body_w_exports)

      PatMonoBind pat grhss loc
	-> putSrcLocDs loc			$
	   dsGuarded grhss 			`thenDs` \ rhs ->
	   mk_error_app pat			`thenDs` \ error_expr ->
	   matchSimply rhs PatBindRhs pat body_w_exports error_expr
  where
    body_w_exports		 = foldr bind_export body exports
    bind_export (tvs, g, l) body = ASSERT( null tvs )
				   bindNonRec g (Var l) body

    mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
				    (exprType body)
				    (showSDoc (ppr pat))

-- Ordinary case for bindings
dsLet (MonoBind binds sigs is_rec) body
  = dsMonoBinds NoSccs binds []  `thenDs` \ prs ->
    returnDs (Let (Rec prs) body)
	-- Use a Rec regardless of is_rec. 
	-- Why? Because it allows the MonoBinds to be all
	-- mixed up, which is what happens in one rare case
	-- Namely, for an AbsBind with no tyvars and no dicts,
	-- 	   but which does have dictionary bindings.
	-- See notes with TcSimplify.inferLoop [NO TYVARS]
	-- It turned out that wrapping a Rec here was the easiest solution
	--
	-- NB The previous case dealt with unlifted bindings, so we<commit_msg>[project @ 2001-11-30 09:39:32 by simonpj] Print a bit more info if dsExpr fails for unlifted bindings<commit_after>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsExpr]{Matching expressions (Exprs)}

\begin{code}
module DsExpr ( dsExpr, dsLet ) where

#include "HsVersions.h"


import HsSyn		( failureFreePat,
			  HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
			  Stmt(..), HsMatchContext(..), HsDoContext(..), 
			  Match(..), HsBinds(..), MonoBinds(..), 
			  mkSimpleMatch 
			)
import TcHsSyn		( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPatType )

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
--     needs to see source types (newtypes etc), and sometimes not
--     So WATCH OUT; check each use of split*Ty functions.
-- Sigh.  This is a pain.

import TcType		( tcSplitAppTy, tcSplitFunTys, tcSplitTyConApp_maybe, tcTyConAppArgs,
			  isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type )
import Type		( splitFunTys )
import CoreSyn
import CoreUtils	( exprType, mkIfThenElse, bindNonRec )

import DsMonad
import DsBinds		( dsMonoBinds, AutoScc(..) )
import DsGRHSs		( dsGuarded )
import DsCCall		( dsCCall, resultWrapper )
import DsListComp	( dsListComp )
import DsUtils		( mkErrorAppDs, mkStringLit, mkStringLitFS, 
			  mkConsExpr, mkNilExpr, mkIntegerLit
			)
import Match		( matchWrapper, matchSimply )

import FieldLabel	( FieldLabel, fieldLabelTyCon )
import CostCentre	( mkUserCC )
import Id		( Id, idType, recordSelectorFieldLabel )
import PrelInfo		( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon		( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon		( isExistentialDataCon )
import Literal		( Literal(..) )
import TyCon		( tyConDataCons )
import TysWiredIn	( tupleCon, listTyCon, charDataCon, intDataCon )
import BasicTypes	( RecFlag(..), Boxity(..), ipNameName )
import Maybes		( maybeToBool )
import PrelNames	( hasKey, ratioTyConKey )
import Util		( zipEqual, zipWithEqual )
import Outputable

import Ratio 		( numerator, denominator )
\end{code}


%************************************************************************
%*									*
\subsection{dsLet}
%*									*
%************************************************************************

@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body
and transforming it into one for the let-bindings enclosing the body.

This may seem a bit odd, but (source) let bindings can contain unboxed
binds like
\begin{verbatim}
	C x# = e
\end{verbatim}
This must be transformed to a case expression and, if the type has
more than one constructor, may fail.

\begin{code}
dsLet :: TypecheckedHsBinds -> CoreExpr -> DsM CoreExpr

dsLet EmptyBinds body
  = returnDs body

dsLet (ThenBinds b1 b2) body
  = dsLet b2 body 	`thenDs` \ body' ->
    dsLet b1 body'
  
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE pragmas...
dsLet bind@(MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body
  | or [isUnLiftedType (idType g) | (_, g, l) <- exports]
  = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
	-- Unlifted bindings are always non-recursive
	-- and are always a Fun or Pat monobind
	--
	-- ToDo: in some bizarre case it's conceivable that there
	--       could be dict binds in the 'binds'.  (See the notes
	--	 below.  Then pattern-match would fail.  Urk.)
    case binds of
      FunMonoBind fun _ matches loc
	-> putSrcLocDs loc			$
	   matchWrapper (FunRhs fun) matches 	`thenDs` \ (args, rhs) ->
	   ASSERT( null args )	-- Functions aren't lifted
	   returnDs (bindNonRec fun rhs body_w_exports)

      PatMonoBind pat grhss loc
	-> putSrcLocDs loc			$
	   dsGuarded grhss 			`thenDs` \ rhs ->
	   mk_error_app pat			`thenDs` \ error_expr ->
	   matchSimply rhs PatBindRhs pat body_w_exports error_expr

      other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
  where
    body_w_exports		 = foldr bind_export body exports
    bind_export (tvs, g, l) body = ASSERT( null tvs )
				   bindNonRec g (Var l) body

    mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
				    (exprType body)
				    (showSDoc (ppr pat))

-- Ordinary case for bindings
dsLet (MonoBind binds sigs is_rec) body
  = dsMonoBinds NoSccs binds []  `thenDs` \ prs ->
    returnDs (Let (Rec prs) body)
	-- Use a Rec regardless of is_rec. 
	-- Why? Because it allows the MonoBinds to be all
	-- mixed up, which is what happens in one rare case
	-- Namely, for an AbsBind with no tyvars and no dicts,
	-- 	   but which does have dictionary bindings.
	-- See notes with TcSimplify.inferLoop [NO TYVARS]
	-- It turned out that wrapping a Rec here was the easiest solution
	--
	-- NB The previous case dealt with unlifted bindings, so we
{'fraction_non_alphanumeric': 0.11859641815910038, 'fraction_numerical': 0.003956684714702207, 'mean_word_length': 3.6423392943450943, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 26, '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': '5876673', 'n_tokens_mistral': 3486, 'n_tokens_neox': 3212, 'n_words': 1066}