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

Desugaring arrow commands

\begin{code}
module DsArrows ( dsProcExpr ) where

#include "HsVersions.h"

import Match
import DsUtils
import DsMonad

import HsSyn	hiding (collectPatBinders, collectPatsBinders )
import TcHsSyn

-- 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 {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )

import TcType
import Type
import CoreSyn
import CoreFVs
import CoreUtils
import MkCore

import Name
import Var
import Id
import PrelInfo
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
import Outputable

import VarSet
import SrcLoc

import Data.List
\end{code}

\begin{code}
data DsCmdEnv = DsCmdEnv {
	meth_binds :: [CoreBind],
	arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
    }

mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
mkCmdEnv ids = do
    (meth_binds, ds_meths) <- dsSyntaxTable ids
    return $ DsCmdEnv {
               meth_binds = meth_binds,
               arr_id     = Var (lookupEvidence ds_meths arrAName),
               compose_id = Var (lookupEvidence ds_meths composeAName),
               first_id   = Var (lookupEvidence ds_meths firstAName),
               app_id     = Var (lookupEvidence ds_meths appAName),
               choice_id  = Var (lookupEvidence ds_meths choiceAName),
               loop_id    = Var (lookupEvidence ds_meths loopAName)
             }

bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
bindCmdEnv ids body = foldr Let body (meth_binds ids)

-- arr :: forall b c. (b -> c) -> a b c
do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]

-- (>>>) :: forall b c d. a b c -> a c d -> a b d
do_compose :: DsCmdEnv -> Type -> Type -> Type ->
		CoreExpr -> CoreExpr -> CoreExpr
do_compose ids b_ty c_ty d_ty f g
  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]

-- first :: forall b c d. a b c -> a (b,d) (c,d)
do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
do_first ids b_ty c_ty d_ty f
  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]

-- app :: forall b c. a (a b c, b) c
do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]

-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
-- note the swapping of d and c
do_choice :: DsCmdEnv -> Type -> Type -> Type ->
		CoreExpr -> CoreExpr -> CoreExpr
do_choice ids b_ty c_ty d_ty f g
  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]

-- loop :: forall b d c. a (b,d) (c,d) -> a b c
-- note the swapping of d and c
do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
do_loop ids b_ty c_ty d_ty f
  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]

-- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
		CoreExpr -> CoreExpr -> CoreExpr
do_map_arrow ids b_ty c_ty d_ty f c
   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c

mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)

-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
mkSndExpr :: Type -> Type -> DsM CoreExpr
mkSndExpr a_ty b_ty = do
    a_var <- newSysLocalDs a_ty
    b_var <- newSysLocalDs b_ty
    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
    return (Lam pair_var
               (coreCasePair pair_var a_var b_var (Var b_var)))
\end{code}

Build case analysis of a tuple.  This cannot be done in the DsM monad,
because the list of variables is typically not yet defined.

\begin{code}
-- coreCaseTuple [u1..] v [x1..xn] body
--	= case v of v { (x1, .., xn) -> body }
-- But the matching may be nested if the tuple is very big

coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
coreCaseTuple uniqs scrut_var vars body
  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)

coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
  = Case (Var scrut_var) scrut_var (exprType body)
         [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
\end{code}

\begin{code}
mkCorePairTy :: Type -> Type -> Type
mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]

mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
\end{code}

The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, each element of which is paired
with the stack in turn.  In general, the input has the form

	(...((x1,...,xn),s1),...sk)

where xi are the environment values, and si the ones on the stack,
with s1 being the "top", the first one to be matched with a lambda.

\begin{code}
envStackType :: [Id] -> [Type] -> Type
envStackType ids stack_tys = foldl mkCorePairTy (mkBigCoreVarTupTy ids) stack_tys

----------------------------------------------
--		buildEnvStack
--
--	(...((x1,...,xn),s1),...sk)

buildEnvStack :: [Id] -> [Id] -> CoreExpr
buildEnvStack env_ids stack_ids
  = foldl mkCorePairExpr (mkBigCoreVarTup env_ids) (map Var stack_ids)

----------------------------------------------
-- 		matchEnvStack
--
--	\ (...((x1,...,xn),s1),...sk) -> e
--	=>
--	\ zk ->
--	case zk of (zk-1,sk) ->
--	...
--	case z1 of (z0,s1) ->
--	case z0 of (x1,...,xn) -><commit_msg>minor fix to comment<commit_after>%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

Desugaring arrow commands

\begin{code}
module DsArrows ( dsProcExpr ) where

#include "HsVersions.h"

