struct/struct.icl

   1 module struct
   2
   3 import StdEnv
   4 import StdGeneric
   5 import StdDebug
   6
   7 import Text
   8
   9 import Data.Functor
  10 import Control.Applicative
  11
  12 :: Structmaker a = SM (SData [String] -> [String]) | Onzin a
  13 :: SData = {indent :: Int, fresh :: Int, inRecord :: Bool}
  14
  15 indent :: SData [String] -> [String]
  16 indent s c = [createArray s.indent '\t':c]
  17
  18 show :: String SData [String] -> [String]
  19 show str s c = indent s [str:c]
  20
  21 toEnumValue :: GenericConsDescriptor -> String
  22 toEnumValue gcd = gcd.gcd_type_def.gtd_name +++ "_" +++ gcd.gcd_name
  23
  24 toEnumType :: GenericTypeDefDescriptor -> String
  25 toEnumType gtd = "enum cleanc_" +++ gtd.gtd_name
  26
  27 class gGenerateC a | gToCType{|*|}, gToCValue{|*|}, gToCEnums{|*|} a
  28
  29 :: CInfo a =
  30         { header    :: String
  31         , toValue   :: a -> String
  32         }
  33
  34 generateCInfo :: CInfo a | gGenerateC a
  35 generateCInfo =
  36         let (CEnums enums) = cast res gToCEnums{|*|}
  37             (SM types)     = cast res gToCType{|*|}
  38             res            = { header  = join "\n" (removeDup (sort enums)) +++ "\n\n" +++ concat (types {fresh=0,inRecord=False,indent=0} [])
  39                              , toValue = \a->concat (gToCValue{|*|} a [])
  40                              }
  41         in  res
  42 where
  43         cast :: (v a) -> ((w a) -> w a)
  44         cast _ = id
  45
  46
  47 generic gToCType a :: Structmaker a
  48 gToCType{|Int|}  = SM (show "uint64_t")
  49 gToCType{|Real|} = SM (show "double")
  50 gToCType{|Bool|} = SM (show "bool")
  51 gToCType{|UNIT|} = SM \_->id
  52 gToCType{|EITHER|} (SM fl) (SM fr) = SM \s->fl s o fr s
  53 gToCType{|PAIR|} (SM fl) (SM fr)
  54          = SM \s c
  55                 | s.inRecord = fl s (fr s c)
  56                 = fl s [" f", toString s.fresh, ";\n":fr {s & fresh=s.fresh+1} c]
  57 gToCType{|OBJECT of gtd|} (SM f)
  58         //Newtype
  59         | gtd.gtd_num_conses == 0 = SM f
  60         = SM \s c
  61                 //Enumeration (no data)
  62                 | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses]
  63                         = indent s [toEnumType gtd:c]
  64                 //Regular ADTs
  65                 # s` = {s & indent = s.indent + 1}
  66                 = indent s ["struct clean_", gtd.gtd_name, " {\n":
  67                         indent s` [toEnumType gtd, " cons;\n":
  68                         indent s` ["union {\n":
  69                         f {s` & indent=s`.indent+1, inRecord=False} (indent s` ["} data;\n":
  70                         indent s ["}":c]])]]]
  71 gToCType{|CONS of gcd|} (SM f)
  72         //No data field
  73         | gcd.gcd_arity == 0 = SM \_->id
  74         //Only one data field
  75         | gcd.gcd_arity == 1 = SM \s c->f s [" ", gcd.gcd_name, ";\n":c]
  76         = 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]]]
  77 gToCType{|RECORD of grd|} (SM f)
  78         = SM \s c->indent s ["struct clean_", grd.grd_name, " {\n": f {s & indent=s.indent+1, inRecord=True} (indent s ["}":c])]
  79 gToCType{|FIELD of gfd|} (SM f) = SM \s c->f s [" ", gfd.gfd_name,";\n":c]
  80
  81 :: CEnums a = CEnums [String] | Onzin2 a
  82 generic gToCEnums a :: CEnums a
  83 gToCEnums{|a|} = CEnums []
  84 gToCEnums{|UNIT|} = CEnums []
  85 gToCEnums{|EITHER|} (CEnums fl) (CEnums fr) = CEnums (fl ++ fr)
  86 gToCEnums{|PAIR|} (CEnums fl) (CEnums fr) = CEnums (fl ++ fr)
  87 gToCEnums{|OBJECT of gtd|} (CEnums f)
  88         = CEnums [concat [toEnumType gtd, " {", join ", " (map toEnumValue gtd.gtd_conses), "};"]:f]
  89 gToCEnums{|CONS|} (CEnums f) = CEnums f
  90 gToCEnums{|RECORD|} (CEnums f) = CEnums f
  91 gToCEnums{|FIELD|} (CEnums f) = CEnums f
  92
  93 generic gToCValue a :: a [String] -> [String]
  94 gToCValue{|Int|} i c = [toString i:c]
  95 gToCValue{|Real|} r c = [toString r:c]
  96 gToCValue{|Bool|} b c = [if b "true" "false":c]
  97 gToCValue{|UNIT|} _ _ = []
  98 gToCValue{|EITHER|} fl _ (LEFT l) c = fl l c
  99 gToCValue{|EITHER|} _ fr (RIGHT l) c = fr l c
 100 gToCValue{|PAIR|} fl fr (PAIR l r) c = fl l [", ":fr r c]
 101 gToCValue{|OBJECT of gtd|} f (OBJECT a) c
 102         //Newtype
 103         | gtd.gtd_num_conses == 0 = f a c
 104         | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses]
 105                 = f a c
 106         = ["{":f a ["}":c]]
 107 gToCValue{|CONS of gcd|} f (CONS a) c
 108         //No data field
 109         | gcd.gcd_arity == 0 = [toEnumValue gcd:c]
 110         | gcd.gcd_arity == 1
 111                 = [" .cons=",toEnumValue gcd,", .data.",gcd.gcd_name,"=":f a c]
 112         = [" .cons=",toEnumValue gcd,", .data.",gcd.gcd_name,"={":f a ["} ":c]]
 113 gToCValue{|RECORD|} f (RECORD a) c
 114         = ["{":f a ["}":c]]
 115 gToCValue{|FIELD of gfd|} f (FIELD a) c
 116         = [" .", gfd.gfd_name, "=": f a c]
 117
 118 :: DHTDetails
 119         = DHT Int Bool
 120         | SHT Addr
 121         | XXX Int Int Int
 122         | XXY Int Int DHTType
 123
 124 :: Addr =: Addr Int
 125
 126 :: DHTType = DHT11 | DHT12 | DHT22
 127
 128 derive class gGenerateC DHTDetails, DHTType, Addr, Record
 129
 130 Start :: CInfo DHTDetails
 131 Start = generateCInfo
 132
 133 :: Record =
 134         { field1 :: Int
 135         , field2 :: Bool
 136         , field3 :: DHTType
 137         }
 138
 139 s :: (Structmaker DHTDetails)
 140 s = gToCType{|*|}
 141
 142 s` :: (Structmaker Record)
 143 s` = gToCType{|*|}