1 implementation module Data.GenType
3 import StdEnv, StdGeneric, StdMaybe
4 import Control.Applicative
6 import Control.Monad => qualified join
7 import Control.Monad.State
9 import Control.Monad.Writer
10 import Control.Monad.Trans
13 import Data.Functor.Identity
20 derive gEq BasicType, UListType, ArrayType, GenType
21 instance == BasicType where (==) a b = a === b
22 instance == UListType where (==) a b = a === b
23 instance == ArrayType where (==) a b = a === b
24 instance == GenType where (==) a b = a === b
25 instance == GType where (==) x y = gTypeEqShallow (2<<30-1) x y
28 * Compares two GTypes only up to a given depth
35 gTypeEqShallow :: Int GType GType -> Bool
38 gTypeEqShallow _ (GTyBasic i) (GTyBasic j) = i == j
39 gTypeEqShallow _ (GTyRef i) (GTyRef j) = i == j
40 gTypeEqShallow _ (GTyRef i) (GTyObject j _) = i == j.gtd_name
41 gTypeEqShallow _ (GTyRef i) (GTyRecord j _) = i == j.grd_name
42 gTypeEqShallow _ (GTyObject j _) (GTyRef i) = i == j.gtd_name
43 gTypeEqShallow _ (GTyRecord j _) (GTyRef i) = i == j.grd_name
44 gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
45 gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
46 gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
47 gTypeEqShallow _ GTyUnit GTyUnit = True
48 gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
49 gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
50 gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
51 gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
52 = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
53 gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
54 = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
55 gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
56 = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
57 gTypeEqShallow _ _ _ = False
61 (==) (TyBasic a1) (TyBasic a2) = a1 == a2
62 (==) (TyRef a1) (TyRef a2) = a1 == a2
63 (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
64 (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
65 (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
66 (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
67 = i1.gtd_name == i2.gtd_name && a1 == a2
68 (==) (TyObject i1 a1) (TyObject i2 a2)
69 = i1.gtd_name == i2.gtd_name && length a1 == length a2
70 && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
71 (==) (TyRecord i1 a1) (TyRecord i2 a2)
72 = i1.grd_name == i2.grd_name && length a1 == length a2
73 && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
76 class print a :: a [String] -> [String]
77 instance print Bool where print s c = [toString s:c]
78 instance print Int where print s c = [toString s:c]
79 instance print Char where print s c = [toString s:c]
80 instance print String where print s c = [s:c]
81 instance print BasicType
83 print BTInt c = ["Int":c]
84 print BTChar c = ["Char":c]
85 print BTReal c = ["Real":c]
86 print BTBool c = ["Bool":c]
87 print BTDynamic c = ["Dynamic":c]
88 print BTFile c = ["File":c]
89 print BTWorld c = ["World":c]
90 instance print UListType
92 print ULStrict c = ["!":c]
94 instance print ArrayType
96 print AStrict c = ["!":c]
97 print AUnboxed c = ["#":c]
98 print APacked c = ["32#":c]
102 print (GTyBasic s) c = print s c
103 print (GTyRef s) c = [s:c]
104 print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
105 print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
106 print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
107 print GTyUnit c = ["UNIT":c]
108 print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
109 print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
110 print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
111 print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
112 print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
113 print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
116 print (TyBasic s) c = print s c
117 print (TyRef s) c = [s:c]
118 print (TyArrow l r) c = print l [" -> ":print r c]
119 print (TyArray s a) c = ["{":print s ["}":print a c]]
120 print (TyUList s a) c = ["[#":print s ["]":print a c]]
121 print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
122 [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
124 nttype (GenTypeArrow l r) = l
125 print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
126 [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
127 print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
128 $ [" ":isperse " | " (map pCons conses) c]
130 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
131 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
133 n c = case i.gcd_prio of
134 GenConsNoPrio = [i.gcd_name:c]
135 GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
136 GenConsAssocRight = "r";
137 GenConsAssocLeft = "l"
138 _ = "", " ":print s c]
140 pTyVars :: String Int [String] -> [String]
141 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
143 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
145 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
147 instance print GenType
149 print (GenTypeVar i) c = print (['a'..] !! i) c
150 print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
152 collectApps (GenTypeApp l r) c = collectApps l [print r:c]
153 collectApps a c = [print a:c]
154 print (GenTypeCons s) c = [s:c]
155 print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
157 instance toString GType where toString a = concat $ print a []
158 instance toString Type where toString a = concat $ print a []
159 instance toString BasicType where toString a = concat $ print a []
160 instance toString ArrayType where toString a = concat $ print a []
161 instance toString UListType where toString a = concat $ print a []
162 instance toString GenType where toString a = concat $ print a []
164 isperse :: a [[a] -> [a]] [a] -> [a]
165 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
167 gTypeToType :: GType -> Maybe Type
168 gTypeToType (GTyBasic a) = pure $ TyBasic a
169 gTypeToType (GTyRef a) = pure $ TyRef a
170 gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
171 gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
172 gTypeToType (GTyUList s a) = TyUList s <$> gTypeToType a
173 gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
175 gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
176 gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
178 gTypeToType (GTyObject i=:{gtd_num_conses=0} t)
179 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
180 gTypeToType (GTyObject i t) = TyObject i <$> gtobj t
182 gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
183 gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
184 gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
187 gtcons :: GType -> Maybe [Type]
188 gtcons GTyUnit = pure []
189 gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
190 gtcons t = (\x->[x]) <$> gTypeToType t
192 :: FlatMonad :== State FMState GType
193 :: FMState = { objects :: [String], types :: [GType], otypes :: [GType], depth :: Int }
194 flattenGType :: GType -> [[GType]]
196 # {types} = execState (mkf ot) {objects=[], otypes=[], types=[], depth=10}
197 = scc [(t, refs t [])\\t<-types]
199 refs (GTyObject _ a) c = refs a c
200 refs (GTyRecord _ a) c = refs a c
201 refs (GTyEither l r) c = refs l $ refs r c
202 refs (GTyPair l r) c = refs l $ refs r c
203 refs (GTyCons _ a) c = refs a c
204 refs (GTyField _ a) c = refs a c
206 refs (GTyArrow l r) c = refs l $ refs r c
207 refs (GTyArray _ a) c = refs a c
208 refs (GTyUList _ a) c = refs a c
209 refs (GTyBasic _) c = c
210 refs a=:(GTyRef _) c = [a:c]
212 write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
213 write cons t a = getState >>= \s
214 //We have seen the type but it might've had different arguments
215 | isMember name s.objects
216 //We have not seen this configuration
217 | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
218 = modify (\x->{x & depth=dec x.depth}) *> mkf a *> pure (GTyRef name)
219 //If not, just return the basictype
221 //We have not seen the type so we add, calculate and output it
222 = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
223 >>= \ty->addIfNotThere ty >>| pure (GTyRef name)
225 name = genericDescriptorName t
227 addIfNotThere :: GType -> FlatMonad
228 addIfNotThere ty = getState >>= \s
229 | isMember ty s.types
231 = modify (\s->{s & types=[ty:s.types]}) >>| pure ty
233 mkf :: GType -> FlatMonad
234 mkf (GTyObject t a) = write GTyObject t a
235 mkf (GTyRecord t a) = write GTyRecord t a
236 mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
237 mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
238 mkf (GTyCons i a) = GTyCons i <$> mkf a
239 mkf (GTyField i a) = GTyField i <$> mkf a
240 mkf GTyUnit = pure GTyUnit
241 mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
242 mkf (GTyArray s a) = GTyArray s <$> mkf a
243 mkf (GTyUList s a) = GTyUList s <$> mkf a
244 mkf a=:(GTyBasic _) = addIfNotThere a
245 mkf a=:(GTyRef _) = pure a
247 typeName :: Type -> String
248 typeName (TyBasic a) = toString a
249 typeName (TyRef a) = a
250 typeName (TyArrow l r) = typeName l +++ "->" +++ typeName r
251 typeName (TyArray s a) = "{" +++ toString s +++ typeName a +++ "}"
252 typeName (TyUList s a) = "{" +++ toString s +++ typeName a +++ "}"
253 typeName (TyNewType i _ _) = i.gtd_name
254 typeName (TyObject i _) = i.gtd_name
255 typeName (TyRecord i _) = i.grd_name
257 instance isBuiltin String
259 isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_]
260 instance isBuiltin Type
262 isBuiltin (TyObject i a) = isBuiltin i.gtd_name
263 isBuiltin (TyRecord i a) = isBuiltin i.grd_name
264 isBuiltin (TyRef a) = isBuiltin a
266 instance isBuiltin GType
268 isBuiltin (GTyObject i a) = isBuiltin i.gtd_name
269 isBuiltin (GTyRecord i a) = isBuiltin i.grd_name
270 isBuiltin (GTyRef a) = isBuiltin a
273 instance replaceBuiltins GenericFieldDescriptor
275 replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}
276 instance replaceBuiltins GenericConsDescriptor
278 replaceBuiltins s = {s & gcd_name=replaceBuiltins s.gcd_name, gcd_type=replaceBuiltins s.gcd_type}
279 instance replaceBuiltins GenericTypeDefDescriptor
281 replaceBuiltins s = {s & gtd_name=replaceBuiltins s.gtd_name}
282 instance replaceBuiltins GenericRecordDescriptor
284 replaceBuiltins s = {s & grd_name=replaceBuiltins s.grd_name, grd_type=replaceBuiltins s.grd_type}
285 instance replaceBuiltins String
287 replaceBuiltins a = fromMaybe a $ lookup a predef
288 instance replaceBuiltins Type
290 replaceBuiltins (TyRef a) = TyRef (replaceBuiltins a)
291 replaceBuiltins (TyArrow l r) = TyArrow (replaceBuiltins l) (replaceBuiltins r)
292 replaceBuiltins (TyArray s a) = TyArray s (replaceBuiltins a)
293 replaceBuiltins (TyUList s a) = TyUList s (replaceBuiltins a)
294 replaceBuiltins (TyNewType i j a) = TyNewType (replaceBuiltins i) (replaceBuiltins j) (replaceBuiltins a)
295 replaceBuiltins (TyObject i cs) = TyObject (replaceBuiltins i) [(replaceBuiltins i, map replaceBuiltins fs)\\(i, fs)<-cs]
296 replaceBuiltins (TyRecord j fs) = TyRecord (replaceBuiltins j) [(replaceBuiltins i, replaceBuiltins a)\\(i, a)<-fs]
297 replaceBuiltins t = t
298 instance replaceBuiltins GType
300 replaceBuiltins (GTyEither l r) = GTyEither (replaceBuiltins l) (replaceBuiltins r)
301 replaceBuiltins (GTyPair l r) = GTyPair (replaceBuiltins l) (replaceBuiltins r)
302 replaceBuiltins (GTyArrow l r) = GTyArrow (replaceBuiltins l) (replaceBuiltins r)
303 replaceBuiltins (GTyArray s a) = GTyArray s (replaceBuiltins a)
304 replaceBuiltins (GTyUList s a) = GTyUList s (replaceBuiltins a)
305 replaceBuiltins (GTyObject i a) = GTyObject (replaceBuiltins i) (replaceBuiltins a)
306 replaceBuiltins (GTyRecord i a) = GTyRecord (replaceBuiltins i) (replaceBuiltins a)
307 replaceBuiltins (GTyCons i a) = GTyCons (replaceBuiltins i) (replaceBuiltins a)
308 replaceBuiltins (GTyField i a) = GTyField (replaceBuiltins i) (replaceBuiltins a)
309 replaceBuiltins (GTyRef a) = GTyRef (replaceBuiltins a)
310 replaceBuiltins a = a
311 instance replaceBuiltins GenType
313 replaceBuiltins (GenTypeCons a) = GenTypeCons (replaceBuiltins a)
314 replaceBuiltins (GenTypeApp l r) = GenTypeApp (replaceBuiltins l) (replaceBuiltins r)
315 replaceBuiltins (GenTypeArrow l r) = GenTypeArrow (replaceBuiltins l) (replaceBuiltins r)
316 replaceBuiltins a = a
318 predef :: [(String, String)]
320 [ ("_List", "[]"), ("_Cons", "(:)"), ("_Nil", "[]")
321 , ("_!List", "[! ]"), ("_!Cons", "(:)"), ("_!Nil", "[! ]")
322 , ("_List!", "[ !]"), ("_Cons!", "(:)"), ("_Nil!", "[ !]")
323 , ("_!List!", "[!!]"), ("_!Cons!", "(:)"), ("_!Nil!", "[ !]")
324 , ("_#List", "[#]"), ("_#Cons", "(:)"), ("_#Nil", "[#]")
325 , ("_#List!", "[#!]"), ("_#Cons!", "(:)"), ("_#Nil!", "[#!]")
326 , ("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}"), ("_32#Array", "{32#}")
328 :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
330 generic type a :: Box GType a
331 gType{|UNIT|} = box GTyUnit
332 gType{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
333 gType{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
334 gType{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
335 gType{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
336 gType{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
337 gType{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
338 gType{|Int|} = box $ GTyBasic BTInt
339 gType{|Bool|} = box $ GTyBasic BTBool
340 gType{|Real|} = box $ GTyBasic BTReal
341 gType{|Char|} = box $ GTyBasic BTChar
342 gType{|World|} = box $ GTyBasic BTWorld
343 gType{|Dynamic|} = box $ GTyBasic BTDynamic
344 gType{|File|} = box $ GTyBasic BTFile
345 gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
346 gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
347 gType{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
348 gType{|{}|} a = box $ GTyArray ALazy $ unBox a
349 gType{|{!}|} a = box $ GTyArray AStrict $ unBox a
350 gType{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
351 gType{|{32#}|} a = box $ GTyArray APacked $ unBox a
352 derive gType ?#, ?, ?^
353 derive gType [], [! ], [ !], [!!]
354 derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)