Commit ba6e445e authored by Tao He's avatar Tao He Committed by Ben Gamari

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
parent 849547bd
......@@ -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)
......
{-# 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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment