<commit_before>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsUtils]{Utilities for desugaring}

This module exports some utility functions of no great interest.

\begin{code}
module DsUtils (
	EquationInfo(..), 
	firstPat, shiftEqns,

	mkDsLet, mkDsLets,

	MatchResult(..), CanItFail(..), 
	cantFailMatchResult, alwaysFailMatchResult,
	extractMatchResult, combineMatchResults, 
	adjustMatchResult,  adjustMatchResultDs,
	mkCoLetMatchResult, mkGuardedMatchResult, 
	matchCanFail,
	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
	wrapBind, wrapBinds,

	mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
	mkIntExpr, mkCharExpr,
	mkStringExpr, mkStringExprFS, mkIntegerExpr, 

	mkSelectorBinds, mkTupleExpr, mkTupleSelector, 
	mkTupleType, mkTupleCase, mkBigCoreTup,
	mkCoreTup, mkCoreTupTy,
	
	dsSyntaxTable, lookupEvidence,

	selectSimpleMatchVarL, selectMatchVars
    ) where

#include "HsVersions.h"

import {-# SOURCE #-}	Match ( matchSimply )
import {-# SOURCE #-}	DsExpr( dsExpr )

import HsSyn
import TcHsSyn		( hsPatType )
import CoreSyn
import Constants	( mAX_TUPLE_SIZE )
import DsMonad

import CoreUtils	( exprType, mkIfThenElse, mkCoerce, bindNonRec )
import MkId		( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id		( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
import Var		( Var )
import Name		( Name )
import Literal		( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
import TyCon		( isNewTyCon, tyConDataCons )
import DataCon		( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
import Type		( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
import TcType		( tcEqType )
import TysPrim		( intPrimTy )
import TysWiredIn	( nilDataCon, consDataCon, 
                          tupleCon, mkTupleTy,
			  unitDataConId, unitTy,
                          charTy, charDataCon, 
                          intTy, intDataCon, 
			  isPArrFakeCon )
import BasicTypes	( Boxity(..) )
import UniqSet		( mkUniqSet, minusUniqSet, isEmptyUniqSet )
import UniqSupply	( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
import PrelNames	( unpackCStringName, unpackCStringUtf8Name, 
			  plusIntegerName, timesIntegerName, smallIntegerDataConName, 
			  lengthPName, indexPName )
import Outputable
import SrcLoc		( Located(..), unLoc )
import Util             ( isSingleton, notNull, zipEqual, sortWith )
import ListSetOps	( assocDefault )
import FastString

import Data.Char	( ord )
\end{code}



%************************************************************************
%*									*
		Rebindable syntax
%*									*
%************************************************************************

\begin{code}
dsSyntaxTable :: SyntaxTable Id 
	       -> DsM ([CoreBind], 	-- Auxiliary bindings
		       [(Name,Id)])	-- Maps the standard name to its value

dsSyntaxTable rebound_ids
  = mapAndUnzipDs mk_bind rebound_ids	`thenDs` \ (binds_s, prs) ->
    return (concat binds_s, prs)
  where
	-- The cheapo special case can happen when we 
	-- make an intermediate HsDo when desugaring a RecStmt
    mk_bind (std_name, HsVar id) = return ([], (std_name, id))
    mk_bind (std_name, expr)
 	 = dsExpr expr				`thenDs` \ rhs ->
     	   newSysLocalDs (exprType rhs)		`thenDs` \ id ->
     	   return ([NonRec id rhs], (std_name, id))

lookupEvidence :: [(Name, Id)] -> Name -> Id
lookupEvidence prs std_name
  = assocDefault (mk_panic std_name) prs std_name
  where
    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
\end{code}


%************************************************************************
%*									*
\subsection{Building lets}
%*									*
%************************************************************************

Use case, not let for unlifted types.  The simplifier will turn some
back again.

\begin{code}
mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
mkDsLet (NonRec bndr rhs) body
  | isUnLiftedType (idType bndr) 
  = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
mkDsLet bind body
  = Let bind body

mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkDsLets binds body = foldr mkDsLet body binds
\end{code}


%************************************************************************
%*									*
\subsection{ Selecting match variables}
%*									*
%************************************************************************

We're about to match against some patterns.  We want to make some
@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.

\begin{code}
selectSimpleMatchVarL :: LPat Id -> DsM Id
selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat)

-- (selectMatchVars ps tys) chooses variables of type tys
-- to use for matching ps against.  If the pattern is a variable,
-- we try to use that, to save inventing lots of fresh variables.
-- But even if it is a variable, its type might not match.  Consider
--	data T a where
--	  T1 :: Int -> T Int
--	  T2 :: a   -> T a
--
--	f :: T a -> a -> Int
--	f (T1 i) (x::Int) = x
--	f (T2 i) (y::a)   = 0
-- Then we must not choose (x::Int) as the matching variable!

selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id]
selectMatchVars []     [] 	= return []
selectMatchVars (p:ps) (ty:tys) = do { v  <- selectMatchVar  p  ty
				     ; vs <- selectMatchVars ps tys
				     ; return (v:vs) }

selectMatchVar (LazyPat pat)   pat_ty  = selectMatchVar (unLoc pat) pat_ty
selectMatchVar (VarPat var)    pat_ty  = try_for var 	     pat_ty
selectMatchVar (AsPat var pat) pat_ty  = try_for (unLoc var) pat_ty
selectMatchVar other_pat       pat_ty  = newSysLocalDs pat_ty   -- OK, better make up one...

try_for var pat_ty 
  | idType var `tcEqType` pat_ty = returnDs var
  | otherwise			 = newSysLocalDs pat_ty
\end{code}


%************************************************************************
%*									*
%* type synonym EquationInfo and access functions for its pieces	*
%*									*
%************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}

The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.

\begin{code}
firstPat :: EquationInfo -> Pat Id
firstPat eqn = head (eqn_pats eqn)

shiftEqns :: [EquationInfo] -> [EquationInfo]
-- Drop the first pattern in each equation
shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
\end{code}

Functions on MatchResults

\begin{code}
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanFail _)  = True
matchCanFail (MatchResult CantFail _) = False

alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)

cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)

extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult (MatchResult CantFail match_fn) fail_expr
  = match_fn (error "It can't fail!")

extractMatchResult (MatchResult CanFail match_fn) fail_expr
  = mkFailurePair fail_expr	 	`thenDs` \ (fail_bind, if_it_fails) ->
    match_fn if_it_fails		`thenDs` \ body ->
    returnDs (mkDsLet fail_bind body)


combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults (MatchResult CanFail      body_fn1)
		    (MatchResult can_it_fail2 body_fn2)
  = MatchResult can_it_fail2 body_fn
  where
    body_fn fail = body_fn2 fail			`thenDs` \ body2 ->
		   mkFailurePair body2	 		`thenDs` \ (fail_bind, duplicatable_expr) ->
		   body_fn1 duplicatable_expr		`thenDs` \ body1 ->
		   returnDs (Let fail_bind body1)

combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
  = match_result1

adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
  = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
				      returnDs (encl_fn body))

adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
  = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
				      encl_fn body)

wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)

wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
wrapBind new old body
  | new==old    = body
  | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
  | otherwise   = Let (NonRec new (Var old)) body

mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind match_result
  = adjustMatchResult (mkDsLet bind) match_result

mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
  = MatchResult CanFail (\fail -> body_fn fail	`thenDs` \ body ->
				  returnDs (mkIfThenElse pred_expr body fail))

mkCoPrimCaseMatchResult :: Id				-- Scrutinee
                    -> Type                             -- Type of the case
		    -> [(Literal, MatchResult)]		-- Alternatives
		    -> MatchResult
mkCoPrimCaseMatchResult var ty match_alts
  = MatchResult CanFail mk_case
  where
    mk_case fail
      = mappM (mk_alt fail) sorted_alts		`thenDs` \ alts ->
	returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))

    sorted_alts = sortWith fst match_alts	-- Right order for a Case
    mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail	`thenDs` \ body ->
					       returnDs (LitAlt lit, [], body)


mkCoAlgCaseMatchResult :: Id					-- Scrutinee
                    -> Type                                     -- Type of exp
		    -> [(DataCon, [CoreBndr], MatchResult)]	-- Alternatives
		    -> MatchResult
mkCoAlgCaseMatchResult var ty match_alts 
  | isNewTyCon tycon		-- Newtype case; use a let
  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1

  | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
  = MatchResult CanFail mk_parrCase

  | otherwise			-- Datatype case; use a case
  = MatchResult fail_flag mk_case
  where
    tycon = dataConTyCon con1
	-- [Interesting: becuase of GADTs, we can't rely on the type of 
	--  the scrutinised Id to be sufficiently refined to have a TyCon in it]

	-- Stuff for newtype
    (con1, arg_ids1, match_result1) = head match_alts
    arg_id1 	= head arg_ids1
    newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
		
	-- Stuff for data types
    data_cons      = tyConDataCons tycon
    match_results  = [match_result | (_,_,match_result) <- match_alts]

    fail_flag | exhaustive_case
	      = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
	      | otherwise
	      = CanFail

    wild_var = mkWildId (idType var)
    sorted_alts  = sortWith get_tag match_alts
    get_tag (con, _, _) = dataConTag con
    mk_case fail = mappM (mk_alt fail) sorted_alts	`thenDs` \ alts ->
		   returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))

    mk_alt fail (con, args, MatchResult _ body_fn)
	= body_fn fail				`thenDs` \ body ->
	  newUniqueSupply			`thenDs` \ us ->
	  returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)

    mk_default fail | exhaustive_case = []
		    | otherwise       = [(DEFAULT, [], fail)]

    un_mentioned_constructors
        = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
    exhaustive_case = isEmptyUniqSet un_mentioned_constructors

	-- Stuff for parallel arrays
	-- 
	--  * the following is to desugar cases over fake constructors for
	--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
	--   case
	--
	-- Concerning `isPArrFakeAlts':
	--
	--  * it is *not* sufficient to just check the type of the type
	--   constructor, as we have to be careful not to confuse the real
	--   representation of parallel arrays with the fake constructors;
	--   moreover, a list of alternatives must not mix fake and real
	--   constructors (this is checked earlier on)
	--
	-- FIXME: We actually go through the whole list and make sure that
	--	  either all or none of the constructors are fake parallel
	--	  array constructors.  This is to spot equations that mix fake
	--	  constructors with the real representation defined in
	--	  `PrelPArr'.  It would be nicer to spot this situation
	--	  earlier and raise a proper error message, but it can really
	--	  only happen in `PrelPArr' anyway.
	--
    isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
    isPArrFakeAlts ((dcon, _, _):alts) = 
      case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
        (True , True ) -> True
        (False, False) -> False
	_	       -> 
	  panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
    --
    mk_parrCase fail = 		   
      dsLookupGlobalId lengthPName			`thenDs` \lengthP  ->
      unboxAlt						`thenDs` \alt      ->
      returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
      where
	elemTy      = case splitTyConApp (idType var) of
		        (_, [elemTy]) -> elemTy
		        _	        -> panic panicMsg
        panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
	len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
	--
	unboxAlt = 
	  newSysLocalDs intPrimTy			`thenDs` \l	   ->
	  dsLookupGlobalId indexPName			`thenDs` \indexP   ->
	  mappM (mkAlt indexP) sorted_alts              `thenDs` \alts     ->
	  returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
          where
	    wild = mkWildId intPrimTy
	    dft  = (DEFAULT, [], fail)
	--
	-- each alternative matches one array length (corresponding to one
	-- fake array constructor), so the match is on a literal; each
	-- alternative's body is extended by a local binding for each
	-- constructor argument, which are bound to array elements starting
	-- with the first
	--
	mkAlt indexP (con, args, MatchResult _ bodyFun) = 
	  bodyFun fail					`thenDs` \body     ->
	  returnDs (LitAlt lit, [], mkDsLets binds body)
	  where
	    lit   = MachInt $ toInteger (dataConSourceArity con)
	    binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
	    --
	    indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
\end{code}


%************************************************************************
%*									*
\subsection{Desugarer's versions of some Core functions}
%*									*
%************************************************************************

\begin{code}
mkErrorAppDs :: Id 		-- The error function
	     -> Type		-- Type to which it should be applied
	     -> String		-- The error message string to pass
	     -> DsM CoreExpr

mkErrorAppDs err_id ty msg
  = getSrcSpanDs		`thenDs` \ src_loc ->
    let
	full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
	core_msg = Lit (mkStringLit full_msg)
	-- mkStringLit returns a result of type String#
    in
    returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}


*************************************************************
%*									*
\subsection{Making literals}
%*									*
%************************************************************************

\begin{code}
mkCharExpr     :: Char	     -> CoreExpr      -- Returns	C# c :: Int
mkIntExpr      :: Integer    -> CoreExpr      -- Returns	I# i :: Int
mkIntegerExpr  :: Integer    -> DsM CoreExpr  -- Result :: Integer
mkStringExpr   :: String     -> DsM CoreExpr  -- Result :: String
mkStringExprFS :: FastString -> DsM CoreExpr  -- Result :: String

mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]

mkIntegerExpr i
  | inIntRange i  	-- Small enough, so start from an Int
  = dsLookupDataCon  smallIntegerDataConName	`thenDs` \ integer_dc ->
    returnDs (mkSmallIntegerLit integer_dc i)

-- Special case for integral literals with a large magnitude:
-- They are transformed into an expression involving only smaller
-- integral literals. This improves constant folding.

  | otherwise 		-- Big, so start from a string
  = dsLookupGlobalId plusIntegerName		`thenDs` \ plus_id ->
    dsLookupGlobalId timesIntegerName		`thenDs` \ times_id ->
    dsLookupDataCon  smallIntegerDataConName	`thenDs` \ integer_dc ->
    let 
	lit i = mkSmallIntegerLit integer_dc i
        plus a b  = Var plus_id  `App` a `App` b
        times a b = Var times_id `App` a `App` b

	-- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
	horner :: Integer -> Integer -> CoreExpr
	horner b i | abs q <= 1 = if r == 0 || r == i 
				  then lit i 
				  else lit r `plus` lit (i-r)
	           | r == 0     =               horner b q `times` lit b
	           | otherwise  = lit r `plus` (horner b q `times` lit b)
  		   where
		     (q,r) = i `quotRem` b

    in
    returnDs (horner tARGET_MAX_INT i)

mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]

mkStringExpr str = mkStringExprFS (mkFastString str)

mkStringExprFS str
  | nullFS str
  = returnDs (mkNilExpr charTy)

  | lengthFS str == 1
  = let
	the_char = mkCharExpr (headFS str)
    in
    returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))

  | all safeChar chars
  = dsLookupGlobalId unpackCStringName	`thenDs` \ unpack_id ->
    returnDs (App (Var unpack_id) (Lit (MachStr str)))

  | otherwise
  = dsLookupGlobalId unpackCStringUtf8Name	`thenDs` \ unpack_id ->
    returnDs (App (Var unpack_id) (Lit (MachStr str)))

  where
    chars = unpackFS str
    safeChar c = ord c >= 1 && ord c <= 0xFF
\end{code}


%************************************************************************
%*									*
\subsection[mkSelectorBind]{Make a selector bind}
%*									*
%************************************************************************

This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
\begin{verbatim}
    b = case v of pat' -> b'
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.

ToDo: making these bindings should really depend on whether there's
much work to be done per binding.  If the pattern is complex, it
should be de-mangled once, into a tuple (and then selected from).
Otherwise the demangling can be in-line in the bindings (as here).

Boring!  Boring!  One error message per binder.  The above ToDo is
even more helpful.  Something very similar happens for pattern-bound
expressions.

\begin{code}
mkSelectorBinds :: LPat Id	-- The pattern
		-> CoreExpr	-- Expression to which the pattern is bound<commit_msg>[project @ 2006-01-11 13:12:09 by simonmar] fix string desugaring: we can only use the ASCII unpackCString# if all the chars are <= 0x7F, not <= 0xFF.<commit_after>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsUtils]{Utilities for desugaring}

This module exports some utility functions of no great interest.

\begin{code}
module DsUtils (
	EquationInfo(..), 
	firstPat, shiftEqns,

	mkDsLet, mkDsLets,

	MatchResult(..), CanItFail(..), 
	cantFailMatchResult, alwaysFailMatchResult,
	extractMatchResult, combineMatchResults, 
	adjustMatchResult,  adjustMatchResultDs,
	mkCoLetMatchResult, mkGuardedMatchResult, 
	matchCanFail,
	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
	wrapBind, wrapBinds,

	mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
	mkIntExpr, mkCharExpr,
	mkStringExpr, mkStringExprFS, mkIntegerExpr, 

	mkSelectorBinds, mkTupleExpr, mkTupleSelector, 
	mkTupleType, mkTupleCase, mkBigCoreTup,
	mkCoreTup, mkCoreTupTy,
	
	dsSyntaxTable, lookupEvidence,

	selectSimpleMatchVarL, selectMatchVars
    ) where

#include "HsVersions.h"

import {-# SOURCE #-}	Match ( matchSimply )
import {-# SOURCE #-}	DsExpr( dsExpr )

import HsSyn
import TcHsSyn		( hsPatType )
import CoreSyn
import Constants	( mAX_TUPLE_SIZE )
import DsMonad

import CoreUtils	( exprType, mkIfThenElse, mkCoerce, bindNonRec )
import MkId		( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id		( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
import Var		( Var )
import Name		( Name )
import Literal		( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
import TyCon		( isNewTyCon, tyConDataCons )
import DataCon		( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
import Type		( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
import TcType		( tcEqType )
import TysPrim		( intPrimTy )
import TysWiredIn	( nilDataCon, consDataCon, 
                          tupleCon, mkTupleTy,
			  unitDataConId, unitTy,
                          charTy, charDataCon, 
                          intTy, intDataCon, 
			  isPArrFakeCon )
import BasicTypes	( Boxity(..) )
import UniqSet		( mkUniqSet, minusUniqSet, isEmptyUniqSet )
import UniqSupply	( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
import PrelNames	( unpackCStringName, unpackCStringUtf8Name, 
			  plusIntegerName, timesIntegerName, smallIntegerDataConName, 
			  lengthPName, indexPName )
import Outputable
import SrcLoc		( Located(..), unLoc )
import Util             ( isSingleton, notNull, zipEqual, sortWith )
import ListSetOps	( assocDefault )
import FastString

import Data.Char	( ord )
\end{code}



%************************************************************************
%*									*
		Rebindable syntax
%*									*
%************************************************************************

\begin{code}
dsSyntaxTable :: SyntaxTable Id 
	       -> DsM ([CoreBind], 	-- Auxiliary bindings
		       [(Name,Id)])	-- Maps the standard name to its value

dsSyntaxTable rebound_ids
  = mapAndUnzipDs mk_bind rebound_ids	`thenDs` \ (binds_s, prs) ->
    return (concat binds_s, prs)
  where
	-- The cheapo special case can happen when we 
	-- make an intermediate HsDo when desugaring a RecStmt
    mk_bind (std_name, HsVar id) = return ([], (std_name, id))
    mk_bind (std_name, expr)
 	 = dsExpr expr				`thenDs` \ rhs ->
     	   newSysLocalDs (exprType rhs)		`thenDs` \ id ->
     	   return ([NonRec id rhs], (std_name, id))

lookupEvidence :: [(Name, Id)] -> Name -> Id
lookupEvidence prs std_name
  = assocDefault (mk_panic std_name) prs std_name
  where
    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
\end{code}


%************************************************************************
%*									*
\subsection{Building lets}
%*									*
%************************************************************************

Use case, not let for unlifted types.  The simplifier will turn some
back again.

\begin{code}
mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
mkDsLet (NonRec bndr rhs) body
  | isUnLiftedType (idType bndr) 
  = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
mkDsLet bind body
  = Let bind body

mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkDsLets binds body = foldr mkDsLet body binds
\end{code}


%************************************************************************
%*									*
\subsection{ Selecting match variables}
%*									*
%************************************************************************

We're about to match against some patterns.  We want to make some
@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.

\begin{code}
selectSimpleMatchVarL :: LPat Id -> DsM Id
selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat)

-- (selectMatchVars ps tys) chooses variables of type tys
-- to use for matching ps against.  If the pattern is a variable,
-- we try to use that, to save inventing lots of fresh variables.
-- But even if it is a variable, its type might not match.  Consider
--	data T a where
--	  T1 :: Int -> T Int
--	  T2 :: a   -> T a
--
--	f :: T a -> a -> Int
--	f (T1 i) (x::Int) = x
--	f (T2 i) (y::a)   = 0
-- Then we must not choose (x::Int) as the matching variable!

selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id]
selectMatchVars []     [] 	= return []
selectMatchVars (p:ps) (ty:tys) = do { v  <- selectMatchVar  p  ty
				     ; vs <- selectMatchVars ps tys
				     ; return (v:vs) }

selectMatchVar (LazyPat pat)   pat_ty  = selectMatchVar (unLoc pat) pat_ty
selectMatchVar (VarPat var)    pat_ty  = try_for var 	     pat_ty
selectMatchVar (AsPat var pat) pat_ty  = try_for (unLoc var) pat_ty
selectMatchVar other_pat       pat_ty  = newSysLocalDs pat_ty   -- OK, better make up one...

try_for var pat_ty 
  | idType var `tcEqType` pat_ty = returnDs var
  | otherwise			 = newSysLocalDs pat_ty
\end{code}


%************************************************************************
%*									*
%* type synonym EquationInfo and access functions for its pieces	*
%*									*
%************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}

The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.

\begin{code}
firstPat :: EquationInfo -> Pat Id
firstPat eqn = head (eqn_pats eqn)

shiftEqns :: [EquationInfo] -> [EquationInfo]
-- Drop the first pattern in each equation
shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
\end{code}

Functions on MatchResults

\begin{code}
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanFail _)  = True
matchCanFail (MatchResult CantFail _) = False

alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)

cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)

extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult (MatchResult CantFail match_fn) fail_expr
  = match_fn (error "It can't fail!")

extractMatchResult (MatchResult CanFail match_fn) fail_expr
  = mkFailurePair fail_expr	 	`thenDs` \ (fail_bind, if_it_fails) ->
    match_fn if_it_fails		`thenDs` \ body ->
    returnDs (mkDsLet fail_bind body)


combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults (MatchResult CanFail      body_fn1)
		    (MatchResult can_it_fail2 body_fn2)
  = MatchResult can_it_fail2 body_fn
  where
    body_fn fail = body_fn2 fail			`thenDs` \ body2 ->
		   mkFailurePair body2	 		`thenDs` \ (fail_bind, duplicatable_expr) ->
		   body_fn1 duplicatable_expr		`thenDs` \ body1 ->
		   returnDs (Let fail_bind body1)

combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
  = match_result1

adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
  = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
				      returnDs (encl_fn body))

adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
  = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
				      encl_fn body)

wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)

wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
wrapBind new old body
  | new==old    = body
  | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
  | otherwise   = Let (NonRec new (Var old)) body

mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind match_result
  = adjustMatchResult (mkDsLet bind) match_result

mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
  = MatchResult CanFail (\fail -> body_fn fail	`thenDs` \ body ->
				  returnDs (mkIfThenElse pred_expr body fail))

mkCoPrimCaseMatchResult :: Id				-- Scrutinee
                    -> Type                             -- Type of the case
		    -> [(Literal, MatchResult)]		-- Alternatives
		    -> MatchResult
mkCoPrimCaseMatchResult var ty match_alts
  = MatchResult CanFail mk_case
  where
    mk_case fail
      = mappM (mk_alt fail) sorted_alts		`thenDs` \ alts ->
	returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))

    sorted_alts = sortWith fst match_alts	-- Right order for a Case
    mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail	`thenDs` \ body ->
					       returnDs (LitAlt lit, [], body)


mkCoAlgCaseMatchResult :: Id					-- Scrutinee
                    -> Type                                     -- Type of exp
		    -> [(DataCon, [CoreBndr], MatchResult)]	-- Alternatives
		    -> MatchResult
mkCoAlgCaseMatchResult var ty match_alts 
  | isNewTyCon tycon		-- Newtype case; use a let
  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1

  | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
  = MatchResult CanFail mk_parrCase

  | otherwise			-- Datatype case; use a case
  = MatchResult fail_flag mk_case
  where
    tycon = dataConTyCon con1
	-- [Interesting: becuase of GADTs, we can't rely on the type of 
	--  the scrutinised Id to be sufficiently refined to have a TyCon in it]

	-- Stuff for newtype
    (con1, arg_ids1, match_result1) = head match_alts
    arg_id1 	= head arg_ids1
    newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
		
	-- Stuff for data types
    data_cons      = tyConDataCons tycon
    match_results  = [match_result | (_,_,match_result) <- match_alts]

    fail_flag | exhaustive_case
	      = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
	      | otherwise
	      = CanFail

    wild_var = mkWildId (idType var)
    sorted_alts  = sortWith get_tag match_alts
    get_tag (con, _, _) = dataConTag con
    mk_case fail = mappM (mk_alt fail) sorted_alts	`thenDs` \ alts ->
		   returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))

    mk_alt fail (con, args, MatchResult _ body_fn)
	= body_fn fail				`thenDs` \ body ->
	  newUniqueSupply			`thenDs` \ us ->
	  returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)

    mk_default fail | exhaustive_case = []
		    | otherwise       = [(DEFAULT, [], fail)]

    un_mentioned_constructors
        = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
    exhaustive_case = isEmptyUniqSet un_mentioned_constructors

	-- Stuff for parallel arrays
	-- 
	--  * the following is to desugar cases over fake constructors for
	--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
	--   case
	--
	-- Concerning `isPArrFakeAlts':
	--
	--  * it is *not* sufficient to just check the type of the type
	--   constructor, as we have to be careful not to confuse the real
	--   representation of parallel arrays with the fake constructors;
	--   moreover, a list of alternatives must not mix fake and real
	--   constructors (this is checked earlier on)
	--
	-- FIXME: We actually go through the whole list and make sure that
	--	  either all or none of the constructors are fake parallel
	--	  array constructors.  This is to spot equations that mix fake
	--	  constructors with the real representation defined in
	--	  `PrelPArr'.  It would be nicer to spot this situation
	--	  earlier and raise a proper error message, but it can really
	--	  only happen in `PrelPArr' anyway.
	--
    isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
    isPArrFakeAlts ((dcon, _, _):alts) = 
      case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
        (True , True ) -> True
        (False, False) -> False
	_	       -> 
	  panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
    --
    mk_parrCase fail = 		   
      dsLookupGlobalId lengthPName			`thenDs` \lengthP  ->
      unboxAlt						`thenDs` \alt      ->
      returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
      where
	elemTy      = case splitTyConApp (idType var) of
		        (_, [elemTy]) -> elemTy
		        _	        -> panic panicMsg
        panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
	len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
	--
	unboxAlt = 
	  newSysLocalDs intPrimTy			`thenDs` \l	   ->
	  dsLookupGlobalId indexPName			`thenDs` \indexP   ->
	  mappM (mkAlt indexP) sorted_alts              `thenDs` \alts     ->
	  returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
          where
	    wild = mkWildId intPrimTy
	    dft  = (DEFAULT, [], fail)
	--
	-- each alternative matches one array length (corresponding to one
	-- fake array constructor), so the match is on a literal; each
	-- alternative's body is extended by a local binding for each
	-- constructor argument, which are bound to array elements starting
	-- with the first
	--
	mkAlt indexP (con, args, MatchResult _ bodyFun) = 
	  bodyFun fail					`thenDs` \body     ->
	  returnDs (LitAlt lit, [], mkDsLets binds body)
	  where
	    lit   = MachInt $ toInteger (dataConSourceArity con)
	    binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
	    --
	    indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
