gengen/Data/GenType/CType.icl

   1 implementation module Data.GenType.CType
   2
   3 import Control.Applicative
   4 import Control.Monad => qualified join
   5 import Control.Monad.State
   6 import Control.Monad.Trans
   7 import Data.Either
   8 import Data.Maybe
   9 import Data.Func
  10 import Data.Functor
  11 import Data.List
  12 import StdEnv
  13 import Data.GenType
  14 import Text
  15
  16 typedefs :: [[Type]] -> Either String [String]
  17 typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) { tinfo = [] }
  18
  19 :: TDMonad :== StateT TDState (Either String) [String]
  20 :: TDState = { tinfo :: [(String, Bool)] }
  21
  22 typedefgroup :: [Type] -> TDMonad
  23 typedefgroup ts
  24         =   flatten
  25 //      <$  mapM (\t->modify \s->{s & tinfo=[(typeName t, True):s.tinfo]}) ts
  26         <$  modify (\s->{s & tinfo=[(typeName t, True)\\t<-ts] ++ s.tinfo})
  27         <*> mapM (\t->typedef t >>= post ["\n"]) ts
  28         <*  modify (\s->{s & tinfo=[(typeName t, maybeInfinite t)\\t<-ts] ++ s.tinfo})
  29 where
  30         maybeInfinite :: Type -> Bool
  31         maybeInfinite t = False
  32
  33 printTypeName :: String -> TDMonad
  34 printTypeName tname = maybe [tname] (\b->[tname, " ", if b "*" ""])
  35         <$> gets \s->lookup tname s.tinfo
  36
  37 pre :: [String] (m [String]) -> m [String] | Monad m
  38 pre t s = ((++)t) <$> s
  39
  40 post :: [String] [String] -> m [String] | pure m
  41 post t s = pure (s ++ t)
  42
  43 typedef :: Type -> TDMonad
  44 typedef (TyRef s) = printTypeName s
  45 typedef (TyBasic BTInt) = pure [IF_INT_64_OR_32 "int64_t" "int32_t"]
  46 typedef (TyBasic BTChar) = pure ["char"]
  47 typedef (TyBasic BTReal) = pure ["double"]
  48 typedef (TyBasic BTBool) = pure ["bool"]
  49 typedef (TyArray _ a) = pre ["*"] $ typedef a
  50 typedef t=:(TyNewType ti ci a)
  51         = pre ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
  52 typedef t=:(TyRecord ti fs) = pre
  53         [ "// ", toString t, "\n", "struct ", ti.grd_name, " {\n"]
  54         $ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs] >>= post ["};\n"]
  55 //Enumeration
  56 typedef t=:(TyObject ti fs)
  57         | and [t =: [] \\ (_, t)<-fs] = pure
  58                 [ "// ", toString t, "\n", "enum ", ti.gtd_name, " {"
  59                 , join ", " [ci.gcd_name\\(ci, _)<-fs], "};\n"]
  60 //Single constructor, single field (box)
  61 typedef t=:(TyObject ti [(ci, [ty])]) = pre
  62         ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
  63 //Single constructor
  64 typedef t=:(TyObject ti [(ci, ts)]) = pre
  65         [ "// ", toString t, "\n", "struct ", ti.gtd_name, " {\n"]
  66         $ fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts] >>= post ["};\n"]
  67 //Complex adt
  68 typedef t=:(TyObject ti fs) = pre
  69         [ "// ", toString t, "\nstruct ", ti.gtd_name, " {\n"
  70         , "\tenum {", join ", " [ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
  71         , "\tstruct {\n"]
  72         $ mapM fmtCons fs
  73         >>= post ["\t} data;\n};\n"] o flatten
  74 where
  75         fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
  76         fmtCons (ci, []) = pure []
  77         fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
  78                 $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
  79                 >>= post ["\t\t} ", ci.gcd_name, ";\n"]
  80 typedef t = pure []//liftT $ Left $ toString t +++ " not implemented"
  81
  82 fmtFields :: Int GenType [String] -> TDMonad
  83 fmtFields i _ [] = pure []
  84 fmtFields i (GenTypeArrow l r) [x:xs] = fmtField i x l >>= flip pre (fmtFields i r xs)
  85
  86 fmtField :: Int String GenType -> TDMonad
  87 fmtField i x (GenTypeCons a) = pre [createArray i '\t'] $ printTypeName a >>= post [x,";\n"]
  88 fmtField i x (GenTypeVar a) = fmtField i x (GenTypeCons "void *")
  89 fmtField i x (GenTypeApp l r) = fmtField i x l
  90 fmtField i x t=:(GenTypeArrow _ _) = liftT $ Left $ toString t +++ " unsupported"
  91 //typedef t=:(TyRecord ti fs) = pre
  92 //      [ "// ", toString t, "\n", "struct ", i.grd_name, " {\n"]
  93 //      $ mapM (fmtField 1) [(i.gfd_name, t)\\(i, t)<-fs]
  94 //      >>= post ["};\n"] o flatten
  95 ////Enumeration
  96 //typedef t=:(TyObject i fs)
  97 //      | and [t =: [] \\ (_, t)<-fs] = pure
  98 //              [ "// ", toString t, "\n", "enum ", i.gtd_name, " {"
  99 //              , join ", " [i.gcd_name\\(i, _)<-fs], "};\n"]
 100 ////Single constructor, single field (box)
 101 //typedef t=:(TyObject i [(j, [ty])]) = pre
 102 //      ["// ", toString t, "\n", "typedef ", i.gtd_name, " "] $ typedef ty
 103 ////Single constructor
 104 //typedef t=:(TyObject i [(j, ts)]) = pre
 105 //      [ "// ", toString t, "\n", "struct ", i.gtd_name, " {\n"]
 106 //      $ mapM (fmtField 1) (numberConsData ts)
 107 //      >>= post ["};\n"] o flatten
 108 ////Complex adt
 109 //typedef t=:(TyObject i fs) = pre
 110 //      [ "// ", toString t, "\nstruct ", i.gtd_name, " {\n"
 111 //      , "\tenum {", join ", " [i.gcd_name\\(i, _)<-fs], "} cons;\n"
 112 //      , "\tstruct {\n"]
 113 //      $ mapM fmtCons fs
 114 //      >>= post ["\t} data;\n};\n"] o flatten
 115 //where
 116 //      fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
 117 //      fmtCons (i, []) = pure []
 118 //      fmtCons (i, ts) = pre ["\t\tstruct {\n"]
 119 //              $ mapM (fmtField 3) (numberConsData ts)
 120 //              >>= post ["\t\t} ", i.gcd_name, ";\n"] o flatten
 121
 122 numberConsData ts = [("f"+++toString i, t)\\i<-[0..] & t<-ts]
 123
 124 //fmtField :: Int (String, Type) -> TDMonad
 125 //fmtField indent (i, t) = pre [createArray indent '\t'] $ typedef t >>= post [" ", i, ";\n"]