1 implementation module Data.GenType
3 import StdEnv, StdGeneric
4 import Control.Applicative
7 import Control.Monad.State
9 import Control.Monad.Writer
10 import Control.Monad.Trans
13 import Data.Functor.Identity
17 from Text import class Text(concat), instance Text String
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 i (GTyUMaybe a1) (GTyUMaybe a2) = gTypeEqShallow (dec i) a1 a2
48 gTypeEqShallow _ GTyUnit GTyUnit = True
49 gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
50 gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
51 gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
52 gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
53 = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
54 gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
55 = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
56 gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
57 = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
58 gTypeEqShallow _ _ _ = False
62 (==) (TyBasic a1) (TyBasic a2) = a1 == a2
63 (==) (TyRef a1) (TyRef a2) = a1 == a2
64 (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
65 (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
66 (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
67 (==) (TyUMaybe a1) (TyUMaybe a2) = a1 == a2
68 (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
69 = i1.gtd_name == i2.gtd_name && a1 == a2
70 (==) (TyObject i1 a1) (TyObject i2 a2)
71 = i1.gtd_name == i2.gtd_name && length a1 == length a2
72 && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
73 (==) (TyRecord i1 a1) (TyRecord i2 a2)
74 = i1.grd_name == i2.grd_name && length a1 == length a2
75 && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
78 class print a :: a [String] -> [String]
79 instance print Bool where print s c = [toString s:c]
80 instance print Int where print s c = [toString s:c]
81 instance print Char where print s c = [toString s:c]
82 instance print String where print s c = [s:c]
83 instance print BasicType
85 print BTInt c = ["Int":c]
86 print BTChar c = ["Char":c]
87 print BTReal c = ["Real":c]
88 print BTBool c = ["Bool":c]
89 print BTDynamic c = ["Dynamic":c]
90 print BTFile c = ["File":c]
91 print BTWorld c = ["World":c]
92 instance print UListType
94 print ULStrict c = ["!":c]
96 instance print ArrayType
98 print AStrict c = ["!":c]
99 print AUnboxed c = ["#":c]
100 print APacked c = ["32#":c]
104 print (GTyBasic s) c = print s c
105 print (GTyRef s) c = [s:c]
106 print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
107 print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
108 print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
109 print (GTyUMaybe a) c = ["?#":print a ["]":c]]
110 print GTyUnit c = ["UNIT":c]
111 print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
112 print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
113 print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
114 print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
115 print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
116 print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
119 print (TyBasic s) c = print s c
120 print (TyRef s) c = [s:c]
121 print (TyArrow l r) c = print l [" -> ":print r c]
122 print (TyArray s a) c = ["{":print s ["}":print a c]]
123 print (TyUList s a) c = ["[#":print s ["]":print a c]]
124 print (TyUMaybe a) c = ["?#":print a c]
125 print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
126 [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
128 nttype (GenTypeArrow l r) = l
129 print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
130 [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
131 print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
132 $ [" ":isperse " | " (map pCons conses) c]
134 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
135 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
137 n c = case i.gcd_prio of
138 GenConsNoPrio = [i.gcd_name:c]
139 GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
140 GenConsAssocRight = "r";
141 GenConsAssocLeft = "l"
142 _ = "", " ":print s c]
144 pTyVars :: String Int [String] -> [String]
145 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
147 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
149 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
151 instance print GenType
153 print (GenTypeVar i) c = print (['a'..] !! i) c
154 print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
156 collectApps (GenTypeApp l r) c = collectApps l [print r:c]
157 collectApps a c = [print a:c]
158 print (GenTypeCons s) c = [s:c]
159 print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
161 instance toString GType where toString a = concat $ print a []
162 instance toString Type where toString a = concat $ print a []
163 instance toString BasicType where toString a = concat $ print a []
164 instance toString ArrayType where toString a = concat $ print a []
165 instance toString UListType where toString a = concat $ print a []
166 instance toString GenType where toString a = concat $ print a []
168 isperse :: a [[a] -> [a]] [a] -> [a]
169 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
171 gTypeToType :: GType -> Type
172 gTypeToType (GTyBasic a) = TyBasic a
173 gTypeToType (GTyRef a) = TyRef a
174 gTypeToType (GTyArrow l r) = TyArrow (gTypeToType l) (gTypeToType r)
175 gTypeToType (GTyArray s a) = TyArray s (gTypeToType a)
176 gTypeToType (GTyUList s a) = TyUList s (gTypeToType a)
177 gTypeToType (GTyUMaybe a) = TyUMaybe (gTypeToType a)
178 gTypeToType (GTyRecord i t) = TyRecord i (gtrec t [])
180 gtrec :: GType [(GenericFieldDescriptor, Type)] -> [(GenericFieldDescriptor, Type)]
181 gtrec (GTyField i t) c = [(i, gTypeToType t):c]
182 gtrec (GTyPair l r) c = gtrec l $ gtrec r c
184 gTypeToType (GTyObject i=:{gtd_num_conses=0} t)
185 = TyNewType i (hd i.gtd_conses) (gTypeToType t)
186 gTypeToType (GTyObject i t) = TyObject i (gtobj t [])
188 gtobj :: GType [(GenericConsDescriptor, [Type])] -> [(GenericConsDescriptor, [Type])]
189 gtobj (GTyEither l r) c = gtobj l $ gtobj r c
190 gtobj (GTyCons i a) c = [(i, gtcons a []):c]
193 gtcons :: GType [Type] -> [Type]
195 gtcons (GTyPair l r) c = gtcons l $ gtcons r c
196 gtcons t c = [gTypeToType t:c]
198 :: FlatMonad :== State FMState GType
199 :: FMState = { objects :: [String], types :: [GType], otypes :: [GType], depth :: Int }
200 flattenGType :: GType -> [[GType]]
202 # {types} = execState (mkf ot) {objects=[], otypes=[], types=[], depth=10}
203 = scc [(t, refs t [])\\t<-types]
205 refs (GTyObject _ a) c = refs a c
206 refs (GTyRecord _ a) c = refs a c
207 refs (GTyEither l r) c = refs l $ refs r c
208 refs (GTyPair l r) c = refs l $ refs r c
209 refs (GTyCons _ a) c = refs a c
210 refs (GTyField _ a) c = refs a c
212 refs (GTyArrow l r) c = refs l $ refs r c
213 refs (GTyArray _ a) c = refs a c
214 refs (GTyUList _ a) c = refs a c
215 refs (GTyUMaybe a) c = refs a c
216 refs (GTyBasic _) c = c
217 refs a=:(GTyRef _) c = [a:c]
219 write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
220 write cons t a = getState >>= \s
221 //We have seen the type but it might've had different arguments
222 | isMember name s.objects
223 //We have not seen this configuration
224 | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
225 = modify (\x->{x & depth=dec x.depth}) *> mkf a *> pure (GTyRef name)
226 //If not, just return the basictype
228 //We have not seen the type so we add, calculate and output it
229 = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
230 >>= \ty->addIfNotThere ty >>| pure (GTyRef name)
232 name = genericDescriptorName t
234 addIfNotThere :: GType -> FlatMonad
235 addIfNotThere ty = getState >>= \s
236 | isMember ty s.types
238 = modify (\s->{s & types=[ty:s.types]}) >>| pure ty
240 mkf :: GType -> FlatMonad
241 mkf (GTyObject t a) = write GTyObject t a
242 mkf (GTyRecord t a) = write GTyRecord t a
243 mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
244 mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
245 mkf (GTyCons i a) = GTyCons i <$> mkf a
246 mkf (GTyField i a) = GTyField i <$> mkf a
247 mkf GTyUnit = pure GTyUnit
248 mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
249 mkf (GTyArray s a) = GTyArray s <$> mkf a
250 mkf (GTyUList s a) = GTyUList s <$> mkf a
251 mkf (GTyUMaybe a) = GTyUMaybe <$> mkf a
252 mkf a=:(GTyBasic _) = addIfNotThere a
253 mkf a=:(GTyRef _) = pure a
255 typeName :: Type -> String
256 typeName (TyBasic a) = toString a
257 typeName (TyRef a) = a
258 typeName (TyArrow l r) = typeName l +++ "->" +++ typeName r
259 typeName (TyArray s a) = "{" +++ toString s +++ typeName a +++ "}"
260 typeName (TyUList s a) = "[#" +++ toString s +++ typeName a +++ "]"
261 typeName (TyUMaybe a) = "?" +++ typeName a
262 typeName (TyNewType i _ _) = i.gtd_name
263 typeName (TyObject i _) = i.gtd_name
264 typeName (TyRecord i _) = i.grd_name
266 instance isBuiltin String
268 isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_]
269 instance isBuiltin Type
271 isBuiltin (TyObject i a) = isBuiltin i.gtd_name
272 isBuiltin (TyRecord i a) = isBuiltin i.grd_name
273 isBuiltin (TyRef a) = isBuiltin a
275 instance isBuiltin GType
277 isBuiltin (GTyObject i a) = isBuiltin i.gtd_name
278 isBuiltin (GTyRecord i a) = isBuiltin i.grd_name
279 isBuiltin (GTyRef a) = isBuiltin a
282 instance isBasic Type
284 isBasic (TyBasic t) = True
287 instance isBasic GType
289 isBasic (GTyBasic t) = True
292 instance replaceBuiltins GenericFieldDescriptor
294 replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}
295 instance replaceBuiltins GenericConsDescriptor
297 replaceBuiltins s = {s & gcd_name=replaceBuiltins s.gcd_name, gcd_type=replaceBuiltins s.gcd_type}
298 instance replaceBuiltins GenericTypeDefDescriptor
300 replaceBuiltins s = {s & gtd_name=replaceBuiltins s.gtd_name}
301 instance replaceBuiltins GenericRecordDescriptor
303 replaceBuiltins s = {s & grd_name=replaceBuiltins s.grd_name, grd_type=replaceBuiltins s.grd_type}
304 instance replaceBuiltins String
306 replaceBuiltins a = fromMaybe a $ lookup a predef
307 instance replaceBuiltins Type
309 replaceBuiltins (TyRef a) = TyRef (replaceBuiltins a)
310 replaceBuiltins (TyArrow l r) = TyArrow (replaceBuiltins l) (replaceBuiltins r)
311 replaceBuiltins (TyArray s a) = TyArray s (replaceBuiltins a)
312 replaceBuiltins (TyUList s a) = TyUList s (replaceBuiltins a)
313 replaceBuiltins (TyUMaybe a) = TyUMaybe (replaceBuiltins a)
314 replaceBuiltins (TyNewType i j a) = TyNewType (replaceBuiltins i) (replaceBuiltins j) (replaceBuiltins a)
315 replaceBuiltins (TyObject i cs) = TyObject (replaceBuiltins i) [(replaceBuiltins i, map replaceBuiltins fs)\\(i, fs)<-cs]
316 replaceBuiltins (TyRecord j fs) = TyRecord (replaceBuiltins j) [(replaceBuiltins i, replaceBuiltins a)\\(i, a)<-fs]
317 replaceBuiltins t = t
318 instance replaceBuiltins GType
320 replaceBuiltins (GTyEither l r) = GTyEither (replaceBuiltins l) (replaceBuiltins r)
321 replaceBuiltins (GTyPair l r) = GTyPair (replaceBuiltins l) (replaceBuiltins r)
322 replaceBuiltins (GTyArrow l r) = GTyArrow (replaceBuiltins l) (replaceBuiltins r)
323 replaceBuiltins (GTyArray s a) = GTyArray s (replaceBuiltins a)
324 replaceBuiltins (GTyUList s a) = GTyUList s (replaceBuiltins a)
325 replaceBuiltins (GTyUMaybe a) = GTyUMaybe (replaceBuiltins a)
326 replaceBuiltins (GTyObject i a) = GTyObject (replaceBuiltins i) (replaceBuiltins a)
327 replaceBuiltins (GTyRecord i a) = GTyRecord (replaceBuiltins i) (replaceBuiltins a)
328 replaceBuiltins (GTyCons i a) = GTyCons (replaceBuiltins i) (replaceBuiltins a)
329 replaceBuiltins (GTyField i a) = GTyField (replaceBuiltins i) (replaceBuiltins a)
330 replaceBuiltins (GTyRef a) = GTyRef (replaceBuiltins a)
331 replaceBuiltins a = a
332 instance replaceBuiltins GenType
334 replaceBuiltins (GenTypeCons a) = GenTypeCons (replaceBuiltins a)
335 replaceBuiltins (GenTypeApp l r) = GenTypeApp (replaceBuiltins l) (replaceBuiltins r)
336 replaceBuiltins (GenTypeArrow l r) = GenTypeArrow (replaceBuiltins l) (replaceBuiltins r)
337 replaceBuiltins a = a
339 predef :: [(String, String)]
341 [ ("_List", "[]"), ("_Cons", "(:)"), ("_Nil", "[]")
342 , ("_!List", "[! ]"), ("_!Cons", "(:)"), ("_!Nil", "[! ]")
343 , ("_List!", "[ !]"), ("_Cons!", "(:)"), ("_Nil!", "[ !]")
344 , ("_!List!", "[!!]"), ("_!Cons!", "(:)"), ("_!Nil!", "[ !]")
345 , ("_#List", "[#]"), ("_#Cons", "(:)"), ("_#Nil", "[#]")
346 , ("_#List!", "[#!]"), ("_#Cons!", "(:)"), ("_#Nil!", "[#!]")
347 , ("_!Maybe", "?"), ("_!Just", "?Just"), ("_!Nothing", "?None")
348 , ("_Maybe", "?^"), ("_Just", "?^Just"), ("_Nothing", "?^None")
349 , ("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}"), ("_32#Array", "{32#}")
351 :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
353 generic type a :: Box GType a
354 gType{|UNIT|} = box GTyUnit
355 gType{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
356 gType{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
357 gType{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
358 gType{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
359 gType{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
360 gType{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
361 gType{|Int|} = box $ GTyBasic BTInt
362 gType{|Bool|} = box $ GTyBasic BTBool
363 gType{|Real|} = box $ GTyBasic BTReal
364 gType{|Char|} = box $ GTyBasic BTChar
365 gType{|World|} = box $ GTyBasic BTWorld
366 //gType{|Dynamic|} = box $ GTyBasic BTDynamic
367 gType{|File|} = box $ GTyBasic BTFile
368 gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
369 gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
370 gType{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
371 gType{|{}|} a = box $ GTyArray ALazy $ unBox a
372 gType{|{!}|} a = box $ GTyArray AStrict $ unBox a
373 gType{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
374 gType{|{32#}|} a = box $ GTyArray APacked $ unBox a
375 gType{|(?#)|} a = box $ GTyUMaybe $ unBox a
377 derive gType [], [! ], [ !], [!!]
378 derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)