import Control.Monad => qualified join
import Control.Monad.State
import Control.Monad.Trans
+import Control.Monad.Writer
+import Control.Monad.Fail
import Data.Either
import Data.Func
import Data.Functor
import Data.Tuple
import qualified Data.Map
-from Data.Map import :: Map(..), putList, alter, get, union, fromList
+from Data.Map import :: Map(..)
import Data.Maybe
+import Data.List
import StdEnv
import Data.GenType
import Text
-flatTypedef :: Type -> Either String [String]
-flatTypedef t = case ftd t 0 [] of
- [] = Left ("Unable to flatTypedef: " +++ toString t)
- c = Right c
+instance MonadFail (Either String) where fail s = Left s
+
+safe :: String -> String
+safe s = concat [fromMaybe {c} $ lookup c cs\\c <-:s]
where
- indent i c = [createArray i '\t':c]
+ cs = [('~', "Tld"), ('@', "At"), ('#', "Hsh"), ('$', "Dlr"), ('%', "Prc")
+ ,('^', "Hat"), ('?', "Qtn"), ('!', "Bng"), (':', "Cln"), ('+', "Pls")
+ ,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
+ ,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
- ftd :: Type Int [String] -> [String]
- ftd (TyRef s) i c = indent i [s:c]
- ftd (TyBasic t) i c = case t of
- BTInt = indent i ["int64_t":c]
- BTChar = indent i ["char":c]
- BTReal = indent i ["double":c]
- BTBool = indent i ["bool":c]
- t = []
+:: FTMonad :== WriterT [String] (StateT [(String, [String])] (Either String)) ()
+flatTypedef :: Type -> Either String [String]
+flatTypedef t = (\(w, es)->flatten (map snd es) ++ w)
+ <$> runStateT (execWriterT (ftd t True 0)) []
+where
+ indent :: Int [String] -> FTMonad
+ indent i c = tell [createArray i '\t':c]
+
+ ftd :: Type Bool Int -> FTMonad
+ ftd (TyRef s) tl i = indent i [s]
+ ftd (TyBasic t) tl i
+ | tl = tell []
+ = case t of
+ BTInt = indent i ["int64_t"]
+ BTChar = indent i ["char"]
+ BTReal = indent i ["double"]
+ BTBool = indent i ["bool"]
+ t = fail $ "cannot flatTypedef: " +++ toString t
// ftd (TyArrow l r) i c = indent i ["*":ftd a i c]
- ftd (TyArray _ a) i c = indent i ["*":ftd a i c]
- ftd (TyNewType ti ci a) i c = ftd a i c
- ftd (TyRecord ti fs) i c
- = indent i ["struct ", safe ti.grd_name, " {\n"
- : foldr (fmtField $ i+1) (indent i ["}\n":c])
- [(fi.gfd_name, ty)\\(fi, ty)<-fs]
- ]
+ ftd (TyNewType ti ci a) tl i = ftd a tl i
+ ftd (TyArray _ a) tl i = indent i ["*"] >>| ftd a tl i
+ ftd (TyRecord ti fs) tl i
+ = indent i ["struct ", if tl (safe ti.grd_name) "", " {\n"
+ ] >>| mapM_ (fmtField $ i+1) [(fi.gfd_name, ty)\\(fi, ty)<-fs]
+ >>| indent i ["}\n"]
//Enumeration
- ftd (TyObject ti fs) i c
+ ftd (TyObject ti fs) tl i
| and [t =: [] \\ (_, t)<-fs]
- = indent i ["enum ", safe ti.gtd_name, " {"
- , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "}":c]
+ | tl = tell []
+ = indent i [] >>| enum ti fs
//Single constructor, single field (box)
- ftd (TyObject ti [(ci, [ty])]) i c = ftd ty i c
+ ftd (TyObject ti [(ci, [ty])]) tl i = ftd ty tl i
//Single constructor
- ftd (TyObject ti [(ci, ts)]) i c
- = indent i ["struct ", safe ti.gtd_name, " {\n"
- : flip (foldr (fmtField $ i+1)) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
- $ indent i ["}":c]]
+ ftd (TyObject ti [(ci, ts)]) tl i
+ = indent i ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
+ >>| mapM_ (fmtField $ i+1) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
+ >>| indent i ["}"]
//Complex adt
- ftd (TyObject ti fs) i c
- = indent i ["struct ", safe ti.gtd_name, " {\n"
- : indent (i+1) ["enum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
- : indent (i+1) ["struct {\n"
- : flip (foldr (fmtCons $ i + 2)) fs
- $ indent (i+1) ["} data;\n"
- : indent i ["}":c]
- ]]]]
+ ftd (TyObject ti fs) tl i
+ = indent i ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
+ >>| indent (i+1) [] >>| enum ti fs >>| tell [" cons;\n"]
+ >>| indent (i+1) ["struct {\n"]
+ >>| mapM_ (fmtCons $ i+2) fs
+ >>| indent (i+1) ["} data;\n"]
+ >>| indent i ["}", if tl ";" ""]
where
- fmtCons i (ci, []) c = c
- fmtCons i (ci, [t]) c = ftd t i [" ", safe ci.gcd_name, ";\n":c]
- fmtCons i (ci, ts) c
- = indent i ["struct {\n"
- : flip (foldr (fmtField (i+1))) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
- $ indent i ["} ", safe ci.gcd_name, ";\n":c]
- ]
- ftd t i c = []
-
- fmtField i (name, ty) c = ftd ty i [" ", name, ";\n":c]
-
-typedefs :: [[Type]] -> Either String [String]
-typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
+ fmtCons i (ci, []) = pure ()
+ fmtCons i (ci, [t]) = ftd t False i >>| tell [" ", safe ci.gcd_name, ";\n"]
+ fmtCons i (ci, ts)
+ = indent i ["struct {\n"]
+ >>| mapM_ (fmtField $ i+1) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
+ >>| indent i ["} ", safe ci.gcd_name, ";\n"]
+ ftd t tl i = fail $ "cannot flatTypedef: " +++ toString t
+
+
+ enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad
+ enum ti fs = liftT (gets (lookup ti.gtd_name)) >>= \e->case e of
+ ?None = liftT (modify \s->[(ti.gtd_name, ["enum ", safe ti.gtd_name, "_cons {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
+ ?Just _ = tell ["enum ", safe ti.gtd_name, "_cons"]
+
+ fmtField :: Int (String, Type) -> FTMonad
+ fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
:: TDMonad :== StateT TDState (Either String) [String]
:: TDState :== 'Data.Map'.Map String (String, Bool)
-
-typedefgroup :: [Type] -> TDMonad
-typedefgroup ts
- = flatten
- <$ modify (putList [(typeName ty, (prefix ty, True))\\ty<-ts])
- <*> mapM (\t->typedef t >>= post ["\n"]) ts
- <* 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
- prefix :: Type -> String
- prefix (TyRecord _ _) = "struct "
- prefix (TyObject _ fs)
- | and [t =: [] \\ (_, t)<-fs] = "enum "
- | fs =: [(_, [_])] = ""
- | fs =: [_] = "struct "
- = "struct "
- prefix _ = ""
-
-printTypeName :: String -> TDMonad
-printTypeName tname
- = gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o get tname
-
-safe s = concat [sf c\\c <-:s]
+typedefs :: [[Type]] -> Either String [String]
+typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
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
-
-post :: [String] [String] -> m [String] | pure m
-post t s = pure (s ++ t)
-
-header t c = pre ["// ", toString (replaceBuiltins t), "\n":c]
-
-typedef :: Type -> TDMonad
-typedef (TyRef s) = printTypeName s
-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)
- = header t [] $ tydef ti.gtd_name ci.gcd_type
-typedef t=:(TyRecord ti fs) = header t ["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] = header t
- ["enum ", safe ti.gtd_name, " {"
- , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"] $ pure []
-//Single constructor, single field (box)
-typedef t=:(TyObject ti [(ci, [ty])]) = header t [] $ tydef ti.gtd_name ci.gcd_type
-//Single constructor
-typedef t=:(TyObject ti [(ci, ts)]) = header t ["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) = header t
- ["struct ", safe ti.gtd_name, " {\n"
+ typedefgroup :: [Type] -> TDMonad
+ typedefgroup ts
+ = flatten
+ <$ modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts])
+ <*> mapM (\t->typedef t >>= post ["\n"]) ts
+ <* modify (flip (foldr $ 'Data.Map'.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
+ prefix :: Type -> String
+ prefix (TyRecord _ _) = "struct "
+ prefix (TyObject _ fs)
+ | and [t =: [] \\ (_, t)<-fs] = "enum "
+ | fs =: [(_, [_])] = ""
+ | fs =: [_] = "struct "
+ = "struct "
+ prefix _ = ""
+
+ printTypeName :: String -> TDMonad
+ printTypeName tname
+ = gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o 'Data.Map'.get tname
+
+ pre :: [String] (m [String]) -> m [String] | Monad m
+ pre t s = ((++)t) <$> s
+
+ post :: [String] [String] -> m [String] | pure m
+ post t s = pure (s ++ t)
+
+ header t c = pre ["// ", toString (replaceBuiltins t), "\n":c]
+
+ typedef :: Type -> TDMonad
+ typedef (TyRef s) = printTypeName s
+ 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)
+ = header t [] $ tydef ti.gtd_name ci.gcd_type
+ typedef t=:(TyRecord ti fs) = header t ["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] = header t
+ ["enum ", safe ti.gtd_name, " {"
+ , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"] $ pure []
+ //Single constructor, single field (box)
+ typedef t=:(TyObject ti [(ci, [ty])]) = header t [] $ tydef ti.gtd_name ci.gcd_type
+ //Single constructor
+ typedef t=:(TyObject ti [(ci, ts)]) = header t ["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) = header t
+ ["struct ", 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
-where
- fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
- fmtCons (ci, []) = pure []
- fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
- fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
- $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
- >>= post ["\t\t} ", safe ci.gcd_name, ";\n"]
-typedef t = liftT $ Left $ toString t +++ " not implemented"
-
-tydef :: String GenType -> TDMonad
-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] = pre [createArray i '\t'] $ fmtField x l >>= \c->pre (c ++ [";\n"]) $ fmtFields i r xs
-
-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]
+ $ mapM fmtCons fs
+ >>= post ["\t} data;\n};\n"] o flatten
+ where
+ fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
+ fmtCons (ci, []) = pure []
+ fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
+ fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
+ $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
+ >>= post ["\t\t} ", safe ci.gcd_name, ";\n"]
+ typedef t = liftT $ Left $ toString t +++ " not implemented"
+
+ tydef :: String GenType -> TDMonad
+ 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] = pre [createArray i '\t'] $ fmtField x l >>= \c->pre (c ++ [";\n"]) $ fmtFields i r xs
+
+ 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 / commitdiff