1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 module GenVal ( 23 gen_vals, gen_id_val 24 ) where 25 26 import Utils 27 import Config 28 import Types 29 import Env 30 31 32 33 34 35 36 37 38 gen_vals :: Int -> Int -> Cont -> Cont 39 gen_vals n dp c 40 = get_all_type_names 41 (\tns -> cmap (rep n (upto (length tns - one) 42 . (\vc r -> gen_val (tns !! r) dp vc))) 43 (\vs -> get_val_names n 44 (\vns -> extend_val_env (zip vns vs) c))) 45 46 47 48 49 50 51 52 gen_val :: Type_name -> Int -> Vcont -> Cont 53 gen_val tn dp vc 54 | dp <= one = get_type tn (\t -> vc (Tagged_val (fst (head t)) [])) 55 | otherwise = get_type tn tc 56 where 57 tc t = upto (length t - one) nc 58 where 59 nc r = cmap (map (gen_id_val (dp - one)) ids) 60 (\vs -> vc (Tagged_val c' vs)) 61 where 62 (c', ids) = t !! r 63 64 65 66 67 68 69 70 gen_id_val :: Int -> Argtype -> Vcont -> Cont 71 gen_id_val dp (Name_type tn) vc = gen_val tn dp vc 72 gen_id_val dp (Basic_type bt) vc = gen_basic_val bt vc 73 gen_id_val dp (List_type id) vc 74 = upto max_list_len 75 (\r -> cmap (rep r (gen_id_val (dp - one) id)) 76 (\vs -> vc (List_val vs))) 77 gen_id_val dp (Tuple_type ids) vc 78 = cmap (map (gen_id_val (dp - one)) ids) 79 (\vs -> vc (Tuple_val vs)) 80 gen_id_val dp (Array_type id id') vc 81 = let vsc [v,v'] 82 = upto (max_array_len-one) 83 (\r -> let vsc' vs = vc (Array_val (v,v'') 84 (zipWith (,) vrng vs)) 85 vrng = take (r+one) (vrange (v,v')) 86 v'' = case vrng of 87 [] -> v' 88 (_:_) -> last vrng 89 in 90 cmap (rep (length vrng) 91 (gen_id_val (dp-one) id')) vsc') 92 in 93 cmap (rep 2 (gen_id_val (dp - one) id)) vsc 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 gen_basic_val :: Base_type -> Vcont -> Cont 113 gen_basic_val (Num_type k) vc 114 = upto maxint (\r -> vc (Num_val k r)) 115 where 116 maxint = 256 :: Int 117 gen_basic_val Bool_type vc 118 = choose [True, False] (\b -> vc (Bool_val b)) 119 gen_basic_val Char_type vc 120 = upto maxchar (\r -> vc (Char_val (toEnum r))) 121 122 123 124 125 126 127 128