afp/a1[0-9]/a1[0-9]
struct
+
+*.hi
+*.dyn_hi
+*.dyn_o
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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 ^.
--- /dev/null
+{-# 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)) }
+ )
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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:)
--- /dev/null
+{-# 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)
--- /dev/null
+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{|*|}
+++ /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"
- }
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
+// ]
repositories / clean-tests.git / commitdiff