{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Table (
    -- * Synopsis
    -- | 'Table' models a database table.
    -- It corresponds to a collection of rows.
    -- Each row has a unique ID, but this is transparent to the API user.
    --
    -- 'Pile' models a set of values.
    -- Unlike 'Set', it is represented as a lightweight list.
    -- This is used to highlight that the ordering of rows
    -- in a 'Table' is /not/ deterministic.
    --
    -- 'Supply' is a supply of unique IDs.

    -- * Table
    Table (..)
    , empty, fromRows, fromList, toPile, toRows
    , selectWhere, insertMany, deleteWhere, updateWhere
    , DeltaTable (..)
    , DeltaDB (..)
    , tableIntoDatabase

    -- * Pile
    , Pile (..)
    , fromSet
    , deltaListToPile, deltaListFromPile
    , deltaSetToPile, deltaSetFromPile

    -- * Supply
    , Supply
    , abundance, fresh, consume
    ) where

import Prelude

import Control.Monad
    ( forM )
import Control.Monad.Trans.State.Strict
    ( evalState, state )
import Data.Delta
    ( Delta (..)
    , DeltaList (..)
    , DeltaSet
    , DeltaSet1 (..)
    , Embedding
    , Embedding' (..)
    , mkEmbedding
    )
import Data.IntMap.Strict
    ( IntMap )
import Data.List
    ( sort, sortOn )
import Data.Ord
    ( Down (..) )
import Data.Set
    ( Set )

import qualified Data.Delta as Delta
import qualified Data.IntMap.Strict as Map
import qualified Data.Set as Set

{-------------------------------------------------------------------------------
    Table
-------------------------------------------------------------------------------}
-- | A 'Table' is a collection of rows.
data Table row = Table
    { Table row -> IntMap row
rows :: IntMap row
    -- ^ Rows indexed by unique ID.
    , Table row -> Supply
uids :: Supply
    -- ^ Unique ID supply.
    -- WARNING: This is an internal part of the structure.
    -- Changing it may lead to an inconsistent state.
    } deriving (Int -> Table row -> ShowS
[Table row] -> ShowS
Table row -> String
(Int -> Table row -> ShowS)
-> (Table row -> String)
-> ([Table row] -> ShowS)
-> Show (Table row)
forall row. Show row => Int -> Table row -> ShowS
forall row. Show row => [Table row] -> ShowS
forall row. Show row => Table row -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Table row] -> ShowS
$cshowList :: forall row. Show row => [Table row] -> ShowS
show :: Table row -> String
$cshow :: forall row. Show row => Table row -> String
showsPrec :: Int -> Table row -> ShowS
$cshowsPrec :: forall row. Show row => Int -> Table row -> ShowS
Show)

instance Functor Table where
    fmap :: (a -> b) -> Table a -> Table b
fmap a -> b
f table :: Table a
table@Table{IntMap a
rows :: IntMap a
rows :: forall row. Table row -> IntMap row
rows} = Table a
table{ rows :: IntMap b
rows = (a -> b) -> IntMap a -> IntMap b
forall a b. (a -> b) -> IntMap a -> IntMap b
Map.map a -> b
f IntMap a
rows }

-- | The empty 'Table', containing no rows.
empty :: Table row
empty :: Table row
empty = Table :: forall row. IntMap row -> Supply -> Table row
Table{ rows :: IntMap row
rows = IntMap row
forall a. IntMap a
Map.empty, uids :: Supply
uids = Supply
abundance }

-- | List all rows satisfying the predicate.
selectWhere :: (row -> Bool) -> Table row -> Pile row
selectWhere :: (row -> Bool) -> Table row -> Pile row
selectWhere row -> Bool
p = [row] -> Pile row
forall a. [a] -> Pile a
Pile ([row] -> Pile row)
-> (Table row -> [row]) -> Table row -> Pile row
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (row -> Bool) -> [row] -> [row]
forall a. (a -> Bool) -> [a] -> [a]
filter row -> Bool
p ([row] -> [row]) -> (Table row -> [row]) -> Table row -> [row]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap row -> [row]
forall a. IntMap a -> [a]
Map.elems (IntMap row -> [row])
-> (Table row -> IntMap row) -> Table row -> [row]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table row -> IntMap row
forall row. Table row -> IntMap row
rows

