implementation module GenC

import StdEnv, StdGeneric, StdMaybe
import Data.Map => qualified updateAt
import Data.Func, Data.Tuple
import Data.Maybe
import Data.Either
import Data.List => qualified difference, union, find
import Text

import scc

derive bimap Box

potInf :: Box Bool a | gPotInf{|*|} a
potInf = gPotInf{|*|} []

generic gPotInf a :: [String] -> Box Bool a
gPotInf{|Int|} _ = box False
gPotInf{|Bool|} _ = box False
gPotInf{|Char|} _ = box False
gPotInf{|Real|} _ = box False
gPotInf{|World|} _ = box False
gPotInf{|Dynamic|} _ = box False
gPotInf{|c|} _ = box False
gPotInf{|UNIT|} _ = box False
gPotInf{|CONS|} f s = reBox (f s)
gPotInf{|FIELD|} f s = reBox (f s)
gPotInf{|EITHER|} fl fr s = box (unBox (fl s) || unBox (fr s))
gPotInf{|PAIR|} fl fr s = box (unBox (fl s) || unBox (fr s))
gPotInf{|OBJECT of {gtd_name}|} f s
	= if (isMember gtd_name s) (box True) (reBox (f [gtd_name:s]))
gPotInf{|RECORD of {grd_name}|} f s
	= if (isMember grd_name s) (box True) (reBox (f [grd_name:s]))

:: CType
	= CTTypeDef String
	| CTEnum [String]
	| CTStruct Int [(String, [(String, Bool, String, Maybe GenType)])]

:: GTSState = {dict :: Map String CType, ts :: [GenType]}
instance zero GTSState where zero = {dict=newMap, ts=[]}

toStruct :: Box GTSState a | gToStruct{|*|} a
toStruct = snd $ gToStruct{|*|} zero
generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
:: GTSResult
	= GTSType Bool String (Maybe GenType)//ispointer and the name
	| GTSTyVar Int
	| GTSUnit
	| GTSEither [GTSResult]
	| GTSPair [GTSResult]
	| GTSError

putst k v st = {st & dict=put k v st.dict}

import Debug.Trace
gToStruct{|Int|}  st = (GTSType False "uint64_t" $ listToMaybe st.ts, box st)
gToStruct{|Bool|} st = (GTSType False "bool" $ listToMaybe st.ts, box st)
gToStruct{|Char|} st = (GTSType False "char" $ listToMaybe st.ts, box st)
gToStruct{|Real|} st = (GTSType False "double" $ listToMaybe st.ts, box st)
gToStruct{|UNIT|} st = (GTSUnit, box st)
gToStruct{|CONS of {gcd_type}|} f _ st
	= appSnd reBox $ f {st & ts=pt gcd_type}
where
	pt (GenTypeArrow l r) = [l:pt r] 
	pt a = [a]

gToStruct{|FIELD|} f _ st = appSnd reBox $ f st
gToStruct{|EITHER|} fl _ fr _ st
	# (l, Box st) = fl st
	# (r, Box st) = fr st
	= (case (l, r) of
		(GTSEither l, GTSEither r) = GTSEither (l ++ r)
		(a, GTSEither l) = GTSEither [a:l]
		(l, r) = GTSEither [l, r]
	, box st)
gToStruct{|PAIR|} fl _ fr _ st=:{ts=[t:ts]}
	# (l, Box st) = fl {st & ts = [t]}
	# (r, Box st) = fr {st & ts = ts}
	= (case (l, r) of
		(GTSPair l, GTSPair r) = GTSPair (l ++ r)
		(a, GTSPair l) = GTSPair [a:l]
		(l, r) = GTSPair [l, r]
	, box st)
import Debug.Trace
gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
	# (Box isPInf) = i []
	= case get gtd_name st.dict of
		Just _ = (GTSType isPInf gtd_name $ listToMaybe st.ts, box st)
		Nothing
			//Newtype
			| gtd_num_conses == 0
				= case f st of
					(GTSType pi n mt, Box st) = (GTSType pi gtd_name mt, box $ putst gtd_name (CTTypeDef n) st)
			//If it is just an enumeration, Just the enum
			| and [gcd.gcd_arity == 0\\gcd<-gtd_conses]
				= (GTSType False gtd_name Nothing, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
			//Constructors with data fields
			# (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
			=
				( GTSType isPInf gtd_name Nothing
				, box $ putst gtd_name
					(CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
				)
	where
		mkty :: GTSResult -> [GTSResult]
		mkty (GTSEither l) = l
		mkty t = [t]

		mkccons :: GTSResult -> [GTSResult]
		mkccons (GTSType pi t a) = [GTSType pi t a]
		mkccons (GTSPair t) = t
		mkccons _ = []

		ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String, Maybe GenType)])
		ctcons gcd cons = (gcd.gcd_name, toT cons)
		where
			toT cons = [(t, pi, "f"+++toString i, mt)\\i<-[0..] & GTSType pi t mt<-cons]
gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st
	# (Box isPInf) = i []
	= case get grd_name st.dict of
		Just n = (GTSType isPInf grd_name Nothing, box st)
		Nothing
			# (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st
			= case n of
				GTSPair l =
					( GTSType isPInf grd_name Nothing
					, box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd, mt)\\GTSType pi t mt<-l & gfd<-grd_fields])]) st)
				_ = (GTSError, box st)

/**
 * Given a GTSState, generate typedefinitions
 */
toCType :: GTSState -> [String]
toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
where
	refs (CTTypeDef s) = [s]
	refs (CTEnum _) = []
	refs (CTStruct _ cs) = map (\(a, _, _, _)->a) (flatten (map snd cs))

	proc [] c = c
	proc [x] c = ctypedef x (find x m) c
	proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts
	where
		ts = [(x, find x m)\\x<-xs]
		prototype x c = ["struct ", x, ";\n":c]

	ctypedef :: String CType [String] -> [String]
	ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c]
	ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
	ctypedef name (CTStruct _ [(_, fs)]) c =
		[ "struct ", name, " {\n"
		: foldr (field 1)
		["};\n":c] fs
		]
	ctypedef name (CTStruct _ cs) c =
		[ "struct ", name, " {\n"
		: ind 1 ["enum {"
		: enum (map fst cs)
		["} cons;\n"
		: ind 1 ["union {\n"
		: foldr (uncurry struct)
			(ind 1 ["} data;\n};\n":c])
		cs]]]]

	struct name [] c = c
	struct name [(ty, pi, _, mt)] c = field 2 (ty, pi, name, mt) c
	struct name fs c = ind 2 ["struct {\n" :foldr (field 3) (ind 2 ["} ", name, ";\n":c]) fs]
	
	field i (ty, pi, name, gt) c
		= ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
	
	enum [] c = c
	enum [x] c = [x:c]
	enum [x:xs] c = [x, ",": enum xs c]

typeName ty m c = [case get ty m of
		Just (CTStruct _ _) = "struct "
		Just (CTEnum _) = "enum "
		_ = ""
	, ty:c]

ind n c = [createArray n '\t':c]

uncurry3 f (x,y,z) = f x y z

/**
 * Given a GTSState, generate a parser
 * @result Function signature
 * @result Function
 */
toCParser :: GTSState -> ([String], [String])
toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
where
	funsigs = foldr (uncurry funsig) [";\n"] $ toList m
	pfname n c = ["parse_", n:c]
	pfcall n Nothing c = pfname n ["(get, alloc, err);":c]
	pfcall n (Just t) c
		# (n, t) = trace_stdout (n, t)
		= pf t c
	where
		pf (GenTypeCons n) c = pfcall n Nothing c
		pf (GenTypeVar i) c = pfcall (toString i) Nothing c
		pf (GenTypeApp t (GenTypeVar i)) c
			= pf t $ pfcall (toString i) Nothing c
		pf _ c = c
//
//	pfcall n (Just (GenTypeVar i)) c = pfcall (toString i) Nothing c
//	pfcall n (Just (GenTypeApp (GenTypeCons _) (GenTypeVar i))) c
//		= pfcall (toString i) Nothing c
//	pfcall n (Just t) c
//		# (_, t, c, _) = trace_stdout ("\nblurp: ", t, c, "\n")
//		= c

//	pfcall n mt c = pfname n ["(get, alloc, err":(maybe id stycall mt) [");":c]]
//	where
//		stycall (GenTypeVar i) c
//			= [", ":pfname (toString i) c]
//		stycall (GenTypeApp (GenTypeCons _) (GenTypeVar i)) c
//			= [", ":pfname (toString i) c]
//		stycall _ c = c
	funsig n (CTStruct i _) c
		| i > 0
			= typeName n m [" "
			: pfname n ["(\n"
			: funargs 1
			$ foldr (\i c->
				[",\n":ind 1 ["void *(*parse_", toString i, ")(\n"
				: funargs 2 [")":c]]]) [")":c] [0..i-1]]]
	funsig n _ c = typeName n m [" ": pfname n ["(\n":funargs 1 [")":c]]]
	funbody (n, ty) c = funsig n ty
		["\n{\n"
		:ind 1 $ typeName n m [" r;\n"
		:funb ty $ ind 1 ["return r;\n}\n":c]]]
	funargs i c
		= ind i ["uint8_t (*get)(void),\n"
		: ind i ["void *(*alloc)(size_t size),\n"
		: ind i ["void (*err)(const char *errmsg, ...)"
		:c]]]

	funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a Nothing ["\n":c]]
	funb (CTEnum a) c = ind 1 ["r = get()\n":c]
	funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
	funb (CTStruct _ fs) c
		= ind 1 ["switch(r.cons = get()) {\n"
		:foldr field
		( ind 1 ["default:\n"
		: ind 2 ["break;\n"
		: ind 1 ["}\n":c]]]) fs]
	where
		field (n, []) c = c
		field (n, fs) c =
			ind 1 ["case ", n, ":\n"
			: foldr (sfield 2 ("r.data."+++ n))
			(ind 2 ["break;\n":c]) fs]

	sfield i r (ty, ptr, f, mt) c
		= (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c)
		$ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty mt ["\n":c]]

