-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
module Retrie.PatternMap.Bag where

import qualified Data.Map as M
import qualified Data.IntMap as I

import Retrie.AlphaEnv
import qualified Retrie.GHC as GHC
import Retrie.PatternMap.Class
import Retrie.Quantifiers
import Retrie.Substitution

data BoolMap a
  = EmptyBoolMap
  | BoolMap
      { BoolMap a -> MaybeMap a
bmTrue :: MaybeMap a
      , BoolMap a -> MaybeMap a
bmFalse :: MaybeMap a
      }
  deriving (a -> BoolMap b -> BoolMap a
(a -> b) -> BoolMap a -> BoolMap b
(forall a b. (a -> b) -> BoolMap a -> BoolMap b)
-> (forall a b. a -> BoolMap b -> BoolMap a) -> Functor BoolMap
forall a b. a -> BoolMap b -> BoolMap a
forall a b. (a -> b) -> BoolMap a -> BoolMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BoolMap b -> BoolMap a
$c<$ :: forall a b. a -> BoolMap b -> BoolMap a
fmap :: (a -> b) -> BoolMap a -> BoolMap b
$cfmap :: forall a b. (a -> b) -> BoolMap a -> BoolMap b
Functor)

instance PatternMap BoolMap where
  type Key BoolMap = Bool

  mEmpty :: BoolMap a
  mEmpty :: BoolMap a
mEmpty = BoolMap a
forall a. BoolMap a
EmptyBoolMap

  mUnion :: BoolMap a -> BoolMap a -> BoolMap a
  mUnion :: BoolMap a -> BoolMap a -> BoolMap a
mUnion BoolMap a
EmptyBoolMap BoolMap a
m = BoolMap a
m
  mUnion BoolMap a
m BoolMap a
EmptyBoolMap = BoolMap a
m
  mUnion BoolMap a
m1 BoolMap a
m2 = BoolMap :: forall a. MaybeMap a -> MaybeMap a -> BoolMap a
BoolMap
    { bmTrue :: MaybeMap a
bmTrue = (BoolMap a -> MaybeMap a) -> BoolMap a -> BoolMap a -> MaybeMap a
forall (m :: * -> *) a b.
PatternMap m =>
(a -> m b) -> a -> a -> m b
unionOn BoolMap a -> MaybeMap a
forall a. BoolMap a -> MaybeMap a
bmTrue BoolMap a
m1 BoolMap a
m2
    , bmFalse :: MaybeMap a
bmFalse = (BoolMap a -> MaybeMap a) -> BoolMap a -> BoolMap a -> MaybeMap a
forall (m :: * -> *) a b.
PatternMap m =>
(a -> m b) -> a -> a -> m b
unionOn BoolMap a -> MaybeMap a
forall a. BoolMap a -> MaybeMap a
bmFalse BoolMap a
m1 BoolMap a
m2
    }

  mAlter
    :: AlphaEnv -> Quantifiers -> Key BoolMap -> A a -> BoolMap a -> BoolMap a
  mAlter :: AlphaEnv
-> Quantifiers -> Key BoolMap -> A a -> BoolMap a -> BoolMap a
mAlter AlphaEnv
env Quantifiers
qs Key BoolMap
b A a
f BoolMap a
EmptyBoolMap = AlphaEnv
-> Quantifiers -> Key BoolMap -> A a -> BoolMap a -> BoolMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
qs Key BoolMap
b A a
f (MaybeMap a -> MaybeMap a -> BoolMap a
forall a. MaybeMap a -> MaybeMap a -> BoolMap a
BoolMap MaybeMap a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty MaybeMap a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty)
  mAlter AlphaEnv
env Quantifiers
qs Key BoolMap
b A a
f m :: BoolMap a
m@BoolMap{}
    | Bool
Key BoolMap
b = BoolMap a
m { bmTrue :: MaybeMap a
bmTrue = AlphaEnv
-> Quantifiers -> Key MaybeMap -> A a -> MaybeMap a -> MaybeMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
qs () A a
f (BoolMap a -> MaybeMap a
forall a. BoolMap a -> MaybeMap a
bmTrue BoolMap a
m) }
    | Bool