\end{code}


%************************************************************************
%*									*
\subsection{Desugarer's versions of some Core functions}
%*									*
%************************************************************************

\begin{code}
mkErrorAppDs :: Id 		-- The error function
	     -> Type		-- Type to which it should be applied
	     -> String		-- The error message string to pass
	     -> DsM CoreExpr

mkErrorAppDs err_id ty msg
  = getSrcSpanDs		`thenDs` \ src_loc ->
    let
	full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
	core_msg = Lit (mkStringLit full_msg)
	-- mkStringLit returns a result of type String#
    in
    returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}


*************************************************************
%*									*
\subsection{Making literals}
%*									*
%************************************************************************

\begin{code}
mkCharExpr     :: Char	     -> CoreExpr      -- Returns	C# c :: Int
mkIntExpr      :: Integer    -> CoreExpr      -- Returns	I# i :: Int
mkIntegerExpr  :: Integer    -> DsM CoreExpr  -- Result :: Integer
mkStringExpr   :: String     -> DsM CoreExpr  -- Result :: String
mkStringExprFS :: FastString -> DsM CoreExpr  -- Result :: String

mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]

mkIntegerExpr i
  | inIntRange i  	-- Small enough, so start from an Int
  = dsLookupDataCon  smallIntegerDataConName	`thenDs` \ integer_dc ->
    returnDs (mkSmallIntegerLit integer_dc i)

