.

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
index a073c6b..aeaf7da 100644 (file)
--- a/gengen/Data/GenType.dcl
+++ b/gengen/Data/GenType.dcl
@@ -67,16 +67,20 @@ typeName :: Type -> String
  * Predicate whether the outer type is a builtin type
  */
 class isBuiltin a :: a -> Bool
-instance isBuiltin Type
-instance isBuiltin GType
+instance isBuiltin Type, GType
+
+/**
+ * Predicate whether the outer type is a basic type
+ * Int, Bool, Char, Real, World, File, Dynamic
+ */
+class isBasic a :: a -> Bool
+instance isBasic Type, GType
 
 /**
  * Replace builtin constructors with their pretty names
  */
 class replaceBuiltins a :: a -> a
-instance replaceBuiltins Type
-instance replaceBuiltins GType
-instance replaceBuiltins GenType
+instance replaceBuiltins Type, GType, GenType
 
 /**
  * Creates a deep representation of the type

diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index e6cfe8b..aeaf5aa 100644 (file)
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -271,6 +271,16 @@ where
        isBuiltin (GTyRef a) = isBuiltin a
        isBuiltin _ = True
 
+instance isBasic Type
+where
+       isBasic (TyBasic t) = True
+       isBasic _ = False
+
+instance isBasic GType
+where
+       isBasic (GTyBasic t) = True
+       isBasic _ = False
+
 instance replaceBuiltins GenericFieldDescriptor
 where
        replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}

diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index 3ce9216..3b61d0d 100644 (file)
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -8,31 +8,66 @@ import Data.Either
 import Data.Maybe
 import Data.Func
 import Data.Functor
-import Data.List
+import Data.Tuple
+import qualified Data.Map
+from Data.Map import :: Map(..), putList, alter, get, union, fromList
 import StdEnv
 import Data.GenType
 import Text
 
 typedefs :: [[Type]] -> Either String [String]
-typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) { tinfo = [] }
+typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
 
 :: TDMonad :== StateT TDState (Either String) [String]
-:: TDState = { tinfo :: [(String, Bool)] }
+:: TDState :== 'Data.Map'.Map String (String, Bool)
 
 typedefgroup :: [Type] -> TDMonad
 typedefgroup ts
        =   flatten
-//     <$  mapM (\t->modify \s->{s & tinfo=[(typeName t, True):s.tinfo]}) ts
-       <$  modify (\s->{s & tinfo=[(typeName t, True)\\t<-ts] ++ s.tinfo})
+       <$  modify (putList [(typeName ty, (prefix ty, True))\\ty<-ts])
        <*> mapM (\t->typedef t >>= post ["\n"]) ts
-       <*  modify (\s->{s & tinfo=[(typeName t, maybeInfinite t)\\t<-ts] ++ s.tinfo})
+       <*  modify (flip (foldr $ alter (fmap (fmap \_->False)) o typeName) ts)
+       >>= \c->case ts of
+               [_] = pure c
+               ts = mapM (\x->printTypeName x >>= post [";\n"]) (map typeName ts)
+                       >>= post c o flatten
 where
-       maybeInfinite :: Type -> Bool
-       maybeInfinite t = False
+       prefix :: Type -> String
+       prefix (TyRecord _ _) = "struct "
+       prefix (TyObject _ fs)
+               | and [t =: [] \\ (_, t)<-fs] = "enum "
+               | fs =: [(_, [_])] = ""
+               | fs =: [_] = "struct "
+               = "struct "
+       prefix  _ = ""
 
 printTypeName :: String -> TDMonad
-printTypeName tname = maybe [tname] (\b->[tname, " ", if b "*" ""])
-       <$> gets \s->lookup tname s.tinfo
+printTypeName tname
+       = gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o get tname
+
+safe s = concat [sf c\\c <-:s]
+where
+       sf '~' = "Tld"
+       sf '@' = "At"
+       sf '#' = "Hsh"
+       sf '$' = "Dlr"
+       sf '%' = "Prc"
+       sf '^' = "Hat"
+       sf '?' = "Qtn"
+       sf '!' = "Bng"
+       sf ':' = "Cln"
+       sf '+' = "Pls"
+       sf '-' = "Min"
+       sf '*' = "Ast"
+       sf '<' = "Les"
+       sf '>' = "Gre"
+       sf '\\' = "Bsl"
+       sf '/' = "Slh"
+       sf '|' = "Pip"
+       sf '&' = "Amp"
+       sf '=' = "Eq"
+       sf '.' = "Dot"
+       sf c = toString c
 
 pre :: [String] (m [String]) -> m [String] | Monad m
 pre t s = ((++)t) <$> s
@@ -42,32 +77,34 @@ post t s = pure (s ++ t)
 
 typedef :: Type -> TDMonad
 typedef (TyRef s) = printTypeName s
-typedef (TyBasic BTInt) = pure [IF_INT_64_OR_32 "int64_t" "int32_t"]
-typedef (TyBasic BTChar) = pure ["char"]
-typedef (TyBasic BTReal) = pure ["double"]
-typedef (TyBasic BTBool) = pure ["bool"]
+typedef (TyBasic t) = case t of
+       BTInt = printTypeName "int64_t"
+       BTChar = printTypeName "char"
+       BTReal = printTypeName "double"
+       BTBool = printTypeName "bool"
+       t = pure []//liftT $ Left $ "basic type: " +++ toString t +++ " not implemented"
 typedef (TyArray _ a) = pre ["*"] $ typedef a
 typedef t=:(TyNewType ti ci a)
-       = pre ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
+       = pre ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
 typedef t=:(TyRecord ti fs) = pre
-       [ "// ", toString t, "\n", "struct ", ti.grd_name, " {\n"]
+       [ "// ", toString t, "\n", "struct ", safe ti.grd_name, " {\n"]
        $ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs] >>= post ["};\n"]
 //Enumeration
 typedef t=:(TyObject ti fs)
        | and [t =: [] \\ (_, t)<-fs] = pure
-               [ "// ", toString t, "\n", "enum ", ti.gtd_name, " {"
-               , join ", " [ci.gcd_name\\(ci, _)<-fs], "};\n"]
+               [ "// ", toString t, "\n", "enum ", safe ti.gtd_name, " {"
+               , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
 //Single constructor, single field (box)
 typedef t=:(TyObject ti [(ci, [ty])]) = pre
-       ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
+       ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
 //Single constructor
 typedef t=:(TyObject ti [(ci, ts)]) = pre
-       [ "// ", toString t, "\n", "struct ", ti.gtd_name, " {\n"]
+       [ "// ", toString t, "\n", "struct ", safe ti.gtd_name, " {\n"]
        $ fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts] >>= post ["};\n"]
 //Complex adt
 typedef t=:(TyObject ti fs) = pre
-       [ "// ", toString t, "\nstruct ", ti.gtd_name, " {\n"
-       , "\tenum {", join ", " [ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
+       [ "// ", toString t, "\nstruct ", safe ti.gtd_name, " {\n"
+       , "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
        , "\tstruct {\n"]
        $ mapM fmtCons fs
        >>= post ["\t} data;\n};\n"] o flatten
@@ -76,50 +113,22 @@ where
        fmtCons (ci, []) = pure []
        fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
                $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
-               >>= post ["\t\t} ", ci.gcd_name, ";\n"]
-typedef t = pure []//liftT $ Left $ toString t +++ " not implemented"
+               >>= post ["\t\t} ", safe ci.gcd_name, ";\n"]
+typedef t = liftT $ Left $ toString t +++ " not implemented"
+
+tydef name (GenTypeArrow l r) = pre ["typedef "] $ fmtField "" l >>= post [safe name,";\n"]
 
 fmtFields :: Int GenType [String] -> TDMonad
 fmtFields i _ [] = pure []
-fmtFields i (GenTypeArrow l r) [x:xs] = fmtField i x l >>= flip pre (fmtFields i r xs)
+fmtFields i (GenTypeArrow l r) [x:xs] = pre [createArray i '\t'] $ fmtField x l >>= \c->pre (c ++ [";\n"]) $ fmtFields i r xs
 
-fmtField :: Int String GenType -> TDMonad
-fmtField i x (GenTypeCons a) = pre [createArray i '\t'] $ printTypeName a >>= post [x,";\n"]
-fmtField i x (GenTypeVar a) = fmtField i x (GenTypeCons "void *")
-fmtField i x (GenTypeApp l r) = fmtField i x l
-fmtField i x t=:(GenTypeArrow _ _) = liftT $ Left $ toString t +++ " unsupported"
-//typedef t=:(TyRecord ti fs) = pre
-//     [ "// ", toString t, "\n", "struct ", i.grd_name, " {\n"]
-//     $ mapM (fmtField 1) [(i.gfd_name, t)\\(i, t)<-fs]
-//     >>= post ["};\n"] o flatten
-////Enumeration
-//typedef t=:(TyObject i fs)
-//     | and [t =: [] \\ (_, t)<-fs] = pure
-//             [ "// ", toString t, "\n", "enum ", i.gtd_name, " {"
-//             , join ", " [i.gcd_name\\(i, _)<-fs], "};\n"]
-////Single constructor, single field (box)
-//typedef t=:(TyObject i [(j, [ty])]) = pre
-//     ["// ", toString t, "\n", "typedef ", i.gtd_name, " "] $ typedef ty
-////Single constructor
-//typedef t=:(TyObject i [(j, ts)]) = pre
-//     [ "// ", toString t, "\n", "struct ", i.gtd_name, " {\n"]
-//     $ mapM (fmtField 1) (numberConsData ts)
-//     >>= post ["};\n"] o flatten
-////Complex adt
-//typedef t=:(TyObject i fs) = pre
-//     [ "// ", toString t, "\nstruct ", i.gtd_name, " {\n"
-//     , "\tenum {", join ", " [i.gcd_name\\(i, _)<-fs], "} cons;\n"
-//     , "\tstruct {\n"]
-//     $ mapM fmtCons fs
-//     >>= post ["\t} data;\n};\n"] o flatten
-//where
-//     fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
-//     fmtCons (i, []) = pure []
-//     fmtCons (i, ts) = pre ["\t\tstruct {\n"]
-//             $ mapM (fmtField 3) (numberConsData ts)
-//             >>= post ["\t\t} ", i.gcd_name, ";\n"] o flatten
-
-numberConsData ts = [("f"+++toString i, t)\\i<-[0..] & t<-ts]
-
-//fmtField :: Int (String, Type) -> TDMonad
-//fmtField indent (i, t) = pre [createArray indent '\t'] $ typedef t >>= post [" ", i, ";\n"]
+fmtField :: String GenType -> TDMonad
+fmtField x (GenTypeCons a) = printTypeName a >>= post [x]
+fmtField x (GenTypeVar a) = pure ["void *",x]
+fmtField x (GenTypeApp l r) = fmtField x l
+fmtField x t=:(GenTypeArrow _ r)
+       = map concat <$> mapM (fmtField "") (collectArgs t [])
+               >>= \[r:as]->pure [r, " (*",x,")(",join ", " as, ")"]
+where
+       collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
+       collectArgs t c = [t:c]

diff --git a/gengen/test.icl b/gengen/test.icl
index 2a59baa..1348136 100644 (file)
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -14,22 +14,25 @@ import Data.Either
 import Data.GenType
 import Data.GenType.CType
 
-derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp
+derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList
 
 :: T a =: T2 a
 :: NT =: NT Int
 :: SR = {f1 :: Int, f2 :: Bool}
 :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
        f5 :: [([#Int], [#Int!], [!Int!], [!Int], [Int!])],
-       f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int})/*({!Int}, {#Char}, {R Bool})*/}
+       f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/
+       f7 :: {!Int}}
 :: Tr m b= Tr (m Int b)
-:: Frac a = (/.) infixl 7 a a 
+:: Frac a = (/.) infixl 7 a a  | Flurp
 :: Fix f = Fix (f (Fix f))
 
 :: List a = Cons a (List a) | Nil
 
 :: Blurp a = Blurp (List a) | Blorp
 
+:: EnumList = ECons Enum EnumList | ENil
+
 ////Start :: [String]
 ////Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
 //:: Pair a b = Pair a b
@@ -42,15 +45,17 @@ Start = typedefs //$ (\x->[[gTypeToType x]])
 //     $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
 //     $ (\x->[[x]])
        $ map (map gTypeToType)
+       $ map (filter (not o isBasic))
        $ flattenGType
        $ unBox t
-//
-//
+
+
 //t :: Box GType (?# Int)
 //t :: Box GType (Maybe [Maybe (Either Bool String)])
-t :: Box GType ([SR], Enum, T Int, NT, Blurp Int)
+//t :: Box GType ([SR], Enum, T Int, NT, Blurp Int)
+//t :: Box GType [EnumList]
 //t :: Box GType (Tr Either Enum)
-//t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
+t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
 t = gType{|*|}
 
 //Start = toString t