1 
    2 
    3 
    4 
    5 
    6 
    7 
    8 
    9 
   10 
   11 
   12 
   13 
   14 
   15 
   16 
   17 
   18 
   19 
   20 
   21 
   22 
   23 
   24 
   25 
   26 
   27 
   28 
   29 
   30 
   31 
   32 
   33 
   34 
   35 
   36 
   37 
   38 
   39 
   40 
   41 
   42 
   43 
   44 
   45   module GenType (
   46       gen_types
   47       ) where
   48 
   49   import Utils
   50   import Config
   51   import Types
   52   import Env
   53 
   54 
   55 
   56 
   57 
   58 
   59 
   60 
   61 
   62 
   63 
   64   gen_types :: Int -> Int -> Int -> Int -> Cont -> Cont
   65   gen_types vnts flds n dp c
   66       =  get_type_names n
   67          (\tns -> get_all_type_names
   68          (\tns' -> cmap (rep n (gen_type vnts flds (tns'++tns) dp))
   69          (\ts -> extend_type_env (zip tns ts) c)))
   70 
   71 
   72 
   73 
   74 
   75 
   76 
   77 
   78   gen_type :: Int -> Int -> [Type_name] -> Int -> Xcont Htype -> Cont
   79   gen_type vnts flds tns dp tc
   80       =  upto (vnts-one)
   81          (\n -> get_constructors (n + one)
   82          (\cs -> cmap (rep n (gen_argtypes flds tns dp))
   83          (\as -> tc (zip cs ([]:as)))))
   84 
   85 
   86 
   87 
   88 
   89 
   90 
   91 
   92   gen_argtypes :: Int -> [Type_name] -> Int -> Xscont Argtype -> Cont
   93   gen_argtypes flds tns dp asc
   94       =  upto flds (\n -> cmap (rep n (gen_argtype tns dp)) asc)
   95 
   96 
   97 
   98 
   99 
  100 
  101 
  102 
  103 
  104 
  105   gen_argtype :: [Type_name] -> Int -> Xcont Argtype -> Cont
  106   gen_argtype tns dp ac | dp <= one  =  gen_base ac
  107   gen_argtype tns dp ac
  108       =  choose [upto (length tns - one) (\n -> ac (Name_type (tns !! n))),
  109                  gen_base ac,
  110                  gen_argtype tns (dp - one) (\a -> ac (List_type a)),
  111                  upto max_tuple_len
  112                    (\r -> cmap (rep r (gen_argtype tns (dp - one)))
  113                    (\as -> ac (Tuple_type as))),
  114                  gen_ix_type tns (dp - one)
  115                    (\a -> gen_argtype tns (dp - one)
  116                    (\a' -> ac (Array_type a a')))] id
  117                  
  118 
  119 
  120 
  121 
  122 
  123 
  124 
  125 
  126 
  127 
  128 
  129 
  130 
  131   gen_base :: Xcont Argtype -> Cont
  132   gen_base ac
  133       =  choose [choose [Int_type, Integer_type, Float_type, Double_type]
  134                         (\k -> ac (Basic_type (Num_type k))),
  135                  ac (Basic_type Bool_type),
  136                  ac (Basic_type Char_type)] id
  137 
  138 
  139 
  140 
  141 
  142 
  143 
  144 
  145   gen_ix_type :: [Type_name] -> Int -> Xcont Argtype -> Cont
  146   gen_ix_type tns dp ac | dp <= one  =  gen_ix_base ac
  147   gen_ix_type tns dp ac
  148       =  choose [gen_ix_base ac,
  149                  upto max_tuple_len
  150                    (\r -> cmap (rep r (gen_ix_type tns (dp-one)))
  151                    (\as -> ac (Tuple_type as)))] id
  152 
  153 
  154 
  155 
  156 
  157 
  158 
  159   gen_ix_base :: Xcont Argtype -> Cont
  160   gen_ix_base ac
  161       =  choose [choose [Int_type, Integer_type]
  162                         (\k -> ac (Basic_type (Num_type k))),
  163                  ac (Basic_type Bool_type),
  164                  ac (Basic_type Char_type)] id
  165 
  166