MatchLit.lhs 5.95 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
%
4
\section[MatchLit]{Pattern-matching literal patterns}
5 6 7 8

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

9
module MatchLit ( matchLiterals ) where
10

11 12
IMP_Ubiq()
IMPORT_DELOOPER(DsLoop)		-- break match-ish and dsExpr-ish loops
13

14
import HsSyn		( HsLit(..), OutPat(..), HsExpr(..),
15
			  Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
16 17
import TcHsSyn		( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
			  SYN_IE(TypecheckedPat)
18
			)
19
import CoreSyn		( SYN_IE(CoreExpr), SYN_IE(CoreBinding) )
20 21

import DsMonad
22
import DsUtils
23 24 25 26 27

import Literal		( mkMachInt, Literal(..) )
import Maybes		( catMaybes )
import Type		( isPrimType )
import Util		( panic, assertPanic )
28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
\end{code}

\begin{code}
matchLiterals :: [Id]
	      -> [EquationInfo]
	      -> [EquationInfo]		-- Shadows
	      -> DsM MatchResult
\end{code}

This first one is a {\em special case} where the literal patterns are
unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@).  We
want to avoid using the ``equality'' stuff provided by the
typechecker, and do a real ``case'' instead.  In that sense, the code
is much like @matchConFamily@, which uses @match_cons_used@ to create
the alts---here we use @match_prims_used@.

\begin{code}
matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps1) _ : eqns) shadows
  = -- GENERATE THE ALTS
    match_prims_used vars eqns_info shadows `thenDs` \ prim_alts ->

    -- MAKE THE PRIMITIVE CASE
    mkCoPrimCaseMatchResult var prim_alts
  where
    match_prims_used _ [{-no more eqns-}] _ = returnDs []

54
    match_prims_used vars eqns_info@(EqnInfo ((LitPat literal lit_ty):ps1) _ : eqns) shadows
55 56
      = let
	    (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
57
	      = partitionEqnsByLit literal eqns_info
58
	    (shifted_shadows_for_this_lit, shadows_not_for_this_lit)
59
	      = partitionEqnsByLit literal shadows
60 61 62 63 64 65 66 67
	in
	-- recursive call to make other alts...
	match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit	`thenDs` \ rest_of_alts ->

	-- (prim pats have no args; no selectMatchVars as in match_cons_used)
	-- now do the business to make the alt for _this_ LitPat ...
	match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit	`thenDs` \ match_result ->
	returnDs (
68
	    (mk_core_lit lit_ty literal, match_result)
69 70 71
	    : rest_of_alts
	)
      where
72 73 74 75 76 77 78 79
	mk_core_lit :: Type -> HsLit -> Literal

	mk_core_lit ty (HsIntPrim     i) = mkMachInt  i
	mk_core_lit ty (HsCharPrim    c) = MachChar   c
	mk_core_lit ty (HsStringPrim  s) = MachStr    s
	mk_core_lit ty (HsFloatPrim   f) = MachFloat  f
	mk_core_lit ty (HsDoublePrim  d) = MachDouble d
	mk_core_lit ty (HsLitLit      s) = ASSERT(isPrimType ty)
80
					   MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
81
    	mk_core_lit ty other	         = panic "matchLiterals:mk_core_lit:unhandled"
82 83 84 85 86 87
\end{code}

\begin{code}
matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows
  = let
	(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
88
	  = partitionEqnsByLit literal eqns_info
89
	(shifted_shadows_for_this_lit, shadows_not_for_this_lit)
90
	  = partitionEqnsByLit literal shadows
91
    in
92
    dsExpr (HsApp eq_chk (HsVar var))					`thenDs` \ pred_expr ->
93 94 95 96
    match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit	`thenDs` \ inner_match_result ->
    mkGuardedMatchResult pred_expr inner_match_result			`thenDs` \ match_result1 ->

    if (null eqns_not_for_this_lit)
97
    then
98
	returnDs match_result1
99
    else
100 101 102 103 104 105 106 107 108 109 110 111 112 113
	matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit 	`thenDs` \ match_result2 ->
	combineMatchResults match_result1 match_result2
\end{code}

For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
    if ge var lit then
	let n = sub var lit
	in  <expr-for-a-successful-match>
    else
	<try-next-pattern-or-whatever>
\end{verbatim}

114
Given a blob of LitPats/NPats, we want to split them into those
115
that are ``same''/different as one we are looking at.  We need to know
116
whether we're looking at a LitPat/NPat, and what literal we're after.
117 118

\begin{code}
119
partitionEqnsByLit :: HsLit
120 121 122 123 124 125 126 127
		   -> [EquationInfo]
		   -> ([EquationInfo], 	-- These ones are for this lit, AND
					-- they've been "shifted" by stripping
					-- off the first pattern
		       [EquationInfo]	-- These are not for this lit; they
					-- are exactly as fed in.
		      )

128
partitionEqnsByLit lit eqns
129
  = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
130
	(unzip (map (partition_eqn lit) eqns))
131
  where
132
    partition_eqn :: HsLit -> EquationInfo ->
133 134
		(Maybe EquationInfo, Maybe EquationInfo)

135
    partition_eqn lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
136 137 138
      | lit `eq_lit` k  = (Just (EqnInfo remaining_pats match_result), Nothing)
			  -- NB the pattern is stripped off thhe EquationInfo

139
    partition_eqn lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
140 141 142 143
      | lit `eq_lit` k  = (Just (EqnInfo remaining_pats match_result), Nothing)
			  -- NB the pattern is stripped off thhe EquationInfo

	-- Wild-card patterns, which will only show up in the shadows, go into both groups
144
    partition_eqn lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result)
145 146 147
			= (Just (EqnInfo remaining_pats match_result), Just eqn)

	-- Default case; not for this pattern
148
    partition_eqn lit eqn = (Nothing, Just eqn)
149 150 151

-- ToDo: meditate about this equality business...

152 153 154 155 156 157 158 159 160 161 162 163
eq_lit (HsInt  i1)   	 (HsInt  i2)       = i1 == i2
eq_lit (HsFrac f1) 	 (HsFrac f2)       = f1 == f2

eq_lit (HsIntPrim i1)	 (HsIntPrim i2)    = i1 == i2
eq_lit (HsFloatPrim f1)  (HsFloatPrim f2)  = f1 == f2
eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2
eq_lit (HsChar c1) 	 (HsChar c2)       = c1 == c2
eq_lit (HsCharPrim c1)	 (HsCharPrim c2)   = c1 == c2
eq_lit (HsString s1)	 (HsString s2)     = s1 == s2
eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2
eq_lit (HsLitLit s1)	 (HsLitLit s2)     = s1 == s2 -- ToDo: ??? (dubious)
eq_lit other1	      	 other2		   = panic "matchLiterals:eq_lit"
164
\end{code}