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 Bool 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 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]
  41 instance print GType
  42 where
  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]]
  53
  54 :: Type
  55         = TyBasic String
  56         | TyArrow Type Type
  57         | TyArray Bool Type
  58         | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
  59         | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
  60         | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
  61 instance print Type
  62 where
  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]
  73         where
  74                 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
  75                 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
  76                 where
  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]
  83
  84 pTyVars :: String Int [String] -> [String]
  85 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
  86
  87 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
  88 pField pre [] _ = []
  89 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
  90
  91 instance print GenType
  92 where
  93         print (GenTypeVar i) c = print (['a'..] !! i) c
  94         print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
  95         where
  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]]]
 100
 101 isperse :: a [[a] -> [a]] [a] -> [a]
 102 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
 103
 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
 109 where
 110         gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
 111         gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
 112         gtrec _ = Nothing
 113 gTypeToType (GTyObject i t)
 114         | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
 115                                 = TyObject i <$> gtobj t
 116 where
 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
 120         gtobj _ = Nothing
 121
 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
 126
 127 flattenGType :: GType -> [GType]
 128 flattenGType t = execWriter $ evalStateT (mkf t) []
 129 where
 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)
 135
 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
 145         mkf t = pure t
 146
 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
 157
 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
 165
 166 derive type [], Either, Maybe, T, R, Frac, Tr, (,)
 167
 168 :: T a =: T2 a
 169 :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic}
 170
 171 :: Tr m b= Tr (m Int b)
 172
 173 :: Frac a = (/.) infixl 7 a a
 174
 175 Start :: [String]
 176 Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
 177
 178 t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool)
 179 t = type{|*|}