{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}

module Data.Discrimination.Grouping
  ( Group(..)
  , Grouping(..)
  , Grouping1(..)
  -- * Combinators
  , nub, nubWith
  , group, groupWith
  , groupingEq
  , runGroup
  -- * Internals
  , hashing
  ) where

import Control.Monad hiding (mapM_)
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Complex
import Data.Discrimination.Internal.WordMap as WordMap
import Data.Discrimination.Internal
import Data.Foldable hiding (concat)
import Data.Functor.Compose
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Functor.Contravariant.Generic
import Data.Hashable
import Data.Int
import Data.List.NonEmpty (NonEmpty)
import Data.Semigroup hiding (Any)
import Data.Primitive.MutVar
import Data.Promise
import Data.Proxy
import Data.Ratio
import Data.Typeable
import Data.Void
import Data.Word
import Numeric.Natural (Natural)
import Prelude hiding (read, concat, mapM_)

-- | Productive Stable Unordered Discriminator

newtype Group a = Group
  { Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup :: forall m b. PrimMonad m
             => (b -> m (b -> m ())) -> m (a -> b -> m ())
  } deriving Typeable

-- Note: Group should be
--
--     type role Group representational
--
-- but it isn't due PrimMonad not implying higher-order Coercible constraint.

instance Contravariant Group where
  contramap :: (a -> b) -> Group b -> Group a
