[commit: ghc] master: Normalize the element type of ListPat, fix #14547 (ba6e445)

[git at git.haskell.org]

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

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

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

commit ba6e445e1cf31957f2a327a73f9f66cfa7f24e26
Author: HE, Tao <sighingnow at gmail.com>
Date:   Tue May 8 10:53:41 2018 -0400

    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


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

ba6e445e1cf31957f2a327a73f9f66cfa7f24e26
 compiler/deSugar/Check.hs                        | 40 ++++++++++++++++--------
 testsuite/tests/deSugar/should_compile/T14547.hs | 15 +++++++++
 testsuite/tests/deSugar/should_compile/all.T     |  1 +
 3 files changed, 43 insertions(+), 13 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 545aace..b383fb2 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 0000000..02ff2e6
--- /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 2d36146..1414073 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'])