master
= get applicationOptions
>>- \eo->traceValue ("Master started on port " +++ toString eo.serverPort)
+ >-| updateSharedInformation [] (remoteShare (sharedStore "bork" 42) {domain="localhost",port=9099})
// >-| set 42 (remoteShare (sharedStore "bork" 42) {domain="localhost",port=9099})
// >-| asyncTask (ExistingNode "localhost" 9099) (blockWait 5)
// >-| asyncTask "localhost" 9090 (blockWait 5)
// >-| asyncTask (PrivateNode 9099) (traceValue 5 >-| traceValue 42)
- >-| asyncTask "localhost" 9099 (updateInformation [] 5)
+// >-| asyncTask "localhost" 9099 (updateInformation [] 5)
// >-| sleepSortPar [5,1,3,8]
>&^ viewSharedInformation []
@! ()
-
-asyncTaskChannel :: !String !Int !((sds () (Queue r) w) -> Task a) !((sds () (Queue w) r) -> Task b) -> Task (a, b)
-asyncTaskChannel host port remote local
- = asyncTask host port (remote shareTo)
- -&&-
-where
- shareTo :: (sds () (Queue r) (Queue r))
- shareTo = sdsFocus ("to-" +++ host +++ toString port) $ memoryStore "asyncITasks-channels" (Just newQueue)
-
- shareFro :: (sds () (Queue w) (Queue w))
- shareFro = sdsFocus ("fro-" +++ host +++ toString port) $ memoryStore "asyncITasks-channels" (Just newQueue)
+//
+//asyncTaskChannel :: !String !Int !((sds () (Queue r) w) -> Task a) !((sds () (Queue w) r) -> Task b) -> Task (a, b)
+//asyncTaskChannel host port remote local
+// = asyncTask host port (remote shareTo)
+// -&&-
+//where
+// shareTo :: (sds () (Queue r) (Queue r))
+// shareTo = sdsFocus ("to-" +++ host +++ toString port) $ memoryStore "asyncITasks-channels" (Just newQueue)
+//
+// shareFro :: (sds () (Queue w) (Queue w))
+// shareFro = sdsFocus ("fro-" +++ host +++ toString port) $ memoryStore "asyncITasks-channels" (Just newQueue)
blockWait :: Int -> Task Int
blockWait i = accWorld (sleep i)
sleepSortPar :: [Int] -> Task [Int]
sleepSortPar numbers = parallel
[ (Embedded, \stl->
- asyncTaskSpawn port (blockWait num)
- >-| appendTask Embedded (\_->return num) stl
+/* asyncTaskSpawn port (blockWait num)
+ >-| */appendTask Embedded (\_->return num) stl
@? const NoValue)
\\ num <- numbers
& port <- [9092..9099]
--- /dev/null
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}
+module Main where
+
+import Prelude hiding (print)
+import Data.Functor.Identity
+class Empty x
+
+instance Empty x
+
+main = putStrLn $ show (unP e1 [])
+
+e1 :: Printer Int
+e1 = lit 42
+
+infixl 6 +., -.
+infixl 7 *.
+infix 4 ==.
+class Expr v c where
+ lit :: (c a) => a -> v a
+ (+.) :: (c a, Num a) => v a -> v a -> v a
+ (-.) :: (c a, Num a) => v a -> v a -> v a
+ (*.) :: (c a, Num a) => v a -> v a -> v a
+ (==.) :: (c a, Eq a) => v a -> v a -> v Bool
+-- if' :: (c a) => v Bool -> v a -> v a -> v a
+
+data Printer a = P ([String] -> [String])
+unP (P a) = a
+instance Expr Printer Show where
+ lit a = P (show a:)
+ l +. r = P $ unP l . ("+":) . unP r
+ l -. r = P $ unP l . ("-":) . unP r
+ l *. r = P $ unP l . ("*":) . unP r
+ l ==. r = P $ unP l . ("==":) . unP r
+-- if' i t e = P $ ("if ":) . unP i . (" then ":) . unP t . (" else ":) . unP e
+
+data Eval a = E a
+unE (E a) = a
+instance Expr Eval Empty where
+ lit a = E a
+ l +. r = E $ unE l + unE r
+ l -. r = E $ unE l - unE r
+ l *. r = E $ unE l * unE r
+ l ==. r = E $ unE l == unE r
+-- if' i t e = if unE i then t else e
--- /dev/null
+module test
+
+import StdEnv
+
+class expr v c
+where
+ lit :: a -> v (c a)
+
+//class plus v c
+//where
+// (+.) infixl 6 :: (v c a) (v c a) -> v c a | + a
+
+:: BM x y = { to :: x -> y, fro :: y -> x }
+bm :: BM a a
+bm = {to=id, fro=id}
+
+:: ToString a = E.e: ToString (BM a e) & toString e
+
+:: Printer a = P a ([String] -> [String])
+:: PrintConstraints a = E.e: PC (BM a e) & toString e
+
+print :: (Printer (PrintConstraints a)) -> [String]
+print (P _ a) = a []
+
+instance expr Printer PrintConstraints
+where
+ lit a = P (PC bm) \c->[toString (bm.to a):c]
+//instance plus Printer PrintConstraints
+//where
+// (+.) (P l) (P r) = P \c->["(":l ["+":r [")":c]]]
+
+//:: Eval c a = E a | EBlurp (c a)
+//:: EvalConstraints a = EC a
+//eval :: (Eval EvalConstraints a) -> a
+//eval (E a) = a
+//
+//instance expr Eval EvalConstraints
+//where
+// lit a = E a
+//instance plus Eval PrintConstraints
+//where
+// (+.) (E l) (E r) = E (l + r)
+
+Start = print t
+where
+ t = lit 42
+++ /dev/null
-module deep
-
-import StdEnv
-
-:: DSL
- = Lit Int
- | Plus DSL DSL
- | Div DSL DSL
-
-eval :: DSL -> Int
-eval (Lit i) = i
-eval (Plus x y) = eval x + eval y
-eval (Div x y) = eval x / eval y
-
-//Start = eval (Plus (Lit 41) (Lit 1))
-
-import Control.Applicative
-import Control.Monad
-import Data.Functor
-import Data.Maybe
-
-evalM :: DSL -> Maybe Int
-evalM (Lit i) = pure i
-evalM (Plus x y) = (+) <$> evalM x <*> evalM y
-evalM (Div x y) = evalM x >>= \x->evalM y >>= \y->case y of
- 0 = Nothing
- x = Just (x / y)
-
-Start = evalM (Plus (Lit 41) (Lit 1))
+++ /dev/null
-module eadt
-
-import StdEnv
-import Control.Monad
-import Control.Applicative
-import Data.Functor
-import Data.Maybe
-
-:: BM a b = { to :: a -> b, fro :: b -> a}
-bm :: BM a a
-bm = {to=id, fro=id}
-
-class eval m where eval :: (m a) -> Maybe a
-class print m where print :: (m a) [String] -> [String]
-class flat m where flat :: (m a) -> DSL a
-:: DSL a
- = E.e: Lit (BM e a) a & toString e
- | E.e: Plus (BM e a) (DSL e) (DSL e) & + e
- | E.m: Ext (m a) & eval, print, flat m
-lit = Lit bm
-(+.) infixl 6
-(+.) = Plus bm
-
-instance eval DSL where
- eval (Lit _ a) = Just a
- eval (Plus bm x y) = bm.to <$> ((+) <$> eval x <*> eval y)
- eval (Ext m) = eval m
-
-instance print DSL where
- print (Lit bm a) c = [toString (bm.fro a):c]
- print (Plus _ x y) c = print x ["+":print y c]
- print (Ext m) c = print m c
-
-instance flat DSL where
- flat (Ext m) = Ext (flat m)
- flat a = a
-
-:: Div a = E.e: Div (BM e a) (DSL e) (DSL e) & /, zero, == e
-(/.) infixl 7
-(/.) x y = Ext (Div bm x y)
-
-instance eval Div where
- eval (Div bm x y) = bm.to <$> (eval x >>= \x->eval y >>= \y->
- if (y == zero) Nothing (Just (x/y)))
-
-instance print Div where
- print (Div bm x y) c = print x ["/":print y c]
-
-instance flat Div where
- flat a = Ext a
-
-:: In a b = In infix 0 a b
-:: Var a = E.b: Var ((DSL b) -> In (DSL b) (DSL a))
-var = Ext o Var
-instance eval Var where
- eval (Var def) =
- let (init In body) = def init
- in eval body
-
-instance print Var where
- print (Var def) c =
- let (init In body) = def init
- in ["let _ = ":print init [" in ":print body c]]
-
-instance flat Var where
- flat (Var def) =
- let (init In body) = def init
- in body
-
-Start = printEval (var \x=lit 41 In x +. lit 1)
-
-printEval :: (DSL a) -> (Maybe a, [String])
-printEval e = (eval e, print e [])
--- /dev/null
+module DSLUnique
+
+import StdEnv
+import UniqueState
+
+class list v
+where
+ list :: [Int] -> *v *[Int]
+ (++.) infixr 5 :: *(v *[Int]) *(v *[Int]) -> *(v *[Int])
+
+class select v
+where
+ (!.) infixl 9 :: *(v *[Int]) *(v Int) -> *(v Int)
+
+class expr v
+where
+ lit :: a -> *(v a) | toStringU a
+ (+.) infixl 6 :: *(v Int) *(v Int) -> *(v Int)
+ (-.) infixl 6 :: *(v Int) *(v Int) -> *(v Int)
+ (*.) infixl 7 :: *(v Int) *(v Int) -> *(v Int)
+ (/.) infixl 7 :: *(v Int) *(v Int) -> *(v Int)
+ If :: *(v Bool) *(v a) *(v a) -> *(v a)
+
+class step v
+where
+ (>>*.) infixl 1 :: *(v .t) *[Step *v .t .u] -> *(v .u)
+
+:: *Step v t u
+ = IfValue ((v t) -> *(v Bool, v t)) ((v t) -> v u)
+ | Always (v u)
+
+class toStringU a
+where
+ toStringU :: .a -> String
+
+instance toStringU Bool
+where
+ toStringU :: !.Bool -> String
+ toStringU a
+ = code inline {
+ .d 0 1 i
+ jsr BtoAC
+ .o 1 0
+ }
+instance toStringU Int
+where
+ toStringU :: !.Int -> String
+ toStringU a
+ = code inline {
+ .d 0 1 i
+ jsr ItoAC
+ .o 1 0
+ }
+
+instance toStringU String
+where
+ toStringU :: !.String -> String
+ toStringU a
+ = code inline {
+ no_op
+ }
+
+show :: u:a -> *(State String u:b) | toStringU a
+show x = State \s -> (undef, s +++ toStringU x)
+
+instance list (State String)
+where
+ list x = show " list " >>| pure undef
+ (++.) l r = l >>| show " ++ " >>| r >>| pure undef
+
+instance select (State String)
+where
+ // >>| expects both sides to have the same attribute, this is not the case
+ // here
+ (!.) a i = a >>| show " ! " >>| i >>| pure undef
+
+instance expr (State String)
+where
+ lit x = show x
+ (+.) l r = l >>| show " + " >>| r >>| pure undef
+ (-.) l r = l >>| show " - " >>| r >>| pure undef
+ (*.) l r = l >>| show " * " >>| r >>| pure undef
+ (/.) l r = l >>| show " / " >>| r >>| pure undef
+ If b t e = show "If " >>| b >>| t >>| e >>| pure undef
+
+instance step (State String)
+where
+ (>>*.) l cs = l >>| show " >>*. [" >>|
+ printSteps cs
+ where
+ printSteps [] = show "]"
+ printSteps [IfValue p c:cs]
+ # (pb, pr) = p (show "i")
+ = show "IfValue (\\i->(" >>| pb >>| show ", " >>| pr >>| show ")) (\\v->" >>| c (show "v") >>| show ")" >>| commaCont cs
+ printSteps [Always c:cs] = show "Always " >>| c >>| commaCont cs
+
+ commaCont [] = printSteps []
+ commaCont cs = show ", " >>| printSteps cs
+
+instance list Maybe
+where
+ list x = undef//Just x
+ (++.) l r = l >>= \l -> r >>= \r -> pure (l ++ r)
+
+instance select Maybe
+where
+ (!.) a i = a >>= \a -> i >>= \i -> pure (a!!i)
+
+instance expr Maybe
+where
+ lit x = pure x
+ (+.) l r = l >>= \l -> r >>= \r -> pure (l + r)
+ (-.) l r = l >>= \l -> r >>= \r -> pure (l - r)
+ (*.) l r = l >>= \l -> r >>= \r -> pure (l * r)
+ (/.) _ (Just 0) = Nothing
+ (/.) l r = l >>= \l -> r >>= \r -> pure (l / r)
+ If b t e = b >>= \b
+ | b = t
+ | otherwise = e
+
+instance step Maybe
+where
+ (>>*.) _ [] = Nothing
+ (>>*.) _ [Always c:_] = c
+ (>>*.) Nothing [_:cs] = Nothing >>*. cs
+ (>>*.) v=:(Just _) [IfValue p c:cs]
+ = case p v of
+ (Nothing, v) = Nothing
+ (Just b, v) = if b (c v) (v >>*. cs)
+
+Start :: (Maybe Int, String, Maybe Int, String)
+Start = (lit 1 +. lit 2, snd (runState (lit 1 +. lit 2) ""), t, snd (runState t ""))
+
+t :: *(v Int) | expr, step v
+t = lit 38 /. lit 0 >>*.
+ [ IfValue (\v->(lit True, v)) (\i->i)
+ , Always (lit 42)
+ ]
--- /dev/null
+definition module UniqueState
+
+:: Maybe a = Just a | Nothing
+
+class Functor f
+where
+ fmap :: u:(v:a -> w:b) *(f v:a) -> *(f w:b)
+
+class Applicative f | Functor f
+where
+ (<*>) infixl 4 :: *(f v:(w:a -> x:b)) *(f w:a) -> *(f x:b)
+ pure :: u:a -> *(f u:a)
+
+class Monad m | Applicative m
+where
+ bind :: *(m v:b) w:(v:b -> *(m x:c)) -> *(m x:c)
+ (>>=) infixl 1 :: *(m v:b) w:(v:b -> *(m x:c)) -> *(m x:c)
+ (>>=) ma a2mb :== bind ma a2mb
+ (>>|) infixl 1 :: *(m v:b) w:(v:b -> *(m x:c)) -> *(m x:c)
+ (>>|) ma mb :== ma >>= \_ -> mb
+ return :: u:a -> *(m u:a) | Applicative m
+ return x :== pure x
+
+:: State s a = State .(s -> .(a, s))
+
+runState :: u:(State .s .a) .s -> v:(.a,.s), [u <= v]
+
+instance Functor (State String)
+instance Applicative (State String)
+instance Monad (State String)
+
+instance Functor Maybe
+instance Applicative Maybe
+instance Monad Maybe
--- /dev/null
+implementation module UniqueState
+
+import StdEnv
+
+runState :: u:(State .s .a) .s -> v:(.a,.s), [u <= v]
+runState (State f) s = f s
+
+instance Functor (State String)
+where
+ //fmap :: u:(v:a -> w:b) x:(State String v:a) -> x:(State String w:b), [x <= u,x <= v,x <= w]
+ fmap f a = State (\s
+ # (a`, s`) = runState a s
+ = (f a`, s`))
+
+instance Applicative (State String)
+where
+ //(<*>) infixl 4 :: u:(State String v:(w:a -> x:b)) y:(State String w:a) -> z:(State String x:b), [z <= u,u <= v,y <= w,z <= x,z <= y]
+ (<*>) f a = State (\s
+ # (f`, s`) = runState f s
+ # (a`, s``) = runState a s`
+ = (f` a`, s``))
+
+ //pure :: u:a -> v:(State String u:a), [v <= u]
+ pure x = State (\s -> (x, s))
+
+instance Monad (State String)
+where
+ //bind :: u:(State String v:a) w:(v:a -> x:(State String y:b)) -> x:(State String y:b), [x <= u,u <= v,x <= w,x <= y]
+ bind a f = State (\s
+ # (v, s`) = runState a s
+ # a` = f v
+ = runState a` s`)
+
+instance Functor Maybe
+where
+ fmap f (Just x) = Just (f x)
+ fmap _ _ = Nothing
+
+instance Applicative Maybe
+where
+ (<*>) (Just f) (Just x) = Just (f x)
+ (<*>) _ _ = Nothing
+
+ pure x = Just x
+
+instance Monad Maybe
+where
+ bind (Just x) f = f x
+ bind _ _ = Nothing
--- /dev/null
+module test
+
+import StdEnv, StdMaybe
+import Data.Functor
+
+:: Expr v
+ = Lit Int
+ | Add (Expr v) (Expr v)
+ | E.e: Ext (e v) & eval e v
+:: Fix f = Fix (f (Fix f))
+
+
+class eval t v where
+ eval :: (t v) -> Int
+instance eval Expr v
+where
+ eval (Lit i) = i
+
+
+Start = eval t
+
+t :: Expr (Fix Expr)
+t = Lit 42
--- /dev/null
+module gen
+
+import Control.Applicative
+import Control.Monad => qualified join
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans
+import Data.Either
+import Data.Func
+import Data.Functor
+import Data.Functor.Identity
+import Data.Generics
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Tuple
+import StdEnv, StdGeneric
+import Text
+
+:: Box b a =: Box b
+derive bimap Box
+unBox (Box b) :== b
+box b :== Box b
+reBox x :== box (unBox x)
+
+:: GType
+ = GTyBasic String
+ | GTyArrow GType GType
+ | GTyArray Bool GType
+ | GTyUnit
+ | GTyEither GType GType
+ | GTyPair GType GType
+ | GTyCons GenericConsDescriptor GType
+ | GTyField GenericFieldDescriptor GType
+ | GTyObject GenericTypeDefDescriptor GType
+ | GTyRecord GenericRecordDescriptor GType
+class print a :: a [String] -> [String]
+instance print Int where print s c = [toString s:c]
+instance print Char where print s c = [toString s:c]
+instance print String where print s c = [s:c]
+instance print GType
+where
+ print (GTyBasic s) c = [s:c]
+ print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
+ print (GTyArray s a) c = ["(", if s "!" "", "Array ":print a [")":c]]
+ print GTyUnit c = ["UNIT":c]
+ print (GTyEither l r) c = ["(EITHER":print l [" ":print r [")":c]]]
+ print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
+ print (GTyCons _ a) c = ["(CONS ":print a [")":c]]
+ print (GTyField _ a) c = ["(FIELD ":print a [")":c]]
+ print (GTyObject _ a) c = ["(OBJECT ":print a [")":c]]
+ print (GTyRecord _ a) c = ["(RECORD ":print a [")":c]]
+
+:: Type
+ = TyBasic String
+ | TyArrow Type Type
+ | TyArray Bool Type
+ | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
+ | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
+ | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
+instance print Type
+where
+ print (TyBasic s) c = [s:c]
+ print (TyArrow l r) c = print l [" -> ":print r c]
+ print (TyArray s a) c = ["{", if s "!" "":print a ["}":c]]
+ print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
+ [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
+ where nttype (GenTypeArrow l r) = l
+ print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
+ [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
+ print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
+ $ [" ":isperse " | " (map pCons conses) c]
+ where
+ pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
+ pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
+ where
+ n c = case i.gcd_prio of
+ GenConsNoPrio = [i.gcd_name:c]
+ GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
+ GenConsAssocRight = "r";
+ GenConsAssocLeft = "l"
+ _ = "", " ":print s c]
+
+pTyVars :: String Int [String] -> [String]
+pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
+
+pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
+pField pre [] _ = []
+pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
+
+instance print GenType
+where
+ print (GenTypeVar i) c = print (['a'..] !! i) c
+ print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
+ where
+ collectApps (GenTypeApp l r) c = collectApps l [print r:c]
+ collectApps a c = [print a:c]
+ print (GenTypeCons s) c = [s:c]
+ print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
+
+isperse :: a [[a] -> [a]] [a] -> [a]
+isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
+
+gTypeToType :: GType -> Maybe Type
+gTypeToType (GTyBasic a) = pure $ TyBasic a
+gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
+gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
+gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
+where
+ gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
+ gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
+ gtrec _ = Nothing
+gTypeToType (GTyObject i t)
+ | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
+ = TyObject i <$> gtobj t
+where
+ gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
+ gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
+ gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
+ gtobj _ = Nothing
+
+ gtcons :: GType -> Maybe [Type]
+ gtcons GTyUnit = pure []
+ gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
+ gtcons t = (\x->[x]) <$> gTypeToType t
+
+flattenGType :: GType -> [GType]
+flattenGType t = execWriter $ evalStateT (mkf t) []
+where
+ add :: (g GType -> GType) g GType -> StateT [String] (WriterT [GType] Identity) GType | genericDescriptorName g
+ add cons t a = gets (isMember $ genericDescriptorName t) >>= \b->if b
+ (pure $ GTyBasic $ genericDescriptorName t)
+ (cons t <$ modify (\x->[genericDescriptorName t:x]) <*> mkf a
+ >>= \ty->liftT (tell [ty]) >>| add cons t a)
+
+ mkf :: GType -> StateT [String] (WriterT [GType] Identity) GType
+ mkf (GTyObject t a) = add GTyObject t a
+ mkf (GTyRecord t a) = add GTyRecord t a
+ mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
+ mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
+ mkf (GTyCons i a) = GTyCons i <$> mkf a
+ mkf (GTyField i a) = GTyField i <$> mkf a
+ mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
+ mkf (GTyArray s a) = GTyArray s <$> mkf a
+ mkf t = pure t
+
+generic type a :: Box GType a
+type{|Int|} = box $ GTyBasic "Int"
+type{|Bool|} = box $ GTyBasic "Bool"
+type{|Real|} = box $ GTyBasic "Real"
+type{|Char|} = box $ GTyBasic "Char"
+type{|World|} = box $ GTyBasic "World"
+type{|Dynamic|} = box $ GTyBasic "Dynamic"
+type{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
+type{|{}|} a = box $ GTyArray False $ unBox a
+type{|{!}|} a = box $ GTyArray True $ unBox a
+
+type{|UNIT|} = box GTyUnit
+type{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
+type{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
+type{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
+type{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
+type{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
+type{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
+
+derive type [], Either, Maybe, T, R, Frac, Tr, (,)
+
+:: T a =: T2 a
+:: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic}
+
+:: Tr m b= Tr (m Int b)
+
+:: Frac a = (/.) infixl 7 a a
+
+Start :: [String]
+Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
+
+t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool)
+t = type{|*|}
--- /dev/null
+module test
+
+import StdEnv, StdGeneric, StdMaybe
+
+import Data.Either, Data.Func
+
+:: Box b a =: Box b
+derive bimap Box
+unBox (Box b) :== b
+box b :== Box b
+reBox x :== box (unBox x)
+
+:: GGFuns st a =
+ { int :: st -> Either String (Int, st)
+ , bool :: st -> Either String (Bool, st)
+ , real :: st -> Either String (Real, st)
+ , char :: st -> Either String (Char, st)
+
+ , unit :: st -> Either String (UNIT, st)
+// , cons :: (st -> Either String (a, st)) GenericConsDescriptor st -> Either String (CONS b, st)
+// , field :: (st -> Either String (a, st)) GenericFieldDescriptor st -> Either String (FIELD b, st)
+// , record :: (st -> Either String (a, st)) GenericRecordDescriptor st -> Either String (RECORD b, st)
+// , object :: (st -> Either String (a, st)) GenericTypeDefDescriptor st -> Either String (OBJECT b, st)
+// , pair :: (st -> Either String (al, st)) (st -> Either String (br, st)) st -> Either String (PAIR bl br, st)
+// , either :: (st -> Either String (al, st)) (st -> Either String (br, st)) st -> Either String (EITHER bl br, st)
+ }
+
+ggcast :: (GGFuns st a) -> GGFuns st c
+ggcast d = {d & int=d.int}
+
+generic gGeneric a :: (GGFuns st a) st -> Either String (a, st)
+
+gGeneric{|Int|} d st = d.int st
+gGeneric{|Bool|} d st = d.bool st
+gGeneric{|Real|} d st = d.real st
+gGeneric{|Char|} d st = d.char st
+
+gGeneric{|UNIT|} d st = d.unit st
+//gGeneric{|CONS of gcd|} f d st = d.cons (f (ggcast d)) gcd st
+//gGeneric{|FIELD of gfd|} f d st = d.field (f (ggcast d)) gfd st
+//gGeneric{|OBJECT of gtd|} f d st = d.object (f (ggcast d)) gtd st
+//gGeneric{|RECORD of grd|} f d st = d.record (f (ggcast d)) grd st
+//gGeneric{|PAIR|} fl fr d st = d.pair (fl (ggcast d)) (fr (ggcast d)) st
+//gGeneric{|EITHER|} fl fr d st = d.either (fl (ggcast d)) (fr (ggcast d)) st
+
+gDefault :: a | gGeneric{|*|} a
+gDefault = fromRight o snd $
+ { int=basic 0, bool=basic True, real=basic 0.0, char=basic 'a', unit=basic UNIT
+ }
+where
+ basic c = \_->Right (c, ())
+
+Start = 42
--- /dev/null
+module bug
+
+import StdEnv
+import Data.Functor
+import Data.Func
+import Data.Maybe
+import Control.Applicative
+import Control.Monad
+
+:: In a b = In infixl 0 a b
+class lambda v
+where
+ (@) infixr 1 :: (v (a -> v b)) (v a) -> v b
+ \| :: ((v a) -> v b) -> v (a -> v b) | TC a & TC b & TC (v b)
+
+class expr v
+where
+ lit :: a -> v a | toString, TC a
+ (+.) infixl 6 :: (v a) (v a) -> v a | + a
+ (-.) infixl 6 :: (v a) (v a) -> v a | - a
+ (*.) infixl 6 :: (v a) (v a) -> v a | * a
+ (/.) infixl 6 :: (v a) (v a) -> v a | / a
+ (==.) infix 4 :: (v a) (v a) -> v Bool | == a
+ If :: (v Bool) (v a) (v a) -> v a
+
+class let v
+where
+ lett :: ((v a) -> In (v a) (v b)) -> v b | TC a
+
+import Data.Either
+import Data.Tuple
+:: St a = St (Env -> Either String (a, Env))
+:: Env :== [(Int, Dynamic)]
+instance Functor St where fmap f m = St $ fmap (appFst f) o evalSt m
+instance pure St where pure x = St \s->Right (x, s)
+instance <*> St where (<*>) mfa ma = ap mfa ma
+instance Monad St
+where
+ bind ma a2mb = St \s->case evalSt ma s of
+ Left err = Left err
+ Right (a, s) = evalSt (a2mb a) s
+
+get = St \s->Right (s, s)
+put s = St \_->Right ((), s)
+evalSt (St m) = m
+
+instance expr St
+where
+ lit a = pure a
+ (+.) l r = (+) <$> l <*> r
+ (-.) l r = (-) <$> l <*> r
+ (*.) l r = (*) <$> l <*> r
+ (/.) l r = (/) <$> l <*> r
+ (==.) l r = (==) <$> l <*> r
+ If i t e = if` <$> i <*> t <*> e
+
+instance lambda St
+where
+ (@) l r = l >>= \l->r >>= \r->l r
+ \| def = pure $ def o pure
+
+instance let St
+where
+ lett def = length <$> get >>= \l->
+ let (x In y) = def $ get >>= \s->hd [d\\(x, d :: St a^)<-s | l == x]
+ in get >>= \s->put [(l, dynamic x):s] >>| y
+
+Start = evalSt t2 []
+where
+// Geeft:
+/*
+initial_unification_environment [module: _SystemDynamic]
+_initial_unification_environment [module: _SystemDynamic]
+_f111;111 [module: bug]
+<lambda>[line:65];38;90 [module: bug]
+<case>[line:39];27;103 [module: bug]
+evalSt [module: bug]
+<lambda>[line:39];23;11 [module: bug]
+evalSt [module: bug]
+<lambda>[line:39];23;11 [module: bug]
+evalSt [module: bug]
+evalSt [module: bug]
+<lambda>[line:39];23;11 [module: bug]
+*/
+ t1 = lett \id = (\| \x->x)
+// In lett \fix = (\| \f->lett \x=f @ x In x)
+ In lett \fac = (\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1)))
+// In lett \facfix = (\| \n->(fix @ \| \fac-> \| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1))) @ n)
+ In fac @ id @ lit 10
+// Geeft:
+/*
+unify_ [module: _SystemDynamic]
+unify_ [module: _SystemDynamic]
+unify_ [module: _SystemDynamic]
+unify_types [module: _SystemDynamic]
+_unify [module: _SystemDynamic]
+_f143;143 [module: bug]
+<lambda>[line:65];38;101 [module: bug]
+<case>[line:39];27;135 [module: bug]
+evalSt [module: bug]
+<lambda>[line:39];23;22 [module: bug]
+evalSt [module: bug]
+evalSt [module: bug]
+*/
+ t2 = lett \id = (\| \x->x)
+ In lett \fix = (\| \f->lett \x=f @ x In x)
+ In lett \fac = (\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1)))
+ In lett \facfix = (\| \n->(fix @ \| \fac-> \| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1))) @ n)
+ In facfix @ id @ lit 10
--- /dev/null
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+module Main where
+
+import Data.Functor
+import Data.Maybe
+import Control.Applicative
+import Control.Monad
+import Data.Dynamic
+import Control.Monad.State
+
+main = putStrLn
+ $ show
+ ( concat $ Main.print e4
+-- , eval e4
+ , evalSt $ (lambdalift e4)
+ , concat $ Main.print e5
+ , evalSt $ (lambdalift e5)
+ )
+
+e1 :: Expr v => v Integer
+e1 = lit 41 +. lit 1
+
+e2 :: (Expr v, Lambda v) => v Integer
+e2 = (a $ \x->x) % e1
+
+e3 :: (Expr v, Lambda v, Let v) => v Integer
+e3 = lett (\id->(a $ \x->x)
+ :- id % e1)
+
+e4 :: (Expr v, Lambda v, Let v, Typeable v) => v Integer
+e4 = {-lett (\id -> (a $ \x->x)
+ :- -}lett (\fix -> (a $ \f->lett $ \x->f % x :- x)
+-- :- lett (\fac -> (a (\n->if' (n ==. lit 0) (lit 1) (n *. (fac % n -. lit 1))))
+ :- lett (\facfix -> (a $ \fac->a $ \n->if' (n ==. lit 0) (lit 1) (n *. (fac % n -. lit 1)))
+ :- (fix % facfix) % lit 10))
+
+e5 :: (Expr v, Lambda v, Let v, Typeable v) => v Integer
+e5 = lett (\fac -> (a $ \n->
+ if' (n ==. lit 0)
+ (lit 1)
+ ((a $ \x->x *. n) % (fac % n -. lit 1))
+ )
+ :- fac % lit 5)
+
+infixl 1 :-
+data In a b = a :- b
+
+infixr 2 %
+class Lambda v where
+ (%) :: v (a -> b) -> v a -> v b
+ a :: (v a -> v b) -> v (a -> b)
+
+infixl 6 +., -.
+infixl 7 *.
+infix 4 ==.
+class Expr v where
+ lit :: Show a => a -> v a
+ (+.) :: Num a => v a -> v a -> v a
+ (-.) :: Num a => v a -> v a -> v a
+ (*.) :: Num a => v a -> v a -> v a
+ (==.) :: Eq a => v a -> v a -> v Bool
+ if' :: v Bool -> v a -> v a -> v a
+
+class Let v where
+ lett :: (Typeable a) => (v a -> In (v a) (v b)) -> v b
+
+data Printer a = P (PS -> [String] -> [String])
+data PS = PS {fresh :: [String]}
+unP (P a) = a
+
+par x = P $ \s->("(":) . unP x s . (")":)
+
+print :: (Printer a) -> [String]
+print a = unP a (PS {fresh = ['v':show x | x <- [0..]]}) []
+
+instance Lambda Printer where
+ l % r = par $ P $ \s->unP l s . (" ":) . unP r s
+ a def = par $ P $ \(PS {fresh=i:is})->
+ (["\\",i,"->"]++) . unP (def (P $ \_->(i:))) (PS {fresh=is})
+
+instance Expr Printer where
+ lit a = P $ \_->(show a:)
+ l +. r = par $ P $ \s->unP l s . ("+":) . unP r s
+ l -. r = par $ P $ \s->unP l s . ("-":) . unP r s
+ l *. r = par $ P $ \s->unP l s . ("*":) . unP r s
+ l ==. r = par $ P $ \s->unP l s . ("==":) . unP r s
+ if' p t e = P $ \s->("if ":) . unP p s . (" then ":)
+ . unP t s . (" else ":) . unP e s . (" fs":)
+
+instance Let Printer where
+ lett def = P $ \s@(PS {fresh=i:is})->
+ let x :- y = def $ P $ \_->(i:)
+ in (["let ",i,"="]++) . unP x s . (" in\n":) . unP y (PS {fresh=is})
+
+eval :: Maybe a -> Maybe a
+eval a = a
+
+instance Lambda Maybe where
+ (%) l r = ($) <$> l <*> r
+ a def = pure $ fromJust . def . pure
+
+instance Expr Maybe where
+ lit a = pure a
+ l +. r = (+) <$> l <*> r
+ l -. r = (-) <$> l <*> r
+ l *. r = (*) <$> l <*> r
+ l ==. r = (==) <$> l <*> r
+ if' i t e = i >>= \i->if i then t else e
+
+instance Let Maybe where
+ lett def = let x :- y = def x in y
+
+evalSt :: (State [(Int, Dynamic)] a) -> a
+evalSt s = evalState s []
+
+instance Lambda (State [(Int, Dynamic)]) where
+ l % r = ($) <$> l <*> r
+ a def = get >>= \s->pure $ \a->evalState (def $ pure a) s
+
+instance Expr (State [(Int, Dynamic)]) where
+ lit a = pure a
+ l +. r = (+) <$> l <*> r
+ l -. r = (-) <$> l <*> r
+ l *. r = (*) <$> l <*> r
+ l ==. r = (==) <$> l <*> r
+ if' i t e = i >>= \i->if i then t else e
+
+instance Let (State [(Int, Dynamic)]) where
+ lett def = gets length >>= \l->
+ let x :- y = def $ get >>= \s->head $ catMaybes [fromDynamic d | (x, d)<-s, l == x]
+ in modify ((l, toDyn x):) >> y
+
+data LambdaLift v a = LL {unLL :: LLS -> (v a, LLS)}
+data LLS = LLS {toplevel :: Bool}
+lambdalift :: LambdaLift v a -> v a
+lambdalift m = fst $ unLL m $ LLS {toplevel=True}
+
+infixl 4 <<$>>, <<*>>
+infixl 1 >>>=
+class FFunctor m where
+ (<<$>>) :: (v a -> w b) -> m v a -> m w b
+
+class AApplicative m where
+ ppure :: v a -> m v a
+ (<<*>>) :: m ((->) (v a)) (w b) -> m v a -> m w b
+
+class MMonad m where
+ (>>>=) :: m v a -> (v a -> m w b) -> m w b
+
+instance FFunctor LambdaLift where
+ f <<$>> m = LL $ \s->let (a, s') = unLL m s in (f a, s')
+instance AApplicative LambdaLift where
+ ppure a = LL $ (,) a
+ m <<*>> n = LL $ \s->
+ let (v, s') = unLL m s
+ (w, s'') = unLL n s
+ in (v w, s'')
+instance MMonad LambdaLift where
+ --m >>>= a2mb = LL $ uncurry (unLL . a2mb) . unLL m
+ m >>>= a2mb = LL $ \s->let (a, s') = unLL m $ s in unLL (a2mb a) s
+
+instance Expr v => Expr (LambdaLift v) where
+ lit a = ppure (lit a)
+ l +. r = (+.) <<$>> l <<*>> r
+ l -. r = (-.) <<$>> l <<*>> r
+ l *. r = (*.) <<$>> l <<*>> r
+ l ==. r = (==.) <<$>> l <<*>> r
+ if' i t e = if' <<$>> i <<*>> t <<*>> e
+
+instance Lambda v => Lambda (LambdaLift v) where
+ l % r = (%) <<$>> l <<*>> r
+ a def = LL $ \s->(a $ \a->fst $ unLL (def $ ppure a) s, s)
+
+instance Let v => Let (LambdaLift v) where
+ lett def = let x :- y = def x in y
+++ /dev/null
-module test
-
-import StdEnv
-import Data.Functor
-import Data.Func
-import Data.Maybe
-import Control.Applicative
-import Control.Monad
-
-:: In a b = In infixl 0 a b
-class lambda v
-where
- (@) infixr 1 :: (v (a -> b)) (v a) -> v b
- \| :: ((v a) -> v b) -> v (a -> b) | TC a & TC b
-
-class expr v
-where
- lit :: a -> v a | toString, TC a
- (+.) infixl 6 :: (v a) (v a) -> v a | + a
- (-.) infixl 6 :: (v a) (v a) -> v a | - a
- (*.) infixl 6 :: (v a) (v a) -> v a | * a
- (/.) infixl 6 :: (v a) (v a) -> v a | / a
- (==.) infix 4 :: (v a) (v a) -> v Bool | == a
- If :: (v Bool) (v a) (v a) -> v a
-
-class let v
-where
- lett :: ((v a) -> In (v a) (v b)) -> v b | TC a
-
-:: Printer a = P ([String] [String] -> [String])
-unP (P a) = a
-print :: (Printer a) -> [String]
-print (P a) = a ["v" +++ toString i\\i<-[0..]] []
-instance lambda Printer
-where
- (@) (P l) (P r) = P \i c->l i [" ":r i c]
- \| def = P \[i:is] c->["(\\", i, "->":unP (def (P \_ c->[i:c])) is [")":c]]
-
-instance expr Printer
-where
- lit a = P \i c->[toString a:c]
- (+.) (P l) (P r) = P \i c->["(":l i ["+":r i [")":c]]]
- (-.) (P l) (P r) = P \i c->["(":l i ["-":r i [")":c]]]
- (*.) (P l) (P r) = P \i c->["(":l i ["*":r i [")":c]]]
- (/.) (P l) (P r) = P \i c->["(":l i ["/":r i [")":c]]]
- (==.) (P l) (P r) = P \i c->["(":l i ["==":r i [")":c]]]
- If (P p) (P t) (P e) = P \i c->["if ":p i [" then ":t i [" else ":e i [" fi":c]]]]
-
-instance let Printer
-where
- lett def = P \[i:is] c->
- let (x In y) = def $ P \_ c->[i:c]
- in ["let ",i,"=":(unP x) [i:is] [" in ":(unP y) is c]]
-
-eval :: (Maybe a) -> Maybe a
-eval a = a
-
-instance lambda Maybe
-where
- (@) l r = ($) <$> l <*> r
- \| def = Just $ fromJust o def o Just
-
-instance expr Maybe
-where
- lit a = pure a
- (+.) l r = (+) <$> l <*> r
- (-.) l r = (-) <$> l <*> r
- (*.) l r = (*) <$> l <*> r
- (/.) l r = (/) <$> l <*> r
- (==.) l r = (==) <$> l <*> r
- If i t e = if` <$> i <*> t <*> e
-
-instance let m
-where
- lett def = let (x In y) = def x in y
-
-:: St a = St (State -> (a, State))
-:: State :== [(Int, Dynamic)]
-instance Functor St where fmap f m = St $ (\(a, b)->(f a, b)) o evalSt m
-instance pure St where pure x = St \s->(x, s)
-instance <*> St where (<*>) mfa ma = ap mfa ma
-instance Monad St
-where
- bind ma a2mb = St \s
- # (a, s) = evalSt ma s
- = evalSt (a2mb a) s
-
-get = St \s->(s, s)
-put s = St \_->((), s)
-evalSt (St m) = m
-
-instance expr St
-where
- lit a = pure a
- (+.) l r = (+) <$> l <*> r
- (-.) l r = (-) <$> l <*> r
- (*.) l r = (*) <$> l <*> r
- (/.) l r = (/) <$> l <*> r
- (==.) l r = (==) <$> l <*> r
- If i t e = if` <$> i <*> t <*> e
-
-instance lambda St
-where
- (@) l r = ($) <$> l <*> r
- \| def = get >>= \s->pure \a->fst $ evalSt (def $ pure a) s
-
-instance let St
-where
- lett def = length <$> get >>= \l->
- let (x In y) = def $ get >>= \s->hd [d\\(x, d :: St a^)<-s | l == x]
- in get >>= \s->put [(l, dynamic x):s] >>| y
-
-//Start = (print t, "\n", eval t, semSt t)
-Start = (print t, "\n", fst $ evalSt t [])
-where
- t :: (v Int) | expr, lambda, let v
- t = lett \id =(\| \x->x)
- In lett \fix =(\| \f->lett \x=f @ x In x)
- In lett \fac=(\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1)))
- In lett \facfix=(\| \n->(fix @ \| \fac-> \| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1))) @ n)
- In facfix @ id @ lit 10
--- /dev/null
+module test
+
+import iTasks
+
+Start w = doTasks (return ()) w
+++ /dev/null
-module shallow
-
-import StdEnv
-
-:: DSL = DSL a
-
-lit :: a -> DSL a
-lit a = ...
--- /dev/null
+module cloudiTasks
+
+import Data.Functor
+import Data.Queue
+import iTasks.Internal.Serialization
+import iTasks.Internal.TaskEval
+import iTasks.UI.Editor.Common
+import StdEnv
+import Data.Func
+import Data.Tuple
+import Data.Map.GenJSON
+import iTasks
+import iTasks.Extensions.DateTime
+import iTasks.Internal.Distributed.RemoteTask
+import qualified Data.Map
+import System.Time
+
+:: CloudTaskType = ExistingNode String Int
+
+//mapReadWrite :: !(!r -> r`,!w` r -> Maybe w) !(Maybe (SDSReducer p w w`)) !(sds p r w) -> SDSLens p r` w` | gText{|*|} p & TC p & TC r & TC w & RWShared sds
+
+asyncTask :: CloudTaskType (Task a) -> Task a | iTask a
+asyncTask (ExistingNode host port) t
+ = upd (\tid->(tid, TaskWrapper t)) (remoteShare cloudITasksQueue {domain=host, port=port})
+ >>- \(tid, _)->let rvalue = remoteShare (sdsFocus tid cloudITasksValues) {domain=host,port=port}
+ in Task (proxy NoValue rvalue rvalue)
+where
+ proxy ::
+ //The old task value
+ (TaskValue a)
+ //The original value queue
+ (sds1 () (Queue (TaskValue a, UIChange)) (Queue (TaskValue a, UIChange)))
+ //The temporary value queue
+ (sds2 () (Queue (TaskValue a, UIChange)) (Queue (TaskValue a, UIChange)))
+ Event
+ TaskEvalOpts
+ !*IWorld
+ -> *(TaskResult a, *IWorld) | RWShared sds1 & Readable, Registrable sds2 & iTask a
+ proxy lastVal valueShare tValueShare event {TaskEvalOpts|taskId,lastEval} iworld
+ = case readRegister taskId tValueShare iworld of
+ (Ok (ReadingDone queue), iworld)
+ = case dequeue queue of
+ (Nothing, queue)
+ = (ValueResult
+ lastVal
+ {lastEvent=lastEval, removedTasks=[]}
+ NoChange
+ (Task (proxy lastVal valueShare tValueShare))
+ , iworld)
+ (Just (tv, ui), queue)
+ = case write queue valueShare (TaskContext taskId) iworld of
+ (Ok _, iworld)
+ = (ValueResult
+ tv
+ {lastEvent=lastEval, removedTasks=[]}
+ ui
+ (Task (proxy tv valueShare valueShare))
+ , iworld)
+ (Error e, iworld) = (ExceptionResult e, iworld)
+ (Ok (Reading tValueShare), iworld)
+ = (ValueResult
+ lastVal
+ {lastEvent=lastEval, removedTasks=[]}
+ NoChange
+ (Task (proxy lastVal valueShare tValueShare))
+ , iworld)
+ (Error e, iworld) = (ExceptionResult e, iworld)
+
+Start w = flip doTasksWithOptions w \args eo
+ # (eo, s) = case args of
+ [argv0,"--slave",p] = ({eo & sdsPort=toInt p}, onStartup o slave)
+ _ = (eo, onRequest "/" o master)
+ = Ok (s args, {eo & distributed=True})
+
+JSONEncode{|TaskWrapper|} _ t = [dynamicJSONEncode t]
+JSONDecode{|TaskWrapper|} _ [t:c] = (dynamicJSONDecode t, c)
+JSONDecode{|TaskWrapper|} _ c = (Nothing, c)
+gEq{|TaskWrapper|} _ _ = False
+gEditor{|TaskWrapper|} = emptyEditor
+gText{|TaskWrapper|} tf ma = maybe [] (\_->["TaskWrapper"]) ma
+
+slave :: [String] -> Task ()
+slave args
+ = get applicationOptions
+ >>- \eo->traceValue ("Slave started on port " +++ toString eo.sdsPort)
+ >-| parallel
+ [(Embedded, \stl->flip (@!) () $ forever $
+ watch cloudITasksQueueInt
+ >>* [OnValue $ ifValue (not o isEmpty) \[(tid, TaskWrapper task):xs]->
+ set xs cloudITasksQueueInt
+ >-| appendTask Embedded (\_->wrapTask tid task) stl
+ ]
+ )] []
+ @? const NoValue
+where
+ wrapTask :: TaskId (Task a) -> Task () | iTask a
+ wrapTask taskId (Task teval) = Task \event opts iworld->
+ case teval event {TaskEvalOpts|opts & taskId=taskId} iworld of
+ (ValueResult tv tei uic newtask, iworld)
+ = case modify (enqueue (tv, uic)) (sdsFocus taskId cloudITasksValues) EmptyContext iworld of
+ (Ok (ModifyingDone _), iworld)
+ = (ValueResult (() <$ tv) tei uic $ wrapTask taskId newtask, iworld)
+ (Ok _, iworld) = (ExceptionResult $ exception "wrapTask async share????", iworld)
+ (Error e, iworld) = (ExceptionResult e, iworld)
+ (ExceptionResult e, iworld) = (ExceptionResult e, iworld)
+ (DestroyedResult, iworld) = (DestroyedResult, iworld)
+
+derive JSONEncode Queue, Event, Set
+derive JSONDecode Queue, Event, Set
+cloudITasksValues :: SDSLens TaskId (Queue (TaskValue a, UIChange)) (Queue (TaskValue a, UIChange)) | TC, JSONEncode{|*|}, JSONDecode{|*|} a
+cloudITasksValues = sdsTranslate "" toString
+ $ memoryStore "cloudITasks-values" $ Just newQueue
+
+cloudITasksEvents :: SDSLens TaskId (Queue Event) (Queue Event)
+cloudITasksEvents = sdsTranslate "" toString
+ $ memoryStore "cloudITasks-events" $ Just newQueue
+
+nextTaskIdShare :: SDSSource () TaskId ()
+nextTaskIdShare = SDSSource
+ { SDSSourceOptions
+ | name = "nextTaskIdShare"
+ , read = \_->appFst Ok o getNextTaskId
+ , write = \_ _->tuple $ Ok (\_ _->True)
+ }
+
+cloudITasksQueue :: SDSLens () TaskId (TaskId, TaskWrapper)
+cloudITasksQueue =
+ mapReadWrite
+ ( \(nextTaskId, _)->nextTaskId
+ , \newTask (nextTaskId, tasks)->Just ((), [newTask:tasks])
+ ) Nothing (nextTaskIdShare >*< cloudITasksQueueInt)
+
+cloudITasksQueueInt :: SimpleSDSLens [(TaskId, TaskWrapper)]
+cloudITasksQueueInt = sdsFocus "queue" $ memoryStore "cloudITasks" (Just [])
+
+master :: [String] -> Task ()
+master args
+ = get applicationOptions
+ >>- \eo->traceValue ("Master started on port " +++ toString eo.serverPort)
+ >-| asyncTask (ExistingNode "localhost" 9099) (traceValue "boink")
+ @! ()
+
+blockWait :: Int -> Task Int
+blockWait i = accWorld (sleep i)
+where
+ sleep :: !Int !*e -> (!Int, !*e)
+ sleep _ _ = code {
+ ccall sleep "I:I:A"
+ }
:: GTSState
instance zero GTSState
generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
-derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_arity,gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_arity,grd_name,grd_fields}
+derive gToStruct Int, Bool, Char, Real, UNIT, CONS of {gcd_type}, FIELD, EITHER, PAIR, OBJECT of {gtd_arity,gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_arity,grd_name,grd_fields}
/**
* Given a GTSState, generate typedefinitions
:: CType
= CTTypeDef String
| CTEnum [String]
- | CTStruct Int [(String, [(String, Bool, String)])]
+ | CTStruct Int [(String, [(String, Bool, String, Maybe GenType)])]
-:: GTSState = {dict :: Map String CType}
-instance zero GTSState where zero = {dict=newMap}
+:: GTSState = {dict :: Map String CType, ts :: [GenType]}
+instance zero GTSState where zero = {dict=newMap, ts=[]}
toStruct :: Box GTSState a | gToStruct{|*|} a
toStruct = snd $ gToStruct{|*|} zero
generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
:: GTSResult
- = GTSType Bool String //ispointer and the name
+ = GTSType Bool String (Maybe GenType)//ispointer and the name
+ | GTSTyVar Int
| GTSUnit
| GTSEither [GTSResult]
| GTSPair [GTSResult]
putst k v st = {st & dict=put k v st.dict}
-gToStruct{|Int|} st = (GTSType False "uint64_t", box st)
-gToStruct{|Bool|} st = (GTSType False "bool", box st)
-gToStruct{|Char|} st = (GTSType False "char", box st)
-gToStruct{|Real|} st = (GTSType False "double", box st)
+import Debug.Trace
+gToStruct{|Int|} st = (GTSType False "uint64_t" $ listToMaybe st.ts, box st)
+gToStruct{|Bool|} st = (GTSType False "bool" $ listToMaybe st.ts, box st)
+gToStruct{|Char|} st = (GTSType False "char" $ listToMaybe st.ts, box st)
+gToStruct{|Real|} st = (GTSType False "double" $ listToMaybe st.ts, box st)
gToStruct{|UNIT|} st = (GTSUnit, box st)
-gToStruct{|CONS|} f _ st = appSnd reBox $ f st
+gToStruct{|CONS of {gcd_type}|} f _ st
+ = appSnd reBox $ f {st & ts=pt gcd_type}
+where
+ pt (GenTypeArrow l r) = [l:pt r]
+ pt a = [a]
+
gToStruct{|FIELD|} f _ st = appSnd reBox $ f st
gToStruct{|EITHER|} fl _ fr _ st
# (l, Box st) = fl st
(a, GTSEither l) = GTSEither [a:l]
(l, r) = GTSEither [l, r]
, box st)
-gToStruct{|PAIR|} fl _ fr _ st
- # (l, Box st) = fl st
- # (r, Box st) = fr st
+gToStruct{|PAIR|} fl _ fr _ st=:{ts=[t:ts]}
+ # (l, Box st) = fl {st & ts = [t]}
+ # (r, Box st) = fr {st & ts = ts}
= (case (l, r) of
(GTSPair l, GTSPair r) = GTSPair (l ++ r)
(a, GTSPair l) = GTSPair [a:l]
import Debug.Trace
gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
# (Box isPInf) = i []
- # ty = GTSType isPInf
= case get gtd_name st.dict of
- Just _ = (GTSType isPInf gtd_name, box st)
+ Just _ = (GTSType isPInf gtd_name $ listToMaybe st.ts, box st)
Nothing
//Newtype
| gtd_num_conses == 0
= case f st of
- (GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st)
+ (GTSType pi n mt, Box st) = (GTSType pi gtd_name mt, box $ putst gtd_name (CTTypeDef n) st)
//If it is just an enumeration, Just the enum
| and [gcd.gcd_arity == 0\\gcd<-gtd_conses]
- = (GTSType False gtd_name, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
+ = (GTSType False gtd_name Nothing, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
//Constructors with data fields
# (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
=
- ( GTSType isPInf gtd_name
+ ( GTSType isPInf gtd_name Nothing
, box $ putst gtd_name
(CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
)
mkty t = [t]
mkccons :: GTSResult -> [GTSResult]
- mkccons (GTSType pi t) = [GTSType pi t]
+ mkccons (GTSType pi t a) = [GTSType pi t a]
mkccons (GTSPair t) = t
mkccons _ = []
- ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
- ctcons gcd cons
- # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
- = (gcd_name, toT cons)
+ ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String, Maybe GenType)])
+ ctcons gcd cons = (gcd.gcd_name, toT cons)
where
- toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
+ toT cons = [(t, pi, "f"+++toString i, mt)\\i<-[0..] & GTSType pi t mt<-cons]
gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st
# (Box isPInf) = i []
= case get grd_name st.dict of
- Just n = (GTSType isPInf grd_name, box st)
+ Just n = (GTSType isPInf grd_name Nothing, box st)
Nothing
# (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st
= case n of
GTSPair l =
- ( GTSType isPInf grd_name
- , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
+ ( GTSType isPInf grd_name Nothing
+ , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd, mt)\\GTSType pi t mt<-l & gfd<-grd_fields])]) st)
_ = (GTSError, box st)
/**
where
refs (CTTypeDef s) = [s]
refs (CTEnum _) = []
- refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
+ refs (CTStruct _ cs) = map (\(a, _, _, _)->a) (flatten (map snd cs))
proc [] c = c
proc [x] c = ctypedef x (find x m) c
ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
ctypedef name (CTStruct _ [(_, fs)]) c =
[ "struct ", name, " {\n"
- : foldr (uncurry3 (field 1))
+ : foldr (field 1)
["};\n":c] fs
]
ctypedef name (CTStruct _ cs) c =
cs]]]]
struct name [] c = c
- struct name [(ty, pi, _)] c = field 2 ty pi name c
- struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs]
+ struct name [(ty, pi, _, mt)] c = field 2 (ty, pi, name, mt) c
+ struct name fs c = ind 2 ["struct {\n" :foldr (field 3) (ind 2 ["} ", name, ";\n":c]) fs]
- field i ty pi name c
+ field i (ty, pi, name, gt) c
= ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
enum [] c = c
where
funsigs = foldr (uncurry funsig) [";\n"] $ toList m
pfname n c = ["parse_", n:c]
- pfcall n c = pfname n ["(get, alloc, err);":c]
+ pfcall n Nothing c = pfname n ["(get, alloc, err);":c]
+ pfcall n (Just t) c
+ # (n, t) = trace_stdout (n, t)
+ = pf t c
+ where
+ pf (GenTypeCons n) c = pfcall n Nothing c
+ pf (GenTypeVar i) c = pfcall (toString i) Nothing c
+ pf (GenTypeApp t (GenTypeVar i)) c
+ = pf t $ pfcall (toString i) Nothing c
+ pf _ c = c
+//
+// pfcall n (Just (GenTypeVar i)) c = pfcall (toString i) Nothing c
+// pfcall n (Just (GenTypeApp (GenTypeCons _) (GenTypeVar i))) c
+// = pfcall (toString i) Nothing c
+// pfcall n (Just t) c
+// # (_, t, c, _) = trace_stdout ("\nblurp: ", t, c, "\n")
+// = c
+
+// pfcall n mt c = pfname n ["(get, alloc, err":(maybe id stycall mt) [");":c]]
+// where
+// stycall (GenTypeVar i) c
+// = [", ":pfname (toString i) c]
+// stycall (GenTypeApp (GenTypeCons _) (GenTypeVar i)) c
+// = [", ":pfname (toString i) c]
+// stycall _ c = c
funsig n (CTStruct i _) c
| i > 0
= typeName n m [" "
: ind i ["void (*err)(const char *errmsg, ...)"
:c]]]
- funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]]
+ funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a Nothing ["\n":c]]
funb (CTEnum a) c = ind 1 ["r = get()\n":c]
funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
funb (CTStruct _ fs) c
: foldr (sfield 2 ("r.data."+++ n))
(ind 2 ["break;\n":c]) fs]
- sfield i r (ty, ptr, f) c
+ sfield i r (ty, ptr, f, mt) c
= (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c)
- $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty ["\n":c]]
+ $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty mt ["\n":c]]
/**
* Given a GTSState, generate a printer
: foldr (sfield 2 ("r.data."+++ n))
(ind 2 ["break;\n":c]) fs]
- sfield i r (ty, ptr, f) c
+ sfield i r (ty, ptr, f, mt) c
= ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]
toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
module test
+import Data.Maybe
+import Data.Either
import GenC
import Text
:: R = {i :: Int, q :: T}
:: Muta a = Muta (Mutb a)
:: Mutb a = Mutb (Muta a)
-derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
-derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
-
+derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,), Maybe, Either
+derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,), Maybe, Either
Start = let (l, r) = (toCParser (unBox t2)) in concat r
where
// t :: Box GTSState NInt
t = Box "listmutaint"
- t2 :: Box GTSState (Bool, Int)
+ t2 :: Box GTSState [Either Int Bool]
+// t2 :: Box GTSState (Either Int Bool)
+// t2 :: Box GTSState [Int]
t2 = toStruct
import Data.Maybe
import Data.Functor
import Data.Func
+import Data.Tuple
+import Data.List
import Control.Applicative
import Control.Monad
import qualified Data.Map
-class get v ~st
-where
- get :: (v r w) .st -> .(Maybe r, .st) | TC r
-class put v ~st
-where
- put :: w (v r w) .st -> .(Maybe (), .st) | TC w
+class get v ~st :: (v r w) .st -> .(Maybe r, .st) | TC r
+class put v ~st :: w (v r w) .st -> .(Maybe (), .st) | TC w
+
+:: SDS sds a :== sds a a
:: Source r w = Source String
:: St :== 'Data.Map'.Map String Dynamic
where
put w (Source n) st = (Just (), 'Data.Map'.put n (dynamic w) st)
-:: Par sdsl sdsr r w = E.r1 r2 w1 w2: Par (ParOpts sdsl sdsr r1 r2 w1 w2 r w)
- & TC r1 & TC r2 & TC w1 & TC w2
+:: Par sdsl sdsr r w = E.r1 r2 w1 w2: Par (ParOpts sdsl sdsr r1 r2 w1 w2 r w) & TC r1 & TC r2 & TC w1 & TC w2
:: ParOpts sdsl sdsr r1 r2 w1 w2 r w =
{ read :: r1 r2 -> Maybe r
, write :: w -> Maybe (w1, w2)
- , left :: (sdsl r1 w1)
- , right :: (sdsr r2 w2)
+ , left :: sdsl r1 w1
+ , right :: sdsr r2 w2
}
+(>*<) infixl 6 :: (sdsl r1 w1) (sdsr r2 w2) -> Par sdsl sdsr (r1, r2) (w1, w2) | get sdsl St & put sdsr St & TC r1 & TC r2 & TC w1 & TC w2
+(>*<) l r = Par {read= \x y->Just (x, y), write=Just, left=l, right=r}
instance get (Par sdsl sdsr) St | get sdsl St & get sdsr St
where
where
put w (Par {write,left,right}) st
= case write w of
- Nothing = (Nothing, st)
Just (w1, w2)
# (ml, st) = put w1 left st
# (mr, st) = put w2 right st
= (ml *> mr, st)
+ Nothing = (Nothing, st)
+
+:: Lens sds r w = E.r1 w1: Lens (LensOpts sds r1 w1 r w) & TC r1 & TC w1
+:: LensOpts sds r1 w1 r w =
+ { mapr :: r1 -> Maybe r
+ , mapw :: w r1 -> Maybe w1
+ , lens :: sds r1 w1
+ }
+
+instance get (Lens sds) St | get sds St
+where
+ get (Lens {mapr,lens}) st = appFst ((=<<) mapr) $ get lens st
+instance put (Lens sds) St | get sds St & put sds St
+where
+ put w (Lens {mapw,lens}) st
+ # (mv, st) = get lens st
+ = case mv of
+ Just r = case mapw w r of
+ Just w = put w lens st
+ Nothing = (Nothing, st)
+ Nothing = (Nothing, st)
+
+:: Select sdsl sdsr r w = E.r1 w1: Select (SelectOpts sdsl sdsr r1 w1 r w) & TC r1 & TC w1
+:: SelectOpts sdsl sdsr r1 w1 r w =
+ { select :: sdsl r1 w1
+ , bind :: r1 -> (sdsr r w)
+ }
+
+instance get (Select sdsl sdsr) St | get sdsl St & get sdsr St
+where
+ get (Select {select,bind}) st
+ = case get select st of
+ (Just r, st) = get (bind r) st
+ (Nothing, st) = (Nothing, st)
+instance put (Select sdsl sdsr) St | get sdsl St & put sdsr St
+where
+ put w (Select {select,bind}) st
+ = case get select st of
+ (Just r, st) = put w (bind r) st
+ (Nothing, st) = (Nothing, st)
+
+mapRead :: (r -> r`) (sds r w) -> Lens sds r` w | TC r` & TC r & TC w
+mapRead f sds = Lens {mapr=Just o f, mapw=const o Just, lens=sds}
+(>?@) infixl 6
+(>?@) :== mapRead
+
+mapWrite :: (w` r -> Maybe w) (sds r w) -> Lens sds r w` | TC r & TC w & TC w`
+mapWrite f sds = Lens {mapr=Just, mapw=f, lens=sds}
+(>!@) infixl 6
+(>!@) :== mapWrite
+
+indexedStore :: Int (SDS sds [a]) -> SDS (Lens sds) a | TC a
+indexedStore idx sds
+ = Lens
+ { mapr = \r->r !? idx
+ , mapw = \w->Just o updateAt idx w
+ , lens = sds
+ }
+
+indexedSelect :: (sdsl Int z) (SDS sdsr [a]) -> SDS (Select sdsl (Lens sdsr)) a | TC a & TC z
+indexedSelect l r = Select {select=l, bind=flip indexedStore r}
+
+keyedSelect :: (sdsl k z) (SDS sdsr ('Data.Map'.Map k v)) -> SDS (Select sdsl (Lens sdsr)) v | TC z & TC v & TC k & < k
+keyedSelect l r = Select {select=l, bind=flip keyedStore r}
+
+keyedStore :: k (SDS sds ('Data.Map'.Map k v)) -> SDS (Lens sds) v | TC v & TC k & < k
+keyedStore key sds
+ = Lens
+ { mapr = 'Data.Map'.get key
+ , mapw = \r->Just o 'Data.Map'.put key r
+ , lens = sds
+ }
+
+Start = appSnd 'Data.Map'.toList
+ $ put (42, "blurp") (store "foo" >*< store "bar") 'Data.Map'.newMap
-Start :: (Maybe Int, .St)
-Start
- # st = 'Data.Map'.newMap
- # (Just _, st) = put 42 (Source "blurp") st
- = get (Source "blurp") st
+store :: (String -> Source a a) | TC a
+store = Source
--- /dev/null
+module test
+
+import StdArray
+
+someint :: *{Int}
+someint = {1,2,3}
+
+uid :: .a -> .a
+uid x = x
+
+toDyn :: *a -> *Dynamic
+toDyn a = dynamic a
+
+Start = toDyn someint
repositories / clean-tests.git / commitdiff