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

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 ...@@ -53,6 +53,7 @@ import Type
import UniqSupply import UniqSupply
import DsGRHSs (isTrueLHsExpr) import DsGRHSs (isTrueLHsExpr)
import Maybes (expectJust) import Maybes (expectJust)
import qualified GHC.LanguageExtensions as LangExt
import Data.List (find) import Data.List (find)
import Data.Maybe (catMaybes, isJust, fromMaybe) import Data.Maybe (catMaybes, isJust, fromMaybe)
...@@ -788,18 +789,31 @@ translatePat fam_insts pat = case pat of ...@@ -788,18 +789,31 @@ translatePat fam_insts pat = case pat of
<$> translatePatVec fam_insts (map unLoc ps) <$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list -- overloaded list
ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do
| Just e_ty <- splitListTyConApp_maybe pat_ty dflags <- getDynFlags
, (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty if xopt LangExt.RebindableSyntax dflags
-- elem_ty is frequently something like then mkCanFailPmPat pat_ty
-- `Item [Int]`, but we prefer `Int` else case splitListTyConApp_maybe pat_ty of
, norm_elem_ty `eqType` e_ty -> Just e_ty -> translatePat fam_insts
-- We have to ensure that the element types are exactly the same. (ListPat (ListPatTc e_ty Nothing) lpats)
-- Otherwise, one may give an instance IsList [Int] (more specific than Nothing -> mkCanFailPmPat pat_ty
-- the default IsList [a]) with a different implementation for `toList' -- (a) In the presence of RebindableSyntax, we don't know anything about
translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats) -- `toList`, we should treat `ListPat` as any other view pattern.
-- See Note [Guards and Approximation] --
| otherwise -> mkCanFailPmPat pat_ty -- (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 ConPatOut { pat_con = L _ con
, pat_arg_tys = arg_tys , pat_arg_tys = arg_tys
...@@ -1073,7 +1087,7 @@ An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The ...@@ -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 problem is exactly like above, as its solution. For future reference, the code
below is the *right thing to do*: 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 otherwise -> do
(xp, xe) <- mkPmId2Forms pat_ty (xp, xe) <- mkPmId2Forms pat_ty
ps <- translatePatVec (map unLoc lpats) 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, ['']) ...@@ -100,6 +100,7 @@ test('T13290', normal, compile, [''])
test('T13257', normal, compile, ['']) test('T13257', normal, compile, [''])
test('T13870', normal, compile, ['']) test('T13870', normal, compile, [''])
test('T14135', normal, compile, ['']) test('T14135', normal, compile, [''])
test('T14547', normal, compile, ['-Wincomplete-patterns'])
test('T14773a', normal, compile, ['-Wincomplete-patterns']) test('T14773a', normal, compile, ['-Wincomplete-patterns'])
test('T14773b', normal, compile, ['-Wincomplete-patterns']) test('T14773b', normal, compile, ['-Wincomplete-patterns'])
test('T14815', [], run_command, ['$MAKE -s --no-print-directory T14815']) 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