Commit c6c5c885 authored by Bas Lijnse's avatar Bas Lijnse

Reorganized the Generic libraries further

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@2574 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent e1d8a401
......@@ -12,12 +12,9 @@ import iTasks.Framework.Engine // iTasks engine
, iTasks.API
// Miscellaneous machinery
, Text.JSON // Functions for serializing/deserializing strings
, Text.JSON // JSON is used for serializing/deserializing strings
, iTasks.Framework.Generic // Generic foundation modules
, iTasks.Framework.Shared // Shared data sources
, iTasks.Framework.GenVisualize // Functions for generating GUIs
, iTasks.Framework.GenUpdate // Functions for updating arbitrary values
, iTasks.Framework.GenVerify // Functions for appending errors and hints to form values
, iTasks.Framework.GenRecord // Functions for manipulating records
, iTasks.Framework.GenSpecialize // Functions for custom specializations
// API extensions for user & workflow management
......
implementation module iTasks
import Text.JSON
import iTasks.Framework.GenUpdate
import iTasks.Framework.GenVisualize
import iTasks.Framework.GenVerify
......@@ -4,7 +4,7 @@ implementation module iTasks.API.Common.CommonCombinators
*/
import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdClass
import Text, System.Time, Data.Tuple, Data.List, Data.Either, Data.Functor
import iTasks.Framework.Util, iTasks.Framework.GenVisualize, iTasks.Framework.GenUpdate, iTasks.Framework.GenRecord
import iTasks.Framework.Util
from StdFunc import id, const, o
from iTasks.API.Core.SystemTypes import :: User(..), :: Note(..)
from iTasks.Framework.TaskState import :: TaskTree(..), :: DeferredJSON
......@@ -93,7 +93,6 @@ where
, lastWorkedOn :: !Maybe DateTime
}
derive class iTask ProcessControlView
derive class GenRecord ProcessControlView, UserConstraint, ManagementMeta, TaskPriority
(@:) infix 3 :: !worker !(Task a) -> Task a | iTask a & toUserConstraint worker
(@:) worker task = assign {defaultValue & worker = toUserConstraint worker} task
......
definition module iTasks.API.Common.DBTasks
import iTasks.Framework.iTaskClass, iTasks.Framework.Task, iTasks.Framework.Shared
import iTasks.Framework.Generic, iTasks.Framework.Task, iTasks.Framework.Shared
//Convenience wrapper functions for databases with multiple values of type a
class DB a where
......
implementation module iTasks.API.Common.DBTasks
import StdList, StdOrdList, Data.List
import iTasks.Framework.iTaskClass, iTasks.Framework.Task, iTasks.Framework.Shared
import iTasks.Framework.Generic, iTasks.Framework.Task, iTasks.Framework.Shared
import iTasks.Framework.Util
from iTasks.API.Core.CoreTasks import get, set, return
from iTasks.API.Common.CommonCombinators import >>|, >>=
......
definition module iTasks.API.Common.InteractionTasks
import iTasks.API.Core.CoreTasks
from iTasks.API.Core.SystemTypes import :: Tree, :: Date, :: Time, :: Action
from Data.Functor import class Functor
//Option types for customizing interaction
:: ViewOption a = E.v: ViewWith (a -> v) & iTask v
......
......@@ -10,6 +10,7 @@ from Data.Map import qualified get, put
import StdBool, StdList, StdMisc, StdTuple, Data.Functor
import iTasks.API.Core.CoreTasks, iTasks.API.Core.OptimizedCoreTasks, iTasks.API.Core.CoreCombinators
import iTasks.API.Common.CommonCombinators, iTasks.API.Core.LayoutCombinators, iTasks.API.Core.SystemData
import iTasks.Framework.Generic.Interaction
enterInformation :: !d ![EnterOption m] -> Task m | descr d & iTask m
enterInformation d [EnterWith fromf]
......
......@@ -5,7 +5,7 @@ definition module iTasks.API.Core.CoreCombinators
*/
from System.Time import :: Timestamp
from iTasks.API.Core.LayoutCombinators import :: SetLayout, :: AfterLayout, :: ModifyLayout, :: Layout
import iTasks.Framework.Task, iTasks.Framework.Shared, iTasks.Framework.iTaskClass
import iTasks.Framework.Task, iTasks.Framework.Shared, iTasks.Framework.Generic
derive class iTask ParallelTaskType, WorkOnStatus
......
......@@ -4,8 +4,8 @@ import StdList, StdTuple, StdMisc, StdBool, StdOrdList
import Internet.HTTP, GenEq, System.Time, Text, Data.Func, Data.Tuple, Data.List, Data.Error, Data.Either, Text.JSON
import iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskStore, iTasks.Framework.TaskEval
import iTasks.Framework.Util, iTasks.Framework.Shared, iTasks.Framework.Store, iTasks.Framework.GenUpdate
import iTasks.Framework.iTaskClass, iTasks.Framework.UIDefinition
import iTasks.Framework.Util, iTasks.Framework.Shared, iTasks.Framework.Store
import iTasks.Framework.Generic, iTasks.Framework.UIDefinition
import iTasks.API.Core.SystemTypes, iTasks.API.Core.LayoutCombinators
import iTasks.Framework.ClientSupport.ClientOverride
......
......@@ -3,8 +3,10 @@ definition module iTasks.API.Core.CoreTasks
* This module provides the core 'basic tasks' from which more specialized tasks can be derived.
*/
import iTasks.Framework.iTaskClass, iTasks.Framework.Shared
from iTasks.Framework.Task import :: Task
import iTasks.Framework.Generic
import iTasks.Framework.Shared
from iTasks.Framework.Task import :: Task
from iTasks.API.Core.SystemTypes import class descr
from Data.Error import ::MaybeError(..)
from System.OSError import ::MaybeOSError, ::OSError, ::OSErrorCode, ::OSErrorMessage
......
......@@ -4,7 +4,7 @@ import StdList, StdBool, StdInt, StdTuple,StdMisc
import System.Time, Data.Error, System.OSError, Data.Map, Data.Tuple, Text.JSON
import qualified StdList
import iTasks.Framework.Util, iTasks.Framework.HtmlUtil
import iTasks.Framework.iTaskClass, iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskEval, iTasks.Framework.TaskStore
import iTasks.Framework.Generic, iTasks.Framework.Generic.Interaction, iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskEval, iTasks.Framework.TaskStore
import iTasks.Framework.UIDefinition, iTasks.Framework.Shared
import iTasks.API.Core.LayoutCombinators
......
......@@ -6,10 +6,11 @@ definition module iTasks.API.Core.IntegrationTasks
from Data.Maybe import :: Maybe
from Data.Void import :: Void
from Data.Error import :: MaybeError, :: MaybeErrorString
from System.FilePath import :: FilePath
import iTasks.Framework.iTaskClass
import iTasks.Framework.Generic
from iTasks.Framework.Task import :: Task
from iTasks.API.Core.SystemTypes import :: Note, :: EmailAddress
from iTasks.API.Core.SystemTypes import class descr, :: Note, :: EmailAddress, :: ProcessStatus, :: Document
from iTasks.API.Common.InteractionTasks import :: ViewOption //TODO: We shouldn't import from Common in Core
:: HTTPMethod = GET | POST
......
......@@ -7,6 +7,7 @@ import Data.Either, System.OS
import iTasks.Framework.IWorld, iTasks.Framework.Task, iTasks.Framework.TaskState
import iTasks.Framework.Shared
import iTasks.Framework.Generic.Interaction
import iTasks.API.Core.SystemTypes, iTasks.API.Core.CoreTasks, iTasks.API.Core.LayoutCombinators
import iTasks.API.Common.InteractionTasks, iTasks.API.Common.CommonCombinators //TODO don't import from Common in Core
......
......@@ -5,8 +5,11 @@ definition module iTasks.API.Core.OptimizedCoreTasks
* if not all expressive power is needed.
*/
import iTasks.Framework.iTaskClass, iTasks.Framework.Shared
import iTasks.Framework.Generic
import iTasks.Framework.Shared
from iTasks.Framework.Task import :: Task
from iTasks.API.Core.SystemTypes import class descr, class Choice, class ChoiceNoView
interactNullEnter :: !d !v (v->l) -> Task l | descr d & iTask v & iTask l
interactNullUpdate :: !d !(l -> v) (l v -> l) l -> Task l | descr d & iTask l & iTask v
......
......@@ -3,15 +3,15 @@ implementation module iTasks.API.Core.OptimizedCoreTasks
import StdList, StdBool, StdInt, StdTuple,StdMisc
import System.Time, Data.Error, System.OSError, Data.Map, Data.Tuple, Data.List, Text.JSON
import qualified StdList
import iTasks.Framework.iTaskClass, iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskEval
import iTasks.Framework.Generic, iTasks.Framework.Generic.Interaction, iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskEval
import iTasks.Framework.TaskStore, iTasks.Framework.UIDefinition, iTasks.Framework.Shared
import iTasks.Framework.Util, iTasks.Framework.HtmlUtil
import iTasks.API.Core.LayoutCombinators
from Data.SharedDataSource import qualified read, readRegister, write, writeFilterMsg
from Data.SharedDataSource import qualified read, readRegister, write, writeFilterMsg
from StdFunc import o, id
from iTasks.Framework.IWorld import :: IWorld(..)
from iTasks.API.Core.SystemData import topLevelTasks
from Data.Map import qualified get
from Data.Map import qualified get
interactSharedChoice :: !d !(ReadOnlyShared r) (Maybe l) (r (Maybe l) -> t v l)
-> Task (Maybe l) | descr d & Choice t & iTask r & iTask l & iTask (t v l)
......
......@@ -31,7 +31,10 @@ from System.Time import :: Timestamp
from iTasks.Framework.IWorld import :: IWorld
from iTasks.Framework.UIDefinition import :: UIDef, :: UIControlSequence, :: UIAnnotatedControls, :: UIControl, :: UISize, :: UIDirection, :: UISideSizes, :: UIMinSize, :: UIAttributes
from iTasks.Framework.Task import :: Task, :: TaskId
from iTasks.Framework.iTaskClass import class iTask, generic gVerify, :: VerifyOptions, generic gDefault, generic gUpdate, generic gEditor, generic gEditMeta, generic gVisualizeText, :: EditMeta, :: VSt, :: VisualizationResult, :: VisualizationFormat(..), visualizeAsText
from iTasks.Framework.Generic import class iTask
from iTasks.Framework.Generic.Interaction import generic gEditor, generic gEditMeta, generic gVerify, generic gUpdate, :: VSt, :: VisualizationResult,:: EditMeta, :: VerifyOptions
from iTasks.Framework.Generic.Visualization import generic gVisualizeText, :: VisualizationFormat(..), visualizeAsText
from iTasks.Framework.Generic.Defaults import generic gDefault
from iTasks.Framework.Shared import :: ReadWriteShared, :: ReadOnlyShared, :: RWShared
from iTasks.Framework.ClientInterface import :: JSWorld, :: JSPtr
from iTasks.API.Core.LayoutCombinators import :: Layout
......
......@@ -3,7 +3,9 @@ from StdFunc import until
import StdInt, StdBool, StdClass, StdArray, StdEnum, StdTuple, StdMisc, StdList, StdFunc, StdOrdList
import Data.List, Data.Functor, Text.JSON, Text.HTML, Text, Data.Map, Text.Encodings.Base64, Data.Tuple, dynamic_string, System.File
import iTasks.Framework.GenVisualize, iTasks.Framework.GenUpdate
import iTasks.Framework.UIDefinition
import iTasks.Framework.Generic.Interaction
import iTasks.Framework.Generic.Visualization
import iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.Util
import iTasks.Framework.SerializationGraphCopy
import iTasks.Framework.IWorld
......
......@@ -2,7 +2,7 @@ implementation module iTasks.API.Extensions.Admin.WorkflowAdmin
import iTasks
import StdMisc, Data.Tuple, Text, Data.Either, Data.Functor
import iTasks.Framework.Shared
import iTasks.Framework.Shared, iTasks.Framework.Generic.Interaction
from StdFunc import seq
from Data.Map import qualified newMap
......
definition module iTasks.Framework.GenRecord
/**
* This module provides functions for generically copying record fields of similar record.
* An example is a record representing the data model and a similar one representing the view.
* All fields with the same name & type can be copied automatically, only different fields have to be mapped manually.
*/
import iTasks.API.Core.SystemTypes, iTasks.Framework.GenUpdate
/**
* Copies all fields with same name & type from one record to another.
*
* @param The source record
* @param The destrination record
* @return The resulting record
*/
copyRecord :: !a !b -> b | GenRecord a & GenRecord b
/**
* Maps a record to another type.
* All fields with same name & type keep their value, for others default values are filled in.
*
* @param The record to be mapped
* @return The resulting record of another type
*/
mapRecord :: !a -> b | GenRecord a & GenRecord, gDefault{|*|} b
class GenRecord r
| gGetRecordFields{|*|}
, gPutRecordFields{|*|} r
generic gGetRecordFields r :: !r ![GenType] !*RecordFields -> *RecordFields
generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields)
:: *RecordFields
derive gGetRecordFields UNIT, PAIR, EITHER, CONS, OBJECT, RECORD of {grd_type}, FIELD of {gfd_name,gfd_index}
derive gGetRecordFields Int, Real, Char, Bool, String
derive gGetRecordFields Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gGetRecordFields Note, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
derive gGetRecordFields EmailAddress, Action
derive gPutRecordFields UNIT, PAIR, EITHER, CONS, OBJECT, RECORD of {grd_type}, FIELD of {gfd_name,gfd_index}
derive gPutRecordFields Int, Real, Char, Bool, String
derive gPutRecordFields Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gPutRecordFields Note, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
derive gPutRecordFields EmailAddress, Action
implementation module iTasks.Framework.GenRecord
import StdTuple, StdList, StdFunc, Data.Error, Data.Map, Data.Generic, Data.Tuple
import iTasks.Framework.Util, iTasks.Framework.GenUpdate
from dynamic_string import copy_to_string, copy_from_string
copyRecord :: !a !b -> b | GenRecord a & GenRecord b
copyRecord src dst
# srcFields = gGetRecordFields{|*|} src [] newMap
= fst (gPutRecordFields{|*|} dst [] srcFields)
mapRecord :: !a -> b | GenRecord a & GenRecord, gDefault{|*|} b
mapRecord rec
# fields = gGetRecordFields{|*|} rec [] newMap
= fst (gPutRecordFields{|*|} defaultValue [] fields)
generic gGetRecordFields r :: !r ![GenType] !*RecordFields -> *RecordFields
gGetRecordFields{|OBJECT|} fx (OBJECT o) _ fields = fields
gGetRecordFields{|CONS|} fx (CONS c) types fields = fx c types fields
gGetRecordFields{|EITHER|} fx fy either types fields = case either of
LEFT x = fx x types fields
RIGHT y = fy y types fields
gGetRecordFields{|PAIR|} fx fy (PAIR x y) types fields
# fields = fx x types fields
= fy y types fields
gGetRecordFields{|RECORD of {grd_type}|} fx (RECORD r) _ fields = fx r (getFieldTypes grd_type) fields
gGetRecordFields{|FIELD of {gfd_name,gfd_index}|} _ f types fields = put gfd_name (GenericDyn (copy_to_string f) (types !! gfd_index)) fields
gGetRecordFields{|UNIT|} _ _ fields = fields
gGetRecordFields{|Int|} _ _ fields = fields
gGetRecordFields{|Real|} _ _ fields = fields
gGetRecordFields{|Char|} _ _ fields = fields
gGetRecordFields{|Bool|} _ _ fields = fields
gGetRecordFields{|String|} _ _ fields = fields
gGetRecordFields{|(->)|} _ _ _ _ fields = fields
gGetRecordFields{|Dynamic|} _ _ fields = fields
derive gGetRecordFields [], Maybe, Either, (,), (,,), (,,,), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gGetRecordFields Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
derive gGetRecordFields EmailAddress, Action, ActionOption, Hotkey, Trigger, ButtonState
generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields)
gPutRecordFields{|OBJECT|} fx obj=:(OBJECT o) _ fields = (obj,fields)
gPutRecordFields{|CONS|} fx (CONS c) types fields = appFst CONS (fx c types fields)
gPutRecordFields{|EITHER|} fx fy either types fields = case either of
LEFT x = appFst LEFT (fx x types fields)
RIGHT y = appFst RIGHT (fy y types fields)
gPutRecordFields{|PAIR|} fx fy (PAIR x y) types fields
# (x`,fields) = fx x types fields
# (y`,fields) = fy y types fields
= (PAIR x` y`,fields)
gPutRecordFields{|RECORD of {grd_type}|} fx (RECORD r) _ fields
= appFst RECORD (fx r (getFieldTypes grd_type) fields)
gPutRecordFields{|FIELD of {gfd_name,gfd_index}|} _ f types fields
# (mbGenDyn,fields) = delU gfd_name fields
# f` = case mbGenDyn of
Just genDyn = case matchGenericDyn genDyn (types !! gfd_index) of
Just f = f
Nothing = f
Nothing = f
= (f`,fields)
gPutRecordFields{|UNIT|} _ _ fields = (UNIT,fields)
gPutRecordFields{|Int|} c _ fields = (c,fields)
gPutRecordFields{|Real|} c _ fields = (c,fields)
gPutRecordFields{|Char|} c _ fields = (c,fields)
gPutRecordFields{|Bool|} c _ fields = (c,fields)
gPutRecordFields{|String|} c _ fields = (c,fields)
gPutRecordFields{|(->)|} _ _ f _ fields = (f,fields)
gPutRecordFields{|Dynamic|} dyn _ fields = (dyn,fields)
derive gPutRecordFields [], Maybe, Either, (,), (,,), (,,,), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gPutRecordFields Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
derive gPutRecordFields EmailAddress, Action, ActionOption, Hotkey, Trigger, ButtonState
:: *RecordFields :== Map String GenericDyn
// This type is needed because dynamics can't be used inside generic functions.
// It includes the string representation of the value (generated by copy_to_string)
// and the generic type of it.
:: *GenericDyn = GenericDyn !*String !GenType
/**
* Tries to match & unpack a GenericDyn value.
*
* @param The GenericDyn
* @param The type to match
*
* @return The unpacked value if match succeeded.
*/
matchGenericDyn :: !*GenericDyn !GenType -> Maybe a
matchGenericDyn (GenericDyn str dynType) reqType
| dynType === reqType = Just (fst (copy_from_string str))
| otherwise = Nothing
// Retrieves the types of a record's fields.
getFieldTypes :: !GenType -> [GenType]
getFieldTypes grd_type = getFieldTypes` grd_type []
where
getFieldTypes` (GenTypeArrow field next) acc = getFieldTypes` next [field:acc]
getFieldTypes` _ acc = reverse acc
derive gEq GenType
......@@ -18,9 +18,9 @@ from Data.Maybe import :: Maybe
from StdGeneric import :: ConsPos
from Text.JSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from iTasks.Framework.GenVisualize import :: VisualizationFormat,:: VSt, :: VisualizationResult, :: EditMeta
from iTasks.Framework.GenVisualize import generic gVisualizeText, generic gEditor, generic gEditMeta
from iTasks.Framework.GenUpdate import generic gUpdate, generic gDefault
from iTasks.Framework.Generic.Interaction import generic gEditor, generic gEditMeta, generic gUpdate, :: VSt, :: VisualizationResult, :: EditMeta
from iTasks.Framework.Generic.Visualization import generic gVisualizeText, :: VisualizationFormat
from iTasks.Framework.Generic.Defaults import generic gDefault
from iTasks.API.Core.SystemTypes import :: DataPath, :: InteractionMask, :: Verification, :: MaskedValue, :: VerifiedValue
......
implementation module iTasks.Framework.GenSpecialize
import Text.JSON, Data.Functor
import iTasks.Framework.iTaskClass
import iTasks.Framework.Generic
customJSONEncode :: (a -> b) a -> [JSONNode] | JSONEncode{|*|} b
customJSONEncode toPrj a = JSONEncode{|*|} (toPrj a)
......
implementation module iTasks.Framework.GenUpdate
import StdString, StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, Data.Maybe, StdGeneric, StdEnum, Data.Tuple, Data.List, Text, Text.JSON, Data.Functor
import iTasks.Framework.Util
import iTasks.API.Core.SystemTypes
from StdFunc import id, flip, const, o
from iTasks.Framework.UIDefinition import :: UISize(..)
generic gDefault a :: [ConsPos] -> a
gDefault{|UNIT|} _ = UNIT
gDefault{|PAIR|} fa fb path = PAIR (fa []) (fb [])
gDefault{|EITHER|} fa fb [] = LEFT (fa [])
gDefault{|EITHER|} fa fb [ConsLeft:path] = LEFT (fa path)
gDefault{|EITHER|} fa fb [ConsRight:path] = RIGHT (fb path)
gDefault{|OBJECT|} fa _ = OBJECT (fa [])
gDefault{|CONS|} fa _ = CONS (fa [])
gDefault{|RECORD|} fa _ = RECORD (fa [])
gDefault{|FIELD|} fa _ = FIELD (fa [])
gDefault{|Int|} _ = 0
gDefault{|Real|} _ = 0.0
gDefault{|Char|} _ = '\0'
gDefault{|Bool|} _ = False
gDefault{|String|} _ = ""
gDefault{|[]|} _ _ = []
gDefault{|(,)|} fa fb _ = (fa [],fb [])
gDefault{|(,,)|} fa fb fc _ = (fa [],fb [],fc [])
gDefault{|(,,,)|} fa fb fc fd _ = (fa [],fb [],fc [],fd [])
gDefault{|(->)|} fa fb _ = const (fb [])
gDefault{|Dynamic|} _ = dynamic 42
gDefault{|Maybe|} fa _ = Nothing
gDefault{|HtmlTag|} _ = Html ""
derive gDefault Either, Void, Map, JSONNode, Timestamp
defaultValue :: a | gDefault{|*|} a
defaultValue = gDefault{|*|} []
updateValueAndMask :: !DataPath !JSONNode !(MaskedValue a) -> MaskedValue a | gUpdate{|*|} a
updateValueAndMask path update (a,mask) = gUpdate{|*|} path update (a,mask)
//Generic updater
generic gUpdate a | gDefault a, JSONDecode a :: !DataPath !JSONNode !(MaskedValue a) -> (MaskedValue a)
gUpdate{|UNIT|} _ _ val = val
gUpdate{|PAIR|} gUpdx gDefx jDecx gUpdy gDefy jDecy [0:target] upd (PAIR x y, xmask)
# (x,xmask) = gUpdx target upd (x,xmask)
= (PAIR x y,xmask)
gUpdate{|PAIR|} gUpdx gDefx jDecx gUpdy gDefy jDecy [1:target] upd (PAIR x y, ymask)
# (y,ymask) = gUpdy target upd (y,ymask)
= (PAIR x y,ymask)
gUpdate{|PAIR|} gUpdx gDefx jDecx gUpdy gDefy jDecy target upd val = val
gUpdate{|EITHER|} gUpdx gDefx jDecx gUpdy gDefy jDecy target upd (LEFT x,mask) = appFst LEFT (gUpdx target upd (x,mask))
gUpdate{|EITHER|} gUpdx gDefx jDecx gUpdy gDefy jDecy target upd (RIGHT y,mask) = appFst RIGHT (gUpdy target upd (y,mask))
gUpdate{|OBJECT of {gtd_num_conses,gtd_conses}|} gUpdx gDefx jDecx [] upd (OBJECT x, _) //Update is a constructor switch
# consIdx = case upd of
JSONInt i = i
_ = 0
# mask = case upd of
JSONNull = Blanked //Reset
_ = CompoundMask (repeatn (gtd_conses !! consIdx).gcd_arity Untouched)
= (OBJECT (gDefx (path consIdx)), mask)
where
path consIdx = if (consIdx < gtd_num_conses) (consPath consIdx gtd_num_conses) []
gUpdate{|OBJECT|} gUpdx gDefx jDecx target upd (OBJECT object, mask) //Update is targeted somewhere in a substructure of this value
= appFst OBJECT (gUpdx target upd (object,mask))
gUpdate{|CONS of {gcd_arity,gcd_index}|} gUpdx gDefx jDecx [index:target] upd (CONS cons,mask)
| index >= gcd_arity
= (CONS cons,mask)
# childMasks = subMasks gcd_arity mask
# (cons,targetMask) = gUpdx (pairPath index gcd_arity ++ target) upd (cons,childMasks !! index)
= (CONS cons,CompoundMask (updateAt index targetMask childMasks))
gUpdate{|CONS|} gUpdx gDefx jDecx target upd val = val
gUpdate{|RECORD of {grd_arity}|} gUpdx gDefx jDecx [index:target] upd (RECORD record,mask)
| index >= grd_arity
= (RECORD record,mask)
# childMasks = subMasks grd_arity mask
# (record,targetMask) = gUpdx (pairPath index grd_arity ++ target) upd (record,childMasks !! index)
= (RECORD record,CompoundMask (updateAt index targetMask childMasks))
gUpdate{|RECORD|} gUpdx gDefx jDecx _ _ val = val
gUpdate{|FIELD|} gUpdx gDefx jDecx target upd (FIELD field,mask)= appFst FIELD (gUpdx target upd (field,mask))
consPath i n
| i >= n
= []
| n == 1
= []
| i < (n/2)
= [ ConsLeft : consPath i (n/2) ]
| otherwise
= [ ConsRight : consPath (i - (n/2)) (n - (n/2)) ]
pairPath i n
| i >= n
= []
| n == 1
= []
| i < (n /2)
= [0: pairPath i (n /2)]
| otherwise
= [1: pairPath (i - (n/2)) (n - (n/2))]
gUpdate{|Int|} target upd val = basicUpdateSimple target upd val
gUpdate{|Real|} target upd val = basicUpdateSimple target upd val
gUpdate{|Char|} target upd val = basicUpdateSimple target upd val
gUpdate{|Bool|} target upd val = basicUpdateSimple target upd val
gUpdate{|String|} target upd val = basicUpdateSimple target upd val
gUpdate{|Maybe|} gUpdx gDefx jDecx target upd (m,mmask)
| isEmpty target && (upd === JSONNull || upd === JSONBool False)
= (Nothing, Blanked) //Reset
| otherwise
= case m of
Nothing
// Create a default value
# x = gDefx []
// Search in the default value
# (x,mmask) = gUpdx target upd (x,Untouched)
= (Just x, mmask)
Just x
= appFst Just (gUpdx target upd (x,mmask))
gUpdate{|[]|} gUpdx gDefx jDecx target upd (l,listMask)
# (l,childMasks)
= case ((not (isEmpty target)) && (hd target >= (length l))) of
True
# nv = gDefx []
= (l++[nv], subMasks (length l) listMask ++ [Untouched])
False
= (l, subMasks (length l) listMask)
# (l,childMasks) = updateElements gUpdx target upd l childMasks
| isEmpty target
//Process the reordering commands
# split = split "_" (fromMaybe "" (fromJSON upd))
# index = toInt (last split)
# (l,childMasks) = case hd split of
"mup" = (swap l index,swap childMasks index)
"mdn" = (swap l (index+1),swap childMasks (index+1))
"rem" = (removeAt index l,removeAt index childMasks)
"add"
= (insertAt (length l) (gDefx []) l, insertAt (length l) Untouched childMasks)
_
= (l,childMasks)
= (l,CompoundMask childMasks)
| otherwise
= (l,CompoundMask childMasks)
where
updateElements fx [i:target] upd elems masks
| i >= (length elems)
= (elems,masks)
# (nx,nm) = fx target upd (elems !! i,masks !! i)
= (updateAt i nx elems, updateAt i nm masks)
updateElements fx target upd elems masks
= (elems,masks)
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{|Dynamic|} target upd val = basicUpdate (\Void v -> Just v) target upd val
gUpdate{|(->)|} _ _ gUpdy _ _ _ target upd val = basicUpdate (\Void v -> Just v) target upd val
gUpdate{|HtmlTag|} target upd val = val
derive gUpdate Either, (,), (,,), (,,,), JSONNode, Void, Timestamp, Map
basicUpdate :: !(upd a -> Maybe a) !DataPath !JSONNode !(MaskedValue a) -> MaskedValue a | JSONDecode{|*|} upd
basicUpdate toV target upd (v,vmask)
| isEmpty target
# mbV = maybe Nothing (\u -> toV u v) (fromJSON upd)