repositories
/
clean-tests.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
ca0986f
)
make writerT as well from non-flat typedef
author
Mart Lubbers
<mart@martlubbers.net>
Thu, 20 Aug 2020 13:43:58 +0000
(15:43 +0200)
committer
Mart Lubbers
<mart@martlubbers.net>
Thu, 20 Aug 2020 13:43:58 +0000
(15:43 +0200)
gengen/Data/GenType/CType.icl
patch
|
blob
|
history
diff --git
a/gengen/Data/GenType/CType.icl
b/gengen/Data/GenType/CType.icl
index
ec0d5fb
..
7caa64e
100644
(file)
--- a/
gengen/Data/GenType/CType.icl
+++ b/
gengen/Data/GenType/CType.icl
@@
-28,14
+28,13
@@
where
,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
+indent i c = tell [createArray i '\t':c]
+
:: 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
:: 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
ftd :: Type Bool Int -> FTMonad
ftd (TyRef s) tl i = indent i [s]
ftd (TyBasic t) tl i
@@
-91,21
+90,19
@@
where
fmtField :: Int (String, Type) -> FTMonad
fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
fmtField :: Int (String, Type) -> FTMonad
fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
-:: TDMonad :==
StateT TDState (Either String) [String]
+:: TDMonad :==
WriterT [String] (StateT TDState (Either String)) ()
:: TDState :== 'Data.Map'.Map String (String, Bool)
typedefs :: [[Type]] -> Either String [String]
:: TDState :== 'Data.Map'.Map String (String, Bool)
typedefs :: [[Type]] -> Either String [String]
-typedefs ts =
flatten <$> evalStateT (mapM typedefgroup ts
) 'Data.Map'.newMap
+typedefs ts =
evalStateT (execWriterT (mapM_ typedefgroup ts)
) 'Data.Map'.newMap
where
typedefgroup :: [Type] -> TDMonad
typedefgroup ts
where
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
+ = liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
+ >>| mapM_ (\t->typedef t >>| tell ["\n"]) ts
+ >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->False)) o typeName) ts))
+ >>| case ts of
+ [_] = tell []
+ ts = mapM_ (\x->printTypeName x >>| tell [";\n"]) (map typeName ts)
where
prefix :: Type -> String
prefix (TyRecord _ _) = "struct "
where
prefix :: Type -> String
prefix (TyRecord _ _) = "struct "
@@
-118,15
+115,11
@@
where
printTypeName :: String -> TDMonad
printTypeName tname
printTypeName :: String -> TDMonad
printTypeName tname
- = gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o 'Data.Map'.get tname
+ = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
+ >>= tell
- 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]
+ header :: Type [String] -> WriterT [String] m () | Monad m
+ header t c = tell ["// ", toString (replaceBuiltins t), "\n":c]
typedef :: Type -> TDMonad
typedef (TyRef s) = printTypeName s
typedef :: Type -> TDMonad
typedef (TyRef s) = printTypeName s
@@
-135,52
+128,58
@@
where
BTChar = printTypeName "char"
BTReal = printTypeName "double"
BTBool = printTypeName "bool"
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
+ t =
fail
$ "basic type: " +++ toString t +++ " not implemented"
+ typedef (TyArray _ a) =
tell ["*"] >>|
typedef a
typedef t=:(TyNewType ti ci 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"]
+ = 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]
+ >>| tell ["};\n"]
//Enumeration
typedef t=:(TyObject ti fs)
| and [t =: [] \\ (_, t)<-fs] = header t
//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 []
+ ["enum ", safe ti.gtd_name, "
_cons
{"
+ , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
//Single constructor, single field (box)
//Single constructor, single field (box)
- typedef t=:(TyObject ti [(ci, [ty])]) = header t []
$
tydef ti.gtd_name ci.gcd_type
+ typedef t=:(TyObject ti [(ci, [ty])]) = header t []
>>|
tydef ti.gtd_name ci.gcd_type
//Single constructor
//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"]
+ 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]
+ >>| tell ["};\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"]
//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
+
>>| mapM_
fmtCons fs
+ >>
| tell ["\t} data;\n};\n"]
where
fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
where
fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
- fmtCons (ci, []) =
pure
[]
+ fmtCons (ci, []) =
tell
[]
fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
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"
+ 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"
tydef :: String GenType -> TDMonad
tydef :: String GenType -> TDMonad
- tydef name (GenTypeArrow l r) =
pre ["typedef "] $ fmtField "" l >>= post
[safe name,";\n"]
+ tydef name (GenTypeArrow l r) =
tell ["typedef "] >>| fmtField "" l >>| tell
[safe name,";\n"]
fmtFields :: Int GenType [String] -> TDMonad
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
+ fmtFields i _ [] = tell []
+ fmtFields i (GenTypeArrow l r) [x:xs]
+ = indent i [] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs
fmtField :: String GenType -> TDMonad
fmtField :: String GenType -> TDMonad
- fmtField x (GenTypeCons a) = printTypeName a >>
= post
[x]
- fmtField x (GenTypeVar a) =
pure
["void *",x]
+ 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 (GenTypeApp l r) = fmtField x l
- fmtField x t=:(GenTypeArrow _
r
)
- = map
concat <$> mapM (
fmtField "") (collectArgs t [])
- >>= \[r:as]->
pure
[r, " (*",x,")(",join ", " as, ")"]
+ fmtField x t=:(GenTypeArrow _
_
)
+ = map
M (fmap (concat o snd) o listen o
fmtField "") (collectArgs t [])
+ >>= \[r:as]->
tell
[r, " (*",x,")(",join ", " as, ")"]
where
collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
collectArgs t c = [t:c]
where
collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
collectArgs t c = [t:c]