3 import Control.Applicative
4 import Control.Monad => qualified join
5 import Control.Monad.State
6 import Control.Monad.Writer
7 import Control.Monad.Trans
11 import Data.Functor.Identity
17 import StdEnv, StdGeneric
24 reBox x :== box (unBox x)
28 | GTyArrow GType GType
31 | GTyEither GType GType
33 | GTyCons GenericConsDescriptor GType
34 | GTyField GenericFieldDescriptor GType
35 | GTyObject GenericTypeDefDescriptor GType
36 | GTyRecord GenericRecordDescriptor GType
37 class print a :: a [String] -> [String]
38 instance print Int where print s c = [toString s:c]
39 instance print Char where print s c = [toString s:c]
40 instance print String where print s c = [s:c]
43 print (GTyBasic s) c = [s:c]
44 print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
45 print (GTyArray s a) c = ["(", if s "!" "", "Array ":print a [")":c]]
46 print GTyUnit c = ["UNIT":c]
47 print (GTyEither l r) c = ["(EITHER":print l [" ":print r [")":c]]]
48 print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
49 print (GTyCons _ a) c = ["(CONS ":print a [")":c]]
50 print (GTyField _ a) c = ["(FIELD ":print a [")":c]]
51 print (GTyObject _ a) c = ["(OBJECT ":print a [")":c]]
52 print (GTyRecord _ a) c = ["(RECORD ":print a [")":c]]
58 | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
59 | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
60 | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
63 print (TyBasic s) c = [s:c]
64 print (TyArrow l r) c = print l [" -> ":print r c]
65 print (TyArray s a) c = ["{", if s "!" "":print a ["}":c]]
66 print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
67 [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
68 where nttype (GenTypeArrow l r) = l
69 print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
70 [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
71 print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
72 $ [" ":isperse " | " (map pCons conses) c]
74 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
75 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
77 n c = case i.gcd_prio of
78 GenConsNoPrio = [i.gcd_name:c]
79 GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
80 GenConsAssocRight = "r";
81 GenConsAssocLeft = "l"
82 _ = "", " ":print s c]
84 pTyVars :: String Int [String] -> [String]
85 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
87 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
89 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
91 instance print GenType
93 print (GenTypeVar i) c = print (['a'..] !! i) c
94 print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
96 collectApps (GenTypeApp l r) c = collectApps l [print r:c]
97 collectApps a c = [print a:c]
98 print (GenTypeCons s) c = [s:c]
99 print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
101 isperse :: a [[a] -> [a]] [a] -> [a]
102 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
104 gTypeToType :: GType -> Maybe Type
105 gTypeToType (GTyBasic a) = pure $ TyBasic a
106 gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
107 gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
108 gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
110 gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
111 gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
113 gTypeToType (GTyObject i t)
114 | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
115 = TyObject i <$> gtobj t
117 gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
118 gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
119 gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
122 gtcons :: GType -> Maybe [Type]
123 gtcons GTyUnit = pure []
124 gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
125 gtcons t = (\x->[x]) <$> gTypeToType t
127 flattenGType :: GType -> [GType]
128 flattenGType t = execWriter $ evalStateT (mkf t) []
130 add :: (g GType -> GType) g GType -> StateT [String] (WriterT [GType] Identity) GType | genericDescriptorName g
131 add cons t a = gets (isMember $ genericDescriptorName t) >>= \b->if b
132 (pure $ GTyBasic $ genericDescriptorName t)
133 (cons t <$ modify (\x->[genericDescriptorName t:x]) <*> mkf a
134 >>= \ty->liftT (tell [ty]) >>| add cons t a)
136 mkf :: GType -> StateT [String] (WriterT [GType] Identity) GType
137 mkf (GTyObject t a) = add GTyObject t a
138 mkf (GTyRecord t a) = add GTyRecord t a
139 mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
140 mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
141 mkf (GTyCons i a) = GTyCons i <$> mkf a
142 mkf (GTyField i a) = GTyField i <$> mkf a
143 mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
144 mkf (GTyArray s a) = GTyArray s <$> mkf a
147 generic type a :: Box GType a
148 type{|Int|} = box $ GTyBasic "Int"
149 type{|Bool|} = box $ GTyBasic "Bool"
150 type{|Real|} = box $ GTyBasic "Real"
151 type{|Char|} = box $ GTyBasic "Char"
152 type{|World|} = box $ GTyBasic "World"
153 type{|Dynamic|} = box $ GTyBasic "Dynamic"
154 type{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
155 type{|{}|} a = box $ GTyArray False $ unBox a
156 type{|{!}|} a = box $ GTyArray True $ unBox a
158 type{|UNIT|} = box GTyUnit
159 type{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
160 type{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
161 type{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
162 type{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
163 type{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
164 type{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
166 derive type [], Either, Maybe, T, R, Frac, Tr, (,)
169 :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic}
171 :: Tr m b= Tr (m Int b)
173 :: Frac a = (/.) infixl 7 a a
176 Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
178 t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool)