monomorph structgen

diff --git a/structs/GenC.dcl b/structs/GenC.dcl
new file mode 100644 (file)
index 0000000..b33d991
--- /dev/null
+++ b/structs/GenC.dcl
@@ -0,0 +1,76 @@
+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_name,gtd_conses,gtd_num_conses}, RECORD of {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

diff --git a/structs/GenC.icl b/structs/GenC.icl
new file mode 100644 (file)
index 0000000..c566d23
--- /dev/null
+++ b/structs/GenC.icl
@@ -0,0 +1,349 @@
+implementation module GenC
+
+import StdEnv, StdGeneric, StdMaybe
+import Data.Map => qualified updateAt
+import Data.Func, Data.Tuple
+import Data.Maybe
+import Data.Either
+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 [(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)
+gToStruct{|OBJECT of {gtd_name,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 (zip2 [gcd.gcd_name\\gcd<-gtd_conses] (map (toT o mkccons) n))) st
+                               )
+       where
+               mkty (GTSEither l) = l
+               mkty t = [t]
+
+               mkccons (GTSType pi t) = [GTSType pi t]
+               mkccons (GTSPair t) = t
+               mkccons _ = []
+               
+               toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
+gToStruct{|RECORD of {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_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 = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
+       pfname n c = ["parse_", n:c]
+       pfcall n c = pfname n ["(get, alloc, err);":c]
+       funsig n c
+               = typeName n m [" ": pfname n ["(\n"
+               : ind 1 ["uint8_t (*get)(void),\n"
+               : ind 1 ["void *(*alloc)(size_t),\n"
+               : ind 1 ["void (*err)(const char *errmsg, ...))"
+               :c]]]]]
+       funbody (n, ty) c = funsig n
+               ["\n{\n"
+               :ind 1 $ typeName n m [" r;\n"
+               :funb ty $ ind 1 ["return r;\n}\n":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

diff --git a/structs/scc.dcl b/structs/scc.dcl
new file mode 100644 (file)
index 0000000..c683730
--- /dev/null
+++ b/structs/scc.dcl
@@ -0,0 +1,13 @@
+definition module scc
+
+from StdOverloaded import class <, class ==
+from StdClass import class Ord, class Eq
+
+/*
+ * Find all strongly connected components using tarjan's algorithm
+ * see: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm
+ *
+ * @param list of nodes together with their successors
+ * @return the strongly connected components
+ */
+scc :: ![(a, [a])] -> [[a]] | Eq, Ord a

diff --git a/structs/scc.icl b/structs/scc.icl
new file mode 100644 (file)
index 0000000..408e647
--- /dev/null
+++ b/structs/scc.icl
@@ -0,0 +1,41 @@
+implementation module scc
+
+import StdEnv, StdMaybe
+import Data.Map => qualified updateAt
+
+:: St a  = {nextindex :: !Int, stack :: ![a], map :: !Map a Annot, sccs :: ![[a]]}
+:: Annot = {index :: !Int, lowlink :: !Int, onstack :: !Bool}
+
+scc :: ![(a, [a])] -> [[a]] | Eq, Ord a
+scc nodes = reverse (foldr (strongconnect nodes) {nextindex=zero,stack=[],map=newMap,sccs=[]} nodes).sccs
+where
+       strongconnect :: ![(a, [a])] !(a, [a]) !(St a) -> St a | Eq, Ord a
+       strongconnect nodes (v, suc) s
+               | isJust (get v s.map) = s
+               # s = foldr (processSucc nodes v)
+                       { s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
+                       , stack     = [v:s.stack]
+                       , nextindex = inc s.nextindex
+                       } suc
+               # (Just a) = get v s.map
+               | a.index <> a.lowlink = s
+               # (scc, [sl:stack]) = span ((<>) v) s.stack
+               # scc = scc ++ [sl]
+               = { s & sccs = [scc:s.sccs]
+                 , stack    = stack
+                 , map      = foldr (alter \(Just s)->Just {s & onstack=False}) s.map scc
+                 }
+       where
+               processSucc :: ![(a, [a])] !a !a !(St a) -> St a | Eq, Ord a
+               processSucc nodes v w s = case get w s.map of
+                       Nothing
+                               # n = filter ((==)w o fst) nodes
+                               | n =: [] = s
+                               # s = strongconnect nodes (hd n) s
+                               # (Just aw) = get w s.map
+                               # (Just av) = get v s.map
+                               = {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}
+                       Just aw=:{onstack=True}
+                               # (Just av) = get v s.map
+                               = {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map}
+                       Just _ = s

diff --git a/structs/test.icl b/structs/test.icl
new file mode 100644 (file)
index 0000000..8585bd0
--- /dev/null
+++ b/structs/test.icl
@@ -0,0 +1,19 @@
+module test
+
+import GenC
+
+:: List a = Nil | Cons a (List a)
+:: NInt =: NInt Int
+:: T = A | B | C
+:: R = {i :: Int, q :: T}
+:: Muta a = Muta (Mutb a)
+:: Mutb a = Mutb (Muta a)
+derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
+derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
+
+Start = (toCFiles t)
+where
+       t :: Box String (List (Muta Int))
+//     t :: Box GTSState NInt
+       t = Box "listmutaint"
+