Ticket #2037: Dict.hs

File Dict.hs, 4.0 KB (added by basvandijk, 6 years ago)

Just a module I was working on when this bug occurred

Line 
1{-# OPTIONS_GHC -XTypeOperators #-}
2{-# OPTIONS_GHC -XScopedTypeVariables #-}
3
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  Data.Dict
7-- Copyright   :  (c) Bas van Dijk 2008
8-- License     :  BSD-style
9-- Maintainer  :  v.dijk.bas@gmail.com
10-- Stability   :  provisional
11-- Portability :  portable
12--
13-----------------------------------------------------------------------------
14
15module Data.Dict where
16
17import Prelude hiding (lookup)
18
19import qualified Data.Map as M
20import Data.Monoid (Monoid(..))
21
22{--------------------------------------------------------------------
23  Type
24--------------------------------------------------------------------}
25
26newtype Dict k a = D (DMap k a) deriving Show
27
28type DMap k a = M.Map k (Value k a)
29
30data Value k a = NoValue (Dict k a) 
31               | AValue  (Dict k a, a)
32                 deriving Show
33
34
35{--------------------------------------------------------------------
36  Instances
37--------------------------------------------------------------------}
38
39instance (Ord k) => Monoid (Dict k a) where
40    mempty  = empty
41    mappend = union
42    mconcat = unions
43
44{--------------------------------------------------------------------
45  Operators
46--------------------------------------------------------------------}
47
48
49
50{--------------------------------------------------------------------
51  Construction
52--------------------------------------------------------------------}
53
54empty :: Dict k a
55empty = D M.empty
56
57singleton :: forall k a. [k] -> a -> Dict k a
58singleton []     _ = empty -- TODO: or error ???
59singleton (x:xs) y = go x xs
60    where
61      go :: k -> [k] -> Dict k a
62      go x xs = D $ M.singleton x $ case xs of
63                                      []   -> AValue (empty, y) 
64                                      x:xs -> NoValue $ go x xs
65
66
67{--------------------------------------------------------------------
68  Query
69--------------------------------------------------------------------}
70
71lookup :: forall k a m. (Monad m, Ord k) => [k] -> Dict k a -> m a
72lookup []     _     = fail "not found"
73lookup (x:xs) (D m) = go x xs m
74    where
75      go :: k -> [k] -> DMap k a -> m a
76      go x xs m = do v <- M.lookup x m
77                     case v of
78                       NoValue (D m)   -> case xs of
79                                            []   -> fail "not found"
80                                            x:xs -> go x xs m
81                       AValue (D m, y) -> case xs of
82                                            []   -> return y
83                                            x:xs -> go x xs m
84
85
86{--------------------------------------------------------------------
87  Insertion
88--------------------------------------------------------------------}
89
90-- TODO: error when xs is null?
91insert :: Ord k => [k] -> a -> Dict k a -> Dict k a
92insert xs y d = d `union` (singleton xs y)
93
94
95{--------------------------------------------------------------------
96  Union
97--------------------------------------------------------------------}
98
99union :: Ord k => Dict k a -> Dict k a -> Dict k a
100union = unionWithKey (\k l r -> l)
101
102-- I use foldl instead of foldr because union is more efficient on (bigset `union` smallset)
103-- TODO: Data.Map uses a strict foldl. Investigate if a strict version is also better here...
104unions :: Ord k => [Dict k a] -> Dict k a
105unions = foldl union empty
106
107unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> Dict k a -> Dict k a -> Dict k a
108unionWithKey f dl@(D ml) dr@(D mr) | M.null ml = dr
109                                   | M.null mr = dl
110                                   | otherwise = D $ M.unionWithKey unify ml mr
111    where
112      unify :: k ->  Value k a -> Value k a -> Value k a
113      unify x (NoValue   dl)      (NoValue dr)      = NoValue(union dl dr)
114      unify x (NoValue   dl)      (AValue (dr, yr)) = AValue (union dl dr, yr) 
115      unify x (AValue   (dl, yl)) (NoValue dr)      = AValue (union dl dr, yl)
116      unify x (AValue   (dl, yl)) (AValue (dr, yr)) = AValue (union dl dr, f x yl yr)
117