1(* Title: Pure/General/alist.ML 2 Author: Florian Haftmann, TU Muenchen 3 4Association lists -- lists of (key, value) pairs. 5*) 6 7structure AList :> AList = 8struct 9 10open Portable 11 12infix |>> 13 14fun find_index eq xs key = 15 let 16 fun find [] _ = ~1 17 | find ((key', value)::xs) i = 18 if eq (key, key') 19 then i 20 else find xs (i+1); 21 in find xs 0 end; 22 23fun map_index eq key f_none f_some xs = 24 let 25 val i = find_index eq xs key 26 fun mapp 0 (x::xs) = f_some x xs 27 | mapp i (x::xs) = x :: mapp (i-1) xs 28 | mapp _ _ = raise Fail "Impossible case - AList.map_index.mapp" 29 in 30 (if i = ~1 then f_none else mapp i) xs 31 end; 32 33fun lookup _ [] _ = NONE 34 | lookup eq ((key, value)::xs) key' = 35 if eq (key', key) then SOME value 36 else lookup eq xs key'; 37 38fun defined _ [] _ = false 39 | defined eq ((key, value)::xs) key' = 40 eq (key', key) orelse defined eq xs key'; 41 42fun update eq (x as (key, value)) = 43 map_index eq key (cons x) (fn _ => cons x); 44 45fun default eq (key, value) xs = 46 if defined eq xs key then xs else (key, value) :: xs; 47 48fun delete eq key = 49 map_index eq key I (K I); 50 51fun map_entry eq key f = 52 map_index eq key I (fn (key, value) => cons (key, f value)); 53 54fun map_default eq (key, value) f = 55 map_index eq key (cons (key, f value)) (fn (key, value) => cons (key, f value)); 56 57fun map_entry_yield eq key f xs = 58 let 59 val i = find_index eq xs key; 60 fun mapp 0 ((x as (key, value))::xs) = 61 let val (r, value') = f value 62 in (SOME r, (key, value') :: xs) end 63 | mapp i (x::xs) = 64 let val (r, xs') = mapp (i-1) xs 65 in (r, x::xs') end 66 | mapp _ _ = raise Fail "Impossible case - AList.map_entry_yield" 67 in if i = ~1 then (NONE, xs) else mapp i xs end; 68 69exception DUP; 70 71fun join eq f (xs, ys) = 72 let 73 fun add (y as (key, value)) xs = 74 (case lookup eq xs key of 75 NONE => cons y xs 76 | SOME value' => update eq (key, f key (value', value)) xs); 77 in foldr' add ys xs end; 78 79fun merge eq_key eq_val = 80 join eq_key (K (fn (yx as (_, x)) => if eq_val yx then x else raise DUP)); 81 82fun make keyfun = 83 let fun keypair x = (x, keyfun x) 84 in map keypair end; 85 86fun find eq [] _ = [] 87 | find eq ((key, value) :: xs) value' = 88 let 89 val values = find eq xs value'; 90 in if eq (value', value) then key :: values else values end; 91 92fun coalesce eq = 93 let 94 fun vals _ [] = ([], []) 95 | vals x (lst as (y, b) :: ps) = 96 if eq (x, y) then vals x ps |>> cons b 97 else ([], lst); 98 fun coal [] = [] 99 | coal ((x, a) :: ps) = 100 let val (bs, qs) = vals x ps 101 in (x, a :: bs) :: coal qs end; 102 in coal end; 103 104fun group eq xs = 105 foldr' (fn (k, v) => map_default eq (k, []) (cons v)) xs []; 106 107end; 108