[project @ 1999-11-08 16:38:24 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsUtils.lhs

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 7cb082f..c1c822d 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -10,6 +10,8 @@ module DsUtils (
        CanItFail(..), EquationInfo(..), MatchResult(..),
         EqnNo, EqnSet,
 
+       tidyLitPat, 
+
        mkDsLet, mkDsLets,
 
        cantFailMatchResult, extractMatchResult,
@@ -55,9 +57,61 @@ import Outputable
 \end{code}
 
 
+
+%************************************************************************
+%*                                                                     *
+\subsection{Tidying lit pats}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+tidyLitPat lit lit_ty default_pat
+  | lit_ty == charTy      = ConPat charDataCon   lit_ty [] [] [LitPat (mk_char lit)   charPrimTy]
+  | lit_ty == intTy              = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
+  | lit_ty == wordTy             = ConPat wordDataCon   lit_ty [] [] [LitPat (mk_word lit)   wordPrimTy]
+  | lit_ty == addrTy             = ConPat addrDataCon   lit_ty [] [] [LitPat (mk_addr lit)   addrPrimTy]
+  | lit_ty == floatTy            = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
+  | lit_ty == doubleTy           = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
+
+               -- Convert the literal pattern "" to the constructor pattern [].
+  | null_str_lit lit       = ConPat nilDataCon lit_ty [] [] [] 
+               -- Similar special case for "x"
+  | one_str_lit        lit        = ConPat consDataCon lit_ty [] [] 
+                               [mk_first_char_lit lit, ConPat nilDataCon lit_ty [] [] []]
+
+  | otherwise = default_pat
+
+  where
+    mk_int    (HsInt i)      = HsIntPrim i
+    mk_int    l@(HsLitLit s) = l
+
+    mk_char   (HsChar c)     = HsCharPrim c
+    mk_char   l@(HsLitLit s) = l
+
+    mk_word   l@(HsLitLit s) = l
+
+    mk_addr   l@(HsLitLit s) = l
+
+    mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
+    mk_float  (HsFrac f)     = HsFloatPrim f
+    mk_float  l@(HsLitLit s) = l
+
+    mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
+    mk_double (HsFrac f)     = HsDoublePrim f
+    mk_double l@(HsLitLit s) = l
+
+    null_str_lit (HsString s) = _NULL_ s
+    null_str_lit other_lit    = False
+
+    one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
+    one_str_lit other_lit    = False
+    mk_first_char_lit (HsString s) = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim (_HEAD_ s))]
+\end{code}
+
+
 %************************************************************************
 %*                                                                     *
-\subsection{ Building lets}
+\subsection{Building lets}
 %*                                                                     *
 %************************************************************************