Commit 64825291 authored by Tim Steenvoorden's avatar Tim Steenvoorden

add simple share of integers

parent cc5f03a5
...@@ -15,6 +15,8 @@ import iTasks.Extensions.Editors.DynamicEditor ...@@ -15,6 +15,8 @@ import iTasks.Extensions.Editors.DynamicEditor
always x :== const True x always x :== const True x
cons x xs :== [x:xs]
(>?>) infixl 1 :: (Task a) (List ( Button, a -> Bool, a -> Task b )) -> Task b | iTask a & iTask b (>?>) infixl 1 :: (Task a) (List ( Button, a -> Bool, a -> Task b )) -> Task b | iTask a & iTask b
(>?>) task options = task >>* map trans options (>?>) task options = task >>* map trans options
where where
...@@ -56,11 +58,16 @@ where ...@@ -56,11 +58,16 @@ where
| Both TaskExpr TaskExpr | Both TaskExpr TaskExpr
| Any TaskExpr TaskExpr | Any TaskExpr TaskExpr
| One Button TaskExpr Button TaskExpr | One Button TaskExpr Button TaskExpr
// | Init Ty TaskExpr
| Watch String
// | Change String
:: TaskFunc :: TaskFunc
= ThenF TaskFunc TaskFunc = ThenF TaskFunc TaskFunc
| ViewF String Func | ViewF String Func
| UpdateF String Func | UpdateF String Func
| StoreF
| WatchF String
:: Expr :: Expr
= Int Int = Int Int
...@@ -87,7 +94,8 @@ where ...@@ -87,7 +94,8 @@ where
| Snd | Snd
:: Value :: Value
= VInt Int = VUnit
| VInt Int
| VBool Bool | VBool Bool
| VString String | VString String
| VTuple Value Value | VTuple Value Value
...@@ -102,12 +110,12 @@ derive class iTask TaskExpr, TaskFunc, Expr, Func, Value, Typed ...@@ -102,12 +110,12 @@ derive class iTask TaskExpr, TaskFunc, Expr, Func, Value, Typed
// These instances cannot be auto derived because of the existential quantifier. // These instances cannot be auto derived because of the existential quantifier.
// However, they will be never used, so we make them undefined. // However, they will be never used, so we make them undefined.
gDefault{|Ty|} = undef gDefault{|Ty|} = abort "Typed task editor: internal error with gDefault of Ty"
gEq{|Ty|} _ _ = undef gEq{|Ty|} _ _ = abort "Typed task editor: internal error with gEq of Ty"
JSONEncode{|Ty|} _ _ = undef JSONEncode{|Ty|} _ _ = abort "Typed task editor: internal error with JSONEncode of Ty"
JSONDecode{|Ty|} _ _ = undef JSONDecode{|Ty|} _ _ = abort "Typed task editor: internal error with JSONDecode of Ty"
gText{|Ty|} _ _ = undef gText{|Ty|} _ _ = abort "Typed task editor: internal error with gText of Ty"
gEditor{|Ty|} = undef gEditor{|Ty|} = abort "Typed task editor: internal error with gEditor of Ty"
// Editor ////////////////////////////////////////////////////////////////////// // Editor //////////////////////////////////////////////////////////////////////
...@@ -224,6 +232,37 @@ taskEditor = DynamicEditor ...@@ -224,6 +232,37 @@ taskEditor = DynamicEditor
<<@@@ applyHorizontalBoxedLayout <<@@@ applyHorizontalBoxedLayout
] ]
// Non-task functions: // Non-task functions:
, 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" , DynamicConsGroup "Basics"
[ functionConsDyn "Identity" "this value" [ functionConsDyn "Identity" "this value"
(dynamic Typed Identity :: A.a: Typed Func (a -> a)) (dynamic Typed Identity :: A.a: Typed Func (a -> a))
...@@ -355,17 +394,23 @@ where ...@@ -355,17 +394,23 @@ where
// Evaluation ////////////////////////////////////////////////////////////////// // Evaluation //////////////////////////////////////////////////////////////////
// globalValueShare :: SimpleSDSLens ( Ty, List Value )
// globalValueShare = sharedStore "global share for typed task editor" ( abort "Global share not initialised", [] )
globalValueShare :: SimpleSDSLens (List Value)
globalValueShare = sharedStore "global share for typed task editor" []
evalTaskExpr :: TaskExpr -> Task Value evalTaskExpr :: TaskExpr -> Task Value
evalTaskExpr (Done expr) = return $ evalExpr expr evalTaskExpr (Done expr) = return $ evalExpr expr
evalTaskExpr (EnterInfo (Ty toValue) msg) = enterInformation msg [] @ toValue evalTaskExpr (EnterInfo (Ty toValue) msg) = enterInformation msg [] @ toValue
evalTaskExpr (Then task taskFunc) = evalTaskExpr task >>= evalTaskFunc taskFunc evalTaskExpr (Then task taskFunc) = evalTaskExpr task >>= evalTaskFunc taskFunc
evalTaskExpr (Both task1 task2) = (evalTaskExpr task1 -&&- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal @ \(a, b) -> VTuple a b evalTaskExpr (Both task1 task2) = (evalTaskExpr task1 -&&- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal @ \(a, b) -> VTuple a b
evalTaskExpr (Any task1 task2) = (evalTaskExpr task1 -||- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal evalTaskExpr (Any task1 task2) = (evalTaskExpr task1 -||- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal
evalTaskExpr (One button1 task1 button2 task2) evalTaskExpr (One button1 task1 button2 task2) = viewInformation "Make a choice" [] () >?>
= viewInformation "Make a choice" [] () >?>
[ ( button1, const True, \_ -> evalTaskExpr task1 ) [ ( button1, const True, \_ -> evalTaskExpr task1 )
, ( button2, const True, \_ -> evalTaskExpr task2 ) , ( button2, const True, \_ -> evalTaskExpr task2 )
] ]
// evalTaskExpr (Init sharedTy task) = set ( sharedTy, [] ) globalValueShare >>| evalTaskExpr task
evalTaskExpr (Watch msg) = viewSharedInformation msg [] globalValueShare @ (const VUnit)
// evalTaskExpr (When task1 options) = evalTaskExpr task1 // evalTaskExpr (When task1 options) = evalTaskExpr task1
// >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFunc cont)) // >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFunc cont))
...@@ -383,7 +428,8 @@ evalTaskExpr (One button1 task1 button2 task2) ...@@ -383,7 +428,8 @@ evalTaskExpr (One button1 task1 button2 task2)
evalTaskFunc :: TaskFunc Value -> Task Value evalTaskFunc :: TaskFunc Value -> Task Value
evalTaskFunc (ThenF this next) val = evalTaskFunc this val >>= evalTaskFunc next evalTaskFunc (ThenF this next) val =
evalTaskFunc this val >>= evalTaskFunc next
evalTaskFunc (ViewF msg func) val = case evalFunc val func of evalTaskFunc (ViewF msg func) val = case evalFunc val func of
(VInt i) -> (viewInformation msg [] i @ VInt) <<@ ApplyLayout arrangeHorizontal (VInt i) -> (viewInformation msg [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
...@@ -407,6 +453,14 @@ evalTaskFunc (UpdateF msg func) val = case evalFunc val func of ...@@ -407,6 +453,14 @@ evalTaskFunc (UpdateF msg func) val = case evalFunc val func of
) )
<<@ ApplyLayout arrangeHorizontal <<@ ApplyLayout arrangeHorizontal
evalTaskFunc (StoreF) val =
// upd (\( sharedTy, values ) -> ( sharedTy, cons val values)) globalValueShare @ (const VUnit)
upd (cons val) globalValueShare @ (const VUnit)
evalTaskFunc (WatchF msg) val =
viewSharedInformation msg [] globalValueShare @ (const VUnit)
evalExpr :: Expr -> Value evalExpr :: Expr -> Value
evalExpr (Int i) = VInt i evalExpr (Int i) = VInt i
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment