implementation module StoreTasks import TSt, Store import StdList, StdOrdList from StdFunc import id, const from SystemTasks import getDefaultValue import CoreCombinators import GenPrint, GenParse, GenVisualize, GenUpdate derive gVisualize DBRef derive gUpdate DBRef derive gPrint DBRef derive gParse DBRef derive bimap Maybe, (,) ::DBid a :== String // Core db access readDB :: !(DBid a) -> Task a | iTask a readDB key = mkInstantTask "readDB" readDB` where readDB` tst=:{TSt|dataStore,world} # (mbVal,dstore,world) = loadValue key dataStore world = case mbVal of Just val = (TaskFinished val,{TSt|tst & dataStore = dstore, world = world}) Nothing # (val,world) = defaultValue world = (TaskFinished val,{TSt|tst & dataStore = dstore, world = world}) writeDB :: !(DBid a) !a -> Task a | iTask a writeDB key value = mkInstantTask "writeDB" writeDB` where writeDB` tst=:{TSt|dataStore} # dstore = storeValue key value dataStore = (TaskFinished value, {TSt| tst & dataStore = dstore}) mkDBid :: !String -> (DBid a) mkDBid s = s // Convenient operations on databases :: DBRef a = DBRef Int instance == (DBRef a) where (==) (DBRef x) (DBRef y) = x == y instance < (DBRef a) where (<) (DBRef x) (DBRef y) = x < y eqItemId :: a a -> Bool | DB a eqItemId a b = getItemId a == getItemId b dbReadAll :: Task [a] | iTask, DB a dbReadAll = readDB databaseId dbWriteAll :: ![a] -> Task Void | iTask, DB a dbWriteAll all = writeDB databaseId all >>| return Void dbModify :: ([a] -> [a]) -> Task Void | iTask, DB a dbModify f = dbReadAll >>= \items -> dbWriteAll (f items) // C(reate)R(ead)U(pdate)D(elete) operations: dbCreateItem :: Task a | iTask, DB a dbCreateItem = readDB databaseId >>= \items -> let newid = newDBRef items in getDefaultValue >>= \newval -> return (setItemId newid newval) where newDBRef :: [a] -> DBRef a | DB a newDBRef [] = DBRef 1 newDBRef items = let (DBRef i) = maxList (map getItemId items) in DBRef (i+1) dbReadItem :: !(DBRef a) -> Task (Maybe a) | iTask, DB a dbReadItem itemid = readDB databaseId >>= \items -> case filter (\item -> itemid == getItemId item) items of [found:_] = return (Just found) nothing = return Nothing dbUpdateItem :: a -> Task a | iTask, DB a dbUpdateItem new = dbModify (replace eqItemId new) >>| return new dbDeleteItem :: !(DBRef a) -> Task Void | iTask, DB a dbDeleteItem itemid = dbModify (filter (\item -> itemid <> getItemId item)) //List utility function replace :: (a a -> Bool) a [a] -> [a] replace cond new [] = [new] replace cond new [x:xs] | cond new x = [new : xs] | otherwise = [x : replace cond new xs]