--- /dev/null
+module bc
+
+import Crypto.Hash.SHA1
+import Data.Func
+import Data.Integer, Data.Integer.GenJSON
+import Data.List
+import Math.Random
+import StdEnv
+import System.Process
+import System.Time
+import Text
+import iTasks
+import iTasks.Extensions.DateTime
+
+NONCESIZE :== 2
+
+:: HashFun :== String -> String
+:: ValidationFun :== String -> Bool
+:: Block = {nonce :: !Int, prevHash :: !String, data :: !String, hash :: !String}
+:: BlockChain :== [Block]
+:: Settings = {difficulty :: Int, workers :: [Int]}
+
+derive class iTask Settings, Block
+
+Start w = doTasks main w
+
+mine :: !HashFun !ValidationFun !String !String !Int -> Block
+mine hfun pred prev data seed
+# (nonce, hash) = hd $ filter (pred o snd) $ map hash $ genRandInt seed
+= {nonce=nonce,prevHash=prev,data=data,hash=hash}
+where
+ hash i = (i, hfun $ data +++ prev +++ toString i)
+
+dataShare :: SimpleSDSLens [String]
+dataShare = sharedStore "data" []
+
+chainShare :: SimpleSDSLens [Block]
+chainShare = sharedStore "chain" []
+
+messageShare :: SimpleSDSLens [String]
+messageShare = sharedStore "messages" []
+
+settingsShare :: SimpleSDSLens Settings
+settingsShare = sharedStore "settings" {difficulty=4, workers=[8000,8001,8002]}
+
+main = (parallel
+ [(Embedded, \_->chainViewer <<@ Title "Chain")
+ ,(Embedded, \_->minerTask <<@ Title "Pool" @! ())
+ ,(Embedded, \_->updateSharedInformation [] settingsShare <<@ Title "Settings" @! ())
+ ] [] <<@ ArrangeWithTabs False)
+ >>* [OnAction (Action "Shutdown") $ always $ shutDown 0]
+where
+ chainViewer :: Task ()
+ chainViewer
+ = (addData <<@ heightAttr (ExactSize 80))
+ -|| (viewSharedInformation [] chainShare <<@ Label "Chain")
+ where
+ addData = (enterInformation [] <<@ Label "Add data")
+ >>? \x->upd (\q->q ++ [x]) dataShare
+ >-| addData
+
+ minerTask :: Task ()
+ minerTask
+ = get applicationOptions
+ >>- \opts->wait (not o isEmpty) dataShare
+ >>- \[data:_]->upd (\[_:qs]->qs) dataShare
+ >-| get settingsShare
+ >>- \sett->get chainShare @ maybe "" (\b->b.hash) o listToMaybe
+ >>- \prevhash->anyTask
+ [ mineTask i opts.appPath port sett.difficulty data prevhash
+ \\ port <- sett.workers & i <- [0..]]
+ >>- \block->upd (\chain->[block:chain]) chainShare
+ >-| minerTask
+ where
+ mineTask :: Int String Int Int String String -> Task Block
+ mineTask num appPath port difficulty data prevHash =
+ Title ("Worker " +++ toString num) @>> ApplyLayout (toPanel False) @>>
+ withShared [] \stdin->
+ withShared ([], []) \stdout->
+ workerproc stdin stdout ||- workerTask (mapRead fst stdout)
+ where
+ workerproc = externalProcess {tv_sec=0,tv_nsec=100000000} appPath ["--distributed", toString port, "--distributedChild"] Nothing 9 (Just defaultPtyOptions)
+ workerTask stdout
+ = wait (any (startsWith "SDS server listening on ") o split "\n" o concat) stdout
+ >-| asyncTask "localhost" port
+ (get randomInt >>- return o mine sha1 (startsWith (createArray difficulty '0')) prevHash data)
--- /dev/null
+definition module GenC
+
+import StdGeneric
+from Data.Either import :: Either
+from StdOverloaded import class zero
+
+/**
+ * Helper types for @ style types
+ */
+:: Box b a =: Box b
+derive bimap Box
+unBox (Box b) :== b
+box b :== Box b
+reBox x :== box (unBox x)
+
+/**
+ * Calculate whether a type has a potentially infinite size
+ */
+potInf :: Box Bool a | gPotInf{|*|} a
+generic gPotInf a :: [String] -> Box Bool a
+derive gPotInf Int, Bool, Char, Real, World, Dynamic, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_name}, RECORD of {grd_name}
+
+/**
+ * Calculate the ctype representation of a type
+ */
+toStruct :: Box GTSState a | gToStruct{|*|} a
+:: GTSResult
+:: GTSState
+instance zero GTSState
+generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
+derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_arity,gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_arity,grd_name,grd_fields}
+
+/**
+ * Given a GTSState, generate typedefinitions
+ */
+toCType :: GTSState -> [String]
+
+/**
+ * Given a GTSState, generate a parser
+ * @result Function signatures
+ * @result Function
+ */
+toCParser :: GTSState -> ([String], [String])
+/**
+ * Given a GTSState, generate a printer
+ * @result Function signatures
+ * @result Function
+ */
+toCPrinter :: GTSState -> ([String], [String])
+
+/**
+ * Generate a serialized value for the given type
+ * @param value
+ * @param continuation list
+ * @result Bytes
+ */
+toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
+generic gToCValue a :: a [Char] -> [Char]
+derive gToCValue Int, Bool, Char, UNIT, EITHER, PAIR, CONS of {gcd_index}, FIELD, RECORD, OBJECT
+
+/**
+ * Parse a value from the serializized value
+ * @param bytes
+ * @result Either an error or a value
+ */
+:: FromCValueError = CVEUnknownConstructor | CVEInputExhausted
+fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
+generic gFromCValue a :: ([Char] -> Either FromCValueError (a, [Char]))
+derive gFromCValue Int, Bool, Char, UNIT, EITHER, PAIR, CONS of {gcd_index}, FIELD, RECORD, OBJECT
+
+/**
+ * @param type in a box with a filename
+ * @param .h file
+ * @param .c file
+ */
+toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
--- /dev/null
+implementation module GenC
+
+import StdEnv, StdGeneric, StdMaybe
+import Data.Map => qualified updateAt
+import Data.Func, Data.Tuple
+import Data.Maybe
+import Data.Either
+import Data.List => qualified difference, union, find
+import Text
+
+import scc
+
+derive bimap Box
+
+potInf :: Box Bool a | gPotInf{|*|} a
+potInf = gPotInf{|*|} []
+
+generic gPotInf a :: [String] -> Box Bool a
+gPotInf{|Int|} _ = box False
+gPotInf{|Bool|} _ = box False
+gPotInf{|Char|} _ = box False
+gPotInf{|Real|} _ = box False
+gPotInf{|World|} _ = box False
+gPotInf{|Dynamic|} _ = box False
+gPotInf{|c|} _ = box False
+gPotInf{|UNIT|} _ = box False
+gPotInf{|CONS|} f s = reBox (f s)
+gPotInf{|FIELD|} f s = reBox (f s)
+gPotInf{|EITHER|} fl fr s = box (unBox (fl s) || unBox (fr s))
+gPotInf{|PAIR|} fl fr s = box (unBox (fl s) || unBox (fr s))
+gPotInf{|OBJECT of {gtd_name}|} f s
+ = if (isMember gtd_name s) (box True) (reBox (f [gtd_name:s]))
+gPotInf{|RECORD of {grd_name}|} f s
+ = if (isMember grd_name s) (box True) (reBox (f [grd_name:s]))
+
+:: CType
+ = CTTypeDef String
+ | CTEnum [String]
+ | CTStruct Int [(String, [(String, Bool, String)])]
+
+:: GTSState = {dict :: Map String CType}
+instance zero GTSState where zero = {dict=newMap}
+
+toStruct :: Box GTSState a | gToStruct{|*|} a
+toStruct = snd $ gToStruct{|*|} zero
+generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
+:: GTSResult
+ = GTSType Bool String //ispointer and the name
+ | GTSUnit
+ | GTSEither [GTSResult]
+ | GTSPair [GTSResult]
+ | GTSError
+
+putst k v st = {st & dict=put k v st.dict}
+
+gToStruct{|Int|} st = (GTSType False "uint64_t", box st)
+gToStruct{|Bool|} st = (GTSType False "bool", box st)
+gToStruct{|Char|} st = (GTSType False "char", box st)
+gToStruct{|Real|} st = (GTSType False "double", box st)
+gToStruct{|UNIT|} st = (GTSUnit, box st)
+gToStruct{|CONS|} f _ st = appSnd reBox $ f st
+gToStruct{|FIELD|} f _ st = appSnd reBox $ f st
+gToStruct{|EITHER|} fl _ fr _ st
+ # (l, Box st) = fl st
+ # (r, Box st) = fr st
+ = (case (l, r) of
+ (GTSEither l, GTSEither r) = GTSEither (l ++ r)
+ (a, GTSEither l) = GTSEither [a:l]
+ (l, r) = GTSEither [l, r]
+ , box st)
+gToStruct{|PAIR|} fl _ fr _ st
+ # (l, Box st) = fl st
+ # (r, Box st) = fr st
+ = (case (l, r) of
+ (GTSPair l, GTSPair r) = GTSPair (l ++ r)
+ (a, GTSPair l) = GTSPair [a:l]
+ (l, r) = GTSPair [l, r]
+ , box st)
+import Debug.Trace
+gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
+ # (Box isPInf) = i []
+ # ty = GTSType isPInf
+ = case get gtd_name st.dict of
+ Just _ = (GTSType isPInf gtd_name, box st)
+ Nothing
+ //Newtype
+ | gtd_num_conses == 0
+ = case f st of
+ (GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st)
+ //If it is just an enumeration, Just the enum
+ | and [gcd.gcd_arity == 0\\gcd<-gtd_conses]
+ = (GTSType False gtd_name, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
+ //Constructors with data fields
+ # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
+ =
+ ( GTSType isPInf gtd_name
+ , box $ putst gtd_name
+ (CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
+ )
+ where
+ mkty :: GTSResult -> [GTSResult]
+ mkty (GTSEither l) = l
+ mkty t = [t]
+
+ mkccons :: GTSResult -> [GTSResult]
+ mkccons (GTSType pi t) = [GTSType pi t]
+ mkccons (GTSPair t) = t
+ mkccons _ = []
+
+ ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
+ ctcons gcd cons
+ # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
+ = (gcd_name, toT cons)
+ where
+ toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
+gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st
+ # (Box isPInf) = i []
+ = case get grd_name st.dict of
+ Just n = (GTSType isPInf grd_name, box st)
+ Nothing
+ # (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st
+ = case n of
+ GTSPair l =
+ ( GTSType isPInf grd_name
+ , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
+ _ = (GTSError, box st)
+
+/**
+ * Given a GTSState, generate typedefinitions
+ */
+toCType :: GTSState -> [String]
+toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
+where
+ refs (CTTypeDef s) = [s]
+ refs (CTEnum _) = []
+ refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
+
+ proc [] c = c
+ proc [x] c = ctypedef x (find x m) c
+ proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts
+ where
+ ts = [(x, find x m)\\x<-xs]
+ prototype x c = ["struct ", x, ";\n":c]
+
+ ctypedef :: String CType [String] -> [String]
+ ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c]
+ ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
+ ctypedef name (CTStruct _ [(_, fs)]) c =
+ [ "struct ", name, " {\n"
+ : foldr (uncurry3 (field 1))
+ ["};\n":c] fs
+ ]
+ ctypedef name (CTStruct _ cs) c =
+ [ "struct ", name, " {\n"
+ : ind 1 ["enum {"
+ : enum (map fst cs)
+ ["} cons;\n"
+ : ind 1 ["union {\n"
+ : foldr (uncurry struct)
+ (ind 1 ["} data;\n};\n":c])
+ cs]]]]
+
+ struct name [] c = c
+ struct name [(ty, pi, _)] c = field 2 ty pi name c
+ struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs]
+
+ field i ty pi name c
+ = ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
+
+ enum [] c = c
+ enum [x] c = [x:c]
+ enum [x:xs] c = [x, ",": enum xs c]
+
+typeName ty m c = [case get ty m of
+ Just (CTStruct _ _) = "struct "
+ Just (CTEnum _) = "enum "
+ _ = ""
+ , ty:c]
+
+ind n c = [createArray n '\t':c]
+
+uncurry3 f (x,y,z) = f x y z
+
+/**
+ * Given a GTSState, generate a parser
+ * @result Function signature
+ * @result Function
+ */
+toCParser :: GTSState -> ([String], [String])
+toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
+where
+ funsigs = foldr (uncurry funsig) [";\n"] $ toList m
+ pfname n c = ["parse_", n:c]
+ pfcall n c = pfname n ["(get, alloc, err);":c]
+ funsig n (CTStruct i _) c
+ | i > 0
+ = typeName n m [" "
+ : pfname n ["(\n"
+ : funargs 1
+ $ foldr (\i c->
+ [",\n":ind 1 ["void *(*parse_", toString i, ")(\n"
+ : funargs 2 [")":c]]]) [")":c] [0..i-1]]]
+ funsig n _ c = typeName n m [" ": pfname n ["(\n":funargs 1 [")":c]]]
+ funbody (n, ty) c = funsig n ty
+ ["\n{\n"
+ :ind 1 $ typeName n m [" r;\n"
+ :funb ty $ ind 1 ["return r;\n}\n":c]]]
+ funargs i c
+ = ind i ["uint8_t (*get)(void),\n"
+ : ind i ["void *(*alloc)(size_t size),\n"
+ : ind i ["void (*err)(const char *errmsg, ...)"
+ :c]]]
+
+ funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]]
+ funb (CTEnum a) c = ind 1 ["r = get()\n":c]
+ funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
+ funb (CTStruct _ fs) c
+ = ind 1 ["switch(r.cons = get()) {\n"
+ :foldr field
+ ( ind 1 ["default:\n"
+ : ind 2 ["break;\n"
+ : ind 1 ["}\n":c]]]) fs]
+ where
+ field (n, []) c = c
+ field (n, fs) c =
+ ind 1 ["case ", n, ":\n"
+ : foldr (sfield 2 ("r.data."+++ n))
+ (ind 2 ["break;\n":c]) fs]
+
+ sfield i r (ty, ptr, f) c
+ = (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c)
+ $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty ["\n":c]]
+
+/**
+ * Given a GTSState, generate a printer
+ * @result Function signature
+ * @result Function
+ */
+toCPrinter :: GTSState -> ([String], [String])
+toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m))
+where
+ funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
+ pfname n c = ["print_", n:c]
+ pfcall r n c = pfname n ["(", r, ", put);":c]
+ funsig n c =
+ ["void ":pfname n ["(\n"
+ : ind 1 $ typeName n m [" r,\n"
+ : ind 1 ["void (*put)(uint8_t))"
+ :c]]]]
+ funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]]
+
+ funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c]
+ funb (CTEnum a) c = ind 1 ["put(r)\n":c]
+ funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
+ funb (CTStruct _ fs) c =
+ ind 1 ["put(r.cons);\n"
+ : ind 1 ["switch(r.cons) {\n"
+ :foldr field
+ ( ind 1 ["default:\n"
+ : ind 2 ["break;\n"
+ : ind 1 ["}\n":c]]]) fs]]
+ where
+ field (n, []) c = c
+ field (n, fs) c
+ = ind 1 ["case ", n, ":\n"
+ : foldr (sfield 2 ("r.data."+++ n))
+ (ind 2 ["break;\n":c]) fs]
+
+ sfield i r (ty, ptr, f) c
+ = ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]
+
+toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
+toCValue a c = gToCValue{|*|} a c
+
+gToCValue{|Char|} x c = [x:c]
+gToCValue{|Int|} x c =
+ [ toChar (x >> 56)
+ , toChar (x >> 48)
+ , toChar (x >> 40)
+ , toChar (x >> 32)
+ , toChar (x >> 24)
+ , toChar (x >> 16)
+ , toChar (x >> 8)
+ , toChar x:c]
+gToCValue{|Bool|} x c = [toChar (if x 1 0):c]
+gToCValue{|UNIT|} x c = c
+gToCValue{|EITHER|} l _ (LEFT x) c = l x c
+gToCValue{|EITHER|} _ r (RIGHT x) c = r x c
+gToCValue{|PAIR|} l r (PAIR x y) c = l x $ r y c
+gToCValue{|CONS of {gcd_index}|} f (CONS x) c = [toChar gcd_index:f x c]
+gToCValue{|FIELD|} f (FIELD x) c = f x c
+gToCValue{|RECORD|} f (RECORD x) c = f x c
+gToCValue{|OBJECT|} f (OBJECT x) c = f x c
+
+fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
+fromCValue i = gFromCValue{|*|} i
+
+:: Parser a :== [Char] -> Either FromCValueError (a, [Char])
+top :: Parser Char
+top = satisfy (\_->True) CVEInputExhausted
+
+satisfy :: (Char -> Bool) FromCValueError -> Parser Char
+satisfy f e = \c->case c of
+ [c:cs]
+ | f c = Right (c, cs)
+ = Left e
+ [] = Left CVEInputExhausted
+
+yield :: a -> Parser a
+yield a = \c->Right (a, c)
+
+list :: [Parser a] -> Parser [a]
+list [] = yield []
+list [x:xs] = cons <<$>> x <<*>> list xs
+
+cons x xs = [x:xs]
+
+(<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b
+(<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a
+
+(<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b
+(<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f
+
+(<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a
+(<<|>>) l r = \c->either (\_->r c) Right $ l c
+
+int b = sum <<$>> list [(\x->toInt x << (i*8)) <<$>> top \\i<-[b-1,b-2..0]]
+gFromCValue{|Char|} = top
+gFromCValue{|Int|} = fromInt <<$>> int 8
+gFromCValue{|Bool|} = ((==) '\1') <<$>> top
+gFromCValue{|UNIT|} = yield UNIT
+gFromCValue{|EITHER|} l r = (LEFT <<$>> l) <<|>> (RIGHT <<$>> r)
+gFromCValue{|PAIR|} l r = PAIR <<$>> l <<*>> r
+gFromCValue{|CONS of {gcd_index}|} f
+ = (\x->CONS) <<$>> satisfy ((==)(toChar gcd_index)) CVEUnknownConstructor <<*>> f
+gFromCValue{|FIELD|} f = (\x->FIELD x) <<$>> f
+gFromCValue{|RECORD|} f = RECORD <<$>> f
+gFromCValue{|OBJECT|} f = (\x->OBJECT x) <<$>> f
+
+toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
+toCFiles b=:(Box fn)
+ # (padefs, paimp) = toCParser gts
+ # (prdefs, primp) = toCPrinter gts
+ =
+ ( flatten
+ [["#ifndef ", guard, "\n"
+ , "#define ", guard, "\n"
+ , "#include <stdint.h>\n"
+ , "#include <stddef.h>\n"
+ , "#include <stdarg.h>\n"]
+ , toCType gts, padefs, prdefs
+ , ["#endif\n"]
+ ]
+ , flatten
+ [["#include \"", fn, ".h\"\n"]
+ , paimp
+ , primp]
+ )
+where
+ guard = {safe c\\c<-:fn +++ ".h"}
+ safe c
+ | not (isAlphanum c) = '_'
+ = toUpper c
+ gts = unBox (cast b)
+
+ cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a
+ cast _ = toStruct
repositories / clean-tests.git / commitdiff