<commit_before>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}

Handles @HsBinds@; those at the top level require different handling,
in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).

\begin{code}
#include "HsVersions.h"

module DsBinds ( dsBinds, dsMonoBinds ) where

IMP_Ubiq()
IMPORT_DELOOPER(DsLoop)		-- break dsExpr-ish loop

import HsSyn		-- lots of things
import CoreSyn		-- lots of things
import CoreUtils	( coreExprType )
import TcHsSyn		( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
			  SYN_IE(TypecheckedMonoBinds),
			  SYN_IE(TypecheckedPat)
			)
import DsMonad
import DsGRHSs		( dsGuarded )
import DsUtils
import Match		( matchWrapper )

import CmdLineOpts	( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, 
			  opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
import CostCentre	( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
import Id		( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) )
import ListSetOps	( minusList, intersectLists )
import Name		( isExported )
import PprType		( GenType )
import PprStyle		( PprStyle(..) )
import Type		( mkTyVarTy, isDictTy, instantiateTy
			)
import TyVar		( tyVarSetToList, GenTyVar{-instance Eq-} )
import TysPrim		( voidTy )
import Util		( isIn, panic{-, pprTrace ToDo:rm-} )
\end{code}

%************************************************************************
%*									*
\subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
%*									*
%************************************************************************

Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
that some of the binders are of unboxed type.  This is sorted out when
the caller wraps the bindings round an expression.

\begin{code}
dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]

dsBinds EmptyBinds	  	     = returnDs []
dsBinds (ThenBinds  binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2)

dsBinds (MonoBind binds sigs is_rec)
  = dsMonoBinds is_rec binds		`thenDs` \ prs ->
    returnDs (if is_rec then
		[Rec prs]
	      else
		[NonRec binder rhs | (binder,rhs) <- prs]
    )
\end{code}


%************************************************************************
%*									*
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
%*									*
%************************************************************************

\begin{code}
dsMonoBinds :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)]

dsMonoBinds is_rec EmptyMonoBinds = returnDs []

dsMonoBinds is_rec (AndMonoBinds  binds_1 binds_2)
  = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2)

dsMonoBinds is_rec (CoreMonoBind var core_expr)
  = returnDs [(var, core_expr)]

dsMonoBinds is_rec (VarMonoBind var expr)
  = dsExpr expr			`thenDs` \ core_expr ->

	-- Dictionary bindings are always VarMonoBinds, so
	-- we only need do this here
    addDictScc var core_expr	`thenDs` \ core_expr' ->

    returnDs [(var, core_expr')]

dsMonoBinds is_rec (FunMonoBind fun _ matches locn)
  = putSrcLocDs locn	$
    matchWrapper (FunMatch fun) matches error_string	`thenDs` \ (args, body) ->
    returnDs [(fun, mkValLam args body)]
  where
    error_string = "function " ++ showForErr fun

dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn)
  = putSrcLocDs locn $
    dsGuarded grhss_and_binds			`thenDs` \ body_expr ->
    mkSelectorBinds pat body_expr

dsMonoBinds is_rec (AbsBinds [] [] exports binds)	-- Common special case
  = dsMonoBinds is_rec binds			`thenDs` \ prs ->
    returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])

dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
  = dsMonoBinds is_rec binds				`thenDs` \ core_prs ->
    let 
	core_binds | is_rec    = [Rec core_prs]
		   | otherwise = [NonRec b e | (b,e) <- core_prs]

	tup_expr = mkLam all_tyvars dicts $
		   mkCoLetsAny core_binds $
		   mkTupleExpr locals
	locals    = [local | (_, _, local) <- exports]
	local_tys = map idType locals
    in
    newSysLocalDs (coreExprType tup_expr)		`thenDs` \ tup_id ->
    let
	dict_args    = map VarArg dicts

	mk_bind (tyvars, global, local) n	-- locals !! n == local<commit_msg>[project @ 1997-05-26 04:51:57 by sof] Updated imports; common AbsBinds cases optimised<commit_after>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}

Handles @HsBinds@; those at the top level require different handling,
in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).

\begin{code}
#include "HsVersions.h"

module DsBinds ( dsBinds, dsMonoBinds ) where

IMP_Ubiq()
IMPORT_DELOOPER(DsLoop)		-- break dsExpr-ish loop

