From f1baea4472c8123f7482e316d70415525e0bb4f3 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 23 Mar 2001 17:34:44 +0000 Subject: [PATCH] [project @ 2001-03-23 17:34:44 by simonmar] Fix the long-standing overlapping patterns bug with string-literal patterns. --- ghc/compiler/deSugar/Check.lhs | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 4fcc01a..dd4c9ae 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -13,17 +13,16 @@ module Check ( check , ExhaustivePat ) where import HsSyn import TcHsSyn ( TypecheckedPat ) import DsHsSyn ( outPatType ) -import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..), - tidyLitPat +import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, + CanItFail(..), tidyLitPat, tidyNPat, ) import Id ( idType ) import DataCon ( DataCon, dataConTyCon, dataConArgTys, dataConSourceArity, dataConFieldLabels ) import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc ) import Type ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe ) -import TysWiredIn ( nilDataCon, consDataCon, - mkListTy, mkTupleTy, tupleCon - ) +import TysPrim ( charPrimTy ) +import TysWiredIn import PrelNames ( unboundKey ) import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) import BasicTypes ( Boxity(..) ) @@ -617,7 +616,17 @@ simplify_pat (RecPat dc ty ex_tvs dicts idps) | otherwise = x : insertNm nm p xs simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat -simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyLitPat lit pat + +-- unpack string patterns fully, so we can see when they overlap with +-- each other, or even explicit lists of Chars. +simplify_pat pat@(NPat (HsString s) _ _) = + foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) + (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s) + where + mk_char_lit c = ConPat charDataCon charTy [] [] + [LitPat (HsCharPrim c) charPrimTy] + +simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = WildPat ty -- 1.7.10.4