[commit: ghc] master: Fix broken test T14547. (d8efb09)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d8efb0983cf90aa4224cb62ce8d7fb37e7e6dffb/ghc

>---------------------------------------------------------------

commit d8efb0983cf90aa4224cb62ce8d7fb37e7e6dffb
Author: HE, Tao <sighingnow at gmail.com>
Date:   Sun Jun 3 17:18:54 2018 -0400

    Fix broken test T14547.
    
    Phab:D4571 lags behind HEAD for too many commits. The commit of
    Phab:4571 1f88f541aad1e36d01f22f9e71dfbc247e6558e2 brought some
    unintentional changes (not belong to [Phab:4571's Diff
    16314](https://phabricator.haskell.org/differential/diff/16314/)) into
    ghc-head, breaking T14557.
    
    Let's fix that.
    
    Test Plan: make test TEST="T14547"
    
    Reviewers: bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie, carter
    
    GHC Trac Issues: #15222
    
    Differential Revision: https://phabricator.haskell.org/D4778


>---------------------------------------------------------------

d8efb0983cf90aa4224cb62ce8d7fb37e7e6dffb
 compiler/deSugar/Check.hs                    | 38 +++++++++++++++++++---------
 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 ba64154..201ed12 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 3aadbea..9951047 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'])