implementation module GenUpdate import StdString, StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, StdMaybe, StdGeneric, StdEnum import Void, Either import Text import JSON import Types from StdFunc import id derive bimap (,) defaultValue :: !*World -> (!a,!*World) | gUpdate{|*|} a defaultValue world # (a,ust=:{world}) = gUpdate{|*|} (abort "gUpdate accessed value during create") {USt|mode = UDCreate, searchPath = [], currentPath = [], consPath = [], update = "", mask = [], listMask = [], world = world} = (a,world) defaultMask :: a !*World -> (DataMask,*World) | gUpdate{|*|} a defaultMask a world # (_,ust=:{world,mask}) = gUpdate{|*|} a {USt| mode = UDMask, searchPath = [], currentPath = [0], consPath = [], update = "", mask = [], listMask = [], world = world} = (mask,world) updateValue :: String String a !*World -> (a,!*World) | gUpdate{|*|} a updateValue path update a world # (a,_,_,world) = updateValueAndMask path update a [] [] world = (a,world) updateValueAndMask :: String String a DataMask ListMask !*World -> (a,DataMask,ListMask,!*World) | gUpdate{|*|} a updateValueAndMask path update a mask listMask world //Only try to update when the 'path' string is a datapath formatted string | isdps path # (a,ust=:{world,mask,listMask}) = gUpdate{|*|} a {USt| mode = UDSearch, searchPath = s2dp path, currentPath = [0], consPath = [], update = update, mask = mask, listMask = listMask, world = world} = (a,mask,listMask,world) | otherwise = (a,mask,listMask,world) //Generic updater generic gUpdate a :: a *USt -> (a, *USt) gUpdate{|UNIT|} _ ust=:{mode=UDCreate} = (UNIT, ust) gUpdate{|UNIT|} u ust = (u, ust) gUpdate{|PAIR|} fx fy _ ust=:{mode=UDCreate} # (nx,ust) = fx (abort "PAIR create with undef") ust # (ny,ust) = fy (abort "PAIR create with undef") ust = (PAIR nx ny, ust) gUpdate{|PAIR|} fx fy p ust=:{mode=UDSearch} # (nx,ust) = fx x ust # (ny,ust) = fy y ust = (PAIR nx ny, ust) where (PAIR x y) = p gUpdate{|PAIR|} fx fy p ust=:{mode=UDMask} # (nx,ust) = fx x ust # (ny,ust) = fy y ust = (PAIR nx ny, ust) where (PAIR x y) = p gUpdate{|PAIR|} fx fy p ust = (p, ust) gUpdate{|EITHER|} fx fy _ ust=:{mode=UDCreate,consPath} = case consPath of [ConsLeft:cl] # (nx,ust) = fx (abort "EITHER create with undef") {ust & consPath = cl} = (LEFT nx, ust) [ConsRight:cl] # (ny,ust) = fy (abort "EITHER create with undef") {ust & consPath = cl} = (RIGHT ny, ust) [] # (nx,ust) = fx (abort "EITHER create with undef") ust = (LEFT nx, ust) gUpdate{|EITHER|} fx fy e ust=:{mode=UDSearch} = case e of (LEFT x) # (nx,ust) = fx x ust = (LEFT nx, ust) (RIGHT y) # (ny,ust) = fy y ust = (RIGHT ny,ust) gUpdate{|EITHER|} fx fy e ust=:{mode=UDMask} = case e of (LEFT x) # (nx,ust) = fx x ust = (LEFT nx, ust) (RIGHT y) # (ny,ust) = fy y ust = (RIGHT ny,ust) gUpdate{|EITHER|} fx fy e ust = (e, ust) gUpdate{|CONS|} fx _ ust=:{mode=UDCreate} # (nx,ust) = fx (abort "CONS create with undef") ust = (CONS nx, ust) gUpdate{|CONS|} fx c ust=:{mode=UDSearch} # (nx,ust) = fx x ust = (CONS nx, ust) where (CONS x) = c gUpdate{|CONS|} fx c ust=:{mode=UDMask} # (nx,ust) = fx x ust = (CONS nx, ust) where (CONS x) = c gUpdate{|CONS|} fx c ust = (c, ust) gUpdate{|OBJECT|} fx _ ust=:{mode=UDCreate} # (nx,ust) = fx (abort "OBJECT create with undef") ust = (OBJECT nx, ust) gUpdate{|OBJECT of d|} fx o ust=:{mode=UDSearch,searchPath,currentPath,update} | currentPath == searchPath # (nx,ust) = fx (abort "OBJECT create with undef") {USt|ust & mode = UDCreate, consPath = path} = (OBJECT nx, toggleMask {USt|ust & mode = UDDone}) | otherwise # (nx,ust) = fx x {USt|ust & currentPath = shiftDataPath currentPath} = (OBJECT nx, {USt|ust & currentPath = stepDataPath currentPath}) where (OBJECT x) = o path = case [cons \\ cons <- d.gtd_conses | cons.gcd_name == update] of [cons] = getConsPath cons _ = [] gUpdate{|OBJECT of d|} fx o ust=:{mode=UDMask,currentPath,mask} # (_,ust) = fx x {USt|ust & currentPath = shiftDataPath currentPath, mask = [currentPath:mask]} = (o,{USt|ust & currentPath = stepDataPath currentPath}) where (OBJECT x) = o gUpdate{|OBJECT|} fx o ust = (o, ust) gUpdate{|FIELD|} fx _ ust=:{mode=UDCreate} # (nx,ust) = fx (abort "FIELD create with undef") ust = (FIELD nx, ust) gUpdate{|FIELD|} fx f ust=:{mode=UDSearch} # (nx,ust) = fx x ust = (FIELD nx, ust) where (FIELD x) = f gUpdate{|FIELD|} fx f ust=:{mode=UDMask} # (nx,ust) = fx x ust = (FIELD nx, ust) where (FIELD x) = f gUpdate{|FIELD|} fx f ust = (f, ust) gUpdate{|Int|} _ ust=:{USt|mode=UDCreate} = (0,ust) gUpdate{|Int|} i ust=:{USt|mode=UDSearch,searchPath,currentPath,update} | currentPath == searchPath = (toInt update, toggleMask {USt|ust & mode = UDDone}) | otherwise = (i, {USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|Int|} i ust=:{USt|mode=UDMask,currentPath,mask} = (i, {USt|ust & currentPath = stepDataPath currentPath, mask = [currentPath:mask]}) gUpdate{|Int|} i ust = (i,ust) gUpdate{|Real|} _ ust=:{USt|mode=UDCreate} = (0.0, ust) gUpdate{|Real|} r ust=:{USt|mode=UDSearch,searchPath,currentPath,update} | currentPath == searchPath = (toReal update, toggleMask {USt|ust & mode = UDDone}) | otherwise = (r, {USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|Real|} r ust=:{USt|mode=UDMask,currentPath,mask} = (r, {USt|ust & currentPath = stepDataPath currentPath, mask = [currentPath:mask]}) gUpdate{|Real|} r ust = (r, ust) gUpdate{|Char|} _ ust=:{USt|mode=UDCreate} = (' ', ust) gUpdate{|Char|} c ust=:{USt|mode=UDSearch,searchPath,currentPath,update} | currentPath == searchPath = (if (size update > 0) update.[0] c, toggleMask {USt|ust & mode = UDDone}) | otherwise = (c, {USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|Char|} c ust=:{USt|mode=UDMask,currentPath,mask} = (c, {USt|ust & currentPath = stepDataPath currentPath, mask = [currentPath:mask]}) gUpdate{|Char|} c ust = (c, ust) gUpdate{|Bool|} _ ust=:{USt|mode=UDCreate} = (False, ust) gUpdate{|Bool|} b ust=:{USt|mode=UDSearch,searchPath,currentPath,update} | currentPath == searchPath = (update == "true", toggleMask {USt|ust & mode = UDDone}) | otherwise = (b, {USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|Bool|} b ust=:{USt|mode=UDMask,currentPath,mask} = (b, {USt|ust & currentPath = stepDataPath currentPath, mask = [currentPath:mask]}) gUpdate{|Bool|} b ust = (b, ust) gUpdate{|String|} _ ust=:{USt|mode=UDCreate} = ("", ust) gUpdate{|String|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update} | currentPath == searchPath = (update, toggleMask {USt|ust & mode = UDDone}) | otherwise = (s, {USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|String|} s ust=:{USt|mode=UDMask,currentPath,mask} = (s, {USt|ust & currentPath = stepDataPath currentPath, mask = [currentPath:mask]}) gUpdate{|String|} s ust = (s, ust) //Specialize instance for Dynamic gUpdate{|Dynamic|} _ ust=:{USt|mode=UDCreate} = (dynamic 42, ust) gUpdate{|Dynamic|} d ust = (d, ust) gUpdate{|[]|} fx _ ust=:{USt|mode=UDCreate} = ([], ust) gUpdate{|[]|} fx l ust=:{USt|mode=UDSearch,searchPath,currentPath,update} # (lx,ust=:{mask,listMask}) = applyListUpdates fx l {USt|ust & currentPath = shiftDataPath currentPath} | currentPath == searchPath = case (update % (0,2)) of "mup" # index = toInt (last (split "_" update)) | index == 0 = (lx, {USt | ust & currentPath = stepDataPath currentPath, mode=UDDone}) | otherwise # upd = swapList lx index # nm = swapMask mask currentPath index # lmask = [(currentPath,[index-1,index])]++listMask = (upd, {USt | ust & currentPath = stepDataPath currentPath, mask = nm, listMask=lmask, mode=UDDone}) "mdn" # index = toInt (last(split "_" update)) | index >= (length lx)-1 = (lx, {USt | ust & currentPath = stepDataPath currentPath, mode=UDDone}) | otherwise # upd = swapList lx ((toInt index)+1) //down idx == up (idx+1) # nm = swapMask mask currentPath (index+1) # lmask = [(currentPath,[index,index+1])]++listMask = (upd, {USt | ust & currentPath = stepDataPath currentPath, mask=nm, listMask=lmask, mode=UDDone}) "rem" # index = toInt (last(split "_" update)) # upd = removeAt index lx # nm = (maskRemove mask currentPath index (length lx == (index+1))) # lmask = [(currentPath,[index..length upd-1])]++listMask = (upd, {USt | ust & currentPath = stepDataPath currentPath, mask=nm, listMask=lmask, mode=UDDone}) "add" # index = toInt (last (split "_" update)) # (nv,ust) = fx (abort "LIST create with undef") {USt | ust & mode=UDCreate} # upd = insertAt (index+1) nv lx # nm = moveMaskDown mask currentPath (index+1) # lmask = [(currentPath,[index+1..length upd-1])]++listMask = (upd, {USt | ust & currentPath = stepDataPath currentPath, mask=nm, listMask=lmask, mode=UDDone}) _ = (lx, {USt | ust & currentPath = stepDataPath currentPath, mode=UDDone}) | otherwise = (lx, {USt | ust & currentPath = stepDataPath currentPath}) where applyListUpdates fx [] ust = ([],ust) applyListUpdates fx [l:ls] ust # (lx,ust) = fx l ust # (lxs,ust) = applyListUpdates fx ls ust = ([lx:lxs],ust) swapList [] _ = [] swapList list index | index == 0 = list //prevent move first element up | index >= length list = list //prevent move last element down | otherwise # f = list !! (index-1) # l = list !! (index) = updateAt (index-1) l (updateAt index f list) swapMask mask path index = [ (swapMask` m path index) \\ m <- mask ] swapMask` m path index | tlEq m [index:path] = changeMask [index:path] (-) m | tlEq m [(index-1):path] = changeMask [(index-1):path] (+) m | otherwise = m maskRemove mask path index True = [m \\ m <- mask | not(tlEq m [index:path])] //last element, nothing to move up maskRemove mask path index False = moveMaskUp [m \\ m <- mask | not(tlEq m [index:path])] path (index+1) moveMaskUp mask path index = map (\m = if(tlGrEq m [index:path]) (changeMask [index:path] (-) m) (id m)) mask moveMaskDown mask path index = map (\m = if(tlGrEq m [index:path]) (changeMask [index:path] (+) m) (id m)) mask changeMask prefix fx datapath # (unchanged,changed) = splitAt((length datapath-length prefix)) datapath # id = hd changed # tl = tl prefix = unchanged ++ [(fx id 1)] ++ tl tlEq mask path = tlEq` (reverse mask) (reverse path) tlEq` _ [] = True tlEq` [] _ = False tlEq` [e:ex] [i:ix] = (i == e) && (tlEq` ex ix) tlGrEq mask path = tlGrEq` (reverse mask) (reverse path) tlGrEq` [] _ = False tlGrEq` [e:ex] [i] = (e>=i) tlGrEq` [e:ex] [i:ix] = (i==e) && (tlGrEq` ex ix) gUpdate{|[]|} fx l ust=:{USt|mode=UDMask,currentPath,mask} # ust = gMarkList fx l {USt|ust & mask = [currentPath:mask],currentPath = shiftDataPath currentPath} = (l,{USt | ust & currentPath = stepDataPath currentPath}) where gMarkList fx [] ust = ust gMarkList fx [x:xs] ust=:{USt|currentPath,mask} # (_,ust) = fx x ust = gMarkList fx xs ust gUpdate{|[]|} fx l ust = (l,ust) //Specialized instance Maybe that chooses the non-recursive constructor gUpdate{|Maybe|} fx _ ust=:{USt|mode=UDCreate} = (Nothing,ust) gUpdate{|Maybe|} fx m ust=:{USt|mode=UDSearch,currentPath,searchPath,update} | currentPath == searchPath && update == "" = (Nothing, toggleMask {USt|ust & mode = UDDone}) //Reset | otherwise = case m of Nothing # (x,ust) = fx (abort "Maybe create with undef") {ust & mode = UDCreate} //Create an empty value to update # (x,ust=:{mode,currentPath}) = fx x {ust & mode = UDSearch,currentPath = currentPath, searchPath = searchPath,update = update} = case mode of UDDone = (Just x,ust) //Only switch keep newly created value if a field was updated _ = (Nothing, ust) Just x # (x,ust) = fx x ust = (Just x,ust) gUpdate{|Maybe|} fx m ust=:{USt|mode=UDMask,currentPath,mask} = case m of Nothing = (m, {USt|ust & currentPath = stepDataPath currentPath}) Just x # (_,ust) = fx x ust = (m, {USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|Maybe|} fx l ust = (l,ust) // Document import StdDebug, GenPrint gUpdate {|Document|} _ ust =: {USt | mode=UDCreate} = ({ Document | fileName = "" , size = 0 , mimeType = "" , taskId = "" , index = 0 }, ust) gUpdate {|Document|} s ust =: {USt | mode=UDMask,currentPath,mask} = (s, {USt | ust & currentPath = stepDataPath currentPath, mask = [currentPath:mask]}) gUpdate {|Document|} s ust =: {USt | mode=UDSearch, searchPath, currentPath, update, mask} | currentPath == searchPath = case update of "clear" = (emptyDoc,{USt | ust & currentPath = stepDataPath currentPath}) _ # upd = fromJSON update | isJust upd = (fromJust upd,{USt | ust & currentPath = stepDataPath currentPath, mode=UDDone}) | otherwise = abort "[Upd Document] Cannot parse JSON" //| otherwise = ({ Document | fileName = "", size = 0, mimeType = "", taskId = "", index = 0},{USt | ust & currentPath = stepDataPath currentPath}) | otherwise = (s, {USt | ust & currentPath = stepDataPath currentPath}) gUpdate {|Document|} s ust = (s,ust) derive gUpdate Either, (,), (,,), (,,,), Void, Static, Hidden //Utility functions dp2s :: DataPath -> String dp2s path = join "-" (map toString (reverse path)) dp2id :: String DataPath -> String dp2id prefix path = prefix +++ "-" +++ dp2s path s2dp :: String -> DataPath s2dp path = reverse (map toInt (split "-" path)) isdps :: String -> Bool isdps path = and [c == '-' || isDigit c \\ c <-: path] stepDataPath :: DataPath -> DataPath stepDataPath [] = [] stepDataPath [x:xs] = [inc x:xs] shiftDataPath :: DataPath -> DataPath shiftDataPath path = [0:path] dataPathLevel :: DataPath -> Int dataPathLevel l = length l instance == DataPath where (==) a b = (length a == length b) && and (map (\(x,y) -> x == y) (zip (a,b))) //Force a field to be masked setMask :: *USt -> *USt setMask ust=:{currentPath,mask} # mask = if (isMember currentPath mask) mask [currentPath:mask] = {ust & mask = mask} //Masking and unmasking of fields toggleMask :: *USt -> *USt toggleMask ust=:{searchPath,currentPath,update,mask} | searchPath == currentPath | update == "" //Remove the current path from the mask = {ust & mask = filter (\x -> x <> currentPath) mask} | otherwise //Add the current path to the mask (if it is not already in it) # mask = if (isMember currentPath mask) mask [currentPath:mask] //Remove the underlying fields from the mask # mask = [m \\ m <- mask | not (childOf currentPath m)] = {ust & mask = mask} | otherwise = ust where //Check if a datapath is a child of another childOf parent child | clen > plen = take plen (reverse child) == reverse parent | otherwise = False where plen = length parent clen = length child isMasked :: DataPath DataMask -> Bool isMasked dp dm = isMember dp dm