Commit d0b9920c authored by Bas Lijnse's avatar Bas Lijnse

Fixed propagation of writes in basic editors

parent 9b1532dd
Pipeline #36648 failed with stage
in 1 minute and 35 seconds
......@@ -270,7 +270,7 @@ where
viewWorkflowDetails :: !(sds () (Maybe Workflow) ()) -> Task Workflow | RWShared sds
viewWorkflowDetails sel
= Title "Task description" @>> viewSharedInformation [ViewUsing view textView] sel
= Title "Task description" @>> viewSharedInformation [ViewUsing view (ignoreEditorWrites textView)] sel
@? onlyJust
where
view = maybe "" (\wf -> wf.Workflow.description)
......
......@@ -17,10 +17,10 @@ import iTasks.UI.Editor.Modifiers
import iTasks.Internal.SDS
import StdBool, StdArray, StdEnum, StdList, StdString
import StdBool, StdArray, StdEnum, StdList, StdString, StdFunctions
import Text, Text.GenJSON, Text.GenPrint, System.Time
import Data.Maybe, Data.Error, Data.Func
import Data.Maybe, Data.Error, Data.Func, Data.Functor
import qualified Data.Map as DM
from iTasks.Extensions.Form.Pikaday import pikadayDateField
......@@ -107,10 +107,13 @@ JSONDecode{|Time|} _ c = (Nothing, c)
gText{|Time|} _ val = [maybe "" toString val]
gEditor{|Time|} = selectByMode
(bijectEditorWrite toString fromString $ bijectEditorValue toString fromString textView)
(injectEditorWrite toString parseTime $ injectEditorValue toString parseTime (withDynamicHintAttributes "time (hh:mm:ss)" (withEditModeAttr textField)))
(injectEditorWrite toString parseTime $ injectEditorValue toString parseTime (withDynamicHintAttributes "time (hh:mm:ss)" (withEditModeAttr textField)))
gEditor{|Time|} = selectByMode view edit edit
where
view = ignoreEditorWrites $ bijectEditorValue toString fromString textView
edit
= injectEditorWrite (maybe "" toString) (\s -> Just <$> parseTime s)
$ injectEditorValue toString parseTime
$ withDynamicHintAttributes "time (hh:mm:ss)" $ withEditModeAttr textField
derive gDefault Time
derive gEq Time
......@@ -178,10 +181,13 @@ gText{|DateTime|} AsHeader _ = [""]
gText{|DateTime|} _ (Just ({DateTime|year,mon,day,hour,min,sec}))
= [toSingleLineText {Date|year=year,mon=mon,day=day} +++" "+++ toSingleLineText {Time|hour=hour,min=min,sec=sec}]
gEditor{|DateTime|} = selectByMode
(bijectEditorWrite toString fromString $ bijectEditorValue toString fromString textView)
(injectEditorWrite toString parseDateTime $ injectEditorValue toString parseDateTime (withDynamicHintAttributes "date/time (yyyy-mm-dd hh:mm:ss)" (withEditModeAttr textField) ))
(injectEditorWrite toString parseDateTime $ injectEditorValue toString parseDateTime (withDynamicHintAttributes "date/time (yyyy-mm-dd hh:mm:ss)" (withEditModeAttr textField) ))
gEditor{|DateTime|} = selectByMode view edit edit
where
view = ignoreEditorWrites $ bijectEditorValue toString fromString textView
edit
= injectEditorWrite (maybe "" toString) (\s -> Just <$> parseDateTime s)
$ injectEditorValue toString parseDateTime
$ withDynamicHintAttributes "date/time (yyyy-mm-dd hh:mm:ss)" $ withEditModeAttr textField
derive gDefault DateTime
derive gEq DateTime
......
......@@ -6,7 +6,8 @@ import iTasks.UI.Editor.Controls, iTasks.UI.Editor.Modifiers
import iTasks.Internal.Task, iTasks.Internal.IWorld, iTasks.Internal.TaskState
import StdBool, StdString, StdFile, StdArray, StdInt
import Text.GenJSON, Text.Encodings.MIME, Text.HTML, System.FilePath, System.File, System.OSError, Data.Error, Data.Func
import Text.GenJSON, Text.Encodings.MIME, Text.HTML, System.FilePath, System.File, System.OSError
import Data.Error, Data.Func, Data.Functor
import qualified Data.Map as DM
from StdFunc import const
......@@ -24,7 +25,7 @@ where
where
toView {Document|contentUrl,name} = ATag [HrefAttr contentUrl, TargetAttr "_blank"] [Text name]
editDocument = bijectEditorWrite toView fromView $ bijectEditorValue toView fromView documentField
editDocument = bijectEditorWrite (fmap toView) (fmap fromView) $ bijectEditorValue toView fromView documentField
where
toView {Document|documentId,contentUrl,name,mime,size} = (documentId,contentUrl,name,mime,size)
fromView (documentId,contentUrl,name,mime,size) = {Document|documentId=documentId,contentUrl=contentUrl,name=name,mime=mime,size=size}
......
......@@ -5,4 +5,4 @@ import iTasks, iTasks.UI.Editor
*/
pikadayField :: Editor String String
pikadayDateField :: Editor Date Date
pikadayDateField :: Editor Date (Maybe Date)
implementation module iTasks.Extensions.Form.Pikaday
import StdEnv
import iTasks, Data.Func
import iTasks, Data.Func, Data.Functor
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.JavaScript
import iTasks.UI.Editor.Modifiers, iTasks.UI.Editor.Controls
import iTasks.Extensions.DateTime
......@@ -103,8 +103,12 @@ where
unique Nothing = Nothing
unique (Just x) = Just x
pikadayDateField :: Editor Date Date
pikadayDateField = selectByMode
(bijectEditorWrite toString fromString $ bijectEditorValue toString fromString textView)
(injectEditorWrite toString parseDate $ injectEditorValue toString parseDate (withDynamicHintAttributes "date (yyyy-mm-dd)" (withEditModeAttr pikadayField)))
(injectEditorWrite toString parseDate $ injectEditorValue toString parseDate (withDynamicHintAttributes "date (yyyy-mm-dd)" (withEditModeAttr pikadayField)))
pikadayDateField :: Editor Date (Maybe Date)
pikadayDateField = selectByMode view edit edit
where
view = ignoreEditorWrites $ bijectEditorValue toString fromString textView
edit
= injectEditorWrite (maybe "" toString) (\s -> Just <$> parseDate s)
$ injectEditorValue toString parseDate
(withDynamicHintAttributes "date (yyyy-mm-dd)" (withEditModeAttr pikadayField))
......@@ -74,8 +74,10 @@ JSONEncode{|Username|} _ (Username u) = [JSONString u]
JSONDecode{|Username|} _ [JSONString u:c] = (Just (Username u),c)
JSONDecode{|Username|} _ c = (Nothing,c)
gEditor{|Username|} = bijectEditorWrite fromUsername toUsername $ bijectEditorValue fromUsername toUsername
(selectByMode textView usernameField usernameField)
gEditor{|Username|}
= bijectEditorWrite (maybe "" fromUsername) (Just o toUsername)
$ bijectEditorValue fromUsername toUsername
$ selectByMode textView usernameField usernameField
where
fromUsername (Username u) = u
toUsername u = Username u
......@@ -104,8 +106,10 @@ JSONDecode{|Password|} _ c = (Nothing,c)
gText{|Password|} AsHeader _ = [""]
gText{|Password|} _ _ = ["********"]
gEditor{|Password|} = bijectEditorWrite fromPassword toPassword $ bijectEditorValue fromPassword toPassword
(selectByMode passwordView passwordEdit passwordEdit)
gEditor{|Password|}
= bijectEditorWrite (maybe "" fromPassword) (Just o toPassword)
$ bijectEditorValue fromPassword toPassword
$ selectByMode passwordView passwordEdit passwordEdit
where
fromPassword (Password p) = p
toPassword s = Password s
......
......@@ -14,7 +14,7 @@ from Data.GenEq import generic gEq
*
* @result the empty editor
*/
emptyEditor :: Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditor :: Editor a w | JSONEncode{|*|}, JSONDecode{|*|} a
/**
* Editor that does nothing and gives a default value in enter mode.
......@@ -22,11 +22,11 @@ emptyEditor :: Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
* @param default value used when editor is generated in edit mode
* @result the empty editor
*/
emptyEditorWithDefaultInEnterMode :: !a -> Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditorWithDefaultInEnterMode :: !a -> Editor a w | JSONEncode{|*|}, JSONDecode{|*|} a
//Version without overloading, for use in generic case
//The first two argument should be JSONEncode{|*|} and JSONDecode{|*|} which cannot be used by overloading within generic functions
emptyEditorWithDefaultInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode] -> (Maybe a, [JSONNode])) !a -> Editor a a
emptyEditorWithDefaultInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode] -> (Maybe a, [JSONNode])) !a -> Editor a w
/**
* Editor that does nothing and gives an error in enter mode.
......@@ -34,12 +34,12 @@ emptyEditorWithDefaultInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode]
* @param the error messsage used when the editor is used in enter mode
* @result the empty editor
*/
emptyEditorWithErrorInEnterMode :: !String -> Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditorWithErrorInEnterMode :: !String -> Editor a w | JSONEncode{|*|}, JSONDecode{|*|} a
//Version without overloading, for use in generic case
//The first two argument should be JSONEncode{|*|} and JSONDecode{|*|} which cannot be used by overloading within generic functions
emptyEditorWithErrorInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode] -> (Maybe a, [JSONNode])) !String
-> Editor a a
-> Editor a w
/**
* Indicates if and how a UI child can be updated to another one.
......
......@@ -7,7 +7,7 @@ import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Containers, iTas
import Data.Tuple, Data.Error, Text, Text.GenJSON, Data.Func, Data.Functor
import qualified Data.Map as DM
emptyEditor :: Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditor :: Editor a w | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditor = leafEditorToEditor {LeafEditor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}
where
// store initial value in state
......@@ -16,10 +16,10 @@ where
onRefresh _ val _ vst = (Ok (NoChange, Just val, Nothing),vst) // just use new value
valueFromState mbVal = mbVal
emptyEditorWithDefaultInEnterMode :: !a -> Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditorWithDefaultInEnterMode :: !a -> Editor a w| JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditorWithDefaultInEnterMode defaultValue = emptyEditorWithDefaultInEnterMode_ JSONEncode{|*|} JSONDecode{|*|} defaultValue
emptyEditorWithDefaultInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode] -> (Maybe a, [JSONNode])) !a -> Editor a a
emptyEditorWithDefaultInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode] -> (Maybe a, [JSONNode])) !a -> Editor a w
emptyEditorWithDefaultInEnterMode_ jsonEncode jsonDecode defaultValue = leafEditorToEditor_
jsonEncode jsonDecode
{LeafEditor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}
......@@ -30,11 +30,11 @@ where
onRefresh _ val _ vst = (Ok (NoChange, val, Nothing),vst) // just use new value
valueFromState val = Just val
emptyEditorWithErrorInEnterMode :: !String -> Editor a a | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditorWithErrorInEnterMode :: !String -> Editor a w | JSONEncode{|*|}, JSONDecode{|*|} a
emptyEditorWithErrorInEnterMode error = emptyEditorWithErrorInEnterMode_ JSONEncode{|*|} JSONDecode{|*|} error
emptyEditorWithErrorInEnterMode_ :: !(Bool a -> [JSONNode]) !(Bool [JSONNode] -> (Maybe a, [JSONNode])) !String
-> Editor a a
-> Editor a w
emptyEditorWithErrorInEnterMode_ jsonEncode jsonDecode error = leafEditorToEditor_ jsonEncode jsonDecode
{LeafEditor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}
where
......
......@@ -34,17 +34,17 @@ passwordField :: Editor String String
* Textfield that only allows you to enter integer numbers
* Supported attributes:
*/
integerField :: Editor Int Int
integerField :: Editor Int (Maybe Int)
/**
* Textfield that only allows you to enter decimal (or integer) numbers
* Supported attributes:
*/
decimalField :: Editor Real Real
decimalField :: Editor Real (Maybe Real)
/**
* Form field that allows you to upload files
* Supported attributes:
*/
documentField :: Editor (!String,!String,!String,!String,!Int) (!String,!String,!String,!String,!Int)
documentField :: Editor (!String,!String,!String,!String,!Int) (Maybe (!String,!String,!String,!String,!Int))
/**
* Simple checkbox
* Supported attributes:
......@@ -130,7 +130,7 @@ tabBar :: Editor ([ChoiceText], [Int]) [Int]
withConstantChoices :: !choices !(Editor (!choices, ![Int]) [Int]) -> Editor [Int] [Int]
fieldComponent
:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a a
:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a (Maybe a)
| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a
//Convenient types for describing the values of grids and trees
......
......@@ -12,13 +12,19 @@ import iTasks.UI.Editor.Modifiers
disableOnView e = selectByMode (e <<@ enabledAttr False) e e
textField :: Editor String String
textField = fieldComponent UITextField (Just "") isValidString
textField
= bijectEditorWrite Just (fromMaybe "")
$ fieldComponent UITextField (Just "") isValidString
textArea :: Editor String String
textArea = fieldComponent UITextArea (Just "") isValidString
textArea
= bijectEditorWrite Just (fromMaybe "")
$ fieldComponent UITextArea (Just "") isValidString
passwordField :: Editor String String
passwordField = fieldComponent UIPasswordField (Just "") isValidString
passwordField
= bijectEditorWrite Just (fromMaybe "")
$ fieldComponent UIPasswordField (Just "") isValidString
isValidString :: !UIAttributes !String -> Bool
isValidString attrs str
......@@ -31,23 +37,32 @@ where
lStr = size str
integerField :: Editor Int Int
integerField = fieldComponent UIIntegerField Nothing (\_ _ -> True)
integerField :: Editor Int (Maybe Int)
integerField = fieldComponent UIIntegerField Nothing valid
where
valid :: UIAttributes Int -> Bool
valid _ _ = True
decimalField :: Editor Real Real
decimalField :: Editor Real (Maybe Real)
decimalField = fieldComponent UIDecimalField Nothing (\_ _ -> True)
documentField :: Editor (!String,!String,!String,!String,!Int) (!String,!String,!String,!String,!Int)
documentField :: Editor (!String,!String,!String,!String,!Int) (Maybe (!String,!String,!String,!String,!Int))
documentField = fieldComponent UIDocumentField Nothing (\_ _ -> True)
checkBox :: Editor Bool Bool
checkBox = fieldComponent UICheckbox (Just False) (\_ _ -> True)
checkBox
= bijectEditorWrite Just (fromMaybe False)
$ fieldComponent UICheckbox (Just False) (\_ _ -> True)
slider :: Editor Int Int
slider = fieldComponent UISlider Nothing (\_ _ -> True)
slider
= bijectEditorWrite Just (fromMaybe 0)
$ fieldComponent UISlider Nothing (\_ _ -> True)
button :: Editor Bool Bool
button = fieldComponent UIButton Nothing (\_ _ -> True)
button
= bijectEditorWrite Just (fromMaybe False)
$ fieldComponent UIButton Nothing (\_ _ -> True)
label :: Editor String String
label = viewComponent textAttr UILabel
......@@ -125,7 +140,7 @@ where
//Field like components for which simply knowing the UI type is sufficient
fieldComponent
:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a a
:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a (Maybe a)
| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a
fieldComponent type mbEditModeInitValue isValid = disableOnView $ editorWithJSONEncode (leafEditorToEditor o leafEditor)
where
......@@ -143,7 +158,8 @@ where
]
= (Ok (uia type attr, (mbVal, attr)), vst)
onEdit _ (_, mbVal) (_, attrs) vst = (Ok (ChangeUI [SetAttribute "value" valJSON] [], (mbVal`, attrs), unique mbVal`), vst)
onEdit _ (_, mbVal) (_, attrs) vst
= (Ok (ChangeUI [SetAttribute "value" valJSON] [], (mbVal`, attrs), unique (Just mbVal`)), vst)
where
(mbVal`, valJSON) = case mbVal of
Just val | isValid attrs val = (Just val, toJSON val)
......@@ -155,7 +171,7 @@ where
valueFromState (mbVal, _) = mbVal
editorWithJSONEncode :: !((a -> JSONNode) -> Editor a a) -> Editor a a | JSONEncode{|*|} a
editorWithJSONEncode :: !((a -> JSONNode) -> Editor a (Maybe a)) -> Editor a (Maybe a) | JSONEncode{|*|} a
editorWithJSONEncode genFunc = genFunc toJSON
//Components which cannot be edited
......
......@@ -12,7 +12,7 @@ from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat
/**
* Main generic editor function
*/
generic gEditor a | gText a, JSONEncode a, JSONDecode a :: Editor a a
generic gEditor a | gText a, JSONEncode a, JSONDecode a :: Editor a (Maybe a)
derive gEditor
UNIT,
......
......@@ -15,7 +15,7 @@ import Text.Language
import System.Time
import Data.GenEq, Data.Func, Control.GenBimap, Data.Functor, Data.Tuple
generic gEditor a | gText a, JSONEncode a, JSONDecode a :: Editor a a
generic gEditor a | gText a, JSONEncode a, JSONDecode a :: Editor a (Maybe a)
derive bimap Editor, MaybeError
gEditor{|UNIT|} = emptyEditorWithDefaultInEnterMode_ (\_ _ -> [JSONNull]) (\_ [JSONNull: json] -> (Just UNIT, json)) UNIT
......@@ -150,7 +150,7 @@ where
gEditor{|OBJECT of {gtd_num_conses,gtd_conses}|} ce=:{Editor|genUI=exGenUI,onEdit=exOnEdit,onRefresh=exOnRefresh,valueFromState=exValueFromState} _ _ _
//Newtypes or ADTs just use the child editor
| gtd_num_conses < 2
= bijectEditorWrite (\(OBJECT i)->i) (\i->OBJECT i) $ bijectEditorValue (\(OBJECT i)->i) (\i->OBJECT i) ce
= bijectEditorWrite (fmap (\(OBJECT i)->i)) (fmap (\i->OBJECT i)) $ bijectEditorValue (\(OBJECT i)->i) (\i->OBJECT i) ce
= withEditModeAttr $ compoundEditorToEditor
{CompoundEditor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}
where
......@@ -537,26 +537,39 @@ where
(ChangeUI _ ll) = fromPairChange s half l
(ChangeUI _ rl) = fromPairChange (s + half) (n - half) r
gEditor{|Int|} = selectByMode
(bijectEditorWrite toString toInt $ bijectEditorValue toString toInt textView)
(withDynamicHintAttributes "whole number" (withEditModeAttr integerField))
(withDynamicHintAttributes "whole number" (withEditModeAttr integerField))
gEditor{|Real|} = selectByMode
(bijectEditorWrite toString toReal $ bijectEditorValue toString toReal textView)
(withDynamicHintAttributes "decimal number" (withEditModeAttr decimalField ))
(withDynamicHintAttributes "decimal number" (withEditModeAttr decimalField ))
gEditor{|Char|} = bijectEditorWrite toString (\c -> c.[0]) $ bijectEditorValue toString (\c -> c.[0]) (selectByMode
textView
(withDynamicHintAttributes "single character" (withEditModeAttr textField <<@ boundedlengthAttr 1 1))
(withDynamicHintAttributes "single character" (withEditModeAttr textField <<@ boundedlengthAttr 1 1)))
gEditor{|Int|} = selectByMode view edit edit
where
view = ignoreEditorWrites $ bijectEditorValue toString toInt textView
edit = withDynamicHintAttributes "whole number" $ withEditModeAttr integerField
gEditor{|Real|} = selectByMode view edit edit
where
view = ignoreEditorWrites $ bijectEditorValue toString toReal textView
edit = withDynamicHintAttributes "decimal number" $ withEditModeAttr decimalField
gEditor{|Char|} = bijectEditorValue toString (\c -> c.[0]) $ selectByMode view edit edit
where
view = ignoreEditorWrites textView
edit
= bijectEditorWrite (maybe "" toString ) (\c -> if (size c == 1) (Just c.[0]) Nothing)
$ withDynamicHintAttributes "single character"
$ withEditModeAttr textField <<@ boundedlengthAttr 1 1
gEditor{|String|} = selectByMode
textView
(withDynamicHintAttributes "single line of text" (withEditModeAttr textField <<@ minlengthAttr 1))
(withDynamicHintAttributes "single line of text" (withEditModeAttr textField <<@ minlengthAttr 1))
gEditor{|Bool|} = selectByMode (checkBox <<@ enabledAttr False) checkBox checkBox
gEditor{|String|} = selectByMode view edit edit
where
view = ignoreEditorWrites textView
edit
= bijectEditorWrite (fromMaybe "") Just
$ withDynamicHintAttributes "single line of text"
$ withEditModeAttr textField <<@ minlengthAttr 1
gEditor{|Bool|}
= bijectEditorWrite (fromMaybe False) Just
$ selectByMode (checkBox <<@ enabledAttr False) checkBox checkBox
gEditor{|[]|} ex _ tjx _ = listEditor_ tjx (Just (const Nothing)) True True (Just (\l -> pluralisen English (length l) "item")) ex
gEditor{|[]|} ex _ tjx _
= bijectEditorWrite (const []) (\l -> Just [x \\ Just x <- l])
$ listEditor_ tjx (Just (const Nothing)) True True (Just (\l -> pluralisen English (length l) "item")) ex
gEditor{|()|} = emptyEditorWithDefaultInEnterMode ()
gEditor{|(->)|} _ _ tjx fjx _ _ tjy fjy =
......@@ -564,6 +577,6 @@ gEditor{|(->)|} _ _ tjx fjx _ _ tjy fjy =
(JSONDecode{|* -> * -> *|} fjx fjy)
"A function cannot be entered."
gEditor{|Dynamic|} = emptyEditorWithErrorInEnterMode "A dynamic value cannot be entered."
gEditor{|HtmlTag|} = htmlView
gEditor{|HtmlTag|} = ignoreEditorWrites htmlView
derive gEditor JSONNode, Either, MaybeError, (,), (,,), (,,,), (,,,,), (,,,,,), Timestamp, Map
......@@ -80,7 +80,7 @@ comapEditorValue :: !(b -> a) !(Editor a w) -> Editor b w | JSONEncode{|*|}, JSO
/**
* Select part of a larger datastructure and map writes back
*/
lensEditor :: !(b -> a) !(b wa -> Maybe wb) !(Editor a wa) -> Editor b wb | JSONEncode{|*|}, JSONDecode{|*|} b
lensEditor :: !(b -> a) !((Maybe b) wa -> Maybe wb) !(Editor a wa) -> Editor b wb | JSONEncode{|*|}, JSONDecode{|*|} b
......@@ -243,7 +243,7 @@ where
editorOnRefresh dp (tof newB) st vst
valueFromState mbB _ = mbB
lensEditor :: !(b -> a) !(b wa -> Maybe wb) !(Editor a wa) -> Editor b wb | JSONEncode{|*|}, JSONDecode{|*|} b
lensEditor :: !(b -> a) !((Maybe b) wa -> Maybe wb) !(Editor a wa) -> Editor b wb | JSONEncode{|*|}, JSONDecode{|*|} b
lensEditor tof fromf {Editor|genUI=editorGenUI,onEdit=editorOnEdit,onRefresh=editorOnRefresh,valueFromState=editorValueFromState}
= editorModifierWithStateToEditor
{EditorModifierWithState|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}
......@@ -260,10 +260,5 @@ where
= appFst (fmap (\(ui, st, mbw) -> (ui, mbB, st, modWrite mbB mbw)))
$ editorOnRefresh dp (tof newB) st vst
modWrite Nothing Nothing = Nothing
modWrite Nothing (Just wa) = Nothing //FIXME: We can't pass along the write without a 'b' value
modWrite (Just b) (Just wa) = fromf b wa
modWrite (Just b) Nothing = Nothing
modWrite mbb mbwa = maybe Nothing (fromf mbb) mbwa
valueFromState mbB st = mbB
......@@ -277,7 +277,7 @@ where
compute :: !String a -> Task a | iTask a
compute s a = Hint s @>> enterInformation [EnterUsing id ed] >>~ \_->return a
where
ed :: Editor Bool Bool
ed :: Editor Bool (Maybe Bool)
ed = fieldComponent UILoader Nothing (\_ _ -> True)
valToMaybe :: (TaskValue a) -> Maybe a
......
......@@ -51,14 +51,16 @@ interactRW :: (Editor r w) !(sds () (Maybe r) w) -> Task r | iTask r & TC r & TC
interactRW editor sds = Task
(readRegisterCompletely sds NoValue
(\event -> mkUIIfReset event (asyncSDSLoaderUI Read))
(evalInteractInit sds editor modifyCompletely)
(evalInteractInit sds editor writeCompletely)
)
interactR :: (Editor r w) (sds () (Maybe r) w) -> Task r | iTask r & TC r & TC w & Registrable sds
interactR editor sds = Task
(readRegisterCompletely sds NoValue
(\event->mkUIIfReset event (asyncSDSLoaderUI Read))
(evalInteractInit sds editor (\_ _->modifyCompletely (\()->undef) nullShare))
(\event-> mkUIIfReset event (asyncSDSLoaderUI Read))
(evalInteractInit sds editor dontWrite)
)
where
dontWrite _ _ _ continue event opts iworld = continue event opts iworld
//This initializes the editor state and continues with the actual interact task
evalInteractInit sds editor writefun mbr event evalOpts=:{TaskEvalOpts|taskId} iworld
......@@ -70,11 +72,10 @@ evalInteract ::
(sds () (Maybe r) w)
(Editor r w)
(
((Maybe r) -> w)
w
(sds () (Maybe r) w)
(TaskValue r)
(Event -> UIChange)
(w -> Event -> TaskEvalOpts -> *IWorld -> *(TaskResult r, *IWorld))
(Event -> TaskEvalOpts -> *IWorld -> *(TaskResult r, *IWorld))
Event
TaskEvalOpts
*IWorld
......@@ -92,11 +93,11 @@ evalInteract mbr (Just st) sds editor writefun event=:(EditEvent eTaskId name ed
# (res, iworld) = withVSt taskId (editor.Editor.onEdit [] (s2dp name,edit) st) iworld
= case res of
Ok (change, st, mbw) = case mbw of
//We have an update function
Just w = writefun (const w) sds NoValue (\_->change)
//We have a value to write to the shared state
Just w = writefun w sds NoValue
// We cannot just do this because this will loop endlessly:
// Therefore we delay it by returning the continuation in a value instead of directly:
(\w event {TaskEvalOpts|lastEval} iworld ->
(\event {TaskEvalOpts|lastEval} iworld ->
(ValueResult
(maybe NoValue (\r -> Value r False) mbr)
(mkTaskEvalInfo lastEval)
......@@ -114,7 +115,6 @@ evalInteract mbr (Just st) sds editor writefun event=:(EditEvent eTaskId name ed
, iworld)
Error e = (ExceptionResult (exception e), iworld)
evalInteract mbr mst sds editor writefun ResetEvent evalOpts=:{taskId,lastEval} iworld
= case withVSt taskId (editor.Editor.genUI 'DM'.newMap [] (maybe Enter (\r -> Update r) mbr)) iworld of
(Error e, iworld) = (ExceptionResult (exception e), iworld)
......@@ -129,6 +129,7 @@ evalInteract mbr mst sds editor writefun ResetEvent evalOpts=:{taskId,lastEval}
evalInteract mbr Nothing sds editor writefun event=:(RefreshEvent taskIds _) evalOpts=:{taskId,lastEval} iworld
= (ExceptionResult (exception "corrupt editor state"), iworld)
evalInteract mbr (Just st) sds editor writefun event=:(RefreshEvent taskIds _) evalOpts=:{taskId,lastEval} iworld | 'DS'.member taskId taskIds
= readRegisterCompletely sds (maybe NoValue (\r -> Value r False) mbr) (\e->mkUIIfReset e (asyncSDSLoaderUI Read))
(\mbr event evalOpts iworld
......@@ -138,8 +139,8 @@ evalInteract mbr (Just st) sds editor writefun event=:(RefreshEvent taskIds _) e
= case mbChange of
(Ok (change, st, mbw), iworld)
= case mbw of
Just w = writefun (const w) sds NoValue (\_->change)
(\_-> evalInteract mbr (Just st) sds editor writefun)
Just w = writefun w sds NoValue
(evalInteract mbr (Just st) sds editor writefun)
event evalOpts iworld
Nothing
= (ValueResult
......@@ -159,4 +160,3 @@ evalInteract mbr mst sds editor writefun event {lastEval} iworld
NoChange
(Task (evalInteract mbr mst sds editor writefun))
, iworld)
......@@ -10,15 +10,15 @@ from Data.Functor import class Functor
/*** General input/update/output tasks ***/
:: ViewOption a
= E.v: ViewAs (a -> v) & iTask v
| E.v: ViewUsing (a -> v) (Editor v v) & iTask v
| E.v: ViewUsing (a -> v) (Editor v (Maybe v)) & iTask v
:: EnterOption a
= E.v: EnterAs (v -> a) & iTask v
| E.v: EnterUsing (v -> a) (Editor v v) & iTask v
| E.v: EnterUsing (v -> a) (Editor v (Maybe v)) & iTask v
:: UpdateOption a
= E.v: UpdateAs (a -> v) (a v -> a) & iTask v
| E.v: UpdateUsing (a -> v) (a v -> a) (Editor v v) & iTask v
| E.v: UpdateUsing (a -> v) (a v -> a) (Editor v (Maybe v)) & iTask v
/**
* When using an shared data you have to supply an additional conflict
......@@ -32,8 +32,8 @@ from Data.Functor import class Functor
*/
:: UpdateSharedOption a b
= E.v: UpdateSharedAs (a -> v) (a v -> b) (v (Maybe v) -> Maybe v) & iTask v
| E.v: UpdateSharedUsing (a -> v) (a v -> b) (v (Maybe v) -> Maybe v) (Editor v v) & iTask v
| E.v: UpdateSharedUsingAuto (a -> Maybe v) (a v -> b) (v (Maybe v) -> Maybe v) (Editor v v) & iTask v
| E.v: UpdateSharedUsing (a -> v) (a v -> b) (v (Maybe v) -> Maybe v) (Editor v (Maybe v)) & iTask v
| E.v: UpdateSharedUsingAuto (a -> Maybe v) (a v -> b) (v (Maybe v) -> Maybe v) (Editor v (Maybe v)) & iTask v
//Selection in arbitrary containers (explicit identification is needed)
:: SelectOption c s
......
......@@ -94,7 +94,7 @@ findSelection target options idxs = target <$> getItems options idxs
enterInformation :: ![EnterOption m] -> Task m | iTask m
enterInformation options = enterInformation` (enterEditor options)
enterInformation` (EnterUsing fromf editor)
= withShared Nothing (interactRW (ignoreEditorReads (lensEditor id (\_ w -> Just $ Just $ fromf w) editor)))
= withShared Nothing (interactRW (ignoreEditorReads (lensEditor id (\_ mbw -> Just $ fmap fromf mbw) editor)))
viewInformation :: ![ViewOption m] !m -> Task m | iTask m
viewInformation options m = viewInformation` (viewEditor options) m
......@@ -104,12 +104,13 @@ viewInformation` (ViewUsing tof editor) m
updateInformation :: ![UpdateOption m] m -> Task m | iTask m
updateInformation options m = updateInformation` (updateEditor options) m
updateInformation` (UpdateUsing tof fromf editor) m
= withShared (Just m) (interactRW (lensEditor tof (\m v -> Just $ Just $ fromf m v) editor))
= withShared (Just m) (interactRW (lensEditor tof (\mbm mbv -> maybe Nothing (\m -> Just $ fmap (fromf m) mbv) mbm) editor))
updateSharedInformation :: ![UpdateSharedOption r w] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds
updateSharedInformation options sds = updateSharedInformation` (updateSharedEditor options) sds
updateSharedInformation` (UpdateSharedUsing tof fromf conflictf editor) sds
= interactRW (lensEditor tof (\r w -> Just (fromf r w)) editor) (mapRead Just sds)
= interactRW (lensEditor tof (\mbr mbw -> maybe Nothing (\r -> fmap (fromf r) mbw) mbr) editor) (mapRead Just sds)
updateSharedInformation` (UpdateSharedUsingAuto tof fromf conflictf editor) sds = abort "FIXME: UpdateSharedUsingAuto"
/* //TODO: Fix the 'Auto' choice problem separately
......@@ -133,7 +134,8 @@ updateInformationWithShared :: ![UpdateSharedOption (r,m) m] !(sds () r w) m ->
updateInformationWithShared options sds m = updateInformationWithShared` (updateSharedEditor options) sds m
updateInformationWithShared` (UpdateSharedUsing tof fromf conflictf editor) sds m
= withShared m \sdsm ->
interactRW (lensEditor tof (\r w -> Just (fromf r w)) editor) (mapRead Just (sds |*< sdsm)) @ snd
interactRW (lensEditor tof (\mbr mbw -> maybe Nothing (\r -> fmap (fromf r) mbw) mbr) editor)
(mapRead Just (sds |*< sdsm)) @ snd
editSelection :: ![SelectOption c a] c [Int] -> Task [a] | iTask a
editSelection options container sel = editSelection` (selectAttributes options) (selectEditor options) container sel
......@@ -146,7 +148,7 @@ editSelectionWithShared options sharedContainer initSel = editSelectionWithShare
editSelectionWithShared` attributes (SelectUsing toView fromView editor) sharedContainer initSel
= withShared [] \selsds -> let state = sharedContainer |*< selsds in
upd (\(c,_) -> initSel c) state //Initialize the selection
>-| interactRW (lensEditor (\(c,r) -> (toView c,r)) (\_ s -> Just s) (withAttributes attributes editor)) (mapRead Just state)
>-| interactRW (lensEditor (\(c,r) -> (toView c,r)) (\_ w -> Just w) (withAttributes attributes editor)) (mapRead Just state)
@ (\(container,sel) -> fromView container sel)
editSharedSelection :: ![SelectOption c a] c (Shared sds [Int]) -> Task [a] | iTask c & iTask a & RWShared sds
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment