HSet.hs

module Data.HSet
       ( HSet(..)
       , HGet(..)
       , HGetable
       , hask
         -- * 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. Usefull
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 how 'hget' just takes specific element from list of uniqly 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
  -- | Get 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

-- | Helper typefamily to derive that second argument contained in
-- list of first argument and we can perform 'hget' from set.
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

{- |

>>> 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