-- | Insert rows into the table.
insertMany :: [row] -> Table row -> Table row
insertMany :: [row] -> Table row -> Table row
insertMany [row]
rs Table row
table = (row -> Table row -> Table row) -> Table row -> [row] -> Table row
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr row -> Table row -> Table row
forall row. row -> Table row -> Table row
insertRow Table row
table [row]
rs
  where
    insertRow :: row -> Table row -> Table row
insertRow row
row Table{IntMap row
rows :: IntMap row
rows :: forall row. Table row -> IntMap row
rows,Supply
uids :: Supply
uids :: forall row. Table row -> Supply
uids} =
        Table :: forall row. IntMap row -> Supply -> Table row
Table{ rows :: IntMap row
rows = Int -> row -> IntMap row -> IntMap row
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
uid row
row IntMap row
rows, uids :: Supply
uids = Supply
uids2 }
      where (Int
uid, Supply
uids2) = Supply -> (Int, Supply)
fresh Supply
uids

-- | Construct a 'Table' from a list of rows
fromList :: [row] -> Table row
fromList :: [row] -> Table row
fromList [row]
rows = [row] -> Table row -> Table row
forall row. [row] -> Table row -> Table row
insertMany [row]
rows Table row
forall row. Table row
empty

-- | Construct a 'Table' from a list of rows with unique IDs.
fromRows :: [(Int, row)] -> Table row
fromRows :: [(Int, row)] -> Table row
fromRows [(Int, row)]
rows = Table :: forall row. IntMap row -> Supply -> Table row
Table
    { rows :: IntMap row
rows = [(Int, row)] -> IntMap row
forall a. [(Int, a)] -> IntMap a
Map.fromList [(Int, row)]
rows
    , uids :: Supply
uids = [Int] -> Supply -> Supply
consume [Int]
keys Supply
abundance
    }
  where keys :: [Int]
keys = ((Int, row) -> Int) -> [(Int, row)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, row) -> Int
forall a b. (a, b) -> a
fst [(Int, row)]
rows

-- | Pile of rows contained in the 'Table'.
toPile :: Table row -> Pile row
toPile :: Table row -> Pile row
toPile = [row] -> Pile row
forall a. [a] -> Pile a
Pile ([row] -> Pile row)
-> (Table row -> [row]) -> Table row -> Pile row
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap row -> [row]
forall a. IntMap a -> [a]
Map.elems (IntMap row -> [row])
-> (Table row -> IntMap row) -> Table row -> [row]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table row -> IntMap row
forall row. Table row -> IntMap row
rows

-- | Pile of rows with unique IDs contained in the 'Table'.
toRows :: Table row -> Pile (Int,row)
toRows :: Table row -> Pile (Int, row)
toRows = [(Int, row)] -> Pile (Int, row)
forall a. [a] -> Pile a
Pile ([(Int, row)] -> Pile (Int, row))
-> (Table row -> [(Int, row)]) -> Table row -> Pile (Int, row)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap row -> [(Int, row)]
forall a. IntMap a -> [(Int, a)]
Map.toList (IntMap row -> [(Int, row)])
-> (Table row -> IntMap row) -> Table row -> [(Int, row)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table row -> IntMap row
forall row. Table row -> IntMap row
rows

-- | Delete all rows satisfying the predicate.
deleteWhere :: (row -> Bool) -> Table row -> Table row
deleteWhere :: (row -> Bool) -> Table row -> Table row
deleteWhere row -> Bool
p table :: Table row
table@Table{IntMap row
rows :: IntMap row
rows :: forall row. Table row -> IntMap row
rows} = Table row
table{ rows :: IntMap row
rows = (row -> Bool) -> IntMap row -> IntMap row
forall a. (a -> Bool) -> IntMap a -> IntMap a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (row -> Bool) -> row -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. row -> Bool
p) IntMap row
rows }

-- | Update all rows satisfying the predicate
updateWhere :: (row -> Bool) -> (row -> row) -> Table row -> Table row
updateWhere :: (row -> Bool) -> (row -> row) -> Table row -> Table row
updateWhere row -> Bool
p row -> row
f table :: Table row
table@Table{IntMap row
rows :: IntMap row
rows :: forall row. Table row -> IntMap row
rows} = Table row
table{ rows :: IntMap row
rows = (row -> row) -> IntMap row -> IntMap row
forall a b. (a -> b) -> IntMap a -> IntMap b
Map.map row -> row
g IntMap row
rows }
  where g :: row -> row
g row
row = if row -> Bool
p row
row then row -> row
f row
row else row
row

