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.Tuple
  12 import qualified Data.Map
  13 from Data.Map import :: Map(..), putList, alter, get, union, fromList
  14 import StdEnv
  15 import Data.GenType
  16 import Text
  17
  18 typedefs :: [[Type]] -> Either String [String]
  19 typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
  20
  21 :: TDMonad :== StateT TDState (Either String) [String]
  22 :: TDState :== 'Data.Map'.Map String (String, Bool)
  23
  24 typedefgroup :: [Type] -> TDMonad
  25 typedefgroup ts
  26         =   flatten
  27         <$  modify (putList [(typeName ty, (prefix ty, True))\\ty<-ts])
  28         <*> mapM (\t->typedef t >>= post ["\n"]) ts
  29         <*  modify (flip (foldr $ alter (fmap (fmap \_->False)) o typeName) ts)
  30         >>= \c->case ts of
  31                 [_] = pure c
  32                 ts = mapM (\x->printTypeName x >>= post [";\n"]) (map typeName ts)
  33                         >>= post c o flatten
  34 where
  35         prefix :: Type -> String
  36         prefix (TyRecord _ _) = "struct "
  37         prefix (TyObject _ fs)
  38                 | and [t =: [] \\ (_, t)<-fs] = "enum "
  39                 | fs =: [(_, [_])] = ""
  40                 | fs =: [_] = "struct "
  41                 = "struct "
  42         prefix  _ = ""
  43
  44 printTypeName :: String -> TDMonad
  45 printTypeName tname
  46         = gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o get tname
  47
  48 safe s = concat [sf c\\c <-:s]
  49 where
  50         sf '~' = "Tld"
  51         sf '@' = "At"
  52         sf '#' = "Hsh"
  53         sf '$' = "Dlr"
  54         sf '%' = "Prc"
  55         sf '^' = "Hat"
  56         sf '?' = "Qtn"
  57         sf '!' = "Bng"
  58         sf ':' = "Cln"
  59         sf '+' = "Pls"
  60         sf '-' = "Min"
  61         sf '*' = "Ast"
  62         sf '<' = "Les"
  63         sf '>' = "Gre"
  64         sf '\\' = "Bsl"
  65         sf '/' = "Slh"
  66         sf '|' = "Pip"
  67         sf '&' = "Amp"
  68         sf '=' = "Eq"
  69         sf '.' = "Dot"
  70         sf c = toString c
  71
  72 pre :: [String] (m [String]) -> m [String] | Monad m
  73 pre t s = ((++)t) <$> s
  74
  75 post :: [String] [String] -> m [String] | pure m
  76 post t s = pure (s ++ t)
  77
  78 typedef :: Type -> TDMonad
  79 typedef (TyRef s) = printTypeName s
  80 typedef (TyBasic t) = case t of
  81         BTInt = printTypeName "int64_t"
  82         BTChar = printTypeName "char"
  83         BTReal = printTypeName "double"
  84         BTBool = printTypeName "bool"
  85         t = pure []//liftT $ Left $ "basic type: " +++ toString t +++ " not implemented"
  86 typedef (TyArray _ a) = pre ["*"] $ typedef a
  87 typedef t=:(TyNewType ti ci a)
  88         = pre ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
  89 typedef t=:(TyRecord ti fs) = pre
  90         [ "// ", toString t, "\n", "struct ", safe ti.grd_name, " {\n"]
  91         $ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs] >>= post ["};\n"]
  92 //Enumeration
  93 typedef t=:(TyObject ti fs)
  94         | and [t =: [] \\ (_, t)<-fs] = pure
  95                 [ "// ", toString t, "\n", "enum ", safe ti.gtd_name, " {"
  96                 , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
  97 //Single constructor, single field (box)
  98 typedef t=:(TyObject ti [(ci, [ty])]) = pre
  99         ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
 100 //Single constructor
 101 typedef t=:(TyObject ti [(ci, ts)]) = pre
 102         [ "// ", toString t, "\n", "struct ", safe ti.gtd_name, " {\n"]
 103         $ fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts] >>= post ["};\n"]
 104 //Complex adt
 105 typedef t=:(TyObject ti fs) = pre
 106         [ "// ", toString t, "\nstruct ", safe ti.gtd_name, " {\n"
 107         , "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
 108         , "\tstruct {\n"]
 109         $ mapM fmtCons fs
 110         >>= post ["\t} data;\n};\n"] o flatten
 111 where
 112         fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
 113         fmtCons (ci, []) = pure []
 114         fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
 115                 $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
 116                 >>= post ["\t\t} ", safe ci.gcd_name, ";\n"]
 117 typedef t = liftT $ Left $ toString t +++ " not implemented"
 118
 119 tydef name (GenTypeArrow l r) = pre ["typedef "] $ fmtField "" l >>= post [safe name,";\n"]
 120
 121 fmtFields :: Int GenType [String] -> TDMonad
 122 fmtFields i _ [] = pure []
 123 fmtFields i (GenTypeArrow l r) [x:xs] = pre [createArray i '\t'] $ fmtField x l >>= \c->pre (c ++ [";\n"]) $ fmtFields i r xs
 124
 125 fmtField :: String GenType -> TDMonad
 126 fmtField x (GenTypeCons a) = printTypeName a >>= post [x]
 127 fmtField x (GenTypeVar a) = pure ["void *",x]
 128 fmtField x (GenTypeApp l r) = fmtField x l
 129 fmtField x t=:(GenTypeArrow _ r)
 130         = map concat <$> mapM (fmtField "") (collectArgs t [])
 131                 >>= \[r:as]->pure [r, " (*",x,")(",join ", " as, ")"]
 132 where
 133         collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
 134         collectArgs t c = [t:c]