{-# LANGUAGE ExistentialQuantification
           , ScopedTypeVariables
           , TypeOperators
           , ConstraintKinds
           , MultiParamTypeClasses
           , FlexibleInstances
           -- , KindSignatures
           , PolyKinds
           #-}

-- ----------------------------------------------------------------------------
-- |
-- Module      :  Data.HtsCSet
-- Copyright   :  (c) Zoltan Kelemen 2017
-- License     :  BSD-style
-- Maintainer  :  kelemzol@elte.hu
--
-- HtsCSet is a Heterogenous Set wich can provide storing values with different and constrained type.
--
-- These modules are intended to be imported qualified, to avoid name
-- clashes with Prelude functions, e.g.
--
-- >  import qualified Data.HtsCSet as HCSet
-- ----------------------------------------------------------------------------

module Data.HtsCSet ( HtsCSet
        , empty, emptyP, singleton, singletonP
        , null, size, member, notMember
        , insert
        , lookup, lookupWithDefault
        , update
        , existTypeOf, existTypeOfP
        , (:+) (..), Append (..), fill
        ) where

import qualified Data.Map as M
import Data.Typeable
import GHC.Exts (Constraint)

import Prelude hiding (lookup, null)

data CastBox c = forall a. (Typeable a, c a) => CastBox { unBox :: a }

newtype HtsCSet c = HtsCSet { unHS :: M.Map TypeRep (CastBox c) }

-- | A proxy type
data P a = P

mapCastBox :: forall c a. (Typeable a, c a) => (a -> a) -> CastBox c -> CastBox c
mapCastBox f o@(CastBox e) = case cast e of
    (Just e') -> CastBox (f e')
    Nothing -> o

-- | The empty HtsCSet
empty :: HtsCSet c
empty = HtsCSet M.empty

-- | The empty HtsCSet with proxy
emptyP :: proxy c -> HtsCSet c
emptyP _ = empty

-- | A HtsCSet with an element
singleton :: forall c a. (Typeable a, c a) => a -> HtsCSet c
singleton a = HtsCSet (M.singleton (typeRep (Proxy :: Proxy a)) (CastBox a))

-- | A HtsCSet with an element with proxy
singletonP :: forall proxy c a. (Typeable a, c a) => proxy c -> a -> HtsCSet c
singletonP _ = singleton

-- | Is the HtsCSet is empty?
-- > null empty == True
-- > null (singleton "a") == False
null :: HtsCSet c -> Bool
null = M.null . unHS

-- | The number of elements in the HtsSet
-- > size empty == 0
-- > size (singleton "a") == 1
size :: HtsCSet c -> Int
size = M.size . unHS

-- | The HtsCSet is contain a same type of element?
-- > member (Proxy :: Proxy String) empty == False
-- > member (Proxy :: Proxy String) (singleton "a") == True
member :: forall proxy c a. Typeable a => proxy a -> HtsCSet c -> Bool
member _ = M.member (typeRep (Proxy :: Proxy a)) . unHS

-- | The HtsCSet is not contain a same type of element?
notMember :: forall proxy c a. Typeable a => proxy a -> HtsCSet c -> Bool
notMember p = not . member p


-- | Insert a new value in the HtsCSet. If the a elem is already present in the HtsCSet with type, the associated value is replaced with the supplied value
-- > insert "a" $ insert (2 :: Int) $ insert 'c' $ empty
insert :: forall c a. (Typeable a, c a) => a -> HtsCSet c -> HtsCSet c
insert a (HtsCSet hs) = HtsCSet (M.insert (typeRep (Proxy :: Proxy a)) (CastBox a) hs)

-- | Lookup a value from in the HtsCSet
-- > let hs = insert "a" $ insert (2 :: Int) $ insert 'c' $ empty
-- > lookup hs == Just "a"
-- > lookup hs == Just (2 :: Int)
-- > but
-- > lookup hs == Just 2 -- is False! Because the type of 2 is Num t => t not Int
lookup :: forall c a. (Typeable a, c a) => HtsCSet c -> Maybe a
lookup (HtsCSet hs) = case M.lookup (typeRep (Proxy :: Proxy a)) hs of
    (Just (CastBox a)) -> cast a
    _ -> Nothing

-- | Lookup a value from in the HtsCSet with a default value
lookupWithDefault :: forall c a. (Typeable a, c a) => a -> HtsCSet c -> a
lookupWithDefault a hs = case lookup hs of
    Nothing -> a
    (Just a') -> a'

-- | Update a value in HtsCSet
-- > let hs = insert "a" $ insert (2 :: Int) $ insert 'c' $ empty
-- > let hs' = update (++"b") hs
-- > lookup hs' == Just "ab"
update :: forall c a. (Typeable a, c a) => (a -> a) -> HtsCSet c -> HtsCSet c
update f = HtsCSet . M.adjust (mapCastBox f) (typeRep (Proxy :: Proxy a)) . unHS

-- | The HtsCSet is contain a same type of element?
-- > let hs = insert "a" $ insert (2 :: Int) $ insert 'c' $ empty
-- > existTypeOf "string" hs == True
existTypeOf :: forall c a. (Typeable a, c a) => a -> HtsCSet c -> Bool
existTypeOf _ (HtsCSet hs) = case M.lookup (typeRep (Proxy :: Proxy a)) hs of
    (Just _) -> True
    _ -> False

-- | The HtsCSet is contain a same type of element? (by proxy)
existTypeOfP :: forall proxy c a. (Typeable a, c a) => proxy a -> HtsCSet c -> Bool
existTypeOfP _ (HtsCSet hs) = case M.lookup (typeRep (Proxy :: Proxy a)) hs of
    (Just _) -> True
    _ -> False


-- | Helper heterogeneous list for comfortable HtsSet building (with append and fill)
-- > let hs = fill ("a" :+ 'c' :+ True :+ ())
-- > lookup (hs :: HtsCSet Show) == Just 'c'
-- > use () to close the list
-- > lookup (hs :: HtsCSet Show) == Just () -- is False!
-- > let hs' = fill ("a" :+ 'c' :+ True :+ () :+ ())
-- > lookup (hs' :: HtsCSet Show) == Just () -- is Ok
data a :+ b = a :+ b
infixr 5 :+

class Append c a where
    append :: a -> HtsCSet c -> HtsCSet c

fill :: (Append c a) => a -> HtsCSet c
fill = flip append empty

instance (Typeable a, c a, Append c b) => Append c (a :+ b) where
    append (a :+ b) = insert a . (append b)

instance Append c () where
    append _ hs = hs