+++ /dev/null
-implementation module GenType.CType
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Fail
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Trans
-import Control.Monad.Writer
-import Data.Either
-import Data.Func
-import Data.Functor
-import Data.List
-import qualified Data.Map
-from Data.Map import :: Map(..)
-import Data.Maybe
-import Data.Tuple
-import StdEnv
-import qualified Text
-from Text import class Text(concat), instance Text String
-
-import GenType
-
-instance MonadFail (Either String) where fail s = Left s
-
-safe :: String -> String
-safe s = concat [fromMaybe {c} $ lookup c cs\\c <-:s]
-where
- cs = [('~', "Tld"), ('@', "At"), ('#', "Hsh"), ('$', "Dlr"), ('%', "Prc")
- ,('^', "Hat"), ('?', "Qtn"), ('!', "Bng"), (':', "Cln"), ('+', "Pls")
- ,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
- ,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
-
-prefix :: Type -> String
-prefix (TyRecord _ _) = "struct "
-prefix (TyObject _ fs)
- | and [t =: [] \\ (_, t)<-fs] = "enum "
- | fs =: [(_, [_])] = ""
- | fs =: [_] = "struct "
- = "struct "
-prefix _ = ""
-
-consName :: GenericTypeDefDescriptor -> String
-consName s = "enum " +++ safe s.gtd_name +++ "_cons"
-
-iindent = mapWriterT $ mapStateT $ local inc
-indent c = liftT (liftT ask) >>= \i->tell [createArray i '\t':c]
-
-:: FTMonad :== WriterT [String] (StateT [(String, [String])] (ReaderT Int (Either String))) ()
-flatTypedef :: Type -> Either String [String]
-flatTypedef t = (\(w, es)->flatten (map snd es) ++ w)
- <$> runReaderT (runStateT (execWriterT (ftd t True )) []) 0
-where
- ftd :: Type Bool -> FTMonad
- ftd (TyRef s) tl = indent [s]
- ftd (TyBasic t) tl
- | tl = pure ()
- = case t of
- BTInt = indent ["int64_t"]
- BTChar = indent ["char"]
- BTReal = indent ["double"]
- BTBool = indent ["bool"]
- t = fail $ "flatTypedef: there is no basic type for " +++ toString t
- ftd (TyArrow l r) tl = fail "flatTypedef: functions cannot be serialized"
- ftd (TyNewType ti ci a) tl = ftd a tl
- ftd (TyArray _ a) tl = indent ["*"] >>| ftd a tl
- ftd (TyRecord ti fs) tl
- = indent ["struct ", if tl (safe ti.grd_name) "", " {\n"
- ] >>| mapM_ (iindent o fmtField) [(fi.gfd_name, ty)\\(fi, ty)<-fs]
- >>| indent ["}\n"]
- //Enumeration
- ftd (TyObject ti fs) tl
- | and [t =: [] \\ (_, t)<-fs]
- | tl = pure ()
- = indent [] >>| enum ti fs
- //Single constructor, single field (box)
- ftd (TyObject ti [(ci, [ty])]) tl = ftd ty tl
- //Single constructor
- ftd (TyObject ti [(ci, ts)]) tl
- = indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
- >>| mapM_ (iindent o fmtField) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
- >>| indent ["}"]
- //Complex adt
- ftd (TyObject ti fs) tl
- = indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
- >>| iindent (indent []) >>| enum ti fs >>| tell [" cons;\n"]
- >>| iindent (indent ["struct {\n"])
- >>| mapM_ (iindent o iindent o fmtCons) fs
- >>| iindent (indent ["} data;\n"])
- >>| indent ["}", if tl ";" ""]
- where
- fmtCons (ci, []) = pure ()
- fmtCons (ci, [t]) = ftd t False >>| tell [" ", safe ci.gcd_name, ";\n"]
- fmtCons (ci, ts)
- = indent ["struct {\n"]
- >>| mapM_ (iindent o fmtField) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
- >>| indent ["} ", safe ci.gcd_name, ";\n"]
- ftd t tl = 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, [consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
- ?Just _ = tell [consName ti]
-
- fmtField :: (String, Type) -> FTMonad
- fmtField (name, ty) = ftd ty False >>| tell [" ", name, ";\n"]
-
-:: TDMonad :== WriterT [String] (StateT TDState (Either String)) ()
-:: TDState :== ('Data.Map'.Map String (String, Bool), [String])
-typedefs :: [[Type]] -> Either String [String]
-typedefs ts = (\(text, (_, enums))->enums ++ text)
- <$> runStateT (execWriterT (mapM_ typedefgroup ts)) ('Data.Map'.newMap, [])
-where
- typedefgroup :: [Type] -> TDMonad
- typedefgroup ts
- = liftT (modify (appFst $ 'Data.Map'.putList [(typeName ty, (prefix ty, False))\\ty<-ts]))
- >>| mapM_ (\x->printTypeName x >>| tell [";\n"]) (if (ts=:[_,_:_]) (map typeName ts) [])
- >>| liftT (modify (appFst $ flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->True)) o typeName) ts))
- >>| mapM_ (\t->typedef t >>| tell ["\n"]) ts
-
- printTypeName :: String -> TDMonad
- printTypeName tname
- = liftT (gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o 'Data.Map'.get tname o fst)
- >>= tell
-
- typedef :: Type -> TDMonad
- typedef (TyRef s) = printTypeName s
- typedef (TyBasic t) = case t of
- BTInt = tell ["typedef uint64_t Int;"]
- BTChar = tell ["typedef char Char;"]
- BTReal = tell ["typedef double Real;"]
- BTBool = tell ["typedef bool Bool;"]
- t = fail $ "basic type: " +++ toString t +++ " not implemented"
- typedef (TyArray _ a) = tell ["*"] >>| typedef a
- typedef t=:(TyNewType ti ci a)
- = tydef ti.gtd_name ci.gcd_type
- typedef t=:(TyRecord ti fs)
- = tell ["struct ", safe ti.grd_name, " {\n"]
- >>| fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs]
- >>| tell ["};\n"]
- //Enumeration
- typedef t=:(TyObject ti fs)
- | and [t =: [] \\ (_, t)<-fs] = enum ti fs >>| tell [";\n"]
- //[consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
- //Single constructor, single field (box)
- typedef t=:(TyObject ti [(ci, [ty])]) = tydef ti.gtd_name ci.gcd_type
- //Single constructor
- typedef t=:(TyObject ti [(ci, ts)])
- = tell ["struct ", safe ti.gtd_name, " {\n"]
- >>| fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
- >>| tell ["};\n"]
- //Complex adt
- typedef t=:(TyObject ti fs) = tell
- ["struct ", safe ti.gtd_name, " {\n\t"]
- >>| enum ti fs >>| tell [" cons;\n\tstruct {\n"]
- //, consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
- >>| mapM_ fmtCons fs
- >>| tell ["\t} data;\n};\n"]
- where
- fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
- fmtCons (ci, []) = pure ()
- fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
- fmtCons (ci, ts) = tell ["\t\tstruct {\n"]
- >>| fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
- >>| tell ["\t\t} ", safe ci.gcd_name, ";\n"]
- typedef t = fail $ toString t +++ " not implemented"
-
- enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> TDMonad
- enum ti fs = liftT (modify (appSnd \xs->[consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n":xs]))
- >>| tell [consName ti]
-
- tydef :: String GenType -> TDMonad
- tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
-
- fmtFields :: Int GenType [String] -> TDMonad
- fmtFields i _ [] = pure ()
- fmtFields i (GenTypeArrow l r) [x:xs]
- = tell [createArray i '\t'] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs
-
- fmtField :: String GenType -> TDMonad
- fmtField x (GenTypeCons a) = printTypeName a >>| tell [x]
- fmtField x (GenTypeVar a) = tell ["void *",x]
- fmtField x (GenTypeApp l r) = fmtField x l
- fmtField x t=:(GenTypeArrow _ _)
- = mapM (fmap (concat o snd) o listen o fmtField "") (collectArgs t [])
- >>= \[r:as]->tell [r, " (*",x,")(",'Text'.join ", " as, ")"]
- where
- collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
- collectArgs t c = [t:c]
repositories / clean-tests.git / blobdiff