-- Special case for integral literals with a large magnitude:
-- They are transformed into an expression involving only smaller
-- integral literals. This improves constant folding.

  | otherwise 		-- Big, so start from a string
  = dsLookupGlobalId plusIntegerName		`thenDs` \ plus_id ->
    dsLookupGlobalId timesIntegerName		`thenDs` \ times_id ->
    dsLookupDataCon  smallIntegerDataConName	`thenDs` \ integer_dc ->
    let 
	lit i = mkSmallIntegerLit integer_dc i
        plus a b  = Var plus_id  `App` a `App` b
        times a b = Var times_id `App` a `App` b

	-- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
	horner :: Integer -> Integer -> CoreExpr
	horner b i | abs q <= 1 = if r == 0 || r == i 
				  then lit i 
				  else lit r `plus` lit (i-r)
	           | r == 0     =               horner b q `times` lit b
	           | otherwise  = lit r `plus` (horner b q `times` lit b)
  		   where
		     (q,r) = i `quotRem` b

    in
    returnDs (horner tARGET_MAX_INT i)

mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]

mkStringExpr str = mkStringExprFS (mkFastString str)

mkStringExprFS str
  | nullFS str
  = returnDs (mkNilExpr charTy)

  | lengthFS str == 1
  = let
	the_char = mkCharExpr (headFS str)
    in
    returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))

  | all safeChar chars
  = dsLookupGlobalId unpackCStringName	`thenDs` \ unpack_id ->
    returnDs (App (Var unpack_id) (Lit (MachStr str)))

  | otherwise
  = dsLookupGlobalId unpackCStringUtf8Name	`thenDs` \ unpack_id ->
    returnDs (App (Var unpack_id) (Lit (MachStr str)))

  where
    chars = unpackFS str
    safeChar c = ord c >= 1 && ord c <= 0x7F
\end{code}


%************************************************************************
%*									*
\subsection[mkSelectorBind]{Make a selector bind}
%*									*
%************************************************************************

This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
\begin{verbatim}
    b = case v of pat' -> b'
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.

ToDo: making these bindings should really depend on whether there's
much work to be done per binding.  If the pattern is complex, it
should be de-mangled once, into a tuple (and then selected from).
Otherwise the demangling can be in-line in the bindings (as here).

Boring!  Boring!  One error message per binder.  The above ToDo is
even more helpful.  Something very similar happens for pattern-bound
expressions.

\begin{code}
mkSelectorBinds :: LPat Id	-- The pattern
		-> CoreExpr	-- Expression to which the pattern is bound
{'fraction_non_alphanumeric': 0.14309346567411083, 'fraction_numerical': 0.0032017930040822862, 'mean_word_length': 3.3214573965179293, 'pattern_counts': {'":': 0, '<': 27, '<?xml version=': 0, '>': 195, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4916474', 'n_tokens_mistral': 12925, 'n_tokens_neox': 11829, 'n_words': 3787}