{-# LANGUAGE QuantifiedConstraints #-}

module Data.OpenApi.Compare.PathsPrefixTree
  ( PathsPrefixTree (PathsPrefixNode),
    AStep (..),
    empty,
    singleton,
    fromList,
    null,
    foldWith,
    toList,
    filter,
    filterWithKey,
    takeSubtree,
    lookup,
    embed,
    size,
    partition,
    map,
  )
where

import Control.Monad
import Data.Aeson
import Data.Foldable hiding (null, toList)
import qualified Data.HashMap.Strict as HM
import Data.Kind
import qualified Data.Map as M
import Data.Monoid
import Data.OpenApi.Compare.Paths
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Type.Equality
import qualified Data.TypeRepMap as TRM
import qualified Data.Vector as V
import qualified GHC.Exts as Exts
import Type.Reflection
import Prelude hiding (filter, lookup, map, null)

-- | A list of @AnItem r f@, but optimized into a prefix tree.
data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree
  { PathsPrefixTree q f r -> ASet (f r)
rootItems :: !(ASet (f r))
  , PathsPrefixTree q f r -> TypeRepMap (AStep q f r)
snocItems :: !(TRM.TypeRepMap (AStep q f r))
  }
  deriving stock (Int -> PathsPrefixTree q f r -> ShowS
[PathsPrefixTree q f r] -> ShowS
PathsPrefixTree q f r -> String
(Int -> PathsPrefixTree q f r -> ShowS)
-> (PathsPrefixTree q f r -> String)
-> ([PathsPrefixTree q f r] -> ShowS)
-> Show (PathsPrefixTree q f r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
Show (f r) =>
Int -> PathsPrefixTree q f r -> ShowS
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
Show (f r) =>
[PathsPrefixTree q f r] -> ShowS
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
Show (f r) =>
PathsPrefixTree q f r -> String
showList :: [PathsPrefixTree q f r] -> ShowS
$cshowList :: forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
Show (f r) =>
[PathsPrefixTree q f r] -> ShowS
show :: PathsPrefixTree q f r -> String
$cshow :: forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
Show (f r) =>
PathsPrefixTree q f r -> String
showsPrec :: Int -> PathsPrefixTree q f r -> ShowS
$cshowsPrec :: forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
Show (f r) =>
Int -> PathsPrefixTree q f r -> ShowS
Show)

map :: (forall x. f x -> f x) -> PathsPrefixTree q f r -> PathsPrefixTree q f r
map :: (forall (x :: k). f x -> f x)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
map forall (x :: k). f x -> f x
f (PathsPrefixTree ASet (f r)
roots TypeRepMap (AStep q f r)
branches) =
  ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree ((f r -> f r) -> ASet (f r) -> ASet (f r)
forall a b. (Ord a => Ord b) => (a -> b) -> ASet a -> ASet b
mapASet f r -> f r
forall (x :: k). f x -> f x
f ASet (f r)
roots) ((forall (x :: k). AStep q f r x -> AStep q f r x)
-> TypeRepMap (AStep q f r) -> TypeRepMap (AStep q f r)
forall k (f :: k -> *) (g :: k -> *).
(forall (x :: k). f x -> g x) -> TypeRepMap f -> TypeRepMap g
TRM.hoist ((forall (x :: k). f x -> f x) -> AStep q f r x -> AStep q f r x
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k) (a :: k).
(forall (x :: k). f x -> f x) -> AStep q f r a -> AStep q f r a
mapAStep forall (x :: k). f x -> f x
f) TypeRepMap (AStep q f r)
branches)

-- TODO: optimize
partition :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> (PathsPrefixTree q f r, PathsPrefixTree q f r)
partition :: (forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r
-> (PathsPrefixTree q f r, PathsPrefixTree q f r)
partition forall (a :: k). f a -> Bool
f PathsPrefixTree q f r
x = ((forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
filter forall (a :: k). f a -> Bool
f PathsPrefixTree q f r
x, (forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
filter (Bool -> Bool
not (Bool -> Bool) -> (f a -> Bool) -> f a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Bool
forall (a :: k). f a -> Bool
f) PathsPrefixTree q f r
x)

filter :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> PathsPrefixTree q f r
filter :: (forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
filter forall (a :: k). f a -> Bool
f (PathsPrefixTree ASet (f r)
roots TypeRepMap (AStep q f r)
branches) = ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree ASet (f r)
roots' TypeRepMap (AStep q f r)
branches'
  where
    roots' :: ASet (f r)
roots' = (f r -> Bool) -> ASet (f r) -> ASet (f r)
forall a. (a -> Bool) -> ASet a -> ASet a
filterASet f r -> Bool
forall (a :: k). f a -> Bool
f ASet (f r)
roots
    branches' :: TypeRepMap (AStep q f r)
branches' =
      [WrapTypeable (AStep q f r)] -> TypeRepMap (AStep q f r)
forall l. IsList l => [Item l] -> l
Exts.fromList
        ([WrapTypeable (AStep q f r)] -> TypeRepMap (AStep q f r))
-> (TypeRepMap (AStep q f r) -> [WrapTypeable (AStep q f r)])
-> TypeRepMap (AStep q f r)
-> TypeRepMap (AStep q f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WrapTypeable (AStep q f r) -> WrapTypeable (AStep q f r))
-> [WrapTypeable (AStep q f r)] -> [WrapTypeable (AStep q f r)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TRM.WrapTypeable (AStep x)) -> AStep q f r a -> WrapTypeable (AStep q f r)
forall k (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
TRM.WrapTypeable (AStep q f r a -> WrapTypeable (AStep q f r))
-> (Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a)
-> Map (q r a) (PathsPrefixTree q f a)
-> WrapTypeable (AStep q f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
NiceQuiver q r a =>
Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
AStep (Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a)
-> (Map (q r a) (PathsPrefixTree q f a)
    -> Map (q r a) (PathsPrefixTree q f a))
-> Map (q r a) (PathsPrefixTree q f a)
-> AStep q f r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathsPrefixTree q f a -> Maybe (PathsPrefixTree q f a))
-> Map (q r a) (PathsPrefixTree q f a)
-> Map (q r a) (PathsPrefixTree q f a)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe (PathsPrefixTree q f a -> Maybe (PathsPrefixTree q f a)
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r)
maybeNonEmpty (PathsPrefixTree q f a -> Maybe (PathsPrefixTree q f a))
-> (PathsPrefixTree q f a -> PathsPrefixTree q f a)
-> PathsPrefixTree q f a
-> Maybe (PathsPrefixTree q f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f a -> PathsPrefixTree q f a
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
filter forall (a :: k). f a -> Bool
f) (Map (q r a) (PathsPrefixTree q f a) -> WrapTypeable (AStep q f r))
-> Map (q r a) (PathsPrefixTree q f a)
-> WrapTypeable (AStep q f r)
forall a b. (a -> b) -> a -> b
$ Map (q r a) (PathsPrefixTree q f a)
x)
        ([WrapTypeable (AStep q f r)] -> [WrapTypeable (AStep q f r)])
-> (TypeRepMap (AStep q f r) -> [WrapTypeable (AStep q f r)])
-> TypeRepMap (AStep q f r)
-> [WrapTypeable (AStep q f r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRepMap (AStep q f r) -> [WrapTypeable (AStep q f r)]
forall l. IsList l => l -> [Item l]
Exts.toList
        (TypeRepMap (AStep q f r) -> TypeRepMap (AStep q f r))
-> TypeRepMap (AStep q f r) -> TypeRepMap (AStep q f r)
forall a b. (a -> b) -> a -> b
$ TypeRepMap (AStep q f r)
branches

    maybeNonEmpty :: PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r)
maybeNonEmpty = (PathsPrefixTree q f r -> Bool)
-> Maybe (PathsPrefixTree q f r) -> Maybe (PathsPrefixTree q f r)
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not (Bool -> Bool)
-> (PathsPrefixTree q f r -> Bool) -> PathsPrefixTree q f r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsPrefixTree q f r -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
null) (Maybe (PathsPrefixTree q f r) -> Maybe (PathsPrefixTree q f r))
-> (PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r))
-> PathsPrefixTree q f r
-> Maybe (PathsPrefixTree q f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r)
forall a. a -> Maybe a
Just

filterWithKey :: (forall a. Paths q r a -> f a -> Bool) -> PathsPrefixTree q f r -> PathsPrefixTree q f r
filterWithKey :: (forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
filterWithKey = Paths q r r
-> (forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f r
-> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (r :: k) (b :: k) (f :: k -> *).
Paths q r b
-> (forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f b
-> PathsPrefixTree q f b
go Paths q r r
forall k (q :: k -> k -> *) (a :: k). Paths q a a
Root
  where
    go :: Paths q r b -> (forall a. Paths q r a -> f a -> Bool) -> PathsPrefixTree q f b -> PathsPrefixTree q f b
    go :: Paths q r b
-> (forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f b
-> PathsPrefixTree q f b
go Paths q r b
xs forall (a :: k). Paths q r a -> f a -> Bool
f (PathsPrefixTree ASet (f b)
roots TypeRepMap (AStep q f b)
branches) = ASet (f b) -> TypeRepMap (AStep q f b) -> PathsPrefixTree q f b
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree ASet (f b)
roots' TypeRepMap (AStep q f b)
branches'
      where
        roots' :: ASet (f b)
roots' = (f b -> Bool) -> ASet (f b) -> ASet (f b)
forall a. (a -> Bool) -> ASet a -> ASet a
filterASet (Paths q r b -> f b -> Bool
forall (a :: k). Paths q r a -> f a -> Bool
f Paths q r b
xs) ASet (f b)
roots
        branches' :: TypeRepMap (AStep q f b)
branches' =
          [WrapTypeable (AStep q f b)] -> TypeRepMap (AStep q f b)
forall l. IsList l => [Item l] -> l
Exts.fromList
            ([WrapTypeable (AStep q f b)] -> TypeRepMap (AStep q f b))
-> (TypeRepMap (AStep q f b) -> [WrapTypeable (AStep q f b)])
-> TypeRepMap (AStep q f b)
-> TypeRepMap (AStep q f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WrapTypeable (AStep q f b) -> WrapTypeable (AStep q f b))
-> [WrapTypeable (AStep q f b)] -> [WrapTypeable (AStep q f b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TRM.WrapTypeable (AStep x)) -> AStep q f b a -> WrapTypeable (AStep q f b)
forall k (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
TRM.WrapTypeable (AStep q f b a -> WrapTypeable (AStep q f b))
-> (Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a)
-> Map (q b a) (PathsPrefixTree q f a)
-> WrapTypeable (AStep q f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
NiceQuiver q r a =>
Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
AStep (Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a)
-> (Map (q b a) (PathsPrefixTree q f a)
    -> Map (q b a) (PathsPrefixTree q f a))
-> Map (q b a) (PathsPrefixTree q f a)
-> AStep q f b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (q b a -> PathsPrefixTree q f a -> Maybe (PathsPrefixTree q f a))
-> Map (q b a) (PathsPrefixTree q f a)
-> Map (q b a) (PathsPrefixTree q f a)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey (\q b a
k -> PathsPrefixTree q f a -> Maybe (PathsPrefixTree q f a)
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r)
maybeNonEmpty (PathsPrefixTree q f a -> Maybe (PathsPrefixTree q f a))
-> (PathsPrefixTree q f a -> PathsPrefixTree q f a)
-> PathsPrefixTree q f a
-> Maybe (PathsPrefixTree q f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paths q r a
-> (forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f a
-> PathsPrefixTree q f a
forall k (q :: k -> k -> *) (r :: k) (b :: k) (f :: k -> *).
Paths q r b
-> (forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f b
-> PathsPrefixTree q f b
go (Paths q r b
xs Paths q r b -> q b a -> Paths q r a
forall k (q :: k -> k -> *) (b :: k) (c :: k) (a :: k).
NiceQuiver q b c =>
Paths q a b -> q b c -> Paths q a c
`Snoc` q b a
k) forall (a :: k). Paths q r a -> f a -> Bool
f) (Map (q b a) (PathsPrefixTree q f a) -> WrapTypeable (AStep q f b))
-> Map (q b a) (PathsPrefixTree q f a)
-> WrapTypeable (AStep q f b)
forall a b. (a -> b) -> a -> b
$ Map (q b a) (PathsPrefixTree q f a)
x)
            ([WrapTypeable (AStep q f b)] -> [WrapTypeable (AStep q f b)])
-> (TypeRepMap (AStep q f b) -> [WrapTypeable (AStep q f b)])
-> TypeRepMap (AStep q f b)
-> [WrapTypeable (AStep q f b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRepMap (AStep q f b) -> [WrapTypeable (AStep q f b)]
forall l. IsList l => l -> [Item l]
Exts.toList
            (TypeRepMap (AStep q f b) -> TypeRepMap (AStep q f b))
-> TypeRepMap (AStep q f b) -> TypeRepMap (AStep q f b)
forall a b. (a -> b) -> a -> b
$ TypeRepMap (AStep q f b)
branches

    maybeNonEmpty :: PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r)
maybeNonEmpty = (PathsPrefixTree q f r -> Bool)
-> Maybe (PathsPrefixTree q f r) -> Maybe (PathsPrefixTree q f r)
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not (Bool -> Bool)
-> (PathsPrefixTree q f r -> Bool) -> PathsPrefixTree q f r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsPrefixTree q f r -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
null) (Maybe (PathsPrefixTree q f r) -> Maybe (PathsPrefixTree q f r))
-> (PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r))
-> PathsPrefixTree q f r
-> Maybe (PathsPrefixTree q f r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsPrefixTree q f r -> Maybe (PathsPrefixTree q f r)
forall a. a -> Maybe a
Just

-- | The number of leaves.
size :: PathsPrefixTree q f r -> Int
size :: PathsPrefixTree q f r -> Int
size (PathsPrefixTree ASet (f r)
root TypeRepMap (AStep q f r)
branches) =
  (Set (f r) -> Int
forall a. Set a -> Int
S.size (Set (f r) -> Int)
-> (ASet (f r) -> Set (f r)) -> ASet (f r) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASet (f r) -> Set (f r)
forall a. ASet a -> Set a
toSet (ASet (f r) -> Int) -> ASet (f r) -> Int
forall a b. (a -> b) -> a -> b
$ ASet (f r)
root)
    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> (TypeRepMap (AStep q f r) -> [Int])
-> TypeRepMap (AStep q f r)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WrapTypeable (AStep q f r) -> Int)
-> [WrapTypeable (AStep q f r)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TRM.WrapTypeable (AStep x)) -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> (Map (q r a) (PathsPrefixTree q f a) -> [Int])
-> Map (q r a) (PathsPrefixTree q f a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathsPrefixTree q f a -> Int) -> [PathsPrefixTree q f a] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathsPrefixTree q f a -> Int
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Int
size ([PathsPrefixTree q f a] -> [Int])
-> (Map (q r a) (PathsPrefixTree q f a) -> [PathsPrefixTree q f a])
-> Map (q r a) (PathsPrefixTree q f a)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (q r a) (PathsPrefixTree q f a) -> [PathsPrefixTree q f a]
forall k a. Map k a -> [a]
M.elems (Map (q r a) (PathsPrefixTree q f a) -> Int)
-> Map (q r a) (PathsPrefixTree q f a) -> Int
forall a b. (a -> b) -> a -> b
$ Map (q r a) (PathsPrefixTree q f a)
x) ([WrapTypeable (AStep q f r)] -> [Int])
-> (TypeRepMap (AStep q f r) -> [WrapTypeable (AStep q f r)])
-> TypeRepMap (AStep q f r)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRepMap (AStep q f r) -> [WrapTypeable (AStep q f r)]
forall l. IsList l => l -> [Item l]
Exts.toList (TypeRepMap (AStep q f r) -> Int)
-> TypeRepMap (AStep q f r) -> Int
forall a b. (a -> b) -> a -> b
$ TypeRepMap (AStep q f r)
branches)

pattern PathsPrefixNode :: Ord (f r) => S.Set (f r) -> [TRM.WrapTypeable (AStep q f r)] -> PathsPrefixTree q f r
pattern $bPathsPrefixNode :: Set (f r) -> [WrapTypeable (AStep q f r)] -> PathsPrefixTree q f r
$mPathsPrefixNode :: forall r k (f :: k -> *) (r :: k) (q :: k -> k -> *).
Ord (f r) =>
PathsPrefixTree q f r
-> (Set (f r) -> [WrapTypeable (AStep q f r)] -> r)
-> (Void# -> r)
-> r
PathsPrefixNode s steps <-
  (\(PathsPrefixTree aset m) -> (toSet aset, Exts.toList m) -> (s, steps))
  where
    PathsPrefixNode Set (f r)
s [WrapTypeable (AStep q f r)]
steps = ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree (Set (f r) -> ASet (f r)
forall a. Ord a => Set a -> ASet a
fromSet Set (f r)
s) ([Item (TypeRepMap (AStep q f r))] -> TypeRepMap (AStep q f r)
forall l. IsList l => [Item l] -> l
Exts.fromList [Item (TypeRepMap (AStep q f r))]
[WrapTypeable (AStep q f r)]
steps)

{-# COMPLETE PathsPrefixNode #-}

instance (forall a. ToJSON (f a)) => ToJSON (PathsPrefixTree q f r) where
  toJSON :: PathsPrefixTree q f r -> Value
toJSON =
    Object -> Value
Object (Object -> Value)
-> (PathsPrefixTree q f r -> Object)
-> PathsPrefixTree q f r
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MergableObject -> Object
getMergableObject
      (MergableObject -> Object)
-> (PathsPrefixTree q f r -> MergableObject)
-> PathsPrefixTree q f r
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: k).
 Ord (f a) =>
 Paths q r a -> f a -> MergableObject)
-> PathsPrefixTree q f r -> MergableObject
forall k (q :: k -> k -> *) (f :: k -> *) m (r :: k).
Monoid m =>
(forall (a :: k). Ord (f a) => Paths q r a -> f a -> m)
-> PathsPrefixTree q f r -> m
foldWith (\Paths q r a
t f a
x -> Object -> MergableObject
MergableObject (Object -> MergableObject)
-> (Value -> Object) -> Value -> MergableObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paths q r a -> Value -> Object
forall k (q :: k -> k -> *) (r :: k) (a :: k).
Paths q r a -> Value -> Object
traceObject Paths q r a
t (Value -> MergableObject) -> Value -> MergableObject
forall a b. (a -> b) -> a -> b
$ f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
x)

deriving stock instance Eq (PathsPrefixTree q f a)

-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
-- the components are ordered by the @SomeTypeRep@ of the @a@.
compareTRM ::
  (forall a. Typeable a => Ord (f a)) =>
  TRM.TypeRepMap f ->
  TRM.TypeRepMap f ->
  Ordering
compareTRM :: TypeRepMap f -> TypeRepMap f -> Ordering
compareTRM TypeRepMap f
s1 TypeRepMap f
s2 =
  (SomeTypeRep -> Ordering) -> [SomeTypeRep] -> Ordering
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\SomeTypeRep
k -> (WrapTypeable f -> WrapTypeable f -> Ordering)
-> Maybe (WrapTypeable f) -> Maybe (WrapTypeable f) -> Ordering
forall t t. (t -> t -> Ordering) -> Maybe t -> Maybe t -> Ordering
compareMaybe WrapTypeable f -> WrapTypeable f -> Ordering
forall k (f :: k -> *).
(forall (a :: k). Typeable a => Ord (f a)) =>
WrapTypeable f -> WrapTypeable f -> Ordering
compareW (SomeTypeRep
-> Map SomeTypeRep (WrapTypeable f) -> Maybe (WrapTypeable f)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SomeTypeRep
k Map SomeTypeRep (WrapTypeable f)
m1) (SomeTypeRep
-> Map SomeTypeRep (WrapTypeable f) -> Maybe (WrapTypeable f)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SomeTypeRep
k Map SomeTypeRep (WrapTypeable f)
m2)) [SomeTypeRep]
mKeys
  where
    (Map SomeTypeRep (WrapTypeable f)
m1, Map SomeTypeRep (WrapTypeable f)
m2) = (TypeRepMap f -> Map SomeTypeRep (WrapTypeable f)
forall k l (f :: k -> *).
(IsList l, Item l ~ WrapTypeable f) =>
l -> Map SomeTypeRep (WrapTypeable f)
toMap TypeRepMap f
s1, TypeRepMap f -> Map SomeTypeRep (WrapTypeable f)
forall k l (f :: k -> *).
(IsList l, Item l ~ WrapTypeable f) =>
l -> Map SomeTypeRep (WrapTypeable f)
toMap TypeRepMap f
s2)
    mKeys :: [SomeTypeRep]
mKeys = Set SomeTypeRep -> [SomeTypeRep]
forall a. Set a -> [a]
S.toAscList (Set SomeTypeRep -> [SomeTypeRep])
-> Set SomeTypeRep -> [SomeTypeRep]
forall a b. (a -> b) -> a -> b
$ Map SomeTypeRep (WrapTypeable f) -> Set SomeTypeRep
forall k a. Map k a -> Set k
M.keysSet Map SomeTypeRep (WrapTypeable f)
m1 Set SomeTypeRep -> Set SomeTypeRep -> Set SomeTypeRep
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Map SomeTypeRep (WrapTypeable f) -> Set SomeTypeRep
forall k a. Map k a -> Set k
M.keysSet Map SomeTypeRep (WrapTypeable f)
m2
    compareMaybe :: (t -> t -> Ordering) -> Maybe t -> Maybe t -> Ordering
compareMaybe t -> t -> Ordering
_ Maybe t
Nothing Maybe t
Nothing = Ordering
EQ
    compareMaybe t -> t -> Ordering
_ Maybe t
Nothing (Just t
_) = Ordering
LT
    compareMaybe t -> t -> Ordering
_ (Just t
_) Maybe t
Nothing = Ordering
GT
    compareMaybe t -> t -> Ordering
cmp (Just t
x) (Just t
y) = t -> t -> Ordering
cmp t
x t
y
    compareW ::
      (forall a. Typeable a => Ord (f a)) =>
      TRM.WrapTypeable f ->
      TRM.WrapTypeable f ->
      Ordering
    compareW :: WrapTypeable f -> WrapTypeable f -> Ordering
compareW (TRM.WrapTypeable (f a
x :: f a)) (TRM.WrapTypeable (f a
y :: f b))
      | Just a :~: a
Refl <- TypeRep a -> TypeRep a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a) (Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @b) = f a -> f a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare f a
x f a
f a
y
      | Bool
otherwise = Ordering
EQ -- unreachable
    toMap :: l -> Map SomeTypeRep (WrapTypeable f)
toMap l
s =
      [(SomeTypeRep, WrapTypeable f)] -> Map SomeTypeRep (WrapTypeable f)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        [(f a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep f a
x, WrapTypeable f
w) | w :: WrapTypeable f
w@(TRM.WrapTypeable f a
x) <- l -> [Item l]
forall l. IsList l => l -> [Item l]
Exts.toList l
s]

instance Ord (PathsPrefixTree q f a) where
  compare :: PathsPrefixTree q f a -> PathsPrefixTree q f a -> Ordering
compare (PathsPrefixTree ASet (f a)
r1 TypeRepMap (AStep q f a)
s1) (PathsPrefixTree ASet (f a)
r2 TypeRepMap (AStep q f a)
s2) =
    ASet (f a) -> ASet (f a) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ASet (f a)
r1 ASet (f a)
r2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> TypeRepMap (AStep q f a) -> TypeRepMap (AStep q f a) -> Ordering
forall k (f :: k -> *).
(forall (a :: k). Typeable a => Ord (f a)) =>
TypeRepMap f -> TypeRepMap f -> Ordering
compareTRM TypeRepMap (AStep q f a)
s1 TypeRepMap (AStep q f a)
s2

filterASet :: (a -> Bool) -> ASet a -> ASet a
filterASet :: (a -> Bool) -> ASet a -> ASet a
filterASet a -> Bool
_ ASet a
AnEmptySet = ASet a
forall a. ASet a
AnEmptySet
filterASet a -> Bool
f (ASet Set a
s) = Set a -> ASet a
forall a. Ord a => Set a -> ASet a
fromSet (Set a -> ASet a) -> Set a -> ASet a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
S.filter a -> Bool
f Set a
s

data ASet (a :: Type) where
  AnEmptySet :: ASet a
  ASet :: Ord a => S.Set a -> ASet a

mapASet :: (Ord a => Ord b) => (a -> b) -> ASet a -> ASet b
mapASet :: (a -> b) -> ASet a -> ASet b
mapASet a -> b
_ ASet a
AnEmptySet = ASet b
forall a. ASet a
AnEmptySet
mapASet a -> b
f (ASet Set a
s) = Set b -> ASet b
forall a. Ord a => Set a -> ASet a
ASet (Set b -> ASet b) -> Set b -> ASet b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Set a -> Set b
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map a -> b
f Set a
s

deriving stock instance Show a => Show (ASet a)

toSet :: ASet a -> S.Set a
toSet :: ASet a -> Set a
toSet ASet a
AnEmptySet = Set a
forall a. Set a
S.empty
toSet (ASet Set a
s) = Set a
s

fromSet :: Ord a => S.Set a -> ASet a
fromSet :: Set a -> ASet a
fromSet Set a
s | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
s = ASet a
forall a. ASet a
AnEmptySet
fromSet Set a
s = Set a -> ASet a
forall a. Ord a => Set a -> ASet a
ASet Set a
s

instance ToJSON a => ToJSON (ASet a) where
  toJSON :: ASet a -> Value
toJSON = Set a -> Value
forall a. ToJSON a => a -> Value
toJSON (Set a -> Value) -> (ASet a -> Set a) -> ASet a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASet a -> Set a
forall a. ASet a -> Set a
toSet

instance Semigroup (ASet a) where
  ASet a
AnEmptySet <> :: ASet a -> ASet a -> ASet a
<> ASet a
s = ASet a
s
  ASet a
s <> ASet a
AnEmptySet = ASet a
s
  ASet Set a
s1 <> ASet Set a
s2 = Set a -> ASet a
forall a. Ord a => Set a -> ASet a
ASet (Set a -> ASet a) -> Set a -> ASet a
forall a b. (a -> b) -> a -> b
$ Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
s1 Set a
s2

deriving stock instance Eq (ASet a)

deriving stock instance Ord (ASet a)

-- type traceprefixset = traceprefixtree proxy

instance Monoid (ASet a) where
  mempty :: ASet a
mempty = ASet a
forall a. ASet a
AnEmptySet

data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where
  AStep ::
    NiceQuiver q r a =>
    !(M.Map (q r a) (PathsPrefixTree q f a)) ->
    AStep q f r a

mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a
mapAStep :: (forall (x :: k). f x -> f x) -> AStep q f r a -> AStep q f r a
mapAStep forall (x :: k). f x -> f x
f (AStep Map (q r a) (PathsPrefixTree q f a)
m) = Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
NiceQuiver q r a =>
Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
AStep (Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a)
-> Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
forall a b. (a -> b) -> a -> b
$ (PathsPrefixTree q f a -> PathsPrefixTree q f a)
-> Map (q r a) (PathsPrefixTree q f a)
-> Map (q r a) (PathsPrefixTree q f a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((forall (x :: k). f x -> f x)
-> PathsPrefixTree q f a -> PathsPrefixTree q f a
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (x :: k). f x -> f x)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
map forall (x :: k). f x -> f x
f) Map (q r a) (PathsPrefixTree q f a)
m

deriving stock instance Eq (AStep q f r a)

deriving stock instance Ord (AStep q f r a)

singleton :: AnItem q f r -> PathsPrefixTree q f r
singleton :: AnItem q f r -> PathsPrefixTree q f r
singleton (AnItem Paths q r a
ys f a
v) = Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
go Paths q r a
ys (PathsPrefixTree q f a -> PathsPrefixTree q f r)
-> PathsPrefixTree q f a -> PathsPrefixTree q f r
forall a b. (a -> b) -> a -> b
$ ASet (f a) -> TypeRepMap (AStep q f a) -> PathsPrefixTree q f a
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree (Set (f a) -> ASet (f a)
forall a. Ord a => Set a -> ASet a
ASet (Set (f a) -> ASet (f a)) -> Set (f a) -> ASet (f a)
forall a b. (a -> b) -> a -> b
$ f a -> Set (f a)
forall a. a -> Set a
S.singleton f a
v) TypeRepMap (AStep q f a)
forall k (f :: k -> *). TypeRepMap f
TRM.empty
  where
    go :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
    go :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
go Paths q r a
Root !PathsPrefixTree q f a
t = PathsPrefixTree q f r
PathsPrefixTree q f a
t
    go (Snoc Paths q r b
xs q b a
x) !PathsPrefixTree q f a
t =
      Paths q r b -> PathsPrefixTree q f b -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
go Paths q r b
xs (PathsPrefixTree q f b -> PathsPrefixTree q f r)
-> PathsPrefixTree q f b -> PathsPrefixTree q f r
forall a b. (a -> b) -> a -> b
$
        ASet (f b) -> TypeRepMap (AStep q f b) -> PathsPrefixTree q f b
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree ASet (f b)
forall a. ASet a
AnEmptySet (TypeRepMap (AStep q f b) -> PathsPrefixTree q f b)
-> TypeRepMap (AStep q f b) -> PathsPrefixTree q f b
forall a b. (a -> b) -> a -> b
$
          AStep q f b a -> TypeRepMap (AStep q f b)
forall k (a :: k) (f :: k -> *). Typeable a => f a -> TypeRepMap f
TRM.one (AStep q f b a -> TypeRepMap (AStep q f b))
-> AStep q f b a -> TypeRepMap (AStep q f b)
forall a b. (a -> b) -> a -> b
$
            Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
NiceQuiver q r a =>
Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
AStep (Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a)
-> Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a
forall a b. (a -> b) -> a -> b
$ q b a
-> PathsPrefixTree q f a -> Map (q b a) (PathsPrefixTree q f a)
forall k a. k -> a -> Map k a
M.singleton q b a
x PathsPrefixTree q f a
t

instance Semigroup (PathsPrefixTree q f r) where
  PathsPrefixTree ASet (f r)
r1 TypeRepMap (AStep q f r)
s1 <> :: PathsPrefixTree q f r
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
<> PathsPrefixTree ASet (f r)
r2 TypeRepMap (AStep q f r)
s2 =
    ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree (ASet (f r)
r1 ASet (f r) -> ASet (f r) -> ASet (f r)
forall a. Semigroup a => a -> a -> a
<> ASet (f r)
r2) ((forall (x :: k).
 Typeable x =>
 AStep q f r x -> AStep q f r x -> AStep q f r x)
-> TypeRepMap (AStep q f r)
-> TypeRepMap (AStep q f r)
-> TypeRepMap (AStep q f r)
forall k (f :: k -> *).
(forall (x :: k). Typeable x => f x -> f x -> f x)
-> TypeRepMap f -> TypeRepMap f -> TypeRepMap f
TRM.unionWith forall (x :: k).
Typeable x =>
AStep q f r x -> AStep q f r x -> AStep q f r x
forall (a :: k). AStep q f r a -> AStep q f r a -> AStep q f r a
joinSteps TypeRepMap (AStep q f r)
s1 TypeRepMap (AStep q f r)
s2)
    where
      joinSteps :: AStep q f r a -> AStep q f r a -> AStep q f r a
      joinSteps :: AStep q f r a -> AStep q f r a -> AStep q f r a
joinSteps (AStep Map (q r a) (PathsPrefixTree q f a)
m1) (AStep Map (q r a) (PathsPrefixTree q f a)
m2) = Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
NiceQuiver q r a =>
Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
AStep (Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a)
-> Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
forall a b. (a -> b) -> a -> b
$ (PathsPrefixTree q f a
 -> PathsPrefixTree q f a -> PathsPrefixTree q f a)
-> Map (q r a) (PathsPrefixTree q f a)
-> Map (q r a) (PathsPrefixTree q f a)
-> Map (q r a) (PathsPrefixTree q f a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith PathsPrefixTree q f a
-> PathsPrefixTree q f a -> PathsPrefixTree q f a
forall a. Semigroup a => a -> a -> a
(<>) Map (q r a) (PathsPrefixTree q f a)
m1 Map (q r a) (PathsPrefixTree q f a)
m2

instance Monoid (PathsPrefixTree q f r) where
  mempty :: PathsPrefixTree q f r
mempty = ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree ASet (f r)
forall a. Monoid a => a
mempty TypeRepMap (AStep q f r)
forall k (f :: k -> *). TypeRepMap f
TRM.empty

empty :: PathsPrefixTree q f r
empty :: PathsPrefixTree q f r
empty = PathsPrefixTree q f r
forall a. Monoid a => a
mempty

fromList :: [AnItem q f r] -> PathsPrefixTree q f r
fromList :: [AnItem q f r] -> PathsPrefixTree q f r
fromList = (AnItem q f r -> PathsPrefixTree q f r)
-> [AnItem q f r] -> PathsPrefixTree q f r
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap AnItem q f r -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
AnItem q f r -> PathsPrefixTree q f r
singleton

null :: PathsPrefixTree q f r -> Bool
null :: PathsPrefixTree q f r -> Bool
null (PathsPrefixTree ASet (f r)
AnEmptySet TypeRepMap (AStep q f r)
s) = (WrapTypeable (AStep q f r) -> Bool)
-> [WrapTypeable (AStep q f r)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(TRM.WrapTypeable (AStep x)) -> (PathsPrefixTree q f a -> Bool)
-> Map (q r a) (PathsPrefixTree q f a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PathsPrefixTree q f a -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
null Map (q r a) (PathsPrefixTree q f a)
x) (TypeRepMap (AStep q f r) -> [Item (TypeRepMap (AStep q f r))]
forall l. IsList l => l -> [Item l]
Exts.toList TypeRepMap (AStep q f r)
s)
null PathsPrefixTree q f r
_ = Bool
False

foldWith ::
  forall q f m r.
  Monoid m =>
  (forall a. Ord (f a) => Paths q r a -> f a -> m) ->
  PathsPrefixTree q f r ->
  m
foldWith :: (forall (a :: k). Ord (f a) => Paths q r a -> f a -> m)
-> PathsPrefixTree q f r -> m
foldWith forall (a :: k). Ord (f a) => Paths q r a -> f a -> m
k = Paths q r r -> PathsPrefixTree q f r -> m
forall (a :: k). Paths q r a -> PathsPrefixTree q f a -> m
goTPT Paths q r r
forall k (q :: k -> k -> *) (a :: k). Paths q a a
Root
  where
    goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m
    goTPT :: Paths q r a -> PathsPrefixTree q f a -> m
goTPT Paths q r a
xs PathsPrefixTree q f a
t = Paths q r a -> ASet (f a) -> m
forall (a :: k). Paths q r a -> ASet (f a) -> m
goASet Paths q r a
xs (PathsPrefixTree q f a -> ASet (f a)
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> ASet (f r)
rootItems PathsPrefixTree q f a
t) m -> m -> m
forall a. Semigroup a => a -> a -> a
<> Paths q r a -> TypeRepMap (AStep q f a) -> m
forall (a :: k). Paths q r a -> TypeRepMap (AStep q f a) -> m
goTRM Paths q r a
xs (PathsPrefixTree q f a -> TypeRepMap (AStep q f a)
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> TypeRepMap (AStep q f r)
snocItems PathsPrefixTree q f a
t)
    goASet :: forall a. Paths q r a -> ASet (f a) -> m
    goASet :: Paths q r a -> ASet (f a) -> m
goASet Paths q r a
_ ASet (f a)
AnEmptySet = m
forall a. Monoid a => a
mempty
    goASet Paths q r a
xs (ASet Set (f a)
rs) = (f a -> m) -> Set (f a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Paths q r a -> f a -> m
forall (a :: k). Ord (f a) => Paths q r a -> f a -> m
k Paths q r a
xs) Set (f a)
rs
    goTRM :: forall a. Paths q r a -> TRM.TypeRepMap (AStep q f a) -> m
    goTRM :: Paths q r a -> TypeRepMap (AStep q f a) -> m
goTRM Paths q r a
xs TypeRepMap (AStep q f a)
s = (WrapTypeable (AStep q f a) -> m)
-> [WrapTypeable (AStep q f a)] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TRM.WrapTypeable AStep q f a a
f) -> Paths q r a -> AStep q f a a -> m
forall (a :: k) (b :: k). Paths q r a -> AStep q f a b -> m
goAStep Paths q r a
xs AStep q f a a
f) ([WrapTypeable (AStep q f a)] -> m)
-> [WrapTypeable (AStep q f a)] -> m
forall a b. (a -> b) -> a -> b
$ TypeRepMap (AStep q f a) -> [Item (TypeRepMap (AStep q f a))]
forall l. IsList l => l -> [Item l]
Exts.toList TypeRepMap (AStep q f a)
s
    goAStep :: forall a b. Paths q r a -> AStep q f a b -> m
    goAStep :: Paths q r a -> AStep q f a b -> m
goAStep Paths q r a
xs (AStep Map (q a b) (PathsPrefixTree q f b)
m) =
      (q a b -> PathsPrefixTree q f b -> m -> m)
-> m -> Map (q a b) (PathsPrefixTree q f b) -> m
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\q a b
x PathsPrefixTree q f b
t -> (Paths q r b -> PathsPrefixTree q f b -> m
forall (a :: k). Paths q r a -> PathsPrefixTree q f a -> m
goTPT (Paths q r a -> q a b -> Paths q r b
forall k (q :: k -> k -> *) (b :: k) (c :: k) (a :: k).
NiceQuiver q b c =>
Paths q a b -> q b c -> Paths q a c
Snoc Paths q r a
xs q a b
x) PathsPrefixTree q f b
t m -> m -> m
forall a. Semigroup a => a -> a -> a
<>)) m
forall a. Monoid a => a
mempty Map (q a b) (PathsPrefixTree q f b)
m

toList :: PathsPrefixTree q f r -> [AnItem q f r]
toList :: PathsPrefixTree q f r -> [AnItem q f r]
toList PathsPrefixTree q f r
t = Endo [AnItem q f r] -> [AnItem q f r] -> [AnItem q f r]
forall a. Endo a -> a -> a
appEndo ((forall (a :: k).
 Ord (f a) =>
 Paths q r a -> f a -> Endo [AnItem q f r])
-> PathsPrefixTree q f r -> Endo [AnItem q f r]
forall k (q :: k -> k -> *) (f :: k -> *) m (r :: k).
Monoid m =>
(forall (a :: k). Ord (f a) => Paths q r a -> f a -> m)
-> PathsPrefixTree q f r -> m
foldWith (\Paths q r a
xs f a
f -> ([AnItem q f r] -> [AnItem q f r]) -> Endo [AnItem q f r]
forall a. (a -> a) -> Endo a
Endo (Paths q r a -> f a -> AnItem q f r
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Paths q r a
xs f a
f AnItem q f r -> [AnItem q f r] -> [AnItem q f r]
forall a. a -> [a] -> [a]
:)) PathsPrefixTree q f r
t) []

-- | Select a subtree by prefix
takeSubtree :: forall q f r a. Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
takeSubtree :: Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
takeSubtree Paths q r a
Root PathsPrefixTree q f r
t = PathsPrefixTree q f r
PathsPrefixTree q f a
t
takeSubtree (Snoc Paths q r b
xs q b a
x) PathsPrefixTree q f r
t =
  (AStep q f b a -> PathsPrefixTree q f a)
-> Maybe (AStep q f b a) -> PathsPrefixTree q f a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(AStep Map (q b a) (PathsPrefixTree q f a)
m) -> Maybe (PathsPrefixTree q f a) -> PathsPrefixTree q f a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe (PathsPrefixTree q f a) -> PathsPrefixTree q f a)
-> Maybe (PathsPrefixTree q f a) -> PathsPrefixTree q f a
forall a b. (a -> b) -> a -> b
$ q b a
-> Map (q b a) (PathsPrefixTree q f a)
-> Maybe (PathsPrefixTree q f a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup q b a
x Map (q b a) (PathsPrefixTree q f a)
m) (Maybe (AStep q f b a) -> PathsPrefixTree q f a)
-> Maybe (AStep q f b a) -> PathsPrefixTree q f a
forall a b. (a -> b) -> a -> b
$
    forall k (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
forall (f :: k -> *). Typeable a => TypeRepMap f -> Maybe (f a)
TRM.lookup @a (TypeRepMap (AStep q f b) -> Maybe (AStep q f b a))
-> TypeRepMap (AStep q f b) -> Maybe (AStep q f b a)
forall a b. (a -> b) -> a -> b
$ PathsPrefixTree q f b -> TypeRepMap (AStep q f b)
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> TypeRepMap (AStep q f r)
snocItems (PathsPrefixTree q f b -> TypeRepMap (AStep q f b))
-> PathsPrefixTree q f b -> TypeRepMap (AStep q f b)
forall a b. (a -> b) -> a -> b
$ Paths q r b -> PathsPrefixTree q f r -> PathsPrefixTree q f b
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k) (a :: k).
Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
takeSubtree Paths q r b
xs PathsPrefixTree q f r
t

lookup :: Paths q r a -> PathsPrefixTree q f r -> S.Set (f a)
lookup :: Paths q r a -> PathsPrefixTree q f r -> Set (f a)
lookup Paths q r a
xs = ASet (f a) -> Set (f a)
forall a. ASet a -> Set a
toSet (ASet (f a) -> Set (f a))
-> (PathsPrefixTree q f r -> ASet (f a))
-> PathsPrefixTree q f r
-> Set (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsPrefixTree q f a -> ASet (f a)
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> ASet (f r)
rootItems (PathsPrefixTree q f a -> ASet (f a))
-> (PathsPrefixTree q f r -> PathsPrefixTree q f a)
-> PathsPrefixTree q f r
-> ASet (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k) (a :: k).
Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
takeSubtree Paths q r a
xs

-- | Embed a subtree in a larger tree with given prefix
embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
embed Paths q r a
Root PathsPrefixTree q f a
t = PathsPrefixTree q f r
PathsPrefixTree q f a
t
embed (Snoc Paths q r b
xs q b a
x) PathsPrefixTree q f a
t = Paths q r b -> PathsPrefixTree q f b -> PathsPrefixTree q f r
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
embed Paths q r b
xs (PathsPrefixTree q f b -> PathsPrefixTree q f r)
-> PathsPrefixTree q f b -> PathsPrefixTree q f r
forall a b. (a -> b) -> a -> b
$ ASet (f b) -> TypeRepMap (AStep q f b) -> PathsPrefixTree q f b
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
ASet (f r) -> TypeRepMap (AStep q f r) -> PathsPrefixTree q f r
PathsPrefixTree ASet (f b)
forall a. ASet a
AnEmptySet (TypeRepMap (AStep q f b) -> PathsPrefixTree q f b)
-> TypeRepMap (AStep q f b) -> PathsPrefixTree q f b
forall a b. (a -> b) -> a -> b
$ AStep q f b a -> TypeRepMap (AStep q f b)
forall k (a :: k) (f :: k -> *). Typeable a => f a -> TypeRepMap f
TRM.one (AStep q f b a -> TypeRepMap (AStep q f b))
-> AStep q f b a -> TypeRepMap (AStep q f b)
forall a b. (a -> b) -> a -> b
$ Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
NiceQuiver q r a =>
Map (q r a) (PathsPrefixTree q f a) -> AStep q f r a
AStep (Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a)
-> Map (q b a) (PathsPrefixTree q f a) -> AStep q f b a
forall a b. (a -> b) -> a -> b
$ q b a
-> PathsPrefixTree q f a -> Map (q b a) (PathsPrefixTree q f a)
forall k a. k -> a -> Map k a
M.singleton q b a
x PathsPrefixTree q f a
t

newtype MergableObject = MergableObject {MergableObject -> Object
getMergableObject :: Object}

instance Semigroup MergableObject where
  (MergableObject Object
x) <> :: MergableObject -> MergableObject -> MergableObject
<> (MergableObject Object
y) =
    Object -> MergableObject
MergableObject (Object -> MergableObject) -> Object -> MergableObject
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith Value -> Value -> Value
mergeValue Object
x Object
y
    where
      mergeValue :: Value -> Value -> Value
      mergeValue :: Value -> Value -> Value
mergeValue (Object Object
a) (Object Object
b) =
        Object -> Value
Object (Object -> Value)
-> (MergableObject -> Object) -> MergableObject -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MergableObject -> Object
getMergableObject (MergableObject -> Value) -> MergableObject -> Value
forall a b. (a -> b) -> a -> b
$ Object -> MergableObject
MergableObject Object
a MergableObject -> MergableObject -> MergableObject
forall a. Semigroup a => a -> a -> a
<> Object -> MergableObject
MergableObject Object
b
      mergeValue (Array Array
a) (Array Array
b) = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Array
a Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
b
      mergeValue (Array Array
a) Value
b = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Array -> Value -> Array
forall a. Vector a -> a -> Vector a
V.snoc Array
a Value
b
      mergeValue Value
a (Array Array
b) = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Array -> Array
forall a. a -> Vector a -> Vector a
V.cons Value
a Array
b
      mergeValue Value
a Value
b = [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value
a, Value
b]

instance Monoid MergableObject where
  mempty :: MergableObject
mempty = Object -> MergableObject
MergableObject Object
forall a. Monoid a => a
mempty

traceObject :: Paths q r a -> Value -> Object
traceObject :: Paths q r a -> Value -> Object
traceObject Paths q r a
Root (Object Object
o) = Object
o
traceObject Paths q r a
Root Value
v = Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
"root" Value
v
traceObject (Paths q r b
root `Snoc` q b a
s) Value
v =
  Paths q r b -> Value -> Object
forall k (q :: k -> k -> *) (r :: k) (a :: k).
Paths q r a -> Value -> Object
traceObject Paths q r b
root (Value -> Object) -> (Object -> Value) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (String -> Text
T.pack (String -> Text) -> (q b a -> String) -> q b a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. q b a -> String
forall a. Show a => a -> String
show (q b a -> Text) -> q b a -> Text
forall a b. (a -> b) -> a -> b
$ q b a
s) Value
v