{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}

-- | 'RoughMap' is an approximate finite map data structure keyed on
-- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's
-- (e.g. an instance head).
module GHC.Core.RoughMap
  ( -- * RoughMatchTc
    RoughMatchTc(..)
  , isRoughWildcard
  , typeToRoughMatchTc
  , RoughMatchLookupTc(..)
  , typeToRoughMatchLookupTc
  , roughMatchTcToLookup
  , roughMatchTcs
  , roughMatchTcsLookup
  , instanceCantMatch

    -- * RoughMap
  , RoughMap
  , emptyRM
  , lookupRM
  , lookupRM'
  , insertRM
  , filterRM
  , filterMatchingRM
  , elemsRM
  , sizeRM
  , foldRM
  , unionRM
  ) where

import GHC.Prelude

import GHC.Data.Bag
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName )

import Control.Monad (join)
import Data.Data (Data)
import GHC.Utils.Panic

{-
Note [RoughMap]
~~~~~~~~~~~~~~~
We often want to compute whether one type matches another. That is, given
`ty1` and `ty2`, we want to know whether `ty1` is a substitution instance of `ty2`.

We can bail out early by taking advantage of the following observation:

  If `ty2` is headed by a generative type constructor, say `tc`,
  but `ty1` is not headed by that same type constructor,
  then `ty1` does not match `ty2`.

The idea is that we can use a `RoughMap` as a pre-filter, to produce a
short-list of candidates to examine more closely.

This means we can avoid computing a full substitution if we represent types
as applications of known generative type constructors. So, after type synonym
expansion, we classify application heads into two categories ('RoughMatchTc')

  - `RM_KnownTc tc`: the head is the generative type constructor `tc`,
  - `RM_Wildcard`: anything else.

A (RoughMap val) is semantically a list of (key,[val]) pairs, where
   key :: [RoughMatchTc]
So, writing # for `OtherTc`, and Int for `KnownTc "Int"`, we might have
    [ ([#, Int, Maybe, #, Int], v1)
    , ([Int, #, List], v2 ]

This map is stored as a trie, so looking up a key is very fast.
See Note [Matching a RoughMap] and Note [Simple Matching Semantics] for details on
lookup.

We lookup a key of type [RoughMatchLookupTc], and return the list of all values whose
keys "match":

Given the above map, here are the results of some lookups:
   Lookup key       Result
   -------------------------
   [Int, Int]       [v1,v2] -- Matches because the prefix of both entries matches
   [Int,Int,List]   [v2]
   [Bool]           []

Notice that a single key can map to /multiple/ values.  E.g. if we started
with (Maybe Int, val1) and (Maybe Bool, val2), we'd generate a RoughMap
that is semantically the list   [( Maybe, [val1,val2] )]

Note [RoughMap and beta reduction]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is one tricky case we have to account for when matching a rough map due
to Note [Eta reduction for data families] in `GHC.Core.Coercion.Axiom`:
Consider that the user has written a program containing a data family:

> data family Fam a b
> data instance Fam Int a = SomeType  -- known henceforth as FamIntInst

The LHS of this instance will be eta reduced, as described in Note [Eta
reduction for data families]. Consequently, we will end up with a `FamInst`
with `fi_tcs = [KnownTc Int]`. Naturally, we need RoughMap to return this
instance when queried for an instance with template, e.g., `[KnownTc Fam,
KnownTc Int, KnownTc Char]`.

This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics].
As soon as the lookup key runs out, the remaining instances might match.

This only matters for the data-family case of a FamInstEnv (see Note [Over-saturated matches]
in GHC.Core.FamInstEnv; it's irrelevantfor ClsInstEnv and for type-family instances.
But we use RoughMaps for all cases, so we are conservative.

Note [Matching a RoughMap]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The /lookup key/ into a rough map (RoughMatchLookupTc) is slightly
different to the /insertion key/ (RoughMatchTc).  Like the insertion
key each lookup argument is classified to a simpler key which
describes what could match that position. There are three
possibilities:

* RML_KnownTc Name: The argument is headed by a known type
  constructor.  Example: 'Bool' is classified as 'RML_KnownTc Bool'
  and '[Int]' is classified as `RML_KnownTc []`

* RML_NoKnownTc: The argument is definitely not headed by any known
  type constructor.  Example: For instance matching 'a[sk], a[tau]' and 'F a[sk], F a[tau]'
  are classified as 'RML_NoKnownTc', for family instance matching no examples.

* RML_WildCard: The argument could match anything, we don't know
  enough about it. For instance matching no examples, for type family matching,
  things to do with variables.

The interesting case for instance matching is the second case, because it does not appear in
an insertion key. The second case arises in two situations:

1. The head of the application is a type variable. The type variable definitely
   doesn't match with any of the KnownTC instances so we can discard them all. For example:
    Show a[sk] or Show (a[sk] b[sk]). One place constraints like this arise is when
    typechecking derived instances.

2. The head of the application is a known type family.
   For example: F a[sk]. The application of F is stuck, and because
   F is a type family it won't match any KnownTC instance so it's safe to discard
   all these instances.

Of course, these two cases can still match instances of the form `forall a . Show a =>`,
and those instances are retained as they are classified as RM_WildCard instances.

Note [Matches vs Unifiers]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The lookupRM' function returns a pair of potential /matches/ and potential /unifiers/.
The potential matches is likely to be much smaller than the bag of potential unifiers due
to the reasoning about rigid type variables described in Note [Matching a RoughMap].
On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify
with any instance (depending on the substitution of said rigid variable) so they can't be discounted
from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing
the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC.

This distinction between matches and unifiers is also important for type families.
During normal type family lookup, we care about matches and when checking for consistency
we care about the unifiers. This is evident in the code as `lookup_fam_inst_env` is
parameterised over a lookup function which either performs matching checking or unification
checking.

In addition to this, we only care whether there are zero or non-zero potential
unifiers, even if we have many candidates, the search can stop before consulting
each candidate. We only need the full list of unifiers when displaying error messages.
Therefore the list is computed lazily so much work can be avoided constructing the
list in the first place.

Note [Simple Matching Semantics]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose `rm` is a RoughMap representing a set of (key,vals) pairs,
  where key::[RoughMapTc] and val::a.
Suppose I look up a key lk :: [RoughMapLookupTc] in `rm`
Then I get back (matches, unifiers) where
   matches  = [ vals | (key,vals) <- rm, key `mightMatch` lk ]
   unifiers = [ vals | (key,vals) <- rm, key `mightUnify` lk ]

Where mightMatch is defined like this:

  mightMatch :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool
  mightMatch []  []    = True   -- A perfectly sized match might match
  mightMatch key []    = True   -- A shorter lookup key matches everything
  mightMatch []  (_:_) = True   -- If the lookup key is longer, then still might match
                                -- Note [RoughMap and beta reduction]
  mightMatch (k:ks) (lk:lks) =
    = case (k,lk) of
         -- Standard case, matching on a specific known TyCon.
         (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightMatch ks lks
         -- For example, if the key for 'Show Bool' is [RM_KnownTc Show, RM_KnownTc Bool]
         ---and we match against (Show a[sk]) [RM_KnownTc Show, RML_NoKnownTc]
         -- then Show Bool can never match Show a[sk] so return False.
         (RM_KnownTc _, RML_NoKnownTc)   -> False
         -- Wildcard cases don't inform us anything about the match.
         (RM_WildCard, _ )    -> mightMatch ks lks
         (_, RML_WildCard)    -> mightMatch ks lks

  -- Might unify is very similar to mightMatch apart from RML_NoKnownTc may
  -- unify with any instance.
  mightUnify :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool
  mightUnify []  []    = True   -- A perfectly sized match might unify
  mightUnify key []    = True   -- A shorter lookup key matches everything
  mightUnify []  (_:_) = True
  mightUnify (k:ks) (lk:lks) =
    = case (k,lk) of
         (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightUnify ks lks
         (RM_KnownTc _, RML_NoKnownTc)   -> mightUnify (k:ks) (RML_WildCard:lks)
         (RM_WildCard, _ )    -> mightUnify ks lks
         (_, RML_WildCard)    -> mightUnify ks lks


The guarantee that RoughMap provides is that

if
   insert_ty `tcMatchTy` lookup_ty
then definitely
   typeToRoughMatchTc insert_ty `mightMatch` typeToRoughMatchLookupTc lookup_ty
but not vice versa

this statement encodes the intuition that the RoughMap is used as a quick pre-filter
to remove instances from the matching pool. The contrapositive states that if the
RoughMap reports that the instance doesn't match then `tcMatchTy` will report that the
types don't match as well.

-}

{- *********************************************************************
*                                                                      *
                Rough matching
*                                                                      *
********************************************************************* -}

{- Note [Rough matching in class and family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  instance C (Maybe [Tree a]) Bool
and suppose we are looking up
     C Bool Bool

We can very quickly rule the instance out, because the first
argument is headed by Maybe, whereas in the constraint we are looking
up has first argument headed by Bool.  These "headed by" TyCons are
called the "rough match TyCons" of the constraint or instance.
They are used for a quick filter, to check when an instance cannot
possibly match.

The main motivation is to avoid sucking in whole instance
declarations that are utterly useless.  See GHC.Core.InstEnv
Note [ClsInst laziness and the rough-match fields].

INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon,
like Maybe or Either, including a newtype or a data family, both of
which are generative. It replies True to `isGenerativeTyCon tc Nominal`.

But it is never
    - A type synonym
      E.g. Int and (S Bool) might match
           if (S Bool) is a synonym for Int

    - A type family (#19336)
      E.g.   (Just a) and (F a) might match if (F a) reduces to (Just a)
             albeit perhaps only after 'a' is instantiated.
-}


-- Key for insertion into a RoughMap
data RoughMatchTc
  = RM_KnownTc Name  -- INVARIANT: Name refers to a TyCon tc that responds
                     -- true to `isGenerativeTyCon tc Nominal`. See
                     -- Note [Rough matching in class and family instances]
  | RM_WildCard      -- e.g. type variable at the head
  deriving( Typeable RoughMatchTc
Typeable RoughMatchTc =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c RoughMatchTc)
-> (RoughMatchTc -> Constr)
-> (RoughMatchTc -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c RoughMatchTc))
-> ((forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r)
-> (forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc)
-> Data RoughMatchTc
RoughMatchTc -> Constr
RoughMatchTc -> DataType
(forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
$ctoConstr :: RoughMatchTc -> Constr
toConstr :: RoughMatchTc -> Constr
$cdataTypeOf :: RoughMatchTc -> DataType
dataTypeOf :: RoughMatchTc -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
$cgmapT :: (forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
gmapT :: (forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
Data )

-- Key for lookup into a RoughMap
-- See Note [Matching a RoughMap]
data RoughMatchLookupTc
  = RML_KnownTc Name -- ^ The position only matches the specified KnownTc
  | RML_NoKnownTc    -- ^ The position definitely doesn't match any KnownTc
  | RML_WildCard     -- ^ The position can match anything
  deriving ( Typeable RoughMatchLookupTc
Typeable RoughMatchLookupTc =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> RoughMatchLookupTc
 -> c RoughMatchLookupTc)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc)
-> (RoughMatchLookupTc -> Constr)
-> (RoughMatchLookupTc -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c RoughMatchLookupTc))
-> ((forall b. Data b => b -> b)
    -> RoughMatchLookupTc -> RoughMatchLookupTc)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> RoughMatchLookupTc -> m RoughMatchLookupTc)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> RoughMatchLookupTc -> m RoughMatchLookupTc)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> RoughMatchLookupTc -> m RoughMatchLookupTc)
-> Data RoughMatchLookupTc
RoughMatchLookupTc -> Constr
RoughMatchLookupTc -> DataType
(forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
$ctoConstr :: RoughMatchLookupTc -> Constr
toConstr :: RoughMatchLookupTc -> Constr
$cdataTypeOf :: RoughMatchLookupTc -> DataType
dataTypeOf :: RoughMatchLookupTc -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
$cgmapT :: (forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
gmapT :: (forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
Data )

instance Outputable RoughMatchLookupTc where
    ppr :: RoughMatchLookupTc -> SDoc
ppr (RML_KnownTc Name
nm) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RML_KnownTc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm
    ppr RoughMatchLookupTc
RML_NoKnownTc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RML_NoKnownTC"
    ppr RoughMatchLookupTc
RML_WildCard = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_"

instance Outputable RoughMatchTc where
    ppr :: RoughMatchTc -> SDoc
ppr (RM_KnownTc Name
nm) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"KnownTc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm
    ppr RoughMatchTc
RM_WildCard = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OtherTc"

instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool
-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
-- possibly be instantiated to actual, nor vice versa;
-- False is non-committal
instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool
instanceCantMatch (RoughMatchTc
mt : [RoughMatchTc]
ts) (RoughMatchTc
ma : [RoughMatchTc]
as) = RoughMatchTc -> RoughMatchTc -> Bool
itemCantMatch RoughMatchTc
mt RoughMatchTc
ma Bool -> Bool -> Bool
|| [RoughMatchTc] -> [RoughMatchTc] -> Bool
instanceCantMatch [RoughMatchTc]
ts [RoughMatchTc]
as
instanceCantMatch [RoughMatchTc]
_         [RoughMatchTc]
_         =  Bool
False  -- Safe

itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool
itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool
itemCantMatch (RM_KnownTc Name
t) (RM_KnownTc Name
a) = Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
a
itemCantMatch RoughMatchTc
_              RoughMatchTc
_              = Bool
False

roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup (RM_KnownTc Name
n) = Name -> RoughMatchLookupTc
RML_KnownTc Name
n
roughMatchTcToLookup RoughMatchTc
RM_WildCard = RoughMatchLookupTc
RML_WildCard

isRoughWildcard :: RoughMatchTc -> Bool
isRoughWildcard :: RoughMatchTc -> Bool
isRoughWildcard RoughMatchTc
RM_WildCard  = Bool
True
isRoughWildcard (RM_KnownTc {}) = Bool
False

roughMatchTcs :: [Type] -> [RoughMatchTc]
roughMatchTcs :: [Type] -> [RoughMatchTc]
roughMatchTcs [Type]
tys = (Type -> RoughMatchTc) -> [Type] -> [RoughMatchTc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> RoughMatchTc
typeToRoughMatchTc [Type]
tys

roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]
roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]
roughMatchTcsLookup [Type]
tys = (Type -> RoughMatchLookupTc) -> [Type] -> [RoughMatchLookupTc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc [Type]
tys

typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty
  -- Expand synonyms first, as explained in Note [Rough matching in class and family instances].
  -- Failing to do so led to #22985.
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
  = Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty'
  | CastTy Type
ty' KindCoercion
_ <- Type
ty
  = Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty'
  | Bool
otherwise
  = case Type -> (Type, [Type])
splitAppTys Type
ty of
        -- Case 1: Head of application is a type variable, does not match any KnownTc.
        (TyVarTy {}, [Type]
_) -> RoughMatchLookupTc
RML_NoKnownTc

        (TyConApp TyCon
tc [Type]
_, [Type]
_)
          -- Case 2: Head of application is a known type constructor, hence KnownTc.
          | Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc) -> Name -> RoughMatchLookupTc
RML_KnownTc (Name -> RoughMatchLookupTc) -> Name -> RoughMatchLookupTc
forall a b. (a -> b) -> a -> b
$! TyCon -> Name
roughMatchTyConName TyCon
tc
          -- Case 3: Head is a type family so it's stuck and therefore doesn't match
          -- any KnownTc
          | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc -> RoughMatchLookupTc
RML_NoKnownTc

        -- Fallthrough: Otherwise, anything might match this position
        (Type, [Type])
_ -> RoughMatchLookupTc
RML_WildCard

typeToRoughMatchTc :: Type -> RoughMatchTc
typeToRoughMatchTc :: Type -> RoughMatchTc
typeToRoughMatchTc Type
ty
  | Just (Type
ty', KindCoercion
_) <- Type -> Maybe (Type, KindCoercion)
splitCastTy_maybe Type
ty   = Type -> RoughMatchTc
typeToRoughMatchTc Type
ty'
  | Just (TyCon
tc,[Type]
_)   <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc)              = Name -> RoughMatchTc
RM_KnownTc (Name -> RoughMatchTc) -> Name -> RoughMatchTc
forall a b. (a -> b) -> a -> b
$! TyCon -> Name
roughMatchTyConName TyCon
tc
    -- See Note [Rough matching in class and family instances]
  | Bool
otherwise                               = RoughMatchTc
RM_WildCard

roughMatchTyConName :: TyCon -> Name
roughMatchTyConName :: TyCon -> Name
roughMatchTyConName TyCon
tc
  | Name
tc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
cONSTRAINTTyConName
  = Name
tYPETyConName  -- TYPE and CONSTRAINT are not apart, so they must use
                   -- the same rough-map key. We arbitrarily use TYPE.
                   -- See Note [Type and Constraint are not apart]
                   -- wrinkle (W1) in GHC.Builtin.Types.Prim
  | Bool
otherwise
  = Bool -> SDoc -> Name -> Name
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) Name
tc_name
  where
    tc_name :: Name
tc_name = TyCon -> Name
tyConName TyCon
tc


-- | Trie of @[RoughMatchTc]@
--
-- *Examples*
-- @
-- insert [OtherTc] 1
-- insert [OtherTc] 2
-- lookup [OtherTc] == [1,2]
-- @
data RoughMap a
  = RMEmpty -- An optimised (finite) form of emptyRM
            -- Invariant: Empty RoughMaps are always represented with RMEmpty

  | RM { forall a. RoughMap a -> Bag a
rm_empty :: Bag a
           -- Keyed by an empty [RoughMapTc]

       , forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known :: DNameEnv (RoughMap a)
           -- Keyed by (RM_KnownTc tc : rm_tcs)
           -- DNameEnv: see Note [InstEnv determinism] in GHC.Core.InstEnv

       , forall a. RoughMap a -> RoughMap a
rm_wild :: RoughMap a }
           -- Keyed by (RM_WildCard : rm_tcs)
  deriving ((forall a b. (a -> b) -> RoughMap a -> RoughMap b)
-> (forall a b. a -> RoughMap b -> RoughMap a) -> Functor RoughMap
forall a b. a -> RoughMap b -> RoughMap a
forall a b. (a -> b) -> RoughMap a -> RoughMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> RoughMap a -> RoughMap b
fmap :: forall a b. (a -> b) -> RoughMap a -> RoughMap b
$c<$ :: forall a b. a -> RoughMap b -> RoughMap a
<$ :: forall a b. a -> RoughMap b -> RoughMap a
Functor)

instance Outputable a => Outputable (RoughMap a) where
  ppr :: RoughMap a -> SDoc
ppr (RM Bag a
empty DNameEnv (RoughMap a)
known RoughMap a
unknown) =
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RM"
           , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Empty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bag a -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag a
empty
                          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Known:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DNameEnv (RoughMap a) -> SDoc
forall a. Outputable a => a -> SDoc
ppr DNameEnv (RoughMap a)
known
                          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unknown:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RoughMap a -> SDoc
forall a. Outputable a => a -> SDoc
ppr RoughMap a
unknown])]
  ppr RoughMap a
RMEmpty = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{}"

emptyRM :: RoughMap a
emptyRM :: forall a. RoughMap a
emptyRM = RoughMap a
forall a. RoughMap a
RMEmpty

-- | Order of result is deterministic.
lookupRM :: [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM :: forall a. [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM [RoughMatchLookupTc]
tcs RoughMap a
rm = Bag a -> [a]
forall a. Bag a -> [a]
bagToList ((Bag a, [a]) -> Bag a
forall a b. (a, b) -> a
fst ((Bag a, [a]) -> Bag a) -> (Bag a, [a]) -> Bag a
forall a b. (a -> b) -> a -> b
$ [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs RoughMap a
rm)


-- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists
-- we find in 'rm_empty', which would otherwise be necessary due to '++' if we
-- returned a list. We use a list for unifiers because the tail is computed lazily and
-- we often only care about the first couple of potential unifiers. Constructing a
-- bag forces the tail which performs much too much work.
--
-- See Note [Matching a RoughMap]
-- See Note [Matches vs Unifiers]
lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches
                                                   , [a]) -- Potential unifiers
lookupRM' :: forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
_ RoughMap a
RMEmpty   -- The RoughMap is empty
  = (Bag a
forall a. Bag a
emptyBag, [])

lookupRM' [] RoughMap a
rm       -- See Note [Simple Matching Semantics] about why
  = ([a] -> Bag a
forall a. [a] -> Bag a
listToBag [a]
m, [a]
m)  -- we return everything when the lookup key runs out
  where
    m :: [a]
m = RoughMap a -> [a]
forall a. RoughMap a -> [a]
elemsRM RoughMap a
rm

lookupRM' (RML_KnownTc Name
tc : [RoughMatchLookupTc]
tcs) RoughMap a
rm  =
  let (Bag a
common_m, [a]
common_u) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
      (Bag a
m, [a]
u) = (Bag a, [a])
-> (RoughMap a -> (Bag a, [a]))
-> Maybe (RoughMap a)
-> (Bag a, [a])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bag a
forall a. Bag a
emptyBag, []) ([RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs) (DNameEnv (RoughMap a) -> Name -> Maybe (RoughMap a)
forall a. DNameEnv a -> Name -> Maybe a
lookupDNameEnv (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
tc)
  in ( RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
common_m Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m
     , Bag a -> [a]
forall a. Bag a -> [a]
bagToList (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
common_u [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u)

-- A RML_NoKnownTC does **not** match any KnownTC but can unify
lookupRM' (RoughMatchLookupTc
RML_NoKnownTc : [RoughMatchLookupTc]
tcs) RoughMap a
rm =
  let (Bag a
u_m, [a]
_u_u) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
  in ( RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
u_m -- Definitely don't match
     , (Bag a, [a]) -> [a]
forall a b. (a, b) -> b
snd ((Bag a, [a]) -> [a]) -> (Bag a, [a]) -> [a]
forall a b. (a -> b) -> a -> b
$ [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' (RoughMatchLookupTc
RML_WildCard RoughMatchLookupTc -> [RoughMatchLookupTc] -> [RoughMatchLookupTc]
forall a. a -> [a] -> [a]
: [RoughMatchLookupTc]
tcs) RoughMap a
rm) -- But could unify..

lookupRM' (RoughMatchLookupTc
RML_WildCard : [RoughMatchLookupTc]
tcs)    RoughMap a
rm  =
--  pprTrace "RM wild" (ppr tcs $$ ppr (eltsDNameEnv (rm_known rm))) $
  let (Bag a
m, [a]
u)     = (RoughMap a -> (Bag a, [a]) -> (Bag a, [a]))
-> (Bag a, [a]) -> DNameEnv (RoughMap a) -> (Bag a, [a])
forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
foldDNameEnv RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
forall a. RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
add_one (Bag a
forall a. Bag a
emptyBag, []) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm)
      (Bag a
u_m, [a]
u_u) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
  in ( RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
u_m Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m
     , Bag a -> [a]
forall a. Bag a -> [a]
bagToList (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u_u [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u )
  where
     add_one :: RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
     add_one :: forall a. RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
add_one RoughMap a
rm ~(Bag a
m2, [a]
u2) = (Bag a
m1 Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m2, [a]
u1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u2)
                          where
                            (Bag a
m1,[a]
u1) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs RoughMap a
rm

unionRM :: RoughMap a -> RoughMap a -> RoughMap a
unionRM :: forall a. RoughMap a -> RoughMap a -> RoughMap a
unionRM RoughMap a
RMEmpty RoughMap a
a = RoughMap a
a
unionRM RoughMap a
a RoughMap a
RMEmpty = RoughMap a
a
unionRM RoughMap a
a RoughMap a
b =
  RM { rm_empty :: Bag a
rm_empty = RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
a Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
b
     , rm_known :: DNameEnv (RoughMap a)
rm_known = (RoughMap a -> RoughMap a -> RoughMap a)
-> DNameEnv (RoughMap a)
-> DNameEnv (RoughMap a)
-> DNameEnv (RoughMap a)
forall elt.
(elt -> elt -> elt) -> DNameEnv elt -> DNameEnv elt -> DNameEnv elt
plusDNameEnv_C RoughMap a -> RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a -> RoughMap a
unionRM (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
a) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
b)
     , rm_wild :: RoughMap a
rm_wild = RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
a RoughMap a -> RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a -> RoughMap a
`unionRM` RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
b
     }


insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM :: forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
k a
v RoughMap a
RMEmpty =
    [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
k a
v (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM { rm_empty :: Bag a
rm_empty = Bag a
forall a. Bag a
emptyBag
                      , rm_known :: DNameEnv (RoughMap a)
rm_known = DNameEnv (RoughMap a)
forall a. DNameEnv a
emptyDNameEnv
                      , rm_wild :: RoughMap a
rm_wild = RoughMap a
forall a. RoughMap a
emptyRM }
insertRM [] a
v rm :: RoughMap a
rm@(RM {}) =
    -- See Note [Simple Matching Semantics]
    RoughMap a
rm { rm_empty = v `consBag` rm_empty rm }

insertRM (RM_KnownTc Name
k : [RoughMatchTc]
ks) a
v rm :: RoughMap a
rm@(RM {}) =
    RoughMap a
rm { rm_known = alterDNameEnv f (rm_known rm) k }
  where
    f :: Maybe (RoughMap a) -> Maybe (RoughMap a)
f Maybe (RoughMap a)
Nothing  = RoughMap a -> Maybe (RoughMap a)
forall a. a -> Maybe a
Just (RoughMap a -> Maybe (RoughMap a))
-> RoughMap a -> Maybe (RoughMap a)
forall a b. (a -> b) -> a -> b
$ ([RoughMatchTc] -> a -> RoughMap a -> RoughMap a
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
ks a
v RoughMap a
forall a. RoughMap a
emptyRM)
    f (Just RoughMap a
m) = RoughMap a -> Maybe (RoughMap a)
forall a. a -> Maybe a
Just (RoughMap a -> Maybe (RoughMap a))
-> RoughMap a -> Maybe (RoughMap a)
forall a b. (a -> b) -> a -> b
$ ([RoughMatchTc] -> a -> RoughMap a -> RoughMap a
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
ks a
v RoughMap a
m)

insertRM (RoughMatchTc
RM_WildCard : [RoughMatchTc]
ks) a
v rm :: RoughMap a
rm@(RM {}) =
    RoughMap a
rm { rm_wild = insertRM ks v (rm_wild rm) }

filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a
filterRM :: forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
_ RoughMap a
RMEmpty = RoughMap a
forall a. RoughMap a
RMEmpty
filterRM a -> Bool
pred RoughMap a
rm =
    RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
normalise (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM {
      rm_empty :: Bag a
rm_empty = (a -> Bool) -> Bag a -> Bag a
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
      rm_known :: DNameEnv (RoughMap a)
rm_known = (RoughMap a -> RoughMap a)
-> DNameEnv (RoughMap a) -> DNameEnv (RoughMap a)
forall a b. (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv ((a -> Bool) -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm),
      rm_wild :: RoughMap a
rm_wild = (a -> Bool) -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
    }

-- | Place a 'RoughMap' in normal form, turning all empty 'RM's into
-- 'RMEmpty's. Necessary after removing items.
normalise :: RoughMap a -> RoughMap a
normalise :: forall a. RoughMap a -> RoughMap a
normalise RoughMap a
RMEmpty = RoughMap a
forall a. RoughMap a
RMEmpty
normalise (RM Bag a
empty DNameEnv (RoughMap a)
known RoughMap a
RMEmpty)
  | Bag a -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag a
empty
  , DNameEnv (RoughMap a) -> Bool
forall a. DNameEnv a -> Bool
isEmptyDNameEnv DNameEnv (RoughMap a)
known = RoughMap a
forall a. RoughMap a
RMEmpty
normalise RoughMap a
rm = RoughMap a
rm

-- | Filter all elements that might match a particular key with the given
-- predicate.
filterMatchingRM :: (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM :: forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
_    [RoughMatchTc]
_  RoughMap a
RMEmpty = RoughMap a
forall a. RoughMap a
RMEmpty
filterMatchingRM a -> Bool
pred [] RoughMap a
rm      = (a -> Bool) -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred RoughMap a
rm
filterMatchingRM a -> Bool
pred (RM_KnownTc Name
tc : [RoughMatchTc]
tcs) RoughMap a
rm =
    RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
normalise (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM {
      rm_empty :: Bag a
rm_empty = (a -> Bool) -> Bag a -> Bag a
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
      rm_known :: DNameEnv (RoughMap a)
rm_known = (Maybe (RoughMap a) -> Maybe (RoughMap a))
-> DNameEnv (RoughMap a) -> Name -> DNameEnv (RoughMap a)
forall a. (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a
alterDNameEnv (Maybe (Maybe (RoughMap a)) -> Maybe (RoughMap a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (RoughMap a)) -> Maybe (RoughMap a))
-> (Maybe (RoughMap a) -> Maybe (Maybe (RoughMap a)))
-> Maybe (RoughMap a)
-> Maybe (RoughMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RoughMap a -> Maybe (RoughMap a))
-> Maybe (RoughMap a) -> Maybe (Maybe (RoughMap a))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RoughMap a -> Maybe (RoughMap a)
forall a. RoughMap a -> Maybe (RoughMap a)
dropEmpty (RoughMap a -> Maybe (RoughMap a))
-> (RoughMap a -> RoughMap a) -> RoughMap a -> Maybe (RoughMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs)) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
tc,
      rm_wild :: RoughMap a
rm_wild = (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
    }
filterMatchingRM a -> Bool
pred (RoughMatchTc
RM_WildCard : [RoughMatchTc]
tcs) RoughMap a
rm =
    RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
normalise (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM {
      rm_empty :: Bag a
rm_empty = (a -> Bool) -> Bag a -> Bag a
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
      rm_known :: DNameEnv (RoughMap a)
rm_known = (RoughMap a -> RoughMap a)
-> DNameEnv (RoughMap a) -> DNameEnv (RoughMap a)
forall a b. (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv ((a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm),
      rm_wild :: RoughMap a
rm_wild = (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
    }

dropEmpty :: RoughMap a -> Maybe (RoughMap a)
dropEmpty :: forall a. RoughMap a -> Maybe (RoughMap a)
dropEmpty RoughMap a
RMEmpty = Maybe (RoughMap a)
forall a. Maybe a
Nothing
dropEmpty RoughMap a
rm = RoughMap a -> Maybe (RoughMap a)
forall a. a -> Maybe a
Just RoughMap a
rm

elemsRM :: RoughMap a -> [a]
elemsRM :: forall a. RoughMap a -> [a]
elemsRM = (a -> [a] -> [a]) -> [a] -> RoughMap a -> [a]
forall a b. (a -> b -> b) -> b -> RoughMap a -> b
foldRM (:) []

foldRM :: (a -> b -> b) -> b -> RoughMap a -> b
foldRM :: forall a b. (a -> b -> b) -> b -> RoughMap a -> b
foldRM a -> b -> b
f = b -> RoughMap a -> b
go
  where
    -- N.B. local worker ensures that the loop can be specialised to the fold
    -- function.
    go :: b -> RoughMap a -> b
go b
z RoughMap a
RMEmpty = b
z
    go b
z (RM{ rm_wild :: forall a. RoughMap a -> RoughMap a
rm_wild = RoughMap a
unk, rm_known :: forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known = DNameEnv (RoughMap a)
known, rm_empty :: forall a. RoughMap a -> Bag a
rm_empty = Bag a
empty}) =
      (a -> b -> b) -> b -> Bag a -> b
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        a -> b -> b
f
        ((RoughMap a -> b -> b) -> b -> DNameEnv (RoughMap a) -> b
forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
foldDNameEnv
           ((b -> RoughMap a -> b) -> RoughMap a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> RoughMap a -> b
go)
           (b -> RoughMap a -> b
go b
z RoughMap a
unk)
           DNameEnv (RoughMap a)
known
        )
        Bag a
empty

nonDetStrictFoldRM :: (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM :: forall b a. (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM b -> a -> b
f = b -> RoughMap a -> b
go
  where
    -- N.B. local worker ensures that the loop can be specialised to the fold
    -- function.
    go :: b -> RoughMap a -> b
go !b
z RoughMap a
RMEmpty = b
z
    go  b
z rm :: RoughMap a
rm@(RM{}) =
      (b -> a -> b) -> b -> Bag a -> b
forall b a. (b -> a -> b) -> b -> Bag a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        b -> a -> b
f
        ((RoughMap a -> b -> b) -> b -> DNameEnv (RoughMap a) -> b
forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
nonDetStrictFoldDNameEnv
           ((b -> RoughMap a -> b) -> RoughMap a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> RoughMap a -> b
go)
           (b -> RoughMap a -> b
go b
z (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm))
           (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm)
        )
        (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm)

sizeRM :: RoughMap a -> Int
sizeRM :: forall a. RoughMap a -> Int
sizeRM = (Int -> a -> Int) -> Int -> RoughMap a -> Int
forall b a. (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM (\Int
acc a
_ -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0