definition module Data.GenType
import StdGeneric
+from StdOverloaded import class ==, class toString
:: Box b a =: Box b
derive bimap Box
| GTyArrow GType GType
| GTyArray ArrayType GType
| GTyUList UListType GType
+ | GTyUMaybe GType
| GTyUnit
| GTyEither GType GType
| GTyPair GType GType
| TyArrow Type Type
| TyArray ArrayType Type
| TyUList UListType Type
+ | TyUMaybe Type
| TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
| TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
| TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
*/
generic gType a :: Box GType a
derive gType UNIT, EITHER, PAIR, CONS of gcd, FIELD of gfd, OBJECT of gtd, RECORD of grd
-derive gType Int, Bool, Real, Char, World, Dynamic, File
+derive gType Int, Bool, Real, Char, World, File
derive gType (->)
-derive gType /*?#,*/ ?, ?^
+derive gType ?#, ?, ?^
derive gType [], [! ], [ !], [!!], [#], [#!], {}, {!}, {#}, {32#}
derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
import StdEnv, StdGeneric
import Control.Applicative
-import Control.Monad => qualified join
+import Control.Monad
import Control.Monad.State
import Data.GenEq
import Control.Monad.Writer
import Data.Generics
import Data.List
import Data.Maybe
-import Text
+from Text import class Text(concat), instance Text String
derive bimap Box
derive gEq BasicType, UListType, ArrayType, GenType
gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
+gTypeEqShallow i (GTyUMaybe a1) (GTyUMaybe a2) = gTypeEqShallow (dec i) a1 a2
gTypeEqShallow _ GTyUnit GTyUnit = True
gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
(==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
(==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
(==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
+ (==) (TyUMaybe a1) (TyUMaybe a2) = a1 == a2
(==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
= i1.gtd_name == i2.gtd_name && a1 == a2
(==) (TyObject i1 a1) (TyObject i2 a2)
print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
+ print (GTyUMaybe a) c = ["?#":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 (TyArrow l r) c = print l [" -> ":print r c]
print (TyArray s a) c = ["{":print s ["}":print a c]]
print (TyUList s a) c = ["[#":print s ["]":print a c]]
+ print (TyUMaybe a) c = ["?#":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
gTypeToType (GTyArrow l r) = TyArrow (gTypeToType l) (gTypeToType r)
gTypeToType (GTyArray s a) = TyArray s (gTypeToType a)
gTypeToType (GTyUList s a) = TyUList s (gTypeToType a)
+gTypeToType (GTyUMaybe a) = TyUMaybe (gTypeToType a)
gTypeToType (GTyRecord i t) = TyRecord i (gtrec t [])
where
gtrec :: GType [(GenericFieldDescriptor, Type)] -> [(GenericFieldDescriptor, Type)]
refs (GTyArrow l r) c = refs l $ refs r c
refs (GTyArray _ a) c = refs a c
refs (GTyUList _ a) c = refs a c
+ refs (GTyUMaybe a) c = refs a c
refs (GTyBasic _) c = c
refs a=:(GTyRef _) c = [a:c]
mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
mkf (GTyArray s a) = GTyArray s <$> mkf a
mkf (GTyUList s a) = GTyUList s <$> mkf a
+ mkf (GTyUMaybe a) = GTyUMaybe <$> mkf a
mkf a=:(GTyBasic _) = addIfNotThere a
mkf a=:(GTyRef _) = pure a
typeName (TyRef a) = a
typeName (TyArrow l r) = typeName l +++ "->" +++ typeName r
typeName (TyArray s a) = "{" +++ toString s +++ typeName a +++ "}"
-typeName (TyUList s a) = "{" +++ toString s +++ typeName a +++ "}"
+typeName (TyUList s a) = "[#" +++ toString s +++ typeName a +++ "]"
+typeName (TyUMaybe a) = "?" +++ typeName a
typeName (TyNewType i _ _) = i.gtd_name
typeName (TyObject i _) = i.gtd_name
typeName (TyRecord i _) = i.grd_name
replaceBuiltins (TyArrow l r) = TyArrow (replaceBuiltins l) (replaceBuiltins r)
replaceBuiltins (TyArray s a) = TyArray s (replaceBuiltins a)
replaceBuiltins (TyUList s a) = TyUList s (replaceBuiltins a)
+ replaceBuiltins (TyUMaybe a) = TyUMaybe (replaceBuiltins a)
replaceBuiltins (TyNewType i j a) = TyNewType (replaceBuiltins i) (replaceBuiltins j) (replaceBuiltins a)
replaceBuiltins (TyObject i cs) = TyObject (replaceBuiltins i) [(replaceBuiltins i, map replaceBuiltins fs)\\(i, fs)<-cs]
replaceBuiltins (TyRecord j fs) = TyRecord (replaceBuiltins j) [(replaceBuiltins i, replaceBuiltins a)\\(i, a)<-fs]
replaceBuiltins (GTyArrow l r) = GTyArrow (replaceBuiltins l) (replaceBuiltins r)
replaceBuiltins (GTyArray s a) = GTyArray s (replaceBuiltins a)
replaceBuiltins (GTyUList s a) = GTyUList s (replaceBuiltins a)
+ replaceBuiltins (GTyUMaybe a) = GTyUMaybe (replaceBuiltins a)
replaceBuiltins (GTyObject i a) = GTyObject (replaceBuiltins i) (replaceBuiltins a)
replaceBuiltins (GTyRecord i a) = GTyRecord (replaceBuiltins i) (replaceBuiltins a)
replaceBuiltins (GTyCons i a) = GTyCons (replaceBuiltins i) (replaceBuiltins a)
gType{|Real|} = box $ GTyBasic BTReal
gType{|Char|} = box $ GTyBasic BTChar
gType{|World|} = box $ GTyBasic BTWorld
-gType{|Dynamic|} = box $ GTyBasic BTDynamic
+//gType{|Dynamic|} = box $ GTyBasic BTDynamic
gType{|File|} = box $ GTyBasic BTFile
gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
gType{|{!}|} a = box $ GTyArray AStrict $ unBox a
gType{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
gType{|{32#}|} a = box $ GTyArray APacked $ unBox a
+gType{|(?#)|} a = box $ GTyUMaybe $ unBox a
derive gType ?, ?^
derive gType [], [! ], [ !], [!!]
derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
/**
* generate parsers for the types grouped by strongly connected components
*/
-parsers :: [[Type]] -> Either String [String]
+parsers :: [[Type]] -> Either String ([String], [String])
implementation module Data.GenType.CParser
import Control.Applicative
-import Control.Monad => qualified join
+import Control.Monad
import Control.Monad.Fail
import Control.Monad.Reader
import Control.Monad.State
import Data.Maybe
import Data.Tuple
import StdEnv
-import Text
+import qualified Text
+from Text import class Text(concat), instance Text String
import Data.GenType
import Data.GenType.CType
indent c = liftT ask >>= \i->tell [createArray i '\t':c]
-includes = "#include <stdint.h>\n#include <stdbool.h>\n"
-
parsefun t = "parse_" +++ safe (typeName t)
(<.>) infixr 6
result r op s = indent [r, " ", op, " ", s, ";\n"]
assign r s = result r "=" s
+parsename s = "parse_" +++ safe s
+tail = ["\treturn r;\n}\n"]
+parsenameimp t def = def t [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]
/**
* Generate a single parser for a type.
* This does not terminate for a recursive type
*/
flatParser :: Type -> Either String ([String], [String])
-flatParser t = tuple header <$> runReaderT (execWriterT (tell head >>| fpd t True "r" >>| tell tail)) 1
+flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
where
- header = [includes:parsedef [";\n"]]
- parsedef c = [prefix t, safe (typeName t), parsefun t, "(uint8_t (*get)(void))":c]
- head = [includes:parsedef [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]]
- tail = ["\treturn r;\n}\n"]
- parsename s = "parse_" +++ safe s
+ parsedef c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void))":c]
fpd :: Type Bool String -> FPMonad
fpd (TyRef s) tl r = assign r (parsename s)
= mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
//Complex adt
fpd (TyObject ti fs) tl r
- = assign (r +++ ".cons") ("(" +++ consName ti +++ ") get()")
+ = assign (r <.> "cons") ("(" +++ consName ti +++ ") get()")
>>| indent ["switch (", r <.> "cons){\n"]
- >>| mapM_ (mapWriterT (local inc) o fmtCons) fs
+ >>| mapM_ fmtCons fs
>>| indent ["}\n"]
where
fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad
fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"]
>>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts]
- >>| indent ["break;\n"]
+ >>| mapWriterT (local inc) (indent ["break;\n"])
where
cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
*/
:: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
:: TPState :== 'Data.Map'.Map String (String, Bool)
-parsers :: [[Type]] -> Either String [String]
-parsers ts = evalStateT (execWriterT (mapM_ parsergroup ts)) 'Data.Map'.newMap
+parsers :: [[Type]] -> Either String ([String], [String])
+parsers ts = tuple ([""]) <$> evalStateT (execWriterT (mapM_ parsergroup ts >>| tell tail)) 'Data.Map'.newMap
where
+ parsedef t c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void)",pd t, ")":c]
+ where
+ pd (TyUList _ _) = ", void *parse_0(uint8_t (*)(void))"
+ pd (TyUMaybe _) = ", void *parse_0(uint8_t (*)(void))"
+ pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)(void))"\\i<-[0..gtd.gtd_arity-1]]
+ pd (TyRecord grd _) = abort "not implemented yet\n"
+ pd (TyNewType _ _ _) = abort "not implemented yet\n"
+ pd _ = abort "not implemented yet\n"
+
parsergroup :: [Type] -> TPMonad
parsergroup ts
= liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
- >>| mapM_ (\t->parser t >>| tell ["\n"]) ts
+ >>| mapM_ (\t->tell (parsenameimp t parsedef) >>| parser t >>| tell ["\n"]) ts
printTypeName :: String -> TPMonad
printTypeName tname
parser :: Type -> TPMonad
parser t=:(TyRef s) = tell [parsefun t]
- parser (TyBasic t)
+ parser (TyBasic t)
= case t of
BTInt = tell ["\tr = (int64_t)get()<<54;\n"
, "\tr += (int64_t)get()<<48;\n"
= fmtFields 1 ci.gcd_type ["r.f" +++ toString i\\i<-indexList ts]
//Complex adt
parser (TyObject ti fs)
- = tell ["\tr.cons = (" +++ consName ti +++ ") get();\n"]
+ = tell ["\tr.cons = (", consName ti, ") get();\n"]
>>| tell ["\tswitch(r.cons) {\n"]
>>| mapM_ fmtCons fs
>>| tell ["\t}\n"]
implementation module Data.GenType.CType
import Control.Applicative
-import Control.Monad => qualified join
+import Control.Monad
import Control.Monad.Fail
import Control.Monad.Reader
import Control.Monad.State
import Data.Maybe
import Data.Tuple
import StdEnv
-import Text
+import qualified Text
+from Text import class Text(concat), instance Text String
instance MonadFail (Either String) where fail s = Left s
ftd (TyObject ti fs) tl
= indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
>>| iindent (indent []) >>| enum ti fs >>| tell [" cons;\n"]
- >>| indent [] >>| enum ti fs >>| tell [" cons;\n"]
- >>| indent ["struct {\n"]
+ >>| iindent (indent ["struct {\n"])
>>| mapM_ (iindent o iindent o fmtCons) fs
>>| iindent (indent ["} data;\n"])
>>| indent ["}", if tl ";" ""]
>>| indent ["} ", safe ci.gcd_name, ";\n"]
ftd t tl = fail $ "cannot flatTypedef: " +++ toString t
-
enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad
enum ti fs = liftT (gets (lookup ti.gtd_name)) >>= \e->case e of
- ?None = liftT (modify \s->[(ti.gtd_name, [consName ti, " {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
+ ?None = liftT (modify \s->[(ti.gtd_name, [consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
?Just _ = tell [consName ti]
fmtField :: (String, Type) -> FTMonad
//Enumeration
typedef t=:(TyObject ti fs)
| and [t =: [] \\ (_, t)<-fs] = header t
- [consName ti, " {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
+ [consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
//Single constructor, single field (box)
typedef t=:(TyObject ti [(ci, [ty])]) = header t [] >>| tydef ti.gtd_name ci.gcd_type
//Single constructor
//Complex adt
typedef t=:(TyObject ti fs) = header t
["struct ", safe ti.gtd_name, " {\n"
- , "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
+ , "\t", consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
, "\tstruct {\n"]
>>| mapM_ fmtCons fs
>>| tell ["\t} data;\n};\n"]
fmtField x (GenTypeApp l r) = fmtField x l
fmtField x t=:(GenTypeArrow _ _)
= mapM (fmap (concat o snd) o listen o fmtField "") (collectArgs t [])
- >>= \[r:as]->tell [r, " (*",x,")(",join ", " as, ")"]
+ >>= \[r:as]->tell [r, " (*",x,")(",'Text'.join ", " as, ")"]
where
collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
collectArgs t c = [t:c]
--- /dev/null
+definition module Data.GenType.Serialize
+
+from Data.Either import :: Either
+from Data.GenType import :: Type
+
+/**
+ * Generate a single parser for a type.
+ * This does not terminate for a recursive type
+ */
+serialize :: Type -> Either String [Char]
import Data.Maybe
import Control.GenBimap
import Data.Either
+import System.FilePath
import Data.GenType
import Data.GenType.CType
import Data.GenType.CParser
+import Text
derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest
:: T a = T2 a Char
:: NT =: NT Int
:: SR = {f1 :: Int, f2 :: Bool, f3 :: Tr Either Bool, f4 :: Enum}
-:: R a = {f1 :: ? (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
+:: R a = {f1 :: ? (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Int,
f5 :: [([#Int], [#Int!], [!Int!], [!Int], [Int!])],
f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/
f7 :: {!Int}}
:: Odd a = Odd (Even a) | OddBlurp
:: Even a = Even (Odd a) | EvenBlurp
:: Enum = A | B | C
-Start =
- ( flatTypedef $ gTypeToType $ unBox t
- , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
- , flatParser $ gTypeToType $ unBox t
- , parsers $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
- )
+includes = "#include <stdint.h>\n#include <stdbool.h>\n"
+
+genFiles :: String (Box GType a) *World -> *World | gType{|*|} a
+genFiles bn t w
+ # tds = map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+ # (ok, h, w) = fopen (bn <.> "h") FWriteText w
+ | not ok = abort ("Couldn't open: " +++ bn <.> "h")
+ # (ok, c, w) = fopen (bn <.> "c") FWriteText w
+ | not ok = abort ("Couldn't open: " +++ bn <.> "c")
+ # h = h <<< "#ifndef " <<< toUpperCase bn <<< "_H\n"
+ <<< "#define " <<< toUpperCase bn <<< "_H\n"
+ <<< includes
+ # c = c <<< includes
+ <<< "#include \"" <<< (bn <.> "h") <<< "\"\n"
+ # h = case typedefs tds of
+ Left e = abort ("Couldn't generate typedef: " +++ e)
+ Right d = foldl (<<<) h d
+ # (h, c) = case parsers tds of
+ Left e = abort ("Couldn't generate parser: " +++ e)
+ Right (hd, cd) = (foldl (<<<) h hd, foldl (<<<) c cd)
+ # h = h <<< "\n#endif"
+ # (ok, w) = fclose h w
+ | not ok = abort ("Couldn't close: " +++ bn <.> "h")
+ # (ok, w) = fclose c w
+ | not ok = abort ("Couldn't close: " +++ bn <.> "c")
+ = w
+
+genFilesFlat :: String (Box GType a) *World -> *World | gType{|*|} a
+genFilesFlat bn t w
+ # ty = gTypeToType (unBox t)
+ # (ok, h, w) = fopen (bn <.> "h") FWriteText w
+ | not ok = abort ("Couldn't open: " +++ bn <.> "h")
+ # (ok, c, w) = fopen (bn <.> "c") FWriteText w
+ | not ok = abort ("Couldn't open: " +++ bn <.> "c")
+ # h = h <<< "#ifndef " <<< toUpperCase bn <<< "_H\n"
+ <<< "#define " <<< toUpperCase bn <<< "_H\n"
+ <<< includes
+ # c = c <<< includes
+ <<< "#include \"" <<< (bn <.> "h") <<< "\"\n"
+ # h = case flatTypedef ty of
+ Left e = abort ("Couldn't generate typedef: " +++ e)
+ Right d = foldl (<<<) h d
+ # (h, c) = case flatParser ty of
+ Left e = abort ("Couldn't generate parser: " +++ e)
+ Right (hd, cd) = (foldl (<<<) h hd, foldl (<<<) c cd)
+ # h = h <<< "\n#endif"
+ # (ok, w) = fclose h w
+ | not ok = abort ("Couldn't close: " +++ bn <.> "h")
+ # (ok, w) = fclose c w
+ | not ok = abort ("Couldn't close: " +++ bn <.> "c")
+ = w
+
+Start w = foldr ($) w
+ [ genFiles "maybeInt" maybeInt
+ , genFiles "eitherIntChar" eitherIntChar
+ , genFiles "eitherIntMaybeChar" eitherIntMaybeChar
+ ]
+// ( flatTypedef $ gTypeToType $ unBox t
+// , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+// , flatParser $ gTypeToType $ unBox t
+// , parsers $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+where
+ maybeInt :: Box GType (?Int)
+ maybeInt = gType{|*|}
+
+ eitherIntChar :: Box GType (Either Int Char)
+ eitherIntChar = gType{|*|}
+
+ eitherIntMaybeChar :: Box GType (Either Int (?Char))
+ eitherIntMaybeChar = gType{|*|}
//Start = typedefs //$ (\x->[[gTypeToType x]])
// $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
:: NRequest m = NRequest String (m ()) Dynamic
//* Read a share with one rewrite step
-class read v :: (v m p r w) p -> PViewT m (ReadResult m p r w) | TC r & Monad m
+class read v :: (v m p r w) p -> PViewT m (ReadResult m p r w) | Monad m
//* Write a share with one rewrite step
-class write v :: (v m p r w) p w -> PViewT m (WriteResult m p r w) | TC w & Monad m
+class write v :: (v m p r w) p w -> PViewT m (WriteResult m p r w) | Monad m
+//* Observe a share and get notified when it happens
+class observe v
+where
+ identity :: (v m p r w) [String] -> [String]
+ observe :: (v m p r w) p String (m ()) -> PViewT m () | Monad m & TC p
//* Result of a single read rewrite
:: ReadResult m p r w
| LensWriteConst (p w -> m (? ws))
//* Box type, to get rid of a possible complex constructor of combinators
-:: SDS m p r w = E.sds: SDS (sds m p r w) (m ()) /*force kind*/ & read sds & write sds
-sds :: (sds m p r w) -> SDS m p r w | read sds & write sds & Monad m
+:: SDS m p r w = E.sds: SDS (sds m p r w) (m ()) /*force kind*/ & read, write, observe sds
+sds :: (sds m p r w) -> SDS m p r w | read, write, observe sds & Monad m
instance read SDS
instance write SDS
+instance observe SDS
//* Read a share completely
getShare :: (sds m () r w) -> PViewT m r | Monad m & read sds & TC r & TC w
import ASDS.Select
import ASDS.Parallel
-sds :: (sds m p r w) -> SDS m p r w | read sds & write sds & Monad m
+sds :: (sds m p r w) -> SDS m p r w | read, write, observe sds & Monad m
sds s = SDS s (pure ())
instance read SDS where read (SDS s _) p = read s p
instance write SDS where write (SDS sds _) p w = write sds p w
+instance observe SDS
+where
+ identity (SDS sds _) c = identity sds c
+ observe (SDS sds _) p oid handle = observe sds p oid handle
getShare :: (sds m () r w) -> PViewT m r | Monad m & read sds & TC r & TC w
getShare s = read s () >>= \v->case v of
definition module ASDS.Source
-from ASDS import class read, class write
+from ASDS import class read, class write, class observe
from Control.Monad import class Monad
from Control.Applicative import class Applicative, class <*>, class pure
from Data.Functor import class Functor
instance read ReadSource, (RWPair sdsr sdsw) | read sdsr
instance write WriteSource, (RWPair sdsr sdsw) | write sdsw
+instance observe WriteSource, (RWPair sdsr sdsw) | observe sdsw
//* Immediately returns the given value on a read
constShare :: a -> ReadSource m p a b | pure m
implementation module ASDS.Source
+import StdEnv
import Data.Func
import Data.Functor
import Control.Monad
where
write (WriteSource write) p w = Written <$> liftT (write p w)
+instance observe WriteSource
+where
+ observe sds p oid hnd = modify \s->[NRequest oid hnd (dynamic p):s]
+
instance read (RWPair sdsr sdsw) | read sdsr
where
read (RWPair s w _) p = read s p >>= \v->case v of
Writing s = pure $ Writing $ rwpair r s
Written _ = pure $ Written ()
+instance observe (RWPair sdsr sdsw) | observe sdsw
+where
+ observe (RWPair r s _) p oid hnd = observe s p oid hnd
+
constShare :: a -> ReadSource m p a b | pure m
constShare a = ReadSource \_->pure a
import StdEnv
import Data.Either
import Data.Func
+import Data.Functor.Identity
from Data.Map import :: Map(..)
import qualified Data.Map
import Control.Monad
equal :: a (PViewT m a) -> PViewT m () | MonadFail m & == a
equal expected mon = mon >>= \v->if (v == expected) (pure ()) (fail "Not equal")
+//Start :: Either String (((), [NRequest Identity)]), Map String Dynamic)
+Start = runIdentity (runStateT (observe intsource () "observeid" (pure ()) >>| setShare 42 intsource) [])
+
+intsource :: Source m () Int Int | pure m
+intsource = source (\_->pure 42) (\_ _->pure ())
+
+/*
//Start :: Either String ((), Map String Dynamic)
Start = runStateT (runStateT (sequence_ $ map test tests) []) 'Data.Map'.newMap
where
sh :: Lens (Lens (Lens (Lens (RWPair ReadSource WriteSource)))) (StateT (Map String Dynamic) m) () a a | MonadFail m & TC a
sh = focus "foo" astore
+*/
testpar :: (A.a: sds1 m () a a | TC, == a) (A.a: sds2 m () a a | TC, == a) -> PViewT m () | MonadFail m & read, write sds1 & read, write sds2
testpar l r =
repositories / clean-tests.git / commitdiff