import HsSyn		-- lots of things
import CoreSyn		-- lots of things
import CoreUtils	( coreExprType )
import TcHsSyn		( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
			  SYN_IE(TypecheckedMonoBinds),
			  SYN_IE(TypecheckedPat)
			)
import DsMonad
import DsGRHSs		( dsGuarded )
import DsUtils
import Match		( matchWrapper )

import CmdLineOpts	( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, 
			  opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
import CostCentre	( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
import Id		( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) )
import ListSetOps	( minusList, intersectLists )
import Name		( isExported )
import PprType		( GenType )
import Outputable	( PprStyle(..) )
import Type		( mkTyVarTy, isDictTy, instantiateTy
			)
import TyVar		( tyVarSetToList, GenTyVar{-instance Eq-} )
import TysPrim		( voidTy )
import Util		( isIn, panic, assertPanic  )
\end{code}

%************************************************************************
%*									*
\subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
%*									*
%************************************************************************

Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
that some of the binders are of unboxed type.  This is sorted out when
the caller wraps the bindings round an expression.

\begin{code}
dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]

dsBinds EmptyBinds	  	     = returnDs []
dsBinds (ThenBinds  binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2)

dsBinds (MonoBind binds sigs is_rec)
  = dsMonoBinds is_rec binds		`thenDs` \ prs ->
    returnDs (if is_rec then
		[Rec prs]
	      else
		[NonRec binder rhs | (binder,rhs) <- prs]
    )
\end{code}


%************************************************************************
%*									*
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
%*									*
%************************************************************************

\begin{code}
dsMonoBinds :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)]

dsMonoBinds is_rec EmptyMonoBinds = returnDs []

dsMonoBinds is_rec (AndMonoBinds  binds_1 binds_2)
  = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2)

dsMonoBinds is_rec (CoreMonoBind var core_expr)
  = returnDs [(var, core_expr)]

dsMonoBinds is_rec (VarMonoBind var expr)
  = dsExpr expr			`thenDs` \ core_expr ->

	-- Dictionary bindings are always VarMonoBinds, so
	-- we only need do this here
    addDictScc var core_expr	`thenDs` \ core_expr' ->

    returnDs [(var, core_expr')]

dsMonoBinds is_rec (FunMonoBind fun _ matches locn)
  = putSrcLocDs locn	$
    matchWrapper (FunMatch fun) matches error_string	`thenDs` \ (args, body) ->
    returnDs [(fun, mkValLam args body)]
  where
    error_string = "function " ++ showForErr fun

dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn)
  = putSrcLocDs locn $
    dsGuarded grhss_and_binds			`thenDs` \ body_expr ->
    mkSelectorBinds pat body_expr

	-- Common special case: no type or dictionary abstraction
dsMonoBinds is_rec (AbsBinds [] [] exports binds)
  = dsMonoBinds is_rec binds			`thenDs` \ prs ->
    returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])

	-- Another common case: one exported variable
	-- All non-recursive bindings come through this way
dsMonoBinds is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
  = ASSERT( all (`elem` tyvars) all_tyvars )
    dsMonoBinds is_rec binds				`thenDs` \ core_prs ->
    let 
	core_binds | is_rec    = [Rec core_prs]
		   | otherwise = [NonRec b e | (b,e) <- core_prs]
    in
    returnDs [(global, mkLam tyvars dicts $ mkCoLetsAny core_binds (Var local))]

dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
  = dsMonoBinds is_rec binds				`thenDs` \ core_prs ->
    let 
	core_binds | is_rec    = [Rec core_prs]
		   | otherwise = [NonRec b e | (b,e) <- core_prs]

	tup_expr = mkLam all_tyvars dicts $
		   mkCoLetsAny core_binds $
		   mkTupleExpr locals
	locals    = [local | (_, _, local) <- exports]
	local_tys = map idType locals
    in
    newSysLocalDs (coreExprType tup_expr)		`thenDs` \ tup_id ->
    let
	dict_args    = map VarArg dicts

	mk_bind (tyvars, global, local) n	-- locals !! n == local
{'fraction_non_alphanumeric': 0.15818838201509683, 'fraction_numerical': 0.005032272180286621, 'mean_word_length': 4.2150598973188815, 'pattern_counts': {'":': 0, '<': 12, '<?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': '4717042', 'n_tokens_mistral': 3589, 'n_tokens_neox': 3290, 'n_words': 848}