Groundwork for higher-kinded db indices.

verdict-db/src/Verdict/DB/Internal.hs

@@ -1,10 +1,10 @@
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
 {-# LANGUAGE GADTs #-}
 module Verdict.DB.Internal where
 
 import Data.Proxy
 import qualified Data.Vector as V
+import qualified Data.Map as Map
 import GHC.TypeLits
 import Verdict
 
@@ -13,7 +13,7 @@ import Verdict
 empty :: MkIxs cs val => DB cs val
 empty = DB { dbData = V.empty , dbIxs = mkIxs }
 
-query :: forall c cs val. (HaskVerdict c val, HOccurs c cs val) => DB cs val -> [Validated c val]
+query :: forall c cs val. (DBVerdictIx c val, HOccurs c cs val) => DB cs val -> [Validated c val]
 query db = query' ix (dbData db)
   where
     ix = hOccurrence (Proxy :: Proxy c) (dbIxs db)
@@ -23,19 +23,71 @@ insert val db = DB { dbData = V.snoc (dbData db) val
                    , dbIxs = insertAll (V.length (dbData db), val) (dbIxs db)
                    }
 
+data DB cs val = DB
+    { dbData :: V.Vector val
+    , dbIxs  :: HList cs val
+    }
+
+-- Polykinded tuple proxy
+data Tup a b = Tup
 ------------------------------------------------------------------------------
+-- DBVerdictIx
+--
+-- TODO: Find a better data structure
+--
+class DBVerdictIx (c :: k) val where
+    type Index c val
+    empty' :: Tup c val -> Index c val
+    insert' :: Tup c val -> (Int, val) -> Index c val -> Index c val
+    query' :: Index c val -> V.Vector val -> [Validated c val]
+
+-- @*@-kinded (predicate) constraints.
+instance (HaskVerdict c v) => DBVerdictIx (c :: *) v where
+    type Index c v = ([Int], [Int])
+    empty' _  = ([], [])
+    insert' _ (i,val) (ts, fs) = if isValid p val then (i:ts, fs) else (ts, i:fs)
+      where p = Proxy :: Proxy c
+    query' (ts, fs) vec = [ unsafeValidated (vec V.! i) | i <- ts ]
+
+-- @* -> *@-kinded (map) constraints.
+instance ( HaskVerdict (c n) v, GetIxVal c v, GetIxValType c v ~ n, Ord n
+         ) => DBVerdictIx (c :: * -> *) v where
+    type Index c v = Map.Map (GetIxValType c v) Int
+    empty' _ = Map.empty
+    insert' _ (i,val) = Map.insert (getIxVal p val) i
+      where p = Proxy :: Proxy c
+    {-query' m vec =-}
+------------------------------------------------------------------------------
+-- GetIxVal
+--
+-- Gets the value to use as index for * -> * indices
+
+class GetIxVal c val where
+    type GetIxValType c val
+    getIxVal :: Proxy c -> val -> GetIxValType c val
 
+instance (Foldable f) => GetIxVal Length (f b) where
+    type GetIxValType Length (f b) = Int
+    getIxVal _ = length
 
+------------------------------------------------------------------------------
+-- InsertAll
+--
+-- Inserts across all indices
 class InsertAll cs v where
     insertAll :: (Int, v) -> HList cs v -> HList cs v
 
 instance InsertAll '[] v where
     insertAll _ HNil = HNil
 
-instance (HaskVerdict c v, InsertAll cs v) => InsertAll (c ': cs) v where
+instance (DBVerdictIx c v, InsertAll cs v) => InsertAll (c ': cs) v where
     insertAll new (HCons i rest) = HCons (insert' p new i) (insertAll new rest)
-      where p = Proxy :: Proxy (c, v)
+      where p = Tup :: Tup c v
 
+------------------------------------------------------------------------------
+-- MkIxs
+--
+-- Creates the appropriate empty indices
 class MkIxs cs val where
     mkIxs :: HList cs val
 
@@ -44,30 +96,11 @@ instance MkIxs '[] val where
 
 instance (DBVerdictIx x val, MkIxs xs val) => MkIxs (x ': xs) val where
     mkIxs = HCons (empty' p) mkIxs
-      where p = Proxy :: Proxy (x, val)
+      where p = Tup :: Tup x val
 
--- TODO: Find a better data structure
+------------------------------------------------------------------------------
+-- HOccurs
 --
--- | A single secondary key index
-class DBVerdictIx c val where
-    type Index c val
-    empty' :: Proxy (c, val) -> Index c val
-    insert' :: Proxy (c, val) -> (Int, val) -> Index c val -> Index c val
-    query' :: Index c val -> V.Vector val -> [Validated c val]
-
-instance (HaskVerdict c v) => DBVerdictIx c v where
-    type Index c v = ([Int], [Int])
-    empty' _  = ([], [])
-    insert' _ (i,val) (ts, fs) = if isValid p val then (i:ts, fs) else (ts, i:fs)
-      where p = Proxy :: Proxy c
-    query' (ts, fs) vec = [ unsafeValidated (vec V.! i) | i <- ts ]
-
-data DB cs val = DB
-    { dbData :: V.Vector val
-    , dbIxs  :: HList cs val
-    }
-
-
 -- Gets the first occurrence of a 'c'-index in the HList.
 class HOccurs c cs v where
     hOccurrence :: Proxy c -> HList cs v -> Index c v
@@ -80,10 +113,4 @@ instance (HOccurs x xs v) => HOccurs x (y ': xs) v where
 
 data HList xs v where
     HNil :: HList '[] v
-    HCons :: {- DBVerdictIx c v => -} Index c v -> HList cs v -> HList (c ': cs) v
-{-
-instance (DBVerdict c v, DBVerdict cs v) => DB (c ': cs) v where
-    type Index (c ': cs) v = (Index c v, Index cs v)
-    empty = empty : empty
-    insert new ixs = insert new <$> ixs
--}
+    HCons :: Index c v -> HList cs v -> HList (c ': cs) v

verdict-db/verdict-db.cabal

@@ -32,6 +32,7 @@ library
                      , DeriveGeneric
                      , DeriveDataTypeable
   build-depends:       base >=4.8 && <4.9
+                     , containers
                      , vector
                      , verdict
   hs-source-dirs:      src

verdict/src/Verdict/Class.hs

@@ -43,13 +43,13 @@ instance HaskVerdict 'True a where
 instance HaskVerdict () a where
     haskVerdict _ = const Nothing
 
-instance (Ord b, Show b, KnownVal a b) => HaskVerdict (Maximum a) b where
+instance (Ord b, Num b, Show b, KnownNat a) => HaskVerdict (Maximum a) b where
     haskVerdict _ = check (<= p) ("Should be less than " <> showT p)
-      where p = knownVal (Proxy :: Proxy a)
+      where p = fromInteger $ natVal (Proxy :: Proxy a)
 
-instance (Ord b, Show b, KnownVal a b) => HaskVerdict (Minimum a) b where
+instance (Ord b, Num b, Show b, KnownNat a) => HaskVerdict (Minimum a) b where
     haskVerdict _ = check (>= p) ("Should be more than " <> showT p)
-      where p = knownVal (Proxy :: Proxy a)
+      where p = fromInteger $ natVal (Proxy :: Proxy a)
 
 instance (Foldable f, Show (f b), KnownNat a)
        => HaskVerdict (MaxLength a) (f b) where
@@ -61,13 +61,13 @@ instance (Foldable f, Show (f b), KnownNat a)
        => HaskVerdict (MinLength a) (f b) where
     haskVerdict _ = check ((>= p) . length)
                           ("Should be of length more than " <> showT p)
-      where p = fromInteger $ knownVal (Proxy :: Proxy a)
+      where p = fromInteger $ natVal (Proxy :: Proxy a)
 
 instance (Foldable t, KnownNat a) => HaskVerdict (Length a) (t b) where
     haskVerdict _ = check ((== p) . length) ("Should be of length " <> showT p)
       where p = fromInteger $ natVal (Proxy :: Proxy a)
 
-instance (Foldable t, Show b, Eq b, KnownVal a b)
+instance (Foldable t, Show b, Eq b, KnownVal a, KnownValType a ~ b)
     => HaskVerdict (HasElem a) (t b) where
     haskVerdict _ = check (elem p) ("Should contain " <> showT p)
       where p = knownVal (Proxy :: Proxy a)
@@ -84,8 +84,6 @@ check pred' err x = guard (not $ pred' x) >> pure (Leaf err)
 
 ------------------------------------------------------------------------------
 -- Known Val
-class KnownVal a b | a -> b where
-    knownVal :: Proxy a -> b
-
-instance KnownNat n => KnownVal n Integer where
-    knownVal = natVal
+class KnownVal a where
+    type KnownValType a
+    knownVal :: Proxy a -> KnownValType a