diff options
| -rw-r--r-- | compiler/deSugar/Check.hs | 38 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/all.T | 2 |
2 files changed, 27 insertions, 13 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index ba6415402a..201ed12571 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -53,6 +53,7 @@ import Type import UniqSupply import DsGRHSs (isTrueLHsExpr) import Maybes (expectJust) +import qualified GHC.LanguageExtensions as LangExt import Data.List (find) import Data.Maybe (catMaybes, isJust, fromMaybe) @@ -788,18 +789,31 @@ translatePat fam_insts pat = case pat of <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list - ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats - | Just e_ty <- splitListTyConApp_maybe pat_ty - , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty - -- elem_ty is frequently something like - -- `Item [Int]`, but we prefer `Int` - , norm_elem_ty `eqType` e_ty -> - -- We have to ensure that the element types are exactly the same. - -- Otherwise, one may give an instance IsList [Int] (more specific than - -- the default IsList [a]) with a different implementation for `toList' - translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats) - -- See Note [Guards and Approximation] - | otherwise -> mkCanFailPmPat pat_ty + ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do + dflags <- getDynFlags + if xopt LangExt.RebindableSyntax dflags + then mkCanFailPmPat pat_ty + else case splitListTyConApp_maybe pat_ty of + Just e_ty -> translatePat fam_insts + (ListPat (ListPatTc e_ty Nothing) lpats) + Nothing -> mkCanFailPmPat pat_ty + -- (a) In the presence of RebindableSyntax, we don't know anything about + -- `toList`, we should treat `ListPat` as any other view pattern. + -- + -- (b) In the absence of RebindableSyntax, + -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern + -- as ordinary list pattern. Although we can give an instance + -- `IsList [Int]` (more specific than the default `IsList [a]`), in + -- practice, we almost never do that. We assume the `_to_list` is + -- the `toList` from `instance IsList [a]`. + -- + -- - Otherwise, we treat the `ListPat` as ordinary view pattern. + -- + -- See Trac #14547, especially comment#9 and comment#10. + -- + -- Here we construct CanFailPmPat directly, rather can construct a view + -- pattern and do further translation as an optimization, for the reason, + -- see Note [Guards and Approximation]. ConPatOut { pat_con = L _ con , pat_arg_tys = arg_tys diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T index 3aadbea5d4..9951047e99 100644 --- a/testsuite/tests/deSugar/should_compile/all.T +++ b/testsuite/tests/deSugar/should_compile/all.T @@ -103,7 +103,7 @@ test('T14135', normal, compile, ['']) test('T14546a', normal, compile, ['-Wincomplete-patterns']) test('T14546b', normal, compile, ['-Wincomplete-patterns']) test('T14546c', normal, compile, ['-Wincomplete-patterns']) -test('T14547', expect_broken(15222), compile, ['-Wincomplete-patterns']) +test('T14547', normal, compile, ['-Wincomplete-patterns']) test('T14773a', normal, compile, ['-Wincomplete-patterns']) test('T14773b', normal, compile, ['-Wincomplete-patterns']) test('T14815', [], run_command, ['$MAKE -s --no-print-directory T14815']) |