TT types and values, some text manipulation, basics of Core
Showing the changes to src/Data/StringMap.idr (1 of 18 files). Show all
Unified · Split
| @@ -0,0 +1,303 @@ | |||
| 1 | module Data.StringMap | ||
| 2 | |||
| 3 | -- Hand specialised map, for efficiency... | ||
| 4 | |||
| 5 | %default covering | ||
| 6 | |||
| 7 | Key : Type | ||
| 8 | Key = String | ||
| 9 | |||
| 10 | -- TODO: write split | ||
| 11 | |||
| 12 | private | ||
| 13 | data Tree : Nat -> Type -> Type where | ||
| 14 | Leaf : Key -> v -> Tree Z v | ||
| 15 | Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v | ||
| 16 | Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v | ||
| 17 | |||
| 18 | branch4 : | ||
| 19 | Tree n v -> Key -> | ||
| 20 | Tree n v -> Key -> | ||
| 21 | Tree n v -> Key -> | ||
| 22 | Tree n v -> | ||
| 23 | Tree (S (S n)) v | ||
| 24 | branch4 a b c d e f g = | ||
| 25 | Branch2 (Branch2 a b c) d (Branch2 e f g) | ||
| 26 | |||
| 27 | branch5 : | ||
| 28 | Tree n v -> Key -> | ||
| 29 | Tree n v -> Key -> | ||
| 30 | Tree n v -> Key -> | ||
| 31 | Tree n v -> Key -> | ||
| 32 | Tree n v -> | ||
| 33 | Tree (S (S n)) v | ||
| 34 | branch5 a b c d e f g h i = | ||
| 35 | Branch2 (Branch2 a b c) d (Branch3 e f g h i) | ||
| 36 | |||
| 37 | branch6 : | ||
| 38 | Tree n v -> Key -> | ||
| 39 | Tree n v -> Key -> | ||
| 40 | Tree n v -> Key -> | ||
| 41 | Tree n v -> Key -> | ||
| 42 | Tree n v -> Key -> | ||
| 43 | Tree n v -> | ||
| 44 | Tree (S (S n)) v | ||
| 45 | branch6 a b c d e f g h i j k = | ||
| 46 | Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k) | ||
| 47 | |||
| 48 | branch7 : | ||
| 49 | Tree n v -> Key -> | ||
| 50 | Tree n v -> Key -> | ||
| 51 | Tree n v -> Key -> | ||
| 52 | Tree n v -> Key -> | ||
| 53 | Tree n v -> Key -> | ||
| 54 | Tree n v -> Key -> | ||
| 55 | Tree n v -> | ||
| 56 | Tree (S (S n)) v | ||
| 57 | branch7 a b c d e f g h i j k l m = | ||
| 58 | Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m) | ||
| 59 | |||
| 60 | merge1 : Tree n v -> Key -> Tree (S n) v -> Key -> Tree (S n) v -> Tree (S (S n)) v | ||
| 61 | merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i | ||
| 62 | merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k | ||
| 63 | merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k | ||
| 64 | merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m | ||
| 65 | |||
| 66 | merge2 : Tree (S n) v -> Key -> Tree n v -> Key -> Tree (S n) v -> Tree (S (S n)) v | ||
| 67 | merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i | ||
| 68 | merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k | ||
| 69 | merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k | ||
| 70 | merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m | ||
| 71 | |||
| 72 | merge3 : Tree (S n) v -> Key -> Tree (S n) v -> Key -> Tree n v -> Tree (S (S n)) v | ||
| 73 | merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i | ||
| 74 | merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k | ||
| 75 | merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k | ||
| 76 | merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m | ||
| 77 | |||
| 78 | treeLookup : Key -> Tree n v -> Maybe v | ||
| 79 | treeLookup k (Leaf k' v) = | ||
| 80 | if k == k' then | ||
| 81 | Just v | ||
| 82 | else | ||
| 83 | Nothing | ||
| 84 | treeLookup k (Branch2 t1 k' t2) = | ||
| 85 | if k <= k' then | ||
| 86 | treeLookup k t1 | ||
| 87 | else | ||
| 88 | treeLookup k t2 | ||
| 89 | treeLookup k (Branch3 t1 k1 t2 k2 t3) = | ||
| 90 | if k <= k1 then | ||
| 91 | treeLookup k t1 | ||
| 92 | else if k <= k2 then | ||
| 93 | treeLookup k t2 | ||
| 94 | else | ||
| 95 | treeLookup k t3 | ||
| 96 | |||
| 97 | treeInsert' : Key -> v -> Tree n v -> Either (Tree n v) (Tree n v, Key, Tree n v) | ||
| 98 | treeInsert' k v (Leaf k' v') = | ||
| 99 | case compare k k' of | ||
| 100 | LT => Right (Leaf k v, k, Leaf k' v') | ||
| 101 | EQ => Left (Leaf k v) | ||
| 102 | GT => Right (Leaf k' v', k', Leaf k v) | ||
| 103 | treeInsert' k v (Branch2 t1 k' t2) = | ||
| 104 | if k <= k' then | ||
| 105 | case treeInsert' k v t1 of | ||
| 106 | Left t1' => Left (Branch2 t1' k' t2) | ||
| 107 | Right (a, b, c) => Left (Branch3 a b c k' t2) | ||
| 108 | else | ||
| 109 | case treeInsert' k v t2 of | ||
| 110 | Left t2' => Left (Branch2 t1 k' t2') | ||
| 111 | Right (a, b, c) => Left (Branch3 t1 k' a b c) | ||
| 112 | treeInsert' k v (Branch3 t1 k1 t2 k2 t3) = | ||
| 113 | if k <= k1 then | ||
| 114 | case treeInsert' k v t1 of | ||
| 115 | Left t1' => Left (Branch3 t1' k1 t2 k2 t3) | ||
| 116 | Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3) | ||
| 117 | else | ||
| 118 | if k <= k2 then | ||
| 119 | case treeInsert' k v t2 of | ||
| 120 | Left t2' => Left (Branch3 t1 k1 t2' k2 t3) | ||
| 121 | Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3) | ||
| 122 | else | ||
| 123 | case treeInsert' k v t3 of | ||
| 124 | Left t3' => Left (Branch3 t1 k1 t2 k2 t3') | ||
| 125 | Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c) | ||
| 126 | |||
| 127 | treeInsert : Key -> v -> Tree n v -> Either (Tree n v) (Tree (S n) v) | ||
| 128 | treeInsert k v t = | ||
| 129 | case treeInsert' k v t of | ||
| 130 | Left t' => Left t' | ||
| 131 | Right (a, b, c) => Right (Branch2 a b c) | ||
| 132 | |||
| 133 | delType : Nat -> Type -> Type | ||
| 134 | delType Z v = () | ||
| 135 | delType (S n) v = Tree n v | ||
| 136 | |||
| 137 | treeDelete : Key -> Tree n v -> Either (Tree n v) (delType n v) | ||
| 138 | treeDelete k (Leaf k' v) = | ||
| 139 | if k == k' then | ||
| 140 | Right () | ||
| 141 | else | ||
| 142 | Left (Leaf k' v) | ||
| 143 | treeDelete {n=S Z} k (Branch2 t1 k' t2) = | ||
| 144 | if k <= k' then | ||
| 145 | case treeDelete k t1 of | ||
| 146 | Left t1' => Left (Branch2 t1' k' t2) | ||
| 147 | Right () => Right t2 | ||
| 148 | else | ||
| 149 | case treeDelete k t2 of | ||
| 150 | Left t2' => Left (Branch2 t1 k' t2') | ||
| 151 | Right () => Right t1 | ||
| 152 | treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) = | ||
| 153 | if k <= k1 then | ||
| 154 | case treeDelete k t1 of | ||
| 155 | Left t1' => Left (Branch3 t1' k1 t2 k2 t3) | ||
| 156 | Right () => Left (Branch2 t2 k2 t3) | ||
| 157 | else if k <= k2 then | ||
| 158 | case treeDelete k t2 of | ||
| 159 | Left t2' => Left (Branch3 t1 k1 t2' k2 t3) | ||
| 160 | Right () => Left (Branch2 t1 k1 t3) | ||
| 161 | else | ||
| 162 | case treeDelete k t3 of | ||
| 163 | Left t3' => Left (Branch3 t1 k1 t2 k2 t3') | ||
| 164 | Right () => Left (Branch2 t1 k1 t2) | ||
| 165 | treeDelete {n=S (S _)} k (Branch2 t1 k' t2) = | ||
| 166 | if k <= k' then | ||
| 167 | case treeDelete k t1 of | ||
| 168 | Left t1' => Left (Branch2 t1' k' t2) | ||
| 169 | Right t1' => | ||
| 170 | case t2 of | ||
| 171 | Branch2 a b c => Right (Branch3 t1' k' a b c) | ||
| 172 | Branch3 a b c d e => Left (branch4 t1' k' a b c d e) | ||
| 173 | else | ||
| 174 | case treeDelete k t2 of | ||
| 175 | Left t2' => Left (Branch2 t1 k' t2') | ||
| 176 | Right t2' => | ||
| 177 | case t1 of | ||
| 178 | Branch2 a b c => Right (Branch3 a b c k' t2') | ||
| 179 | Branch3 a b c d e => Left (branch4 a b c d e k' t2') | ||
| 180 | treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) = | ||
| 181 | if k <= k1 then | ||
| 182 | case treeDelete k t1 of | ||
| 183 | Left t1' => Left (Branch3 t1' k1 t2 k2 t3) | ||
| 184 | Right t1' => Left (merge1 t1' k1 t2 k2 t3) | ||
| 185 | else if k <= k2 then | ||
| 186 | case treeDelete k t2 of | ||
| 187 | Left t2' => Left (Branch3 t1 k1 t2' k2 t3) | ||
| 188 | Right t2' => Left (merge2 t1 k1 t2' k2 t3) | ||
| 189 | else | ||
| 190 | case treeDelete k t3 of | ||
| 191 | Left t3' => Left (Branch3 t1 k1 t2 k2 t3') | ||
| 192 | Right t3' => Left (merge3 t1 k1 t2 k2 t3') | ||
| 193 | |||
| 194 | treeToList : Tree n v -> List (Key, v) | ||
| 195 | treeToList = treeToList' (:: []) | ||
| 196 | where | ||
| 197 | treeToList' : ((Key, v) -> List (Key, v)) -> Tree n v -> List (Key, v) | ||
| 198 | treeToList' cont (Leaf k v) = cont (k, v) | ||
| 199 | treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1 | ||
| 200 | treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1 | ||
| 201 | |||
| 202 | export | ||
| 203 | data StringMap : Type -> Type where | ||
| 204 | Empty : StringMap v | ||
| 205 | M : (n : Nat) -> Tree n v -> StringMap v | ||
| 206 | |||
| 207 | export | ||
| 208 | empty : StringMap v | ||
| 209 | empty = Empty | ||
| 210 | |||
| 211 | export | ||
| 212 | lookup : String -> StringMap v -> Maybe v | ||
| 213 | lookup _ Empty = Nothing | ||
| 214 | lookup k (M _ t) = treeLookup k t | ||
| 215 | |||
| 216 | export | ||
| 217 | insert : String -> v -> StringMap v -> StringMap v | ||
| 218 | insert k v Empty = M Z (Leaf k v) | ||
| 219 | insert k v (M _ t) = | ||
| 220 | case treeInsert k v t of | ||
| 221 | Left t' => (M _ t') | ||
| 222 | Right t' => (M _ t') | ||
| 223 | |||
| 224 | export | ||
| 225 | insertFrom : Foldable f => f (String, v) -> StringMap v -> StringMap v | ||
| 226 | insertFrom = flip $ foldl $ flip $ uncurry insert | ||
| 227 | |||
| 228 | export | ||
| 229 | delete : String -> StringMap v -> StringMap v | ||
| 230 | delete _ Empty = Empty | ||
| 231 | delete k (M Z t) = | ||
| 232 | case treeDelete k t of | ||
| 233 | Left t' => (M _ t') | ||
| 234 | Right () => Empty | ||
| 235 | delete k (M (S _) t) = | ||
| 236 | case treeDelete k t of | ||
| 237 | Left t' => (M _ t') | ||
| 238 | Right t' => (M _ t') | ||
| 239 | |||
| 240 | export | ||
| 241 | fromList : List (String, v) -> StringMap v | ||
| 242 | fromList l = foldl (flip (uncurry insert)) empty l | ||
| 243 | |||
| 244 | export | ||
| 245 | toList : StringMap v -> List (String, v) | ||
| 246 | toList Empty = [] | ||
| 247 | toList (M _ t) = treeToList t | ||
| 248 | |||
| 249 | ||| Gets the Keyeys of the map. | ||
| 250 | export | ||
| 251 | keys : StringMap v -> List String | ||
| 252 | keys = map fst . toList | ||
| 253 | |||
| 254 | ||| Gets the values of the map. Could contain duplicates. | ||
| 255 | export | ||
| 256 | values : StringMap v -> List v | ||
| 257 | values = map snd . toList | ||
| 258 | |||
| 259 | treeMap : (a -> b) -> Tree n a -> Tree n b | ||
| 260 | treeMap f (Leaf k v) = Leaf k (f v) | ||
| 261 | treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2) | ||
| 262 | treeMap f (Branch3 t1 k1 t2 k2 t3) | ||
| 263 | = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3) | ||
| 264 | |||
| 265 | export | ||
| 266 | implementation Functor (StringMap) where | ||
| 267 | map _ Empty = Empty | ||
| 268 | map f (M n t) = M _ (treeMap f t) | ||
| 269 | |||
| 270 | ||| Merge two maps. When encountering duplicate keys, using a function to combine the values. | ||
| 271 | ||| Uses the ordering of the first map given. | ||
| 272 | export | ||
| 273 | mergeWith : (v -> v -> v) -> StringMap v -> StringMap v -> StringMap v | ||
| 274 | mergeWith f x y = insertFrom inserted x where | ||
| 275 | inserted : List (Key, v) | ||
| 276 | inserted = do | ||
| 277 | (k, v) <- toList y | ||
| 278 | let v' = (maybe id f $ lookup k x) v | ||
| 279 | pure (k, v') | ||
| 280 | |||
| 281 | ||| Merge two maps using the Semigroup (and by extension, Monoid) operation. | ||
| 282 | ||| Uses mergeWith internally, so the ordering of the left map is kept. | ||
| 283 | export | ||
| 284 | merge : Semigroup v => StringMap v -> StringMap v -> StringMap v | ||
| 285 | merge = mergeWith (<+>) | ||
| 286 | |||
| 287 | ||| Left-biased merge, also keeps the ordering specified by the left map. | ||
| 288 | export | ||
| 289 | mergeLeft : StringMap v -> StringMap v -> StringMap v | ||
| 290 | mergeLeft = mergeWith const | ||
| 291 | |||
| 292 | -- TODO: is this the right variant of merge to use for this? I think it is, but | ||
| 293 | -- I could also see the advantages of using `mergeLeft`. The current approach is | ||
| 294 | -- strictly more powerful I believe, because `mergeLeft` can be emulated with | ||
| 295 | -- the `First` monoid. However, this does require more code to do the same | ||
| 296 | -- thing. | ||
| 297 | export | ||
| 298 | Semigroup v => Semigroup (StringMap v) where | ||
| 299 | (<+>) = merge | ||
| 300 | |||
| 301 | export | ||
| 302 | (Semigroup v) => Monoid (StringMap v) where | ||
| 303 | neutral = empty | ||