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
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
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]
repositories / clean-tests.git / blobdiff