old/dyneditors/DynamicEditor.icl

   1 implementation module DynamicEditor
   2
   3 import StdMisc, Data.Tuple, Text, Data.Maybe
   4 from StdFunc import seq, flip
   5 from Data.Tuple import appFst
   6 import iTasks, iTasks.UI.Definition, iTasks.UI.Editor.Common, iTasks.UI.Editor.Modifiers
   7 import qualified Data.Map as Map
   8 from Data.Func import $
   9 import Util
  10 from Data.List import zip3, intersperse
  11 import Data.Functor
  12
  13 :: DynamicCons =
  14     { consId           :: !DynamicConsId
  15     , label            :: !String
  16     , builder          :: !DynamicConsBuilder
  17     , showIfOnlyChoice :: !Bool
  18     }
  19
  20 (<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
  21 (<<@@@) cons HideIfOnlyChoice = {cons & showIfOnlyChoice = False}
  22
  23 (@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons
  24 (@@@>>) opt cons = cons <<@@@ opt
  25
  26 functionCons :: !String !String !a -> DynamicCons | TC a
  27 functionCons consId label func = functionConsDyn consId label (dynamic func)
  28
  29 functionConsDyn :: !String !String !Dynamic -> DynamicCons
  30 functionConsDyn consId label func = { consId           = consId
  31                                     , label            = label
  32                                     , builder          = FunctionCons func
  33                                     , showIfOnlyChoice = True
  34                                     }
  35
  36 listCons :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b
  37 listCons consId label func = listConsDyn consId label (dynamic func)
  38
  39 listConsDyn :: !String !String !Dynamic -> DynamicCons
  40 listConsDyn consId label func = { consId           = consId
  41                                 , label            = label
  42                                 , builder          = ListCons func
  43                                 , showIfOnlyChoice = True
  44                                 }
  45
  46 customEditorCons :: !String !String !(Editor a) -> DynamicCons | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a
  47 customEditorCons consId label editor = { consId           = consId
  48                                        , label            = label
  49                                        , builder          = CustomEditorCons editor
  50                                        , showIfOnlyChoice = True
  51                                        }
  52
  53 // TODO: don't use aborts here
  54 toValue :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a
  55 toValue (DynamicEditor dynEditor) (DynamicEditorValue cid val) = case toValue` (cid, val) of
  56     (v :: a^) = v
  57     _         = abort "corrupt dynamic editor value"
  58 where
  59     toValue` :: !(!DynamicConsId, !DEVal) -> Dynamic
  60     toValue` (cid, val) = case val of
  61         DEApplication args = case cons.builder of
  62             FunctionCons fbuilder = toValueFunc fbuilder args
  63             ListCons     lbuilder = toValueList lbuilder args
  64             _                     = abort "corrupt dynamic editor value"
  65         DEJSONValue json = case cons.builder of
  66             CustomEditorCons editor = toValueGen editor json
  67             _                       = abort "corrupt dynamic editor value"
  68     where
  69         (cons, _) = consWithId cid dynEditor
  70
  71     toValueFunc :: !Dynamic ![(!DynamicConsId, !DEVal)] -> Dynamic
  72     toValueFunc v [] = v
  73     toValueFunc f [x : xs] = case (f, toValue` x) of
  74         (f :: a -> b, x :: a) = toValueFunc (dynamic (f x)) xs
  75         _                     = abort "corrupt dynamic editor value"
  76
  77     toValueGen :: (Editor a) !JSONNode -> Dynamic | JSONDecode{|*|}, TC a
  78     toValueGen editor json = dynamic (fromJSON` editor json)
  79     where
  80         fromJSON` :: (Editor a) !JSONNode -> a | JSONDecode{|*|} a
  81         fromJSON` _ json = fromMaybe (abort "corrupt dynamic editor value") $ fromJSON json
  82
  83     toValueList :: !Dynamic ![(!DynamicConsId, !DEVal)] -> Dynamic
  84     toValueList (f :: [a] -> b) [] = dynamic (f [])
  85     toValueList f args=:[fst : _] = case (f, toValue` fst) of
  86         (g :: [a] -> b, _ :: a) -> dynamic (g $ fromDynList [toValue` val \\ val <- args])
  87         _                       -> abort "corrupt dynamic editor value"
  88     toValueList _ _ = abort "corrupt dynamic editor value"
  89
  90     fromDynList :: ![Dynamic] -> [a] | TC a
  91     fromDynList dyns = fromDynList` dyns []
  92     where
  93         fromDynList` [] acc = reverse acc
  94         fromDynList` [(a :: a^) : dyns] acc = fromDynList` dyns [a:acc]
  95         fromDynList` _ _ = abort "corrupt dynamic editor value"
  96
  97 dynEditorValToString :: !(DynamicEditor a) !(DynamicEditorValue a) -> String
  98 dynEditorValToString (DynamicEditor dynEditor) (DynamicEditorValue cid val) =
  99     concat $ reverse $ dynEditorValToString` (cid, val) []
 100 where
 101     dynEditorValToString` :: !(!DynamicConsId, !DEVal) ![String] -> [String]
 102     dynEditorValToString` (cid, val) accum = case val of
 103         DEApplication args = case cons.builder of
 104             FunctionCons fbuilder = foldl (flip dynEditorValToString`)
 105                                              [" ", cons.DynamicCons.label : accum]
 106                                              args
 107             ListCons lbuilder
 108                 # listElStrs = flatten $ intersperse [" ", cons.DynamicCons.label] $
 109                                                      (\arg -> dynEditorValToString` arg []) <$> reverse args
 110                 = listElStrs ++ [" "] ++ accum
 111             _ = abort "corrupt dynamic editor value"
 112         DEJSONValue json = case cons.builder of
 113             CustomEditorCons editor = [ " ", toStringGen editor json
 114                                       , " ", cons.DynamicCons.label
 115                                       : accum
 116                                       ]
 117             _ = abort "corrupt dynamic editor value"
 118     where
 119         (cons, _) = consWithId cid dynEditor
 120
 121     toStringGen :: (Editor a) !JSONNode -> String | gText{|*|}, JSONDecode{|*|}  a
 122     toStringGen editor json = toSingleLineText $ fromJSON` editor json
 123     where
 124         fromJSON` :: (Editor a) !JSONNode -> a | JSONDecode{|*|} a
 125         fromJSON` _ json = fromMaybe (abort "corrupt dynamic editor value") $ fromJSON json
 126
 127 derive class iTask DynamicEditorValue, DEVal
 128
 129 :: E = E.a: E (Editor (DynamicEditorValue a))
 130 :: ConsType = Function | List | CustomEditor
 131
 132 derive JSONEncode ConsType
 133 derive JSONDecode ConsType
 134
 135 dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
 136 dynamicEditor dynEditor=:(DynamicEditor conses)
 137     | duplicateIds = abort "duplicate cons IDs in dynamic editor"
 138     = compoundEditorToEditor
 139         {CompoundEditor| genUI = genUI, onEdit = onEdit, onRefresh = onRefresh, valueFromState = valueFromState}
 140 where
 141     duplicateIds = hasDup $ (\b -> b.consId) <$> conses
 142     where
 143         // TODO: use hasDup from platform as soon as available
 144         hasDup :: ![a] -> Bool | Eq a
 145         hasDup []     = False
 146         hasDup [x:xs] = isMember x xs || hasDup xs
 147
 148     genUI :: DataPath !(EditMode (DynamicEditorValue a)) !*VSt
 149           -> *(!MaybeErrorString (!UI, !Maybe (!DynamicConsId, !ConsType), ![EditState]), !*VSt)
 150     genUI dp mode vst=:{VSt|taskId} = case mode of
 151         Enter = case matchingConses of
 152             [onlyChoice] | hideCons
 153                 # (mbUis, _, type, _, vst) = genChildEditors dp onlyChoice.consId Enter vst
 154                 # mbUis = ( \(uis, childSts) -> (uiContainer uis, Just (onlyChoice.consId, type), [nullState: childSts])
 155                           ) <$>
 156                           mbUis
 157                 = (mbUis, vst)
 158             _
 159                 # (consChooseUI, chooseSt) = genConsChooseUI taskId dp Nothing
 160                 = (Ok (uiContainer [consChooseUI], Nothing, [chooseSt]), vst)
 161
 162         Update (DynamicEditorValue cid val)
 163             # (mbUis, idx, type, label, vst) = genChildEditors dp cid (Update val) vst
 164             = case mbUis of
 165                 Ok (uis, childSts)
 166                     | hideCons
 167                         = (Ok (uiContainer uis, Just (cid, type), [nullState: childSts]), vst)
 168                     | otherwise
 169                         # (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
 170                         = (Ok (uiContainer [consChooseUI: uis], Just (cid, type), [chooseSt: childSts]), vst)
 171                 Error e = (Error e, vst)
 172
 173         View (DynamicEditorValue cid val)
 174             # (mbUis, _, type, label, vst) = genChildEditors dp cid (View val) vst
 175             = case mbUis of
 176                 Ok (uis, childSts)
 177                     | hideCons
 178                         = (Ok (uiContainer uis, Just (cid, type), [nullState: childSts]), vst)
 179                     | otherwise
 180                         # consChooseUI = uia UITextView $ valueAttr $ JSONString label
 181                         = (Ok (uiContainer [consChooseUI: uis], Just (cid, type), [nullState: childSts]), vst)
 182                 Error e = (Error e, vst)
 183
 184     genConsChooseUI taskId dp mbSelectedCons = (consChooseUI, consChooseSt)
 185     where
 186         consOptions = [JSONObject [("id",JSONInt i),("text",JSONString cons.DynamicCons.label)] \\ cons <- matchingConses & i <- [0..]]
 187         consChooseUI = uia UIDropdown
 188                            ( 'Map'.put "width" JSONNull $
 189                              choiceAttrs taskId (editorId dp) (maybe [] (\x -> [x]) mbSelectedCons) consOptions
 190                            )
 191         consChooseSt = LeafState {touched=False,state=maybe JSONNull (\x -> JSONInt x) mbSelectedCons}
 192
 193     onEdit :: !DataPath
 194               !(!DataPath, !JSONNode)
 195               !(Maybe (!DynamicConsId, !ConsType))
 196               ![EditState]
 197               !*VSt
 198            -> *( !MaybeErrorString (!UIChange, !Maybe (!DynamicConsId, !ConsType), ![EditState])
 199                , !*VSt
 200                )
 201     // new builder is selected: create a UI for the new builder
 202     onEdit dp ([], JSONArray [JSONInt builderIdx]) _ [_: childrenSts] vst
 203         | builderIdx < 0 || builderIdx >= length matchingConses
 204             = (Error "Dynamic editor selection out of bounds", vst)
 205         # cons = matchingConses !! builderIdx
 206         # (mbRes, _, type, _, vst) = genChildEditors dp cons.consId Enter vst
 207         = case mbRes of
 208             Ok (uis, childSts)
 209                 // insert new UIs for arguments
 210                 # inserts = [(i, InsertChild ui) \\ ui <- uis & i <- [1..]]
 211                 # removals = removeNChildren $ length childrenSts
 212                 # change = ChangeUI [] (removals ++ inserts)
 213                 # builderChooseState = LeafState {touched = True, state = JSONInt $ length uis}
 214                 = (Ok (change, Just (cons.consId, type), [builderChooseState: childSts]), vst)
 215             Error e = (Error e, vst)
 216
 217     // other events targeted directly at this building cons
 218     onEdit dp ([],e) _ [_: childSts] vst
 219         | e =: JSONNull || e =: (JSONArray []) // A null or an empty array are accepted as a reset events
 220             //If necessary remove the fields of the previously selected cons
 221             # change = ChangeUI [] $ removeNChildren $ length childSts
 222             = (Ok (change, Nothing, [nullState: childSts]), vst)
 223         | otherwise
 224             = (Error $ concat ["Unknown dynamic editor select event: '", toString e, "'"], vst)
 225
 226     // update is targeted somewhere inside this value
 227     onEdit dp ([argIdx: tp], e) (Just (cid, type)) childSts vst
 228         # (cons, _) = consWithId cid matchingConses
 229         # (res, vst) = case cons.builder of
 230             FunctionCons fbuilder
 231                 # children = childrenEditors fbuilder
 232                 | argIdx < 0 || argIdx >= length children
 233                     = (Error "Edit event for dynamic editor has invalid path", vst)
 234                 # (E editor) = children !! argIdx
 235                 = editor.Editor.onEdit (dp ++ [argIdx]) (tp, e) (childSts !! (argIdx + 1)) vst
 236             ListCons lbuilder
 237                 = (listBuilderEditor lbuilder).Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
 238             CustomEditorCons editor
 239                 = editor.Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
 240         = case res of
 241             Ok (change, childSt)
 242                 # change = ChangeUI [] [(argIdx + if hideCons 0 1, ChangeChild change)]
 243                 // replace state for this child
 244                 = (Ok (change, Just (cid, type), updateAt (argIdx + 1) childSt childSts), vst)
 245             Error e = (Error e, vst)
 246
 247     onEdit _ _ _ _ vst = (Error "Invalid edit event for dynamic editor.", vst)
 248
 249     removeNChildren :: !Int -> [(!Int, !UIChildChange)]
 250     removeNChildren nrArgs = repeatn nrArgs (1, RemoveChild)
 251
 252     childrenEditors :: !Dynamic -> [E]
 253     childrenEditors (f :: a -> b) = [E $ dynamicEditorFstArg f : childrenEditors (dynamic (f undef))]
 254     where
 255         // first argument only used for type
 256         dynamicEditorFstArg :: (a -> b) -> Editor (DynamicEditorValue a) | TC a
 257         dynamicEditorFstArg _ = dynamicEditor $ DynamicEditor conses
 258     childrenEditors _         = []
 259
 260     onRefresh :: !DataPath
 261                  !(DynamicEditorValue a)
 262                  !(Maybe (!DynamicConsId, !ConsType))
 263                  ![EditState]
 264                  !*VSt
 265               -> *( !MaybeErrorString ( !UIChange
 266                                       , !Maybe (!DynamicConsId, !ConsType)
 267                                       , ![EditState]
 268                                       )
 269                   , !*VSt
 270                   )
 271     onRefresh dp new mbCid childSts vst = (Error "dynamic editor: onRefresh not implemented!", vst)
 272
 273     // TODO: accept ID or index
 274     genChildEditors :: !DataPath !DynamicConsId !(EditMode DEVal) !*VSt
 275                     -> *(!MaybeErrorString (![UI], ![EditState]), Int, ConsType, String, !*VSt)
 276     genChildEditors dp cid mode vst= case cons.builder of
 277         FunctionCons fbuilder
 278             # (mbUis, vst) = genChildEditors` (reverse $ zip3 vals (childrenEditors fbuilder) [0..]) [] [] vst
 279             = (mbUis, idx, type, cons.DynamicCons.label, vst)
 280         where
 281             genChildEditors` [] accUi accSt vst = (Ok (accUi, accSt), vst)
 282             genChildEditors` [(mbVal, E editor, i): children] accUi accSt vst =
 283                 case editor.Editor.genUI (dp ++ [i]) (maybe Enter (if viewMode View Update) mbVal) vst of
 284                     (Ok (ui, st), vst) = genChildEditors` children [ui: accUi] [st: accSt] vst
 285                     (Error e,     vst) = (Error e, vst)
 286
 287             vals :: [Maybe (DynamicEditorValue a)]
 288             vals = case editModeValue mode of
 289                 // update or view mode
 290                 Just (DEApplication children) = [Just $ DynamicEditorValue cid val \\ (cid, val) <- children]
 291                 // enter mode
 292                 _                             = repeat Nothing
 293         ListCons lbuilder
 294             # listEditorMode = mapEditMode (\(DEApplication listElems) -> listElems) mode
 295             # (mbUi, vst) = (listBuilderEditor lbuilder).Editor.genUI (dp ++ [0]) listEditorMode vst
 296             = ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
 297         CustomEditorCons editor
 298             # editorMode = mapEditMode
 299                 (\(DEJSONValue json) -> fromMaybe (abort "Invalid dynamic editor state") $ fromJSON json)
 300                 mode
 301             # (mbUi, vst) = editor.Editor.genUI (dp ++ [0]) editorMode vst
 302             = ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
 303     where
 304         (cons, idx) = consWithId cid matchingConses
 305         type = case cons.builder of
 306             FunctionCons     _ = Function
 307             ListCons         _ = List
 308             CustomEditorCons _ = CustomEditor
 309         viewMode = mode =: View _
 310
 311     hideCons = case matchingConses of
 312         [onlyChoice] | not onlyChoice.showIfOnlyChoice = True
 313         _                                              = False
 314
 315     matchingConses = catMaybes (matchingCons dynEditor <$> conses)
 316
 317     // first arg only used for type
 318     // packs matching conses, with possibly updated (= more specific) type
 319     matchingCons :: !(DynamicEditor a) !DynamicCons -> Maybe DynamicCons | TC a
 320     matchingCons dynEd cons=:{builder} = (\b -> {cons & builder = b}) <$> mbBuilder`
 321     where
 322         mbBuilder` = case builder of
 323             FunctionCons     fbuilder = matchf fbuilder
 324             CustomEditorCons editor   = matchc editor
 325             ListCons         lbuilder = matchl lbuilder
 326
 327         // works for functions with upto 10 args
 328         // the type of the dynamic is updated by unifying the function result with the type produced by the editor
 329         matchf :: !Dynamic -> Maybe DynamicConsBuilder
 330         matchf b = case (b, dynamic dynEd) of
 331             (b :: a b c d e f g h i j -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 332             (b :: a b c d e f g h i   -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 333             (b :: a b c d e f g h     -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 334             (b :: a b c d e f g       -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 335             (b :: a b c d e f         -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 336             (b :: a b c d e           -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 337             (b :: a b c d             -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 338             (b :: a b c               -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 339             (b :: a b                 -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 340             (b :: a                   -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 341             (b ::                        z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
 342             _                                                     = Nothing
 343
 344         // custom editors do not allow for quantified variables, so no type update is required
 345         matchc e = case (dynamic e, dynamic dynEd) of
 346             (_ :: Editor a, _ :: DynamicEditor a) = Just $ CustomEditorCons e
 347             _                                     = Nothing
 348
 349         matchl f = case (f, dynamic dynEd) of
 350             (f :: [a] -> b, _ :: DynamicEditor b) = Just $ ListCons (dynamic f)
 351             _                                     = Nothing
 352
 353     listBuilderEditor :: !Dynamic -> Editor [(!DynamicConsId, !DEVal)]
 354     listBuilderEditor (lbuilder :: [a] -> b) = listEditor (Just $ const Nothing) True True Nothing childrenEd`
 355     where
 356         childrenEd  = childrenEditorList lbuilder
 357         childrenEd` = bijectEditorValue (\(cid, val)                   -> DynamicEditorValue cid val)
 358                                         (\(DynamicEditorValue cid val) -> (cid, val))
 359                                         childrenEd
 360
 361         // first argument only used for type
 362         childrenEditorList :: ([a] -> b) -> Editor (DynamicEditorValue a) | TC a
 363         childrenEditorList _ = dynamicEditor $ DynamicEditor conses
 364     listBuilderEditor _ = abort "dynamic editors: invalid list builder value"
 365
 366     uiContainer :: [UI] -> UI
 367     uiContainer uis  = UI UIContainer
 368                           ('Map'.fromList [("direction", JSONString "horizontal"), ("width", JSONString "wrap")])
 369                           uis
 370
 371     valueFromState :: !(Maybe (!DynamicConsId, !ConsType)) ![EditState] -> *Maybe (DynamicEditorValue a)
 372     valueFromState (Just (cid, CustomEditor)) [_: [editorSt]] =
 373         mapMaybe (DynamicEditorValue cid o DEJSONValue o toJSON`) $ editor.Editor.valueFromState editorSt
 374     where
 375         ({builder}, _) = consWithId cid conses
 376
 377         // toJSON` is used to solve overloading, JSONEncode{|*|} is attached to CustomEditorCons
 378         (editor, toJSON`) = case builder of
 379             CustomEditorCons editor = (editor, toJSON)
 380             _                       = abort "corrupt dynamic editor state"
 381
 382     valueFromState (Just (cid, type)) [_: childSts] =
 383         mapMaybe (\childVals -> DynamicEditorValue cid $ DEApplication childVals) $ childValuesFor childSts` []
 384     where
 385         childSts` = case (type, childSts) of
 386             (List, [CompoundState _ childSts]) = childSts
 387             (_,    childSts)                   = childSts
 388
 389         childValuesFor :: ![EditState] ![(!DynamicConsId, !DEVal)]
 390                        -> Maybe [(!DynamicConsId, !DEVal)]
 391         childValuesFor [] acc = Just $ reverse acc
 392         childValuesFor [childSt: childSts] acc = case (dynamicEditor dynEditor).Editor.valueFromState childSt of
 393             Just (DynamicEditorValue childCid childVal) = childValuesFor childSts [(childCid, childVal): acc]
 394             _                                           = Nothing
 395     valueFromState _ _ = Nothing
 396
 397 consWithId :: !DynamicConsId ![DynamicCons] -> (!DynamicCons, !Int)
 398 consWithId cid conses = case filter (\({consId}, _) -> consId == cid) $ zip2 conses [0..] of
 399     [cons] = cons
 400     []     = abort $ "cons not found: " +++ cid
 401     _      = abort $ "duplicate conses: " +++ cid
 402
 403 nullState :: EditState
 404 nullState = LeafState {touched = True, state = JSONNull}