├── .gitignore ├── COPYING ├── ChangeLog.md ├── Makefile ├── README.md ├── Setup.lhs ├── src └── Data │ └── TotalMap.hs ├── stack.yaml └── total-map.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | Junk* 3 | Old* 4 | dist 5 | Stuff 6 | TAGS 7 | tags 8 | tarballs 9 | 10 | # Mac OS generates 11 | .DS_Store 12 | 13 | # Where do these files come from? They're not readable. 14 | # For instance, .#Help.page 15 | .#* 16 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 Conal Elliott 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The names of the authors may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Change log for total-map 2 | 3 | ## 0.1.0 4 | 5 | * Derived `Show` instance. 6 | * `infixl 9 !` 7 | * `DetectableZero` instance. 8 | * Added a change log. 9 | 10 | ## 0.0.8 11 | 12 | * `Semiring` and `StarSemiring` instances. 13 | 14 | ## 0.0.7 15 | 16 | * `Semigroup` instance. 17 | 18 | ## 0.0.6 19 | 20 | * `codomain` 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include ../cho-home-cabal-make.inc 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The usual finite map type (`Map` from `Data.Map`) is not an applicative functor, as it doesn't have a pure. 2 | Consequently, it's also not a monad. 3 | On the other hand, we can decompose `Map` into two parts: a *total* map, and `Maybe`, i.e., 4 | 5 | type Map k v = TMap k (Maybe v) 6 | 7 | The type `TMap` of total maps does have `Applicative` and `Monad` instances, and hence this hypothetically rebuilt `Map` would as well. 8 | 9 | The idea for `TMap` is introduced in the paper [*Denotational design with type class morphisms*](http://conal.net/papers/type-class-morphisms/). 10 | The meaning `Map k v` is given by its semantic function 11 | 12 | (!) :: Map k v -> (k -> v) 13 | 14 | The type class morphism (TCM) principle then exactly dictates the meanings of several class instances for `TMap`, including `Functor`, `Applicative`, `Monad`, and `Monoid`. 15 | For instance, `(!)` must be a monoid (homo)morphism, i.e., 16 | 17 | (!) mempty == mempty 18 | (!) (s `mappend` t) == (!) s `mappend` (!) t 19 | 20 | The current implementation of `TMap` is via `Data.Map`. 21 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /src/Data/TotalMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | ---------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.TotalMap 6 | -- Copyright : (c) Conal Elliott 2012--2019 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : conal@conal.net 10 | -- Stability : experimental 11 | -- 12 | -- Finitely represented /total/ maps. Represented by as a partial map and 13 | -- a default value. Has Applicative and Monad instances (unlike "Data.Map"). 14 | ---------------------------------------------------------------------- 15 | 16 | module Data.TotalMap 17 | ( TMap,fromPartial 18 | , empty, insert, singleton 19 | , (!),tabulate,trim 20 | , intersectionPartialWith,range 21 | , mapKeysWith 22 | -- , tmapRepr 23 | ) where 24 | 25 | import Data.Monoid (Monoid(..),(<>)) 26 | import Control.Applicative (Applicative(..),liftA2,(<$>)) 27 | import Data.Maybe (fromMaybe) 28 | #if MIN_VERSION_base(4,11,0) 29 | import qualified Data.Semigroup as Sem 30 | #endif 31 | 32 | import Data.Map (Map) 33 | import qualified Data.Map as M 34 | import Data.Set (Set) 35 | import qualified Data.Set as S 36 | import Data.Semiring 37 | 38 | -- import Control.Comonad -- TODO 39 | 40 | -- | Total map 41 | data TMap k v = TMap v (Map k v) deriving Show 42 | 43 | -- The representation is a default value and a finite map for the rest. 44 | 45 | -- | Create a total map from a default value and a partial map. 46 | fromPartial :: v -> Map k v -> TMap k v 47 | fromPartial = TMap 48 | 49 | -- | A total map only default 50 | empty :: v -> TMap k v 51 | empty v = TMap v M.empty 52 | 53 | -- | Insert a key\/value pair 54 | insert :: Ord k => k -> v -> TMap k v -> TMap k v 55 | insert k v (TMap d m) = TMap d (M.insert k v m) 56 | 57 | -- | Singleton plus default 58 | singleton :: Ord k => k -> v -> v -> TMap k v 59 | singleton k v d = insert k v (empty d) 60 | 61 | infixl 9 ! 62 | -- | Sample a total map. Semantic function. 63 | (!) :: Ord k => TMap k v -> k -> v 64 | TMap dflt m ! k = fromMaybe dflt (M.lookup k m) 65 | 66 | -- | Construct a total map, given a default value, a set of keys, and a 67 | -- function to sample over that set. You might want to 'trim' the result. 68 | tabulate :: Eq k => v -> Set k -> (k -> v) -> TMap k v 69 | tabulate dflt keys f = TMap dflt (f <$> idMap keys) 70 | 71 | -- | Optimize a 'TMap', weeding out any explicit default values. 72 | -- A semantic no-op, i.e., @(!) . trim == (!)@. 73 | trim :: (Ord k, Eq v) => TMap k v -> TMap k v 74 | trim (TMap dflt m) = TMap dflt (M.filter (/= dflt) m) 75 | 76 | {- 77 | -- Variation that weeds out values equal to the default. Requires Eq. 78 | tabulate' :: (Ord k, Eq v) => v -> Set k -> (k -> v) -> TMap k v 79 | tabulate' = (fmap.fmap.fmap) trim tabulate 80 | -} 81 | 82 | -- | Intersect a total map with a partial one using an element combinator. 83 | intersectionPartialWith :: 84 | (Ord k) => 85 | (a -> b -> c) -> TMap k a -> Map k b -> Map k c 86 | intersectionPartialWith f (TMap ad am) bm = 87 | M.intersectionWith f am bm 88 | `M.union` 89 | fmap (f ad) bm 90 | 91 | {-# DEPRECATED range "Non-denotative" #-} 92 | -- | Witness the finiteness of the support concretely by giving its image. 93 | range :: Ord v => TMap k v -> Set v 94 | range (TMap dflt m) = S.fromList (dflt : M.elems m) 95 | 96 | {-------------------------------------------------------------------- 97 | Instances 98 | --------------------------------------------------------------------} 99 | 100 | -- These instances follow the principle that semantic functions (here (!)) 101 | -- must be type class morphism (TCM) for all inhabited type classes. 102 | 103 | #if MIN_VERSION_base(4,11,0) 104 | instance (Ord k, Sem.Semigroup v) => Sem.Semigroup (TMap k v) where 105 | (<>) = liftA2 (<>) 106 | #endif 107 | 108 | instance (Ord k, Monoid v) => Monoid (TMap k v) where 109 | mempty = pure mempty 110 | mappend = liftA2 mappend 111 | 112 | instance Functor (TMap k) where 113 | fmap f (TMap d m) = TMap (f d) (fmap f m) 114 | 115 | instance Ord k => Applicative (TMap k) where 116 | pure v = TMap v mempty 117 | fs@(TMap df mf) <*> xs@(TMap dx mx) = 118 | tabulate (df dx) 119 | (M.keysSet mf `mappend` M.keysSet mx) 120 | ((!) fs <*> (!) xs) 121 | 122 | -- | Alternative implementation of (<*>) using complex Map operations. Might be 123 | -- more efficient. Can be used for testing against the canonical implementation 124 | -- above. 125 | _app :: Ord k => TMap k (a -> b) -> TMap k a -> TMap k b 126 | _app (TMap fd fm) (TMap ad am) = 127 | TMap (fd ad) $ 128 | fmap ($ad) (M.difference fm am) <> 129 | fmap (fd$) (M.difference am fm) <> 130 | M.intersectionWith ($) fm am 131 | 132 | -- Note: I'd like to 'trim' the tabulate result in <*>, but doing so would 133 | -- require the Eq constraint on values, which breaks Applicative. 134 | 135 | instance Ord k => Monad (TMap k) where 136 | return = pure 137 | m >>= f = joinT (f <$> m) 138 | 139 | joinT :: Ord k => TMap k (TMap k v) -> TMap k v 140 | joinT (TMap (TMap dd dm) mtm) = 141 | TMap dd (M.mapWithKey (flip (!)) mtm `M.union` dm) 142 | 143 | {- 144 | joinT' :: (Ord k,Eq v) => TMap k (TMap k v) -> TMap k v 145 | joinT' = trim . joinT 146 | -} 147 | 148 | {- 149 | joinT (tt@(TMap (TMap (dd,dm),mtm))) = 150 | tabulate dd 151 | undefined 152 | -- (join ((!) ((!) <$> tt))) 153 | ((!) tt >>= (!)) 154 | -} 155 | 156 | {- 157 | 158 | -- tt :: TMap k (TMap k v) 159 | -- fmap (!) tt :: TMap k (k -> v) 160 | -- (!) (fmap (!) tt) :: k -> (k -> v) 161 | 162 | tt :: TMap k (TMap k v) 163 | dd :: v 164 | dm :: Map k v 165 | mtm :: Map k (TMap k v) 166 | 167 | mapWithKey (flip (!)) mtm :: Map k v 168 | mapWithKey (flip (!)) mtm `union` dm :: Map k v 169 | 170 | TMap (dd,M.mapWithKey (flip (!)) mtm `M.union` dm) :: TMap k v 171 | 172 | spec: 173 | 174 | -} 175 | 176 | instance (Ord k, Semiring v) => Semiring (TMap k v) where 177 | zero = pure zero 178 | one = pure one 179 | (<+>) = liftA2 (<+>) 180 | (<.>) = liftA2 (<.>) 181 | 182 | instance (Ord k, StarSemiring v) => StarSemiring (TMap k v) where 183 | star = fmap star 184 | plus = fmap plus 185 | 186 | instance (Ord k, DetectableZero v) => DetectableZero (TMap k v) where 187 | isZero (TMap d m) = isZero d && M.null m -- or: isZero d && all isZero (elems m) 188 | 189 | {-------------------------------------------------------------------- 190 | Comonad 191 | --------------------------------------------------------------------} 192 | 193 | -- TODO: Based on the function-of-monoid comonad. 194 | -- TODO: Also a version with a pointer. 195 | 196 | {-------------------------------------------------------------------- 197 | Misc 198 | --------------------------------------------------------------------} 199 | 200 | mapKeysWith :: (Semiring z, Ord b) => (z -> z -> z) -> (a -> b) -> TMap a z -> TMap b z 201 | mapKeysWith comb f (TMap d m) = TMap d (M.mapKeysWith comb f m) 202 | 203 | -- liftA2Keys :: Ord b => (a -> b -> c) -> TMap a z -> TMap b z -> TMap c z 204 | -- liftA2Keys f (TMap c m) (TMap d n) = ... -- ?? 205 | 206 | idMap :: Eq k => Set k -> Map k k 207 | idMap = M.fromAscList . map (\ k -> (k,k)) . S.toAscList 208 | 209 | -- or ... map (join (,)) ... 210 | 211 | -- -- | Reveal representation. For use while experimenting. 212 | -- tmapRepr :: TMap k v -> (v, Map k v) 213 | -- tmapRepr (TMap d m) = (d,m) 214 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | 3 | # resolver: lts-9.20 # ghc-8.0.2 4 | # resolver: lts-11.12 # ghc-8.2.2 5 | resolver: lts-12.4 # ghc-8.4.3 6 | # resolver: lts-12.19 # ghc-8.4.4 7 | 8 | # resolver: nightly-2018-11-23 # ghc-8.6.2 9 | 10 | # resolver: lts-14.14 # ghc-8.6.5 11 | 12 | extra-deps: 13 | - semiring-num-1.6.0.4 14 | 15 | # When https://github.com/oisdk/semiring-num/pull/2 is merged and released to 16 | # Hackage, switch to it, and re-try GHC 8.4.3 and later. 17 | 18 | -------------------------------------------------------------------------------- /total-map.cabal: -------------------------------------------------------------------------------- 1 | Name: total-map 2 | Version: 0.1.3 3 | Cabal-Version: >= 1.10 4 | Synopsis: Finitely represented total maps 5 | Category: Data 6 | Description: 7 | Finitely represented /total/ maps. Represented by as a partial map and 8 | a default value. Has Applicative and Monad instances (unlike Data.Map). 9 | Author: Conal Elliott 10 | Maintainer: conal@conal.net 11 | Copyright: (c) 2012--2019 by Conal Elliott 12 | License: BSD3 13 | License-File: COPYING 14 | Stability: experimental 15 | build-type: Simple 16 | Homepage: http://github.com/conal/total-map/ 17 | Extra-Source-Files: 18 | README.md 19 | ChangeLog.md 20 | Source-Repository head 21 | type: git 22 | location: git://github.com/conal/total-map.git 23 | 24 | Library 25 | hs-Source-Dirs: src 26 | Extensions: 27 | Build-Depends: base<5, containers, semiring-num>=1.6.0.4 28 | Exposed-Modules: 29 | Data.TotalMap 30 | default-language: Haskell2010 31 | --------------------------------------------------------------------------------