DynamicEditor.icl 29.7 KB
Newer Older
1
implementation module iTasks.Extensions.Editors.DynamicEditor
Steffen Michels's avatar
Steffen Michels committed
2 3 4 5 6 7 8 9

import StdEnv => qualified foldl
import StdMisc, Data.Tuple, Text, Data.Maybe, Text.GenPrint
from StdFunc import seq, flip
from Data.Tuple import appFst
import iTasks, iTasks.UI.Definition, iTasks.UI.Editor.Common, iTasks.UI.Editor.Modifiers
import qualified Data.Map as Map
from Data.Func import $
Steffen Michels's avatar
Steffen Michels committed
10
from Data.List import zip4, intersperse
Steffen Michels's avatar
Steffen Michels committed
11 12 13 14 15 16 17 18
import Data.Functor

:: DynamicCons =
    { consId           :: !DynamicConsId
    , label            :: !String
    , builder          :: !DynamicConsBuilder
    , showIfOnlyChoice :: !Bool
    , useAsDefault     :: !Bool
19
    , uiAttributes     :: !UIAttributes
20
    , labels           :: ![Maybe String]
Steffen Michels's avatar
Steffen Michels committed
21 22 23 24 25 26 27 28 29 30 31
    }

(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
(<<@@@) cons opt = tunedDynamicConsEditor opt cons

(@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons
(@@@>>) opt cons = cons <<@@@ opt

tunedDynamicConsEditor :: !DynamicConsOption !DynamicCons -> DynamicCons
tunedDynamicConsEditor HideIfOnlyChoice cons = {cons & showIfOnlyChoice = False}
tunedDynamicConsEditor UseAsDefault     cons = {cons & useAsDefault = True}
32 33 34
tunedDynamicConsEditor (ApplyCssClasses classes) cons =
	{cons & uiAttributes = 'Map'.union (classAttr classes) cons.uiAttributes}
tunedDynamicConsEditor (AddLabels labels) cons = {cons & labels = labels}
Steffen Michels's avatar
Steffen Michels committed
35 36 37 38 39 40 41 42 43 44

functionCons :: !String !String !a -> DynamicCons | TC a
functionCons consId label func = functionConsDyn consId label (dynamic func)

functionConsDyn :: !String !String !Dynamic -> DynamicCons
functionConsDyn consId label func = { consId           = consId
                                    , label            = label
                                    , builder          = FunctionCons func
                                    , showIfOnlyChoice = True
                                    , useAsDefault     = False
45
                                    , uiAttributes     = 'Map'.newMap
46
                                    , labels           = []
Steffen Michels's avatar
Steffen Michels committed
47 48 49 50 51 52 53 54 55 56 57
                                    }

listCons :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b
listCons consId label func = listConsDyn consId label (dynamic func)

listConsDyn :: !String !String !Dynamic -> DynamicCons
listConsDyn consId label func = { consId           = consId
                                , label            = label
                                , builder          = ListCons func
                                , showIfOnlyChoice = True
                                , useAsDefault     = False
58
                                , uiAttributes     = 'Map'.newMap
59
                                , labels           = []
Steffen Michels's avatar
Steffen Michels committed
60 61 62 63 64 65 66 67 68
                                }

customEditorCons :: !String !String !(Editor a) -> DynamicCons
                  | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a
customEditorCons consId label editor = { consId           = consId
                                       , label            = label
                                       , builder          = CustomEditorCons editor
                                       , showIfOnlyChoice = True
                                       , useAsDefault     = False
69
                                       , uiAttributes     = 'Map'.newMap
70
                                       , labels           = []
Steffen Michels's avatar
Steffen Michels committed
71 72 73 74
                                       }

// TODO: don't use aborts here
toValue :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a
75
toValue  dynEditor dynEditorValue = case toValueDyn dynEditor dynEditorValue of
Steffen Michels's avatar
Steffen Michels committed
76 77
    (v :: a^) = v
    _         = abort "corrupt dynamic editor value"
78 79 80

toValueDyn :: !(DynamicEditor a) !(DynamicEditorValue a) -> Dynamic | TC a
toValueDyn (DynamicEditor elements) (DynamicEditorValue cid val) = toValue` (cid, val)
Steffen Michels's avatar
Steffen Michels committed
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
where
    toValue` :: !(!DynamicConsId, !DEVal) -> Dynamic
    toValue` (cid, val) = case val of
        DEApplication args = case cons.builder of
            FunctionCons fbuilder = toValueFunc fbuilder args
            ListCons     lbuilder = toValueList lbuilder args
            _                     = abort "corrupt dynamic editor value"
        DEJSONValue json = case cons.builder of
            CustomEditorCons editor = toValueGen editor json
            _                       = abort "corrupt dynamic editor value"
    where
        (cons, _) = consWithId cid $ consesOf elements

    toValueFunc :: !Dynamic ![(!DynamicConsId, !DEVal)] -> Dynamic
    toValueFunc v [] = v
    toValueFunc f [x : xs] = case (f, toValue` x) of
        (f :: a -> b, x :: a) = toValueFunc (dynamic (f x)) xs
        _                     = abort "corrupt dynamic editor value"

    toValueGen :: (Editor a) !JSONNode -> Dynamic | JSONDecode{|*|}, TC a
    toValueGen editor json = dynamic (fromJSON` editor json)
    where
        fromJSON` :: (Editor a) !JSONNode -> a | JSONDecode{|*|} a
        fromJSON` _ json = fromMaybe (abort "corrupt dynamic editor value") $ fromJSON json

    toValueList :: !Dynamic ![(!DynamicConsId, !DEVal)] -> Dynamic
    toValueList (f :: [a] -> b) [] = dynamic (f [])
    toValueList f args=:[fst : _] = case (f, toValue` fst) of
        (g :: [a] -> b, _ :: a) -> dynamic (g $ fromDynList [toValue` val \\ val <- args])
        _                       -> abort "corrupt dynamic editor value"
    toValueList _ _ = abort "corrupt dynamic editor value"

    fromDynList :: ![Dynamic] -> [a] | TC a
    fromDynList dyns = fromDynList` dyns []
    where
        fromDynList` [] acc = reverse acc
        fromDynList` [(a :: a^) : dyns] acc = fromDynList` dyns [a:acc]
        fromDynList` _ _ = abort "corrupt dynamic editor value"

dynEditorValToString :: !(DynamicEditor a) !(DynamicEditorValue a) -> String
dynEditorValToString (DynamicEditor elements) (DynamicEditorValue cid val) =
	concat $ withCapitalisedFirstLetter $
		dropWhile (\s -> textSize (trim s) == 0) $ reverse [".": dynEditorValToString` (cid, val) []]
where
	withCapitalisedFirstLetter [firstString: rest] = [upperCaseFirst firstString: rest]

    dynEditorValToString` :: !(!DynamicConsId, !DEVal) ![String] -> [String]
    dynEditorValToString` (cid, val) accum = case val of
        DEApplication args = case cons.builder of
            FunctionCons fbuilder = 'StdEnv'.foldl (flip dynEditorValToString`)
                                                   [" ", cons.DynamicCons.label : accum]
                                                   args
            ListCons lbuilder
                # listElStrs = flatten $ intersperse [" ", cons.DynamicCons.label] $
                                                     (\arg -> dynEditorValToString` arg []) <$> reverse args
                = listElStrs ++ [" "] ++ accum
            _ = abort "corrupt dynamic editor value"
        DEJSONValue json = case cons.builder of
            CustomEditorCons editor = [ " ", toStringGen editor json
                                      , " ", cons.DynamicCons.label
                                      : accum
                                      ]
            _ = abort "corrupt dynamic editor value"
    where
        (cons, _) = consWithId cid $ consesOf elements

    toStringGen :: (Editor a) !JSONNode -> String | gText{|*|}, JSONDecode{|*|}  a
    toStringGen editor json = toSingleLineText $ fromJSON` editor json
    where
        fromJSON` :: (Editor a) !JSONNode -> a | JSONDecode{|*|} a
        fromJSON` _ json = fromMaybe (abort "corrupt dynamic editor value") $ fromJSON json

derive class iTask DynamicEditorValue, DEVal

155
:: E = E.a: E (Editor (DynamicEditorValue a)) & TC a
Steffen Michels's avatar
Steffen Michels committed
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
:: ConsType = Function | List | CustomEditor

derive JSONEncode ConsType
derive JSONDecode ConsType

parametrisedDynamicEditor
	:: !(p -> DynamicEditor a) -> Editor (!p, !DynamicEditorValue a)
	| TC a & gEq{|*|}, JSONEncode{|*|}, JSONDecode{|*|} p
parametrisedDynamicEditor editor
	= compoundEditorToEditor
		{CompoundEditor| genUI = genUI, onEdit = onEdit, onRefresh = onRefresh, valueFromState = valueFromState}
where
	genUI attr dp mode vst
		= case editModeValue mode of
			Nothing
				= abort "Enter mode not supported by parametrisedDynamicEditor.\n"
			Just (p, _)
				= appFst
					(fmap $ appSnd3 \st -> (p, st))
					((dynamicCompoundEditor $ editor p).CompoundEditor.genUI attr dp (mapEditMode snd mode) vst)

	onEdit dp event (p, mbSt) childSts vst
		= appFst
			(fmap $ appSnd3 \st -> (p, st))
			((dynamicCompoundEditor $ editor p).CompoundEditor.onEdit dp event mbSt childSts vst)

	onRefresh dp (p, new) st=:(p`, mbSt) childSts vst
		= appFst
			(fmap $ appSnd3 \st -> (p, st))
			((dynamicCompoundEditor $ editor p).CompoundEditor.onRefresh dp new mbSt childSts vst)

	valueFromState (p, st) childSts
		= (\val -> (p, val)) <$> (dynamicCompoundEditor $ editor p).CompoundEditor.valueFromState st childSts


dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
dynamicEditor dynEditor = compoundEditorToEditor $ dynamicCompoundEditor dynEditor

194
// Bool element if state indicates whether the type is correct, i.e. the child types are matching
Steffen Michels's avatar
Steffen Michels committed
195
dynamicCompoundEditor
196
	:: !(DynamicEditor a) -> CompoundEditor (Maybe (!DynamicConsId, !ConsType, !Bool)) (DynamicEditorValue a) | TC a
Steffen Michels's avatar
Steffen Michels committed
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
dynamicCompoundEditor dynEditor=:(DynamicEditor elements)
	| not $ isEmpty duplicateIds
		= abort $ concat ["duplicate cons IDs in dynamic editor: ", printToString duplicateIds, "\n"]
	= {CompoundEditor| genUI = genUI, onEdit = onEdit, onRefresh = onRefresh, valueFromState = valueFromState}
where
    // conses with optional group labels
    conses :: [(!DynamicCons, !Maybe String)]
    conses = consesOf elements

    duplicateIds = duplicateIds` $ (\(b, _) -> b.consId) <$> conses
    where
		duplicateIds` [] = []
		duplicateIds` [x: xs]
			| isMember x xs = [x: duplicateIds` xs]
			| otherwise     = duplicateIds` xs

    genUI :: !UIAttributes !DataPath !(EditMode (DynamicEditorValue a)) !*VSt
214
          -> *(!MaybeErrorString (!UI, !Maybe (!DynamicConsId, !ConsType, !Bool), ![EditState]), !*VSt)
Steffen Michels's avatar
Steffen Michels committed
215 216 217 218
    genUI attr dp mode vst=:{VSt|taskId} = case mode of
        Enter = case matchingConses of
            [(onlyChoice, _)] | hideCons
                # (mbUis, _, type, _, vst) = genChildEditors dp onlyChoice.consId Enter vst
Steffen Michels's avatar
Steffen Michels committed
219
                # mbUis = ( \(uis, childSts) -> (uiContainer attr uis, Just (onlyChoice.consId, type, True), [nullState: childSts])
Steffen Michels's avatar
Steffen Michels committed
220 221 222 223 224 225 226 227 228
                          ) <$>
                          mbUis
                = (mbUis, vst)
            _ = case filter (\(cons, _) -> cons.useAsDefault) matchingConses of
                [(defaultChoice, _): _]
                    # (mbUis, idx, type, label, vst) = genChildEditors dp defaultChoice.consId Enter vst
                    = case mbUis of
                        Ok (uis, childSts)
                            | hideCons
Steffen Michels's avatar
Steffen Michels committed
229
                                = (Ok (uiContainer attr uis, Just (defaultChoice.consId, type, True), [nullState: childSts]), vst)
Steffen Michels's avatar
Steffen Michels committed
230 231
                            | otherwise
                                # (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
Steffen Michels's avatar
Steffen Michels committed
232
                                = ( Ok ( uiContainer attr [consChooseUI: uis]
233
                                       , Just (defaultChoice.consId, type, True)
Steffen Michels's avatar
Steffen Michels committed
234 235 236 237 238 239 240
                                       , [chooseSt: childSts]
                                       )
                                  , vst
                                  )
                        Error e = (Error e, vst)
                _
                    # (consChooseUI, chooseSt) = genConsChooseUI taskId dp Nothing
Steffen Michels's avatar
Steffen Michels committed
241
                    = (Ok (uiContainer attr [consChooseUI], Nothing, [chooseSt]), vst)
Steffen Michels's avatar
Steffen Michels committed
242 243 244
		Update Undefined = genUI attr dp Enter vst
        Update (DynamicEditorValue cid val)
            # (mbUis, idx, type, label, vst) = genChildEditors dp cid (Update val) vst
245
			# (cons, _)                      = consWithId cid matchingConses
Steffen Michels's avatar
Steffen Michels committed
246 247
            = case mbUis of
                Ok (uis, childSts)
248
					# attrs = 'Map'.union (withContainerClassAttr cons.uiAttributes) attr
Steffen Michels's avatar
Steffen Michels committed
249
                    | hideCons
250
                        = (Ok (uiContainer attrs uis, Just (cid, type, True), [nullState: childSts]), vst)
Steffen Michels's avatar
Steffen Michels committed
251 252
                    | otherwise
                        # (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
253
                        = (Ok (uiContainer attrs [consChooseUI: uis], Just (cid, type, True), [chooseSt: childSts]), vst)
Steffen Michels's avatar
Steffen Michels committed
254 255 256 257
                Error e = (Error e, vst)

        View (DynamicEditorValue cid val)
            # (mbUis, _, type, label, vst) = genChildEditors dp cid (View val) vst
258
			# (cons, _) = consWithId cid matchingConses
Steffen Michels's avatar
Steffen Michels committed
259 260
            = case mbUis of
                Ok (uis, childSts)
261
					# attrs = 'Map'.union (withContainerClassAttr cons.uiAttributes) attr
Steffen Michels's avatar
Steffen Michels committed
262
                    | hideCons
263
                        = (Ok (uiContainer attrs uis, Just (cid, type, True), [nullState: childSts]), vst)
Steffen Michels's avatar
Steffen Michels committed
264 265
                    | otherwise
                        # consChooseUI = uia UITextView $ valueAttr $ JSONString label
266
                        = (Ok (uiContainer attrs [consChooseUI: uis], Just (cid, type, True), [nullState: childSts]), vst)
Steffen Michels's avatar
Steffen Michels committed
267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
                Error e = (Error e, vst)

    genConsChooseUI taskId dp mbSelectedCons = (consChooseUI, consChooseSt)
    where
        consOptions = [ JSONObject $ [("id",JSONInt i),("text",JSONString cons.DynamicCons.label)] ++
                                     maybe [] (\label -> [("grouplabel", JSONString label)]) mbGroupLabel
                      \\ (cons, mbGroupLabel) <- matchingConses & i <- [0..]
                      ]
        consChooseUI = uia UIDropdown
                           ( 'Map'.put "width" JSONNull $
                             choiceAttrs taskId (editorId dp) (maybe [] (\x -> [x]) mbSelectedCons) consOptions
                           )
        consChooseSt = LeafState {touched=False,state=maybe JSONNull (\x -> JSONInt x) mbSelectedCons}

    onEdit :: !DataPath
              !(!DataPath, !JSONNode)
283
              !(Maybe (!DynamicConsId, !ConsType, !Bool))
Steffen Michels's avatar
Steffen Michels committed
284 285
              ![EditState]
              !*VSt
286
           -> *( !MaybeErrorString (!UIChange, !Maybe (!DynamicConsId, !ConsType, !Bool), ![EditState])
Steffen Michels's avatar
Steffen Michels committed
287 288 289
               , !*VSt
               )
    // new builder is selected: create a UI for the new builder
Steffen Michels's avatar
Steffen Michels committed
290
    onEdit dp ([], JSONArray [JSONInt builderIdx]) st [_: childrenSts] vst
Steffen Michels's avatar
Steffen Michels committed
291 292 293 294 295 296 297 298 299
        | builderIdx < 0 || builderIdx >= length matchingConses
            = (Error "Dynamic editor selection out of bounds", vst)
        # (cons, _) = matchingConses !! builderIdx
        # (mbRes, _, type, _, vst) = genChildEditors dp cons.consId Enter vst
        = case mbRes of
            Ok (uis, childSts)
                // insert new UIs for arguments
                # inserts = [(i, InsertChild ui) \\ ui <- uis & i <- [1..]]
                # removals = removeNChildren $ length childrenSts
300
                // add "itasks-container" classes as this class always has to be present for containers
301
                # uiAttrs = withContainerClassAttr cons.uiAttributes
Steffen Michels's avatar
Steffen Michels committed
302 303 304 305 306
				# attrChange  = if (typeWasInvalid st) removeErrorIconAttrChange []
				# childChange =
						if (typeWasInvalid st) removeErrorIconChange []
					++
						[(0, ChangeChild $ ChangeUI (uncurry SetAttribute <$> 'Map'.toList uiAttrs) (removals ++ inserts))]
Steffen Michels's avatar
Steffen Michels committed
307
                # builderChooseState = LeafState {touched = True, state = JSONInt $ length uis}
Steffen Michels's avatar
Steffen Michels committed
308
                = (Ok (ChangeUI attrChange childChange, Just (cons.consId, type, True), [builderChooseState: childSts]), vst)
Steffen Michels's avatar
Steffen Michels committed
309 310
            Error e = (Error e, vst)

311
    // other events targeted directly at this cons
Steffen Michels's avatar
Steffen Michels committed
312
    onEdit dp ([],e) st [_: childSts] vst
Steffen Michels's avatar
Steffen Michels committed
313 314
        | e =: JSONNull || e =: (JSONArray []) // A null or an empty array are accepted as a reset events
            //If necessary remove the fields of the previously selected cons
Steffen Michels's avatar
Steffen Michels committed
315 316 317 318 319 320
            # attrChange  = if (typeWasInvalid st) removeErrorIconAttrChange []
            # childChange =
					if (typeWasInvalid st) removeErrorIconChange []
				++
					[(0, ChangeChild $ ChangeUI [] $ removeNChildren $ length childSts)]
            = (Ok (ChangeUI attrChange childChange, Nothing, [nullState]), vst)
Steffen Michels's avatar
Steffen Michels committed
321 322 323 324
        | otherwise
            = (Error $ concat ["Unknown dynamic editor select event: '", toString e, "'"], vst)

    // update is targeted somewhere inside this value    
325
    onEdit dp ([argIdx: tp], e) (Just (cid, type, typeWasCorrect)) childSts vst
Steffen Michels's avatar
Steffen Michels committed
326 327 328 329 330 331 332 333 334
        # (cons, _) = consWithId cid matchingConses
        # (res, vst) = case cons.builder of
            FunctionCons fbuilder
                # children = childrenEditors fbuilder
                | argIdx < 0 || argIdx >= length children
                    = (Error "Edit event for dynamic editor has invalid path", vst)
                # (E editor) = children !! argIdx
                = editor.Editor.onEdit (dp ++ [argIdx]) (tp, e) (childSts !! (argIdx + 1)) vst
            ListCons lbuilder
335
                = (listBuilderEditor lbuilder).Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
Steffen Michels's avatar
Steffen Michels committed
336 337 338 339
            CustomEditorCons editor
                = editor.Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
        = case res of
            Ok (change, childSt)
340
				# change = ChangeUI mbErrorIconAttrChange $ [(0, ChangeChild $ ChangeUI [] [(argIdx + if hideCons 0 1, ChangeChild change)])] ++ mbErrorIconChange
341 342 343
				// replace state for this child
				= (Ok (change, Just (cid, type, isOk typeIsCorrect), childSts`), vst)
			where
344 345
				(mbErrorIconChange, mbErrorIconAttrChange) = mbErrorIconUpd
				mbErrorIconUpd
346
					| typeWasCorrect && isError typeIsCorrect =
347 348 349
						( [(1, InsertChild errorIcon)]
						, [SetAttribute "class" $ JSONArray [JSONString "itasks-container", JSONString "itasks-horizontal", JSONString "itasks-dynamic-editor-error"]]
						)
350 351 352
					with
						errorIcon =
							UI
Steffen Michels's avatar
Steffen Michels committed
353 354 355 356 357 358 359
								UIContainer
								('Map'.singleton "class" $ JSONString "itasks-dynamic-editor-icon-error-container")
								[ UI
									UIIcon
									('Map'.union (iconClsAttr "icon-invalid") (tooltipAttr $ fromError typeIsCorrect))
									[]
								]
360
					| not typeWasCorrect && isOk typeIsCorrect =
Steffen Michels's avatar
Steffen Michels committed
361
						(removeErrorIconChange, removeErrorIconAttrChange)
362
					| otherwise = ([], [])
363 364
				typeIsCorrect = childTypesAreMatching cons.builder (drop 1 childSts`)
				childSts` = updateAt (argIdx + 1) childSt childSts
Steffen Michels's avatar
Steffen Michels committed
365 366 367 368
            Error e = (Error e, vst)

    onEdit _ _ _ _ vst = (Error "Invalid edit event for dynamic editor.", vst)

Steffen Michels's avatar
Steffen Michels committed
369 370 371 372 373
	typeWasInvalid (Just (_, _, False)) = True
	typeWasInvalid _                    = False

	removeErrorIconChange     = [(1, RemoveChild)]
	removeErrorIconAttrChange = [SetAttribute "class" $ JSONArray [JSONString "itasks-container", JSONString "itasks-horizontal"]]
374 375 376 377 378 379 380 381
	// add "itasks-container" classes as this class always has to be present for containers
	withContainerClassAttr attrs = 'Map'.alter (Just o addContainerClass) "class" attrs
	where
		addContainerClass :: !(Maybe JSONNode) -> JSONNode
		addContainerClass mbJSONClasses = JSONArray [JSONString "itasks-container": otherClasses]
		where
			otherClasses = maybe [] (\(JSONArray classes) -> classes) mbJSONClasses

Steffen Michels's avatar
Steffen Michels committed
382 383 384 385 386
    removeNChildren :: !Int -> [(!Int, !UIChildChange)]
    removeNChildren nrArgs = repeatn nrArgs (1, RemoveChild)

    onRefresh :: !DataPath
                 !(DynamicEditorValue a)
387
                 !(Maybe (!DynamicConsId, !ConsType, !Bool))
Steffen Michels's avatar
Steffen Michels committed
388 389 390
                 ![EditState]
                 !*VSt
              -> *( !MaybeErrorString ( !UIChange
391
                                      , !Maybe (!DynamicConsId, !ConsType, !Bool)
Steffen Michels's avatar
Steffen Michels committed
392 393 394 395 396 397
                                      , ![EditState]
                                      )
                  , !*VSt
                  )
	// TODO: how to get UI attributes?
	// TODO: fine-grained replacement
398 399 400 401 402 403 404
    onRefresh dp new st childSts vst
		| isNotChanged (valueFromState st childSts) new = (Ok (NoChange, st, childSts), vst)
		= appFst (fmap $ appFst3 ReplaceUI) $ genUI 'Map'.newMap dp (Update new) vst
	where
		isNotChanged (Just (DynamicEditorValue consId val)) (DynamicEditorValue consId` val`) =
			consId == consId` && val === val`
		isNotChanged _ _ = False
Steffen Michels's avatar
Steffen Michels committed
405 406 407 408 409 410

    // TODO: accept ID or index
    genChildEditors :: !DataPath !DynamicConsId !(EditMode DEVal) !*VSt
                    -> *(!MaybeErrorString (![UI], ![EditState]), Int, ConsType, String, !*VSt)
    genChildEditors dp cid mode vst= case cons.builder of
        FunctionCons fbuilder
Steffen Michels's avatar
Steffen Michels committed
411
            # (mbUis, vst) = genChildEditors` (reverse $ zip4 vals (childrenEditors fbuilder) (cons.labels ++ repeat Nothing) [0..]) [] [] vst
Steffen Michels's avatar
Steffen Michels committed
412 413 414
            = (mbUis, idx, type, cons.DynamicCons.label, vst)
        where
            genChildEditors` [] accUi accSt vst = (Ok (accUi, accSt), vst)
Steffen Michels's avatar
Steffen Michels committed
415
            genChildEditors` [(mbVal, E editor, mbLabel, i): children] accUi accSt vst =
416
                case editor.Editor.genUI 'Map'.newMap (dp ++ [i]) (maybe Enter (if viewMode View Update) mbVal) vst of
Steffen Michels's avatar
Steffen Michels committed
417
                    (Ok (ui, st), vst) = genChildEditors` children [withLabel mbLabel ui: accUi] [st: accSt] vst
Steffen Michels's avatar
Steffen Michels committed
418
                    (Error e,     vst) = (Error e, vst)
Steffen Michels's avatar
Steffen Michels committed
419 420 421 422
			where
				withLabel :: !(Maybe String) !UI -> UI
				withLabel (Just label) (UI type attrs item) = UI type ('Map'.union attrs $ labelAttr label) item
				withLabel Nothing      ui                   = ui
Steffen Michels's avatar
Steffen Michels committed
423 424 425 426 427 428 429 430 431

            vals :: [Maybe (DynamicEditorValue a)]
            vals = case editModeValue mode of
                // update or view mode
                Just (DEApplication children) = [Just $ DynamicEditorValue cid val \\ (cid, val) <- children]
                // enter mode
                _                             = repeat Nothing
        ListCons lbuilder
            # listEditorMode = mapEditMode (\(DEApplication listElems) -> listElems) mode
432
            # (mbUi, vst) = (listBuilderEditor lbuilder).Editor.genUI 'Map'.newMap (dp ++ [0]) listEditorMode vst
Steffen Michels's avatar
Steffen Michels committed
433 434 435 436 437
            = ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
        CustomEditorCons editor
            # editorMode = mapEditMode
                (\(DEJSONValue json) -> fromMaybe (abort "Invalid dynamic editor state") $ fromJSON json)
                mode
438
            # (mbUi, vst) = editor.Editor.genUI 'Map'.newMap (dp ++ [0]) editorMode vst
Steffen Michels's avatar
Steffen Michels committed
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491
            = ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
    where
        (cons, idx) = consWithId cid matchingConses
        type = case cons.builder of
            FunctionCons     _ = Function
            ListCons         _ = List
            CustomEditorCons _ = CustomEditor
        viewMode = mode =: View _
 
    hideCons = case matchingConses of
        [(onlyChoice, _)] | not onlyChoice.showIfOnlyChoice = True
        _                                                   = False

    matchingConses :: [(!DynamicCons, !Maybe String)]
    matchingConses = catMaybes $
        (\(cons, mbGroupLabel) -> (\cons` -> (cons`, mbGroupLabel)) <$> matchingCons dynEditor cons) <$> conses

    // first arg only used for type
    // packs matching conses, with possibly updated (= more specific) type
    matchingCons :: !(DynamicEditor a) !DynamicCons -> Maybe DynamicCons | TC a
    matchingCons dynEd cons=:{builder} = (\b -> {cons & builder = b}) <$> mbBuilder`
    where
        mbBuilder` = case builder of
            FunctionCons     fbuilder = matchf fbuilder
            CustomEditorCons editor   = matchc editor
            ListCons         lbuilder = matchl lbuilder

        // works for functions with upto 10 args
        // the type of the dynamic is updated by unifying the function result with the type produced by the editor
        matchf :: !Dynamic -> Maybe DynamicConsBuilder
        matchf b = case (b, dynamic dynEd) of
            (b :: a b c d e f g h i j -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c d e f g h i   -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c d e f g h     -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c d e f g       -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c d e f         -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c d e           -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c d             -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b c               -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a b                 -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b :: a                   -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            (b ::                        z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
            _                                                     = Nothing

        // custom editors do not allow for quantified variables, so no type update is required
        matchc e = case (dynamic e, dynamic dynEd) of
            (_ :: Editor a, _ :: DynamicEditor a) = Just $ CustomEditorCons e
            _                                     = Nothing

        matchl f = case (f, dynamic dynEd) of
            (f :: [a] -> b, _ :: DynamicEditor b) = Just $ ListCons (dynamic f)
            _                                     = Nothing

492 493
    listBuilderEditor :: !Dynamic -> Editor [(!DynamicConsId, !DEVal)]
    listBuilderEditor (lbuilder :: [a] -> b) = listEditor (Just $ const Nothing) True True Nothing childrenEd`
Steffen Michels's avatar
Steffen Michels committed
494 495 496 497 498 499 500 501
    where
        childrenEd  = childrenEditorList lbuilder
        childrenEd` = bijectEditorValue (\(cid, val)                   -> DynamicEditorValue cid val)
                                        (\(DynamicEditorValue cid val) -> (cid, val))
                                        childrenEd

        // first argument only used for type
        childrenEditorList :: ([a] -> b) -> Editor (DynamicEditorValue a) | TC a
502 503
        childrenEditorList _ = dynamicEditor (DynamicEditor elements)
    listBuilderEditor _ = abort "dynamic editors: invalid list builder value"
Steffen Michels's avatar
Steffen Michels committed
504

Steffen Michels's avatar
Steffen Michels committed
505
    uiContainer :: !UIAttributes ![UI] -> UI
506 507 508 509 510
    uiContainer attr uis =
		UI
			UIContainer
			('Map'.singleton "class" $ JSONArray [JSONString "itasks-container", JSONString "itasks-horizontal"])
			[UI UIRecord attr uis]
Steffen Michels's avatar
Steffen Michels committed
511

512 513
    valueFromState :: !(Maybe (!DynamicConsId, !ConsType, !Bool)) ![EditState] -> *Maybe (DynamicEditorValue a)
    valueFromState (Just (cid, CustomEditor, True)) [_: [editorSt]] =
Steffen Michels's avatar
Steffen Michels committed
514 515 516 517 518 519 520 521 522
        mapMaybe (DynamicEditorValue cid o DEJSONValue o toJSON`) $ editor.Editor.valueFromState editorSt
    where
        ({builder}, _) = consWithId cid conses

        // toJSON` is used to solve overloading, JSONEncode{|*|} is attached to CustomEditorCons
        (editor, toJSON`) = case builder of
            CustomEditorCons editor = (editor, toJSON)
            _                       = abort "corrupt dynamic editor state"

523
    valueFromState (Just (cid, type, True)) [_: childSts] =
Steffen Michels's avatar
Steffen Michels committed
524 525 526 527 528 529 530 531 532 533 534 535 536 537
        mapMaybe (\childVals -> DynamicEditorValue cid $ DEApplication childVals) $ childValuesFor childSts` []
    where
        childSts` = case (type, childSts) of
            (List, [CompoundState _ childSts]) = childSts
            (_,    childSts)                   = childSts

        childValuesFor :: ![EditState] ![(!DynamicConsId, !DEVal)]
                       -> Maybe [(!DynamicConsId, !DEVal)]
        childValuesFor [] acc = Just $ reverse acc
        childValuesFor [childSt: childSts] acc = case (dynamicEditor dynEditor).Editor.valueFromState childSt of
            Just (DynamicEditorValue childCid childVal) = childValuesFor childSts [(childCid, childVal): acc]
            _                                           = Nothing
    valueFromState _ _ = Nothing

538 539 540 541 542 543 544 545 546 547 548 549 550 551
	childrenEditors :: !Dynamic -> [E]
	childrenEditors (f :: a -> b) = [E $ dynamicEditorFstArg f : childrenEditors (dynamic (f undef))]
	where
		// first argument only used for type
		dynamicEditorFstArg :: (a -> b) -> Editor (DynamicEditorValue a) | TC a
		dynamicEditorFstArg _ = dynamicEditor $ DynamicEditor elements
	childrenEditors _         = []

	childTypesAreMatching :: !DynamicConsBuilder [EditState] -> MaybeErrorString ()
	childTypesAreMatching (FunctionCons cons) childStates =
		childTypesAreMatching` cons (childValueOf <$> zip2 childStates (childrenEditors cons))
	where
		childTypesAreMatching` :: !Dynamic ![Maybe Dynamic] -> MaybeErrorString ()
		childTypesAreMatching` _ [] = Ok ()
552 553 554
		childTypesAreMatching` cons [Nothing: otherArgs] =
			case cons of
				(cons` :: a -> z) = childTypesAreMatching` (dynamic cons` undef) otherArgs
555 556 557 558 559 560 561
		childTypesAreMatching` cons [Just nextArg: otherArgs] =
			case (cons, nextArg) of
				// `cons` undef` has type z`, which is z updated by unifying the type of the next arg
				(cons` :: a -> z, _ :: a) = childTypesAreMatching` (dynamic cons` undef) otherArgs
				_                         =
					Error $
						concat
562 563
							[ "Could not unify\n    ", toString (argOf $ typeCodeOfDynamic cons), "\nwith\n    "
							, toString (typeCodeOfDynamic nextArg)
564 565 566 567 568 569 570
							]

		childValueOf :: !(!EditState, !E) -> Maybe Dynamic
		childValueOf (state, E editor) = toValueDyn (DynamicEditor elements) <$> editor.Editor.valueFromState state

		argOf :: !TypeCode -> TypeCode
		argOf (TypeApp (TypeApp _ arg) _) = arg
571
		argOf (TypeScheme _ type)         = argOf type
572 573 574
	// only function conses can have not matching child types
	childTypesAreMatching _ _ = Ok ()

Steffen Michels's avatar
Steffen Michels committed
575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
consWithId :: !DynamicConsId ![(!DynamicCons, !Maybe String)] -> (!DynamicCons, !Int)
consWithId cid conses = case filter (\(({consId}, _), _) -> consId == cid) $ zip2 conses [0..] of
    [((cons, _), idx)] = (cons, idx)
    []                 = abort $ concat ["dynamic editor: cons not found: '",   cid, "'\n"]
    _                  = abort $ concat ["dynamic editor: duplicate conses: '", cid, "'\n"]

nullState :: EditState
nullState = LeafState {touched = True, state = JSONNull}

consesOf :: ![DynamicEditorElement] -> [(!DynamicCons, !Maybe String)]
consesOf elements = flatten $ consesOf <$> elements
where
    consesOf :: !DynamicEditorElement -> [(!DynamicCons, !Maybe String)]
    consesOf (DynamicCons cons)              = [(cons, Nothing)]
    consesOf (DynamicConsGroup label conses) = (\cons -> (cons, Just label)) <$> conses