From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 10 Jul 2020 07:09:12 +0000 (+0200)
Subject: yes
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=19bc0b989992b4a3a3cde284a95b2e81c674e4e5;p=clean-tests.git

yes
---

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
index 8bef27a..a073c6b 100644
--- a/gengen/Data/GenType.dcl
+++ b/gengen/Data/GenType.dcl
@@ -56,7 +56,7 @@ flattenGType :: GType -> [[GType]]
  * @param gtype
  * @result a type on success
  */
-gTypeToType :: GType -> Maybe Type
+gTypeToType :: GType -> Type
 
 /**
  * Gives the name for the type
diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index 64b804d..e6cfe8b 100644
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -164,30 +164,31 @@ instance toString GenType where toString a = concat $ print a []
 isperse :: a [[a] -> [a]] [a] -> [a]
 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
 
-gTypeToType :: GType -> Maybe Type
-gTypeToType (GTyBasic a) = pure $ TyBasic a
-gTypeToType (GTyRef a) = pure $ TyRef a
-gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
-gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
-gTypeToType (GTyUList s a) = TyUList s <$> gTypeToType a
-gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
+gTypeToType :: GType -> Type
+gTypeToType (GTyBasic a) = TyBasic a
+gTypeToType (GTyRef a) = TyRef a
+gTypeToType (GTyArrow l r) = TyArrow (gTypeToType l) (gTypeToType r)
+gTypeToType (GTyArray s a) = TyArray s (gTypeToType a)
+gTypeToType (GTyUList s a) = TyUList s (gTypeToType a)
+gTypeToType (GTyRecord i t) = TyRecord i (gtrec t [])
 where
-	gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
-	gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
-	gtrec _ = Nothing
+	gtrec :: GType [(GenericFieldDescriptor, Type)] -> [(GenericFieldDescriptor, Type)]
+	gtrec (GTyField i t) c = [(i, gTypeToType t):c]
+	gtrec (GTyPair l r) c = gtrec l $ gtrec r c
+	gtrec _ c = c
 gTypeToType (GTyObject i=:{gtd_num_conses=0} t)
-	= TyNewType i (hd i.gtd_conses) <$> gTypeToType t
-gTypeToType (GTyObject i t) = TyObject i <$> gtobj t
+	= TyNewType i (hd i.gtd_conses) (gTypeToType t)
+gTypeToType (GTyObject i t) = TyObject i (gtobj t [])
 where
-	gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
-	gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
-	gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
-	gtobj _ = Nothing
+	gtobj :: GType [(GenericConsDescriptor, [Type])] -> [(GenericConsDescriptor, [Type])]
+	gtobj (GTyEither l r) c = gtobj l $ gtobj r c
+	gtobj (GTyCons i a) c = [(i, gtcons a []):c]
+	gtobj _ c = c
 	
-	gtcons :: GType -> Maybe [Type]
-	gtcons GTyUnit = pure []
-	gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
-	gtcons t = (\x->[x]) <$> gTypeToType t
+	gtcons :: GType [Type] -> [Type]
+	gtcons GTyUnit c = c
+	gtcons (GTyPair l r) c = gtcons l $ gtcons r c
+	gtcons t c = [gTypeToType t:c]
 
 :: FlatMonad :== State FMState GType
 :: FMState = { objects :: [String], types :: [GType], otypes :: [GType], depth :: Int }
diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index d8ba99b..3ce9216 100644
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -22,8 +22,10 @@ typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) { tinfo = [] }
 typedefgroup :: [Type] -> TDMonad
 typedefgroup ts
 	=   flatten
-	<$  mapM (\t->modify \s->{s & tinfo=[(typeName t, if (ts =: [_]) (maybeInfinite t) True):s.tinfo]}) ts
+//	<$  mapM (\t->modify \s->{s & tinfo=[(typeName t, True):s.tinfo]}) ts
+	<$  modify (\s->{s & tinfo=[(typeName t, True)\\t<-ts] ++ s.tinfo})
 	<*> mapM (\t->typedef t >>= post ["\n"]) ts
+	<*  modify (\s->{s & tinfo=[(typeName t, maybeInfinite t)\\t<-ts] ++ s.tinfo})
 where
 	maybeInfinite :: Type -> Bool
 	maybeInfinite t = False
@@ -38,7 +40,6 @@ pre t s = ((++)t) <$> s
 post :: [String] [String] -> m [String] | pure m
 post t s = pure (s ++ t)
 
-import StdDebug
 typedef :: Type -> TDMonad
 typedef (TyRef s) = printTypeName s
 typedef (TyBasic BTInt) = pure [IF_INT_64_OR_32 "int64_t" "int32_t"]
@@ -50,8 +51,7 @@ typedef t=:(TyNewType ti ci a)
 	= pre ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
 typedef t=:(TyRecord ti fs) = pre
 	[ "// ", toString t, "\n", "struct ", ti.grd_name, " {\n"]
-	$ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs]
-	>>= post ["};\n"]
+	$ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs] >>= post ["};\n"]
 //Enumeration
 typedef t=:(TyObject ti fs)
 	| and [t =: [] \\ (_, t)<-fs] = pure
@@ -63,8 +63,7 @@ typedef t=:(TyObject ti [(ci, [ty])]) = pre
 //Single constructor
 typedef t=:(TyObject ti [(ci, ts)]) = pre
 	[ "// ", toString t, "\n", "struct ", ti.gtd_name, " {\n"]
-	$ fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
-	>>= post ["};\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"
diff --git a/gengen/test.icl b/gengen/test.icl
index 27fcd7d..2a59baa 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -14,7 +14,7 @@ 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
+derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp
 
 :: T a =: T2 a
 :: NT =: NT Int
@@ -28,6 +28,8 @@ derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT
 
 :: List a = Cons a (List a) | Nil
 
+:: Blurp a = Blurp (List a) | Blorp
+
 ////Start :: [String]
 ////Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
 //:: Pair a b = Pair a b
@@ -36,17 +38,17 @@ derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT
 :: Odd a = Odd (Even a) | OddBlurp
 :: Even a = Even (Odd a) | EvenBlurp
 :: Enum = A | B | C
-Start = typedefs
+Start = typedefs //$ (\x->[[gTypeToType x]])
 //	$ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
-//	$ flattenGType
-	$ (\x->[[fromJust x]])
-	$ gTypeToType
+//	$ (\x->[[x]])
+	$ map (map gTypeToType)
+	$ flattenGType
 	$ unBox t
 //
 //
 //t :: Box GType (?# Int)
 //t :: Box GType (Maybe [Maybe (Either Bool String)])
-t :: Box GType ([SR], Enum, T Int, NT)
+t :: Box GType ([SR], Enum, T Int, NT, Blurp Int)
 //t :: Box GType (Tr Either Enum)
 //t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
 t = gType{|*|}