From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 21 Aug 2020 14:25:34 +0000 (+0200)
Subject: non flat parsers
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=ef1da130ffb2428deeeec0bfcd3e5511b2c50a5c;p=clean-tests.git

non flat parsers
---

diff --git a/gengen/Data/GenType/CParser.dcl b/gengen/Data/GenType/CParser.dcl
index 70da0b3..32b8066 100644
--- a/gengen/Data/GenType/CParser.dcl
+++ b/gengen/Data/GenType/CParser.dcl
@@ -3,13 +3,13 @@ definition module Data.GenType.CParser
 from Data.Either import :: Either
 from Data.GenType import :: Type
 
-/**
- * generate parsers for the types grouped by strongly connected components
- */
-parser :: [[Type]] -> Either String [String]
-
 /**
  * Generate a single parser for a type.
  * This does not terminate for a recursive type
  */
 flatParser :: Type -> Either String ([String], [String])
+
+/**
+ * generate parsers for the types grouped by strongly connected components
+ */
+parsers :: [[Type]] -> Either String [String]
diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl
index c363450..6616fac 100644
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/Data/GenType/CParser.icl
@@ -1,18 +1,22 @@
 implementation module Data.GenType.CParser
 
-import StdEnv
 import Control.Applicative
 import Control.Monad => qualified join
+import Control.Monad.Fail
+import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Trans
 import Control.Monad.Writer
-import Control.Monad.Reader
-import Control.Monad.Fail
 import Data.Either
 import Data.Func
 import Data.Functor
-import Data.Tuple
 import Data.List
+import qualified Data.Map
+from Data.Map import :: Map(..)
+import Data.Maybe
+import Data.Tuple
+import StdEnv
+import Text
 
 import Data.GenType
 import Data.GenType.CType
@@ -22,9 +26,16 @@ instance MonadFail (Either String) where fail s = Left s
 
 indent c = liftT ask >>= \i->tell [createArray i '\t':c]
 
+includes = "#include <stdint.h>\n#include <stdbool.h>\n"
+
+parsefun t = "parse_" +++ safe (typeName t)
+
 (<.>) infixr 6
 (<.>) a b = a +++ "." +++ b
 
+result r op s = indent [r, " ", op, " ", s, ";\n"]
+assign r s = result r "=" s
+
 /**
  * Generate a single parser for a type.
  * This does not terminate for a recursive type
@@ -32,14 +43,11 @@ indent c = liftT ask >>= \i->tell [createArray i '\t':c]
 flatParser :: Type -> Either String ([String], [String])
 flatParser t = tuple header <$> runReaderT (execWriterT (tell head >>| fpd t True "r" >>| tell tail)) 1
 where
-	includes = "#include <stdint.h>\n#include <stdbool.h>\n"
-	header = [includes:parsefun [";\n"]]
-	parsefun c = [prefix t, safe (typeName t), " parse_",  safe (typeName t), "(uint8_t (*get)(void))":c]
-	head = [includes:parsefun [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]]
+	header = [includes:parsedef [";\n"]]
+	parsedef c = [prefix t, safe (typeName t), parsefun t, "(uint8_t (*get)(void))":c]
+	head = [includes:parsedef [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]]
 	tail = ["\treturn r;\n}\n"]
 	parsename s = "parse_" +++ safe s
-	result r op s = indent [r, " ", op, " ", s, ";\n"]
-	assign r s = result r "=" s
 
 	fpd :: Type Bool String -> FPMonad
 	fpd (TyRef s) tl r = assign r (parsename s)
@@ -93,5 +101,87 @@ where
 /**
  * generate parsers for the types grouped by strongly connected components
  */
