HSet.hs

module Data.HSet
       ( HSet(..)
       , HGet(..)
       , HGetable
       , hask
       , SubHSet(..)
       , SubHSetable
       , hdelete
       , hnarrow
         -- * Work with 'Labeled' elements
       , hgetLabeled
       , haskLabeled
         -- * Reexports
       , module Data.HSet.Labeled
       ) where

import Control.Monad.Reader
import Data.HSet.Labeled
import Data.HSet.TypeLevel
import Data.Typeable

#if !(MIN_VERSION_base(4, 8, 0))
import Control.Applicative
#endif

{- | Heterogeneous set (list) of elements with unique types. Useful
with MonadReader.

>>> let x = HSCons (10 :: Int) $ HSCons (20 :: Double) HSNil
>>> x
HSCons (10) (HSCons (20.0) (HSNil))

>>> hget x :: Int
10

>>> hget x :: Double
20.0

Note that 'hget' takes specific element from list of uniquely typed
elements depending on what type is required to be returned.

-}

data HSet (elems :: [*]) where
  HSNil  :: HSet '[]
  HSCons :: ('False ~ (Elem elem elems)) => !elem -> !(HSet elems) -> HSet (elem ': elems)
  deriving ( Typeable )

instance Show (HSet '[]) where
  show HSNil = "HSNil"

instance (Show e, Show (HSet els)) => Show (HSet (e ': els)) where
  show (HSCons e els) = "HSCons (" ++ show e ++ ") (" ++ show els ++ ")"

instance Eq (HSet '[]) where
  HSNil == HSNil = True

instance (Eq e, Eq (HSet els)) => Eq (HSet (e ': els)) where
  (HSCons e els) == (HSCons e' els') = (e == e') && (els == els')

instance Ord (HSet '[]) where
  HSNil `compare` HSNil = EQ

instance (Ord e, Ord (HSet els)) => Ord (HSet (e ': els)) where
  (HSCons e els) `compare` (HSCons e' els') = case e `compare` e' of
    EQ -> els `compare` els'
    x  -> x

-- | Typeclass for sets and elements.
class (i ~ (Index e els)) => HGet els e i where
  -- | Gets any data from HSet for you
  hget :: HSet els -> e

instance HGet (e ': els) e 'Z where
  hget (HSCons e _) = e

instance (i ~ (Index e els), ('S i) ~ (Index e (e1 ': els)), HGet els e i) => HGet (e1 ': els) e ('S i) where
  hget (HSCons _ els) = hget els

-- | Enables deriving of the fact that 'e' is contained within 'els' and it's
-- safe to say that 'hget' can be performed on this particular pair.
type HGetable els e = HGet els e (Index e els)

hask :: (MonadReader (HSet els) m, HGetable els e) => m e
hask = do
  h <- ask
  return $ hget h


{- | Takes subset of some hset, including subset of same elements in
different order

>>> let x = (HSCons "hello" $ HSCons 1234 $ HSCons 12.123 HSNil) :: HSet '[String, Int, Double]

>>> subHSet x :: HSet '[Double, Int]
HSCons (12.123) (HSCons (1234) (HSNil))

>>> subHSet x :: HSet '[String, Double]
HSCons ("hello") (HSCons (12.123) (HSNil))

>>> subHSet x :: HSet '[Int, String]
HSCons (1234) (HSCons ("hello") (HSNil))

-}

class (eq ~ TEq els els2) => SubHSet els els2 eq where
  subHSet :: HSet els -> HSet els2

instance (eq ~ TEq els '[]) => SubHSet els '[] eq where
  subHSet _ = HSNil

instance ( HGetable els el, 'False ~ Elem el els2
         , SubHSet els els2 subeq
         , 'False ~ TEq els (el ': els2) )
         => SubHSet els (el ': els2) 'False where
  subHSet h = HSCons (hget h :: el) (subHSet h :: HSet els2)

instance ( HGetable els el, 'False ~ Elem el els2
         , SubHSet els els2 subeq
         , els ~ (el ': els2)
         , 'True ~ TEq els (el ': els2) )
         => SubHSet els (el ': els2) 'True where
  subHSet h = h

type SubHSetable els1 els2 eq = (SubHSet els1 els2 eq, eq ~ TEq els1 els2 )

{- | Removes element from HSet of specified type

>>> let x = (HSCons "sdf" $ HSCons 123 HSNil) :: HSet '[String, Int]

>>> hdelete (Proxy :: Proxy Int) x
HSCons ("sdf") (HSNil)

>>> hdelete (Proxy :: Proxy String) x
HSCons (123) (HSNil)

-}

hdelete :: (SubHSetable els (Delete a els) eq)
        => proxy a -> HSet els -> HSet (Delete a els)
hdelete _ = subHSet

{- | Like 'subHSet' but with proxy for convenience

>>> let x = (HSCons "hello" $ HSCons 123 $ HSCons 345 HSNil) :: HSet '[String, Int, Integer]

>>> hnarrow (Proxy :: Proxy '[]) x
HSNil

>>> hnarrow (Proxy :: Proxy '[String]) x
HSCons ("hello") (HSNil)

>>> hnarrow (Proxy :: Proxy '[Int, Integer]) x
HSCons (123) (HSCons (345) (HSNil))

>>> hnarrow (Proxy :: Proxy '[Integer, Int]) x
HSCons (345) (HSCons (123) (HSNil))

-}

hnarrow :: (SubHSetable els subels eq)
        => proxy subels -> HSet els -> HSet subels
hnarrow _ = subHSet



{- |

>>> let y = HSCons (Labeled 10 :: Labeled "x" Int) $ HSCons (Labeled 20 :: Labeled "y" Int) HSNil
>>> y
HSCons (Labeled {unLabeled = 10}) (HSCons (Labeled {unLabeled = 20}) (HSNil))

>>> hgetLabeled (Proxy :: Proxy "x") y :: Int
10

>>> hgetLabeled (Proxy :: Proxy "y") y :: Int
20

-}

hgetLabeled :: forall proxy label e els.
            (HGetable els (Labeled label e))
            => proxy label -> HSet els -> e
hgetLabeled _ hset =
  let x = hget hset
  in unLabeled (x :: Labeled label e)

haskLabeled :: forall proxy label e els m.
#if MIN_VERSION_base(4, 8, 0)
            (HGetable els (Labeled label e), MonadReader (HSet els) m)
#else
            (HGetable els (Labeled label e), MonadReader (HSet els) m, Applicative m)
#endif
            => proxy label -> m e
haskLabeled p = hgetLabeled p <$> ask