{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}

module Language.REST.Internal.PartialOrder (
      empty
    , insert
    , replaceUnsafe
    , insertUnsafe
    , gt
    , toList
    , isEmpty
    , elems
    , unionDisjointUnsafe
    , PartialOrder
    , toDescsList
    , descendents
    ) where

import GHC.Generics (Generic)
import Data.Hashable
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.List as L

import Language.REST.Types () -- Hashable (M.Map a b)
import Language.REST.Internal.Orphans ()
import Text.Printf

-- | Irreflexive (strict) partial orders
newtype PartialOrder a =
  -- | @PartialOrder m@ represents the relation
  --
  -- > (>) = { (a, b) | (a, bs)  <- toList m, b <- bs }
  --
  -- Transitivity implies that @m ! a == { b | a > b}@ if @a@ is in the map.
  --
  -- Asymmetry implies that @member a (m ! b)@ implies
  -- @not (member b (m ! a))@.
  --
  -- Irreflexivity means that @a@ cannot be in @m ! a@.
  --
  PartialOrder (M.Map a (S.Set a))
  deriving (Eq (PartialOrder a)
Eq (PartialOrder a) =>
(PartialOrder a -> PartialOrder a -> Ordering)
-> (PartialOrder a -> PartialOrder a -> Bool)
-> (PartialOrder a -> PartialOrder a -> Bool)
-> (PartialOrder a -> PartialOrder a -> Bool)
-> (PartialOrder a -> PartialOrder a -> Bool)
-> (PartialOrder a -> PartialOrder a -> PartialOrder a)
-> (PartialOrder a -> PartialOrder a -> PartialOrder a)
-> Ord (PartialOrder a)
PartialOrder a -> PartialOrder a -> Bool
PartialOrder a -> PartialOrder a -> Ordering
PartialOrder a -> PartialOrder a -> PartialOrder a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PartialOrder a)
forall a. Ord a => PartialOrder a -> PartialOrder a -> Bool
forall a. Ord a => PartialOrder a -> PartialOrder a -> Ordering
forall a.
Ord a =>
PartialOrder a -> PartialOrder a -> PartialOrder a
$ccompare :: forall a. Ord a => PartialOrder a -> PartialOrder a -> Ordering
compare :: PartialOrder a -> PartialOrder a -> Ordering
$c< :: forall a. Ord a => PartialOrder a -> PartialOrder a -> Bool
< :: PartialOrder a -> PartialOrder a -> Bool
$c<= :: forall a. Ord a => PartialOrder a -> PartialOrder a -> Bool
<= :: PartialOrder a -> PartialOrder a -> Bool
$c> :: forall a. Ord a => PartialOrder a -> PartialOrder a -> Bool
> :: PartialOrder a -> PartialOrder a -> Bool
$c>= :: forall a. Ord a => PartialOrder a -> PartialOrder a -> Bool
>= :: PartialOrder a -> PartialOrder a -> Bool
$cmax :: forall a.
Ord a =>
PartialOrder a -> PartialOrder a -> PartialOrder a
max :: PartialOrder a -> PartialOrder a -> PartialOrder a
$cmin :: forall a.
Ord a =>
PartialOrder a -> PartialOrder a -> PartialOrder a
min :: PartialOrder a -> PartialOrder a -> PartialOrder a
Ord, PartialOrder a -> PartialOrder a -> Bool
(PartialOrder a -> PartialOrder a -> Bool)
-> (PartialOrder a -> PartialOrder a -> Bool)
-> Eq (PartialOrder a)
forall a. Eq a => PartialOrder a -> PartialOrder a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PartialOrder a -> PartialOrder a -> Bool
== :: PartialOrder a -> PartialOrder a -> Bool
$c/= :: forall a. Eq a => PartialOrder a -> PartialOrder a -> Bool
/= :: PartialOrder a -> PartialOrder a -> Bool
Eq, (forall x. PartialOrder a -> Rep (PartialOrder a) x)
-> (forall x. Rep (PartialOrder a) x -> PartialOrder a)
-> Generic (PartialOrder a)
forall x. Rep (PartialOrder a) x -> PartialOrder a
forall x. PartialOrder a -> Rep (PartialOrder a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PartialOrder a) x -> PartialOrder a
forall a x. PartialOrder a -> Rep (PartialOrder a) x
$cfrom :: forall a x. PartialOrder a -> Rep (PartialOrder a) x
from :: forall x. PartialOrder a -> Rep (PartialOrder a) x
$cto :: forall a x. Rep (PartialOrder a) x -> PartialOrder a
to :: forall x. Rep (PartialOrder a) x -> PartialOrder a
Generic, Eq (PartialOrder a)
Eq (PartialOrder a) =>
(Int -> PartialOrder a -> Int)
-> (PartialOrder a -> Int) -> Hashable (PartialOrder a)
Int -> PartialOrder a -> Int
PartialOrder a -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (PartialOrder a)
forall a. Hashable a => Int -> PartialOrder a -> Int
forall a. Hashable a => PartialOrder a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> PartialOrder a -> Int
hashWithSalt :: Int -> PartialOrder a -> Int
$chash :: forall a. Hashable a => PartialOrder a -> Int
hash :: PartialOrder a -> Int
Hashable)

