From 1e045c594292d096dac9064412e8641e8e02bda7 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 15 Nov 2019 13:37:59 +0100
Subject: [PATCH] structs
---
.gitignore | 2 +
struct/struct.icl | 154 +++++++++++++++++++++++++++++++++-------------
2 files changed, 113 insertions(+), 43 deletions(-)
diff --git a/.gitignore b/.gitignore
index c17b393..df867ba 100644
--- a/.gitignore
+++ b/.gitignore
@@ -13,3 +13,5 @@ test
gopt
afp/a[0-9]/a[0-9]
afp/a1[0-9]/a1[0-9]
+
+struct
diff --git a/struct/struct.icl b/struct/struct.icl
index c1d2bdd..97303ae 100644
--- a/struct/struct.icl
+++ b/struct/struct.icl
@@ -9,57 +9,126 @@ import Text
import Data.Functor
import Control.Applicative
-:: Structmaker a = SM (Int [String] -> [String]) | Onzin a
-
-runSM :: (Structmaker a) -> (Int [String] -> [String])
-runSM (SM a) = a
-
-generic gToStruct a :: Structmaker a
-gToStruct{|Int|} = SM \_ c->["int":c]
-gToStruct{|Real|} = SM \_ c->["double":c]
-gToStruct{|Bool|} = SM \_ c->["bool":c]
-
-gToStruct{|UNIT|} = SM \_->id
-gToStruct{|EITHER|} fl fr = SM \i->runSM fl i o runSM fr i
-gToStruct{|PAIR|} fl fr
- = SM \i c->runSM fl i [" f", toString i, "; ":runSM fr (i+1) c]
-
-gToStruct{|OBJECT of gtd|} f
- | gtd.gtd_num_conses == 0 = SM (runSM f)
- = SM \i c->
- ["struct clean_", gtd.gtd_name, " {\n"
- ,"uint8_t cons;\n"
- ,"union {\n"
- :runSM f i
- ["} data;\n"
- ,"}":c]]
-gToStruct{|CONS of gcd|} f = SM \i c->["struct { ":runSM f i ["} ", gcd.gcd_name, ";\n":c]]
-gToStruct{|RECORD of grd|} f
- = SM \i c->
- ["struct clean_", grd.grd_name, " {\n"
- :runSM f i
- ["}":c]]
-gToStruct{|FIELD of gfd|} f = SM \i c->runSM f i [gfd.gfd_name,";\n":c]
+:: Structmaker a = SM (SData [String] -> [String]) | Onzin a
+:: SData = {indent :: Int, fresh :: Int, inRecord :: Bool}
+
+indent :: SData [String] -> [String]
+indent s c = [createArray s.indent '\t':c]
+
+show :: String SData [String] -> [String]
+show str s c = indent s [str:c]
+
+toEnumValue :: GenericConsDescriptor -> String
+toEnumValue gcd = gcd.gcd_type_def.gtd_name +++ "_" +++ gcd.gcd_name
+
+toEnumType :: GenericTypeDefDescriptor -> String
+toEnumType gtd = "enum cleanc_" +++ gtd.gtd_name
+
+class gGenerateC a | gToCType{|*|}, gToCValue{|*|}, gToCEnums{|*|} a
+
+:: CInfo a =
+ { header :: String
+ , toValue :: a -> String
+ }
+
+generateCInfo :: CInfo a | gGenerateC a
+generateCInfo =
+ let (CEnums enums) = cast res gToCEnums{|*|}
+ (SM types) = cast res gToCType{|*|}
+ res = { header = join "\n" (removeDup (sort enums)) +++ "\n\n" +++ concat (types {fresh=0,inRecord=False,indent=0} [])
+ , toValue = \a->concat (gToCValue{|*|} a [])
+ }
+ in res
+where
+ cast :: (v a) -> ((w a) -> w a)
+ cast _ = id
+
+
+generic gToCType a :: Structmaker a
+gToCType{|Int|} = SM (show "uint64_t")
+gToCType{|Real|} = SM (show "double")
+gToCType{|Bool|} = SM (show "bool")
+gToCType{|UNIT|} = SM \_->id
+gToCType{|EITHER|} (SM fl) (SM fr) = SM \s->fl s o fr s
+gToCType{|PAIR|} (SM fl) (SM fr)
+ = SM \s c
+ | s.inRecord = fl s (fr s c)
+ = fl s [" f", toString s.fresh, ";\n":fr {s & fresh=s.fresh+1} c]
+gToCType{|OBJECT of gtd|} (SM f)
+ //Newtype
+ | gtd.gtd_num_conses == 0 = SM f
+ = SM \s c
+ //Enumeration (no data)
+ | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses]
+ = indent s [toEnumType gtd:c]
+ //Regular ADTs
+ # s` = {s & indent = s.indent + 1}
+ = indent s ["struct clean_", gtd.gtd_name, " {\n":
+ indent s` [toEnumType gtd, " cons;\n":
+ indent s` ["union {\n":
+ f {s` & indent=s`.indent+1, inRecord=False} (indent s` ["} data;\n":
+ indent s ["}":c]])]]]
+gToCType{|CONS of gcd|} (SM f)
+ //No data field
+ | gcd.gcd_arity == 0 = SM \_->id
+ //Only one data field
+ | gcd.gcd_arity == 1 = SM \s c->f s [" ", gcd.gcd_name, ";\n":c]
+ = SM \s c->indent s ["struct {\n":f {s & indent=s.indent+1} [" f", toString (gcd.gcd_arity - 1), ";\n":indent s ["} ", gcd.gcd_name, ";\n":c]]]
+gToCType{|RECORD of grd|} (SM f)
+ = SM \s c->indent s ["struct clean_", grd.grd_name, " {\n": f {s & indent=s.indent+1, inRecord=True} (indent s ["}":c])]
+gToCType{|FIELD of gfd|} (SM f) = SM \s c->f s [" ", gfd.gfd_name,";\n":c]
+
+:: CEnums a = CEnums [String] | Onzin2 a
+generic gToCEnums a :: CEnums a
+gToCEnums{|a|} = CEnums []
+gToCEnums{|UNIT|} = CEnums []
+gToCEnums{|EITHER|} (CEnums fl) (CEnums fr) = CEnums (fl ++ fr)
+gToCEnums{|PAIR|} (CEnums fl) (CEnums fr) = CEnums (fl ++ fr)
+gToCEnums{|OBJECT of gtd|} (CEnums f)
+ = CEnums [concat [toEnumType gtd, " {", join ", " (map toEnumValue gtd.gtd_conses), "};"]:f]
+gToCEnums{|CONS|} (CEnums f) = CEnums f
+gToCEnums{|RECORD|} (CEnums f) = CEnums f
+gToCEnums{|FIELD|} (CEnums f) = CEnums f
+
+generic gToCValue a :: a [String] -> [String]
+gToCValue{|Int|} i c = [toString i:c]
+gToCValue{|Real|} r c = [toString r:c]
+gToCValue{|Bool|} b c = [if b "true" "false":c]
+gToCValue{|UNIT|} _ _ = []
+gToCValue{|EITHER|} fl _ (LEFT l) c = fl l c
+gToCValue{|EITHER|} _ fr (RIGHT l) c = fr l c
+gToCValue{|PAIR|} fl fr (PAIR l r) c = fl l [", ":fr r c]
+gToCValue{|OBJECT of gtd|} f (OBJECT a) c
+ //Newtype
+ | gtd.gtd_num_conses == 0 = f a c
+ | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses]
+ = f a c
+ = ["{":f a ["}":c]]
+gToCValue{|CONS of gcd|} f (CONS a) c
+ //No data field
+ | gcd.gcd_arity == 0 = [toEnumValue gcd:c]
+ | gcd.gcd_arity == 1
+ = [" .cons=",toEnumValue gcd,", .data.",gcd.gcd_name,"=":f a c]
+ = [" .cons=",toEnumValue gcd,", .data.",gcd.gcd_name,"={":f a ["} ":c]]
+gToCValue{|RECORD|} f (RECORD a) c
+ = ["{":f a ["}":c]]
+gToCValue{|FIELD of gfd|} f (FIELD a) c
+ = [" .", gfd.gfd_name, "=": f a c]
:: DHTDetails
= DHT Int Bool
| SHT Addr
| XXX Int Int Int
- | XXY Int Int Int
+ | XXY Int Int DHTType
:: Addr =: Addr Int
:: DHTType = DHT11 | DHT12 | DHT22
-derive gToStruct DHTDetails
-derive gToStruct DHTType
-derive gToStruct Addr
-derive gToStruct Record
+derive class gGenerateC DHTDetails, DHTType, Addr, Record
-Start =
- (concat (runSM s 0 [])
- ,concat (runSM s` 0 [])
- )
+Start :: CInfo DHTDetails
+Start = generateCInfo
:: Record =
{ field1 :: Int
@@ -68,8 +137,7 @@ Start =
}
s :: (Structmaker DHTDetails)
-s = gToStruct{|*|}
+s = gToCType{|*|}
s` :: (Structmaker Record)
-s` = gToStruct{|*|}
-
+s` = gToCType{|*|}
--
2.20.1