Commit 77f7670a authored by Jurriën Stutterheim's avatar Jurriën Stutterheim

Introduce TMonad, TApplicative and TFunctor with iTask constrains


git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@4025 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 3ffc1a7f
......@@ -3,8 +3,9 @@ implementation module iTasks.API.Common.DBTasks
import StdList, StdOrdList, Data.List
import iTasks.Framework.Generic, iTasks.Framework.Task, iTasks.Framework.SDS
import iTasks.Framework.Util
from iTasks.API.Core.Tasks import get, set, return
from iTasks.API.Common.TaskCombinators import >>|, >>=
import iTasks.API.Core.Types
from iTasks.API.Core.Tasks import get, set
from iTasks.API.Common.TaskCombinators import >>|
// Convenient operations on databases
eqItemId :: a a -> Bool | DB a
......
......@@ -32,7 +32,7 @@ from Data.Either import :: Either
*
* @gin False
*/
(>>=) infixl 1 :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b
tbind :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b
/**
* Combines two tasks sequentially but explicitly waits for user input to confirm the completion of
* the first task.
......@@ -380,3 +380,4 @@ ifUnstable :: (a -> b) (TaskValue a) -> Maybe b
ifValue :: (a -> Bool) (a -> b) (TaskValue a) -> Maybe b
ifCond :: Bool b (TaskValue a) -> Maybe b
withValue :: (a -> Maybe b) (TaskValue a) -> Maybe b
......@@ -17,8 +17,8 @@ import iTasks.API.Common.SDSCombinators
(>>*) infixl 1 :: !(Task a) ![TaskCont a (Task b)] -> Task b | iTask a & iTask b
(>>*) task steps = step task (const Nothing) steps
(>>=) infixl 1 :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b
(>>=) taska taskbf = step taska (const Nothing) [OnAction ActionContinue (hasValue taskbf), OnValue (ifStable taskbf)]
tbind :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b
tbind taska taskbf = step taska (const Nothing) [OnAction ActionContinue (hasValue taskbf), OnValue (ifStable taskbf)]
(>>!) infixl 1 :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b
(>>!) taska taskbf = step taska (const Nothing) [OnAction ActionContinue (hasValue taskbf)]
......@@ -305,6 +305,7 @@ appendTopLevelTask attr evalDirect task = appendTask (Detached attr evalDirect)
appendTopLevelTaskFor :: !worker !Bool !(Task a) -> Task TaskId | iTask a & toUserConstraint worker
appendTopLevelTaskFor worker evalDirect task = appendTopLevelTask (workerAttributes worker []) evalDirect task
valToMaybe :: (TaskValue a) -> Maybe a
valToMaybe (Value v _) = Just v
valToMaybe NoValue = Nothing
......@@ -335,3 +336,7 @@ ifStable _ _ = Nothing
ifUnstable :: (a -> b) (TaskValue a) -> Maybe b
ifUnstable ataskb (Value a False) = Just (ataskb a)
ifUnstable _ _ = Nothing
withValue :: (a -> Maybe b) (TaskValue a) -> Maybe b
withValue a2mb (Value tv _) = a2mb tv
withValue _ _ = Nothing
......@@ -16,7 +16,7 @@ from StdFunc import id, const, o, seq
from iTasks import JSONEncode, JSONDecode, dynamicJSONEncode, dynamicJSONDecode
from iTasks.Framework.TaskStore import localShare, parallelTaskList, topLevelTaskList
from iTasks.Framework.SDS import write, read, readRegister
from iTasks.API.Core.Tasks import return
import iTasks.API.Core.Types
from iTasks.API.Common.SDSCombinators import sdsFocus, sdsSplit, sdsTranslate, toReadOnly, mapRead, mapReadWriteError, mapSingle
derive class iTask ParallelTaskType, WorkOnStatus
......
......@@ -21,7 +21,7 @@ from System.OSError import ::MaybeOSError, ::OSError, ::OSErrorCode, ::OSErro
* @gin-icon return
* @gin-shape return
*/
return :: !a -> Task a | iTask a
treturn :: !a -> Task a | iTask a
/**
* Exception throwing. This will throw an exception of arbitrary type e which has to be caught
......
......@@ -18,8 +18,8 @@ from TCPChannels import instance toString IPAddress
from TCPChannels import class closeRChannel(..), instance closeRChannel TCP_RChannel_, openTCP_Listener
from TCPChannelClass import :: DuplexChannel(..), closeChannel
return :: !a -> (Task a) | iTask a
return a = mkInstantTask (\taskId iworld-> (Ok a, iworld))
treturn :: !a -> (Task a) | iTask a
treturn a = mkInstantTask (\taskId iworld-> (Ok a, iworld))
throw :: !e -> Task a | iTask a & iTask, toString e
throw e = mkInstantTask (\taskId iworld -> (Error (dynamic e,toString e), iworld))
......
......@@ -40,6 +40,35 @@ from iTasks.Framework.SDS import :: ReadWriteShared, :: ReadOnlyShared, :: RWSha
from iTasks.API.Core.Client.Interface import :: JSWorld, :: JSVal
from iTasks.API.Core.LayoutCombinators import :: LayoutRules
import iTasks.Framework.Serialization
class TFunctor f where
tmap :: (a -> b) (f a) -> f b | iTask a & iTask b
(@$) infixl 1 :: (a -> b) (f a) -> f b | iTask a & iTask b & TFunctor f
class TApplicative f | TFunctor f where
(<#>) :: (f (a -> b)) (f a) -> f b | iTask a & iTask b
return :: a -> f a | iTask a
class TMonad m | TApplicative m where
(>>=) infixl 1 :: (m a) (a -> m b) -> m b | iTask a & iTask b
instance TFunctor Task
instance TApplicative Task
instance TMonad Task
instance TFunctor Maybe
instance TApplicative Maybe
instance TMonad Maybe
instance TFunctor []
instance TApplicative []
instance TMonad []
instance TFunctor (Either e)
instance TApplicative (Either e)
instance TMonad (Either e)
//****************************************************************************//
// Common data types that have specialized user interfaces
//****************************************************************************//
......
implementation module iTasks.API.Core.Types
from StdFunc import until
import StdInt, StdBool, StdClass, StdArray, StdEnum, StdTuple, StdMisc, StdList, StdFunc, StdOrdList
from StdFunc import until, const, id
import StdInt, StdBool, StdClass, StdArray, StdEnum, StdTuple, StdMisc, StdList, StdOrdList
import GenLexOrd
import Data.Either, Data.Functor, Text.JSON, Text.HTML, Text, Text.Encodings.Base64, Data.Tuple, dynamic_string, System.File
from Data.Map import :: Map, :: Size
......@@ -19,7 +18,51 @@ import System.Time, System.File, System.FilePath
import iTasks.Framework.SDS
from iTasks.Framework.UIDefinition import :: UIDef(..), :: UIContent(..), :: UIForm, :: UIActions, :: UIDirection(..), :: UIBlock, :: UIViewport, :: UIAction, :: UIControl, stringDisplay
from iTasks.API.Core.LayoutCombinators import mergeAttributes, setMargins
from iTasks.API.Core.Tasks import treturn
from iTasks.API.Common.TaskCombinators import tbind, @
instance TFunctor Task where
tmap f x = x @ f
instance TApplicative Task where
(<#>) tf ta = tf >>= \f -> tmap f ta
return x = treturn x
instance TMonad Task where
(>>=) l r = tbind l r
instance TFunctor Maybe where
tmap f (Just x) = Just (f x)
tmap _ _ = Nothing
instance TApplicative Maybe where
(<#>) (Just f) (Just x) = Just (f x)
(<#>) _ _ = Nothing
return x = Just x
instance TMonad Maybe where
(>>=) (Just x) f = f x
(>>=) _ _ = Nothing
instance TFunctor [] where
tmap f xs = map f xs
instance TApplicative [] where
(<#>) fs xs = [f x \\ f <- fs, x <- xs]
return x = [x]
instance TMonad [] where
(>>=) xs f = [y \\ x <- xs, y <- f x]
instance TFunctor (Either e) where
tmap f (Right x) = Right (f x)
tmap _ (Left x) = Left x
instance TApplicative (Either e) where
(<#>) (Right f) (Right x) = Right (f x)
(<#>) (Left e) _ = Left e
(<#>) _ (Left e) = Left e
return x = Right x
instance TMonad (Either e) where
(>>=) (Left x) _ = Left x
(>>=) (Right x) f = f x
(@$) infixl 1 :: (a -> b) (f a) -> f b | iTask a & iTask b & TFunctor f
(@$) f x = tmap f x
JSONEncode{|RWShared|} _ _ _ _ s = []
JSONDecode{|RWShared|} _ _ _ _ s = (Nothing, s)
......
implementation module iTasks.Framework.Client.LinkerSupport
import StdString, StdList, StdFunc, StdMisc, StdFile, StdTuple, StdDebug
from StdFunc import id
import StdString, StdList, StdMisc, StdFile, StdTuple, StdDebug
import Data.Maybe, System.File
import graph_to_sapl_string
......
implementation module iTasks.Framework.Engine
import StdMisc, StdArray, StdList, StdOrdList, StdTuple, StdChar, StdFile, StdBool, StdEnum
from StdFunc import o, seqList, ::St
from StdFunc import o, seqList, ::St, const
import Data.Map, Data.Error, Data.Func, Data.Tuple, Math.Random, Internet.HTTP, Text, Text.Encodings.MIME, Text.Encodings.UrlEncoding
import System.Time, System.CommandLine, System.Environment, System.OSError, System.File, System.FilePath, System.Directory
import iTasks.Framework.Util, iTasks.Framework.HtmlUtil
......@@ -28,7 +28,7 @@ JS_COMPILER_EXCLUDES :==
,"System.Directory"
]
import StdFile, StdInt, StdList, StdChar, StdBool, StdString, StdFunc
import StdInt, StdChar, StdString
import tcp
import Internet.HTTP, System.Time, System.CommandLine, Data.Func
......
implementation module iTasks.Framework.Generic.Interaction
import StdList, StdBool, StdTuple, StdFunc, StdMisc
from StdFunc import const
import StdList, StdBool, StdTuple, StdMisc
import Data.Maybe, Data.Either, Data.Error, Data.Map, Data.Generic, Data.Functor, Data.Tuple
import Text, Text.JSON
import iTasks.Framework.IWorld
......
implementation module iTasks.Framework.SDS
import StdString, StdFunc, StdTuple, StdMisc, StdList, StdBool
from StdFunc import const
import StdString, StdTuple, StdMisc, StdList, StdBool
import Data.Error, Data.Func, Data.Tuple, Data.Map, System.Time, Text, Text.JSON
import qualified Data.Set as Set
import iTasks.Framework.IWorld
......
implementation module iTasks.Framework.Task
import StdClass, StdArray, StdTuple, StdInt, StdList, StdFunc, StdBool, StdMisc
from StdFunc import const, id
import StdClass, StdArray, StdTuple, StdInt, StdList, StdBool, StdMisc
import Text.HTML, Internet.HTTP, Data.Map, Data.Error, Text.JSON
import iTasks.Framework.IWorld, iTasks.Framework.UIDefinition, iTasks.Framework.Util
import iTasks.API.Core.Types
......
implementation module iTasks.Framework.TaskStore
import StdEnv
import StdOverloaded, StdBool, StdArray, StdTuple
from StdFunc import const, id, o
import Data.Maybe, Text, System.Time, Math.Random, Text.JSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath, Data.Functor
import iTasks.Framework.IWorld, iTasks.Framework.TaskState, iTasks.Framework.Task, iTasks.Framework.Store
......
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