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 :mport 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         | GTyUList UListType GType
  31         | GTyUnit
  32         | GTyEither GType GType
  33         | GTyPair 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
  40 instance == UListType
  41 where
  42         (==) ULLazy ULLazy = True
  43         (==) ULStrict ULStrict = True
  44         (==) _ _ = False
  45 instance == ArrayType
  46 where
  47         (==) AStrict AStrict = True
  48         (==) ALazy ALazy = True
  49         (==) AUnboxed AUnboxed = True
  50         (==) A32Unboxed A32Unboxed = True
  51         (==) _ _ = False
  52
  53 instance == GType where (==) x y = gTypeEqShallow 999 x y
  54 gTypeEqShallow :: Int GType GType -> Bool
  55 gTypeEqShallow i _ _
  56         | i < 0 = True
  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
  72
  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
  79 where
  80         print ULStrict c = ["!":c]
  81         print ULLazy c = c
  82 instance print ArrayType
  83 where
  84         print AStrict c = ["!":c]
  85         print AUnboxed c = ["#":c]
  86         print A32Unboxed c = ["32#":c]
  87         print ALazy c = c
  88 instance print GType
  89 where
  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]]
 101
 102 :: Type
 103         = TyBasic String
 104         | TyArrow Type Type
 105         | TyArray ArrayType Type
 106         | TyUList UListType Type
 107         | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
 108         | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
 109         | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
 110 instance == Type
 111 where
 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]
 124         (==) _ _ = False
 125
 126 predef :: [(String, String)]
 127 predef =:
 128         [("_List", "[]"), ("_!List", "[! ]"), ("_List!", "[ !]"), ("_!List!", "[!!]")
 129         ,("_#List", "[#]"), ("_#List!", "[#!]")
 130         ,("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}")
 131         :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
 132
 133 translateType :: String -> String
 134 translateType s = maybe s id $ lookup s predef
 135
 136 instance print Type
 137 where
 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]
 149         where
 150                 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
 151                 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
 152                 where
 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]
 159
 160 pTyVars :: String Int [String] -> [String]
 161 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
 162
 163 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
 164 pField pre [] _ = []
 165 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
 166
 167 instance == GenType
 168 where
 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
 173         (==) _ _ = False
 174 instance print GenType
 175 where
 176         print (GenTypeVar i) c = print (['a'..] !! i) c
 177         print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
 178         where
 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]]]
 183
 184 isperse :: a [[a] -> [a]] [a] -> [a]
 185 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
 186
 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
 193 where
 194         gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
 195         gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
 196         gtrec _ = Nothing
 197 gTypeToType (GTyObject i t)
 198         | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
 199                                 = TyObject i <$> gtobj t
 200 where
 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
 204         gtobj _ = Nothing
 205
 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
 210
 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}
 215 where
 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]
 222                                 = mkf a *> r
 223                         //If not, just return the basictype
 224                                 = r
 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
 228         where
 229                 name = genericDescriptorName t
 230                 r = pure $ GTyBasic name
 231
 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
 244
 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
 259
 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
 267
 268 derive type ?#, ?, ?^
 269 derive type [], [! ], [ !], [!!]
 270 derive type (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
 271 derive type Either, Maybe, T, R, Frac, Tr, Fix
 272
 273 :: T a =: T2 a
 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})*/}
 276
 277 :: Tr m b= Tr (m Int b)
 278
 279 :: Frac a = (/.) infixl 7 a a
 280
 281 //Start :: [String]
 282 //Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
 283 Start = foldr (\i c->print i ["\n":c]) []
 284         $ catMaybes
 285         $ map gTypeToType
 286         $ snd $ flattenGType
 287         $ unBox t
 288
 289 :: Fix f = Fix (f (Fix f))
 290
 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)
 295 t = type{|*|}