-- | Delta encoding for changes to a 'Table'.
data DeltaTable row
    = InsertMany [row]
    | DeleteWhere (row -> Bool)
    | UpdateWhere (row -> Bool) (row -> row)

instance Show row => Show (DeltaTable row) where
    showsPrec :: Int -> DeltaTable row -> ShowS
showsPrec Int
d DeltaTable row
delta = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ case DeltaTable row
delta of
        InsertMany [row]
rs -> String -> ShowS
showString String
"InsertMany " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [row] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
app_precInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [row]
rs
        DeleteWhere row -> Bool
_ -> String -> ShowS
showString String
"DeleteWhere (..)"
        UpdateWhere row -> Bool
_ row -> row
_ -> String -> ShowS
showString String
"UpdateWhere (..)"
      where app_prec :: Int
app_prec = Int
10

instance Delta (DeltaTable row) where
    type Base (DeltaTable row) = Table row
    apply :: DeltaTable row -> Base (DeltaTable row) -> Base (DeltaTable row)
apply (InsertMany [row]
rows) = [row] -> Table row -> Table row
forall row. [row] -> Table row -> Table row
insertMany [row]
rows
    apply (DeleteWhere row -> Bool
p)   = (row -> Bool) -> Table row -> Table row
forall row. (row -> Bool) -> Table row -> Table row
deleteWhere row -> Bool
p
    apply (UpdateWhere row -> Bool
p row -> row
f) = (row -> Bool) -> (row -> row) -> Table row -> Table row
forall row. (row -> Bool) -> (row -> row) -> Table row -> Table row
updateWhere row -> Bool
p row -> row
f

-- | Delta encoding for changes to a database table with unique IDs.
data DeltaDB key row
    = InsertManyDB [(key, row)]
    | DeleteManyDB [key]
    | UpdateManyDB [(key, row)]
    deriving (DeltaDB key row -> DeltaDB key row -> Bool
(DeltaDB key row -> DeltaDB key row -> Bool)
-> (DeltaDB key row -> DeltaDB key row -> Bool)
-> Eq (DeltaDB key row)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall key row.
(Eq key, Eq row) =>
DeltaDB key row -> DeltaDB key row -> Bool
/= :: DeltaDB key row -> DeltaDB key row -> Bool
$c/= :: forall key row.
(Eq key, Eq row) =>
DeltaDB key row -> DeltaDB key row -> Bool
== :: DeltaDB key row -> DeltaDB key row -> Bool
$c== :: forall key row.
(Eq key, Eq row) =>
DeltaDB key row -> DeltaDB key row -> Bool
Eq, Int -> DeltaDB key row -> ShowS
[DeltaDB key row] -> ShowS
DeltaDB key row -> String
(Int -> DeltaDB key row -> ShowS)
-> (DeltaDB key row -> String)
-> ([DeltaDB key row] -> ShowS)
-> Show (DeltaDB key row)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall key row.
(Show key, Show row) =>
Int -> DeltaDB key row -> ShowS
forall key row. (Show key, Show row) => [DeltaDB key row] -> ShowS
forall key row. (Show key, Show row) => DeltaDB key row -> String
showList :: [DeltaDB key row] -> ShowS
$cshowList :: forall key row. (Show key, Show row) => [DeltaDB key row] -> ShowS
show :: DeltaDB key row -> String
$cshow :: forall key row. (Show key, Show row) => DeltaDB key row -> String
showsPrec :: Int -> DeltaDB key row -> ShowS
$cshowsPrec :: forall key row.
(Show key, Show row) =>
Int -> DeltaDB key row -> ShowS
Show)

instance Functor (DeltaDB key) where
    fmap :: (a -> b) -> DeltaDB key a -> DeltaDB key b
fmap a -> b
f (InsertManyDB [(key, a)]
zs) = [(key, b)] -> DeltaDB key b
forall key row. [(key, row)] -> DeltaDB key row
InsertManyDB [ (key
k, a -> b
f a
r) | (key
k,a
r) <- [(key, a)]
zs ]
    fmap a -> b
_ (DeleteManyDB [key]
ks) = [key] -> DeltaDB key b
forall key row. [key] -> DeltaDB key row
DeleteManyDB [key]
ks
    fmap a -> b
f (UpdateManyDB [(key, a)]
zs) = [(key, b)] -> DeltaDB key b
forall key row. [(key, row)] -> DeltaDB key row
UpdateManyDB [ (key
k, a -> b
f a
r) | (key
k,a
r) <- [(key, a)]
zs ]

instance (key ~ Int) => Delta (DeltaDB key row) where
    type Base (DeltaDB key row) = Table row
    apply :: DeltaDB key row -> Base (DeltaDB key row) -> Base (DeltaDB key row)
apply (InsertManyDB [(key, row)]
zs) table :: Base (DeltaDB key row)
table@Table{rows,uids} = Base (DeltaDB key row)
Table row
table
        { rows :: IntMap row
rows = ((IntMap row -> IntMap row) -> IntMap row -> IntMap row)
-> IntMap row -> [IntMap row -> IntMap row] -> IntMap row
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IntMap row -> IntMap row) -> IntMap row -> IntMap row
forall a b. (a -> b) -> a -> b
($) IntMap row
rows [ Int -> row -> IntMap row -> IntMap row
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert key
Int
k row
r | (key
k,row
r) <- [(key, row)]
zs ]
        , uids :: Supply
uids = [Int] -> Supply -> Supply
consume (((key, row) -> key) -> [(key, row)] -> [key]
forall a b. (a -> b) -> [a] -> [b]
map (key, row) -> key
forall a b. (a, b) -> a
fst [(key, row)]
zs) Supply
uids
        }
    apply (DeleteManyDB [key]
ks) table :: Base (DeltaDB key row)
table@Table{rows} =
        Base (DeltaDB key row)
Table row
table{ rows :: IntMap row
rows = ((IntMap row -> IntMap row) -> IntMap row -> IntMap row)
-> IntMap row -> [IntMap row -> IntMap row] -> IntMap row
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IntMap row -> IntMap row) -> IntMap row -> IntMap row
forall a b. (a -> b) -> a -> b
($) IntMap row
rows [ Int -> IntMap row -> IntMap row
forall a. Int -> IntMap a -> IntMap a
Map.delete key
Int
k | key
k <- [key]
ks ] }
    apply (UpdateManyDB [(key, row)]
zs) table :: Base (DeltaDB key row)
table@Table{rows} =
        Base (DeltaDB key row)
Table row
table{ rows :: IntMap row
rows = ((IntMap row -> IntMap row) -> IntMap row -> IntMap row)
-> IntMap row -> [IntMap row -> IntMap row] -> IntMap row
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IntMap row -> IntMap row) -> IntMap row -> IntMap row
forall a b. (a -> b) -> a -> b
($) IntMap row
rows [ (row -> row) -> Int -> IntMap row -> IntMap row
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
Map.adjust (row -> row -> row
forall a b. a -> b -> a
const row
r) key
Int
k | (key
k,row
r) <- [(key, row)]
zs ] }

tableIntoDatabase :: Embedding [DeltaTable row] [DeltaDB Int row]
tableIntoDatabase :: Embedding [DeltaTable row] [DeltaDB Int row]
tableIntoDatabase = Embedding' [DeltaTable row] [DeltaDB Int row]
-> Embedding [DeltaTable row] [DeltaDB Int row]
forall da db. Embedding' da db -> Embedding da db
mkEmbedding Embedding' :: forall da db a b.
(Delta da, Delta db, a ~ Base da, b ~ Base db) =>
(b -> Either SomeException a)
-> (a -> b) -> (a -> b -> da -> db) -> Embedding' da db
Embedding'
    { Table row -> Either SomeException (Table row)
forall b a. b -> Either a b
load :: Table row -> Either SomeException (Table row)
load :: forall b a. b -> Either a b
load, Table row -> Table row
forall a. a -> a
write :: Table row -> Table row
write :: forall a. a -> a
write, update :: Table row -> Table row -> [DeltaTable row] -> [DeltaDB Int row]
update = \Table row
_ Table row
b -> (DeltaTable row -> DeltaDB Int row)
-> [DeltaTable row] -> [DeltaDB Int row]
forall a b. (a -> b) -> [a] -> [b]
map (Table row -> DeltaTable row -> DeltaDB Int row
forall row. Table row -> DeltaTable row -> DeltaDB Int row
update1 Table row
b) }
  where
    load :: b -> Either a b
load = b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> (b -> b) -> b -> Either a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
forall a. a -> a
id
    write :: a -> a
write = a -> a
forall a. a -> a
id
    update1 :: Table row -> DeltaTable row -> DeltaDB Int row
