gengen/gen.icl

   1 module gen
   2
   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
   8 import Data.Either
   9 import Data.Func
  10 import Data.Functor
  11 import Data.Functor.Identity
  12 import Data.Generics
  13 import Data.List
  14 import Data.Maybe
  15 import Data.Monoid
  16 import Data.Tuple
  17 import StdEnv, StdGeneric
  18 import Text
  19
  20 :: Box b a =: Box b
  21 derive bimap Box
  22 unBox (Box b) :== b
  23 box b :== Box b
  24 reBox x :== box (unBox x)
  25
  26 :: GType
  27         = GTyBasic String
  28         | GTyArrow GType GType
  29         | GTyArray ArrayType GType
  30         | GTyUnit
  31         | GTyEither GType GType
  32         | GTyPair GType GType
  33         | GTyCons GenericConsDescriptor GType
  34         | GTyField GenericFieldDescriptor GType
  35         | GTyObject GenericTypeDefDescriptor GType
  36         | GTyRecord GenericRecordDescriptor GType
  37 :: ArrayType = ATStrict | ATLazy | ATBoxed
  38 class print a :: a [String] -> [String]
  39 instance print Int where print s c = [toString s:c]
  40 instance print Char where print s c = [toString s:c]
  41 instance print String where print s c = [s:c]
  42 instance print ArrayType
  43 where
  44         print ATStrict c = ["!":c]
  45         print ATBoxed c = ["#":c]
  46         print ATLazy c = c
  47 instance print GType
  48 where
  49         print (GTyBasic s) c = [s:c]
  50         print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
  51         print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
  52         print GTyUnit c = ["UNIT":c]
  53         print (GTyEither l r) c = ["(EITHER":print l [" ":print r [")":c]]]
  54         print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
  55         print (GTyCons _ a) c = ["(CONS ":print a [")":c]]
  56         print (GTyField _ a) c = ["(FIELD ":print a [")":c]]
  57         print (GTyObject _ a) c = ["(OBJECT ":print a [")":c]]
  58         print (GTyRecord _ a) c = ["(RECORD ":print a [")":c]]
  59
  60 :: Type
  61         = TyBasic String
  62         | TyArrow Type Type
  63         | TyArray ArrayType Type
  64         | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
  65         | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
  66         | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
  67 instance print Type
  68 where
  69         print (TyBasic s) c = [case s of
  70                         "_List"   = "[]"
  71                         "_!List"  = "[! ]"
  72                         "_List!"  = "[ !]"
  73                         "_!List!" = "[!!]"
  74                         "_#List"  = "[#]"
  75                         "_#List!" = "[#!]"
  76                         "_Array"  = "{}"
  77                         "_!Array" = "{!}"
  78                         "_#Array" = "{#}"
  79                         _ = s:c]
  80         print (TyArrow l r) c = print l [" -> ":print r c]
  81         print (TyArray s a) c = ["{":print s $ print a ["}":c]]
  82         print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
  83                 [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
  84         where nttype (GenTypeArrow l r) = l
  85         print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
  86                 [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
  87         print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
  88                         $ [" ":isperse " | " (map pCons conses) c]
  89         where
  90                 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
  91                 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
  92                 where
  93                         n c = case i.gcd_prio of
  94                                 GenConsNoPrio = [i.gcd_name:c]
  95                                 GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
  96                                         GenConsAssocRight = "r";
  97                                         GenConsAssocLeft = "l"
  98                                         _ = "", " ":print s c]
  99
 100 pTyVars :: String Int [String] -> [String]
 101 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
 102
 103 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
 104 pField pre [] _ = []
 105 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
 106
 107 instance print GenType
 108 where
 109         print (GenTypeVar i) c = print (['a'..] !! i) c
 110         print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
 111         where
 112                 collectApps (GenTypeApp l r) c = collectApps l [print r:c]
 113                 collectApps a c = [print a:c]
 114         print (GenTypeCons s) c = [s:c]
 115         print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
 116
 117 isperse :: a [[a] -> [a]] [a] -> [a]
 118 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
 119
 120 gTypeToType :: GType -> Maybe Type
 121 gTypeToType (GTyBasic a) = pure $ TyBasic a
 122 gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
 123 gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
 124 gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
 125 where
 126         gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
 127         gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
 128         gtrec _ = Nothing
 129 gTypeToType (GTyObject i t)
 130         | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
 131                                 = TyObject i <$> gtobj t
 132 where
 133         gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
 134         gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
 135         gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
 136         gtobj _ = Nothing
 137
 138         gtcons :: GType -> Maybe [Type]
 139         gtcons GTyUnit = pure []
 140         gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
 141         gtcons t = (\x->[x]) <$> gTypeToType t
 142
 143 flattenGType :: GType -> [GType]
 144 flattenGType t = execWriter $ evalStateT (mkf t) []
 145 where
 146         add :: (g GType -> GType) g GType -> StateT [String] (WriterT [GType] Identity) GType | genericDescriptorName g
 147         add cons t a = gets (isMember $ genericDescriptorName t) >>= \b->if b
 148                 (pure $ GTyBasic $ genericDescriptorName t)
 149                 (cons t <$ modify (\x->[genericDescriptorName t:x]) <*> mkf a
 150                         >>= \ty->liftT (tell [ty]) >>| add cons t a)
 151
 152         mkf :: GType -> StateT [String] (WriterT [GType] Identity) GType
 153         mkf (GTyObject t a) = add GTyObject t a
 154         mkf (GTyRecord t a) = add GTyRecord t a
 155         mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
 156         mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
 157         mkf (GTyCons i a) = GTyCons i <$> mkf a
 158         mkf (GTyField i a) = GTyField i <$> mkf a
 159         mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
 160         mkf (GTyArray s a) = GTyArray s <$> mkf a
 161         mkf t = pure t
 162
 163 generic type a :: Box GType a
 164 type{|Int|} = box $ GTyBasic "Int"
 165 type{|Bool|} = box $ GTyBasic "Bool"
 166 type{|Real|} = box $ GTyBasic "Real"
 167 type{|Char|} = box $ GTyBasic "Char"
 168 type{|World|} = box $ GTyBasic "World"
 169 type{|Dynamic|} = box $ GTyBasic "Dynamic"
 170 type{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
 171 type{|{}|} a = box $ GTyArray ATLazy $ unBox a
 172 type{|{!}|} a = box $ GTyArray ATStrict $ unBox a
 173 type{|{#}|} a = box $ GTyArray ATBoxed $ unBox a
 174 type{|[#]|} a = box $ GTyArray ATBoxed $ unBox a
 175 type{|[#!]|} a = box $ GTyArray ATBoxed $ unBox a
 176
 177 type{|UNIT|} = box GTyUnit
 178 type{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
 179 type{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
 180 type{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
 181 type{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
 182 type{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
 183 type{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
 184
 185 derive type [], [! ], [ !], [!!], Either, Maybe, T, R, Frac, Tr, (,), (,,), (,,,), (,,,,), (,,,,,)
 186
 187 :: T a =: T2 a
 188 :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
 189         f5 :: [([!Int!], [!Int], [Int!], {!Int}, {R Bool}, {#Char})]/*({!Int}, {#Char}, {R Bool})*/}
 190
 191 :: Tr m b= Tr (m Int b)
 192
 193 :: Frac a = (/.) infixl 7 a a
 194
 195 Start :: [String]
 196 Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
 197
 198 t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool)
 199 t = type{|*|}