3 import Control.Applicative
4 import Control.Monad => qualified join
5 import Control.Monad.State
6 import Control.Monad.Writer
7 :mport Control.Monad.Trans
11 import Data.Functor.Identity
17 import StdEnv, StdGeneric
24 reBox x :== box (unBox x)
28 | GTyArrow GType GType
29 | GTyArray ArrayType GType
30 | GTyUList UListType GType
32 | GTyEither GType GType
34 | GTyCons GenericConsDescriptor GType
35 | GTyField GenericFieldDescriptor GType
36 | GTyObject GenericTypeDefDescriptor GType
37 | GTyRecord GenericRecordDescriptor GType
38 :: ArrayType = AStrict | ALazy | AUnboxed | A32Unboxed
39 :: UListType = ULLazy | ULStrict
42 (==) ULLazy ULLazy = True
43 (==) ULStrict ULStrict = True
47 (==) AStrict AStrict = True
48 (==) ALazy ALazy = True
49 (==) AUnboxed AUnboxed = True
50 (==) A32Unboxed A32Unboxed = True
53 instance == GType where (==) x y = gTypeEqShallow 999 x y
54 gTypeEqShallow :: Int GType GType -> Bool
57 gTypeEqShallow _ (GTyBasic i) (GTyBasic j) = i == j
58 gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
59 gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
60 gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
61 gTypeEqShallow _ GTyUnit GTyUnit = True
62 gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
63 gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
64 gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
65 gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
66 = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
67 gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
68 = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
69 gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
70 = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
71 gTypeEqShallow _ _ _ = False
73 class print a :: a [String] -> [String]
74 instance print Bool where print s c = [toString s:c]
75 instance print Int where print s c = [toString s:c]
76 instance print Char where print s c = [toString s:c]
77 instance print String where print s c = [s:c]
78 instance print UListType
80 print ULStrict c = ["!":c]
82 instance print ArrayType
84 print AStrict c = ["!":c]
85 print AUnboxed c = ["#":c]
86 print A32Unboxed c = ["32#":c]
90 print (GTyBasic s) c = [s:c]
91 print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
92 print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
93 print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
94 print GTyUnit c = ["UNIT":c]
95 print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
96 print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
97 print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
98 print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
99 print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
100 print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
105 | TyArray ArrayType Type
106 | TyUList UListType Type
107 | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
108 | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
109 | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
112 (==) (TyBasic a1) (TyBasic a2) = a1 == a2
113 (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
114 (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
115 (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
116 (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
117 = i1.gtd_name == i2.gtd_name && a1 == a2
118 (==) (TyObject i1 a1) (TyObject i2 a2)
119 = i1.gtd_name == i2.gtd_name && length a1 == length a2
120 && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
121 (==) (TyRecord i1 a1) (TyRecord i2 a2)
122 = i1.grd_name == i2.grd_name && length a1 == length a2
123 && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
126 predef :: [(String, String)]
128 [("_List", "[]"), ("_!List", "[! ]"), ("_List!", "[ !]"), ("_!List!", "[!!]")
129 ,("_#List", "[#]"), ("_#List!", "[#!]")
130 ,("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}")
131 :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
133 translateType :: String -> String
134 translateType s = maybe s id $ lookup s predef
138 print (TyBasic s) c = [translateType s:c]
139 print (TyArrow l r) c = print l [" -> ":print r c]
140 print (TyArray s a) c = ["{":print s ["}":print a c]]
141 print (TyUList s a) c = ["[#":print s ["]":print a c]]
142 print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
143 [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
144 where nttype (GenTypeArrow l r) = l
145 print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
146 [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
147 print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
148 $ [" ":isperse " | " (map pCons conses) c]
150 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
151 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
153 n c = case i.gcd_prio of
154 GenConsNoPrio = [i.gcd_name:c]
155 GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
156 GenConsAssocRight = "r";
157 GenConsAssocLeft = "l"
158 _ = "", " ":print s c]
160 pTyVars :: String Int [String] -> [String]
161 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
163 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
165 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
169 (==) (GenTypeVar i) (GenTypeVar j) = i == j
170 (==) (GenTypeApp l1 r1) (GenTypeApp l2 r2) = l1 == l2 && r1 == r2
171 (==) (GenTypeCons i) (GenTypeCons j) = i == j
172 (==) (GenTypeArrow l1 r1) (GenTypeArrow l2 r2) = l1 == l2 && r1 == r2
174 instance print GenType
176 print (GenTypeVar i) c = print (['a'..] !! i) c
177 print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
179 collectApps (GenTypeApp l r) c = collectApps l [print r:c]
180 collectApps a c = [print a:c]
181 print (GenTypeCons s) c = [translateType s:c]
182 print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
184 isperse :: a [[a] -> [a]] [a] -> [a]
185 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
187 gTypeToType :: GType -> Maybe Type
188 gTypeToType (GTyBasic a) = pure $ TyBasic a
189 gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
190 gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
191 gTypeToType (GTyUList s a) = TyUList s <$> gTypeToType a
192 gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
194 gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
195 gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
197 gTypeToType (GTyObject i t)
198 | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
199 = TyObject i <$> gtobj t
201 gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
202 gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
203 gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
206 gtcons :: GType -> Maybe [Type]
207 gtcons GTyUnit = pure []
208 gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
209 gtcons t = (\x->[x]) <$> gTypeToType t
211 :: FlatMonad :== State FMState GType
212 :: FMState = { objects :: [String], otypes :: [GType], types :: [GType], depth :: Int}
213 flattenGType :: GType -> (GType, [GType])
214 flattenGType ot = appSnd (\x->x.types) $ runState (mkf ot) {objects=[], types=[], otypes=[], depth=10}
216 write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
217 write cons t a = modify (\x->{x & depth=dec x.depth}) >>| getState >>= \s
218 //We have seen the type but it might've had different arguments
219 | isMember name s.objects
220 //We have not seen this configuration
221 | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
223 //If not, just return the basictype
225 //We have not seen the type so we add, calculate and output it
226 = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
227 >>= \ty->modify (\x->{x & types=[ty:x.types]}) >>| r
229 name = genericDescriptorName t
230 r = pure $ GTyBasic name
232 mkf :: GType -> FlatMonad
233 mkf (GTyObject t a) = write GTyObject t a
234 mkf (GTyRecord t a) = write GTyRecord t a
235 mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
236 mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
237 mkf (GTyCons i a) = GTyCons i <$> mkf a
238 mkf (GTyField i a) = GTyField i <$> mkf a
239 mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
240 mkf (GTyArray s a) = GTyArray s <$> mkf a
241 mkf (GTyUList s a) = GTyUList s <$> mkf a
242 mkf GTyUnit = pure GTyUnit
243 mkf a=:(GTyBasic _) = pure a
245 generic type a :: Box GType a
246 type{|Int|} = box $ GTyBasic "Int"
247 type{|Bool|} = box $ GTyBasic "Bool"
248 type{|Real|} = box $ GTyBasic "Real"
249 type{|Char|} = box $ GTyBasic "Char"
250 type{|World|} = box $ GTyBasic "World"
251 type{|Dynamic|} = box $ GTyBasic "Dynamic"
252 type{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
253 type{|[#]|} a = box $ GTyUList ULLazy $ unBox a
254 type{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
255 type{|{}|} a = box $ GTyArray ALazy $ unBox a
256 type{|{!}|} a = box $ GTyArray AStrict $ unBox a
257 type{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
258 type{|{32#}|} a = box $ GTyArray A32Unboxed $ unBox a
260 type{|UNIT|} = box GTyUnit
261 type{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
262 type{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
263 type{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
264 type{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
265 type{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
266 type{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
268 derive type ?#, ?, ?^
269 derive type [], [! ], [ !], [!!]
270 derive type (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
271 derive type Either, Maybe, T, R, Frac, Tr, Fix
274 :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
275 f5 :: [[([#Int], [#Int!], [!Int!], [!Int], [Int!], {!Int}, {R Bool}, {#Char})]]/*({!Int}, {#Char}, {R Bool})*/}
277 :: Tr m b= Tr (m Int b)
279 :: Frac a = (/.) infixl 7 a a
282 //Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
283 Start = foldr (\i c->print i ["\n":c]) []
289 :: Fix f = Fix (f (Fix f))
291 //t :: Box GType (?# Int)
292 //t :: Box GType (Maybe [Maybe (Either Bool String)])
293 //t :: Box GType [Either [[!Int]] [[![Bool]]]]
294 t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)