Commit 03434db2 authored by simonpj's avatar simonpj
Browse files

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

Deal better with lit-lit pats
parent 0b3442cc
......@@ -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
......
......@@ -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}
%* *
%************************************************************************
......
......@@ -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...
......
......@@ -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}
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment