Commit d9eb1cef authored by Bas Lijnse's avatar Bas Lijnse

Updated tests and examples

parent e803865d
Pipeline #26187 passed with stage
in 5 minutes and 9 seconds
module BasicImages
import iTasks.Engine
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions, StdList
......@@ -15,7 +15,7 @@ none = toSVGColor "none"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Basic Images"
= doTasks (Title "Basic Images" @>> viewInformation
[ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const basic_images
......
......@@ -2,7 +2,7 @@ module Box
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions
......@@ -11,7 +11,7 @@ none = toSVGColor "none"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Box"
= doTasks (Title "Box" @>> viewInformation
[ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const box2
......
......@@ -2,13 +2,13 @@ module Character
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions
Start :: *World -> *World
Start world
= startEngine [publish "/" (const (viewInformation "A char" [ViewUsing id (fromSVGEditor
= startEngine [publish "/" (const (Title "A char" @>> viewInformation [ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const char
, updModel = \_ v = v
......
......@@ -4,7 +4,7 @@ import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.WF.Combinators.Common
import iTasks.WF.Combinators.SDS
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions
from iTasks import instance Identifiable SDSLens, instance Modifiable SDSLens, instance Registrable SDSLens, instance Readable SDSLens, instance Writeable SDSLens
......@@ -13,13 +13,13 @@ Start :: *World -> *World
Start world
= startEngine [publish "/" (const
(withShared 'F' (\share ->
viewSharedInformation "A char" [ViewUsing id (fromSVGEditor
Title "A char" @>> viewSharedInformation [ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const char
, updModel = \_ v = v
})] share
-||-
updateSharedInformation "This char" [] share
(Title "This char" @>> updateSharedInformation [] share)
)))] world
char :: Char *TagSource -> Image Char
......
......@@ -2,7 +2,7 @@ module Clean
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import Graphics.Scalable.Extensions
import iTasks.Extensions.SVG.SVGEditor
import StdArray, StdEnum, StdFunctions, StdList
......@@ -16,7 +16,7 @@ white = toSVGColor "white"
Start :: *World -> *World
Start world
= doTasks (viewInformation "100% Clean!"
= doTasks (Title "100% Clean!" @>> viewInformation
[ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const clean
......
......@@ -2,7 +2,7 @@ module Grids
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions, StdList
import Text
......@@ -12,7 +12,7 @@ lucida = normalFontDef "Lucida Console"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Grids"
= doTasks (Title "Grids" @>> viewInformation
[ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const grids
......
......@@ -2,7 +2,7 @@ module Linears
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions, StdList
import Text
......@@ -15,7 +15,7 @@ blue = toSVGColor "blue"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Linears" [ViewUsing id (fromSVGEditor
= doTasks (Title "Linears" @>> viewInformation [ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const linears
, updModel = \_ v = v
......
......@@ -2,7 +2,7 @@ module OnClick
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdArray, StdClass, StdFunctions, StdInt, StdList, StdReal
import Text
......@@ -15,7 +15,7 @@ white = toSVGColor "white"
Start :: *World -> *World
Start world
= doTasks (updateInformation "On Click"
= doTasks (Title "On Click" @>> updateInformation
[UpdateUsing id (\_ v = v) (fromSVGEditor
{ initView = id
, renderImage = const count
......
......@@ -2,7 +2,7 @@ module Overlays
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunc, StdList
import Text
......@@ -12,7 +12,7 @@ lucida = normalFontDef "Lucida Console"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Overlays" [ViewUsing id (fromSVGEditor
= doTasks (Title "Overlays" @>> viewInformation [ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const overlays
, updModel = \_ v = v
......
......@@ -2,7 +2,7 @@ module Polyline
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunctions
......@@ -11,7 +11,7 @@ white = toSVGColor "white"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Polyline" [ViewUsing id (fromSVGEditor
= doTasks (Title "Polyline" @>> viewInformation [ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const polyline_in_host
, updModel = \_ v = v
......
......@@ -2,7 +2,7 @@ module Rosetree
import iTasks.Engine
import iTasks.WF.Tasks.Interaction
import iTasks.UI.Prompt
import iTasks.UI.Definition, iTasks.UI.Tune
import iTasks.Extensions.SVG.SVGEditor
import StdFunc, StdList, StdTuple
......@@ -14,7 +14,7 @@ white = toSVGColor "white"
Start :: *World -> *World
Start world
= doTasks (viewInformation "Rose tree" [ViewUsing id (fromSVGEditor
= doTasks (Hint "Rose tree" @>> viewInformation [ViewUsing id (fromSVGEditor
{ initView = id
, renderImage = const roses
, updModel = \_ v = v
......
......@@ -84,7 +84,7 @@ filterTestsByName pattern tests = filter (\{UnitTest|name} -> indexOf pattern na
testEditor :: (Editor a) (EditMode a) -> Task a | iTask a
testEditor editor mode
= (interactR unitShare {onInit = const ((),mode), onEdit = \v l _ -> (l,v,Nothing), onRefresh = \_ l (Just v) -> (l,v,Nothing)} editor @ snd
>&> viewSharedInformation [ViewWithTitle "Editor value", ViewAs (toString o toJSON)] @? tvFromMaybe
>&> \s -> Title "Editor value" @>> viewSharedInformation [ViewAs (toString o toJSON)] s @? tvFromMaybe
) <<@ ArrangeHorizontal
testEditorWithShare :: (Editor a) a Bool -> Task a | iTask a
......
module TestCallProcess
import iTasks
test = viewInformation "Press the button to run an OS process" [] ()
test = Hint "Press the button to run an OS process" @>> viewInformation [] ()
>>| withShared []
\io -> (externalProcess () "/bin/date" [] Nothing io {onStartup=onStartup
\io -> (externalProcess "/bin/date" [] Nothing io {onStartup=onStartup
,onOutData=onOutData
,onErrData=onErrData
,onShareChange=onShareChange
,onExit=onExit} Nothing gEditor{|*|}
-|| viewSharedInformation "OUTPUT: " [] io
-|| (Hint "OUTPUT: " @>> viewSharedInformation [] io)
)
where
onStartup r = (Ok r, Nothing, [], False)
......
......@@ -8,7 +8,7 @@ import Text.HTML
test = (testHtmlFrame -&&- testResizable) <<@ AddCSSClass "itasks-horizontal"
testHtmlFrame :: Task HtmlTag
testHtmlFrame = viewInformation () [ViewUsing id (scaledEditor 300 200 (htmlView <<@ styleAttr "padding: 0"))] html
testHtmlFrame = viewInformation [ViewUsing id (scaledEditor 300 200 (htmlView <<@ styleAttr "padding: 0"))] html
<<@ ApplyLayout (sequenceLayouts [layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))
,setUIAttributes (sizeAttr FlexSize FlexSize)
]
......@@ -19,7 +19,7 @@ where
]
testResizable :: Task String
testResizable = viewInformation () [] "RESIZE THIS PANEL"
testResizable = viewInformation [] "RESIZE THIS PANEL"
<<@ ApplyLayout (sequenceLayouts[setUIType UIPanel,setUIAttributes (resizableAttr [LeftSide])])
Start world = doTasks test world
......@@ -2,8 +2,8 @@ module TestLeafletResize
import iTasks
import iTasks.Extensions.GIS.Leaflet
test = (viewInformation "Map resizing" [] {LeafletMap|perspective=defaultValue,objects=objects,tilesUrls=[],icons=[]} <<@ FlexInner <<@ AddCSSClass "itasks-flex-height")
-|| (updateInformation "List to force resizing" [] [1,2,3,4] <<@ AddCSSClass "itasks-wrap-height")
test = ((Hint "Map resizing" @>> viewInformation [] {LeafletMap|perspective=defaultValue,objects=objects,tilesUrls=[],icons=[]}) <<@ FlexInner <<@ AddCSSClass "itasks-flex-height")
-|| ((Hint "List to force resizing" @>> updateInformation [] [1,2,3,4]) <<@ AddCSSClass "itasks-wrap-height")
where
objects = [Polygon {polygonId = LeafletObjectID "poly", points = points,style=[], editable = True}]
......
......@@ -2,7 +2,7 @@ module TestCopyAttributes
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for copying an attribute" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for copying an attribute" @! () >>= return) <<@ ApplyLayout layout
where
layout = copySubUIAttributes SelectAll [0] [1]
......
......@@ -2,7 +2,7 @@ module TestDelAttributes
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for deleting an attribute" @! () >> return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for deleting an attribute" @! () >> return) <<@ ApplyLayout layout
where
layout = delUIAttributes (SelectKeys ["direction"])
......
module TestForeverLoop
test = forever (
viewInformation () [] "From one screen..."
>>| viewInformation () [] "To the next..."
viewInformation [] "From one screen..."
>>| viewInformation [] "To the next..."
>>| return ()
)
......
......@@ -2,7 +2,7 @@ module TestInsertSub
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for inserting a sub ui" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for inserting a sub ui" @! () >>= return) <<@ ApplyLayout layout
where
layout = insertChildUI 1 (ui UIDebug)
......
......@@ -2,7 +2,7 @@ module TestLayoutSubs
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for layouting a sub ui" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for layouting a sub ui" @! () >>= return) <<@ ApplyLayout layout
where
layout = layoutSubUIs (SelectByPath [0]) (setUIType UIDebug)
......
......@@ -2,7 +2,7 @@ module TestModifyAttributes
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for modifying attributes" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for modifying attributes" @! () >>= return) <<@ ApplyLayout layout
where
layout = modifyUIAttributes (SelectKeys ["direction"]) f
f attr = maybe 'DM'.newMap (\(JSONString dir) -> optionalAttr (dir == "horizontal")) ('DM'.get "direction" attr)
......
module TestModifyAttributesTwice
import iTasks
import qualified Data.Map as DM
test :: Task ()
test = (updateInformation [] "Test for modifying attributes" @! () >>= return) <<@ ApplyLayout layout1 <<@ ApplyLayout layout2
where
layout1 = modifyUIAttributes (SelectKeys ["class"]) (addClass "A")
layout2 = modifyUIAttributes (SelectKeys ["class"]) (addClass "B")
addClass name attr = 'DM'.put "class" (maybe
(JSONArray [JSONString name])
(\(JSONArray names) -> JSONArray (names ++ [JSONString name]))
('DM'.get "class" attr)) attr
Start world = doTasks test world
module TestNestedSteps
import iTasks
test = viewInformation () [] "Step 1"
>>| viewInformation () [] "Step 2"
>>| viewInformation () [] "Step 3"
>>| viewInformation () [] "Step 4"
test = viewInformation [] "Step 1"
>>| viewInformation [] "Step 2"
>>| viewInformation [] "Step 3"
>>| viewInformation [] "Step 4"
Start world = doTasks test world
......@@ -2,7 +2,7 @@ module TestRemoveSubs
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for removing a sub ui" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for removing a sub ui" @! () >>= return) <<@ ApplyLayout layout
where
layout = removeSubUIs (SelectByPath [1])
......
......@@ -2,7 +2,7 @@ module TestSetAttributes
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for setting an attribute" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for setting an attribute" @! () >>= return) <<@ ApplyLayout layout
where
layout = setUIAttributes (styleAttr "background: #f0f")
......
......@@ -2,7 +2,7 @@ module TestSetType
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for setting a UI type" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for setting a UI type" @! () >>= return) <<@ ApplyLayout layout
where
layout = setUIType UIDebug
......
......@@ -2,7 +2,7 @@ module TestUnwrap
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for unwrapping a ui" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for unwrapping a ui" @! () >>= return) <<@ ApplyLayout layout
where
layout = unwrapUI
......
......@@ -2,10 +2,10 @@ module TestWindow
import iTasks
test = viewInformation "Press the button to open a window" [] ()
test = Hint "Press the button to open a window" @>> viewInformation [] ()
>>| taskInWindow
>>| viewInformation "Done" [] ()
>>| Title "Done" @>> viewInformation [] ()
where
taskInWindow = (viewInformation (Title "Test window") [] "Hello!" >>* [OnAction ActionClose (always (return ()))]) <<@ InWindow
taskInWindow = (Title "Test window" @>> viewInformation [] "Hello!" >>* [OnAction ActionClose (always (return ()))]) <<@ InWindow
Start world = doTasks test world
......@@ -2,7 +2,7 @@ module TestWrap
import iTasks
test :: Task ()
test = (updateInformation () [] "Test for wrapping a ui" @! () >>= return) <<@ ApplyLayout layout
test = (updateInformation [] "Test for wrapping a ui" @! () >>= return) <<@ ApplyLayout layout
where
layout = wrapUI UIDebug
......
......@@ -14,8 +14,8 @@ myShare :: Shared Int
myShare = sharedStore "myShare" 0
t0 :: Task Int
t0 = updateSharedInformation "t0" [] myShare
t0 = Title "t0" @>> updateSharedInformation [] myShare
t1 :: Task Int
t1 = updateSharedInformation "t1" [] myShare
t1 = Title "t1" @>> updateSharedInformation [] myShare
......@@ -6,6 +6,6 @@ test
= (testItem "A" -&&- testItem "B") <<@ ArrangeHorizontal <<@ CSSStyle "justify-content: center"
@! ()
testItem label = viewInformation () [] label <<@ ApplyLayout (setUIAttributes (sizeAttr (ExactSize 100) (ExactSize 300))) <<@ InPanel False
testItem label = viewInformation [] label <<@ ApplyLayout (setUIAttributes (sizeAttr (ExactSize 100) (ExactSize 300))) <<@ InPanel False
Start world = doTasks test world
......@@ -2,6 +2,6 @@ module TestFrameCompact
import iTasks
test :: Task Int
test = viewInformation () [] 23 <<@ ApplyLayout frameCompact
test = viewInformation [] 23 <<@ ApplyLayout frameCompact
Start world = doTasks test world
......@@ -16,10 +16,10 @@ editInTextArea model
]
editAsListOfLines model
= updateSharedInformation ("Lines","Edit lines") [listEditor] model
= Title "Lines" @>> Hint "Edit lines" @>> updateSharedInformation [listEditor] model
noteEditor = UpdateUsing id (const id) textArea
listEditor = UpdateAs (split "\n") (\_ l -> join "\n" l)
noteEditor = UpdateSharedUsing id (const id) const textArea
listEditor = UpdateSharedAs (split "\n") (\_ l -> join "\n" l) const
toMaybe (Value v _) = (Just v)
toMaybe _ = Nothing
......
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