StdGeneric.icl 1.36 KB
Newer Older
1 2 3 4
implementation module StdGeneric

import StdInt, StdMisc, StdClass, StdFunc

5
generic bimap a b | bimap b a :: .a ->.b
6

7
bimap{|c|} x = x
8

9
bimap{|PAIR|} fx _ fy _ (PAIR x y) = PAIR (fx x) (fy y)
10

11 12
bimap{|EITHER|} fl _ fr _ (LEFT x) 	= LEFT (fl x)
bimap{|EITHER|} fl _ fr _ (RIGHT x)	= RIGHT (fr x)
13

14
bimap{|CONS|} fx _ (CONS x) = CONS (fx x)
15

16
bimap{|RECORD|} fx _ (RECORD x) = RECORD (fx x)
17

18
bimap{|FIELD|} fx _ (FIELD x) = FIELD (fx x)
19

20
bimap{|OBJECT|} fx _ (OBJECT x) = OBJECT (fx x)
21

22
bimap{|(->)|} _ ba fr _ f = comp3 fr f ba
23 24 25 26 27 28 29 30 31 32 33 34 35 36

comp3 :: !(.a -> .b) u:(.c -> .a) !(.d -> .c) -> u:(.d -> .b)
comp3 f g h
	| is_id f
		| is_id h
			= cast g
			= cast (\x -> g (h x))
		| is_id h
			= cast (\x -> f (g x))
			= \x -> f (g (h x))
where
	is_id :: !.(.a -> .b) -> Bool
	is_id f = code inline
	{
37
		eq_desc e_StdFunctions_did 0 0
38 39 40 41 42 43 44 45 46 47 48
		pop_a 1
	}
	
	cast :: !u:a -> u:b
	cast f = code inline
	{
		pop_a 0
	}

getConsPath :: !GenericConsDescriptor -> [ConsPos]
getConsPath {gcd_index, gcd_type_def={gtd_num_conses}}
49 50 51
	| gtd_num_conses==0
		= [] // for newtype
		= doit gcd_index gtd_num_conses
52 53 54 55 56 57
where
	doit i n
		| i >= n	
			= abort "getConsPath: cons index >= number of conses"
		| n == 1
			= []
58 59
		| i < (n>>1)
			= [ ConsLeft : doit i (n>>1) ]
60
		| otherwise
61
			= [ ConsRight : doit (i - (n>>1)) (n - (n>>1)) ]
62 63 64

bimapId :: Bimap .a .a	// deprecated, no longer used
bimapId = { map_to = id, map_from = id }