From e1f8e1ebd0c95e7bfefb6618a5996fe9b3accc04 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 10 Oct 2019 14:19:22 +0200 Subject: [PATCH] things --- 7gui/test.icl | 63 +++++++++------- dsl/dsl.icl | 164 ++++++++++++++++++++++++++++++++++++++++++ stampedShare/test.icl | 73 +++++++++++++++++++ tabbar/test.icl | 21 ++++++ test.icl | 91 +++++++++++------------ test.txt | 4 ++ 6 files changed, 341 insertions(+), 75 deletions(-) create mode 100644 dsl/dsl.icl create mode 100644 stampedShare/test.icl create mode 100644 tabbar/test.icl create mode 100644 test.txt diff --git a/7gui/test.icl b/7gui/test.icl index b76ee57..e2b46cb 100644 --- a/7gui/test.icl +++ b/7gui/test.icl @@ -1,5 +1,6 @@ module test +import Graphics.Scalable.Internal.Types import StdMisc import Data.Func import Data.Tuple @@ -21,14 +22,14 @@ import Data.Map.GenJSON 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 @@ -37,22 +38,22 @@ gui2 = withShared 42.0 \sh-> 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) = @@ -66,34 +67,46 @@ instance toString Name where toString n = n.Name.name +++ ", " +++ n.surname 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` diff --git a/dsl/dsl.icl b/dsl/dsl.icl new file mode 100644 index 0000000..d8dd42e --- /dev/null +++ b/dsl/dsl.icl @@ -0,0 +1,164 @@ +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) diff --git a/stampedShare/test.icl b/stampedShare/test.icl new file mode 100644 index 0000000..1b2445c --- /dev/null +++ b/stampedShare/test.icl @@ -0,0 +1,73 @@ +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) diff --git a/tabbar/test.icl b/tabbar/test.icl new file mode 100644 index 0000000..0837b06 --- /dev/null +++ b/tabbar/test.icl @@ -0,0 +1,21 @@ +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 ()))] diff --git a/test.icl b/test.icl index 600f4d6..88f470b 100644 --- a/test.icl +++ b/test.icl @@ -1,57 +1,48 @@ 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 (), []) + } diff --git a/test.txt b/test.txt new file mode 100644 index 0000000..1fc5add --- /dev/null +++ b/test.txt @@ -0,0 +1,4 @@ +*** test HTTP server *** + +Running at http://localhost:8080/ +[5, TOUIChange ReplaceUI UIHtmlView Bin 4 height "flex" Bin 1 class [] Tip Tip Bin 2 value "€" Tip Bin 1 width "flex" Tip Tip []] -- 2.20.1