From de9656d30475c64e1a52017821e04393c9904a16 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 26 Aug 2021 10:04:12 +0200 Subject: [PATCH] add datatype generation DSL stuff --- .gitignore | 4 + datatype/Compiler.hs | 268 ++++++++++++++++++++++++++++++ datatype/Language.hs | 37 +++++ datatype/Main.hs | 86 ++++++++++ datatype/MkCons.hs | 173 +++++++++++++++++++ datatype/Printer.hs | 136 +++++++++++++++ datatype/Serialise.hs | 41 +++++ datatype/Tuple.hs | 26 +++ gopt.icl | 166 ++++++++++++++++++ slave/cloudiTasks/cloudiTasks.icl | 149 ----------------- test.icl | 27 ++- 11 files changed, 950 insertions(+), 163 deletions(-) create mode 100644 datatype/Compiler.hs create mode 100644 datatype/Language.hs create mode 100644 datatype/Main.hs create mode 100644 datatype/MkCons.hs create mode 100644 datatype/Printer.hs create mode 100644 datatype/Serialise.hs create mode 100644 datatype/Tuple.hs create mode 100644 gopt.icl delete mode 100644 slave/cloudiTasks/cloudiTasks.icl diff --git a/.gitignore b/.gitignore index df867ba..af28e48 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,7 @@ afp/a[0-9]/a[0-9] afp/a1[0-9]/a1[0-9] struct + +*.hi +*.dyn_hi +*.dyn_o diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs new file mode 100644 index 0000000..1070ecb --- /dev/null +++ b/datatype/Compiler.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Compiler where + +import Language +import Serialise + +import qualified Data.Map as DM +import Control.Monad.Writer +import Control.Monad.State +import Control.Monad.ST +import Debug.Trace +import Data.Array +import Data.Array.ST +import Data.Function + +newtype Compiler a = Compiler { unCompiler :: StateT CS (WriterT [Instr] (Either String)) a } + deriving + ( Functor + , Applicative + , Monad + , MonadWriter [Instr] + , MonadState CS + ) +instance MonadFail Compiler where fail s = Compiler $ lift $ lift $ Left s +data CS = CS + { fresh :: [Int] + , functions :: DM.Map Int [Instr] + } + +runCompiler :: Compiler a -> Either String [Instr] +runCompiler c = execWriterT + $ evalStateT (unCompiler (c >> instr [Halt] >> writeFunctions)) + $ CS {fresh=[0..], functions=DM.empty} + where + writeFunctions :: Compiler () + writeFunctions = gets (DM.elems . functions) >>= tell . concat + +instr :: [Instr] -> Compiler a +instr i = tell i >> pure undefined + +freshLabel :: Compiler Int +freshLabel = get >>= \cs->put (cs { fresh=tail (fresh cs) }) >> pure (head $ fresh cs) + +binop :: Instr -> Compiler a1 -> Compiler a2 -> Compiler b +binop i l r = l >> r >> instr [i] + +unop :: Instr -> Compiler a -> Compiler b +unop i l = l >> instr [i] + +instance Expression Compiler where + lit v = instr $ map Push $ serialise v [] + (+.) = binop Add + (-.) = binop Sub + (/.) = binop Div + (*.) = binop Mul + (^.) = binop Pow +-- (^.) l r = freshLabel >>= \lblstart->freshLabel >>= \lblend-> +-- l >> r >> instr -- pow (x, y) { +-- [ Str 1 +-- , Str 0 +-- , Push 1 -- res = 1 +-- , Lbl lblstart -- while +-- , Ldr 1 -- (y == 0) +-- , Push 0 -- +-- , Neq -- +-- , Brf lblend -- +-- , Ldr 0 -- res *= x +-- , Mul -- +-- , Ldr 1 -- y -= 1 +-- , Push 1 -- +-- , Sub -- +-- , Str 1 -- +-- , Bra lblstart -- +-- , Lbl lblend -- +-- ] + neg = unop Neg + (&.) = binop And + (|.) = binop Or + not = unop Not + (==.) = binop Eq + (/=.) = binop Neq + (<.) = binop Le + (>.) = binop Ge + (<=.) = binop Leq + (>=.) = binop Geq + if' p t e = freshLabel >>= \elselabel-> freshLabel >>= \endiflabel-> + p >> instr [Brf elselabel] >> + t >> instr [Bra endiflabel, Lbl elselabel] >> + e >> instr [Lbl endiflabel] + +instance Function () Compiler where + fun def = Main $ + freshLabel >>= \funlabel-> + let g :- m = def (\()->instr [Jsr funlabel]) + in liftFunction funlabel 0 (g ()) >> unmain m + +instance Function (Compiler a) Compiler where + fun def = Main $ + freshLabel >>= \funlabel-> + let g :- m = def (\a->a >> instr [Jsr funlabel]) + in liftFunction funlabel 1 (g (instr [Arg 0])) >> unmain m + +instance Function (Compiler a, Compiler b) Compiler where + fun def = Main $ + freshLabel >>= \funlabel-> + let g :- m = def (\(a, b)->a >> b >> instr [Jsr funlabel]) + in liftFunction funlabel 2 (g (instr [Arg 1], instr [Arg 0])) >> unmain m + +instance Function (Compiler a, Compiler b, Compiler c) Compiler where + fun def = Main $ + freshLabel >>= \funlabel-> + let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel]) + in liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m + +liftFunction :: Int -> Int -> Compiler a -> Compiler () +liftFunction lbl nargs body = do + is <- snd <$> censor (\_->[]) (listen body) + let instructions = Lbl lbl : is ++ [Ret nargs] + modify (\s->s { functions=DM.insert lbl instructions $ functions s }) + +data Instr + = Push Int | Pop Int | Dup | Roll Int Int + | Add | Sub | Mul | Div | Neg | Pow + | And | Or | Not + | Eq | Neq | Le | Ge | Leq | Geq + | Lbl Int | Bra Int | Brf Int + | Str Int | Ldr Int + | Sth Int | Ldh Int + | Jsr Int | Ret Int | Arg Int + | Halt + deriving Show + +data Registers = Registers + { pc :: Int + , hp :: Int + , sp :: Int + , mp :: Int + , gp :: DM.Map Int Int + } + deriving Show + +interpret :: Int -> [Instr] -> Array Int Int +interpret memsize prog = runSTArray $ do + program <- newListArray (0, length prog) prog + mem <- newArray (0, memsize-1) 0 + int program mem (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty}) + where + pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers + pushh memory value reg = do + writeArray memory (hp reg) value + pure (reg { hp = hp reg + 1} ) + + loadh :: STArray s Int Int -> Int -> Registers -> ST s Registers + loadh memory hptr registers = readArray memory hptr >>= flip (push memory) registers + + push :: STArray s Int Int -> Int -> Registers -> ST s Registers + push memory value reg = do + writeArray memory (sp reg) value + pure (reg { sp = sp reg - 1} ) + + pop :: STArray s Int Int -> Registers -> ST s (Registers, Int) + pop memory reg = do + v <- readArray memory (sp reg + 1) + pure (reg { sp = sp reg + 1}, v) + + popn :: STArray s Int Int -> Int -> Registers -> ST s (Registers, [Int]) + popn _ 0 reg = pure (reg, []) + popn memory n reg = do + (reg', v) <- pop memory reg + (reg'', vs) <- popn memory (n - 1) reg' + pure (reg'', v:vs) + + bop :: (Int -> Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers + bop op memory reg = do + (reg1, r) <- pop memory reg + uop (flip op r) memory reg1 + + uop :: (Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers + uop op memory reg = do + (reg1, r) <- pop memory reg + push memory (op r) reg1 + + int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int) + int program memory registers = do + instruction <- readArray program $ pc registers + stack <- getElems memory + let reg = registers { pc = pc registers + 1 } + case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of +-- case instruction of + Str r -> do + (reg', v) <- pop memory reg + int program memory $ reg' { gp = DM.insert r v (gp reg')} + Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory + Roll 0 _ -> int program memory reg + Roll 1 _ -> int program memory reg + Roll _ 0 -> int program memory reg + Roll depth num -> do + (reg', vs) <- popn memory depth reg + foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory + where + roll 0 acc vs = vs ++ reverse acc + roll n acc [] = roll n [] $ reverse acc + roll n acc (v:vs) = roll (n-1) (v:acc) vs + Pop n -> popn memory n reg >>= int program memory . fst + Push v -> push memory v reg >>= int program memory + Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory + Add -> bop (+) memory reg >>= int program memory + Sub -> bop (-) memory reg >>= int program memory + Mul -> bop (*) memory reg >>= int program memory + Div -> bop div memory reg >>= int program memory + Neg -> uop negate memory reg >>= int program memory + Pow -> bop (^) memory reg >>= int program memory + And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory + Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory + Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory + Eq -> bop ((b2i .) . (==)) memory reg >>= int program memory + Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory + Le -> bop ((b2i .) . (<)) memory reg >>= int program memory + Ge -> bop ((b2i .) . (>)) memory reg >>= int program memory + Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory + Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory + Lbl _ -> int program memory reg + Bra l -> branch l program reg >>= int program memory + Brf l -> do + (reg', v) <- pop memory reg + reg'' <- if i2b v then pure reg' else branch l program reg' + int program memory reg'' + Sth n -> + popn memory n reg + >>= uncurry (foldM $ flip $ pushh memory) + >>= push memory (hp reg + n - 1) + >>= int program memory + Ldh n -> pop memory reg >>= \(reg', hptr)->loadh memory (hptr - n - 1) reg' + >>= int program memory + Jsr i -> push memory (pc reg) reg + >>= push memory (mp reg) + >>= branch i program + >>= \r->int program memory (r { mp = sp r}) + Ret n -> do + (reg1, rval) <- pop memory reg + (reg2, omp) <- pop memory reg1 + (reg3, ra) <- pop memory reg2 + (reg4, _) <- popn memory n reg3 + reg5 <- push memory rval reg4 + int program memory $ reg5 { pc=ra, mp=omp } + Arg n -> do + v <- readArray memory (mp reg + 3 + n) + push memory v reg >>= int program memory + Halt -> pure memory + + branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers + branch label program reg = case pc reg of + -1 -> getBounds program >>= \(_, m)->branch label program $ reg { pc = m - 1} + _ -> readArray program (pc reg) >>= \case + Lbl l | label == l -> pure $ reg + _ -> branch label program $ reg { pc = pc reg - 1 } + +b2i :: Bool -> Int +b2i True = 1 +b2i False = 0 + +i2b :: Int -> Bool +i2b 0 = False +i2b _ = True diff --git a/datatype/Language.hs b/datatype/Language.hs new file mode 100644 index 0000000..64c5ea8 --- /dev/null +++ b/datatype/Language.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module Language where + +import Serialise + +newtype Main a = Main {unmain :: a} +data In a b = a :- b +infix 1 :- + +class Expression v where + lit :: (Serialise a, Show a) => a -> v a + (+.) :: Num a => v a -> v a -> v a + (-.) :: Num a => v a -> v a -> v a + (/.) :: Fractional a => v a -> v a -> v a + (*.) :: Num a => v a -> v a -> v a + (^.) :: Num a => v a -> v a -> v a + neg :: Num a => v a -> v a + (&.) :: v Bool -> v Bool -> v Bool + (|.) :: v Bool -> v Bool -> v Bool + not :: v Bool -> v Bool + (==.) :: Eq a => v a -> v a -> v Bool + (/=.) :: Eq a => v a -> v a -> v Bool + (<.) :: Ord a => v a -> v a -> v Bool + (>.) :: Ord a => v a -> v a -> v Bool + (<=.) :: Ord a => v a -> v a -> v Bool + (>=.) :: Ord a => v a -> v a -> v Bool + if' :: v Bool -> v a -> v a -> v a + +class Function a v where + fun :: ( (a -> v s) -> In (a -> v s) (Main (v u)) ) -> Main (v u) + +infixr 2 |. +infixr 3 &. +infix 4 ==., /=., <., >., <=., >=. +infixl 6 +., -. +infixl 7 *., /. +infixl 8 ^. diff --git a/datatype/Main.hs b/datatype/Main.hs new file mode 100644 index 0000000..3b8c1f4 --- /dev/null +++ b/datatype/Main.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Language + +import Compiler +import Printer + +import Tuple + +main :: IO () +main +-- = putStrLn (runPrint e0) +-- >> putStrLn (runPrint e1) +-- >> putStrLn (runPrint e2) +-- >> putStrLn (runPrint e3) +-- >> putStrLn (show $ runCompiler e0) +-- = putStrLn (show $ interpret 10 <$> runCompiler e0) +-- = putStrLn (show $ interpret 10 <$> runCompiler e1'') + = putStrLn (show $ interpret 10 <$> runCompiler (e1)) + >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef0' e1)) + >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' e1)) + >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' $ second' e3)) + >> putStrLn (runPrint $ lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil)) + >> putStrLn (show $ interpret 20 <$> runCompiler (lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil))) + >> putStrLn (runPrint $ unmain $ f0) + >> putStrLn (show $ runCompiler (unmain f0)) + >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f0)) + >> putStrLn (show $ runCompiler (unmain f1)) + >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f1)) + >> putStrLn (show $ runCompiler (unmain f2)) + >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f2)) + >> putStrLn (show $ runCompiler (unmain f3)) + >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f3)) +-- >> putStrLn (show $ interpret <$> runCompiler e1) +-- >> putStrLn (show $ interpret <$> runCompiler e1') +-- >> putStrLn (show $ interpret <$> runCompiler e1'') + +e0 :: Expression v => v Int +e0 = lit 2 ^. lit 8 + +e1 :: (Expression v, Tuple' v) => v (Tuple Char Int) +e1 = tuple (lit 'c') (lit 42) + +e1' :: (Expression v, Tuple' v) => v Char +e1' = tuplef0' e1 + +e1'' :: (Expression v, Tuple' v) => v Int +e1'' = tuplef1' e1 + +e2 :: (Expression v, TupleR' v) => v (TupleR Char Bool) +e2 = tupler (lit 'c') (lit True) + +e3 :: (Expression v, Tuple' v, TupleR' v) => v (TupleR Char (Tuple Int Bool)) +e3 = tupler (lit 'c') (tuple (lit 42) (lit True)) + +f0 :: (Expression v, Function () v) => Main (v Int) +f0 + = fun ( \c42->(\()->lit 42) + :- Main {unmain=c42 () +. lit 38} + ) + +f1 :: (Expression v, Function (v Int) v, Function () v) => Main (v Int) +f1 + = fun ( \c42->(\()->lit 42) + :- fun ( \inc->(\i->i +. lit 1) + :- Main {unmain=c42 () +. inc (lit 41)} + )) + +f2 :: (Expression v, Function (v Int, v Int) v) => Main (v Int) +f2 + = fun ( \sub->(\(x, y)->x -. y) + :- Main {unmain=sub (lit 2, lit 8)} + ) + +f3 :: (Expression v, Tuple' v, Function (v Int) v) => Main (v (Tuple Int Int)) +f3 + = fun ( \idfun->(\x->x) + :- Main {unmain=tuple (idfun (lit 42)) (idfun (lit 4)) } + ) + +f4 :: (Expression v, Function (v Int) v) => Main (v Int) +f4 + = fun ( \fac->(\x->x) + :- Main {unmain=tuple (idfun (lit 42)) (idfun (lit 4)) } + ) diff --git a/datatype/MkCons.hs b/datatype/MkCons.hs new file mode 100644 index 0000000..57b14c6 --- /dev/null +++ b/datatype/MkCons.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE TemplateHaskell #-} +module MkCons where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH +import Data.Char +import Control.Monad + +className :: Name -> Name +className = mkName . (++"'") . stringName +constructorName :: Name -> Name +constructorName = mkName . map toLower . stringName +selectorName :: Name -> Name +selectorName = mkName . map toLower . (++"'") . stringName +stringName :: Name -> String +stringName (Name occ _) = occString occ + +numberedArgs :: [a] -> [String] +numberedArgs = zipWith (\i _->"f" ++ show i) [0 :: Int ..] + +mkConsClass :: Name -> DecsQ +mkConsClass typename = reify typename >>= \info->case info of + TyConI dec + -> case dec of + DataD _ _ tyvars _ constructors _ + -> sequence + [ mkDerivation tyvars + , mkConstructorClasses tyvars constructors + , mkPrinterInstances tyvars constructors + , mkCompilerInstances tyvars constructors + ] + _ + -> fail "mkConsClass only supports data types" + _ + -> fail "mkConsClass only supports types" + where + mkDerivation :: [TyVarBndr] -> DecQ + mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $ + InstanceD Nothing + [ConT (mkName "Serialise") `AppT` t | t <- names] + (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names) + [] + + mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ + mkConstructorClasses tyvars constructors = do + cclasses <- mapM mkConstructorClassMember constructors + sclasses <- concat <$> mapM mkSelectorClassMember constructors + pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses) + where + view = mkName "m" + + mkConstructorClassMember :: Con -> DecQ + mkConstructorClassMember (NormalC consname fs) + = mkConstructorClassMemberForName consname [t | (_, t)<-fs] + mkConstructorClassMember (RecC consname fs) + = mkConstructorClassMemberForName consname [t | (_, _, t)<-fs] + mkConstructorClassMember t + = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkConstructorClassMemberForName :: Name -> [Type] -> DecQ + mkConstructorClassMemberForName consname fs + = pure $ SigD (constructorName consname) + $ foldr (AppT . AppT ArrowT) resultT + $ map (AppT $ VarT view) fs + + mkSelectorClassMember :: Con -> DecsQ + mkSelectorClassMember (NormalC _ fs) + = mapM (uncurry mkSelectorClassMemberForField) + $ zipWith (\(_, t) i->(mkName $ map toLower (stringName typename) ++ "f" ++ show i, t)) fs [0 :: Int ..] + mkSelectorClassMember (RecC _ fs) + = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs] + mkSelectorClassMember t + = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkSelectorClassMemberForField :: Name -> Type -> DecQ + mkSelectorClassMemberForField n t = pure + $ SigD (className n) + $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars] + $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t) + + resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars) + + mkPrinterInstances :: [TyVarBndr] -> [Con] -> DecQ + mkPrinterInstances _ constructors + = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat + <$> mapM mkPrinterInstance constructors + where + mkPrinterInstance :: Con -> DecsQ + mkPrinterInstance (NormalC name fs) + | null fs = pure [FunD (constructorName name) + [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName name)) [] ]] + | otherwise = + let args = map mkName $ numberedArgs fs + in (:) <$> pure (FunD (constructorName name) + [Clause + (map VarP args) + (NormalB $ + (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName name)) + (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args) + ) + ) + [] + ]) + <*> mapM mkPrinterSelector + (zipWith (\_ i->map toLower (stringName typename) ++ "f" ++ show i) fs [0 :: Int ..]) + mkPrinterInstance (RecC name fs) + = let args = map mkName $ numberedArgs fs + in (:) <$> pure (FunD (constructorName name) + [Clause + (map VarP args) + (NormalB $ + (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename)) + (foldl1 (\x y->x `pc` pl ", " `pc` y) + $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args fs) + ) + ) + [] + ]) + <*> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs] + mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkPrinterSelector :: String -> Q Dec + mkPrinterSelector n' = do + body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|] + pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []] + + mkCompilerInstances :: [TyVarBndr] -> [Con] -> DecQ + mkCompilerInstances _ constructors + = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat + <$> mapM (uncurry mkCompilerInstance) (zip constructors [0..]) + where + mkCompilerInstance :: Con -> Int -> DecsQ + mkCompilerInstance (NormalC name fs) consnum = (:) + <$> mkCompilerInstanceForName name consnum (numberedArgs fs) + <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName typename) ++ f | f<-numberedArgs fs]) + mkCompilerInstance (RecC name fs) consnum = (:) + <$> mkCompilerInstanceForName name consnum [occString occ | (Name occ _, _, _) <- fs] + <*> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs]) + mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ + mkCompilerInstanceForName name consnum fs = + let args = map mkName $ numberedArgs fs + in do + body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |] + pure $ FunD (constructorName name) + [Clause (map VarP args) (NormalB body) [] ] + where + mkBody :: [Exp] -> Q Exp + mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name + mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as + + mkCompilerSelector :: Int -> String -> DecQ + mkCompilerSelector idx n' = do + body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |] + pure $ FunD (selectorName $ mkName n') + [Clause [] (NormalB body) [] ] + +instrE :: Exp -> Exp +instrE e = VarE (mkName "instr") `AppE` ListE [e] + +ifx :: String -> Exp -> Exp -> Exp +ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b) + +pc :: Exp -> Exp -> Exp +pc l r = VarE (mkName ">>>") `AppE` l `AppE` r + +pl :: String -> Exp +pl s = VarE (mkName "printLit") `AppE` LitE (StringL s) + +getNameTyVarBndr :: TyVarBndr -> Name +getNameTyVarBndr (PlainTV name) = name +getNameTyVarBndr (KindedTV name _) = name diff --git a/datatype/Printer.hs b/datatype/Printer.hs new file mode 100644 index 0000000..8668b91 --- /dev/null +++ b/datatype/Printer.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +module Printer where + +import Control.Monad.RWS +import Language + +newtype Printer a = P { runPrinter :: RWS Ctx [String] PS a } + deriving + ( Functor + , Applicative + , Monad + , MonadWriter [String] + , MonadState PS + , MonadReader Ctx + ) +data PS = PS {fresh :: [Int]} +data Ctx = CtxNo | CtxNullary | CtxNonfix | CtxInfix {assoc :: CtxAssoc, prio :: Int, branch :: CtxAssoc} + deriving Eq + +leftctx,rightctx,nonectx :: Int -> Ctx +leftctx p = CtxInfix {assoc=CtxLeft, prio=p, branch=CtxNone} +rightctx p = CtxInfix {assoc=CtxRight, prio=p, branch=CtxNone} +nonectx p = CtxInfix {assoc=CtxNone, prio=p, branch=CtxNone} + +setBranch :: Ctx -> CtxAssoc -> Ctx +setBranch ctx@(CtxInfix _ _ _) b = ctx { branch=b } +setBranch ctx _ = ctx + +data CtxAssoc = CtxLeft | CtxRight | CtxNone + deriving Eq + +runPrint :: Printer a -> String +runPrint p = concat $ snd $ execRWS (runPrinter p) CtxNo $ PS {fresh=[0..]} + +--printString :: Show a => a -> Printer a +--printString = pure . shows +-- +printLit :: String -> Printer a +printLit a = tell [a] *> pure undefined +-- +--printcc :: Printer a -> Printer b -> Printer c +--printcc a b = a >>= bkkkkkkkkkkP $ \ps->runPrinter a ps . runPrinter b ps +-- +--printcs :: Printer a -> Printer b -> Printer c +--printcs a b = P $ \ps->runPrinter a ps . (' ':) . runPrinter b ps + +paren :: Printer a -> Printer a +paren p = printLit "(" *> p <* printLit ")" + +accol :: Printer a -> Printer a +accol p = printLit "{" *> p <* printLit "}" + +paren' :: Ctx -> Printer a -> Printer a +paren' this p = ask >>= \outer->if needsParen this outer then paren p else p + +needsParen :: Ctx -> Ctx -> Bool +needsParen CtxNo _ = False +needsParen CtxNullary _ = False +needsParen CtxNonfix CtxNo = False +needsParen CtxNonfix CtxNonfix = True +needsParen CtxNonfix (CtxInfix _ _ _) = False +needsParen (CtxInfix _ _ _) CtxNo = False +needsParen (CtxInfix _ _ _) CtxNonfix = True +needsParen (CtxInfix thisassoc thisprio _) (CtxInfix outerassoc outerprio outerbranch) + | outerprio > thisprio = True + | outerprio == thisprio + = thisassoc /= outerassoc || thisassoc /= outerbranch + | otherwise = False +needsParen _ CtxNullary = error "shouldn't occur" + +instance Expression Printer where + lit = printLit . show + (+.) = printBinOp (leftctx 6) "+" + (-.) = printBinOp (leftctx 6) "-" + (*.) = printBinOp (leftctx 7) "*" + (/.) = printBinOp (leftctx 7) "/" + (^.) = printBinOp (rightctx 8) "^" + neg = printUnOp (nonectx 7) "!" + (&.) = printBinOp (rightctx 3) "&" + (|.) = printBinOp (rightctx 2) "|" + not = printUnOp (nonectx 7) "!" + (==.) = printBinOp (nonectx 4) "==" + (/=.) = printBinOp (nonectx 4) "/=" + (<.) = printBinOp (nonectx 4) "<" + (>.) = printBinOp (nonectx 4) ">" + (<=.) = printBinOp (nonectx 4) "<" + (>=.) = printBinOp (nonectx 4) ">" + if' p t e = printLit "if" >> p >> printLit "then" >> t >> printLit "else" >> e + +freshLabel :: MonadState PS m => String -> m String +freshLabel prefix = gets fresh >>= \(f:fs)->modify (\s->s {fresh=fs}) >> pure (prefix ++ show f) + +instance Function () Printer where + fun def = Main $ freshLabel "f" >>= \f-> + let g :- m = def (\()->printLit (f ++ " ()")) + in printLit ("let " ++ f ++ " () = ") >> g () >> printLit "\n in " >> unmain m +instance Function (Printer a) Printer where + fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a-> + let g :- m = def (\arg->printLit (f ++ " ") >>> arg) + in printLit (concat ["let ", f, " ", a, " = "]) >> g (printLit a) >> printLit " in\n" >> unmain m +instance Function (Printer a, Printer b) Printer where + fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2-> + let g :- m = def (\(arg1, arg2)->printLit (f ++ " ") >> arg1 >> printLit " " >>> arg2) + in printLit (concat ["let ", f, " ", a1, " ", a2, " = "]) >> g (printLit a1, printLit a2) >> printLit " in\n" >> unmain m +instance Function (Printer a, Printer b, Printer c) Printer where + fun def = Main $ + freshLabel "f" >>= \f-> + freshLabel "a" >>= \a1-> + freshLabel "a" >>= \a2-> + freshLabel "a" >>= \a3-> + let g :- m = def (\(arg1, arg2, arg3)->printLit (f ++ " ") >> arg1 >> printLit " " >> arg2 >> printLit " " >>> arg3) + in printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "]) >> g (printLit a1, printLit a2, printLit a3) >> printLit " in\n" >> unmain m + +(>>>) :: Printer a1 -> Printer a2 -> Printer a3 +l >>> r = l >> r >> pure undefined + +printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3 +printBinOp thisctx op l r = paren' thisctx $ + local (\_->setBranch thisctx CtxLeft) l + >> printLit op + >> local (\_->setBranch thisctx CtxRight) r + >> pure undefined + +printUnOp :: Ctx -> String -> Printer a -> Printer a +printUnOp thisctx op l = paren' thisctx $ + printLit op + >> local (\_->setBranch thisctx CtxRight) l + +printCons :: String -> Printer a -> Printer a +printCons = printUnOp CtxNonfix . (++" ") + +printRec :: String -> Printer a -> Printer a +printRec op l = printUnOp CtxNo (op++" ") (accol l) diff --git a/datatype/Serialise.hs b/datatype/Serialise.hs new file mode 100644 index 0000000..524cdb3 --- /dev/null +++ b/datatype/Serialise.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} +module Serialise where + +import Data.Char + +import GHC.Generics + +class Serialise a where + serialise :: a -> [Int] -> [Int] + default serialise :: (Generic a, GSerialise (Rep a)) => a -> [Int] -> [Int] + serialise = gserialise . from + +class GSerialise f where + gserialise :: f a -> [Int] -> [Int] + +--Void +instance GSerialise V1 where + gserialise _ = id +--Unit +instance GSerialise U1 where + gserialise _ = id +--Pair +instance (GSerialise a, GSerialise b) => GSerialise (a :*: b) where + gserialise (l :*: r) = gserialise l . gserialise r +--Constants, additional parameters and recursion of kind * +instance Serialise a => GSerialise (K1 i a) where + gserialise (K1 a) = serialise a +--Either not supported because we don't support sumtypes in our stack machine +instance (GSerialise a, GSerialise b) => GSerialise (a :+: b) where + gserialise (L1 l) = (0:) . gserialise l + gserialise (R1 r) = (1:) . gserialise r +--Datatype, Constructor or Selector +instance (GSerialise a) => GSerialise (M1 i c a) where + gserialise (M1 l) = gserialise l + +instance Serialise Int where + serialise i = (i:) +instance Serialise Bool where + serialise b = ((if b then 1 else 0):) +instance Serialise Char where + serialise c = (ord c:) diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs new file mode 100644 index 0000000..6c6a3d7 --- /dev/null +++ b/datatype/Tuple.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Tuple where + +import GHC.Generics + +import Printer +import Compiler +import Serialise +import MkCons + +data Tuple a b = Tuple a b + deriving Generic +$(mkConsClass ''Tuple) + +data Tuple3 a c = Tuple3 a Int c + deriving Generic +$(mkConsClass ''Tuple3) + +data TupleR a b = TupleR {first :: a, second :: b} + deriving Generic +$(mkConsClass ''TupleR) + +data List a = Nil | Cons a (List a) + deriving Generic +$(mkConsClass ''List) diff --git a/gopt.icl b/gopt.icl new file mode 100644 index 0000000..09089ab --- /dev/null +++ b/gopt.icl @@ -0,0 +1,166 @@ +module gopt + +import StdEnv, StdGeneric + +import Data.List +import Data.Error +import Data.Func +import Data.Functor +import Data.Tuple +import Data.Maybe +import Control.Applicative +import Control.Monad => qualified join +import System.CommandLine +import Text + +:: Opt a + = BinaryFlag (a -> a) (a -> a) + | Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))] + | Positionals [(String, String a -> (MaybeError [String] a))] + | SubParsers [(String, Opt a)] + +class bifmap m :: (a -> b) (b -> a) (m b) -> m a +instance bifmap Opt +where + bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr) + bifmap fr to (Flags fs) = Flags $ map (appSnd $ (\f s->fm (appFst to) o f s o fr)) fs + bifmap fr to (Positionals fs) = Positionals $ map (appSnd $ fmap $ \f->fm to o f o fr) fs + bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp + +fm f (Ok a) = Ok (f a) +fm f (Error e) = Error e + +combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t) +combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as) + +ar0 s f as = Ok o flip tuple as o f + +generic gopt a *! :: Opt a +//generic gopt a :: Opt a +gopt{|Bool|} = BinaryFlag (const True) (const False) +gopt{|Int|} = Positionals [("INT", \s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"]))] +gopt{|Char|} = Positionals [("CHAR", \s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"]))] +gopt{|String|} = Positionals [("STRING", \s _->Ok s)] +gopt{|RECORD|} f = bifmap (\(RECORD a)->a) (\x->RECORD x) f +gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) (\x->OBJECT x) f +gopt{|FIELD of {gfd_name}|} f = case f of + //Child is a boolean + BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)] + //Child is a basic value or a tuple + Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)] + //Child is another record, make the arguments ddstyle TODO + Flags x = mapF (Flags x) + //Child is a subparser + SubParsers ps = mapF (Flags [(gfd_name, pOpts (SubParsers ps))]) + x = abort "Subparsers not supported" +where + mapF :: ((m a) -> m (FIELD a)) | bifmap m + mapF = bifmap (\(FIELD a)->a) (\x->FIELD x) + + ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name] + ptoarg [(_, p):ps] [a:as] i = p a i >>= ptoarg ps as + ptoarg [] as i = Ok (i, as) +gopt{|PAIR|} l r = case (l, r) of + (Positionals pl, Positionals pr) + = Positionals + $ map (appSnd $ combine PFst appPFst) pl + ++ map (appSnd $ combine PSnd appPSnd) pr + (Flags fl, Flags fr) + = Flags + $ map (appSnd $ combine` PFst appPFst) fl + ++ map (appSnd $ combine` PSnd appPSnd) fr + (x, y) = abort $ "gopt{|PAIR|}: " +++ consPrint x +++ " " +++ consPrint y +where + appPFst f (PAIR x y) = PAIR (f x) y + appPSnd f (PAIR x y) = PAIR x (f y) + PFst (PAIR x y) = x + PSnd (PAIR x y) = y +gopt{|UNIT|} = Positionals [] +gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)] +gopt{|EITHER|} l r = case (l, r) of + (SubParsers sl, SubParsers sr) + = SubParsers + $ map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl + ++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr +gopt{|(,)|} l r = case (l, r) of + (Positionals pl, Positionals pr) + = Positionals + $ map (appSnd $ combine fst appFst) pl + ++ map (appSnd $ combine snd appSnd) pr +gopt{|(,,)|} f s t = case (f, s, t) of + (Positionals pf, Positionals ps, Positionals pt) + = Positionals + $ map (appSnd $ combine fst3 appFst3) pf + ++ map (appSnd $ combine snd3 appSnd3) ps + ++ map (appSnd $ combine thd3 appThd3) pt + +consPrint (Positionals x) = "Positionals" +consPrint (BinaryFlag x _) = "BinaryFlag" +consPrint (Flags x) = "Flags" +consPrint (SubParsers x) = "SubParsers" + +parseOpts :: [String] a -> MaybeError [String] (a, [String]) | gopt{|*|} a +parseOpts args a = pOpts gopt{|*|} args a + +pOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String]) +pOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"] +pOpts (Positionals [p:ps]) [arg:args] a = (snd p) arg a >>= pOpts (Positionals ps) args +pOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of + Nothing = Error ["Unrecognized subcommand"] + Just (l, p) = pOpts p args a +pOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)] +pOpts (Flags fs) [arg:args] a + | not (startsWith "--" arg) = Ok (a, [arg:args]) + = case find (\(l,p)->"--" +++ l == arg) fs of + Nothing = Error ["Unrecognized option: " +++ arg] + Just (l, p) = p args a >>= \(a, args)->pOpts (Flags fs) args a +pOpts (BinaryFlag yes no) args a + = pOpts (Positionals [("BOOL", \s v-> + if (s == "True") + (Ok (yes v)) + (if (s == "False") + (Ok (no v)) + (Error ["Not True or False"]) + ) + )]) args a +pOpts t args a = Ok (a, args) + +pHelp :: (Opt a) -> [String] +pHelp (Positionals []) = [] +pHelp (Positionals [(i, _):ps]) = [i, " ":pHelp $ Positionals ps] +pHelp (SubParsers ps) = + flatten + [[n, " ":pHelp opt] ++ ["\n"] + \\(n, opt)<-ps + ] +pHelp (Flags fs) = + ["Flags\n" + : + flatten + [["--",f, "\n"] + \\(f, p)<-fs + ] + ] + +:: T = + { field :: (Int,Int) + , field2 :: String + , t2 :: C + } +:: T2 = {f :: Int, f2 :: Bool} +:: C = A Int | B | C Bool + +:: ADT + = ADT1 + | ADT2 Int String + +derive binumap Opt, [], (,), MaybeError +derive gopt T, T2, ADT, C + +Start w +# ([argv0:args], w) = getCommandLine w +//= pHelp opt += parseOpts args {field=(0, 0),field2="",t2=A 4} + +opt :: Opt T +opt = gopt{|*|} diff --git a/slave/cloudiTasks/cloudiTasks.icl b/slave/cloudiTasks/cloudiTasks.icl deleted file mode 100644 index 09d6fde..0000000 --- a/slave/cloudiTasks/cloudiTasks.icl +++ /dev/null @@ -1,149 +0,0 @@ -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" - } diff --git a/test.icl b/test.icl index ed64bbc..0093bb4 100644 --- a/test.icl +++ b/test.icl @@ -1,19 +1,18 @@ module test +//import Data.Func import iTasks -import Data.Func -Start w = doTasks t w +Start w = doTasks (onStartup par) w where - t = parallel - [(Embedded, \stl->tune (Title "New Task") $ addTask stl - >>* [OnAction (Action "Close") (always (return ()))]) - ] [] <<@ ArrangeWithTabs True - - addTask :: (SharedTaskList ()) -> Task () - addTask stl - = (enterInformation [] <<@ Label "Title") -&&- updateInformation [] "text" - >>! \(title, text)->appendTask Embedded - (\_->tune (Title title) $ viewInformation [] text @? const NoValue) - stl - >-| addTask stl + par :: Task [(Int, TaskValue ())] + par = parallel [] [] +//Start w = doTasks (onStartup $ m >>- traceValue) w +// +//m = parallel +// [(Embedded, \stl->return 42)] +// [] +// [OnValue $ \tv->case tv of +// NoValue = ?None +// _ = ?None +// ] -- 2.20.1