update1 Table{Supply
uids :: Supply
uids :: forall row. Table row -> Supply
uids} (InsertMany [row]
rs) = [(Int, row)] -> DeltaDB Int row
forall key row. [(key, row)] -> DeltaDB key row
InsertManyDB ([Int] -> [row] -> [(Int, row)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
keys [row]
rs)
      where
        keys :: [Int]
keys = (State Supply [Int] -> Supply -> [Int])
-> Supply -> State Supply [Int] -> [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Supply [Int] -> Supply -> [Int]
forall s a. State s a -> s -> a
evalState Supply
uids (State Supply [Int] -> [Int]) -> State Supply [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [row] -> (row -> StateT Supply Identity Int) -> State Supply [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([row] -> [row]
forall a. [a] -> [a]
reverse [row]
rs) ((row -> StateT Supply Identity Int) -> State Supply [Int])
-> (row -> StateT Supply Identity Int) -> State Supply [Int]
forall a b. (a -> b) -> a -> b
$ \row
_ -> (Supply -> (Int, Supply)) -> StateT Supply Identity Int
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state Supply -> (Int, Supply)
fresh
    update1 Table{IntMap row
rows :: IntMap row
rows :: forall row. Table row -> IntMap row
rows} (DeleteWhere row -> Bool
p)
        = [Int] -> DeltaDB Int row
forall key row. [key] -> DeltaDB key row
DeleteManyDB [ Int
key | (Int
key,row
row) <- IntMap row -> [(Int, row)]
forall a. IntMap a -> [(Int, a)]
Map.toList IntMap row
rows, row -> Bool
p row
row ]
    update1 Table{IntMap row
rows :: IntMap row
rows :: forall row. Table row -> IntMap row
rows} (UpdateWhere row -> Bool
p row -> row
f)
        = [(Int, row)] -> DeltaDB Int row
forall key row. [(key, row)] -> DeltaDB key row
UpdateManyDB [ (Int
key, row -> row
f row
row) | (Int
key,row
row) <- IntMap row -> [(Int, row)]
forall a. IntMap a -> [(Int, a)]
Map.toList IntMap row
rows, row -> Bool
p row
row ]
-- FIXME! Be careful about the order of updates here.

{-------------------------------------------------------------------------------
    Pile
-------------------------------------------------------------------------------}
-- | A 'Pile' is a set of values.
-- Unlike 'Set', it is represented as a list, and avoids the 'Ord' constraint.
--
-- This type is useful for highlighting that a collection of values
-- has no specific order, even though it is not represented as a 'Set'.
newtype Pile a = Pile { Pile a -> [a]
getPile :: [a] }
    deriving Int -> Pile a -> ShowS
[Pile a] -> ShowS
Pile a -> String
(Int -> Pile a -> ShowS)
-> (Pile a -> String) -> ([Pile a] -> ShowS) -> Show (Pile a)
forall a. Show a => Int -> Pile a -> ShowS
forall a. Show a => [Pile a] -> ShowS
forall a. Show a => Pile a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pile a] -> ShowS
$cshowList :: forall a. Show a => [Pile a] -> ShowS
show :: Pile a -> String
$cshow :: forall a. Show a => Pile a -> String
showsPrec :: Int -> Pile a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Pile a -> ShowS
Show

instance Ord a => Eq (Pile a) where
    (Pile [a]
x) == :: Pile a -> Pile a -> Bool
== (Pile [a]
y) = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
x [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
y

fromSet :: Set a -> Pile a
fromSet :: Set a -> Pile a
fromSet = [a] -> Pile a
forall a. [a] -> Pile a
Pile ([a] -> Pile a) -> (Set a -> [a]) -> Set a -> Pile a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList

-- | Randomly permute the objects in a 'Pile'. Useful for stress testing.
--
-- Every function @f :: Pile A -> B@ should satisfy
--
-- > forall g.  f . permute g = f
--
-- permute :: RandomGen g => g -> Pile a -> Pile a
-- permute = undefined
--      let (index, g2) = randomR (1,n) g1

-- | Map a 'DeltaSet' to a 'Pile' of single element insertions and deltions.
deltaSetToPile :: DeltaSet a -> Pile (DeltaSet1 a)
deltaSetToPile :: DeltaSet a -> Pile (DeltaSet1 a)
deltaSetToPile = [DeltaSet1 a] -> Pile (DeltaSet1 a)
forall a. [a] -> Pile a
Pile ([DeltaSet1 a] -> Pile (DeltaSet1 a))
-> (DeltaSet a -> [DeltaSet1 a])
-> DeltaSet a
-> Pile (DeltaSet1 a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeltaSet a -> [DeltaSet1 a]
forall a. DeltaSet a -> [DeltaSet1 a]
Delta.deltaSetToList

-- | Restore a 'DeltaSet' from a 'Pile' of single element
-- insertions and deletions.
--
-- > deltaSetFromPile . deltaSetToPile = id
deltaSetFromPile :: Ord a => Pile (DeltaSet1 a) -> DeltaSet a
deltaSetFromPile :: Pile (DeltaSet1 a) -> DeltaSet a
deltaSetFromPile = [DeltaSet1 a] -> DeltaSet a
forall a. Ord a => [DeltaSet1 a] -> DeltaSet a
Delta.deltaSetFromList ([DeltaSet1 a] -> DeltaSet a)
-> (Pile (DeltaSet1 a) -> [DeltaSet1 a])
-> Pile (DeltaSet1 a)
-> DeltaSet a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pile (DeltaSet1 a) -> [DeltaSet1 a]
forall a. Pile a -> [a]
getPile

-- | Map a 'DeltaList' to a 'Pile' of indexed single element concatenations.
-- Higher indices are prepended later.
deltaListToPile :: DeltaList a -> Pile (Int, a)
deltaListToPile :: DeltaList a -> Pile (Int, a)
deltaListToPile (Append [a]
xs) = [(Int, a)] -> Pile (Int, a)
forall a. [a] -> Pile a
Pile ([(Int, a)] -> Pile (Int, a)) -> [(Int, a)] -> Pile (Int, a)
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)

-- | Restore a 'DeltaList' from a 'Pile'.
--
-- > deltaListFromPile . deltaListToPile = id
deltaListFromPile :: Pile (Int, a) -> DeltaList a
deltaListFromPile :: Pile (Int, a) -> DeltaList a
deltaListFromPile = [a] -> DeltaList a
forall a. [a] -> DeltaList a
Append ([a] -> DeltaList a)
-> (Pile (Int, a) -> [a]) -> Pile (Int, a) -> DeltaList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd ([(Int, a)] -> [a])
-> (Pile (Int, a) -> [(Int, a)]) -> Pile (Int, a) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> Down Int) -> [(Int, a)] -> [(Int, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> ((Int, a) -> Int) -> (Int, a) -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> Int
forall a b. (a, b) -> a
fst) ([(Int, a)] -> [(Int, a)])
-> (Pile (Int, a) -> [(Int, a)]) -> Pile (Int, a) -> [(Int, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pile (Int, a) -> [(Int, a)]
forall a. Pile a -> [a]
getPile

{-------------------------------------------------------------------------------
    Supply
-------------------------------------------------------------------------------}
-- | A supply of unique IDs.
newtype Supply = Supply
    { Supply -> Int
now  :: Int -- ^ Largest unique ID that is *in use*.
    }

instance Show Supply where
    showsPrec :: Int -> Supply -> ShowS
showsPrec Int
d (Supply{Int
now :: Int
now :: Supply -> Int
now}) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"Supply {now = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
now ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"} "
      where app_prec :: Int
app_prec = Int
10

-- | Fresh supply of unique IDs.
abundance :: Supply
abundance :: Supply
abundance = Supply :: Int -> Supply
Supply{ now :: Int
now = Int
0 }

-- | Retrieve a fresh unique ID.
fresh :: Supply -> (Int, Supply)
fresh :: Supply -> (Int, Supply)
fresh supply :: Supply
supply@Supply{now :: Supply -> Int
now=Int
old} = Int
new Int -> (Int, Supply) -> (Int, Supply)
`seq` (Int
new, Supply
supply{now :: Int
now=Int
new})
  where new :: Int
new = Int -> Int
forall a. Enum a => a -> a
succ Int
old -- smallest unused unique ID

-- | Remove a list of unique IDs from the 'Supply' if necessary.
consume :: [Int] -> Supply -> Supply
consume :: [Int] -> Supply -> Supply
consume [Int]
xs supply :: Supply
supply@Supply{now :: Supply -> Int
now=Int
old} = Int
new Int -> Supply -> Supply
`seq` Supply
supply{now :: Int
now=Int
new}
  where new :: Int
new = Int
old Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
xs