From: simonpj Date: Mon, 8 Nov 1999 16:38:26 +0000 (+0000) Subject: [project @ 1999-11-08 16:38:24 by simonpj] X-Git-Tag: Approximately_9120_patches~5592 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=03434db2706b0a8a15956e07cf3445b11b645260;p=ghc-hetmet.git [project @ 1999-11-08 16:38:24 by simonpj] Deal better with lit-lit pats --- diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index b71eb26..cefba7e 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 7cb082f..c1c822d 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 890cba9..fcc65af 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 25797ca..2056b89 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} %************************************************************************