/**
 * Given a GTSState, generate a printer
 * @result Function signature
 * @result Function
 */
toCPrinter :: GTSState -> ([String], [String])
toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m))
where
	funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
	pfname n c = ["print_", n:c]
	pfcall r n c = pfname n ["(", r, ", put);":c]
	funsig n c =
		["void ":pfname n ["(\n"
		: ind 1 $ typeName n m [" r,\n"
		: ind 1 ["void (*put)(uint8_t))"
		:c]]]]
	funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]]

	funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c]
	funb (CTEnum a) c = ind 1 ["put(r)\n":c]
	funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
	funb (CTStruct _ fs) c =
		ind 1 ["put(r.cons);\n"
		: ind 1 ["switch(r.cons) {\n"
		:foldr field
		( ind 1 ["default:\n"
		: ind 2 ["break;\n"
		: ind 1 ["}\n":c]]]) fs]]
	where
		field (n, []) c = c
		field (n, fs) c
			= ind 1 ["case ", n, ":\n"
			: foldr (sfield 2 ("r.data."+++ n))
			(ind 2 ["break;\n":c]) fs]

	sfield i r (ty, ptr, f, mt) c
		= ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]

toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
toCValue a c = gToCValue{|*|} a c

gToCValue{|Char|} x c = [x:c]
gToCValue{|Int|} x c =
	[ toChar (x >> 56)
	, toChar (x >> 48)
	, toChar (x >> 40)
	, toChar (x >> 32)
	, toChar (x >> 24)
	, toChar (x >> 16)
	, toChar (x >> 8)
	, toChar x:c]
gToCValue{|Bool|} x c = [toChar (if x 1 0):c]
gToCValue{|UNIT|} x c = c
gToCValue{|EITHER|} l _ (LEFT x) c = l x c
gToCValue{|EITHER|} _ r (RIGHT x) c = r x c
gToCValue{|PAIR|} l r (PAIR x y) c = l x $ r y c
gToCValue{|CONS of {gcd_index}|} f (CONS x) c = [toChar gcd_index:f x c]
gToCValue{|FIELD|} f (FIELD x) c = f x c
gToCValue{|RECORD|} f (RECORD x) c = f x c
gToCValue{|OBJECT|} f (OBJECT x) c = f x c

fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
fromCValue i = gFromCValue{|*|} i

:: Parser a :== [Char] -> Either FromCValueError (a, [Char])
top :: Parser Char
top = satisfy (\_->True) CVEInputExhausted

satisfy :: (Char -> Bool) FromCValueError -> Parser Char
satisfy f e = \c->case c of
	[c:cs]
		| f c = Right (c, cs)
		      = Left e
	[] = Left CVEInputExhausted

yield :: a -> Parser a
yield a = \c->Right (a, c)

list :: [Parser a] -> Parser [a]
list [] = yield []
list [x:xs] = cons <<$>> x <<*>> list xs

cons x xs = [x:xs]

(<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b
(<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a

(<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b
(<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f

(<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a
(<<|>>) l r = \c->either (\_->r c) Right $ l c

int b = sum <<$>> list [(\x->toInt x << (i*8)) <<$>> top \\i<-[b-1,b-2..0]]
gFromCValue{|Char|} = top
gFromCValue{|Int|} = fromInt <<$>> int 8
gFromCValue{|Bool|} = ((==) '\1') <<$>> top
gFromCValue{|UNIT|} = yield UNIT
gFromCValue{|EITHER|} l r = (LEFT <<$>> l) <<|>> (RIGHT <<$>> r)
gFromCValue{|PAIR|} l r = PAIR <<$>> l <<*>> r
gFromCValue{|CONS of {gcd_index}|} f
	= (\x->CONS) <<$>> satisfy ((==)(toChar gcd_index)) CVEUnknownConstructor <<*>> f
gFromCValue{|FIELD|} f = (\x->FIELD x) <<$>> f
gFromCValue{|RECORD|} f = RECORD <<$>> f
gFromCValue{|OBJECT|} f = (\x->OBJECT x) <<$>> f

toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
toCFiles b=:(Box fn)
	# (padefs, paimp) = toCParser gts
	# (prdefs, primp) = toCPrinter gts
	=
		( flatten
			[["#ifndef ", guard, "\n"
			, "#define ", guard, "\n"
			, "#include <stdint.h>\n"
			, "#include <stddef.h>\n"
			, "#include <stdarg.h>\n"]
			, toCType gts, padefs, prdefs
			, ["#endif\n"]
			]
		, flatten
			[["#include \"", fn, ".h\"\n"]
			, paimp
			, primp]
		)
where
	guard = {safe c\\c<-:fn +++ ".h"}
	safe c
		| not (isAlphanum c) = '_'
		= toUpper c
	gts = unBox (cast b)

	cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a
	cast _ = toStruct