module Data.Store.Internal.Type
where
import Control.Applicative ((<$>), (<*>))
import Control.DeepSeq (NFData(rnf))
import Data.Data (Typeable, Typeable2)
import qualified Data.Data
import qualified Data.List
import Data.Monoid ((<>))
#if MIN_VERSION_containers(0,5,0)
import qualified Data.IntMap.Strict as Data.IntMap
import qualified Data.Map.Strict as Data.Map
#else
import qualified Data.IntMap
import qualified Data.Map
#endif
import qualified Data.IntSet
import qualified Data.Foldable as F
import qualified Data.SafeCopy as Ser
import qualified Data.Serialize as Ser (Serialize, get, put)
moduleName :: String
moduleName = "Data.Store.Internal.Type"
data M
data O
data Z = Z
data S n = S n
type N0 = Z
type N1 = S N0
type N2 = S N1
type N3 = S N2
type N4 = S N3
type N5 = S N4
type N6 = S N5
type N7 = S N6
type N8 = S N7
type N9 = S N8
type N10 = S N9
n0 :: N0
n0 = Z
n1 :: N1
n1 = S n0
n2 :: N2
n2 = S n1
n3 :: N3
n3 = S n2
n4 :: N4
n4 = S n3
n5 :: N5
n5 = S n4
n6 :: N6
n6 = S n5
n7 :: N7
n7 = S n6
n8 :: N8
n8 = S n7
n9 :: N9
n9 = S n8
n10 :: N10
n10 = S n9
type family DimensionRelation n rs ts :: *
type instance DimensionRelation Z O ts = O
type instance DimensionRelation Z M ts = M
type instance DimensionRelation Z (r :. rt) (t :. tt) = r
type instance DimensionRelation (S n) (r :. rt) (t :. tt) = DimensionRelation n rt tt
type family DimensionType n rs ts :: *
type instance DimensionType Z M t = t
type instance DimensionType Z O t = t
type instance DimensionType Z (r :. rt) (t :. tt) = t
type instance DimensionType (S n) (r :. rt) (t :. tt) = DimensionType n rt tt
type family RawDimensionType n a :: *
type instance RawDimensionType n (Index irs ts) = IndexDimension (DimensionRelation n irs ts) (DimensionType n irs ts)
type family RawKey kspec tspec :: *
type instance RawKey (O :. rt) (t :. tt) = t :. RawKey rt tt
type instance RawKey (M :. rt) (t :. tt) = [t] :. RawKey rt tt
type instance RawKey O t = t
type instance RawKey M t = [t]
class (Ord k, Enum k, Bounded k) => Auto k where
instance (Ord k, Enum k, Bounded k) => Auto k where
data Store tag krs irs ts v = Store
{ storeV :: !(Data.IntMap.IntMap (IKey krs ts, v))
, storeI :: !(Index irs ts)
, storeNID :: !Int
} deriving (Typeable)
instance (Show h, Show t) => Show (h :. t) where
show (h :. t) = show h <> " :. " <> show t
instance (Ser.Serialize (IKey krs ts), Ser.Serialize (Index irs ts), Ser.Serialize v) => Ser.Serialize (Store tag krs irs ts v) where
get = Store <$> Ser.get <*> Ser.get <*> Ser.get
put (Store vs ix nid) = Ser.put vs >> Ser.put ix >> Ser.put nid
instance (Ser.SafeCopy (IKey krs ts), Ser.SafeCopy (Index irs ts), Ser.SafeCopy v) => Ser.SafeCopy (Store tag krs irs ts v) where
getCopy = Ser.contain $ Store <$> Ser.safeGet <*> Ser.safeGet <*> Ser.safeGet
putCopy (Store vs ix nid) = Ser.contain $ Ser.safePut vs >> Ser.safePut ix >> Ser.safePut nid
instance (Show (IKey krs ts), Show v) => Show (Store tag krs irs ts v) where
show (Store vs _ _) = "[" <> go <> "]"
where
go = Data.List.intercalate "," $ map (\(ik, v) -> "((" <> show ik <> "), " <> show v <> ")")
$ F.toList vs
data GenericKey dim rs ts where
KN :: !(dim r t) -> !(GenericKey dim rt tt) -> GenericKey dim (r :. rt) (t :. tt)
K1 :: !(dim r t) -> GenericKey dim r t
instance Eq (GenericKey IKeyDimension rs ts) where
(K1 x) == (K1 y) = x == y
(KN x xt) == (KN y yt) = x == y && xt == yt
_ == _ = False
(K1 x) /= (K1 y) = x /= y
(KN x xt) /= (KN y yt) = x /= y || xt /= yt
_ /= _ = True
instance Ser.Serialize (dim O t) => Ser.Serialize (GenericKey dim O t) where
get = K1 <$> Ser.get
put (K1 d) = Ser.put d
instance Ser.Serialize (dim M t) => Ser.Serialize (GenericKey dim M t) where
get = K1 <$> Ser.get
put (K1 d) = Ser.put d
instance (Ser.Serialize (GenericKey dim rt tt), Ser.Serialize (dim r t)) => Ser.Serialize (GenericKey dim (r :. rt) (t :. tt)) where
get = KN <$> Ser.get <*> Ser.get
put (KN d dt) = Ser.put d >> Ser.put dt
put (K1 _) = error $ moduleName <> ".GenricKey.put: The impossible happened."
instance Ser.SafeCopy (dim O t) => Ser.SafeCopy (GenericKey dim O t) where
getCopy = Ser.contain $ K1 <$> Ser.safeGet
putCopy (K1 d) = Ser.contain $ Ser.safePut d
instance Ser.SafeCopy (dim M t) => Ser.SafeCopy (GenericKey dim M t) where
getCopy = Ser.contain $ K1 <$> Ser.safeGet
putCopy (K1 d) = Ser.contain $ Ser.safePut d
instance (Ser.SafeCopy (GenericKey dim rt tt), Ser.SafeCopy (dim r t)) => Ser.SafeCopy (GenericKey dim (r :. rt) (t :. tt)) where
getCopy = Ser.contain $ KN <$> Ser.safeGet <*> Ser.safeGet
putCopy (KN d dt) = Ser.contain $ Ser.safePut d >> Ser.safePut dt
putCopy (K1 _) = error $ moduleName <> ".GenricKey.putCopy: The impossible happened."
instance Typeable2 (GenericKey dim) where
typeOf2 (K1 _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "K1") []
typeOf2 (KN _ _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "KN") []
type Key = GenericKey KeyDimension
type IKey = GenericKey IKeyDimension
instance Show t => Show (Key O t) where
show (K1 d) = show d
instance Show t => Show (Key M t) where
show (K1 d) = show d
instance (Show t, Show (Key rt tt)) => Show (Key (r :. rt) (t :. tt)) where
show (KN d k) = show d <> ", " <> show k
show (K1 _) = error $ moduleName <> ".Key.show: The impossible happened."
instance Show t => Show (IKey O t) where
show (K1 d) = show d
instance Show t => Show (IKey M t) where
show (K1 d) = show d
instance (Show t, Show (IKey rt tt)) => Show (IKey (r :. rt) (t :. tt)) where
show (KN d k) = show d <> ", " <> show k
show (K1 _) = error $ moduleName <> ".IKey.show: The impossible happened."
data Index rs ts where
IN :: Ord t => !(IndexDimension r t) -> !(Index rt tt) -> Index (r :. rt) (t :. tt)
I1 :: Ord t => !(IndexDimension r t) -> Index r t
instance (Ord t, Ser.Serialize t) => Ser.Serialize (Index O t) where
get = I1 <$> Ser.get
put (I1 ixd) = Ser.put ixd
instance (Ord t, Ser.Serialize t) => Ser.Serialize (Index M t) where
get = I1 <$> Ser.get
put (I1 ixd) = Ser.put ixd
instance (Ord t, Ser.Serialize t, Ser.Serialize (Index rt tt)) => Ser.Serialize (Index (O :. rt) (t :. tt)) where
get = IN <$> Ser.get <*> Ser.get
put (IN ixd ixt) = Ser.put ixd >> Ser.put ixt
put (I1 _) = error $ moduleName <> ".Index.put: The impossible happened (#1)."
instance (Ord t, Ser.Serialize t, Ser.Serialize (Index rt tt)) => Ser.Serialize (Index (M :. rt) (t :. tt)) where
get = IN <$> Ser.get <*> Ser.get
put (IN ixd ixt) = Ser.put ixd >> Ser.put ixt
put (I1 _) = error $ moduleName <> ".Index.put: The impossible happened (#2)."
instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (Index O t) where
getCopy = Ser.contain $ I1 <$> Ser.safeGet
putCopy (I1 ixd) = Ser.contain $ Ser.safePut ixd
instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (Index M t) where
getCopy = Ser.contain $ I1 <$> Ser.safeGet
putCopy (I1 ixd) = Ser.contain $ Ser.safePut ixd
instance (Ord t, Ser.SafeCopy t, Ser.SafeCopy (Index rt tt)) => Ser.SafeCopy (Index (O :. rt) (t :. tt)) where
getCopy = Ser.contain $ IN <$> Ser.safeGet <*> Ser.safeGet
putCopy (IN ixd ixt) = Ser.contain $ Ser.safePut ixd >> Ser.safePut ixt
putCopy (I1 _) = error $ moduleName <> ".Index.putCopy: The impossible happened (#1)."
instance (Ord t, Ser.SafeCopy t, Ser.SafeCopy (Index rt tt)) => Ser.SafeCopy (Index (M :. rt) (t :. tt)) where
getCopy = Ser.contain $ IN <$> Ser.safeGet <*> Ser.safeGet
putCopy (IN ixd ixt) = Ser.contain $ Ser.safePut ixd >> Ser.safePut ixt
putCopy (I1 _) = error $ moduleName <> ".Index.putCopy: The impossible happened (#2)."
instance Typeable2 Index where
typeOf2 (I1 _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "I1") []
typeOf2 (IN _ _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "IN") []
instance Show t => Show (Index O t) where
show (I1 d) = show d
instance Show t => Show (Index M t) where
show (I1 d) = show d
instance (Show t, Show (Index rt tt)) => Show (Index (r :. rt) (t :. tt)) where
show (IN d i) = show d <> "\n" <> show i
show (I1 _) = error $ moduleName <> ".Index.show: The impossible happened."
data KeyDimension r t where
KeyDimensionO :: Ord t => t -> KeyDimension O t
KeyDimensionM :: Ord t => [t] -> KeyDimension M t
KeyDimensionA :: Auto t => KeyDimension O t
deriving instance Typeable2 KeyDimension
instance Show t => Show (KeyDimension r t) where
show (KeyDimensionM ts) = show ts
show (KeyDimensionO t) = show t
show KeyDimensionA = show "Auto"
data IKeyDimension r t where
IKeyDimensionO :: Ord t => t -> IKeyDimension O t
IKeyDimensionM :: Ord t => [t] -> IKeyDimension M t
instance Eq (IKeyDimension r t) where
(IKeyDimensionM x) == (IKeyDimensionM y) = x == y
(IKeyDimensionO x) == (IKeyDimensionO y) = x == y
_ == _ = False
(IKeyDimensionM x) /= (IKeyDimensionM y) = x /= y
(IKeyDimensionO x) /= (IKeyDimensionO y) = x /= y
_ /= _ = True
deriving instance Typeable2 IKeyDimension
instance (Ord t, Ser.Serialize t) => Ser.Serialize (IKeyDimension O t) where
get = IKeyDimensionO <$> Ser.get
put (IKeyDimensionO x) = Ser.put x
instance (Ord t, Ser.Serialize t) => Ser.Serialize (IKeyDimension M t) where
get = IKeyDimensionM <$> Ser.get
put (IKeyDimensionM x) = Ser.put x
instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IKeyDimension O t) where
getCopy = Ser.contain $ IKeyDimensionO <$> Ser.safeGet
putCopy (IKeyDimensionO x) = Ser.contain $ Ser.safePut x
instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IKeyDimension M t) where
getCopy = Ser.contain $ IKeyDimensionM <$> Ser.safeGet
putCopy (IKeyDimensionM x) = Ser.contain $ Ser.safePut x
instance Show t => Show (IKeyDimension r t) where
show (IKeyDimensionM ts) = show ts
show (IKeyDimensionO t) = show t
data IndexDimension r t where
IndexDimensionO :: Ord t
=> !(Data.Map.Map t Int)
-> IndexDimension O t
IndexDimensionM :: Ord t
=> !(Data.Map.Map t Data.IntSet.IntSet)
-> IndexDimension M t
instance (Ord t, Ser.Serialize t) => Ser.Serialize (IndexDimension O t) where
get = IndexDimensionO <$> Ser.get
put (IndexDimensionO x) = Ser.put x
instance (Ord t, Ser.Serialize t) => Ser.Serialize (IndexDimension M t) where
get = IndexDimensionM <$> Ser.get
put (IndexDimensionM x) = Ser.put x
instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IndexDimension O t) where
getCopy = Ser.contain $ IndexDimensionO <$> Ser.safeGet
putCopy (IndexDimensionO x) = Ser.contain $ Ser.safePut x
instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IndexDimension M t) where
getCopy = Ser.contain $ IndexDimensionM <$> Ser.safeGet
putCopy (IndexDimensionM x) = Ser.contain $ Ser.safePut x
instance Show t => Show (IndexDimension r t) where
show (IndexDimensionM m) = show $ map (\(k, vs) -> (k, Data.IntSet.toList vs)) $ Data.Map.toList m
show (IndexDimensionO m) = show $ Data.Map.toList m
class GetDimension n a where
getDimension :: n -> a -> RawDimensionType n a
instance GetDimension Z (Index O t) where
getDimension _ (I1 ixd) = ixd
instance GetDimension Z (Index M t) where
getDimension _ (I1 ixd) = ixd
instance GetDimension Z (Index (r :. rt) (t :. tt)) where
getDimension _ (IN ixd _) = ixd
getDimension _ (I1 _) = error $ moduleName <> ".Index.getDimension: The impossible happened."
instance GetDimension n (Index rt tt) => GetDimension (S n) (Index (r :. rt) (t :. tt)) where
getDimension (S n) (IN _ ixt) = getDimension n ixt
getDimension _ (I1 _) = error $ moduleName <> ".Index.getDimension: The impossible happened."
data TT
data FF
type family EmptyProxyIsSpecial t :: *
type instance EmptyProxyIsSpecial Int = TT
class Empty a where
empty :: a
class EmptyProxy flag a where
emptyProxy :: flag -> a
instance Ord t => Empty (Index O t) where
empty = I1 (IndexDimensionO Data.Map.empty)
instance Ord t => Empty (Index M t) where
empty = I1 (IndexDimensionM Data.Map.empty)
instance (Ord t, Empty (Index rt tt)) => Empty (Index (O :. rt) (t :. tt)) where
empty = IN (IndexDimensionO Data.Map.empty) empty
instance (Ord t, Empty (Index rt tt)) => Empty (Index (M :. rt) (t :. tt)) where
empty = IN (IndexDimensionM Data.Map.empty) empty
instance Empty (Index irs ts) => Empty (Store tag krs irs ts e) where
empty = Store
{ storeV = Data.IntMap.empty
, storeI = empty
, storeNID = 0
}
data h :. t = h :. t
infixr 3 :.
instance (NFData e, NFData (IKey krs ts), NFData (Index irs ts)) => NFData (Store tag krs irs ts e) where
rnf (Store ke ix nid) = rnf ke `seq` rnf ix `seq` rnf nid
instance NFData t => NFData (IndexDimension r t) where
rnf (IndexDimensionO m) = rnf m
rnf (IndexDimensionM m) = rnf m
instance NFData t => NFData (Index O t) where
rnf (I1 kd) = rnf kd
instance NFData t => NFData (Index M t) where
rnf (I1 kd) = rnf kd
instance (NFData t, NFData (Index rt tt)) => NFData (Index (r :. rt) (t :. tt)) where
rnf (IN kd kt) = rnf kd `seq` rnf kt
rnf (I1 _) = error "Impossible! (Index NFData)"
instance NFData t => NFData (IKeyDimension r t) where
rnf (IKeyDimensionO x) = rnf x
rnf (IKeyDimensionM x) = rnf x
instance NFData t => NFData (IKey O t) where
rnf (K1 kd) = rnf kd
instance NFData t => NFData (IKey M t) where
rnf (K1 kd) = rnf kd
instance (NFData t, NFData (IKey rt tt)) => NFData (IKey (r :. rt) (t :. tt)) where
rnf (KN kd kt) = rnf kd `seq` rnf kt
rnf (K1 _) = error "Impossible! (IKey NFData)"
instance (NFData a, NFData b) => NFData (a :. b) where
rnf (a :. b) = rnf a `seq` rnf b