+++ /dev/null
-implementation module DynamicEditor
-
-import StdMisc, Data.Tuple, Text, Data.Maybe
-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 $
-import Util
-from Data.List import zip3, intersperse
-import Data.Functor
-
-:: DynamicCons =
- { consId :: !DynamicConsId
- , label :: !String
- , builder :: !DynamicConsBuilder
- , showIfOnlyChoice :: !Bool
- }
-
-(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
-(<<@@@) cons HideIfOnlyChoice = {cons & showIfOnlyChoice = False}
-
-(@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons
-(@@@>>) opt cons = cons <<@@@ opt
-
-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
- }
-
-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
- }
-
-customEditorCons :: !String !String !(Editor a) -> DynamicCons | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a
-customEditorCons consId label editor = { consId = consId
- , label = label
- , builder = CustomEditorCons editor
- , showIfOnlyChoice = True
- }
-
-// TODO: don't use aborts here
-toValue :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a
-toValue (DynamicEditor dynEditor) (DynamicEditorValue cid val) = case toValue` (cid, val) of
- (v :: a^) = v
- _ = abort "corrupt dynamic editor value"
-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 dynEditor
-
- 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 dynEditor) (DynamicEditorValue cid val) =
- concat $ reverse $ dynEditorValToString` (cid, val) []
-where
- dynEditorValToString` :: !(!DynamicConsId, !DEVal) ![String] -> [String]
- dynEditorValToString` (cid, val) accum = case val of
- DEApplication args = case cons.builder of
- FunctionCons fbuilder = 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 dynEditor
-
- 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
-
-:: E = E.a: E (Editor (DynamicEditorValue a))
-:: ConsType = Function | List | CustomEditor
-
-derive JSONEncode ConsType
-derive JSONDecode ConsType
-
-dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
-dynamicEditor dynEditor=:(DynamicEditor conses)
- | duplicateIds = abort "duplicate cons IDs in dynamic editor"
- = compoundEditorToEditor
- {CompoundEditor| genUI = genUI, onEdit = onEdit, onRefresh = onRefresh, valueFromState = valueFromState}
-where
- duplicateIds = hasDup $ (\b -> b.consId) <$> conses
- where
- // TODO: use hasDup from platform as soon as available
- hasDup :: ![a] -> Bool | Eq a
- hasDup [] = False
- hasDup [x:xs] = isMember x xs || hasDup xs
-
- genUI :: DataPath !(EditMode (DynamicEditorValue a)) !*VSt
- -> *(!MaybeErrorString (!UI, !Maybe (!DynamicConsId, !ConsType), ![EditState]), !*VSt)
- genUI dp mode vst=:{VSt|taskId} = case mode of
- Enter = case matchingConses of
- [onlyChoice] | hideCons
- # (mbUis, _, type, _, vst) = genChildEditors dp onlyChoice.consId Enter vst
- # mbUis = ( \(uis, childSts) -> (uiContainer uis, Just (onlyChoice.consId, type), [nullState: childSts])
- ) <$>
- mbUis
- = (mbUis, vst)
- _
- # (consChooseUI, chooseSt) = genConsChooseUI taskId dp Nothing
- = (Ok (uiContainer [consChooseUI], Nothing, [chooseSt]), vst)
-
- Update (DynamicEditorValue cid val)
- # (mbUis, idx, type, label, vst) = genChildEditors dp cid (Update val) vst
- = case mbUis of
- Ok (uis, childSts)
- | hideCons
- = (Ok (uiContainer uis, Just (cid, type), [nullState: childSts]), vst)
- | otherwise
- # (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
- = (Ok (uiContainer [consChooseUI: uis], Just (cid, type), [chooseSt: childSts]), vst)
- Error e = (Error e, vst)
-
- View (DynamicEditorValue cid val)
- # (mbUis, _, type, label, vst) = genChildEditors dp cid (View val) vst
- = case mbUis of
- Ok (uis, childSts)
- | hideCons
- = (Ok (uiContainer uis, Just (cid, type), [nullState: childSts]), vst)
- | otherwise
- # consChooseUI = uia UITextView $ valueAttr $ JSONString label
- = (Ok (uiContainer [consChooseUI: uis], Just (cid, type), [nullState: childSts]), vst)
- Error e = (Error e, vst)
-
- genConsChooseUI taskId dp mbSelectedCons = (consChooseUI, consChooseSt)
- where
- consOptions = [JSONObject [("id",JSONInt i),("text",JSONString cons.DynamicCons.label)] \\ cons <- 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)
- !(Maybe (!DynamicConsId, !ConsType))
- ![EditState]
- !*VSt
- -> *( !MaybeErrorString (!UIChange, !Maybe (!DynamicConsId, !ConsType), ![EditState])
- , !*VSt
- )
- // new builder is selected: create a UI for the new builder
- onEdit dp ([], JSONArray [JSONInt builderIdx]) _ [_: childrenSts] vst
- | 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
- # change = ChangeUI [] (removals ++ inserts)
- # builderChooseState = LeafState {touched = True, state = JSONInt $ length uis}
- = (Ok (change, Just (cons.consId, type), [builderChooseState: childSts]), vst)
- Error e = (Error e, vst)
-
- // other events targeted directly at this building cons
- onEdit dp ([],e) _ [_: childSts] vst
- | 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
- # change = ChangeUI [] $ removeNChildren $ length childSts
- = (Ok (change, Nothing, [nullState: childSts]), vst)
- | otherwise
- = (Error $ concat ["Unknown dynamic editor select event: '", toString e, "'"], vst)
-
- // update is targeted somewhere inside this value
- onEdit dp ([argIdx: tp], e) (Just (cid, type)) childSts vst
- # (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
- = (listBuilderEditor lbuilder).Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
- CustomEditorCons editor
- = editor.Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
- = case res of
- Ok (change, childSt)
- # change = ChangeUI [] [(argIdx + if hideCons 0 1, ChangeChild change)]
- // replace state for this child
- = (Ok (change, Just (cid, type), updateAt (argIdx + 1) childSt childSts), vst)
- Error e = (Error e, vst)
-
- onEdit _ _ _ _ vst = (Error "Invalid edit event for dynamic editor.", vst)
-
- removeNChildren :: !Int -> [(!Int, !UIChildChange)]
- removeNChildren nrArgs = repeatn nrArgs (1, RemoveChild)
-
- 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 conses
- childrenEditors _ = []
-
- onRefresh :: !DataPath
- !(DynamicEditorValue a)
- !(Maybe (!DynamicConsId, !ConsType))
- ![EditState]
- !*VSt
- -> *( !MaybeErrorString ( !UIChange
- , !Maybe (!DynamicConsId, !ConsType)
- , ![EditState]
- )
- , !*VSt
- )
- onRefresh dp new mbCid childSts vst = (Error "dynamic editor: onRefresh not implemented!", vst)
-
- // 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
- # (mbUis, vst) = genChildEditors` (reverse $ zip3 vals (childrenEditors fbuilder) [0..]) [] [] vst
- = (mbUis, idx, type, cons.DynamicCons.label, vst)
- where
- genChildEditors` [] accUi accSt vst = (Ok (accUi, accSt), vst)
- genChildEditors` [(mbVal, E editor, i): children] accUi accSt vst =
- case editor.Editor.genUI (dp ++ [i]) (maybe Enter (if viewMode View Update) mbVal) vst of
- (Ok (ui, st), vst) = genChildEditors` children [ui: accUi] [st: accSt] vst
- (Error e, vst) = (Error e, vst)
-
- 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
- # (mbUi, vst) = (listBuilderEditor lbuilder).Editor.genUI (dp ++ [0]) listEditorMode vst
- = ((\(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
- # (mbUi, vst) = editor.Editor.genUI (dp ++ [0]) editorMode vst
- = ((\(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 = catMaybes (matchingCons dynEditor <$> 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
-
- listBuilderEditor :: !Dynamic -> Editor [(!DynamicConsId, !DEVal)]
- listBuilderEditor (lbuilder :: [a] -> b) = listEditor (Just $ const Nothing) True True Nothing childrenEd`
- 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
- childrenEditorList _ = dynamicEditor $ DynamicEditor conses
- listBuilderEditor _ = abort "dynamic editors: invalid list builder value"
-
- uiContainer :: [UI] -> UI
- uiContainer uis = UI UIContainer
- ('Map'.fromList [("direction", JSONString "horizontal"), ("width", JSONString "wrap")])
- uis
-
- valueFromState :: !(Maybe (!DynamicConsId, !ConsType)) ![EditState] -> *Maybe (DynamicEditorValue a)
- valueFromState (Just (cid, CustomEditor)) [_: [editorSt]] =
- 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"
-
- valueFromState (Just (cid, type)) [_: childSts] =
- 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
-
-consWithId :: !DynamicConsId ![DynamicCons] -> (!DynamicCons, !Int)
-consWithId cid conses = case filter (\({consId}, _) -> consId == cid) $ zip2 conses [0..] of
- [cons] = cons
- [] = abort $ "cons not found: " +++ cid
- _ = abort $ "duplicate conses: " +++ cid
-
-nullState :: EditState
-nullState = LeafState {touched = True, state = JSONNull}
repositories / clean-tests.git / blobdiff