Types/Data/Map.hs

   1 {-# LANGUAGE
   2   EmptyDataDecls,
   3   TypeFamilies,
   4   TypeOperators,
   5   UndecidableInstances
   6   #-}
   7 module Types.Data.Map
   8     ( -- * Map class
   9       Map
  10
  11       -- * Query
  12     , Null
  13     , Size
  14     , Lookup
  15     , LookupAssoc
  16     , Member
  17     , NotMember
  18     , Find
  19     , FindWithDefault
  20
  21       -- * Construction
  22     , Empty
  23     , Singleton
  24
  25       -- ** Insertion
  26     , Insert
  27
  28       -- ** Delete\/Update
  29     , Delete
  30     , Adjust
  31     , AdjustWithKey
  32     , UpdateWithKey
  33
  34       -- * Traversal
  35       -- ** Map
  36     , MapValue
  37     , MapWithKey
  38
  39       -- ** Fold
  40     , FoldrWithKey
  41     , FoldlWithKey
  42
  43       -- * Conversion
  44     , Keys
  45     , Assocs
  46
  47       -- ** Lists
  48     , ToList
  49     , FromList
  50
  51       -- ** Ordered lists
  52     , ToAscList
  53     , ToDescList
  54
  55       -- * Min\/Max
  56     , DeleteFindMin
  57     , DeleteFindMax
  58     , MinView
  59     , MaxView
  60     , MinViewWithKey
  61     , MaxViewWithKey
  62     )
  63     where
  64
  65 import qualified Types.Data.List as L
  66 import qualified Types.Data.List.Ops as L
  67
  68 import Types.Data.Bool
  69 import Types.Data.List hiding (Null)
  70 import Types.Data.List.Ops hiding (Map)
  71 import Types.Data.Maybe
  72 import Types.Data.Num
  73 import Types.Data.Ord
  74
  75 data Tip
  76 data Bin size key value left right
  77
  78 class    Map m
  79 instance Map Tip
  80 instance Map (Bin s k v l r)
  81
  82 -- Null
  83 type family   Null m
  84 type instance Null Tip             = True
  85 type instance Null (Bin s k v l r) = False
  86
  87 -- Size
  88 type family   Size m
  89 type instance Size Tip             = D0
  90 type instance Size (Bin s k v l r) = s
  91
  92 -- CompCase
  93 type family   CompCase o  ifLT ifGT ifEQ
  94 type instance CompCase LT ifLT ifGT ifEQ = ifLT
  95 type instance CompCase GT ifLT ifGT ifEQ = ifGT
  96 type instance CompCase EQ ifLT ifGT ifEQ = ifEQ
  97
  98 -- Lookup
  99 type family   Lookup k m
 100 type instance Lookup k Tip              = Nothing
 101 type instance Lookup k (Bin s k' v l r)
 102     = CompCase (Compare k k')
 103                (Lookup k l)
 104                (Lookup k r)
 105                (Just v)
 106
 107 -- LookupAssoc
 108 type family   LookupAssoc k m
 109 type instance LookupAssoc k Tip              = Nothing
 110 type instance LookupAssoc k (Bin s k' v l r)
 111     = CompCase (Compare k k')
 112                (LookupAssoc k l)
 113                (LookupAssoc k r)
 114                (Just (Cons k v))
 115
 116 -- Member
 117 type Member k m = IsJust (Lookup k m)
 118
 119 -- NotMember
 120 type NotMember k m = Not (Member k m)
 121
 122 -- Find
 123 type Find k m = FromJust (Lookup k m)
 124
 125 -- FindWithDefault
 126 type FindWithDefault a k m
 127     = FromMaybe a (Lookup k m)
 128
 129 -- Empty
 130 type Empty = Tip
 131
 132 -- Singleton
 133 type Singleton k v = Bin D1 k v Tip Tip
 134
 135 -- Insert
 136 type family   Insert k v m
 137 type instance Insert k v Tip              = Singleton k v
 138 type instance Insert k v (Bin s k' v' l r)
 139     = CompCase (Compare k k')
 140                (Balance k' v' (Insert k v l) r)
 141                (Balance k' v' l (Insert k v r))
 142                (Bin s k v l r)
 143
 144 -- Delete
 145 type family   Delete k m
 146 type instance Delete k Tip              = Tip
 147 type instance Delete k (Bin s k' v l r)
 148     = CompCase (Compare k k')
 149                (Balance k' v (Delete k l) r)
 150                (Balance k' v l (Delete k r))
 151                (Glue l r)
 152
 153 -- Balance
 154 type Delta = D5
 155 type Ratio = D2
 156
 157 type Balance k v l r
 158     = If ((Size l :+: Size r) :<=: D1)
 159          (Bin (SizeX l r) k v l r)
 160          (If (Size r :>=: (Delta :*: Size l))
 161              (RotateL k v l r)
 162              (If (Size l :>=: (Delta :*: Size r))
 163                  (RotateR k v l r)
 164                  (Bin (SizeX l r) k v l r)))
 165
 166 type SizeX l r = Size l :+: Size r :+: D1
 167
 168 -- Rotate
 169 type family   RotateL k v l r
 170 type instance RotateL k v l (Bin s k' v' l' r')
 171     = If (Size l' :<: (Ratio :*: Size r'))
 172          (SingleL k v l (Bin s k' v' l' r'))
 173          (DoubleL k v l (Bin s k' v' l' r'))
 174
 175 type family   RotateR k v l r
 176 type instance RotateR k v (Bin s k' v' l' r') r
 177     = If (Size r' :<: (Ratio :*: Size l'))
 178          (SingleR k v (Bin s k' v' l' r') r)
 179          (DoubleR k v (Bin s k' v' l' r') r)
 180
 181 -- Rotations
 182 type family   SingleL k v l r
 183 type instance SingleL k v l (Bin s k' v' l' r')
 184     = Bin' k' v' (Bin' k v l l') r'
 185
 186 type family   SingleR k v l r
 187 type instance SingleR k v (Bin s k' v' l r) r'
 188     = Bin' k' v' l (Bin' k v r r')
 189
 190 type family   DoubleL k v l r
 191 type instance DoubleL k v l (Bin s k' v' (Bin s' k'' v'' l' r) r')
 192     = Bin' k'' v'' (Bin' k v l l') (Bin' k' v' r r')
 193
 194 type family   DoubleR k v l r
 195 type instance DoubleR k v (Bin s k' v' l (Bin s' k'' v'' l' r)) r'
 196     = Bin' k'' v'' (Bin' k' v' l l') (Bin' k v r r')
 197
 198 -- Bin'
 199 type Bin' k v l r
 200     = Bin (Size l :+: Size r :+: D1) k v l r
 201
 202 -- Glue
 203 type Glue l r
 204     = If (Null l)
 205          r
 206          (If (Null r)
 207              l
 208              (If (Size l :>: Size r)
 209                  (GlueL (DeleteFindMax l) r)
 210                  (GlueR l (DeleteFindMin r))))
 211
 212 type family   GlueL dfm r
 213 type instance GlueL (Cons (Cons km m) l') r = Balance km m l' r
 214
 215 type family   GlueR l dfm
 216 type instance GlueR l (Cons (Cons km m) r') = Balance km m l r'
 217
 218 -- DeleteFindMin
 219 type family   DeleteFindMin m
 220 type instance DeleteFindMin (Bin s k v l r)
 221     = If (Null l)
 222          (Cons (Cons k v) r)
 223          (DeleteFindMin' k v (DeleteFindMin l) r)
 224
 225 type family   DeleteFindMin' k v dfm r
 226 type instance DeleteFindMin' k v (Cons km l') r
 227     = Cons km (Balance k v l' r)
 228
 229 -- DeleteFindMax
 230 type family   DeleteFindMax m
 231 type instance DeleteFindMax (Bin s k v l r)
 232     = If (Null r)
 233          (Cons (Cons k v) l)
 234          (DeleteFindMax' k v l (DeleteFindMax r))
 235
 236 type family   DeleteFindMax' k v l dfm
 237 type instance DeleteFindMax' k v l (Cons km r')
 238     = Cons km (Balance k v l r')
 239
 240 -- MinViewWithKey
 241 type MinViewWithKey m
 242     = If (Null m)
 243          Nothing
 244          (Just (DeleteFindMin m))
 245
 246 -- MaxViewWithKey
 247 type MaxViewWithKey m
 248     = If (Null m)
 249          Nothing
 250          (Just (DeleteFindMax m))
 251
 252 -- MinView
 253 type MinView m
 254     = If (Null m)
 255          Nothing
 256          (Just (View' (DeleteFindMin m)))
 257
 258 type family   View' m
 259 type instance View' (Cons (Cons k v) m') = Cons v m'
 260
 261 -- MaxView
 262 type MaxView m
 263     = If (Null m)
 264          Nothing
 265          (Just (View' (DeleteFindMax m)))
 266
 267 -- Adjust
 268 type Adjust f k m
 269     = AdjustWithKey (Adjust' f) k m
 270
 271 data Adjust' f
 272 type instance App2 (Adjust' f) k v = App f v
 273
 274 -- AdjustWithKey
 275 type AdjustWithKey f k m
 276     = UpdateWithKey (AdjustWithKey' f) k m
 277
 278 data AdjustWithKey' f
 279 type instance App2 (AdjustWithKey' f) k v = Just (App2 f k v)
 280
 281 -- UpdateWithKey
 282 type family   UpdateWithKey f k m
 283 type instance UpdateWithKey f k Tip              = Tip
 284 type instance UpdateWithKey f k (Bin s k' v l r)
 285     = CompCase (Compare k k')
 286                (Balance k' v (UpdateWithKey f k l) r)
 287                (Balance k' v l (UpdateWithKey f k r))
 288                (UpdateWithKey' s k' (App2 f k' v) l r)
 289
 290 type family   UpdateWithKey' s k mv l r
 291 type instance UpdateWithKey' s k (Just v) l r = Bin s k v l r
 292 type instance UpdateWithKey' s k Nothing  l r = Glue l r
 293
 294 -- Map
 295 type MapValue f m = MapWithKey (MapValue' f) m
 296
 297 data MapValue' f
 298 type instance App2 (MapValue' f) k v = App f v
 299
 300 -- MapWithKey
 301 type family   MapWithKey f m
 302 type instance MapWithKey f Tip             = Tip
 303 type instance MapWithKey f (Bin s k v l r)
 304     = Bin s k (App2 f k v) (MapWithKey f l) (MapWithKey f r)
 305
 306 -- FoldrWithKey
 307 type family   FoldrWithKey f z m
 308 type instance FoldrWithKey f z Tip             = z
 309 type instance FoldrWithKey f z (Bin s k v l r)
 310     = FoldrWithKey f (App3 f k v (FoldrWithKey f z r)) l
 311
 312 -- FoldlWithKey
 313 type family   FoldlWithKey f z m
 314 type instance FoldlWithKey f z Tip             = z
 315 type instance FoldlWithKey f z (Bin s k v l r)
 316     = FoldlWithKey f (App3 f (FoldlWithKey f z l) k v) r
 317
 318 -- Keys
 319 type Keys m = L.Map Key' (Assocs m)
 320
 321 data Key'
 322 type instance App Key' (Cons k v) = k
 323
 324 -- Assocs
 325 type Assocs m = ToList m
 326
 327 -- ToList
 328 type ToList m = ToAscList m
 329
 330 -- FromList
 331 type FromList xs = Foldl Ins' Empty xs
 332
 333 data Ins'
 334 type instance App2 Ins' m (Cons k v) = Insert k v m
 335
 336 -- ToAscList
 337 type ToAscList m = FoldrWithKey ToAscList' L.Null m
 338
 339 data ToAscList'
 340 type instance App3 ToAscList' k v vs = Cons (Cons k v) vs
 341
 342 -- ToDescList
 343 type ToDescList m = FoldlWithKey ToDescList' L.Null m
 344
 345 data ToDescList'
 346 type instance App3 ToDescList' vs k v = Cons (Cons k v) vs