Skip to content

GitLab

I
iTasks-SDK
Source
Select Git revision
...
Target
Select Git revision
 
Commits (89)
Show whitespace changes
Inline Side-by-side
Showing with 846 additions and 58 deletions
Examples/DynamicEditor/DynEditorExample.css 0 → 100644
View file @ d01b2680
/*
* 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%);
}
Examples/DynamicEditor/DynEditorExample.icl 0 → 100644
View file @ d01b2680
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 TaskExpr)) -> Task (Maybe (DynamicEditorValue TaskExpr))
editTaskExpr mv =
enterOrUpdateExpr ("Contruct a task", info1) mv >?>
[ ( "Run", const True, \v ->
viewInformation ("Evaluate the task", info2) [] ()
||- (set [] globalValueShare >>| 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 ////////////////////////////////////////////////////////////////////////
:: TaskExpr
= Done Expr
| EnterInfo Ty String
| Then TaskExpr TaskFunc
| Both TaskExpr TaskExpr
| Any TaskExpr TaskExpr
| One Button TaskExpr Button TaskExpr
// | Init Ty TaskExpr
| Watch String
// | Change String
| Forever TaskExpr
:: TaskFunc
= ThenF TaskFunc TaskFunc
| ViewF String Func
| UpdateF String Func
| StoreF
| WatchF String
:: Expr
= Int Int
| Bool Bool
| String String
| Date Date
| Pair Expr Expr
| Apply Func Expr
:: Func
= Identity
| Conj Expr
| Disj Expr
| Not
| Gt Expr
| Ge Expr
| Eq Expr
| Le Expr
| Lt Expr
| Add Expr
| Sub Expr
| Mul Expr
| Div Expr
| Fst
| Snd
:: Value
= VUnit
| VInt Int
| VBool Bool
| VString String
| VDate Date
| VPair Value Value
:: Ty
= E.a: Ty (a -> Value) & iTask a
:: Typed a b
=: Typed a
derive class iTask TaskExpr, TaskFunc, Expr, Func, 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 TaskExpr
taskEditor = DynamicEditor
[ // This cons is used to provide untyped `TaskExpr` values.
DynamicCons
$ functionConsDyn "TaskExpr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed TaskExpr a) -> TaskExpr)
<<@@@ HideIfOnlyChoice
, DynamicConsGroup "Combinators"
[ functionConsDyn "Then" "sequence"
( dynamic \(Typed task) (Typed taskFunc) -> Typed (Then task taskFunc) ::
A.a b:
(Typed TaskExpr (Task a)) (Typed TaskFunc (a -> Task b))
-> Typed TaskExpr (Task b)
)
<<@@@ applyVerticalBoxedLayout
, functionConsDyn "ThenF" "sequence"
( dynamic \(Typed taskFunc1) (Typed taskFunc2) -> Typed (ThenF taskFunc1 taskFunc2) ::
A.a b c:
(Typed TaskFunc (a -> Task b)) (Typed TaskFunc (b -> Task c))
-> Typed TaskFunc (a -> Task c)
)
<<@@@ applyVerticalBoxedLayout
, functionConsDyn "Both" "both"
( dynamic \(Typed task1) (Typed task2) -> Typed (Both task1 task2) ::
A.a b:
(Typed TaskExpr (Task a))
(Typed TaskExpr (Task b))
-> Typed TaskExpr (Task (a, b))
)
<<@@@ applyVerticalBoxedLayout
, functionConsDyn "Any" "any of"
( dynamic \(Typed task1) (Typed task2) -> Typed (Any task1 task2) ::
A.a b:
(Typed TaskExpr (Task a))
(Typed TaskExpr (Task a))
-> Typed TaskExpr (Task a)
)
<<@@@ applyVerticalBoxedLayout
, functionConsDyn "One" "one of"
( dynamic \button1 (Typed task1) button2 (Typed task2) -> Typed (One button1 task1 button2 task2) ::
A.a b:
String
(Typed TaskExpr (Task a))
String
(Typed TaskExpr (Task a))
-> Typed TaskExpr (Task a)
)
<<@@@ applyVerticalBoxedLayout
, functionConsDyn "Forever" "forever"
( dynamic \(Typed taskExpr) -> Typed (Forever taskExpr) ::
A.a:
(Typed TaskExpr (Task a))
-> Typed TaskExpr (Task a)
)
<<@@@ applyVerticalBoxedLayout
]
// , functionConsDyn "When" "guarded sequence"
// ( dynamic \(Typed task1) (Typed steps) -> Typed (When task1 steps) ::
// // Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) ::
// A.a b:
// (Typed TaskExpr (Task a))
// (Typed (List TaskContExpr) (a -> Task b))
// // (Typed (List (Typed Func (a -> Bool), String, Typed TaskFunc (a -> Task a))) (a -> Task b))
// -> Typed TaskExpr (Task b)
// )
// <<@@@ applyHorizontalBoxedLayout
// , listConsDyn "List TaskContExpr" "continuations"
// ( dynamic \typedSteps -> Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
// A.a b:
// (List (Typed TaskContExpr (a -> Task b)))
// -> Typed (List TaskContExpr) (a -> Task b)
// )
// <<@@@ HideIfOnlyChoice
// , functionConsDyn "TaskContExpr" "continuation"
// ( dynamic \s (Typed func) (Typed taskFunc) -> Typed {name = s, pred = func, cont = taskFunc} ::
// A.a b:
// String
// (Typed Func a)
// (Typed TaskFunc (a -> Task b))
// -> Typed TaskContExpr (a -> Task b)
// )
// <<@@@ HideIfOnlyChoice
// <<@@@ AddLabels [Just "name", Just "predicate", Just "continuation"]
// ]
, DynamicConsGroup "Editors"
[ functionConsDyn "Enter" "enter"
( dynamic \(Typed ty) s -> Typed (EnterInfo ty s) ::
A.a:
(Typed Ty a)
String
-> Typed TaskExpr (Task a)
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [Nothing, Just "message"]
, functionConsDyn "ViewF" "view"
( dynamic \s (Typed func) -> Typed (ViewF s func) ::
A.a b:
String
(Typed Func (a -> b))
-> Typed TaskFunc (a -> Task b)
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [Just "message"]
, functionConsDyn "UpdateF" "update"
( dynamic \s (Typed func) -> Typed (UpdateF s func) ::
A.a b:
String
(Typed Func (a -> b))
-> Typed TaskFunc (a -> Task b)
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [ Just "message" ]
, functionConsDyn "Done" "done"
( dynamic \(Typed expr) -> Typed (Done expr) ::
A.a:
(Typed Expr a)
-> Typed TaskExpr (Task a)
)
<<@@@ applyHorizontalBoxedLayout
]
// Task expressions and functions on shares
, DynamicConsGroup "Shares"
// [ functionConsDyn "Init" "initialise"
// ( dynamic \(Typed sharedTy) (Typed taskExpr) -> Typed (Init sharedTy taskExpr) ::
// A.s a:
// (Typed Ty s)
// (Typed TaskExpr (Task a))
// -> Typed TaskExpr (Task a)
// )
// <<@@@ applyVerticalBoxedLayout
[ functionConsDyn "StoreF" "store"
(dynamic Typed StoreF :: Typed TaskFunc (Int -> Task ()))
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [ Just "message" ]
, functionConsDyn "Watch" "watch"
( dynamic \msg -> Typed (Watch msg) ::
A.a:
String
-> Typed TaskExpr (Task ())
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [ Just "message" ]
, functionConsDyn "WatchF" "watch"
( dynamic \msg -> Typed (WatchF msg) ::
A.a:
String
-> Typed TaskFunc (a -> Task ())
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [ Just "message" ]
]
// Non-task functions:
, DynamicConsGroup "Basics"
[ functionConsDyn "Identity" "this value"
(dynamic Typed Identity :: A.a: Typed Func (a -> a))
<<@@@ applyHorizontalLayout
, functionConsDyn "Apply" "apply"
( dynamic \(Typed func) (Typed expr) ->
Typed (Apply func expr) ::
A.a b:
(Typed Func (a -> b))
(Typed Expr a)
-> Typed Expr b
)
<<@@@ applyHorizontalBoxedLayout
<<@@@ AddLabels [ Just "the function", Just "to" ]
, functionConsDyn "Fst" "first element"
(dynamic Typed Fst :: A.a b: Typed Func ((a, b) -> a))
<<@@@ applyHorizontalLayout
, functionConsDyn "Snd" "second element"
(dynamic Typed Snd :: A.a b: Typed Func ((a, b) -> b))
<<@@@ applyHorizontalLayout
]
, DynamicConsGroup "Arithmetic"
[ functionConsDyn "Add" "add"
(dynamic \(Typed i) -> Typed (Add i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Sub" "subtract"
(dynamic \(Typed i) -> Typed (Sub i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Mul" "multiply with"
(dynamic \(Typed i) -> Typed (Mul i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Div" "divide by"
(dynamic \(Typed i) -> Typed (Div i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
]
, DynamicConsGroup "Logic"
[ functionConsDyn "Conj" "and"
(dynamic \(Typed b) -> Typed (Conj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Disj" "or"
(dynamic \(Typed b) -> Typed (Disj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Not" "negate"
(dynamic Typed Not :: Typed Func (Bool -> Bool))
<<@@@ applyHorizontalLayout
]
, DynamicConsGroup "Comparison"
[ functionConsDyn "Gt" "is greater than"
(dynamic \(Typed i) -> Typed (Gt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Ge" "is greater or equal"
(dynamic \(Typed i) -> Typed (Ge i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Eq" "is equal to"
(dynamic \(Typed i) -> Typed (Eq i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Le" "is lesser than"
(dynamic \(Typed i) -> Typed (Le i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalBoxedLayout
, functionConsDyn "Lt" "is lesser than"
(dynamic \(Typed i) -> Typed (Lt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ 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 "Date" "the date"
(dynamic \d -> Typed (Date d) :: Date -> Typed Expr Date)
<<@@@ 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.Date" "Date"
(dynamic Typed (Ty VDate) :: Typed Ty Date)
<<@@@ 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
, customEditorCons "date" "(enter date )" dateEditor <<@@@ HideIfOnlyChoice
]
]
where
intEditor :: Editor Int
intEditor = gEditor{|*|}
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
stringEditor :: Editor String
stringEditor = gEditor{|*|}
dateEditor :: Editor Date
dateEditor = 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 //////////////////////////////////////////////////////////////////
// globalValueShare :: SimpleSDSLens ( Ty, List Value )
// globalValueShare = sharedStore "global share for typed task editor" ( abort "Global share not initialised", [] )
globalValueShare :: SimpleSDSLens (List Int)
globalValueShare = sharedStore "global share for typed task editor" []
evalTaskExpr :: TaskExpr -> Task Value
evalTaskExpr (Done expr) = return $ evalExpr expr
evalTaskExpr (EnterInfo (Ty toValue) msg) = enterInformation msg [] @ toValue
evalTaskExpr (Then task taskFunc) = evalTaskExpr task >>= evalTaskFunc taskFunc
evalTaskExpr (Both task1 task2) = (evalTaskExpr task1 -&&- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal @ \(a, b) -> VPair a b
evalTaskExpr (Any task1 task2) = (evalTaskExpr task1 -||- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal
evalTaskExpr (One button1 task1 button2 task2) = viewInformation "Make a choice" [] () >?>
[ ( button1, const True, \_ -> evalTaskExpr task1 )
, ( button2, const True, \_ -> evalTaskExpr task2 )
]
// evalTaskExpr (Init sharedTy task) = set ( sharedTy, [] ) globalValueShare >>| evalTaskExpr task
evalTaskExpr (Watch msg) = viewSharedInformation msg [] globalValueShare @ (const VUnit)
evalTaskExpr (Forever task) = forever (evalTaskExpr task)
// evalTaskExpr (When task1 options) = evalTaskExpr task1
// >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFunc cont))
// \\ {name, pred, cont} <- options
// ]
// where
// test pred (VInt i) = case pred of
// Lt (VInt j) -> i < j
// Gt (VInt j) -> i > j
// Eq (VInt j) -> i == j
// test pred (VBool i) = case pred of
// Eq (VBool j) -> i == j
// Lt (VBool j) -> False
// Gt (VBool j) -> False
evalTaskFunc :: TaskFunc Value -> Task Value
evalTaskFunc (ThenF this next) val =
evalTaskFunc this val >>= evalTaskFunc next
evalTaskFunc (ViewF msg func) val = case evalFunc val func of
(VInt i) -> (viewInformation msg [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
(VBool b) -> (viewInformation msg [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
(VString s) -> (viewInformation msg [] s @ VString) <<@ ApplyLayout arrangeHorizontal
(VDate s) -> (viewInformation msg [] s @ VDate) <<@ ApplyLayout arrangeHorizontal
(VPair a b) ->
( viewInformation msg [] ()
||- (evalTaskFunc (ViewF "" Identity) a -&&- evalTaskFunc (ViewF "" Identity) b)
@ \(a, b) -> VPair a b
)
<<@ ApplyLayout arrangeHorizontal
evalTaskFunc (UpdateF msg func) val = case evalFunc val func of
(VInt i) -> (updateInformation msg [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
(VBool b) -> (updateInformation msg [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
(VString s) -> (updateInformation msg [] s @ VString) <<@ ApplyLayout arrangeHorizontal
(VDate s) -> (updateInformation msg [] s @ VDate) <<@ ApplyLayout arrangeHorizontal
(VPair a b) ->
( viewInformation msg [] ()
||- (evalTaskFunc (UpdateF "" Identity) a -&&- evalTaskFunc (UpdateF "" Identity) b)
@ \(a, b) -> VPair a b
)
<<@ ApplyLayout arrangeHorizontal
evalTaskFunc (StoreF) (VInt i) =
// upd (\( sharedTy, values ) -> ( sharedTy, cons val values)) globalValueShare @ (const VUnit)
upd (cons i) globalValueShare @ (const VUnit)
evalTaskFunc (WatchF msg) val =
viewSharedInformation msg [] globalValueShare @ (const VUnit)
evalExpr :: Expr -> Value
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
evalExpr (Date d) = VDate d
evalExpr (Pair fstExpr sndExpr) = VPair (evalExpr fstExpr) (evalExpr sndExpr)
evalExpr (Apply func expr) = evalFunc (evalExpr expr) func
evalFunc :: Value Func -> Value
evalFunc val Identity = val
evalFunc (VInt i1) func = case func of
(Gt expr) -> VBool $ i1 > evalInt expr
(Ge expr) -> VBool $ i1 >= evalInt expr
(Eq expr) -> VBool $ i1 == evalInt expr
(Le expr) -> VBool $ i1 <= evalInt expr
(Lt expr) -> VBool $ i1 < evalInt expr
(Add expr) -> VInt $ i1 + evalInt expr
(Sub expr) -> VInt $ i1 - evalInt expr
(Mul expr) -> VInt $ i1 * evalInt expr
(Div expr) -> VInt $ i1 / evalInt expr
where
evalInt :: Expr -> Int
evalInt expr = case evalExpr expr of
(VInt i) -> i
evalFunc (VBool b1) func = case func of
(Eq expr) -> VBool $ b1 == evalBool expr
(Conj expr) -> VBool $ b1 && evalBool expr
(Disj expr) -> VBool $ b1 || evalBool expr
(Not) -> VBool $ not b1
where
evalBool :: Expr -> Bool
evalBool expr = case evalExpr expr of
(VBool b) -> b
evalFunc (VString s1) func = case func of
(Eq expr) -> VBool $ s1 == evalString expr
where
evalString :: Expr -> String
evalString expr = case evalExpr expr of
(VString s) -> s
evalFunc (VDate d1) func = case func of
(Eq expr) -> VBool $ d1 == evalDate expr
(Gt expr) -> VBool $ d1 > evalDate expr
(Ge expr) -> VBool $ d1 >= evalDate expr
(Eq expr) -> VBool $ d1 == evalDate expr
(Le expr) -> VBool $ d1 <= evalDate expr
(Lt expr) -> VBool $ d1 < evalDate expr
where
evalDate :: Expr -> Date
evalDate expr = case evalExpr expr of
(VDate d) -> d
evalFunc (VPair x1 x2) func = case func of
Fst -> x1
Snd -> x2
instance toString Value where
toString val = case val of
VUnit -> "()"
VInt i -> toString i
VBool b -> toString b
VString s -> toString s
VDate d -> toString d
VPair x y -> "( " +++ toString x +++ ", " +++ toString y +++ " )"
Examples/DynamicEditor/DynEditorExample.prj.default 0 → 100644
View file @ d01b2680
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
Libraries/iTasks/Extensions/Editors/DynamicEditor.css 0 → 100644
View file @ d01b2680
.itasks-dynamic-editor-icon-error-container {
align-self: center;
padding: 0.2em;
}
.itasks-dynamic-editor-error {
background-color: #FFDDDD;
}
Libraries/iTasks/Extensions/Editors/DynamicEditor.dcl
View file @ d01b2680
......@@ -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
......
Libraries/iTasks/Extensions/Editors/DynamicEditor.icl
View file @ d01b2680
......@@ -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)]
# change = ChangeUI mbErrorIconAttrChange $ [(0, ChangeChild $ ChangeUI [] [(argIdx + if hideCons 0 1, ChangeChild change)])] ++ mbErrorIconChange
// replace state for this child
= (Ok (change, Just (cid, type), updateAt (argIdx + 1) childSt childSts), vst)
= (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)
removeNChildren :: !Int -> [(!Int, !UIChildChange)]
removeNChildren nrArgs = repeatn nrArgs (1, RemoveChild)
typeWasInvalid (Just (_, _, False)) = True
typeWasInvalid _ = False
childrenEditors :: !Dynamic -> [E]
childrenEditors (f :: a -> b) = [E $ dynamicEditorFstArg f : childrenEditors (dynamic (f undef))]
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
// first argument only used for type
dynamicEditorFstArg :: (a -> b) -> Editor (DynamicEditorValue a) | TC a
dynamicEditorFstArg _ = dynamicEditor $ DynamicEditor elements
childrenEditors _ = []
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)
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