1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 module Types ( 23 Type_decl, Htype, Argtype(..), Base_type(..), Num_kind(..), 24 Constructor, Type_name, Val_decl, Value(..), Val_name, 25 Expression(..), 26 showsType_decl, showsVal_decl, vrange, 27 int_val, 28 sep_list 29 ) where 30 31 import Char (isAlpha) -- 1.3 32 import Config 33 34 35 36 37 38 39 40 41 42 43 44 45 46 type Type_decl = (Type_name, Htype) 47 48 49 50 51 52 53 54 55 type Htype = [(Constructor, [Argtype])] 56 57 58 59 60 61 62 data Argtype = Name_type Type_name 63 | Basic_type Base_type 64 | List_type Argtype 65 | Tuple_type [Argtype] 66 | Array_type Argtype Argtype 67 deriving (Eq) 68 69 data Base_type = Num_type Num_kind | Bool_type | Char_type 70 deriving (Eq) 71 72 data Num_kind = Int_type | Integer_type | Float_type | Double_type 73 deriving (Eq) 74 75 type Constructor = String 76 type Type_name = String 77 78 79 80 81 82 83 84 85 86 87 88 instance Show Argtype where 89 showsPrec _ (Name_type tn) = showString tn 90 showsPrec _ (Basic_type bt) = shows bt 91 showsPrec _ (List_type at) = lsq . shows at . rsq 92 showsPrec _ (Tuple_type ats) 93 = lbrack . sep_list list_separator shows ats . rbrack 94 showsPrec d (Array_type at at') 95 = showParen (d >= apply_prec) 96 (array_type_name . space . showsPrec apply_prec at 97 . space . showsPrec apply_prec at') 98 99 instance Show Base_type where 100 showsPrec _ (Num_type k) = shows k 101 showsPrec _ Bool_type = bool_type_name 102 showsPrec _ Char_type = char_type_name 103 104 instance Show Num_kind where 105 showsPrec _ Int_type = int_type_name 106 showsPrec _ Integer_type = integer_type_name 107 showsPrec _ Float_type = float_type_name 108 showsPrec _ Double_type = double_type_name 109 110 111 112 113 114 115 showsType_decl :: Type_decl -> ShowS 116 showsType_decl (tn, ht) 117 = data_name . space . showString tn . type_def 118 . sep_list union showsVnt ht . space . derive_eq 119 where 120 showsVnt (c, ats) = showString c . field_separator 121 . sep_list field_separator 122 (showsPrec apply_prec) ats 123 124 125 126 127 128 129 130 131 132 133 134 135 136 type Val_decl = (Val_name, Value) 137 138 139 140 141 142 143 144 data Value = Num_val Num_kind Int 145 | Bool_val Bool 146 | Char_val Char 147 | List_val [Value] 148 | Tuple_val [Value] 149 | Tagged_val Constructor [Value] 150 | Array_val (Value,Value) [(Value, Value)] 151 deriving (Eq) 152 153 type Val_name = String 154 155 156 157 158 159 160 161 instance Show Value where 162 showsPrec d (Num_val Int_type n) = showsPrec d n 163 showsPrec d (Num_val Integer_type n) = showsPrec d n 164 showsPrec d (Num_val Float_type n) = showsPrec d (int_to_float n) 165 showsPrec d (Num_val Double_type n) = showsPrec d (int_to_double n) 166 showsPrec d (Bool_val b) = showsPrec d b 167 showsPrec d (Char_val c) = showsPrec d c 168 showsPrec _ (List_val vs) 169 = lsq . sep_list list_separator shows vs . rsq 170 showsPrec _ (Tuple_val vs) 171 = lbrack . sep_list list_separator shows vs . rbrack 172 showsPrec d (Tagged_val c vs) 173 = showParen (d >= apply_prec) 174 (showString c . field_separator 175 . sep_list field_separator (showsPrec apply_prec) vs) 176 showsPrec d (Array_val (v,v') avs) 177 = showParen (d >= apply_prec) 178 (array_name . space . (showsPrec apply_prec (Tuple_val [v,v'])) 179 . space . showsPrec apply_prec avs) 180 181 182 183 184 185 186 showsVal_decl :: Val_decl -> ShowS 187 showsVal_decl (vn, v) = showString vn . val_def . shows v 188 189 190 191 192 193 194 195 196 197 198 199 vrange :: (Value,Value) -> [Value] 200 vrange (Num_val Int_type n, Num_val Int_type n') 201 = [int_val r | r <- [n..n']] 202 vrange (Num_val Integer_type n, Num_val Integer_type n') 203 = [Num_val Integer_type r | r <- [n..n']] 204 vrange (Bool_val b, Bool_val b') = [Bool_val r | r <- [b..b']] 205 vrange (Char_val c, Char_val c') = [Char_val r | r <- [c..c']] 206 vrange (Tuple_val vs, Tuple_val vs') = 207 [Tuple_val vs'' | vs'' <- f (map vrange (zip vs vs'))] 208 where 209 f [] = [[]] 210 f (vs:vss) = [(i:is) | i <- vs, is <- f vss] 211 vrange x = error ("Error: vrange called on " 212 ++ show x) 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 int_to_float :: Int -> Float 242 int_to_float n = fromIntegral n 243 244 int_to_double :: Int -> Double 245 int_to_double n = fromIntegral n 246 247 248 249 250 251 252 int_val :: Int -> Value 253 int_val n = Num_val Int_type n 254 255 256 257 258 259 260 261 262 263 264 265 266 267 data Expression = Apply_exp Expression Expression 268 | Id_exp Val_name 269 | Val_exp Value 270 | Tagged_exp Constructor [Expression] 271 | List_exp [Expression] 272 | Tuple_exp [Expression] 273 | Lambda_exp Val_name Expression 274 | Array_exp Expression Expression 275 deriving (Eq) 276 277 278 279 280 281 282 283 instance Show Expression where 284 showsPrec d (Apply_exp e1 e2) 285 = showParen (d > apply_prec) 286 (showsPrec apply_prec e1 . space . showsPrec (apply_prec+one) e2) 287 showsPrec _ (Id_exp vn) 288 = showParen (is_op vn) (showString vn) 289 where 290 is_op (c:cs) = not (isAlpha c) 291 showsPrec d (Val_exp v) = showsPrec d v 292 showsPrec d (Tagged_exp c es) 293 = showParen (d > apply_prec) 294 (showString c . field_separator 295 . sep_list field_separator (showsPrec (apply_prec+one)) es) 296 showsPrec _ (List_exp es) 297 = lsq . sep_list list_separator shows es . rsq 298 showsPrec _ (Tuple_exp es) 299 = lbrack . sep_list list_separator shows es . rbrack 300 showsPrec _ (Lambda_exp vn e) 301 = lbrack . lambda_name . showString vn . space . map_name . space 302 . shows e . rbrack 303 showsPrec d (Array_exp e e') 304 = showParen (d > apply_prec) 305 (array_name . space . showsPrec (apply_prec+one) e . space 306 . showsPrec (apply_prec+one) e') 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 sep_list :: ShowS -> (a -> ShowS) -> [a] -> ShowS 322 sep_list s f [] = empty_string 323 sep_list s f xs = foldr1 g (map f xs) 324 where 325 g x y = x . s . y 326 327