-parser :: [[Type]] -> Either String [String]
-parser _ = undef
+:: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
+:: TPState :== 'Data.Map'.Map String (String, Bool)
+parsers :: [[Type]] -> Either String [String]
+parsers ts = evalStateT (execWriterT (mapM_ parsergroup  ts)) 'Data.Map'.newMap
+where
+	parsergroup :: [Type] -> TPMonad
+	parsergroup ts
+		=   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
+		>>| mapM_ (\t->parser t >>| tell ["\n"]) ts
+
+	printTypeName :: String -> TPMonad
+	printTypeName tname
+		= liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
+		>>= tell
+
+	parser :: Type -> TPMonad
+	parser t=:(TyRef s) = tell [parsefun t]
+	parser (TyBasic t) 
+		= case t of
+			BTInt = tell ["\tr = (int64_t)get()<<54;\n"
+				, "\tr += (int64_t)get()<<48;\n"
+				, "\tr += (int64_t)get()<<40;\n"
+				, "\tr += (int64_t)get()<<32;\n"
+				, "\tr += (int64_t)get()<<24;\n"
+				, "\tr += (int64_t)get()<<16;\n"
+				, "\tr += (int64_t)get()<<8;\n"
+				, "\tr += (int64_t)get();\n"]
+			BTChar = tell ["\tr = (char)get();\n"]
+			BTReal = tell ["\tr = double;\n"]
+			BTBool = tell ["\tr = (bool)get();\n"]
+			t = fail $ "parser: there is no basic type for " +++ toString t
+	parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
+	parser (TyNewType ti ci a) = parser a
+	parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
+	parser (TyRecord ti fs)
+		= fmtFields 1 ti.grd_type ["r" <.> fi.gfd_name\\(fi, _)<-fs]
+	//Enumeration
+	parser (TyObject ti fs)
+		| and [t =: [] \\ (_, t)<-fs]
+			= tell ["\tr = (" +++ consName ti +++ ") get();\n"]
+	//Single constructor, single field (box)
+	parser (TyObject ti [(ci, [ty])]) = tell ["\tr = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
+	//Single constructor
+	parser t=:(TyObject ti [(ci, ts)])
+		= fmtFields 1 ci.gcd_type ["r.f" +++ toString i\\i<-indexList ts]
+	//Complex adt
+	parser (TyObject ti fs)
+		=   tell ["\tr.cons = (" +++ consName ti +++ ") get();\n"]
+		>>| tell ["\tswitch(r.cons) {\n"]
+		>>| mapM_ fmtCons fs
+		>>| tell ["\t}\n"]
+	where
+		fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
+		fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
+			>>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
+			>>| tell ["\t\tbreak;\n"]
+		where
+			cs i = "r.data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
+	parser t = fail $ "parser: unsupported type " +++ toString t
+
+	fmtFields :: Int GenType [String] -> TPMonad
+	fmtFields i _ [] = pure ()
+	fmtFields i (GenTypeArrow l r) [x:xs]
+		= tell [createArray i '\t', x, " = "] >>| fmtField l >>| tell [");\n"] >>| fmtFields i r xs
+
+	fmtField :: GenType -> TPMonad
+	fmtField (GenTypeCons a) = tell ["parse_", safe a, "(get"]
+	fmtField (GenTypeVar a) = tell ["parse_", toString a, "(get"]
+	fmtField t=:(GenTypeApp _ _)
+		= let [x:xs] = ufold t in fmtField x >>| case ufold t of
+			[] = tell [")"]
+			xs = tell [", "] >>| sequence_ (intersperse (tell [", "]) (map (\s->fmtField s >>| tell [")"]) xs))
+	where
+		ufold (GenTypeApp l r) = [l:ufold r]
+		ufold t = [t]
+
+//	fmtField x t=:(GenTypeArrow _ _)
+//		= mapM (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]
+//	| TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
+//	| TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index b359194..c56e408 100644
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -2,21 +2,21 @@ implementation module Data.GenType.CType
 
 import Control.Applicative
 import Control.Monad => qualified join
+import Control.Monad.Fail
+import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Trans
 import Control.Monad.Writer
-import Control.Monad.Reader
-import Control.Monad.Fail
 import Data.Either
 import Data.Func
 import Data.Functor
-import Data.Tuple
+import Data.GenType
+import Data.List
 import qualified Data.Map
 from Data.Map import :: Map(..)
 import Data.Maybe
-import Data.List
+import Data.Tuple
 import StdEnv
-import Data.GenType
 import Text
 
 instance MonadFail (Either String) where fail s = Left s
diff --git a/gengen/test.icl b/gengen/test.icl
index 122b099..e0e46ef 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -15,7 +15,7 @@ import Data.GenType
 import Data.GenType.CType
 import Data.GenType.CParser
 
-derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP
+derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest
 
 :: T a = T2 a Char
 :: NT =: NT Int
@@ -24,7 +24,7 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp,
 	f5 :: [([#Int], [#Int!], [!Int!], [!Int], [Int!])],
 	f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/
 	f7 :: {!Int}}
-:: Tr m b= Tr (m Int b)
+:: Tr m b= Tr (m Int b) | TrBork
 :: Frac a = (/.) infixl 7 a a  | Flurp
 :: Fix f = Fix (f (Fix f))
 
@@ -34,7 +34,8 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp,
 
 :: EnumList = ECons Enum EnumList | ENil
 
-:: ER = {nat :: T Int, bool :: Bool}
+:: ER = {nat :: Int, bool :: Bool}
+:: RA a = {a1 :: a, a2 :: Int}
 
 :: CP = CLeft Int Bool | CRight Char Char
 
@@ -50,6 +51,7 @@ Start =
 	( flatTypedef $ gTypeToType $ unBox t
 	, typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
 	, flatParser $ gTypeToType $ unBox t
+	, parsers $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
 	)
 
 //Start = typedefs //$ (\x->[[gTypeToType x]])
@@ -60,11 +62,12 @@ Start =
 //	$ flattenGType
 //	$ unBox t
 
+:: Nest m = Nest (m (m (m Int))) | NestBlurp
 
 //t :: Box GType (?# Int)
 //t :: Box GType (Maybe [Maybe (Either Bool String)])
 //t :: Box GType ([SR], Enum, T Int, NT, Blurp Int)
 //t :: Box GType [EnumList]
-t :: Box GType (Either (Int, Char) (?CP))
+t :: Box GType (Nest ?, Tr Either (?(Int, Enum)))
 //t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
 t = gType{|*|}