Normalize the element type of ListPat, fix #14547

Summary:
The element type of `List` maybe a type family instacen, rather than a trivial type.
For example in Trac #14547,

```
{-# LANGUAGE TypeFamilies, OverloadedLists #-}

class Foo f where
        type It f
        foo :: [It f] -> f

data List a = Empty | a :! List a deriving Show

instance Foo (List a) where
        type It (List a) = a
        foo [] = Empty
        foo (x : xs) = x :! foo xs
```

Here the element type of `[]` is `It (List a)`, we should also normalize
it as `a`.

Test Plan: make test TEST="T14547"

Reviewers: bgamari

Reviewed By: bgamari

Subscribers: thomie, carter

GHC Trac Issues: #14547

Differential Revision: https://phabricator.haskell.org/D4624

3 files changed, 43 insertions, 13 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 545aacef51..b383fb2f5d 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
@@ -1073,7 +1087,7 @@ An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The
 problem is exactly like above, as its solution. For future reference, the code
 below is the *right thing to do*:
 
-   ListPat lpats elem_ty (Just (pat_ty, to_list))
+   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
      otherwise -> do
        (xp, xe) <- mkPmId2Forms pat_ty
        ps       <- translatePatVec (map unLoc lpats)
diff --git a/testsuite/tests/deSugar/should_compile/T14547.hs b/testsuite/tests/deSugar/should_compile/T14547.hs
new file mode 100644
index 0000000000..02ff2e618c
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14547.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T14547 where
+
+class Foo f where
+        type It f
+        foo :: [It f] -> f
+
+data List a = Empty | a :! List a deriving Show
+
+instance Foo (List a) where
+        type It (List a) = a
+        foo [] = Empty
+        foo (x : xs) = x :! foo xs
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 2d361464a6..14140737d8 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -100,6 +100,7 @@ test('T13290', normal, compile, [''])
 test('T13257', normal, compile, [''])
 test('T13870', normal, compile, [''])
 test('T14135', normal, compile, [''])
+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'])