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 CompCase a b ifLT ifGT ifEQ
  94     = If (IsLT (Compare a b))
  95          ifLT
  96          (If (IsGT (Compare a b))
  97              ifGT
  98              ifEQ)
  99
 100 -- Lookup
 101 type family   Lookup k m
 102 type instance Lookup k Tip              = Nothing
 103 type instance Lookup k (Bin s k' v l r)
 104     = CompCase k k'
 105                (Lookup k l)
 106                (Lookup k r)
 107                (Just v)
 108
 109 -- LookupAssoc
 110 type family   LookupAssoc k m
 111 type instance LookupAssoc k Tip              = Nothing
 112 type instance LookupAssoc k (Bin s k' v l r)
 113     = CompCase k k'
 114                (LookupAssoc k l)
 115                (LookupAssoc k r)
 116                (Just (Cons k v))
 117
 118 -- Member
 119 type Member k m = IsJust (Lookup k m)
 120
 121 -- NotMember
 122 type NotMember k m = Not (Member k m)
 123
 124 -- Find
 125 type Find k m = FromJust (Lookup k m)
 126
 127 -- FindWithDefault
 128 type FindWithDefault a k m
 129     = FromMaybe a (Lookup k m)
 130
 131 -- Empty
 132 type Empty = Tip
 133
 134 -- Singleton
 135 type Singleton k v = Bin D1 k v Tip Tip
 136
 137 -- Insert
 138 type family   Insert k v m
 139 type instance Insert k v Tip              = Singleton k v
 140 type instance Insert k v (Bin s k' v' l r)
 141     = CompCase k k'
 142                (Balance k' v' (Insert k v l) r)
 143                (Balance k' v' l (Insert k v r))
 144                (Bin s k v l r)
 145
 146 -- Delete
 147 type family   Delete k m
 148 type instance Delete k Tip              = Tip
 149 type instance Delete k (Bin s k' v l r)
 150     = CompCase k k'
 151                (Balance k' v (Delete k l) r)
 152                (Balance k' v l (Delete k r))
 153                (Glue l r)
 154
 155 -- Balance
 156 type Delta = D5
 157 type Ratio = D2
 158
 159 type Balance k v l r
 160     = If ((Size l :+: Size r) :<=: D1)
 161          (Bin (Size l :+: Size r :+: D1) k v l r)
 162          (If (Size r :>=: (Delta :*: Size l))
 163              (RotateL k v l r)
 164              (If (Size l :>=: (Delta :*: Size r))
 165                  (RotateR k v l r)
 166                  (Bin (Size l :+: Size r :+: D1) k v l r)))
 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 k k'
 286                (Balance k' v (UpdateWithKey f k l) r)
 287                (Balance k' v l (UpdateWithKey f k r))
 288                (If (IsJust (App2 f k' v))
 289                    (Bin s k' (FromJust (App2 f k' v)) l r)
 290                    (Glue l r))
 291
 292 -- Map
 293 type MapValue f m = MapWithKey (MapValue' f) m
 294
 295 data MapValue' f
 296 type instance App2 (MapValue' f) k v = App f v
 297
 298 -- MapWithKey
 299 type family   MapWithKey f m
 300 type instance MapWithKey f Tip             = Tip
 301 type instance MapWithKey f (Bin s k v l r)
 302     = Bin s k (App2 f k v) (MapWithKey f l) (MapWithKey f r)
 303
 304 -- FoldrWithKey
 305 type family   FoldrWithKey f z m
 306 type instance FoldrWithKey f z Tip             = z
 307 type instance FoldrWithKey f z (Bin s k v l r)
 308     = FoldrWithKey f (App3 f k v (FoldrWithKey f z r)) l
 309
 310 -- FoldlWithKey
 311 type family   FoldlWithKey f z m
 312 type instance FoldlWithKey f z Tip             = z
 313 type instance FoldlWithKey f z (Bin s k v l r)
 314     = FoldlWithKey f (App3 f (FoldlWithKey f z l) k v) r
 315
 316 -- Keys
 317 type Keys m = L.Map Key' (Assocs m)
 318
 319 data Key'
 320 type instance App Key' (Cons k v) = k
 321
 322 -- Assocs
 323 type Assocs m = ToList m
 324
 325 -- ToList
 326 type ToList m = ToAscList m
 327
 328 -- FromList
 329 type FromList xs = Foldl Ins' Empty xs
 330
 331 data Ins'
 332 type instance App2 Ins' m (Cons k v) = Insert k v m
 333
 334 -- ToAscList
 335 type ToAscList m = FoldrWithKey ToAscList' L.Null m
 336
 337 data ToAscList'
 338 type instance App3 ToAscList' k v vs = Cons (Cons k v) vs
 339
 340 -- ToDescList
 341 type ToDescList m = FoldlWithKey ToDescList' L.Null m
 342
 343 data ToDescList'
 344 type instance App3 ToDescList' vs k v = Cons (Cons k v) vs