:: CType
= CTTypeDef String
| CTEnum [String]
- | CTStruct Int [(String, [(String, Bool, String)])]
+ | CTStruct Int [(String, [(String, Bool, String, Maybe GenType)])]
-:: GTSState = {dict :: Map String CType}
-instance zero GTSState where zero = {dict=newMap}
+:: 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 //ispointer and the name
+ = GTSType Bool String (Maybe GenType)//ispointer and the name
+ | GTSTyVar Int
| GTSUnit
| GTSEither [GTSResult]
| GTSPair [GTSResult]
putst k v st = {st & dict=put k v st.dict}
-gToStruct{|Int|} st = (GTSType False "uint64_t", box st)
-gToStruct{|Bool|} st = (GTSType False "bool", box st)
-gToStruct{|Char|} st = (GTSType False "char", box st)
-gToStruct{|Real|} st = (GTSType False "double", box st)
+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|} f _ st = appSnd reBox $ f 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
(a, GTSEither l) = GTSEither [a:l]
(l, r) = GTSEither [l, r]
, box st)
-gToStruct{|PAIR|} fl _ fr _ st
- # (l, Box st) = fl st
- # (r, Box st) = fr 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]
import Debug.Trace
gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
# (Box isPInf) = i []
- # ty = GTSType isPInf
= case get gtd_name st.dict of
- Just _ = (GTSType isPInf gtd_name, box st)
+ Just _ = (GTSType isPInf gtd_name $ listToMaybe st.ts, box st)
Nothing
//Newtype
| gtd_num_conses == 0
= case f st of
- (GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st)
+ (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, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
+ = (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
+ ( GTSType isPInf gtd_name Nothing
, box $ putst gtd_name
(CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
)
mkty t = [t]
mkccons :: GTSResult -> [GTSResult]
- mkccons (GTSType pi t) = [GTSType pi t]
+ mkccons (GTSType pi t a) = [GTSType pi t a]
mkccons (GTSPair t) = t
mkccons _ = []
- ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
- ctcons gcd cons
- # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
- = (gcd_name, toT cons)
+ 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)\\i<-[0..] & GTSType pi t<-cons]
+ 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, box st)
+ 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
- , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
+ ( 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)
/**
where
refs (CTTypeDef s) = [s]
refs (CTEnum _) = []
- refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
+ refs (CTStruct _ cs) = map (\(a, _, _, _)->a) (flatten (map snd cs))
proc [] c = c
proc [x] c = ctypedef x (find x m) c
ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
ctypedef name (CTStruct _ [(_, fs)]) c =
[ "struct ", name, " {\n"
- : foldr (uncurry3 (field 1))
+ : foldr (field 1)
["};\n":c] fs
]
ctypedef name (CTStruct _ cs) c =
cs]]]]
struct name [] c = c
- struct name [(ty, pi, _)] c = field 2 ty pi name c
- struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs]
+ 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 c
+ field i (ty, pi, name, gt) c
= ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
enum [] c = c
where
funsigs = foldr (uncurry funsig) [";\n"] $ toList m
pfname n c = ["parse_", n:c]
- pfcall n c = pfname n ["(get, alloc, err);":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 [" "
: ind i ["void (*err)(const char *errmsg, ...)"
:c]]]
- funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":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
: foldr (sfield 2 ("r.data."+++ n))
(ind 2 ["break;\n":c]) fs]
- sfield i r (ty, ptr, f) c
+ 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 ["\n":c]]
+ $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty mt ["\n":c]]
/**
* Given a GTSState, generate a printer
: foldr (sfield 2 ("r.data."+++ n))
(ind 2 ["break;\n":c]) fs]
- sfield i r (ty, ptr, f) c
+ 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
repositories / clean-tests.git / blobdiff