|
| 1 | +{-# LANGUAGE CPP #-} |
| 2 | +{-# LANGUAGE DeriveFunctor #-} |
| 3 | +-- | Map which remembers the 'fromList' order. |
| 4 | +-- This module is minimal on purpose. |
| 5 | +module Data.TreeDiff.OMap ( |
| 6 | + -- * Ordered map |
| 7 | + OMap, |
| 8 | + -- * Conversions |
| 9 | + toAscList, |
| 10 | + toList, |
| 11 | + fromList, |
| 12 | + -- * Construction |
| 13 | + empty, |
| 14 | + -- * Query |
| 15 | + elems, |
| 16 | +) where |
| 17 | + |
| 18 | +import Data.List (sortBy) |
| 19 | +import Data.Ord (comparing) |
| 20 | +import Data.Semialign (Semialign (..)) |
| 21 | +import Data.These (These (..)) |
| 22 | + |
| 23 | +#if MIN_VERSION_containers(0,5,0) |
| 24 | +import qualified Data.Map.Strict as Map |
| 25 | +#else |
| 26 | +import qualified Data.Map as Map |
| 27 | +#endif |
| 28 | + |
| 29 | +import qualified Test.QuickCheck as QC |
| 30 | + |
| 31 | +-- $setup |
| 32 | +-- >>> import Data.Semialign (alignWith) |
| 33 | + |
| 34 | +------------------------------------------------------------------------------- |
| 35 | +-- Types |
| 36 | +------------------------------------------------------------------------------- |
| 37 | + |
| 38 | +newtype OMap k v = OMap (Map.Map k (Val v)) |
| 39 | + deriving (Functor) |
| 40 | + |
| 41 | +-- Value with its index |
| 42 | +data Val v = Val !Int v |
| 43 | + deriving (Functor) |
| 44 | + |
| 45 | +-- | Note: The instance uses 'toList', so 'Eq'ual 'OMap's can be shown differently. |
| 46 | +instance (Show k, Show v) => Show (OMap k v) where |
| 47 | + showsPrec d m = showParen (d > 10) |
| 48 | + $ showString "fromList " |
| 49 | + . showsPrec d (toList m) |
| 50 | + |
| 51 | +-- | |
| 52 | +-- |
| 53 | +-- >>> xs = toAscList $ fromList [('a', "alpha"), ('b', "beta"), ('g', "gamma")] |
| 54 | +-- >>> ys = toAscList $ fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")] |
| 55 | +-- >>> xs == ys |
| 56 | +-- True |
| 57 | +-- |
| 58 | +-- >>> zs = toAscList $ fromList [('d', "delta"), ('b', "beta"), ('a', "alpha")] |
| 59 | +-- >>> xs == zs |
| 60 | +-- False |
| 61 | +-- |
| 62 | +instance (Eq k, Eq v) => Eq (OMap k v) where |
| 63 | + xs == ys = go (toAscList xs) (toAscList ys) where |
| 64 | + go [] [] = True |
| 65 | + go _ [] = False |
| 66 | + go [] _ = False |
| 67 | + go ((k1, v1) : kvs1) ((k2, v2) : kvs2) = |
| 68 | + k1 == k2 && v1 == v2 && go kvs1 kvs2 |
| 69 | + |
| 70 | +------------------------------------------------------------------------------- |
| 71 | +-- QuickCheck |
| 72 | +------------------------------------------------------------------------------- |
| 73 | + |
| 74 | +instance (Ord k, QC.Arbitrary k, QC.Arbitrary v) => QC.Arbitrary (OMap k v) where |
| 75 | + arbitrary = QC.arbitrary1 |
| 76 | + shrink = QC.shrink1 |
| 77 | + |
| 78 | +instance (Ord k, QC.Arbitrary k) => QC.Arbitrary1 (OMap k) where |
| 79 | + liftArbitrary arb = fmap fromList $ QC.liftArbitrary (QC.liftArbitrary arb) |
| 80 | + liftShrink shr m = fmap fromList $ QC.liftShrink (QC.liftShrink shr) $ toList m |
| 81 | + |
| 82 | +------------------------------------------------------------------------------- |
| 83 | +-- Combinators |
| 84 | +------------------------------------------------------------------------------- |
| 85 | + |
| 86 | +-- | |
| 87 | +-- |
| 88 | +-- >>> empty :: OMap String Integer |
| 89 | +-- fromList [] |
| 90 | +-- |
| 91 | +empty :: OMap k v |
| 92 | +empty = OMap Map.empty |
| 93 | + |
| 94 | +-- | Elements in key ascending order. |
| 95 | +elems :: OMap k v -> [v] |
| 96 | +elems (OMap m) = map (snd . getVal) $ Map.toAscList m |
| 97 | + |
| 98 | +-- | |
| 99 | +-- |
| 100 | +-- >>> toAscList $ fromList [('a', "alpha"), ('b', "beta"), ('g', "gamma")] |
| 101 | +-- [('a',"alpha"),('b',"beta"),('g',"gamma")] |
| 102 | +-- |
| 103 | +-- >>> toAscList $ fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")] |
| 104 | +-- [('a',"alpha"),('b',"beta"),('g',"gamma")] |
| 105 | +-- |
| 106 | +toAscList :: OMap k v -> [(k, v)] |
| 107 | +toAscList (OMap m) = map getVal $ Map.toAscList m |
| 108 | + |
| 109 | +-- | /O(n log n)/. List in creation order. |
| 110 | +-- Doesn't respect 'Eq' instance. |
| 111 | +-- |
| 112 | +-- >>> toList $ fromList [('a', "alpha"), ('b', "beta"), ('g', "gamma")] |
| 113 | +-- [('a',"alpha"),('b',"beta"),('g',"gamma")] |
| 114 | +-- |
| 115 | +-- >>> toList $ fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")] |
| 116 | +-- [('g',"gamma"),('b',"beta"),('a',"alpha")] |
| 117 | +-- |
| 118 | +toList :: OMap k v -> [(k, v)] |
| 119 | +toList (OMap m) = map getVal $ sortBy (comparing getIdx) $ Map.toList m |
| 120 | + |
| 121 | +getIdx :: (k, Val v) -> Int |
| 122 | +getIdx (_, Val i _) = i |
| 123 | + |
| 124 | +getVal :: (k, Val v) -> (k, v) |
| 125 | +getVal (k, Val _ v) = (k, v) |
| 126 | + |
| 127 | +-- | |
| 128 | +-- |
| 129 | +-- >>> fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")] |
| 130 | +-- fromList [('g',"gamma"),('b',"beta"),('a',"alpha")] |
| 131 | +-- |
| 132 | +fromList :: Ord k => [(k, v)] -> OMap k v |
| 133 | +fromList kvs = OMap (Map.fromList (zipWith p [0..] kvs)) where |
| 134 | + p i (k, v) = (k, Val i v) |
| 135 | + |
| 136 | +-- | |
| 137 | +-- |
| 138 | +-- >>> let xs = fromList [('a', "alpha"), ('b', "beta")] |
| 139 | +-- >>> let ys = fromList [('c', 3 :: Int), ('b', 2)] |
| 140 | +-- >>> alignWith id xs ys |
| 141 | +-- fromList [('a',This "alpha"),('c',That 3),('b',These "beta" 2)] |
| 142 | +-- |
| 143 | +instance Ord k => Semialign (OMap k) where |
| 144 | + alignWith f (OMap xs) (OMap ys) = OMap (alignWith g xs ys) where |
| 145 | + g (This (Val i x)) = Val i (f (This x)) |
| 146 | + g (That (Val j y)) = Val j (f (That y)) |
| 147 | + g (These (Val i x) (Val j y)) = Val (min i j) (f (These x y)) |
0 commit comments