instance (Show a) => Show (PartialOrder a) where
  show :: PartialOrder a -> String
show (PartialOrder Map a (Set a)
m) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
" ∧ " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((a, Set a) -> String) -> [(a, Set a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (a, Set a) -> String
forall {a} {a} {t}.
(Show a, Show a, PrintfType t) =>
(a, Set a) -> t
go (Map a (Set a) -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a (Set a)
m) where
    go :: (a, Set a) -> t
go (a
key, Set a
s) = case Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
s of
      [a
x] -> String -> String -> String -> t
forall r. PrintfType r => String -> r
printf String
"%s > %s" (a -> String
forall a. Show a => a -> String
show a
key) (a -> String
forall a. Show a => a -> String
show a
x)
      [a]
xs  -> String -> String -> String -> t
forall r. PrintfType r => String -> r
printf String
"%s > { %s }" (a -> String
forall a. Show a => a -> String
show a
key) (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
xs))

empty :: PartialOrder a
empty :: forall a. PartialOrder a
empty = Map a (Set a) -> PartialOrder a
forall a. Map a (Set a) -> PartialOrder a
PartialOrder Map a (Set a)
forall k a. Map k a
M.empty

isEmpty :: Eq a => PartialOrder a -> Bool
isEmpty :: forall a. Eq a => PartialOrder a -> Bool
isEmpty PartialOrder a
p = PartialOrder a
p PartialOrder a -> PartialOrder a -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrder a
forall a. PartialOrder a
empty

-- | @canInsert (>) a b@ iff @a /= b && not (a > b) && not (b > a)@
canInsert :: (Eq a, Ord a, Hashable a) => PartialOrder a -> a -> a -> Bool
canInsert :: forall a.
(Eq a, Ord a, Hashable a) =>
PartialOrder a -> a -> a -> Bool
canInsert PartialOrder a
o a
f a
g = a
f a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
g Bool -> Bool -> Bool
&& Bool -> Bool
not (PartialOrder a -> a -> a -> Bool
forall a.
(Eq a, Ord a, Hashable a) =>
PartialOrder a -> a -> a -> Bool
gt PartialOrder a
o a
f a
g) Bool -> Bool -> Bool
&& Bool -> Bool
not (PartialOrder a -> a -> a -> Bool
forall a.
(Eq a, Ord a, Hashable a) =>
PartialOrder a -> a -> a -> Bool
gt PartialOrder a
o a
g a
f)

-- | @gt (>) a b == (a > b)@
gt :: (Eq a, Ord a, Hashable a) => PartialOrder a -> a -> a -> Bool
gt :: forall a.
(Eq a, Ord a, Hashable a) =>
PartialOrder a -> a -> a -> Bool
gt PartialOrder a
po a
t a
u = a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member a
u (Set a -> Bool) -> Set a -> Bool
forall a b. (a -> b) -> a -> b
$ a -> PartialOrder a -> Set a
forall a. Ord a => a -> PartialOrder a -> Set a
descendents a
t PartialOrder a
po

unionDisjointUnsafe :: Ord a => PartialOrder a -> PartialOrder a -> PartialOrder a
unionDisjointUnsafe :: forall a.
Ord a =>
PartialOrder a -> PartialOrder a -> PartialOrder a
unionDisjointUnsafe (PartialOrder Map a (Set a)
m) (PartialOrder Map a (Set a)
m') = Map a (Set a) -> PartialOrder a
forall a. Map a (Set a) -> PartialOrder a
PartialOrder (Map a (Set a) -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map a (Set a)
m Map a (Set a)
m')

-- | ascendants a (>) = { b | b > a }
ascendants :: Ord k => k -> PartialOrder k -> S.Set k
ascendants :: forall a. Ord a => a -> PartialOrder a -> Set a
ascendants k
k (PartialOrder Map k (Set k)
m)  = Map k (Set k) -> Set k
forall k a. Map k a -> Set k
M.keysSet (Map k (Set k) -> Set k) -> Map k (Set k) -> Set k
forall a b. (a -> b) -> a -> b
$ (Set k -> Bool) -> Map k (Set k) -> Map k (Set k)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member k
k) Map k (Set k)
m

-- | descendents a (>) = { b | a > b }
descendents :: Ord a => a -> PartialOrder a -> S.Set a
descendents :: forall a. Ord a => a -> PartialOrder a -> Set a
descendents a
k (PartialOrder Map a (Set a)
m) = Set a -> a -> Map a (Set a) -> Set a
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Set a
forall a. Set a
S.empty a
k Map a (Set a)
m

-- | @insertUnsafe (>) a b@ is unsafe because it may not respect some
-- of its properties if @canInsert (>) a b@ doesn't hold.
{-# INLINE insertUnsafe #-}
insertUnsafe :: Ord a => PartialOrder a -> a -> a -> PartialOrder a
insertUnsafe :: forall a. Ord a => PartialOrder a -> a -> a -> PartialOrder a
insertUnsafe o :: PartialOrder a
o@(PartialOrder Map a (Set a)
m) a
f a
g = PartialOrder a
result
  where
    result :: PartialOrder a
result = Map a (Set a) -> PartialOrder a
forall a. Map a (Set a) -> PartialOrder a
PartialOrder (Map a (Set a) -> PartialOrder a)
-> Map a (Set a) -> PartialOrder a
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union a
f Set a
decs (Map a (Set a) -> Map a (Set a)) -> Map a (Set a) -> Map a (Set a)
forall a b. (a -> b) -> a -> b
$ (a -> Set a -> Set a) -> Map a (Set a) -> Map a (Set a)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey a -> Set a -> Set a
go Map a (Set a)
m

    go :: a -> Set a -> Set a
go a
k Set a
old | a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member a
k Set a
ascs = Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
old Set a
decs
    go a
_ Set a
v          = Set a
v

    ascs :: Set a
ascs = a -> PartialOrder a -> Set a
forall a. Ord a => a -> PartialOrder a -> Set a
ascendants a
f PartialOrder a
o
    decs :: Set a
decs = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
g (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ a -> PartialOrder a -> Set a
forall a. Ord a => a -> PartialOrder a -> Set a
descendents a
g PartialOrder a
o

{-# INLINE insert #-}
insert :: (Eq a, Ord a, Hashable a) => PartialOrder a -> a -> a -> Maybe (PartialOrder a)
insert :: forall a.
(Eq a, Ord a, Hashable a) =>
PartialOrder a -> a -> a -> Maybe (PartialOrder a)
insert PartialOrder a
o a
f a
g = if PartialOrder a -> a -> a -> Bool
forall a.
(Eq a, Ord a, Hashable a) =>
PartialOrder a -> a -> a -> Bool
canInsert PartialOrder a
o a
f a
g then PartialOrder a -> Maybe (PartialOrder a)
forall a. a -> Maybe a
Just (PartialOrder a -> a -> a -> PartialOrder a
forall a. Ord a => PartialOrder a -> a -> a -> PartialOrder a
insertUnsafe PartialOrder a
o a
f a
g) else Maybe (PartialOrder a)
forall a. Maybe a
Nothing

toDescsList :: PartialOrder k -> [(k, S.Set k)]
toDescsList :: forall k. PartialOrder k -> [(k, Set k)]
toDescsList (PartialOrder Map k (Set k)
m) = Map k (Set k) -> [(k, Set k)]
forall k a. Map k a -> [(k, a)]
M.toList Map k (Set k)
m

toList :: PartialOrder a -> [(a, a)]
toList :: forall a. PartialOrder a -> [(a, a)]
toList (PartialOrder Map a (Set a)
m) = do
  (a
k, Set a
vs) <- Map a (Set a) -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
M.toList Map a (Set a)
m
  a
v       <- Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
vs
  (a, a) -> [(a, a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
k, a
v)

elems :: (Eq a, Ord a, Hashable a) => PartialOrder a -> S.Set a
elems :: forall a. (Eq a, Ord a, Hashable a) => PartialOrder a -> Set a
elems (PartialOrder Map a (Set a)
m) = Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union (Map a (Set a) -> Set a
forall k a. Map k a -> Set k
M.keysSet Map a (Set a)
m) ([Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (Map a (Set a) -> [Set a]
forall k a. Map k a -> [a]
M.elems Map a (Set a)
m))

-- | @replaceUnsafe olds new (>)@ replaces every element in @olds@ with
-- @new@ in the partial order @(>)@.
--
-- More formally:
--
-- > replaceUnsafe olds new (>) =
-- >   { (a, b) | notElem a olds, notElem b olds }
-- >   U { (new, b) | o <- olds, o > b }
-- >   U { (a, new) | o <- olds, a > o }
--
-- This operation is unsafe because it only yields a partial order
-- if forall @o@ in @olds@:
--  * @o > b@ implies @not (b > new)@, and
--  * @a > o@ implies @not (new > a)@.
--
replaceUnsafe :: (Eq a, Ord a, Hashable a) => [a] -> a -> PartialOrder a -> PartialOrder a
replaceUnsafe :: forall a.
(Eq a, Ord a, Hashable a) =>
[a] -> a -> PartialOrder a -> PartialOrder a
replaceUnsafe [a]
froms a
to po :: PartialOrder a
po@(PartialOrder Map a (Set a)
m) = PartialOrder a
result where

  from' :: Set a
from' = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
froms

  descs :: Set a
descs = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> PartialOrder a -> Set a
forall a. Ord a => a -> PartialOrder a -> Set a
`descendents` PartialOrder a
po) [a]
froms)

  filtered :: Map a (Set a)
filtered = (a -> Set a -> Bool) -> Map a (Set a) -> Map a (Set a)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\a
k Set a
_ -> a
k a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
froms) Map a (Set a)
m
  m' :: Map a (Set a)
m' =
    if Set a -> Bool
forall a. Set a -> Bool
S.null Set a
descs
    then Map a (Set a)
filtered
    else (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union a
to Set a
descs Map a (Set a)
filtered

  result :: PartialOrder a
result = Map a (Set a) -> PartialOrder a
forall a. Map a (Set a) -> PartialOrder a
PartialOrder (Map a (Set a) -> PartialOrder a)
-> Map a (Set a) -> PartialOrder a
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a) -> Map a (Set a) -> Map a (Set a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Set a -> Set a
go Map a (Set a)
m'

  go :: Set a -> Set a
go Set a
s | Set a -> Bool
hasFrom Set a
s = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
to (Set a -> Set a) -> Set a -> Set 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
descs (Set a -> Set a) -> Set a -> Set 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.difference Set a
s Set a
from'
  go Set a
s  = Set a
s

  hasFrom :: Set a -> Bool
hasFrom Set a
set = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
set) [a]
froms