From: Mart Lubbers Date: Fri, 4 Sep 2020 07:27:58 +0000 (+0200) Subject: gengeng X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=073bd32857cb0688200fc76c997061a03c3f2147;p=clean-tests.git gengeng --- diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl index 2230df7..de08c75 100644 --- a/gengen/Data/GenType.dcl +++ b/gengen/Data/GenType.dcl @@ -1,6 +1,7 @@ definition module Data.GenType import StdGeneric +from StdOverloaded import class ==, class toString :: Box b a =: Box b derive bimap Box @@ -14,6 +15,7 @@ reBox x :== box (unBox x) | GTyArrow GType GType | GTyArray ArrayType GType | GTyUList UListType GType + | GTyUMaybe GType | GTyUnit | GTyEither GType GType | GTyPair GType GType @@ -28,6 +30,7 @@ reBox x :== box (unBox x) | TyArrow Type Type | TyArray ArrayType Type | TyUList UListType Type + | TyUMaybe Type | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)] @@ -86,8 +89,8 @@ instance replaceBuiltins Type, GType, GenType */ 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 (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,) diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl index 951b3f4..a391391 100644 --- a/gengen/Data/GenType.icl +++ b/gengen/Data/GenType.icl @@ -3,7 +3,7 @@ implementation module Data.GenType 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 @@ -14,7 +14,7 @@ import Data.Functor.Identity 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 @@ -44,6 +44,7 @@ gTypeEqShallow _ (GTyRecord j _) (GTyRef i) = i == j.grd_name 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 @@ -63,6 +64,7 @@ where (==) (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) @@ -104,6 +106,7 @@ where 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]] @@ -118,6 +121,7 @@ where 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 @@ -170,6 +174,7 @@ gTypeToType (GTyRef a) = TyRef a 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)] @@ -207,6 +212,7 @@ where 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] @@ -242,6 +248,7 @@ where 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 @@ -250,7 +257,8 @@ typeName (TyBasic a) = toString 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 @@ -302,6 +310,7 @@ where 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] @@ -313,6 +322,7 @@ where 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) @@ -353,7 +363,7 @@ gType{|Bool|} = box $ GTyBasic BTBool 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 @@ -362,6 +372,7 @@ gType{|{}|} a = box $ GTyArray ALazy $ 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 (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,) diff --git a/gengen/Data/GenType/CParser.dcl b/gengen/Data/GenType/CParser.dcl index 32b8066..67db0f3 100644 --- a/gengen/Data/GenType/CParser.dcl +++ b/gengen/Data/GenType/CParser.dcl @@ -12,4 +12,4 @@ flatParser :: Type -> Either String ([String], [String]) /** * generate parsers for the types grouped by strongly connected components */ -parsers :: [[Type]] -> Either String [String] +parsers :: [[Type]] -> Either String ([String], [String]) diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl index 6616fac..b29d8a5 100644 --- a/gengen/Data/GenType/CParser.icl +++ b/gengen/Data/GenType/CParser.icl @@ -1,7 +1,7 @@ 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 @@ -16,7 +16,8 @@ from Data.Map import :: Map(..) 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 @@ -26,8 +27,6 @@ instance MonadFail (Either String) where fail s = Left s indent c = liftT ask >>= \i->tell [createArray i '\t':c] -includes = "#include \n#include \n" - parsefun t = "parse_" +++ safe (typeName t) (<.>) infixr 6 @@ -35,19 +34,18 @@ parsefun t = "parse_" +++ safe (typeName t) 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) @@ -82,15 +80,15 @@ where = 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 @@ -103,13 +101,22 @@ where */ :: 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 @@ -118,7 +125,7 @@ where 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" @@ -148,7 +155,7 @@ where = 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"] diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl index c56e408..8ff9341 100644 --- a/gengen/Data/GenType/CType.icl +++ b/gengen/Data/GenType/CType.icl @@ -1,7 +1,7 @@ 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 @@ -17,7 +17,8 @@ from Data.Map import :: Map(..) 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 @@ -82,8 +83,7 @@ where 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 ";" ""] @@ -96,10 +96,9 @@ where >>| 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 @@ -144,7 +143,7 @@ where //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 @@ -155,7 +154,7 @@ where //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"] @@ -182,7 +181,7 @@ where 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] diff --git a/gengen/Data/GenType/Serialize.dcl b/gengen/Data/GenType/Serialize.dcl new file mode 100644 index 0000000..c0e173f --- /dev/null +++ b/gengen/Data/GenType/Serialize.dcl @@ -0,0 +1,10 @@ +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] diff --git a/gengen/gen b/gengen/gen new file mode 100755 index 0000000..be20b09 Binary files /dev/null and b/gengen/gen differ diff --git a/gengen/test.icl b/gengen/test.icl index e0e46ef..7664753 100644 --- a/gengen/test.icl +++ b/gengen/test.icl @@ -10,17 +10,19 @@ import Data.Bifunctor 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}} @@ -47,12 +49,76 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, :: 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 \n#include \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) diff --git a/uds/ASDS.dcl b/uds/ASDS.dcl index f8ea837..fd82537 100644 --- a/uds/ASDS.dcl +++ b/uds/ASDS.dcl @@ -14,9 +14,14 @@ import ASDS.Lens :: 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 @@ -41,11 +46,12 @@ class write v :: (v m p r w) p w -> PViewT m (WriteResult m p r w) | TC w & Mona | 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 diff --git a/uds/ASDS.icl b/uds/ASDS.icl index 041e2c8..4da3be4 100644 --- a/uds/ASDS.icl +++ b/uds/ASDS.icl @@ -12,11 +12,15 @@ import ASDS.Lens 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 diff --git a/uds/ASDS/Source.dcl b/uds/ASDS/Source.dcl index ab3446b..3838e0e 100644 --- a/uds/ASDS/Source.dcl +++ b/uds/ASDS/Source.dcl @@ -1,6 +1,6 @@ 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 @@ -21,6 +21,7 @@ source :: (p -> m r) (p w -> m ()) -> Source m p r w | pure m 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 diff --git a/uds/ASDS/Source.icl b/uds/ASDS/Source.icl index 65c7443..b84aeba 100644 --- a/uds/ASDS/Source.icl +++ b/uds/ASDS/Source.icl @@ -1,5 +1,6 @@ implementation module ASDS.Source +import StdEnv import Data.Func import Data.Functor import Control.Monad @@ -21,6 +22,10 @@ instance write WriteSource 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 @@ -33,6 +38,10 @@ where 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 diff --git a/uds/test.icl b/uds/test.icl index edb8eeb..aceaab3 100644 --- a/uds/test.icl +++ b/uds/test.icl @@ -3,6 +3,7 @@ module test import StdEnv import Data.Either import Data.Func +import Data.Functor.Identity from Data.Map import :: Map(..) import qualified Data.Map import Control.Monad @@ -24,6 +25,13 @@ readwrite r w sds = equal r (setShare w sds >>| getShare sds) 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 @@ -47,6 +55,7 @@ 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 =