...
 
Commits (92)
/*
* CSS additions and fixes for typed task editor.
*/
/* Make labels occupy less space */
.itasks-label {
padding: 0em 1em 0em 0em;
width: auto;
}
/* Make containers have their natural sizes */
.itasks-container {
align-self: auto;
}
.typedtasks-evaluator {
align-self: unset;
}
/* Make generated labels flow on top */
.itasks-container.itasks-form-item {
flex-direction: column;
}
/* Set base padding and indent vertical structures horizontally */
.typedtasks-base {
flex: 0 0 auto;
padding: 0.2em 0.4em;
margin: 0.2em 1.6em;
}
/* Center horizontal structures vertically */
.typedtasks-horizontal {
flex-direction: row;
align-items: center;
}
.typedtasks-vertical {
flex-direction: column;
}
/* Add background boxes which get darker with nesting */
.typedtasks-boxed {
background-color: hsla(0,0%,0%,5%);
}
module DynEditorExample
import StdEnv
import Data.Func
import Data.Functor
import iTasks
import iTasks.Extensions.DateTime
import iTasks.Extensions.Editors.DynamicEditor
// Helpers /////////////////////////////////////////////////////////////////////
:: List a :== [a]
:: Message :== String
:: Button :== String
cons x xs :== [x:xs]
(>?>) infixl 1 :: (Task a) (List ( Button, a -> Bool, a -> Task b )) -> Task b | iTask a & iTask b
(>?>) task options = task >>* map trans options
where
trans ( a, p, t ) = OnAction (Action a) (ifValue p t)
// Main ////////////////////////////////////////////////////////////////////////
Start world = doTasks (editTaskExpr Nothing) world
editTaskExpr :: (Maybe (DynamicEditorValue Expr)) -> Task (Maybe (DynamicEditorValue Expr))
editTaskExpr mv =
enterOrUpdateExpr ("Contruct a task", info1) mv >?>
[ ( "Run", const True, \v ->
viewInformation ("Evaluate the task", info2) [] ()
||- evalTaskExpr (toValue taskEditor v) >>*
[ OnAction (Action "Back") (always (editTaskExpr (Just v)))
, OnAction (Action "Finish") (ifValue (const True) (\r -> viewInformation ("Done!", info3) [] (toString r) >?>
[ ( "Back", const True, \_ -> editTaskExpr (Just v) ) ]
))
]
)
]
where
info1 :: String
info1 = "Select the editors and combinators you'd like to use. When you're ready, push the 'Continue' button below to run your program."
info2 :: String
info2 = "Now step through the task you just created to test it."
info3 :: String
info3 = "The program is done, the result is given below."
enterOrUpdateExpr msg Nothing = enterInformation msg [EnterUsing id $ dynamicEditor taskEditor]
enterOrUpdateExpr msg (Just v) = updateInformation msg [UpdateUsing id (curry snd) (dynamicEditor taskEditor)] v
// Data ////////////////////////////////////////////////////////////////////////
:: Name
:== String
:: Id
:== ( Name, Value )
:: Expr
= Done Expr // Done :: a -> Task a
| Bind Expr Name Expr // Bind :: Task a -> String -> (( String, a ) -> Task b) -> Task b
| Var Name // Var :: String -> a
| Identity Expr // Identity :: a -> a
| Int Int
| Bool Bool
| String String
| Pair Expr Expr
:: Value
= VUnit
| VInt Int
| VBool Bool
| VString String
| VPair Value Value
:: Ty
= E.a: Ty (a -> Value) & iTask a
:: Typed a b
=: Typed a
derive class iTask Expr, Value, Typed
// These instances cannot be auto derived because of the existential quantifier.
// However, they will be never used, so we make them undefined.
gDefault{|Ty|} = abort "Typed task editor: internal error with gDefault of Ty"
gEq{|Ty|} _ _ = abort "Typed task editor: internal error with gEq of Ty"
JSONEncode{|Ty|} _ _ = abort "Typed task editor: internal error with JSONEncode of Ty"
JSONDecode{|Ty|} _ _ = abort "Typed task editor: internal error with JSONDecode of Ty"
gText{|Ty|} _ _ = abort "Typed task editor: internal error with gText of Ty"
gEditor{|Ty|} = abort "Typed task editor: internal error with gEditor of Ty"
// Editor //////////////////////////////////////////////////////////////////////
taskEditor :: DynamicEditor Expr
taskEditor = DynamicEditor
[ // This cons is used to provide untyped `Expr` values.
DynamicCons
$ functionConsDyn "Expr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed Expr a) -> Expr)
<<@@@ HideIfOnlyChoice
, DynamicConsGroup "Basics"
[ functionConsDyn "Bind" "bind"
( dynamic \(Typed task) name (Typed cont) -> Typed (Bind task name cont) ::
A.a b:
(Typed Expr (Task a))
String
(Typed Expr (a -> Task b))
-> Typed Expr (Task b)
)
<<@@@ applyVerticalBoxedLayout
, functionConsDyn "Done" "done"
( dynamic \(Typed expr) -> Typed (Done expr) ::
A.a:
(Typed Expr a)
-> Typed Expr (Task a)
)
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "DoneF" "done"
( dynamic \(Typed expr) -> Typed (Done expr) ::
A.a b:
(Typed Expr (a -> b))
-> Typed Expr (a -> Task b)
)
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Identity" "identity"
( dynamic \(Typed expr) -> Typed (Identity expr) ::
A.a:
(Typed Expr a)
-> Typed Expr a
)
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Var" "variable"
( dynamic \name -> Typed (Var name) ::
A.a:
String
-> Typed Expr a
)
<<@@@ applyHorizontalBoxedLayout
]
// Non-task expressions:
, DynamicConsGroup "Values"
[ functionConsDyn "Int" "the integer"
(dynamic \i -> Typed (Int i) :: Int -> Typed Expr Int)
<<@@@ applyHorizontalLayout
, functionConsDyn "Bool" "the boolean"
(dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
<<@@@ applyHorizontalLayout
, functionConsDyn "String" "the string"
(dynamic \s -> Typed (String s) :: String -> Typed Expr String)
<<@@@ applyHorizontalLayout
, functionConsDyn "Pair" "the pair"
( dynamic \(Typed a) (Typed b) ->
Typed (Pair a b) ::
A.a b:
(Typed Expr a) (Typed Expr b) -> Typed Expr (a, b)
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [ Just "with", Just "and" ]
]
// Types
, DynamicConsGroup "Types"
[ functionConsDyn "Ty.Int" "Integer"
(dynamic Typed (Ty VInt) :: Typed Ty Int)
<<@@@ applyHorizontalLayout
, functionConsDyn "Ty.Bool" "Boolean"
(dynamic Typed (Ty VBool) :: Typed Ty Bool)
<<@@@ applyHorizontalLayout
, functionConsDyn "Ty.String" "String"
(dynamic Typed (Ty VString) :: Typed Ty String)
<<@@@ applyHorizontalLayout
, functionConsDyn "Ty.Pair" "Pair"
( dynamic \(Typed (Ty toValue1)) (Typed (Ty toValue2)) -> Typed (Ty \(x, y) -> VPair (toValue1 x) (toValue2 y)) ::
A.a b:
(Typed Ty a) (Typed Ty b) -> Typed Ty (a, b)
)
<<@@@ applyHorizontalBoxedLayout
]
// Internal helper editors
, DynamicConsGroup "Helpers"
[ customEditorCons "int" "(enter integer)" intEditor <<@@@ HideIfOnlyChoice
, customEditorCons "bool" "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
, customEditorCons "string" "(enter string )" stringEditor <<@@@ HideIfOnlyChoice
]
]
where
intEditor :: Editor Int
intEditor = gEditor{|*|}
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
stringEditor :: Editor String
stringEditor = gEditor{|*|}
basicClasses = [ "typedtasks-base" ]
horizontalClasses = [ "typedtasks-horizontal" ]
verticalClasses = [ "typedtasks-vertical" ]
boxedClasses = [ "typedtasks-boxed" ]
applyHorizontalBoxedLayout = ApplyCssClasses $ basicClasses ++ horizontalClasses ++ boxedClasses
applyVerticalBoxedLayout = ApplyCssClasses $ basicClasses ++ verticalClasses ++ boxedClasses
applyHorizontalLayout = ApplyCssClasses $ basicClasses ++ horizontalClasses
applyVerticalLayout = ApplyCssClasses $ basicClasses ++ verticalClasses
// Evaluation //////////////////////////////////////////////////////////////////
evalTaskExpr :: Expr -> Task Value
evalTaskExpr (Done expr) = return $ evalExpr expr
// evalTaskExpr (Bind task fund) = ... //evalTaskExpr task >>= evalTaskFunc taskFunc
evalExpr :: Expr -> Value
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
evalExpr (Pair fstExpr sndExpr) = VPair (evalExpr fstExpr) (evalExpr sndExpr)
instance toString Value where
toString val = case val of
VUnit -> "()"
VInt i -> toString i
VBool b -> toString b
VString s -> toString s
VPair x y -> "( " +++ toString x +++ ", " +++ toString y +++ " )"
Version: 1.5
Global
ProjectRoot: .
Target: iTasks
Exec: {Project}/DynEditorExample
ByteCode: {Project}/DynEditorExample.bc
CodeGen
CheckStacks: False
CheckIndexes: True
OptimiseABC: True
GenerateByteCode: True
Application
HeapSize: 209715200
StackSize: 20971520
ExtraMemory: 8192
IntialHeapSize: 204800
HeapSizeMultiplier: 4096
ShowExecutionTime: False
ShowGC: False
ShowStackSize: False
MarkingCollector: False
DisableRTSFlags: False
StandardRuntimeEnv: True
Profile
Memory: False
MemoryMinimumHeapSize: 0
Time: False
Stack: False
Dynamics: True
GenericFusion: True
DescExL: True
Output
Output: ShowConstructors
Font: Monaco
FontSize: 9
WriteStdErr: False
Link
LinkMethod: Static
GenerateRelocations: False
GenerateSymbolTable: False
GenerateLinkMap: False
LinkResources: False
ResourceSource:
GenerateDLL: False
ExportedNames:
StripByteCode: True
KeepByteCodeSymbols: True
PrelinkByteCode: True
Paths
Path: {Project}
Precompile:
Postlink:
MainModule
Name: DynEditorExample
Dir: {Project}
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: StrictExportTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
.itasks-dynamic-editor-icon-error-container {
align-self: center;
padding: 0.2em;
}
.itasks-dynamic-editor-error {
background-color: #FFDDDD;
}
......@@ -13,7 +13,7 @@ derive class iTask DynamicEditorValue
:: DynamicEditorElement = DynamicCons !DynamicCons | DynamicConsGroup !String ![DynamicCons]
:: DynamicCons
:: DynamicConsOption = HideIfOnlyChoice | UseAsDefault | ApplyCssClasses ![String]
:: DynamicConsOption = HideIfOnlyChoice | UseAsDefault | ApplyCssClasses ![String] | AddLabels ![Maybe String]
(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
(@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons
......@@ -28,6 +28,7 @@ listCons :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b
customEditorCons :: !String !String !(Editor a) -> DynamicCons | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a
// dynamic variants are required because this is the only way to use quantified type variables
functionConsDyn :: !String !String !Dynamic -> DynamicCons
// The `Dynamic` argument must be a dynamic of type `[a] -> b`.
listConsDyn :: !String !String !Dynamic -> DynamicCons
dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
......
......@@ -7,7 +7,7 @@ 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 $
from Data.List import zip3, intersperse
from Data.List import zip4, intersperse
import Data.Functor
:: DynamicCons =
......@@ -17,6 +17,7 @@ import Data.Functor
, showIfOnlyChoice :: !Bool
, useAsDefault :: !Bool
, uiAttributes :: !UIAttributes
, labels :: ![Maybe String]
}
(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
......@@ -28,8 +29,9 @@ import Data.Functor
tunedDynamicConsEditor :: !DynamicConsOption !DynamicCons -> DynamicCons
tunedDynamicConsEditor HideIfOnlyChoice cons = {cons & showIfOnlyChoice = False}
tunedDynamicConsEditor UseAsDefault cons = {cons & useAsDefault = True}
tunedDynamicConsEditor (ApplyCssClasses classes) cons
= {cons & uiAttributes = 'Map'.union (classAttr classes) cons.uiAttributes}
tunedDynamicConsEditor (ApplyCssClasses classes) cons =
{cons & uiAttributes = 'Map'.union (classAttr classes) cons.uiAttributes}
tunedDynamicConsEditor (AddLabels labels) cons = {cons & labels = labels}
functionCons :: !String !String !a -> DynamicCons | TC a
functionCons consId label func = functionConsDyn consId label (dynamic func)
......@@ -41,6 +43,7 @@ functionConsDyn consId label func = { consId = consId
, showIfOnlyChoice = True
, useAsDefault = False
, uiAttributes = 'Map'.newMap
, labels = []
}
listCons :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b
......@@ -53,6 +56,7 @@ listConsDyn consId label func = { consId = consId
, showIfOnlyChoice = True
, useAsDefault = False
, uiAttributes = 'Map'.newMap
, labels = []
}
customEditorCons :: !String !String !(Editor a) -> DynamicCons
......@@ -63,13 +67,17 @@ customEditorCons consId label editor = { consId = consId
, showIfOnlyChoice = True
, useAsDefault = False
, uiAttributes = 'Map'.newMap
, labels = []
}
// TODO: don't use aborts here
toValue :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a
toValue (DynamicEditor elements) (DynamicEditorValue cid val) = case toValue` (cid, val) of
toValue dynEditor dynEditorValue = case toValueDyn dynEditor dynEditorValue of
(v :: a^) = v
_ = abort "corrupt dynamic editor value"
toValueDyn :: !(DynamicEditor a) !(DynamicEditorValue a) -> Dynamic | TC a
toValueDyn (DynamicEditor elements) (DynamicEditorValue cid val) = toValue` (cid, val)
where
toValue` :: !(!DynamicConsId, !DEVal) -> Dynamic
toValue` (cid, val) = case val of
......@@ -144,7 +152,7 @@ where
derive class iTask DynamicEditorValue, DEVal
:: E = E.a: E (Editor (DynamicEditorValue a))
:: E = E.a: E (Editor (DynamicEditorValue a)) & TC a
:: ConsType = Function | List | CustomEditor
derive JSONEncode ConsType
......@@ -183,8 +191,9 @@ where
dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
dynamicEditor dynEditor = compoundEditorToEditor $ dynamicCompoundEditor dynEditor
// Bool element if state indicates whether the type is correct, i.e. the child types are matching
dynamicCompoundEditor
:: !(DynamicEditor a) -> CompoundEditor (Maybe (!DynamicConsId, !ConsType)) (DynamicEditorValue a) | TC a
:: !(DynamicEditor a) -> CompoundEditor (Maybe (!DynamicConsId, !ConsType, !Bool)) (DynamicEditorValue a) | TC a
dynamicCompoundEditor dynEditor=:(DynamicEditor elements)
| not $ isEmpty duplicateIds
= abort $ concat ["duplicate cons IDs in dynamic editor: ", printToString duplicateIds, "\n"]
......@@ -202,12 +211,12 @@ where
| otherwise = duplicateIds` xs
genUI :: !UIAttributes !DataPath !(EditMode (DynamicEditorValue a)) !*VSt
-> *(!MaybeErrorString (!UI, !Maybe (!DynamicConsId, !ConsType), ![EditState]), !*VSt)
-> *(!MaybeErrorString (!UI, !Maybe (!DynamicConsId, !ConsType, !Bool), ![EditState]), !*VSt)
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
# mbUis = ( \(uis, childSts) -> (uiContainer attr uis, Just (onlyChoice.consId, type), [nullState: childSts])
# mbUis = ( \(uis, childSts) -> (uiContainer attr uis, Just (onlyChoice.consId, type, True), [nullState: childSts])
) <$>
mbUis
= (mbUis, vst)
......@@ -217,11 +226,11 @@ where
= case mbUis of
Ok (uis, childSts)
| hideCons
= (Ok (uiContainer attr uis, Just (defaultChoice.consId, type), [nullState: childSts]), vst)
= (Ok (uiContainer attr uis, Just (defaultChoice.consId, type, True), [nullState: childSts]), vst)
| otherwise
# (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
= ( Ok ( uiContainer attr [consChooseUI: uis]
, Just (defaultChoice.consId, type)
, Just (defaultChoice.consId, type, True)
, [chooseSt: childSts]
)
, vst
......@@ -233,24 +242,28 @@ where
Update Undefined = genUI attr dp Enter vst
Update (DynamicEditorValue cid val)
# (mbUis, idx, type, label, vst) = genChildEditors dp cid (Update val) vst
# (cons, _) = consWithId cid matchingConses
= case mbUis of
Ok (uis, childSts)
# attrs = 'Map'.union (withContainerClassAttr cons.uiAttributes) attr
| hideCons
= (Ok (uiContainer attr uis, Just (cid, type), [nullState: childSts]), vst)
= (Ok (uiContainer attrs uis, Just (cid, type, True), [nullState: childSts]), vst)
| otherwise
# (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
= (Ok (uiContainer attr [consChooseUI: uis], Just (cid, type), [chooseSt: childSts]), vst)
= (Ok (uiContainer attrs [consChooseUI: uis], Just (cid, type, True), [chooseSt: childSts]), vst)
Error e = (Error e, vst)
View (DynamicEditorValue cid val)
# (mbUis, _, type, label, vst) = genChildEditors dp cid (View val) vst
# (cons, _) = consWithId cid matchingConses
= case mbUis of
Ok (uis, childSts)
# attrs = 'Map'.union (withContainerClassAttr cons.uiAttributes) attr
| hideCons
= (Ok (uiContainer attr uis, Just (cid, type), [nullState: childSts]), vst)
= (Ok (uiContainer attrs uis, Just (cid, type, True), [nullState: childSts]), vst)
| otherwise
# consChooseUI = uia UITextView $ valueAttr $ JSONString label
= (Ok (uiContainer attr [consChooseUI: uis], Just (cid, type), [nullState: childSts]), vst)
= (Ok (uiContainer attrs [consChooseUI: uis], Just (cid, type, True), [nullState: childSts]), vst)
Error e = (Error e, vst)
genConsChooseUI taskId dp mbSelectedCons = (consChooseUI, consChooseSt)
......@@ -267,14 +280,14 @@ where
onEdit :: !DataPath
!(!DataPath, !JSONNode)
!(Maybe (!DynamicConsId, !ConsType))
!(Maybe (!DynamicConsId, !ConsType, !Bool))
![EditState]
!*VSt
-> *( !MaybeErrorString (!UIChange, !Maybe (!DynamicConsId, !ConsType), ![EditState])
-> *( !MaybeErrorString (!UIChange, !Maybe (!DynamicConsId, !ConsType, !Bool), ![EditState])
, !*VSt
)
// new builder is selected: create a UI for the new builder
onEdit dp ([], JSONArray [JSONInt builderIdx]) _ [_: childrenSts] vst
onEdit dp ([], JSONArray [JSONInt builderIdx]) st [_: childrenSts] vst
| builderIdx < 0 || builderIdx >= length matchingConses
= (Error "Dynamic editor selection out of bounds", vst)
# (cons, _) = matchingConses !! builderIdx
......@@ -284,22 +297,32 @@ where
// insert new UIs for arguments
# inserts = [(i, InsertChild ui) \\ ui <- uis & i <- [1..]]
# removals = removeNChildren $ length childrenSts
# change = ChangeUI [] (removals ++ inserts)
// add "itasks-container" classes as this class always has to be present for containers
# uiAttrs = withContainerClassAttr cons.uiAttributes
# attrChange = if (typeWasInvalid st) removeErrorIconAttrChange []
# childChange =
if (typeWasInvalid st) removeErrorIconChange []
++
[(0, ChangeChild $ ChangeUI (uncurry SetAttribute <$> 'Map'.toList uiAttrs) (removals ++ inserts))]
# builderChooseState = LeafState {touched = True, state = JSONInt $ length uis}
= (Ok (change, Just (cons.consId, type), [builderChooseState: childSts]), vst)
= (Ok (ChangeUI attrChange childChange, Just (cons.consId, type, True), [builderChooseState: childSts]), vst)
Error e = (Error e, vst)
// other events targeted directly at this building cons
onEdit dp ([],e) _ [_: childSts] vst
// other events targeted directly at this cons
onEdit dp ([],e) st [_: 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)
# attrChange = if (typeWasInvalid st) removeErrorIconAttrChange []
# childChange =
if (typeWasInvalid st) removeErrorIconChange []
++
[(0, ChangeChild $ ChangeUI [] $ removeNChildren $ length childSts)]
= (Ok (ChangeUI attrChange childChange, Nothing, [nullState]), 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
onEdit dp ([argIdx: tp], e) (Just (cid, type, typeWasCorrect)) childSts vst
# (cons, _) = consWithId cid matchingConses
# (res, vst) = case cons.builder of
FunctionCons fbuilder
......@@ -309,36 +332,63 @@ where
# (E editor) = children !! argIdx
= editor.Editor.onEdit (dp ++ [argIdx]) (tp, e) (childSts !! (argIdx + 1)) vst
ListCons lbuilder
= (listBuilderEditor lbuilder cons.uiAttributes).Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
= (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)
# change = ChangeUI mbErrorIconAttrChange $ [(0, ChangeChild $ ChangeUI [] [(argIdx + if hideCons 0 1, ChangeChild change)])] ++ mbErrorIconChange
// replace state for this child
= (Ok (change, Just (cid, type, isOk typeIsCorrect), childSts`), vst)
where
(mbErrorIconChange, mbErrorIconAttrChange) = mbErrorIconUpd
mbErrorIconUpd
| typeWasCorrect && isError typeIsCorrect =
( [(1, InsertChild errorIcon)]
, [SetAttribute "class" $ JSONArray [JSONString "itasks-container", JSONString "itasks-horizontal", JSONString "itasks-dynamic-editor-error"]]
)
with
errorIcon =
UI
UIContainer
('Map'.singleton "class" $ JSONString "itasks-dynamic-editor-icon-error-container")
[ UI
UIIcon
('Map'.union (iconClsAttr "icon-invalid") (tooltipAttr $ fromError typeIsCorrect))
[]
]
| not typeWasCorrect && isOk typeIsCorrect =
(removeErrorIconChange, removeErrorIconAttrChange)
| otherwise = ([], [])
typeIsCorrect = childTypesAreMatching cons.builder (drop 1 childSts`)
childSts` = updateAt (argIdx + 1) childSt childSts
Error e = (Error e, vst)
onEdit _ _ _ _ vst = (Error "Invalid edit event for dynamic editor.", vst)
typeWasInvalid (Just (_, _, False)) = True
typeWasInvalid _ = False
removeErrorIconChange = [(1, RemoveChild)]
removeErrorIconAttrChange = [SetAttribute "class" $ JSONArray [JSONString "itasks-container", JSONString "itasks-horizontal"]]
// 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
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 elements
childrenEditors _ = []
onRefresh :: !DataPath
!(DynamicEditorValue a)
!(Maybe (!DynamicConsId, !ConsType))
!(Maybe (!DynamicConsId, !ConsType, !Bool))
![EditState]
!*VSt
-> *( !MaybeErrorString ( !UIChange
, !Maybe (!DynamicConsId, !ConsType)
, !Maybe (!DynamicConsId, !ConsType, !Bool)
, ![EditState]
)
, !*VSt
......@@ -358,14 +408,18 @@ where
-> *(!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, vst) = genChildEditors` (reverse $ zip4 vals (childrenEditors fbuilder) (cons.labels ++ repeat Nothing) [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 cons.uiAttributes (dp ++ [i]) (maybe Enter (if viewMode View Update) mbVal) vst of
(Ok (ui, st), vst) = genChildEditors` children [ui: accUi] [st: accSt] vst
genChildEditors` [(mbVal, E editor, mbLabel, i): children] accUi accSt vst =
case editor.Editor.genUI 'Map'.newMap (dp ++ [i]) (maybe Enter (if viewMode View Update) mbVal) vst of
(Ok (ui, st), vst) = genChildEditors` children [withLabel mbLabel ui: accUi] [st: accSt] vst
(Error e, vst) = (Error e, vst)
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
vals :: [Maybe (DynamicEditorValue a)]
vals = case editModeValue mode of
......@@ -375,13 +429,13 @@ where
_ = repeat Nothing
ListCons lbuilder
# listEditorMode = mapEditMode (\(DEApplication listElems) -> listElems) mode
# (mbUi, vst) = (listBuilderEditor lbuilder cons.uiAttributes).Editor.genUI 'Map'.newMap (dp ++ [0]) listEditorMode vst
# (mbUi, vst) = (listBuilderEditor lbuilder).Editor.genUI 'Map'.newMap (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 cons.uiAttributes (dp ++ [0]) editorMode vst
# (mbUi, vst) = editor.Editor.genUI 'Map'.newMap (dp ++ [0]) editorMode vst
= ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
where
(cons, idx) = consWithId cid matchingConses
......@@ -435,8 +489,8 @@ where
(f :: [a] -> b, _ :: DynamicEditor b) = Just $ ListCons (dynamic f)
_ = Nothing
listBuilderEditor :: !Dynamic !UIAttributes -> Editor [(!DynamicConsId, !DEVal)]
listBuilderEditor (lbuilder :: [a] -> b) attrs = listEditor (Just $ const Nothing) True True Nothing childrenEd`
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)
......@@ -445,14 +499,18 @@ where
// first argument only used for type
childrenEditorList :: ([a] -> b) -> Editor (DynamicEditorValue a) | TC a
childrenEditorList _ = dynamicEditor (DynamicEditor elements) <<@ attrs
listBuilderEditor _ _ = abort "dynamic editors: invalid list builder value"
childrenEditorList _ = dynamicEditor (DynamicEditor elements)
listBuilderEditor _ = abort "dynamic editors: invalid list builder value"
uiContainer :: !UIAttributes ![UI] -> UI
uiContainer attr uis = UI UIContainer attr uis
valueFromState :: !(Maybe (!DynamicConsId, !ConsType)) ![EditState] -> *Maybe (DynamicEditorValue a)
valueFromState (Just (cid, CustomEditor)) [_: [editorSt]] =
uiContainer attr uis =
UI
UIContainer
('Map'.singleton "class" $ JSONArray [JSONString "itasks-container", JSONString "itasks-horizontal"])
[UI UIRecord attr uis]
valueFromState :: !(Maybe (!DynamicConsId, !ConsType, !Bool)) ![EditState] -> *Maybe (DynamicEditorValue a)
valueFromState (Just (cid, CustomEditor, True)) [_: [editorSt]] =
mapMaybe (DynamicEditorValue cid o DEJSONValue o toJSON`) $ editor.Editor.valueFromState editorSt
where
({builder}, _) = consWithId cid conses
......@@ -462,7 +520,7 @@ where
CustomEditorCons editor = (editor, toJSON)
_ = abort "corrupt dynamic editor state"
valueFromState (Just (cid, type)) [_: childSts] =
valueFromState (Just (cid, type, True)) [_: childSts] =
mapMaybe (\childVals -> DynamicEditorValue cid $ DEApplication childVals) $ childValuesFor childSts` []
where
childSts` = case (type, childSts) of
......@@ -477,6 +535,43 @@ where
_ = Nothing
valueFromState _ _ = Nothing
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 ()
childTypesAreMatching` cons [Nothing: otherArgs] =
case cons of
(cons` :: a -> z) = childTypesAreMatching` (dynamic cons` undef) otherArgs
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
[ "Could not unify\n ", toString (argOf $ typeCodeOfDynamic cons), "\nwith\n "
, toString (typeCodeOfDynamic nextArg)
]
childValueOf :: !(!EditState, !E) -> Maybe Dynamic
childValueOf (state, E editor) = toValueDyn (DynamicEditor elements) <$> editor.Editor.valueFromState state
argOf :: !TypeCode -> TypeCode
argOf (TypeApp (TypeApp _ arg) _) = arg
argOf (TypeScheme _ type) = argOf type
// only function conses can have not matching child types
childTypesAreMatching _ _ = Ok ()
consWithId :: !DynamicConsId ![(!DynamicCons, !Maybe String)] -> (!DynamicCons, !Int)
consWithId cid conses = case filter (\(({consId}, _), _) -> consId == cid) $ zip2 conses [0..] of
[((cons, _), idx)] = (cons, idx)
......
......@@ -272,7 +272,7 @@ div.itasks-exception {
padding: 8px 10px;
font-size: 12px;
line-height: 12px;
white-space: nowrap;
white-space: pre;
box-shadow: 4px 4px 8px rgba(0, 0, 0, 0.3);
}
*.itasks-viewport [data-tooltip]:before {
......
......@@ -143,7 +143,7 @@ itasks.NumberField = {
initDOMEl: function() {
var me = this,
el = this.domEl;
el.type = 'text';
el.type = 'number';
el.value = (me.attributes.value === undefined || me.attributes.value === null) ? '' : me.attributes.value;
if('enabled' in me.attributes && me.attributes['enabled'] === false) {
......
......@@ -263,10 +263,23 @@ itasks.Component = {
setAttribute: function(name,value) {
var me = this;
me.attributes[name] = value;
me.attributes[name] = value;
me.onAttributeChange(name,value);
},
onAttributeChange: function(name,value) {},
onAttributeChange: function(name,value) {
var me = this;
if(name == 'class') {
me.domEl.className = '';
if(Array.isArray(value)) {
value.forEach(function(cls) {
me.domEl.classList.add(cls);
});
} else {
me.domEl.classList.add(value);
}
}
},
onUIChange: function(change) {
var me = this;
if(change) {
......