From 03434db2706b0a8a15956e07cf3445b11b645260 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 8 Nov 1999 16:38:26 +0000
Subject: [PATCH] [project @ 1999-11-08 16:38:24 by simonpj] Deal better with
lit-lit pats
---
ghc/compiler/deSugar/Check.lhs | 63 ++------------------------------
ghc/compiler/deSugar/DsUtils.lhs | 56 +++++++++++++++++++++++++++-
ghc/compiler/deSugar/Match.lhs | 49 +------------------------
ghc/compiler/typecheck/TcPat.lhs | 8 +++-
4 files changed, 67 insertions(+), 109 deletions(-)
diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index b71eb2632c8f..cefba7e2e8b4 100644
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -18,7 +18,8 @@ import CoreSyn
import DsUtils ( EquationInfo(..),
MatchResult(..),
EqnSet,
- CanItFail(..)
+ CanItFail(..),
+ tidyLitPat
)
import Id ( idType )
import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys,
@@ -645,64 +646,8 @@ simplify_pat (RecPat dc ty ex_tvs dicts idps)
| nm == n = (nm,p):xs
| otherwise = x : insertNm nm p xs
-simplify_pat pat@(LitPat lit lit_ty)
- | isUnboxedType lit_ty = pat
-
- | lit_ty == charTy = ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy]
-
- | otherwise = pprPanic "Check.simplify_pat: LitPat:" (ppr pat)
- where
- mk_char (HsChar c) = HsCharPrim c
-
-simplify_pat (NPat lit lit_ty hsexpr) = better_pat
- where
- better_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 [] [] []
- | lit_ty == stringTy =
- foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
- (ConPat nilDataCon list_ty [] [] [])
- (mk_string lit)
- | otherwise = NPat lit lit_ty hsexpr
-
- list_ty = mkListTy lit_ty
-
- mk_int (HsInt i) = HsIntPrim i
- mk_int l@(HsLitLit s) = l
-
- mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
- mk_string (HsString s) =
- map (\ c -> ConPat charDataCon charTy [] []
- [LitPat (HsCharPrim c) charPrimTy])
- (_UNPK_ s)
-
- 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
+simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit lit_ty pat
+simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyLitPat lit lit_ty pat
simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
WildPat ty
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 7cb082ffca7f..c1c822d1235b 100644
--- 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}
%* *
%************************************************************************
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 890cba9636ab..fcc65af8a1c0 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -525,56 +525,11 @@ tidy1 v (DictPat dicts methods) match_result
-- LitPats: the desugarer only sees these at well-known types
tidy1 v pat@(LitPat lit lit_ty) match_result
- | isUnLiftedType lit_ty
- = returnDs (pat, match_result)
-
- | lit_ty == charTy
- = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy],
- match_result)
-
- | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
- where
- mk_char (HsChar c) = HsCharPrim c
+ = returnDs (tidyLitPat lit lit_ty pat, match_result)
-- NPats: we *might* be able to replace these w/ a simpler form
-
-
tidy1 v pat@(NPat lit lit_ty _) match_result
- = returnDs (better_pat, match_result)
- where
- better_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 [] [] []
-
- | otherwise = pat
-
- 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
+ = returnDs (tidyLitPat lit lit_ty pat, match_result)
-- and everything else goes through unchanged...
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 25797cab21e4..2056b898c4a7 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -283,8 +283,12 @@ tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPr
tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
-tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty = tcSimpleLitPat lit intTy pat_ty
- -- This one looks weird!
+tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty
+ -- cf tcExpr on LitLits
+ = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
+ newDicts (LitLitOrigin (_UNPK_ s))
+ [(cCallableClass, [pat_ty])] `thenNF_Tc` \ (dicts, _) ->
+ returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
\end{code}
%************************************************************************
--
GitLab