module test
+import Graphics.Scalable.Internal.Types
import StdMisc
import Data.Func
import Data.Tuple
Start w = doTasks gui6 w
gui1 :: Int -> Task Int
-gui1 c = viewInformation "Counter" [] c
+gui1 c = viewInformation [] c <<@ Label "Counter"
>>* [OnAction (Action "Count") (withValue (Just o gui1 o inc))]
gui2 :: Task Real
gui2 = withShared 42.0 \sh->
- updateSharedInformation "Celcius" [] sh
- -|| updateSharedInformation "Fahrenheit"
- [UpdateAs (\c->1.8*c+32.0) \_ f->(f-32.0)/1.8] sh
+ (updateSharedInformation [] sh <<@ Label "Celcius")
+ -|| updateSharedInformation
+ [UpdateSharedAs (\c->1.8*c+32.0) (\_ f->(f-32.0)/1.8) const] sh <<@ Label "Fahrenheit"
//This should be possible with just a custom editor...
:: Flight
derive class iTask Flight
gui3 :: Task Flight
gui3 = get currentDate
- >>- \now->editChoice () [] ["one-way flight", "return flight"] (Just "one-way flight")
+ >>- \now->editChoice [] ["one-way flight", "return flight"] (Just "one-way flight")
>&> \sh-> whileUnchanged sh \v->case fromJust v of
"one-way flight" = withShared now \sh->
- updateSharedInformation () [] sh
- -|| updateSharedInformation () [UpdateUsing toString const (gEditor{|*|} <<@ enabledAttr False)] sh
+ updateSharedInformation [] sh
+ -|| updateSharedInformation [UpdateSharedUsing toString const const (gEditor{|*|} <<@ enabledAttr False)] sh
>>* [OnAction (Action "Book") $ ifValue (\_->True) $ return o OneWay]
"return flight"
- = updateInformation () [] now
- -&&- updateInformation () [] now
+ = updateInformation [] now
+ -&&- updateInformation [] now
>>* [OnAction (Action "Book") $ ifValue (uncurry (<)) $ return o Return]
gui4 :: Timestamp Int -> Task Timestamp
gui4 startTime duration = withShared duration \duration->
- viewSharedInformation "Elapsed time: " [ViewUsing toProgress progressBar] (currentTimestamp >*< duration)
- -&&- viewSharedInformation () [ViewAs \now->on (-) toInt now startTime] currentTimestamp
- -&&- updateSharedInformation "Duration: " [UpdateUsing id (const id) $ slider <<@ minAttr 0 <<@ maxAttr 3600] duration
+ (viewSharedInformation [ViewUsing toProgress progressBar] (currentTimestamp >*< duration) <<@ Label "Elapsed time: ")
+ -&&- viewSharedInformation [ViewAs \now->on (-) toInt now startTime] currentTimestamp
+ -&&- updateSharedInformation [UpdateSharedUsing id (const id) const $ slider <<@ minAttr 0 <<@ maxAttr 3600] duration <<@ Label "Duration: "
>>* [OnAction (Action "Reset") $ always $ get (currentTimestamp >*< duration) >>- uncurry gui4]
where
toProgress (now, duration) =
gui5 :: Task (Int, Name)
gui5 = withShared ('DM'.fromList [(0, name "Emil" "Hans"), (1, name "Mustermann" "Max"), (2, name "Tisch" "Roman")]) \data->
- enterInformation "Filter prefix" []
+ enterInformation [] <<@ Title "Filter prefix"
>&> \v->whileUnchanged (mapRead (fromMaybe " ") v) \filter->
tune ArrangeHorizontal
- $ enterChoiceWithShared () [ChooseFromList (toString o snd)] (mapRead 'DM'.toList data)
+ $ enterChoiceWithShared [ChooseFromList (toString o snd)] (mapRead 'DM'.toList data)
>&> \sh->whileUnchanged sh \v->case v of
Nothing = return () @? const NoValue
- Just x = updateInformation () [UpdateAs snd (tuple o fst)] x
+ Just x = updateInformation [UpdateAs snd (tuple o fst)] x
>^* [ OnAction (Action "new") $ always $ upd (\l->'DM'.put (inc $ maxList $ 'DM'.keys l) (name "-" "-") l) data
, OnAction (Action "update") $ withValue \(i, n)->Just $ upd ('DM'.put i n) data
, OnAction (Action "delete") $ withValue \(i, n)->Just $ upd ('DM'.del i) data
]
-gui6 :: Task [(Real, Real, Real)]
-gui6 = updateInformation ()
+gui6 :: Task [(Span, Span, Span)]
+gui6 = updateInformation
[UpdateUsing id (const id) (fromSVGEditor svged)]
- [(5.0, 5.0, 5.0)]
+ [(px 5.0, px 5.0, px 5.0)]
-svged :: SVGEditor [(Real, Real, Real)] [(Real, Real, Real)]
-svged = {initView=id, renderImage=renderImage, updModel=const id}
+svged :: SVGEditor [(Span, Span, Span)] [(Span, Span, Span)]
+svged = {initView=id, renderImage=renderImage, updModel= \m v->v}
where
renderImage _ images ts
# (_, images) = trace_stdout ("img: ", images)
- = collage [(px x, px y)\\(_, x, y)<-images] [circle (px r)\\(r, _, _)<-images]
- $ Host $ rect (px 100.0) (px 100.0)
- <@< {fill=toSVGColor "white"}
- <@< {onclick=clicker,local=False}
+ = overlay
+ [(AtMiddleX, AtMiddleY)]
+ [(px 0.0, px 0.0)]
+ [img]
+ $ Host $ rect (px 1000.0) (px 1000.0)
+ <@< {fill=toSVGColor "white"}
+ where
+ img = collage [(x, y)\\(_, x, y)<-images] [circle r\\(r, _, _)<-images]
+ $ Host $ rect (px 100.0) (px 100.0)
+ <@< {fill=toSVGColor "white"}
+ <@< {onclick=clicker,local=False}
- clicker m = jsTrace "click" [(5.0, 10.0, 10.0):m]
+ clicker (x, y) m = [(px 5.0, x, y):m]
import Debug.Trace, StdDebug
import iTasks.UI.JavaScript
+derive gEq Span, LookupSpan, ImageTag
+derive gText Span, LookupSpan, ImageTag, FontDef`
+derive JSONEncode Span, LookupSpan, ImageTag
+derive JSONDecode Span, LookupSpan, ImageTag
+derive gEditor Span, LookupSpan, ImageTag, FontDef`
--- /dev/null
+module dsl
+
+import StdEnv
+
+import Data.Func => qualified app
+import Data.Functor
+import Data.Either
+import Data.GenEq
+import Data.Functor.Identity
+import Control.Applicative
+import Control.Monad => qualified join
+import Text
+
+import Text.Parsers.Simple.Core
+
+class Symantics v where
+ int :: Int -> v Int
+ bool :: Bool -> v Bool
+ lam :: ((v a) -> v b) -> v (a -> b)
+ app :: (v (a -> b)) (v a) -> v b
+ Fix :: ((v a) -> (v a)) -> v a
+ add :: (v a) (v a) -> v a | + a
+ mul :: (v a) (v a) -> v a | * a
+ leq :: (v a) (v a) -> v Bool | Ord a
+ If :: (v Bool) (v a) (v a) -> v a
+
+//Run the object
+:: Run a = Run a
+runRun (Run a) = a
+instance Functor Run where fmap f a = Run $ f $ runRun a
+instance pure Run where pure a = Run a
+instance <*> Run where <*> a b = Run $ runRun a $ runRun b
+instance Symantics Run where
+ int a = pure a
+ bool a = pure a
+ lam f = pure $ runRun o f o Run
+ app f a = f <*> a
+ Fix f = pure $ let x = runRun $ f $ pure x in x
+ add a b = (+) <$> a <*> b
+ mul a b = (*) <$> a <*> b
+ leq a b = (<=) <$> a <*> b
+ If i t e = if` <$> i <*> t <*> e
+
+//Length of the object
+:: Length a = Length Int
+runLength (Length i) = i
+(+.) infixl 6
+(+.) (Length a) (Length b) = Length $ a + b
+instance one (Length a) where one = Length 1
+instance zero (Length a) where zero = Length 0
+instance Symantics Length where
+ int _ = one
+ bool _ = one
+ lam f = f zero +. one
+ app f a = f +. a +. one
+ Fix f = f zero +. one
+ add a b = a +. b +. one
+ mul a b = a +. b +. one
+ leq a b = a +. b +. one
+ If i t e = i +. t +. e +. one
+
+//Print the object
+:: Print a = Print (Int [String] -> [String])
+runPrint (Print a) = a
+print a = concat $ runPrint a 0 []
+var i = "v" +++ toString i
+show a = Print \_ c->[toString a:c]
+binop op (Print a) (Print b) = Print \i c->["(":a i [op: b i [")":c]]]
+instance Symantics Print where
+ int a = show a
+ bool a = show a
+ lam f = Print \i c->["(\\", var i, ".":runPrint (f $ show $ var i) (i+1) [")":c]]
+ app f a = Print \i c->["(":runPrint f i [" ":runPrint a i [")":c]]]
+ Fix f = Print \i c->["fix (\\","self.":runPrint (f $ show "self") (i+1) [")":c]]
+ add a b = binop "+" a b
+ mul a b = binop "*" a b
+ leq a b = binop "<=" a b
+ If p t e = Print \i c->["if ":runPrint p i [" then ":runPrint t i [" else ":runPrint e i c]]]
+
+//Parsing
+:: Token = IntToken Int | BoolToken Bool | BrackOpenToken | BrackCloseToken | LeqToken | AddToken | MulToken | IfToken
+derive gEq Token
+instance == Token where == a b = a === b
+
+lex :: [Char] -> Either [String] [Token]
+lex [] = Right []
+lex [')':cs] = clex cs BrackCloseToken
+lex ['(':cs] = clex cs BrackOpenToken
+lex ['<=':cs] = clex cs LeqToken
+lex ['+':cs] = clex cs AddToken
+lex ['*':cs] = clex cs MulToken
+lex ['True':cs] = clex cs $ BoolToken True
+lex ['False':cs] = clex cs $ BoolToken False
+lex ['-',c:cs]
+ | isDigit c = lex [c:cs] >>= \v->case v of
+ [IntToken i:rest] = Right [IntToken (~i):rest]
+ x = pure x
+lex [c:cs]
+ | isSpace c = lex cs
+ | isDigit c
+ # (d, cs) = span isDigit [c:cs]
+ = clex cs $ IntToken $ toInt $ toString d
+ = Left ["Unexpected: " +++ toString c +++ " ord: " +++ toString (toInt c)]
+
+clex :: [Char] Token -> Either [String] [Token]
+clex cs t = (\ts->[t:ts]) <$> lex cs
+
+class parseSym a where
+ parseSym :: Parser Token (v a) | Symantics v
+instance parseSym Int where
+ parseSym
+ = flip pChainl1 (add <$ pToken AddToken)
+ $ flip pChainl1 (mul <$ pToken MulToken)
+ $ pToken BrackOpenToken *> parseSym <* pToken BrackCloseToken
+ <|> If <$ pToken IfToken <*> parseSym <*> parseSym <*> parseSym
+ <|> int <$> pInt
+ where
+ pInt = pSatisfy (\t->t=:(IntToken _)) >>= \(IntToken i)->pure i
+instance parseSym Bool where
+ parseSym
+ = leq <$> parseSymInt <* pToken LeqToken <*> parseSymInt
+ <|> If <$ pToken IfToken <*> parseSym <*> parseSym <*> parseSym
+ <|> pToken BrackOpenToken *> parseSym <* pToken BrackCloseToken
+ <|> bool <$> pBool
+ where
+ pBool = pSatisfy (\t->t=:(BoolToken _)) >>= \(BoolToken b)->pure b
+
+ parseSymInt :: Parser Token (v Int) | Symantics v
+ parseSymInt = parseSym
+
+Start = print <$> exp
+where
+ exp :: Either [String] (v Bool) | Symantics v
+ exp = lex (fromString inp) >>= parse parseSym
+
+ inp = "1+2*3 <= 42*42"
+//Start =
+// [ toString $ runRun fourtytwo
+// , print fourtytwo
+// , toString $ runRun true
+// , print true
+// , toString $ runRun powfix33
+// , print powfix33
+// , toString $ runRun factfix5
+// , print factfix5
+// ]
+
+fourtytwo :: v Int | Symantics v
+fourtytwo = add (int 38) (int 4)
+
+true :: v Bool | Symantics v
+true = app (lam (\x->x)) (bool True)
+
+powfix = lam \x->Fix \self->lam \n->
+ If (leq n (int 0)) (int 1)
+ (mul x (app self (add n (int -1))))
+
+powfix33 = app (app powfix (int 3)) (int 3)
+
+factfix = Fix \self->lam \n->
+ If (leq n (int 0)) (int 1)
+ (mul n (app self (add n (int -1))))
+
+factfix5 = app factfix (int 5)
--- /dev/null
+module test
+
+import Data.Func
+import iTasks.Extensions.DateTime
+import qualified Data.Map as DM
+import qualified Data.Set as DS
+import iTasks
+
+//:: SDSStamped sds p r w = SDSStamped String (sds p (DateTime, r) (DateTime, w))
+//instance Identifiable (SDSStamped sds) | Identifiable sds
+//where
+// nameSDS (SDSStamped n sds) acc = ["t$":nameSDS sds ["$t":acc]]
+//instance Readable (SDSStamped sds) | Readable sds
+//where
+// readSDS (SDSStamped name sds) p c iworld
+// = case readSDS sds p c iworld of
+// (Error e, iworld) = (Error e, iworld)
+// (Ok (ReadResult r ssds), iworld)
+// = (Ok (ReadResult r (SDSStamped name ssds)), iworld)
+// (Ok (AsyncRead sds), iworld)
+// = (Ok (AsyncRead (SDSStamped name sds)), iworld)
+//
+
+:: SDSNoNotify p r w = E.sds: SDSNoNotify (sds p r w) & RWShared sds
+instance Identifiable SDSNoNotify where
+ nameSDS (SDSNoNotify sds) c = nameSDS sds c
+instance Readable SDSNoNotify where
+ readSDS (SDSNoNotify sds) p c iworld
+ = case readSDS sds p c iworld of
+ (Error e, iworld) = (Error e, iworld)
+ (Ok (ReadResult r sds), iworld)
+ = (Ok (ReadResult r sds), iworld)
+ (Ok (AsyncRead sds), iworld)
+ = (Ok (AsyncRead sds), iworld)
+
+instance Writeable SDSNoNotify where
+ writeSDS (SDSNoNotify sds) p c w iworld
+ = case writeSDS sds p c w iworld of
+ (Error e, iworld) = (Error e, iworld)
+ (Ok (WriteResult _ sds), iworld)
+ = (Ok (WriteResult 'DS'.newSet (SDSNoNotify sds)), iworld)
+ (Ok (AsyncWrite sds), iworld)
+ = (Ok (AsyncWrite (SDSNoNotify sds)), iworld)
+instance Registrable SDSNoNotify where
+ readRegisterSDS (SDSNoNotify sds) p c _ _ iworld
+ = case readSDS sds p c iworld of
+ (Error e, iworld) = (Error e, iworld)
+ (Ok (ReadResult r sds), iworld)
+ = (Ok (ReadResult r sds), iworld)
+ (Ok (AsyncRead sds), iworld)
+ = (Ok (AsyncRead sds), iworld)
+instance Modifiable SDSNoNotify where
+ modifySDS mf (SDSNoNotify sds) p c iworld
+ = case modifySDS mf sds p c iworld of
+ (Error e, iworld) = (Error e, iworld)
+ (Ok (ModifyResult _ r w sds), iworld)
+ = (Ok (ModifyResult 'DS'.newSet r w (SDSNoNotify sds)), iworld)
+ (Ok (AsyncModify sds mf), iworld)
+ = (Ok (AsyncModify (SDSNoNotify sds) mf), iworld)
+
+
+sh = sharedStore "bork" ({DateTime|year=0,mon=0,day=0,hour=0,min=0,sec=0}, 42)
+
+Start w = doTasks t w
+//Start w = nameSDS (SDSStamped "bork" sh) []
+
+stampedShare :: (Shared sds (DateTime, a)) -> SDSLens () (DateTime, a) a | TC a & RWShared sds
+stampedShare sds =
+ mapReadWrite (fst , \a (_, dt)->Just ((dt, a), dt)) Nothing
+ $ sds >*< (mapWrite (\_ _->Nothing) Nothing currentDateTime)
+
+t = viewSharedInformation [] sh
+ -&&- updateSharedInformation [] (stampedShare sh)
--- /dev/null
+module test
+import qualified Data.Map as DM
+import iTasks
+
+Start w = doTasks
+ (parallel
+ [(Embedded, tab "tab1")
+ ,(Embedded, tab "tab2")
+ ]
+ [ OnAction (Action "New") (always (Embedded, tab "New tab"))
+ , OnAction (Action " ") (always (Embedded, tab "New tab"))
+ , OnAction (Action "Close") (never (Embedded, \_->treturn ()))
+ , OnAction (Action "Dis no icon") (never (Embedded, \_->treturn ()))
+ , OnAction (Action "+") (always (Embedded, \_->treturn ()))
+ ]
+ <<@ ArrangeWithTabs True
+ <<@ ApplyLayout (setActionIcon ('DM'.put " " "new" 'DM'.newMap))
+ ) w
+
+tab title _ = viewInformation [] () <<@ Title title
+ >>* [OnAction (Action "Close") (always (treturn ()))]
module test
-//
-//import Data.Func, StdFunctions, iTasks
-//
-//derive gDefault ChoiceNode
-//
-//Start w = flip doTasks w $
-// withShared 5 \sharedInt->
-// withShared [] \sharedSel->
-// (editSharedSelectionWithShared
-// [SelectInTree
-// (\l->[{defaultValue & id=i,label=toString i}\\i<-[0..l]])
-// (\_ s->s)
-// ] sharedInt sharedSel <<@ Title "Selection" <<@ multipleAttr False)
-// -|| (updateSharedInformation [] sharedInt <<@ Title "Number of items")
-// -|| (updateSharedInformation [] sharedSel <<@ Title "Current selection")
-// >&> \sh->(viewSharedInformation [] (mapRead toSingleLineText sh) <<@ Title "Current task value" )
-//
-//from Data.Map import singleton
-//import Data.Map.GenJSON
-//import iTasks
-//
-//Start w = doTasks t w
-//
-//t :: Task [(Int, TaskValue Int)]
-//t = parallel
-// [(Embedded, \stl->
-// appendTask Embedded (\_->viewInformation [] 42) stl
-// >>! \i->set (singleton "focus" (JSONBool True)) (sdsFocus i (taskListEntryMeta stl))
-// >>~ \_->viewSharedInformation []
-// (sdsFocus {onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False,includeValue=True,includeProgress=True,includeAttributes=True} stl)
-// @! 42
-// )] []
-
-//import iTasks
-//Start w = doTasks t w
-//where
-// t = viewInformation [ViewUsing id progressBar] (Just 80, Just long) <<@ Title "bork"
-// long = "borkueaohutenhuaostuehasunethuaosnuhtesuhaotsuehtausneohtusoauhtesauhtesnuhtasuhetauhosunehtoauesnhtaueshautesnhutaonsuhetaonsuhetansuhetansuhetaosnuehtaosnuhetaosunhaoetsunehatounsoehtasunhteunaoshuteoasnuhteaosuhnaoetsnuheotasunehotasunhetusnahotueaou"
-
+import Data.Func
+import qualified Data.Map as DM
import iTasks
-:: R = { x :: !String, y :: !String }
-derive class iTask R
+/*
+Start w = doTasksWithOptions
+// (\a o->Ok o)
+ (\a o->Ok {o & autoLayout=False})
+ (parallel
+ [(Embedded, tab "tab1")
+ ,(Embedded, tab "tab2")
+ ]
+ [ OnAction (Action "New") (always (Embedded, tab "New tab"))
+ , OnAction (Action " ") (always (Embedded, tab "New tab"))
+ , OnAction (Action "Close") (never (Embedded, \_->treturn ()))
+ , OnAction (Action "Dis no icon") (never (Embedded, \_->treturn ()))
+ , OnAction (Action "+") (always (Embedded, \_->treturn ()))
+ ]
+// <<@ ArrangeWithTabs True
+ <<@ ApplyLayout (setActionIcon ('DM'.put " " "new" 'DM'.newMap))
+ ) w
+
+tab title _ = tune (Title title)
+ $ viewInformation [] title
+ >>* [OnAction (Action "Close") (always (treturn ()))]
+*/
-Start w = doTasks (t -&&- u) w
+import StdDebug, Text.GenPrint
+Start w = doTasks (onStartup t) w
-t = updateSharedInformation
- [ UpdateSharedAs
- (\r -> r.x)
- (\r x -> {r & x=x})
- const
- ] s
-u = updateSharedInformation [] s
+null :: SDSSource () () ()
+null = nullShare
-s = sharedStore "x" {x="",y=""}
+t = tcpconnect "localhost" 9999 (Just 500) null
+//t = tcpconnect "localhost" 9999 Nothing null
+ { onConnect = \cid host r = trace_n (printToString ("onConnect: ", cid, host, r))
+ (Ok (), Nothing, [], False)
+ , onData = \ data l r = trace_n (printToString ("onData: ", data, l, r))
+ (Ok (), Nothing, [], False)
+ , onShareChange = \ l r = trace_n (printToString ("onShareChange: ", l, r))
+ (Ok (), Nothing, [], False)
+ , onDisconnect = \ l r = trace_n (printToString ("onDisconnect: ", l, r))
+ (Ok (), Nothing)
+ , onDestroy = \ l = trace_n (printToString ("onDestroy: ", l))
+ (Ok (), [])
+ }
--- /dev/null
+*** test HTTP server ***
+
+Running at http://localhost:8080/
+[5, TOUIChange ReplaceUI UIHtmlView Bin 4 height "flex" Bin 1 class [] Tip Tip Bin 2 value "\80" Tip Bin 1 width "flex" Tip Tip []]
repositories / clean-tests.git / commitdiff