implementation module GenUpdate import StdString, StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, Maybe, StdGeneric, StdEnum, Tuple import SystemTypes, Text, Util, DocumentDB from StdFunc import id, const, o from TUIDefinition import :: TUISize(..), :: TUIFixedSize, :: TUIWeight derive bimap (,), UpdateMode :: DataPath = DataPath [Int] defaultValue :: a | gUpdate{|*|} a defaultValue = fst (gUpdate{|*|} UDCreate {searchPath = emptyDataPath, currentPath = emptyDataPath, consPath = [], update = JSONNull, oldMask = [], newMask = [], iworld = Nothing}) defaultMask :: !a -> UpdateMask | gDefaultMask{|*|} a defaultMask a = hd (gDefaultMask{|*|} a) updateValueAndMask :: !DataPath !JSONNode !a !UpdateMask !*IWorld -> (!a,!UpdateMask,!*IWorld) | gUpdate{|*|} a updateValueAndMask path update a oldMask iworld # (a,ust=:{newMask,iworld}) = gUpdate{|*|} (UDSearch a) {searchPath = path, currentPath = startDataPath, consPath = [], update = update, oldMask = [oldMask], newMask = [], iworld = Just iworld} = (a,hd newMask,fromJust iworld) appIWorldUSt :: !.(*IWorld -> *IWorld)!*USt -> *USt appIWorldUSt f ust=:{iworld} = case iworld of Just iworld = {ust & iworld = Just (f iworld)} Nothing = abort "no IWorld in USt" accIWorldUSt :: !.(*IWorld -> *(!.a,!*IWorld))!*USt -> (!.a,!*USt) accIWorldUSt f ust=:{iworld} = case iworld of Just iworld # (a,iworld) = f iworld = (a,{ust & iworld = Just iworld}) Nothing = abort "no IWorld in USt" //Generic updater generic gUpdate a :: !(UpdateMode a) !*USt -> (!a,!*USt) gUpdate{|UNIT|} _ ust = (UNIT,ust) gUpdate{|OBJECT|} fx UDCreate ust=:{newMask} //Empty object mask # (nx,ust=:{newMask=objectMask}) = fx UDCreate {ust & newMask = []} = (OBJECT nx, {ust & newMask = newMask ++ objectMask}) gUpdate{|OBJECT of d|} fx (UDSearch (OBJECT x)) ust=:{searchPath,currentPath,update,oldMask,newMask} # (cm,om) = popMask oldMask | currentPath == searchPath //Update is a constructor switch # (nx,ust) = fx UDCreate {ust & consPath = path} = (OBJECT nx, {ust & oldMask = om, currentPath = stepDataPath currentPath, newMask = appendToMask newMask (toggleMask update)}) | searchPath <== currentPath //Update is targeted somewhere in a substructure of this value # (nx,ust=:{newMask=childMask}) = fx (UDSearch x) {ust & currentPath = shiftDataPath currentPath, oldMask = childMasks cm, newMask = []} = (OBJECT nx, {ust & currentPath = stepDataPath currentPath, oldMask = om, newMask = appendToMask newMask (Touched childMask)}) | otherwise //Not on the path, so just put back the current mask (cm) = (OBJECT x, {ust & currentPath = stepDataPath currentPath, oldMask = om, newMask = appendToMask newMask cm}) where path = case update of JSONInt consIdx | consIdx < length d.gtd_conses = getConsPath (d.gtd_conses !! consIdx) _ = [] gUpdate{|CONS|} fx UDCreate ust = appFst CONS (fx UDCreate ust) gUpdate{|CONS|} fx (UDSearch (CONS c)) ust = appFst CONS (fx (UDSearch c) ust) gUpdate{|FIELD|} fx UDCreate ust = appFst FIELD (fx UDCreate ust) gUpdate{|FIELD|} fx (UDSearch (FIELD c)) ust = appFst FIELD (fx (UDSearch c) ust) gUpdate{|PAIR|} fx fy UDCreate ust # (nx,ust) = fx UDCreate ust # (ny,ust) = fy UDCreate ust = (PAIR nx ny, ust) gUpdate{|PAIR|} fx fy (UDSearch (PAIR x y)) ust # (nx,ust) = fx (UDSearch x) ust # (ny,ust) = fy (UDSearch y) ust = (PAIR nx ny, ust) gUpdate{|EITHER|} fx fy UDCreate ust=:{consPath} = case consPath of [ConsLeft:cl] # (nx,ust) = fx UDCreate {ust & consPath = cl} = (LEFT nx, ust) [ConsRight:cl] # (ny,ust) = fy UDCreate {ust & consPath = cl} = (RIGHT ny, ust) [] # (nx,ust) = fx UDCreate ust = (LEFT nx, ust) gUpdate{|EITHER|} fx fy (UDSearch e) ust = case e of LEFT x # (nx,ust) = fx (UDSearch x) ust = (LEFT nx, ust) RIGHT y # (ny,ust) = fy (UDSearch y) ust = (RIGHT ny,ust) gUpdate{|Maybe|} _ UDCreate ust=:{newMask} //Specialized instance Maybe that chooses the non-recursive constructor = (Nothing,{ust & newMask = appendToMask newMask Untouched}) gUpdate{|Maybe|} fx (UDSearch m) ust=:{currentPath,searchPath,update,oldMask,newMask} # (cm,om) = popMask oldMask | currentPath == searchPath && (update === JSONNull || update === JSONBool False) = (Nothing, {ust & currentPath = stepDataPath currentPath, newMask = appendToMask newMask Blanked, oldMask = om}) //Reset | otherwise = case m of Nothing | searchPath <== currentPath // Create a default value # (x,ust=:{newMask=nmCreate}) = fx UDCreate ust // Search in the default value # (x,ust=:{newMask=nmSearch}) = fx (UDSearch x) {ust & currentPath = currentPath, searchPath = searchPath, update = update, oldMask = oldMask, newMask = newMask} = (Just x, ust) | otherwise = (Nothing, {ust & currentPath = stepDataPath currentPath, newMask = appendToMask newMask cm, oldMask = om}) Just x # (x,ust) = fx (UDSearch x) ust //all mask transformations are made here.. = (Just x,ust) gUpdate{|[]|} _ UDCreate ust = basicCreate [] ust gUpdate{|[]|} fx (UDSearch l) ust=:{searchPath,currentPath,update,oldMask,newMask} # (cm,om) = popMask oldMask # (l,listMask,ust) = case isNew currentPath searchPath (length l) of True # (nv,ust) = fx UDCreate {ust & oldMask = [], newMask = []} = (l++[nv], Touched [], ust) False = (l,cm,ust) # (lx,ust=:{newMask=cMasks}) = updateElements fx l {ust & currentPath = shiftDataPath currentPath, oldMask = childMasks cm, newMask = []} # ust = {ust & newMask = cMasks} | currentPath == searchPath //Process the reordering commands # split = split "_" (fromMaybe "" (fromJSON update)) # index = toInt (last split) # (lx,cMasks,ust) = case hd split of "mup" = (swap lx index,swap cMasks index,ust) "mdn" = (swap lx (index+1),swap cMasks (index+1),ust) "rem" = (removeAt index lx,removeAt index cMasks,ust) "add" # (nv,ust=:{newMask=childMask}) = fx UDCreate {ust & oldMask = [], newMask = []} = (insertAt (index+1) nv lx,insertAt (index+1) (hd childMask) cMasks,{ust & newMask = childMask}) _ = (lx,cMasks,ust) = (lx,{ust & currentPath = stepDataPath currentPath, newMask = appendToMask newMask (Touched cMasks), oldMask = om}) | otherwise # listMask = case listMask of Touched _ = Touched cMasks mask = mask = (lx, {ust & currentPath = stepDataPath currentPath, newMask = appendToMask newMask listMask, oldMask = om}) where //Check if search path is equal or below [datapath:(length list)] isNew cp sp l = sp <== dataPathFromList [l:dataPathList cp] updateElements fx [] ust = ([],ust) updateElements fx [l:ls] ust # (lx,ust) = fx (UDSearch l) ust # (lxs,ust) = updateElements fx ls ust = ([lx:lxs],ust) swap [] _ = [] swap 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) gUpdate{|Display|} fx mode ust = wrapperUpdate fx mode fromDisplay Display ust gUpdate{|Editable|} fx mode ust = wrapperUpdate fx mode fromEditable Editable ust gUpdate{|Hidden|} fx mode ust = wrapperUpdate fx mode fromHidden Hidden ust gUpdate{|VisualizationHint|} fx UDCreate ust = wrapperUpdate fx UDCreate undef VHEditable ust gUpdate{|VisualizationHint|} fx mode=:(UDSearch (VHEditable s)) ust = wrapperUpdate fx mode fromVisualizationHint VHEditable ust gUpdate{|VisualizationHint|} fx mode=:(UDSearch (VHDisplay s)) ust = wrapperUpdate fx mode fromVisualizationHint VHDisplay ust gUpdate{|VisualizationHint|} fx mode=:(UDSearch (VHHidden s)) ust = wrapperUpdate fx mode fromVisualizationHint VHHidden ust gUpdate{|ControlSize|} fx UDCreate ust = wrapperUpdate fx UDCreate undef (ControlSize Nothing Nothing Nothing) ust gUpdate{|ControlSize|} fx mode=:(UDSearch (ControlSize w h m _)) ust = wrapperUpdate fx mode fromControlSize (ControlSize w h m) ust gUpdate{|FillControlSize|} fx mode ust = wrapperUpdate fx mode fromFillControlSize FillControlSize ust gUpdate{|FillWControlSize|} fx mode ust = wrapperUpdate fx mode fromFillWControlSize FillWControlSize ust gUpdate{|FillHControlSize|} fx mode ust = wrapperUpdate fx mode fromFillHControlSize FillHControlSize ust wrapperUpdate fx mode get cons ust=:{USt|currentPath} = case mode of UDCreate = appFst cons (fx UDCreate ust) UDSearch w # (w,ust) = fx (UDSearch (get w)) ust = (cons w,{USt|ust & currentPath = stepDataPath currentPath}) gUpdate{|Int|} mode ust = basicUpdateSimple mode 0 ust gUpdate{|Real|} mode ust = basicUpdateSimple mode 0.0 ust gUpdate{|Char|} mode ust = basicUpdateSimple mode ' ' ust gUpdate{|Bool|} mode ust = basicUpdateSimple mode False ust gUpdate{|String|} mode ust = basicUpdateSimple mode "" ust gUpdate{|Note|} mode ust = basicUpdateSimple mode (Note "") ust gUpdate{|Password|} mode ust = basicUpdateSimple mode (Password "") ust gUpdate{|User|} mode ust = basicUpdateSimple mode AnyUser ust gUpdate{|HtmlDisplay|} mode ust = basicUpdate mode unchanged (HtmlDisplay "") ust gUpdate{|HtmlInclude|} mode ust = basicUpdateSimple mode (HtmlInclude "") ust gUpdate{|FormButton|} mode ust = basicUpdate mode (\st b -> {b & state = st}) {FormButton | label = "Form Button", icon="", state = NotPressed} ust gUpdate{|Table|} mode ust = basicUpdate mode (\json (Table headers cells _) -> case fromJSON json of Just i = Table headers cells (Just i); _ = Table headers cells Nothing) (Table [] [] Nothing) ust gUpdate{|TreeChoice|} _ _ mode ust = basicUpdate mode (\json (TreeChoice tree _) -> case fromJSON json of Just i = TreeChoice tree i; _ = TreeChoice tree Nothing) (TreeChoice (Tree []) Nothing) ust gUpdate{|RadioChoice|} _ _ mode ust = basicUpdate mode (\json (RadioChoice opts _) -> case fromJSON json of Just i = RadioChoice opts (Just i); _ = RadioChoice opts Nothing) (RadioChoice [] Nothing) ust gUpdate{|ComboChoice|} _ _ mode ust = basicUpdate mode (\l (ComboChoice opts _) -> case l of i = ComboChoice opts (Just i); _ = ComboChoice opts Nothing) (ComboChoice [] Nothing) ust gUpdate{|CheckMultiChoice|} _ _ mode ust = basicUpdate mode (\json (CheckMultiChoice opts sel) -> case fromJSON json of Just (i,v) = CheckMultiChoice opts (updateSel i v sel); _ = CheckMultiChoice opts sel) (CheckMultiChoice [] []) ust where updateSel i True sel = removeDup [i:sel] updateSel i False sel = removeMember i sel gUpdate{|Currency|} mode ust = basicUpdate mode parseUpdate (EUR 0) ust where parseUpdate update orig = case split "." update of [whole] = replaceVal orig (100 * toInt whole) [whole,dec] = replaceVal orig (100 * toInt whole + (if (size dec == 1) (10 * toInt dec) (toInt (dec % (0,1))))) _ = orig replaceVal (EUR _) x = (EUR x) replaceVal (GBP _) x = (GBP x) replaceVal (USD _) x = (USD x) replaceVal (JPY _) x = (JPY x) gUpdate{|Date|} UDCreate ust = basicCreate {day = 1, mon = 1, year = 1970} ust gUpdate{|Date|} (UDSearch d) ust = basicSearch d (\json old -> fromMaybe old (fromJSON json)) ust gUpdate{|Time|} UDCreate ust = basicCreate {hour = 0, min = 0, sec = 0} ust gUpdate{|Time|} (UDSearch t) ust = basicSearch t (\json old -> fromMaybe old (fromJSON json)) ust gUpdate{|Dynamic|} mode ust = basicUpdate mode unchanged (dynamic 42) ust gUpdate{|(->)|} _ fy mode ust # (def,ust) = fy UDCreate ust = basicUpdate mode unchanged (const def) ust gUpdate {|Document|} UDCreate ust = basicCreate {Document|documentId = "", name="", mime="", size = 0} ust gUpdate {|Document|} (UDSearch s) ust=:{searchPath, currentPath, update, oldMask, newMask} # (cm,om) = popMask oldMask # ust = {ust & currentPath = stepDataPath currentPath, oldMask = om} | currentPath == searchPath = case fromJSON update of Nothing // Reset = ({Document|documentId = "", name="", mime="", size = 0},{ust & newMask = appendToMask newMask Blanked}) Just docId // Look up meta-data in the store and update the document # (mbDocument,ust) = getDocument docId ust # ust = {ust & newMask = appendToMask newMask (Touched [])} = (fromMaybe s mbDocument,ust) | otherwise = (s, {ust & newMask = appendToMask newMask cm}) derive gUpdate Either, (,), (,,), (,,,), Void, DateTime, UserDetails, Timestamp, Map, EmailAddress, Action, TreeNode, ManagerProperties, RunningTaskStatus, TaskPriority, Session, Tree basicUpdateSimple :: !(UpdateMode a) a !*USt -> *(!a,!*USt) | JSONDecode{|*|} a basicUpdateSimple mode def ust = case mode of UDCreate = basicCreate def ust UDSearch v = basicSearch v (\json old -> fromMaybe old (fromJSON json)) ust basicUpdate :: !(UpdateMode a) (upd a -> a) a !*USt -> *(!a,!*USt) | JSONDecode{|*|} upd basicUpdate mode toV def ust = case mode of UDCreate = basicCreate def ust UDSearch v = basicSearch v toV ust basicCreate :: !a !*USt -> *(!a,!*USt) basicCreate def ust=:{newMask} = (def,{ust & newMask = appendToMask newMask Untouched}) basicSearch :: !a !(upd a -> a) !*USt -> *(!a,!*USt) | JSONDecode{|*|} upd basicSearch v toV ust=:{searchPath,currentPath,update,oldMask,newMask} # (cm, om) = popMask oldMask # ust = {ust & currentPath = stepDataPath currentPath, oldMask = om} | currentPath == searchPath = (fromMaybe v (fmap (\u -> toV u v) (fromJSON update)), {ust & newMask = appendToMask newMask (toggleMask update)}) | otherwise = (v, {ust & newMask = appendToMask newMask cm}) generic gDefaultMask a :: !a -> [UpdateMask] gDefaultMask{|UNIT|} _ = [] gDefaultMask{|OBJECT|} fx (OBJECT x) = [Touched (fx x)] gDefaultMask{|CONS|} fx (CONS x) = fx x gDefaultMask{|FIELD|} fx (FIELD x) = fx x gDefaultMask{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y gDefaultMask{|EITHER|} fx fy e = case e of (LEFT x) = fx x (RIGHT y) = fy y gDefaultMask{|Maybe|} fx mbVal = maybe [Untouched] fx mbVal gDefaultMask{|[]|} _ [] = [Untouched] gDefaultMask{|[]|} fx l = [Touched (map (hd o fx) l)] gDefaultMask {|Display|} fx (Display d) = fx d gDefaultMask {|Editable|} fx (Editable e) = fx e gDefaultMask {|Hidden|} fx (Hidden h) = fx h gDefaultMask {|VisualizationHint|} fx (VHEditable e) = fx e gDefaultMask {|VisualizationHint|} fx (VHDisplay d) = fx d gDefaultMask {|VisualizationHint|} fx (VHHidden h) = fx h gDefaultMask {|ControlSize|} fx (ControlSize _ _ _ v) = fx v gDefaultMask {|FillControlSize|} fx (FillControlSize v) = fx v gDefaultMask {|FillWControlSize|} fx (FillWControlSize v) = fx v gDefaultMask {|FillHControlSize|} fx (FillHControlSize v) = fx v gDefaultMask{|Int|} _ = [Touched []] gDefaultMask{|Real|} _ = [Touched []] gDefaultMask{|Char|} _ = [Touched []] gDefaultMask{|Bool|} _ = [Touched []] gDefaultMask{|String|} _ = [Touched []] gDefaultMask{|Dynamic|} _ = [Touched []] gDefaultMask{|(->)|} _ _ _ = [Touched []] gDefaultMask{|Document|} _ = [Touched []] gDefaultMask{|FormButton|} _ = [Touched []] gDefaultMask{|Note|} _ = [Touched []] gDefaultMask{|Password|} _ = [Touched []] gDefaultMask{|Currency|} _ = [Touched []] gDefaultMask{|Date|} _ = [Touched []] gDefaultMask{|Time|} _ = [Touched []] gDefaultMask{|User|} _ = [Touched []] gDefaultMask{|HtmlDisplay|} _ = [Touched []] gDefaultMask{|HtmlInclude|} _ = [Touched []] gDefaultMask{|CheckMultiChoice|}_ _ _ = [Touched []] gDefaultMask{|RadioChoice|} _ _ (RadioChoice opts mbSel) // if no valid selection is made, start with untouched mask | isJust mbSel && fromJust mbSel < length opts = [Touched []] | otherwise = [Untouched] gDefaultMask{|ComboChoice|} _ _ (ComboChoice opts mbSel) // if no valid selection is made, start with untouched mask | isJust mbSel && fromJust mbSel < length opts = [Touched []] | otherwise = [Untouched] gDefaultMask{|Table|} _ = [Touched []] gDefaultMask{|TreeChoice|} _ _ tree=:(TreeChoice _ mbSel) // if no valid selection is made, start with untouched mask | isJust mbSel = [Touched []] | otherwise = [Untouched] derive gDefaultMask Either, (,), (,,), (,,,), Void, DateTime, UserDetails, Timestamp, Map, EmailAddress, Action, TreeNode, ManagerProperties, RunningTaskStatus, TaskPriority, Session, Tree //Utility functions dp2s :: !DataPath -> String dp2s (DataPath path) = join "-" (map toString (reverse path)) s2dp :: !String -> DataPath s2dp str = DataPath (reverse (map toInt (split "-" str))) isdps :: !String -> Bool isdps path = and [c == '-' || isDigit c || c == '_' \\ c <-: path] startDataPath :: DataPath startDataPath = DataPath [0] emptyDataPath :: DataPath emptyDataPath = DataPath [] stepDataPath :: !DataPath -> DataPath stepDataPath dp=:(DataPath []) = dp stepDataPath (DataPath [x:xs]) = DataPath [inc x:xs] shiftDataPath :: !DataPath -> DataPath shiftDataPath (DataPath path) = DataPath [0:path] childDataPath :: !DataPath !Int -> DataPath childDataPath (DataPath path) i = DataPath [i:path] parentDataPath :: !DataPath -> (!DataPath,!Int) parentDataPath (DataPath []) = (DataPath [], -1) parentDataPath (DataPath [i:path]) = (DataPath path, i) dataPathLevel :: !DataPath -> Int dataPathLevel (DataPath l) = length l instance == DataPath where (==) (DataPath a) (DataPath b) = a == b dataPathList :: !DataPath -> [Int] dataPathList (DataPath list) = list dataPathFromList :: ![Int] -> DataPath dataPathFromList l = DataPath l // detect whether two paths are equal or if path A is a sub-path of B, assuming reverse-notation. // e.g. [1,0] <== [0] (<==) infixr 1 :: !DataPath !DataPath -> Bool (<==) (DataPath pathA) (DataPath pathB) = tlEq (reverse pathA) (reverse pathB) where tlEq _ [] = True tlEq [] _ = False tlEq [a:as] [b:bs] = (a == b) && (tlEq as bs) //Masking and unmasking of fields toggleMask :: !JSONNode -> UpdateMask toggleMask update = case update of JSONNull = Blanked _ = Touched [] unchanged :: !Void !a -> a unchanged _ v = v instance GenMask UpdateMask where popMask :: ![UpdateMask] -> (!UpdateMask, ![UpdateMask]) popMask [] = (Untouched, []) popMask [c:cm] = (c,cm) appendToMask :: ![UpdateMask] !UpdateMask -> [UpdateMask] appendToMask l m = l ++ [m] childMasks :: !UpdateMask -> [UpdateMask] childMasks (Untouched) = [] childMasks (Touched cm) = cm childMasks (Blanked) = [] isTouched :: !UpdateMask -> Bool isTouched (Touched _) = True isTouched _ = False allUntouched :: ![UpdateMask] -> Bool allUntouched children = and [isUntouched c \\ c <- children] where isUntouched Untouched = True isUntouched _ = False allBlanked :: ![UpdateMask] -> Bool allBlanked children = and [isBlanked c \\ c <- children] where isBlanked Blanked = True isBlanked _ = False