From d1396b988dbd897e9861c5747af4a360d58a25d3 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 30 Oct 2015 15:08:12 +0100 Subject: [PATCH] Groundwork for higher-kinded db indices. --- verdict-db/src/Verdict/DB/Internal.hs | 93 +++++++++++++++++---------- verdict-db/verdict-db.cabal | 1 + verdict/src/Verdict/Class.hs | 20 +++--- 3 files changed, 70 insertions(+), 44 deletions(-) diff --git a/verdict-db/src/Verdict/DB/Internal.hs b/verdict-db/src/Verdict/DB/Internal.hs index 08a10e7..dd46279 100644 --- a/verdict-db/src/Verdict/DB/Internal.hs +++ b/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 diff --git a/verdict-db/verdict-db.cabal b/verdict-db/verdict-db.cabal index c50b1c4..d319eb0 100644 --- a/verdict-db/verdict-db.cabal +++ b/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 diff --git a/verdict/src/Verdict/Class.hs b/verdict/src/Verdict/Class.hs index 514d47c..45b88d7 100644 --- a/verdict/src/Verdict/Class.hs +++ b/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