contramap a -> b
f Group b
m = (forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a.
(forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
Group ((forall (m :: * -> *) b.
  PrimMonad m =>
  (b -> m (b -> m ())) -> m (a -> b -> m ()))
 -> Group a)
-> (forall (m :: * -> *) b.
    PrimMonad m =>
    (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a b. (a -> b) -> a -> b
$ \b -> m (b -> m ())
k -> do
    b -> b -> m ()
g <- Group b -> (b -> m (b -> m ())) -> m (b -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group b
m b -> m (b -> m ())
k
    (a -> b -> m ()) -> m (a -> b -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> m ()
g (b -> b -> m ()) -> (a -> b) -> a -> b -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Divisible Group where
  conquer :: Group a
conquer = (forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a.
(forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
Group ((forall (m :: * -> *) b.
  PrimMonad m =>
  (b -> m (b -> m ())) -> m (a -> b -> m ()))
 -> Group a)
-> (forall (m :: * -> *) b.
    PrimMonad m =>
    (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a b. (a -> b) -> a -> b
$ \ (b -> m (b -> m ())
k :: b -> m (b -> m ())) -> do
    MutVar (PrimState m) (b -> m ())
v <- (b -> m ()) -> m (MutVar (PrimState m) (b -> m ()))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar b -> m ()
forall a. HasCallStack => a
undefined
    MutVar (PrimState m) (b -> m ()) -> (b -> m ()) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (b -> m ())
v ((b -> m ()) -> m ()) -> (b -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \b
b -> b -> m (b -> m ())
k b
b m (b -> m ()) -> ((b -> m ()) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutVar (PrimState m) (b -> m ()) -> (b -> m ()) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (b -> m ())
v
    (a -> b -> m ()) -> m (a -> b -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> b -> m ()) -> m (a -> b -> m ()))
-> (a -> b -> m ()) -> m (a -> b -> m ())
forall a b. (a -> b) -> a -> b
$ \ a
_ b
b -> MutVar (PrimState m) (b -> m ()) -> m (b -> m ())
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (b -> m ())
v m (b -> m ()) -> ((b -> m ()) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((b -> m ()) -> b -> m ()
forall a b. (a -> b) -> a -> b
$ b
b)

  divide :: (a -> (b, c)) -> Group b -> Group c -> Group a
divide a -> (b, c)
f Group b
m Group c
n = (forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a.
(forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
Group ((forall (m :: * -> *) b.
  PrimMonad m =>
  (b -> m (b -> m ())) -> m (a -> b -> m ()))
 -> Group a)
-> (forall (m :: * -> *) b.
    PrimMonad m =>
    (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a b. (a -> b) -> a -> b
$ \b -> m (b -> m ())
k -> do
    b -> (c, b) -> m ()
kbcd <- Group b
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (b -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group b
m (((c, b) -> m ((c, b) -> m ())) -> m (b -> (c, b) -> m ()))
-> ((c, b) -> m ((c, b) -> m ())) -> m (b -> (c, b) -> m ())
forall a b. (a -> b) -> a -> b
$ \ (c
c, b
d) -> do
      c -> b -> m ()
kcd <- Group c -> (b -> m (b -> m ())) -> m (c -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group c
n b -> m (b -> m ())
k
      c -> b -> m ()
kcd c
c b
d
      ((c, b) -> m ()) -> m ((c, b) -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (((c, b) -> m ()) -> m ((c, b) -> m ()))
-> ((c, b) -> m ()) -> m ((c, b) -> m ())
forall a b. (a -> b) -> a -> b
$ (c -> b -> m ()) -> (c, b) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry c -> b -> m ()
kcd
    (a -> b -> m ()) -> m (a -> b -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> b -> m ()) -> m (a -> b -> m ()))
-> (a -> b -> m ()) -> m (a -> b -> m ())
forall a b. (a -> b) -> a -> b
$ \ a
a b
d -> case a -> (b, c)
f a
a of
      (b
b, c
c) -> b -> (c, b) -> m ()
kbcd b
b (c
c, b
d)

instance Decidable Group where
  choose :: (a -> Either b c) -> Group b -> Group c -> Group a
choose a -> Either b c
f Group b
m Group c
n = (forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a.
(forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
Group ((forall (m :: * -> *) b.
  PrimMonad m =>
  (b -> m (b -> m ())) -> m (a -> b -> m ()))
 -> Group a)
-> (forall (m :: * -> *) b.
    PrimMonad m =>
    (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a b. (a -> b) -> a -> b
$ \b -> m (b -> m ())
k -> do
    b -> b -> m ()
kb <- Group b -> (b -> m (b -> m ())) -> m (b -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group b
m b -> m (b -> m ())
k
    c -> b -> m ()
kc <- Group c -> (b -> m (b -> m ())) -> m (c -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group c
n b -> m (b -> m ())
k
    (a -> b -> m ()) -> m (a -> b -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((b -> b -> m ()) -> (c -> b -> m ()) -> Either b c -> b -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> b -> m ()
kb c -> b -> m ()
kc (Either b c -> b -> m ()) -> (a -> Either b c) -> a -> b -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b c
f)

  lose :: (a -> Void) -> Group a
lose a -> Void
k = (forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a.
(forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
Group ((forall (m :: * -> *) b.
  PrimMonad m =>
  (b -> m (b -> m ())) -> m (a -> b -> m ()))
 -> Group a)
-> (forall (m :: * -> *) b.
    PrimMonad m =>
    (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
forall a b. (a -> b) -> a -> b
$ \b -> m (b -> m ())
_ -> (a -> b -> m ()) -> m (a -> b -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Void -> b -> m ()
forall a. Void -> a
absurd (Void -> b -> m ()) -> (a -> Void) -> a -> b -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
k)

instance Semigroup (Group a) where
  <> :: Group a -> Group a -> Group a
(<>) = (a -> (a, a)) -> Group a -> Group a -> Group a
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\a
a -> (a
a,a
a))

instance Monoid (Group a) where
  mempty :: Group a
mempty = Group a
forall (f :: * -> *) a. Divisible f => f a
conquer
  mappend :: Group a -> Group a -> Group a
mappend = Group a -> Group a -> Group a
forall a. Semigroup a => a -> a -> a
(<>)

--------------------------------------------------------------------------------
-- Primitives
--------------------------------------------------------------------------------

groupingWord64 :: Group Word64
groupingWord64 :: Group Word64
groupingWord64 = (forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (Word64 -> b -> m ()))
-> Group Word64
forall a.
(forall (m :: * -> *) b.
 PrimMonad m =>
 (b -> m (b -> m ())) -> m (a -> b -> m ()))
-> Group a
Group ((forall (m :: * -> *) b.
  PrimMonad m =>
  (b -> m (b -> m ())) -> m (Word64 -> b -> m ()))
 -> Group Word64)
-> (forall (m :: * -> *) b.
    PrimMonad m =>
    (b -> m (b -> m ())) -> m (Word64 -> b -> m ()))
-> Group Word64
forall a b. (a -> b) -> a -> b
$ \b -> m (b -> m ())
k -> do
  MutVar (PrimState m) (WordMap (b -> m ()))
mt <- WordMap (b -> m ())
-> m (MutVar (PrimState m) (WordMap (b -> m ())))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar WordMap (b -> m ())
forall a. WordMap a
WordMap.empty
  (Word64 -> b -> m ()) -> m (Word64 -> b -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word64 -> b -> m ()) -> m (Word64 -> b -> m ()))
-> (Word64 -> b -> m ()) -> m (Word64 -> b -> m ())
forall a b. (a -> b) -> a -> b
$ \Word64
a b
b -> MutVar (PrimState m) (WordMap (b -> m ()))
-> m (WordMap (b -> m ()))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (WordMap (b -> m ()))
mt m (WordMap (b -> m ())) -> (WordMap (b -> m ()) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WordMap (b -> m ())
m -> case Word64 -> WordMap (b -> m ()) -> Maybe (b -> m ())
forall v. Word64 -> WordMap v -> Maybe v
WordMap.lookup Word64
a WordMap (b -> m ())
m of
    Maybe (b -> m ())
Nothing -> b -> m (b -> m ())
k b
b m (b -> m ()) -> ((b -> m ()) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b -> m ()
p -> MutVar (PrimState m) (WordMap (b -> m ()))
-> WordMap (b -> m ()) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (WordMap (b -> m ()))
mt (Word64 -> (b -> m ()) -> WordMap (b -> m ()) -> WordMap (b -> m ())
forall v. Word64 -> v -> WordMap v -> WordMap v
insert Word64
a b -> m ()
p WordMap (b -> m ())
m)
    Just b -> m ()
n -> b -> m ()
n b
b

-- | This may be useful for pragmatically accelerating a grouping structure by
-- preclassifying by a hash function
--
-- Semantically,
--
-- @
-- grouping = hashing <> grouping
-- @
hashing :: Hashable a => Group a
hashing :: Group a
hashing = (a -> Int) -> Group Int -> Group a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> Int
forall a. Hashable a => a -> Int
hash Group Int
forall a. Grouping a => Group a
grouping

--------------------------------------------------------------------------------
-- * Unordered Discrimination (for partitioning)
--------------------------------------------------------------------------------

-- | 'Eq' equipped with a compatible stable unordered discriminator.
--
-- Law:
--
-- @
-- 'groupingEq' x y ≡ (x '==' y)
-- @
--
-- /Note:/ 'Eq' is a moral super class of 'Grouping'.
-- It isn't because of some missing instances.
class Grouping a where
  -- | For every surjection @f@,
  --
  -- @
  -- 'contramap' f 'grouping' ≡ 'grouping'
  -- @

  grouping :: Group a
  default grouping :: Deciding Grouping a => Group a
  grouping = Proxy Grouping -> (forall a. Grouping a => Group a) -> Group a
forall (q :: * -> Constraint) a (f :: * -> *)
       (p :: (* -> Constraint) -> *).
(Deciding q a, Decidable f) =>
p q -> (forall b. q b => f b) -> f a
deciding (Proxy Grouping
forall k (t :: k). Proxy t
Proxy :: Proxy Grouping) forall a. Grouping a => Group a
grouping

instance Grouping Void where grouping :: Group Void
grouping = (Void -> Void) -> Group Void
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose Void -> Void
forall a. a -> a
id
instance Grouping () where grouping :: Group ()
grouping = Group ()
forall (f :: * -> *) a. Divisible f => f a
conquer
instance Grouping Word8 where grouping :: Group Word8
grouping = (Word8 -> Word64) -> Group Word64 -> Group Word8
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Word16 where grouping :: Group Word16
grouping = (Word16 -> Word64) -> Group Word64 -> Group Word16
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Word32 where grouping :: Group Word32
grouping = (Word32 -> Word64) -> Group Word64 -> Group Word32
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Word64 where grouping :: Group Word64
grouping = Group Word64
groupingWord64
instance Grouping Word where grouping :: Group Word
grouping = (Word -> Word64) -> Group Word64 -> Group Word
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Int8 where grouping :: Group Int8
grouping = (Int8 -> Word64) -> Group Word64 -> Group Int8
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Int8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Int16 where grouping :: Group Int16
grouping = (Int16 -> Word64) -> Group Word64 -> Group Int16
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Int16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Int32 where grouping :: Group Int32
grouping = (Int32 -> Word64) -> Group Word64 -> Group Int32
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Int32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Int64 where grouping :: Group Int64
grouping = (Int64 -> Word64) -> Group Word64 -> Group Int64
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Int where grouping :: Group Int
grouping = (Int -> Word64) -> Group Word64 -> Group Int
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Group Word64
groupingWord64
instance Grouping Char where grouping :: Group Char
grouping = (Char -> Word64) -> Group Word64 -> Group Char
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (Char -> Int) -> Char -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) Group Word64
groupingWord64

instance Grouping Bool
instance Grouping Ordering
instance (Grouping a, Grouping b) => Grouping (a, b)
instance (Grouping a, Grouping b, Grouping c) => Grouping (a, b, c)
instance (Grouping a, Grouping b, Grouping c, Grouping d) => Grouping (a, b, c, d)
instance Grouping a => Grouping [a]
instance Grouping a => Grouping (NonEmpty a)
instance Grouping a => Grouping (Maybe a)
instance (Grouping a, Grouping b) => Grouping (Either a b)
instance Grouping a => Grouping (Complex a) where
  grouping :: Group (Complex a)
grouping = (Complex a -> (a, a)) -> Group a -> Group a -> Group (Complex a)
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\(a
a :+ a
b) -> (a
a, a
b)) Group a
forall a. Grouping a => Group a
grouping Group a
forall a. Grouping a => Group a
grouping

instance Grouping Integer where
  grouping :: Group Integer
grouping = (Integer -> Either (Int, [Word]) (Either Int (Int, [Word])))
-> Group (Int, [Word])
-> Group (Either Int (Int, [Word]))
-> Group Integer
forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose Integer -> Either (Int, [Word]) (Either Int (Int, [Word]))
integerCases Group (Int, [Word])
forall a. Grouping a => Group a
grouping ((Either Int (Int, [Word]) -> Either Int (Int, [Word]))
-> Group Int
-> Group (Int, [Word])
-> Group (Either Int (Int, [Word]))
forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose Either Int (Int, [Word]) -> Either Int (Int, [Word])
forall a. a -> a
id Group Int
forall a. Grouping a => Group a
grouping Group (Int, [Word])
forall a. Grouping a => Group a
grouping)

instance Grouping Natural where
  grouping :: Group Natural
grouping = (Natural -> Either Word (Int, [Word]))
-> Group Word -> Group (Int, [Word]) -> Group Natural
forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose Natural -> Either Word (Int, [Word])
naturalCases Group Word
forall a. Grouping a => Group a
grouping Group (Int, [Word])
forall a. Grouping a => Group a
grouping

#if __GLASGOW_HASKELL__ >= 800
instance Grouping a => Grouping (Ratio a) where
#else
instance (Grouping a, Integral a) => Grouping (Ratio a) where
#endif
  grouping :: Group (Ratio a)
grouping = (Ratio a -> (a, a)) -> Group a -> Group a -> Group (Ratio a)
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\Ratio a
r -> (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
r, Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
r)) Group a
forall a. Grouping a => Group a
grouping Group a
forall a. Grouping a => Group a
grouping

instance (Grouping1 f, Grouping1 g, Grouping a) => Grouping (Compose f g a) where
  grouping :: Group (Compose f g a)
grouping = Compose f g a -> f (g a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose f g a -> f (g a))
-> Group (f (g a)) -> Group (Compose f g a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Group (g a) -> Group (f (g a))
forall (f :: * -> *) a. Grouping1 f => Group a -> Group (f a)
grouping1 (Group a -> Group (g a)
forall (f :: * -> *) a. Grouping1 f => Group a -> Group (f a)
grouping1 Group a
forall a. Grouping a => Group a
grouping)

class Grouping1 f where
  grouping1 :: Group a -> Group (f a)
  default grouping1 :: Deciding1 Grouping f => Group a -> Group (f a)
  grouping1 = Proxy Grouping
-> (forall a. Grouping a => Group a) -> Group a -> Group (f a)
forall (q :: * -> Constraint) (t :: * -> *) (f :: * -> *)
       (p :: (* -> Constraint) -> *) a.
(Deciding1 q t, Decidable f) =>
p q -> (forall b. q b => f b) -> f a -> f (t a)
deciding1 (Proxy Grouping
forall k (t :: k). Proxy t
Proxy :: Proxy Grouping) forall a. Grouping a => Group a
grouping

instance Grouping1 []
instance Grouping1 Maybe
instance Grouping1 NonEmpty
instance Grouping a => Grouping1 (Either a)
instance Grouping a => Grouping1 ((,) a)
instance (Grouping a, Grouping b) => Grouping1 ((,,) a b)
instance (Grouping a, Grouping b, Grouping c) => Grouping1 ((,,,) a b c)
instance (Grouping1 f, Grouping1 g) => Grouping1 (Compose f g) where
  grouping1 :: Group a -> Group (Compose f g a)
grouping1 Group a
f = Compose f g a -> f (g a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose f g a -> f (g a))
-> Group (f (g a)) -> Group (Compose f g a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Group (g a) -> Group (f (g a))
forall (f :: * -> *) a. Grouping1 f => Group a -> Group (f a)
grouping1 (Group a -> Group (g a)
forall (f :: * -> *) a. Grouping1 f => Group a -> Group (f a)
grouping1 Group a
f)
instance Grouping1 Complex where
  grouping1 :: Group a -> Group (Complex a)
grouping1 Group a
f = (Complex a -> (a, a)) -> Group a -> Group a -> Group (Complex a)
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\(a
a :+ a
b) -> (a
a, a
b)) Group a
f Group a
f

-- | Valid definition for @('==')@ in terms of 'Grouping'.
groupingEq :: Grouping a => a -> a -> Bool
groupingEq :: a -> a -> Bool
groupingEq a
a a
b = (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ do
  MutVar s Word8
rn <- Word8 -> ST s (MutVar (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (Word8
0 :: Word8)
  a -> () -> ST s ()
k <- Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group a
forall a. Grouping a => Group a
grouping ((() -> ST s (() -> ST s ())) -> ST s (a -> () -> ST s ()))
-> (() -> ST s (() -> ST s ())) -> ST s (a -> () -> ST s ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    MutVar (PrimState (ST s)) Word8 -> (Word8 -> Word8) -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> a) -> m ()
modifyMutVar' MutVar s Word8
MutVar (PrimState (ST s)) Word8
rn (Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+Word8
1)
    (() -> ST s ()) -> ST s (() -> ST s ())
forall (m :: * -> *) a. Monad m => a -> m a
return () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return
  a -> () -> ST s ()
k a
a ()
  a -> () -> ST s ()
k a
b ()
  Word8
n <- MutVar (PrimState (ST s)) Word8 -> ST s Word8
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s Word8
MutVar (PrimState (ST s)) Word8
rn
  Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Word8
n Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1
{-# INLINE groupingEq #-}

runGroup :: Group a -> [(a,b)] -> [[b]]
runGroup :: Group a -> [(a, b)] -> [[b]]
runGroup (Group forall (m :: * -> *) b.
PrimMonad m =>
(b -> m (b -> m ())) -> m (a -> b -> m ())
m) [(a, b)]
xs = (forall s. Promise s [[b]] -> Lazy s ()) -> [[b]] -> [[b]]
forall a b. (forall s. Promise s a -> Lazy s b) -> a -> a
runLazy (\Promise s [[b]]
p0 -> do
    MutVar s (Promise s [[b]])
rp <- Promise s [[b]]
-> Lazy s (MutVar (PrimState (Lazy s)) (Promise s [[b]]))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Promise s [[b]]
p0
    a -> b -> Lazy s ()
f <- (b -> Lazy s (b -> Lazy s ())) -> Lazy s (a -> b -> Lazy s ())
forall (m :: * -> *) b.
PrimMonad m =>
(b -> m (b -> m ())) -> m (a -> b -> m ())
m ((b -> Lazy s (b -> Lazy s ())) -> Lazy s (a -> b -> Lazy s ()))
-> (b -> Lazy s (b -> Lazy s ())) -> Lazy s (a -> b -> Lazy s ())
forall a b. (a -> b) -> a -> b
$ \ b
b -> do
      Promise s [[b]]
p <- MutVar (PrimState (Lazy s)) (Promise s [[b]])
-> Lazy s (Promise s [[b]])
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (Promise s [[b]])
MutVar (PrimState (Lazy s)) (Promise s [[b]])
rp
      Promise s [b]
q <- [b] -> Lazy s (Promise s [b])
forall a s. a -> Lazy s (Promise s a)
promise []
      Promise s [[b]]
p' <- [[b]] -> Lazy s (Promise s [[b]])
forall a s. a -> Lazy s (Promise s a)
promise []
      Promise s [[b]]
p Promise s [[b]] -> [[b]] -> Lazy s ()
forall s a. Promise s a -> a -> Lazy s ()
!= (b
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Promise s [b] -> [b]
forall s a. Promise s a -> a
demand Promise s [b]
q) [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: Promise s [[b]] -> [[b]]
forall s a. Promise s a -> a
demand Promise s [[b]]
p'
      MutVar (PrimState (Lazy s)) (Promise s [[b]])
-> Promise s [[b]] -> Lazy s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (Promise s [[b]])
MutVar (PrimState (Lazy s)) (Promise s [[b]])
rp Promise s [[b]]
p'
      MutVar s (Promise s [b])
rq <- Promise s [b]
-> Lazy s (MutVar (PrimState (Lazy s)) (Promise s [b]))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Promise s [b]
q
      (b -> Lazy s ()) -> Lazy s (b -> Lazy s ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((b -> Lazy s ()) -> Lazy s (b -> Lazy s ()))
-> (b -> Lazy s ()) -> Lazy s (b -> Lazy s ())
forall a b. (a -> b) -> a -> b
$ \b
b' -> do
        Promise s [b]
q' <- MutVar (PrimState (Lazy s)) (Promise s [b])
-> Lazy s (Promise s [b])
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (Promise s [b])
MutVar (PrimState (Lazy s)) (Promise s [b])
rq
        Promise s [b]
q'' <- [b] -> Lazy s (Promise s [b])
forall a s. a -> Lazy s (Promise s a)
promise []
        Promise s [b]
q' Promise s [b] -> [b] -> Lazy s ()
forall s a. Promise s a -> a -> Lazy s ()
!= b
b' b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Promise s [b] -> [b]
forall s a. Promise s a -> a
demand Promise s [b]
q''
        MutVar (PrimState (Lazy s)) (Promise s [b])
-> Promise s [b] -> Lazy s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (Promise s [b])
MutVar (PrimState (Lazy s)) (Promise s [b])
rq Promise s [b]
q''
    ((a, b) -> Lazy s ()) -> [(a, b)] -> Lazy s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((a -> b -> Lazy s ()) -> (a, b) -> Lazy s ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Lazy s ()
f) [(a, b)]
xs
  ) []

--------------------------------------------------------------------------------
-- * Combinators
--------------------------------------------------------------------------------

-- | /O(n)/. Similar to 'Data.List.group', except we do not require groups to be clustered.
--
-- This combinator still operates in linear time, at the expense of storing history.
--
-- The result equivalence classes are __not__ sorted, but the grouping is stable.
--
-- @
-- 'group' = 'groupWith' 'id'
-- @
group :: Grouping a => [a] -> [[a]]
group :: [a] -> [[a]]
group [a]
as = Group a -> [(a, a)] -> [[a]]
forall a b. Group a -> [(a, b)] -> [[b]]
runGroup Group a
forall a. Grouping a => Group a
grouping [(a
a, a
a) | a
a <- [a]
as]

-- | /O(n)/. This is a replacement for 'GHC.Exts.groupWith' using discrimination.
--
-- The result equivalence classes are __not__ sorted, but the grouping is stable.
groupWith :: Grouping b => (a -> b) -> [a] -> [[a]]
groupWith :: (a -> b) -> [a] -> [[a]]
groupWith a -> b
f [a]
as = Group b -> [(b, a)] -> [[a]]
forall a b. Group a -> [(a, b)] -> [[b]]
runGroup Group b
forall a. Grouping a => Group a
grouping [(a -> b
f a
a, a
a) | a
a <- [a]
as]

-- | /O(n)/. This upgrades 'Data.List.nub' from @Data.List@ from /O(n^2)/ to /O(n)/ by using
-- productive unordered discrimination.
--
-- @
-- 'nub' = 'nubWith' 'id'
-- 'nub' as = 'head' 'Control.Applicative.<$>' 'group' as
-- @
nub :: Grouping a => [a] -> [a]
nub :: [a] -> [a]
nub = (a -> a) -> [a] -> [a]
forall b a. Grouping b => (a -> b) -> [a] -> [a]
nubWith a -> a
forall a. a -> a
id

-- | /O(n)/. Online 'nub' with a Schwartzian transform.
--
-- @
-- 'nubWith' f as = 'head' 'Control.Applicative.<$>' 'groupWith' f as
-- @
nubWith :: Grouping b => (a -> b) -> [a] -> [a]
nubWith :: (a -> b) -> [a] -> [a]
nubWith a -> b
f [a]
xs = (forall s. Promise s [a] -> Lazy s ()) -> [a] -> [a]
forall a b. (forall s. Promise s a -> Lazy s b) -> a -> a
runLazy (\Promise s [a]
p0 -> do
    MutVar s (Promise s [a])
rp <- Promise s [a]
-> Lazy s (MutVar (PrimState (Lazy s)) (Promise s [a]))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Promise s [a]
p0
    b -> a -> Lazy s ()
k <- Group b
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (b -> b -> m ())
forall a.
Group a
-> forall (m :: * -> *) b.
   PrimMonad m =>
   (b -> m (b -> m ())) -> m (a -> b -> m ())
getGroup Group b
forall a. Grouping a => Group a
grouping ((a -> Lazy s (a -> Lazy s ())) -> Lazy s (b -> a -> Lazy s ()))
-> (a -> Lazy s (a -> Lazy s ())) -> Lazy s (b -> a -> Lazy s ())
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      Promise s [a]
p' <- [a] -> Lazy s (Promise s [a])
forall a s. a -> Lazy s (Promise s a)
promise []
      Promise s [a]
p <- MutVar (PrimState (Lazy s)) (Promise s [a])
-> Lazy s (Promise s [a])
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (Promise s [a])
MutVar (PrimState (Lazy s)) (Promise s [a])
rp
      Promise s [a]
p Promise s [a] -> [a] -> Lazy s ()
forall s a. Promise s a -> a -> Lazy s ()
!= a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Promise s [a] -> [a]
forall s a. Promise s a -> a
demand Promise s [a]
p'
      MutVar (PrimState (Lazy s)) (Promise s [a])
-> Promise s [a] -> Lazy s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (Promise s [a])
MutVar (PrimState (Lazy s)) (Promise s [a])
rp Promise s [a]
p'
      (a -> Lazy s ()) -> Lazy s (a -> Lazy s ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> Lazy s ()) -> Lazy s (a -> Lazy s ()))
-> (a -> Lazy s ()) -> Lazy s (a -> Lazy s ())
forall a b. (a -> b) -> a -> b
$ \ a
_ -> () -> Lazy s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (a -> Lazy s ()) -> [a] -> Lazy s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\a
x -> b -> a -> Lazy s ()
k (a -> b
f a
x) a
x) [a]
xs
  ) []