implementation module Data.GenC 

import StdEnv
import StdGeneric
import StdDebug

import Data.Map => qualified updateAt
import Data.Func

import Text
import Debug.Trace

//derive class gGenerateC (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)

derive bimap Structmaker, Box

toEnumValue :: GenericConsDescriptor -> String
toEnumValue gcd = gcd.gcd_type_def.gtd_name +++ "_" +++ gcd.gcd_name

toEnumType :: GenericTypeDefDescriptor -> String
toEnumType gtd = "enum cleanc_" +++ gtd.gtd_name

class toStructType a :: a -> String
instance toStructType GenericTypeDefDescriptor where
	toStructType gtd = "struct clean_" +++ gtd.gtd_name
instance toStructType GenericRecordDescriptor where
	toStructType grd = "struct clean_" +++ grd.grd_name

:: CInfo a = {header :: String , toValue :: a -> String}

runStructMaker :: (Structmaker a) -> String
runStructMaker (SM t)
# {defs,imps} = snd $ t {dict=newMap,fresh=0,inRecord=False} []
= end (elems defs) +++ end imps
where
	end d = concat [d +++ ";\n"\\d<-d]

generic gToCType a | gPotentialInf a :: Structmaker a
derive gToCType [], [! ], [ !], [!!]
derive gToCType (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
:: Structmaker a = SM (SMInput [String] -> ([String], SMOutput)) | Onzinconstructor a
runSM (SM a) = a
:: SMInput =
	{ fresh :: Int
	, inRecord :: Bool
	, dict :: Map String String
	}
:: SMOutput =
	{ defs :: Map String String
	, imps :: [String]
	}

instance + SMOutput where + a b = {defs=union a.defs b.defs, imps=a.imps++b.imps}
instance zero SMOutput where zero = {defs=newMap, imps=[]}

show :: String -> Structmaker a
show str = SM \st c->([str:c], zero)

gToCType{|Char|} = show "char"
gToCType{|Int|} = show "uint64_t"
gToCType{|Real|} = show "double"
gToCType{|Bool|} = show "bool"
gToCType{|UNIT|} = SM \st c->(c, zero)
gToCType{|EITHER|} fl il fr ir = SM \st c
	# (c, oa) = runSM fl st c
	# (c, ob) = runSM fr {st & dict=union st.dict oa.defs} c
	= (c, oa + ob)
gToCType{|PAIR|} fl il fr ir
	 = SM \st c
		# (c, oa) = runSM fr st c
		# st & dict = union st.dict oa.defs
		# (c, ob) = if st.inRecord
			(runSM fl st c)
			(runSM fl {st & fresh=st.fresh+1} [" f", toString st.fresh, ";\n":c])
		= (c, oa + ob)
gToCType{|OBJECT of gtd|} f i
	//Newtype
	| gtd.gtd_num_conses == 0
		= SM $ runSM f
	= SM \st c->case get gtd.gtd_name st.dict of
		Just n = ([n:c], zero)
		Nothing
			//Generate the enumeration if necessary
			# box = gtd.gtd_num_conses == 1
			# enums = \c->if box c
				[concat [toEnumType gtd, " {", join ", " (map toEnumValue gtd.gtd_conses), "}"]:c]
			//If it is just an enumeration, Just an enumeration
			| and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses]
				= ( [toEnumType gtd:c]
				  , {defs=singleton gtd.gtd_name $ toEnumType gtd,imps=enums []}
				)
			//Only one constructor
			# defs = singleton gtd.gtd_name (toStructType gtd +++ " *")
			# (c`, o) = runSM f {st & dict=union defs st.dict} (if box [] ["} data;\n}"])
			# obj = concat [toStructType gtd, "{\n":if box c` [toEnumType gtd, " cons;\nunion {\n":c`]]
			= ([toStructType gtd:if (isInfinite i) c [" *":c]], {defs=union o.defs defs, imps=enums [obj:o.imps]})
gToCType{|CONS of gcd|} f i
	//No data field
	| gcd.gcd_arity == 0 = SM \st c->(c, zero)
	//Only one data field
	| gcd.gcd_arity == 1 = SM \st c->runSM f st [" ", gcd.gcd_name, ";\n":c]
	//Multiple data fields
	= SM \st c
		# (c, o) = runSM f st [" f", toString (gcd.gcd_arity - 1), ";\n} ", gcd.gcd_name, ";\n":c]
		= (["struct {\n":c], o)
gToCType{|RECORD of grd|} f i
	= SM \st c
		# grd = trace_stdout grd
		# defs = singleton grd.grd_name (toStructType grd)
		# (c`, o) = runSM f {st & inRecord=True,dict=union defs st.dict} ["}"]
		# obj = concat [toStructType grd, " {\n":c`]
		= ([toStructType grd:c], {defs=union defs o.defs, imps=[obj:o.imps]})
gToCType{|FIELD of gfd|} f i
	= SM \s c->runSM f s [" ", gfd.gfd_name,";\n":c]
gToCType{|{}|} f i = SM \s c->runSM f s ["*":c]
gToCType{|{!}|} f i = SM \s c->runSM f s ["*":c]
gToCType{|{#}|} f i  = SM \s c->runSM f s ["*":c]

unBox (Box b) :== b
box b :== Box b

isInfinite :: ([String] -> Box Bool a) -> Bool
isInfinite f = unBox (f [])

generic gPotentialInf a :: [String] -> Box Bool a
derive gPotentialInf [], [! ], [ !], [!!]
derive gPotentialInf (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
gPotentialInf{|World|} _ = box False
gPotentialInf{|File|} _ = box False
gPotentialInf{|Bool|} _ = box False
gPotentialInf{|Char|} _ = box False
gPotentialInf{|Real|} _ = box False
gPotentialInf{|Int|} _ = box False
gPotentialInf{|Dynamic|} _ = box False
gPotentialInf{|(->)|} _ _ _ = box False
gPotentialInf{|{}|} a m = box (unBox (a m))
gPotentialInf{|{!}|} a m = box (unBox (a m))
gPotentialInf{|{#}|} a m = box (unBox (a m))
gPotentialInf{|UNIT|} _ = box False
gPotentialInf{|EITHER|} l r m = box (unBox (l m) || unBox (r m))
gPotentialInf{|PAIR|} l r m = box (unBox (l m) || unBox (r m))
gPotentialInf{|CONS|} x m = box (unBox (x m))
gPotentialInf{|FIELD|} x m = box (unBox (x m))
gPotentialInf{|RECORD of {grd_name}|} x m
	| isMember grd_name m = box True
	= box (unBox (x [grd_name:m]))
gPotentialInf{|OBJECT of {gtd_name}|} x m
	| isMember gtd_name m = box True
	= box (unBox (x [gtd_name:m]))