content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE DeriveGeneric #-}
  module Data.Abstract.Powerset where
  
  import           Prelude hiding ((.))
  
  import           Control.Arrow hiding (ArrowMonad)
  import           Control.Arrow.Monad
  import           Control.Applicative hiding (empty)
  import           Control.Category
  import           Control.Monad
  
  import           Data.Profunctor
  import           Data.Sequence (Seq,(<|),viewl,ViewL(..))
  import           Data.Hashable
  import           Data.HashSet (HashSet)
  import qualified Data.HashSet as H
  import           Data.Foldable (foldl',toList)
  import           Data.List (intercalate)
  import           Data.Order
  
  import           Prettyprinter
  
  import           GHC.Generics (Generic)
  
  newtype Pow a = Pow (Seq a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus, Semigroup, Monoid, Foldable, Traversable, Generic)
  
  instance PreOrd a => PreOrd (Pow a) where
    as ⊑ bs = all (\x -> any (x ⊑) bs) as
  
  instance Hashable a => Eq (Pow a) where
    as == bs = toHashSet as == toHashSet bs
  
  instance PreOrd a => Complete (Pow a) where
    as ⊔ bs = as `union` bs
  
  instance PreOrd a => LowerBounded (Pow a) where
    bottom = empty
  
  instance UpperBounded a => UpperBounded (Pow a) where
    top = singleton top
  
  instance Show a => Show (Pow a) where
    show (Pow a) = "{" ++ intercalate ", " (show <$> toList a) ++ "}"
  
  instance Pretty a => Pretty (Pow a) where
    pretty (Pow a) = braces $ hsep (punctuate "," (pretty <$> toList a))
  
  instance Hashable a => Hashable (Pow a) where
    hashWithSalt salt x = hashWithSalt salt (toHashSet x)
  
  instance (ArrowChoice c, Profunctor c) => ArrowFunctor Pow c where
    mapA f = lmap toEither (arr (\_ -> empty) ||| rmap (\(y,Pow ys) -> Pow (y <| ys)) (f *** mapA f))
  
  instance (ArrowChoice c, Profunctor c) => ArrowMonad Pow c where
    mapJoinA f = lmap toEither (arr (\_ -> empty) ||| rmap (\(ys,ys') -> ys <> join ys') (f *** mapA f))
  
  toEither :: Pow a -> Either () (a,Pow a)
  toEither (Pow s) = case viewl s of
    EmptyL -> Left ()
    x :< xs -> Right (x,Pow xs)
  
  empty :: Pow a
  empty = mempty
  
  singleton :: a -> Pow a
  singleton = Pow . return
  
  insert :: a -> Pow a -> Pow a
  insert a (Pow as) = Pow (a <| as)
  
  union :: Pow a -> Pow a -> Pow a
  union = mappend
  
  toHashSet :: (Hashable a) => Pow a -> HashSet a
  toHashSet = foldl' (flip H.insert) H.empty
  
  fromFoldable :: (Foldable f, Monad t, Monoid (t a)) => f a -> t a
  fromFoldable = foldMap return
  
  size :: Foldable f => f a -> Int
  size = length
  
  dedup :: (Hashable a) => Pow a -> Pow a
  dedup = fromFoldable . toHashSet
  