otherwise = BoolMap a
m { bmFalse :: MaybeMap a
bmFalse = AlphaEnv
-> Quantifiers -> Key MaybeMap -> A a -> MaybeMap a -> MaybeMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
qs () A a
f (BoolMap a -> MaybeMap a
forall a. BoolMap a -> MaybeMap a
bmFalse BoolMap a
m) }

  mMatch
    :: MatchEnv
    -> Key BoolMap
    -> (Substitution, BoolMap a)
    -> [(Substitution, a)]
  mMatch :: MatchEnv
-> Key BoolMap -> (Substitution, BoolMap a) -> [(Substitution, a)]
mMatch MatchEnv
_ Key BoolMap
_ (Substitution
_, BoolMap a
EmptyBoolMap) = []
  mMatch MatchEnv
env Key BoolMap
b hs :: (Substitution, BoolMap a)
hs@(Substitution
_, BoolMap{})
    | Bool
Key BoolMap
b = (BoolMap a -> MaybeMap a)
-> (Substitution, BoolMap a) -> [(Substitution, MaybeMap a)]
forall b c a. (b -> c) -> (a, b) -> [(a, c)]
mapFor BoolMap a -> MaybeMap a
forall a. BoolMap a -> MaybeMap a
bmTrue (Substitution, BoolMap a)
hs [(Substitution, MaybeMap a)]
-> ((Substitution, MaybeMap a) -> [(Substitution, a)])
-> [(Substitution, a)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MatchEnv
-> Key MaybeMap
-> (Substitution, MaybeMap a)
-> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env ()
    | Bool
otherwise = (BoolMap a -> MaybeMap a)
-> (Substitution, BoolMap a) -> [(Substitution, MaybeMap a)]
forall b c a. (b -> c) -> (a, b) -> [(a, c)]
mapFor BoolMap a -> MaybeMap a
forall a. BoolMap a -> MaybeMap a
bmFalse (Substitution, BoolMap a)
hs [(Substitution, MaybeMap a)]
-> ((Substitution, MaybeMap a) -> [(Substitution, a)])
-> [(Substitution, a)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MatchEnv
-> Key MaybeMap
-> (Substitution, MaybeMap a)
-> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env ()

------------------------------------------------------------------------

newtype IntMap a = IntMap { IntMap a -> IntMap [a]
unIntMap :: I.IntMap [a] }
  deriving (a -> IntMap b -> IntMap a
(a -> b) -> IntMap a -> IntMap b
(forall a b. (a -> b) -> IntMap a -> IntMap b)
-> (forall a b. a -> IntMap b -> IntMap a) -> Functor IntMap
forall a b. a -> IntMap b -> IntMap a
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IntMap b -> IntMap a
$c<$ :: forall a b. a -> IntMap b -> IntMap a
fmap :: (a -> b) -> IntMap a -> IntMap b
$cfmap :: forall a b. (a -> b) -> IntMap a -> IntMap b
Functor)

instance PatternMap IntMap where
  type Key IntMap = I.Key

  mEmpty :: IntMap a
  mEmpty :: IntMap a
mEmpty = IntMap [a] -> IntMap a
forall a. IntMap [a] -> IntMap a
IntMap IntMap [a]
forall a. IntMap a
I.empty

  mUnion :: IntMap a -> IntMap a -> IntMap a
  mUnion :: IntMap a -> IntMap a -> IntMap a
mUnion (IntMap IntMap [a]
m1) (IntMap IntMap [a]
m2) = IntMap [a] -> IntMap a
forall a. IntMap [a] -> IntMap a
IntMap (IntMap [a] -> IntMap a) -> IntMap [a] -> IntMap a
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> IntMap [a] -> IntMap [a] -> IntMap [a]
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
I.unionWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) IntMap [a]
m1 IntMap [a]
m2

  mAlter :: AlphaEnv -> Quantifiers -> Key IntMap -> A a -> IntMap a -> IntMap a
  mAlter :: AlphaEnv
-> Quantifiers -> Key IntMap -> A a -> IntMap a -> IntMap a
mAlter AlphaEnv
_ Quantifiers
_ Key IntMap
i A a
f (IntMap IntMap [a]
m) = IntMap [a] -> IntMap a
forall a. IntMap [a] -> IntMap a
IntMap (IntMap [a] -> IntMap a) -> IntMap [a] -> IntMap a
forall a b. (a -> b) -> a -> b
$ (Maybe [a] -> Maybe [a]) -> Key -> IntMap [a] -> IntMap [a]
forall a. (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
I.alter (A a -> Maybe [a] -> Maybe [a]
forall a. A a -> A [a]
toAList A a
f) Key
Key IntMap
i IntMap [a]
m

  mMatch
    :: MatchEnv
    -> Key IntMap
    -> (Substitution, IntMap a)
    -> [(Substitution, a)]
  mMatch :: MatchEnv
-> Key IntMap -> (Substitution, IntMap a) -> [(Substitution, a)]
mMatch MatchEnv
_ Key IntMap
i = (IntMap a -> Maybe [a])
-> (Substitution, IntMap a) -> [(Substitution, a)]
forall b c a. (b -> Maybe [c]) -> (a, b) -> [(a, c)]
maybeListMap (Key -> IntMap [a] -> Maybe [a]
forall a. Key -> IntMap a -> Maybe a
I.lookup Key
Key IntMap
i (IntMap [a] -> Maybe [a])
-> (IntMap a -> IntMap [a]) -> IntMap a -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> IntMap [a]
forall a. IntMap a -> IntMap [a]
unIntMap)

------------------------------------------------------------------------

newtype Map k a = Map { Map k a -> Map k [a]
unMap :: M.Map k [a] }
  deriving (a -> Map k b -> Map k a
(a -> b) -> Map k a -> Map k b
(forall a b. (a -> b) -> Map k a -> Map k b)
-> (forall a b. a -> Map k b -> Map k a) -> Functor (Map k)
forall a b. a -> Map k b -> Map k a
forall a b. (a -> b) -> Map k a -> Map k b
forall k a b. a -> Map k b -> Map k a
forall k a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Map k b -> Map k a
$c<$ :: forall k a b. a -> Map k b -> Map k a
fmap :: (a -> b) -> Map k a -> Map k b
$cfmap :: forall k a b. (a -> b) -> Map k a -> Map k b
Functor)

mapAssocs :: Map k v -> [(k,v)]
mapAssocs :: Map k v -> [(k, v)]
mapAssocs (Map Map k [v]
m) = [ (k
k,v
v) | (k
k,[v]
vs) <- Map k [v] -> [(k, [v])]
forall k a. Map k a -> [(k, a)]
M.assocs Map k [v]
m, v
v <- [v]
vs ]

instance Ord k => PatternMap (Map k) where
  type Key (Map k) = k

  mEmpty :: Map k a
  mEmpty :: Map k a
mEmpty = Map k [a] -> Map k a
forall k a. Map k [a] -> Map k a
Map Map k [a]
forall k a. Map k a
M.empty

  mUnion :: Map k a -> Map k a -> Map k a
  mUnion :: Map k a -> Map k a -> Map k a
mUnion (Map Map k [a]
m1) (Map Map k [a]
m2) = Map k [a] -> Map k a
forall k a. Map k [a] -> Map k a
Map (Map k [a] -> Map k a) -> Map k [a] -> Map k a
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> Map k [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) Map k [a]
m1 Map k [a]
m2

  mAlter :: AlphaEnv -> Quantifiers -> Key (Map k) -> A a -> Map k a -> Map k a
  mAlter :: AlphaEnv -> Quantifiers -> Key (Map k) -> A a -> Map k a -> Map k a
mAlter AlphaEnv
_ Quantifiers
_ Key (Map k)
k A a
f (Map Map k [a]
m) = Map k [a] -> Map k a
forall k a. Map k [a] -> Map k a
Map (Map k [a] -> Map k a) -> Map k [a] -> Map k a
forall a b. (a -> b) -> a -> b
$ (Maybe [a] -> Maybe [a]) -> k -> Map k [a] -> Map k [a]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (A a -> Maybe [a] -> Maybe [a]
forall a. A a -> A [a]
toAList A a
f) k
Key (Map k)
k Map k [a]
m

  mMatch
    :: MatchEnv
    -> Key (Map k)
    -> (Substitution, Map k a)
    -> [(Substitution, a)]
  mMatch :: MatchEnv
-> Key (Map k) -> (Substitution, Map k a) -> [(Substitution, a)]
mMatch MatchEnv
_ Key (Map k)
k = (Map k a -> Maybe [a])
-> (Substitution, Map k a) -> [(Substitution, a)]
forall b c a. (b -> Maybe [c]) -> (a, b) -> [(a, c)]
maybeListMap (k -> Map k [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
Key (Map k)
k (Map k [a] -> Maybe [a])
-> (Map k a -> Map k [a]) -> Map k a -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k a -> Map k [a]
forall k a. Map k a -> Map k [a]
unMap)

------------------------------------------------------------------------

-- Note [OccEnv]
--
-- We avoid using OccEnv because the Uniquable instance for OccName
-- takes the NameSpace of the OccName into account, which we rarely actually
-- want. (Doing so requires creating new RdrNames with the proper namespace,
-- which is a bunch of fiddling for no obvious gain for our uses.) Instead
-- we just use a map based on the FastString name.

newtype FSEnv a =
  FSEnv { FSEnv a -> UniqFM a
_unFSEnv :: UniqFM a } -- this is the UniqFM below, NOT GHC's UniqFM
  deriving (a -> FSEnv b -> FSEnv a
(a -> b) -> FSEnv a -> FSEnv b
(forall a b. (a -> b) -> FSEnv a -> FSEnv b)
-> (forall a b. a -> FSEnv b -> FSEnv a) -> Functor FSEnv
forall a b. a -> FSEnv b -> FSEnv a
forall a b. (a -> b) -> FSEnv a -> FSEnv b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FSEnv b -> FSEnv a
$c<$ :: forall a b. a -> FSEnv b -> FSEnv a
fmap :: (a -> b) -> FSEnv a -> FSEnv b
$cfmap :: forall a b. (a -> b) -> FSEnv a -> FSEnv b
Functor)

instance PatternMap FSEnv where
  type Key FSEnv = GHC.FastString

  mEmpty :: FSEnv a
  mEmpty :: FSEnv a
mEmpty = UniqFM a -> FSEnv a
forall a. UniqFM a -> FSEnv a
FSEnv UniqFM a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty

  mUnion :: FSEnv a -> FSEnv a -> FSEnv a
  mUnion :: FSEnv a -> FSEnv a -> FSEnv a
mUnion (FSEnv UniqFM a
m1) (FSEnv UniqFM a
m2) = UniqFM a -> FSEnv a
forall a. UniqFM a -> FSEnv a
FSEnv (UniqFM a -> UniqFM a -> UniqFM a
forall (m :: * -> *) a. PatternMap m => m a -> m a -> m a
mUnion UniqFM a
m1 UniqFM a
m2)

  mAlter :: AlphaEnv -> Quantifiers -> Key FSEnv -> A a -> FSEnv a -> FSEnv a
  mAlter :: AlphaEnv -> Quantifiers -> Key FSEnv -> A a -> FSEnv a -> FSEnv a
mAlter AlphaEnv
env Quantifiers
qs Key FSEnv
fs A a
f (FSEnv UniqFM a
m) = UniqFM a -> FSEnv a
forall a. UniqFM a -> FSEnv a
FSEnv (AlphaEnv
-> Quantifiers -> Key UniqFM -> A a -> UniqFM a -> UniqFM a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
qs (FastString -> Unique
forall a. Uniquable a => a -> Unique
GHC.getUnique FastString
Key FSEnv
fs) A a
f UniqFM a
m)

  mMatch :: MatchEnv -> Key FSEnv -> (Substitution, FSEnv a) -> [(Substitution, a)]
  mMatch :: MatchEnv
-> Key FSEnv -> (Substitution, FSEnv a) -> [(Substitution, a)]
mMatch MatchEnv
env Key FSEnv
fs (Substitution
hs, FSEnv UniqFM a
m) = MatchEnv
-> Key UniqFM -> (Substitution, UniqFM a) -> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env (FastString -> Unique
forall a. Uniquable a => a -> Unique
GHC.getUnique FastString
Key FSEnv
fs) (Substitution
hs, UniqFM a
m)

------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ < 900
newtype UniqFM a = UniqFM { UniqFM a -> UniqFM [a]
unUniqFM :: GHC.UniqFM [a] }
#else
newtype UniqFM a = UniqFM { unUniqFM :: GHC.UniqFM (Key UniqFM) [a] }
#endif
  deriving (a -> UniqFM b -> UniqFM a
(a -> b) -> UniqFM a -> UniqFM b
(forall a b. (a -> b) -> UniqFM a -> UniqFM b)
-> (forall a b. a -> UniqFM b -> UniqFM a) -> Functor UniqFM
forall a b. a -> UniqFM b -> UniqFM a
forall a b. (a -> b) -> UniqFM a -> UniqFM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UniqFM b -> UniqFM a
$c<$ :: forall a b. a -> UniqFM b -> UniqFM a
fmap :: (a -> b) -> UniqFM a -> UniqFM b
$cfmap :: forall a b. (a -> b) -> UniqFM a -> UniqFM b
Functor)

instance PatternMap UniqFM where
  type Key UniqFM = GHC.Unique

  mEmpty :: UniqFM a
  mEmpty :: UniqFM a
mEmpty = UniqFM [a] -> UniqFM a
forall a. UniqFM [a] -> UniqFM a
UniqFM UniqFM [a]
forall elt. UniqFM elt
GHC.emptyUFM

  mUnion :: UniqFM a -> UniqFM a -> UniqFM a
  mUnion :: UniqFM a -> UniqFM a -> UniqFM a
mUnion (UniqFM UniqFM [a]
m1) (UniqFM UniqFM [a]
m2) = UniqFM [a] -> UniqFM a
forall a. UniqFM [a] -> UniqFM a
UniqFM (UniqFM [a] -> UniqFM a) -> UniqFM [a] -> UniqFM a
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> UniqFM [a] -> UniqFM [a] -> UniqFM [a]
forall elt.
(elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
GHC.plusUFM_C [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) UniqFM [a]
m1 UniqFM [a]
m2

  mAlter :: AlphaEnv -> Quantifiers -> Key UniqFM -> A a -> UniqFM a -> UniqFM a
  mAlter :: AlphaEnv
-> Quantifiers -> Key UniqFM -> A a -> UniqFM a -> UniqFM a
mAlter AlphaEnv
_ Quantifiers
_ Key UniqFM
k A a
f (UniqFM UniqFM [a]
m) = UniqFM [a] -> UniqFM a
forall a. UniqFM [a] -> UniqFM a
UniqFM (UniqFM [a] -> UniqFM a) -> UniqFM [a] -> UniqFM a
forall a b. (a -> b) -> a -> b
$ (Maybe [a] -> Maybe [a]) -> UniqFM [a] -> Unique -> UniqFM [a]
forall key elt.
Uniquable key =>
(Maybe elt -> Maybe elt) -> UniqFM elt -> key -> UniqFM elt
GHC.alterUFM (A a -> Maybe [a] -> Maybe [a]
forall a. A a -> A [a]
toAList A a
f) UniqFM [a]
m Unique
Key UniqFM
k

  mMatch
    :: MatchEnv
    -> Key UniqFM
    -> (Substitution, UniqFM a)
    -> [(Substitution, a)]
  mMatch :: MatchEnv
-> Key UniqFM -> (Substitution, UniqFM a) -> [(Substitution, a)]
mMatch MatchEnv
_ Key UniqFM
k = (UniqFM a -> Maybe [a])
-> (Substitution, UniqFM a) -> [(Substitution, a)]
forall b c a. (b -> Maybe [c]) -> (a, b) -> [(a, c)]
maybeListMap ((UniqFM [a] -> Unique -> Maybe [a])
-> Unique -> UniqFM [a] -> Maybe [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqFM [a] -> Unique -> Maybe [a]
forall elt. UniqFM elt -> Unique -> Maybe elt
GHC.lookupUFM_Directly Unique
Key UniqFM
k (UniqFM [a] -> Maybe [a])
-> (UniqFM a -> UniqFM [a]) -> UniqFM a -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqFM a -> UniqFM [a]
forall a. UniqFM a -> UniqFM [a]
unUniqFM)

------------------------------------------------------------------------