import Match
import DsUtils
import DsMonad

import HsSyn	hiding (collectPatBinders, collectPatsBinders )
import TcHsSyn

-- 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 {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )

import TcType
import Type
import CoreSyn
import CoreFVs
import CoreUtils
import MkCore

import Name
import Var
import Id
import PrelInfo
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
import Outputable

import VarSet
import SrcLoc

import Data.List
\end{code}

\begin{code}
data DsCmdEnv = DsCmdEnv {
	meth_binds :: [CoreBind],
	arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
    }

mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
mkCmdEnv ids = do
    (meth_binds, ds_meths) <- dsSyntaxTable ids
    return $ DsCmdEnv {
               meth_binds = meth_binds,
               arr_id     = Var (lookupEvidence ds_meths arrAName),
               compose_id = Var (lookupEvidence ds_meths composeAName),
               first_id   = Var (lookupEvidence ds_meths firstAName),
               app_id     = Var (lookupEvidence ds_meths appAName),
               choice_id  = Var (lookupEvidence ds_meths choiceAName),
               loop_id    = Var (lookupEvidence ds_meths loopAName)
             }

bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
bindCmdEnv ids body = foldr Let body (meth_binds ids)

-- arr :: forall b c. (b -> c) -> a b c
do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]

-- (>>>) :: forall b c d. a b c -> a c d -> a b d
do_compose :: DsCmdEnv -> Type -> Type -> Type ->
		CoreExpr -> CoreExpr -> CoreExpr
do_compose ids b_ty c_ty d_ty f g
  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]

-- first :: forall b c d. a b c -> a (b,d) (c,d)
do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
do_first ids b_ty c_ty d_ty f
  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]

-- app :: forall b c. a (a b c, b) c
do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]

-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
-- note the swapping of d and c
do_choice :: DsCmdEnv -> Type -> Type -> Type ->
		CoreExpr -> CoreExpr -> CoreExpr
do_choice ids b_ty c_ty d_ty f g
  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]

-- loop :: forall b d c. a (b,d) (c,d) -> a b c
-- note the swapping of d and c
do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
do_loop ids b_ty c_ty d_ty f
  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]

-- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
		CoreExpr -> CoreExpr -> CoreExpr
do_map_arrow ids b_ty c_ty d_ty f c
   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c

mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)

-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
mkSndExpr :: Type -> Type -> DsM CoreExpr
mkSndExpr a_ty b_ty = do
    a_var <- newSysLocalDs a_ty
    b_var <- newSysLocalDs b_ty
    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
    return (Lam pair_var
               (coreCasePair pair_var a_var b_var (Var b_var)))
\end{code}

Build case analysis of a tuple.  This cannot be done in the DsM monad,
because the list of variables is typically not yet defined.

\begin{code}
-- coreCaseTuple [u1..] v [x1..xn] body
--	= case v of v { (x1, .., xn) -> body }
-- But the matching may be nested if the tuple is very big

coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
coreCaseTuple uniqs scrut_var vars body
  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)

coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
  = Case (Var scrut_var) scrut_var (exprType body)
         [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
\end{code}

\begin{code}
mkCorePairTy :: Type -> Type -> Type
mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]

mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
\end{code}

The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, each element of which is paired
with the environment in turn.  In general, the input has the form

	(...((x1,...,xn),s1),...sk)

where xi are the environment values, and si the ones on the stack,
with s1 being the "top", the first one to be matched with a lambda.

\begin{code}
envStackType :: [Id] -> [Type] -> Type
envStackType ids stack_tys = foldl mkCorePairTy (mkBigCoreVarTupTy ids) stack_tys

----------------------------------------------
--		buildEnvStack
--
--	(...((x1,...,xn),s1),...sk)

buildEnvStack :: [Id] -> [Id] -> CoreExpr
buildEnvStack env_ids stack_ids
  = foldl mkCorePairExpr (mkBigCoreVarTup env_ids) (map Var stack_ids)

----------------------------------------------
-- 		matchEnvStack
--
--	\ (...((x1,...,xn),s1),...sk) -> e
--	=>
--	\ zk ->
--	case zk of (zk-1,sk) ->
--	...
--	case z1 of (z0,s1) ->
--	case z0 of (x1,...,xn) ->
{'fraction_non_alphanumeric': 0.13335700967770575, 'fraction_numerical': 0.007280475894521886, 'mean_word_length': 2.823489477257298, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 165, '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': '3076078', 'n_tokens_mistral': 4221, 'n_tokens_neox': 4097, 'n_words': 1443}