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