map-syntax (empty) → 0.1
raw patch · 9 files changed
+619/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, containers, deepseq, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers
Files
- .ghci +3/−0
- LICENSE +27/−0
- README.md +4/−0
- Setup.hs +2/−0
- map-syntax.cabal +70/−0
- src/Data/Map/Syntax.hs +215/−0
- test/Data/Map/Syntax/Tests.hs +220/−0
- test/Data/Map/Syntax/Util.hs +59/−0
- test/TestSuite.hs +19/−0
+ .ghci view
@@ -0,0 +1,3 @@+:set -XOverloadedStrings+:set -Wall+:set -isrc
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Doug Beardsley+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this+list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++Neither the name of the authors nor the names of its contributors may be used to+endorse or promote products derived from this software without specific prior+written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+Haskell's canonical list of tuples syntax for defining maps is not very+convenient and also has ambiguous semantics. This package leverages do+notation to create a lighter syntax that makes semantics explicit and also+allows the option of fail-fast handling of duplicate keys.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ map-syntax.cabal view
@@ -0,0 +1,70 @@+name: map-syntax+version: 0.1+synopsis: Syntax sugar for defining maps+description:+ Haskell's canonical list of tuples syntax for defining maps is not very+ convenient and also has ambiguous semantics. This package leverages do+ notation to create a lighter syntax that makes semantics explicit and also+ allows the option of fail-fast handling of duplicate keys.+license: BSD3+license-file: LICENSE+author: Doug Beardsley+maintainer: Doug Beardsley+build-type: Simple+cabal-version: >= 1.10+category: Data Structures++extra-source-files:+ .ghci,+ LICENSE,+ README.md+++Library+ hs-source-dirs: src+ default-language: Haskell2010++ exposed-modules:+ Data.Map.Syntax+++ build-depends:+ base >= 4 && < 5,+ containers >= 0.3 && < 0.6,+ mtl >= 2.0 && < 2.3++ if impl(ghc >= 6.12.0)+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2++ ghc-prof-options: -prof -auto-all+++source-repository head+ type: git+ location: https://github.com/mightybyte/map-syntax.git++Test-suite testsuite+ hs-source-dirs: src test+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ other-modules: Data.Map.Syntax+ , Data.Map.Syntax.Util+ , Data.Map.Syntax.Tests+ default-language: Haskell2010+ ghc-options: -fhpc++ ghc-options: -Wall -fwarn-tabs -fhpc -O2+ build-depends: + base >= 4 && < 5,+ containers >= 0.3 && < 0.6,+ deepseq >= 1.3 && < 2,+ HUnit >= 1.2 && < 2,+ mtl >= 2.0 && < 2.3,+ QuickCheck >= 2.3.0.2 && < 3,+ test-framework >= 0.8.0.3 && < 0.9,+ test-framework-hunit >= 0.2.7 && < 0.4,+ test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,+ transformers >= 0.3 && < 0.5
+ src/Data/Map/Syntax.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-|++An API implementing a convenient syntax for defining maps. This module was+born from the observation that a list of tuples is semantically ambiguous+about how duplicate keys should be handled. Additionally, the syntax is+inherently rather cumbersome and difficult to work with. This API takes+advantage of do notation to provide a very light syntax for defining maps+while at the same time eliminating the semantic ambiguity of alists.++Here's an example:++> foo :: MapSyntax Text+> foo = do+> "firstName" ## "John"+> "lastName" ## "Smith"++-}++module Data.Map.Syntax+ (+ -- * Core API+ MapSyntaxM+ , MapSyntax+ , runMap+ , (##)+ , (#!)+ , (#?)+ , mapK+ , mapV+ , runMapSyntax+ , runMapSyntax'++ -- * Lower level functions+ , DupStrat(..)+ , ItemRep(..)+ , add+ ) where+++------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad.State+import qualified Data.Map as M+import Data.Monoid+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Strategy to use for duplicates+data DupStrat = Replace | Ignore | Error++{-++Note: We don't use this seemingly more general formulation:++type DupStrat k v = k -> v -> v -> Either k v++...because it is contravariant in k and v and makes it impossible to implement+mapK and mapV.++-}++------------------------------------------------------------------------------+-- | Representation of an indivdual item in a map+data ItemRep k v = ItemRep+ { irStrat :: DupStrat+ , irKey :: k+ , irVal :: v+ }+++------------------------------------------------------------------------------+type MapRep k v = [ItemRep k v]+++------------------------------------------------------------------------------+-- | A monad providing convenient syntax for defining maps.+newtype MapSyntaxM k v a = MapSyntaxM { unMapSyntax :: State (MapRep k v) a }+ deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+instance Monoid (MapSyntax k v) where+ mempty = return $! ()+ mappend = (>>)+++------------------------------------------------------------------------------+-- | Convenient type alias that will probably be used most of the time.+type MapSyntax k v = MapSyntaxM k v ()+++------------------------------------------------------------------------------+-- | Low level add function for adding a specific DupStrat, key, and value.+add :: DupStrat -> k -> v -> MapSyntax k v+add strat k v = add' [ItemRep strat k v]+++------------------------------------------------------------------------------+add' :: [ItemRep k v] -> MapSyntax k v+add' irs = MapSyntaxM $ modify (++ irs)+++------------------------------------------------------------------------------+-- | Forces an entry to be added. If the key already exists, its value is+-- overwritten.+(##) :: k -> v -> MapSyntax k v+(##) = add Replace+infixr 0 ##+++------------------------------------------------------------------------------+-- | Tries to add an entry, but if the key already exists, then 'runMap' will+-- return a Left with the list of offending keys. This may be useful if name+-- collisions are bad and you want to know when they occur.+(#!) :: k -> v -> MapSyntax k v+(#!) = add Error+infixr 0 #!+++------------------------------------------------------------------------------+-- | Inserts into the map only if the key does not already exist. If the key+-- does exist, it silently continues without overwriting or generating an+-- error indication.+(#?) :: k -> v -> MapSyntax k v+(#?) = add Ignore+infixr 0 #?+++------------------------------------------------------------------------------+-- | Runs the MapSyntaxM monad to generate a map.+runMap :: Ord k => MapSyntaxM k v a -> Either [k] (M.Map k v)+runMap = runMapSyntax M.lookup M.insert+++------------------------------------------------------------------------------+-- | Runs the MapSyntaxM monad to generate a map.+runMapSyntax+ :: (Monoid map)+ => (k -> map -> Maybe v)+ -- ^ Function that gets a key's value+ -> (k -> v -> map -> map)+ -- ^ Function to force-insert a key-value pair into the map+ -> MapSyntaxM k v a+ -> Either [k] map+runMapSyntax = runMapSyntax' (\_ _ _ -> Nothing)+++------------------------------------------------------------------------------+-- | Runs the MapSyntaxM monad to generate a map. This function gives you the+-- full power of insertWith when duplicate keys are encountered.+--+-- Example:+--+-- > runMapSyntax' (\k new_val old_val -> Just $ old_val ++ new_val)+runMapSyntax'+ :: (Monoid map)+ => (k -> v -> v -> Maybe v)+ -- ^ Function to handle duplicate key insertion, similar to the first+ -- argument to insertWith. If this function returns Nothing, then this is+ -- interpreted as an error. If it is a Just, then the resulting value+ -- will be inserted into the map.+ -> (k -> map -> Maybe v)+ -- ^ Function that gets a key's value+ -> (k -> v -> map -> map)+ -- ^ Function to force-insert a key-value pair into the map+ -> MapSyntaxM k v a+ -> Either [k] map+runMapSyntax' dupFunc lookupEntry forceIns ms =+ case res of+ ([],m) -> Right m+ (es,_) -> Left es+ where+ res = foldl f (mempty, mempty) $ execState (unMapSyntax ms) mempty+ f accum@(es,m) ir@ItemRep{..} =+ case lookupEntry irKey m of+ Just v1 -> replace accum ir v1+ Nothing -> (es, forceIns irKey irVal m)++ replace (es,m) ir v1 =+ case irStrat ir of+ Replace -> (es, forceIns (irKey ir) (irVal ir) m)+ Ignore -> (es, m)+ Error -> maybe (es ++ [irKey ir], m)+ (\v -> (es, forceIns (irKey ir) v m)) $+ dupFunc (irKey ir) (irVal ir) v1+++------------------------------------------------------------------------------+execMapSyntax :: MapSyntaxM k v a -> MapRep k v+execMapSyntax ms = execState (unMapSyntax ms) mempty+++------------------------------------------------------------------------------+-- | Maps a function over all the keys.+mapK :: (k1 -> k2) -> MapSyntaxM k1 v a -> MapSyntax k2 v+mapK f ms = add' items+ where+ items = map (\ir -> ir { irKey = f (irKey ir) }) $ execMapSyntax ms+++------------------------------------------------------------------------------+-- | Maps a function over all the values.+mapV :: (v1 -> v2) -> MapSyntaxM k v1 a -> MapSyntax k v2+mapV f ms = add' items+ where+ items = map (\ir -> ir { irVal = f (irVal ir) }) $ execMapSyntax ms
+ test/Data/Map/Syntax/Tests.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Map.Syntax.Tests where++------------------------------------------------------------------------------+import qualified Data.List as L+import Data.Function (on)+import qualified Data.Map as M+import Data.Monoid (mempty,(<>))+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (assertEqual)++import Data.Map.Syntax+import Data.Map.Syntax.Util (mkMapABC, mkMapDEF,mkMapAEF,+ ArbMapSyntax(..))+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- |Simple tests for not-nested maps+insTests :: [Test]+insTests =+ [testCase "Insert overwrite" overDup+ ,testCase "Insert over fail" failDup+ ,testCase "Reject duplicate" skipDup+ ,testCase "Trying dupFunc" dupFunc+ ,testProperty "Insert overwrite from list" prop_syntaxMatchesNubOver+ ,testProperty "Insert conditional from list" prop_syntaxMatchesNubCond+ ,testProperty "Insert error on dup from list" prop_syntaxMatchesNubErr]++monoidLaws :: [Test]+monoidLaws =+ [testProperty "Left identity" prop_leftId+ ,testProperty "Right identity" prop_rightId+ ,testProperty "Associativity" prop_assoc+ ]++ +------------------------------------------------------------------------------+-- |Simple tests of ##, #!, #?+overDup :: IO ()+overDup = assertEqual "Failed to overwrite duplicate entry"+ (Right $ M.fromList [("firstName","Egon") :: (String,String)])+ (runMap $ mkDupMap (##))++failDup :: IO ()+failDup = assertEqual "Failed to error on duplicate entry"+ (Left [("firstName" :: String)])+ (runMap $ mkDupMap (#!))++skipDup :: IO ()+skipDup = assertEqual "Failed to reject duplicate entry"+ (Right $ M.fromList [("firstName","Peter")])+ (runMap $ mkDupMap (#?))++dupFunc :: IO ()+dupFunc = assertEqual "Failed use dupFunc"+ (Right $ M.fromList [("firstName","firstNamePeterEgon")+ :: (String,String)])+ (runMapSyntax' f M.lookup M.insert $ mkDupMap (#!))+ where+ f k v v1 = Just (k <> v1 <> v)++mkDupMap :: (String -> String -> MapSyntax String String)+ -> MapSyntax String String+mkDupMap strat = do+ "firstName" `strat` "Peter"+ "firstName" `strat` "Egon"+++------------------------------------------------------------------------------+prop_syntaxMatchesNubOver :: [(String,Int)] -> Bool+prop_syntaxMatchesNubOver pairs = Right revNubMap == (runMap mSyntax)+ where mSyntax = mapM_ (\(k,v) -> (k ## v)) pairs+ revNubMap = M.fromList . L.nubBy ((==) `on` fst) . L.reverse $ pairs+ -- Nub keeps the first of each unique entry, so reverse list to+ -- simulate keeping the last++prop_syntaxMatchesNubCond :: [(String,Int)] -> Bool+prop_syntaxMatchesNubCond pairs = Right nubMap == (runMap mSyntax)+ where mSyntax = mapM_ (\(k,v) -> (k #? v)) pairs + nubMap = M.fromList . L.nubBy ((==) `on` fst) $ pairs++prop_syntaxMatchesNubErr :: [(String,Int)] -> Bool+prop_syntaxMatchesNubErr pairs =+ let mMap = runMap $ mapM_ (\(k,v) -> (k #! v)) pairs+ in if pairs == L.nubBy ((==) `on` fst) pairs+ then mMap == (Right . M.fromList $ pairs)+ else case mMap of+ Right _ -> False -- We expected (Left dupKeys)+ Left _ -> True -- Wasn't sure about semantics here+ -- runMap ... ("a" #! 1) >> ("a" #! 2) >> ("a" #! 3)+ -- should be (Left ["a"]), or (Left ["a","a"])?+++------------------------------------------------------------------------------+-- |Tests for #! when do blocks are nested+nestingTests :: [Test]+nestingTests =+ [testCase "Nested error dups" nestedErr+ ,testCase "Nested error dups mapK" nestedErrMapK+ ,testCase "Nester error dups mapV" nestedErrMapV+ ,testCase "Nested overwrite dups" nestedOver+ ,testCase "Nested overwrite dups mapK" nestedOverMapK+ ,testCase "Nested overwrite dups mapV" nestedOverMapV+ ,testCase "Nested ignore dups mixed" nestedIgnoreMix+ ,testCase "Nested complex pass" nestedComplex+ ,testCase "Nested complex error" nestedComplexErr]+++nestedErr :: IO ()+nestedErr = assertEqual "Failed to error on duplicates across do blocks"+ (Left ['E','F'])+ (runMap $ do {mkMapDEF (#!); mkMapAEF (#!)})++nestedErrMapK :: IO ()+nestedErrMapK = assertEqual "Failed to error on mapK'ed dups across blocks"+ (Left ['B'])+ (runMap $ do+ mapK succ $ mkMapABC (#!)+ mapK succ $ mkMapAEF (#!)+ )++nestedErrMapV :: IO ()+nestedErrMapV = assertEqual "Failed to error on mapV'ed dups across blocks"+ (Left ['A'])+ (runMap $ do+ mapV succ $ mkMapABC (#!)+ mapV succ $ mkMapAEF (#!)+ )++nestedOver :: IO ()+nestedOver = assertEqual "Failed to overwrite dup entries across blocks"+ (Right $ M.fromList+ [('A',100),('B',2),('C',3),('E',200),('F',300)])+ (runMap $ do+ mkMapABC (##)+ mkMapAEF (##)+ )++nestedOverMapK :: IO ()+nestedOverMapK = assertEqual "Failed to mapK in nested blocks"+ (Right $ M.fromList+ [('A',100),('E',200),('F',300),('C',10),('D',20),('B',2)])+ (runMap $ do+ mkMapABC (##)+ mapK pred $ mkMapDEF (##)+ mkMapAEF (##)+ )++nestedOverMapV :: IO ()+nestedOverMapV = assertEqual "Failed to mapV in nested blocks"+ (Right $ M.fromList+ [('A',99),('B',2),('C',3),('E',199),('F',299)])+ (runMap $ do+ mkMapABC (##)+ mapV pred $ mkMapAEF (##)+ )++nestedIgnoreMix :: IO ()+nestedIgnoreMix = assertEqual "Failed to mapK/mapV in 'Ignore' do blocks"+ (Right $ M.fromList+ [('B',0),('C',1),('D',2),('E',31),('@',101)])+ (runMap $ do+ mapV pred . mapK succ $ mkMapABC (#?)+ mapV succ . mapK pred $ mkMapDEF (#?)+ mapK pred . mapV succ $ mkMapAEF (#?)+ )++nestedComplex :: IO ()+nestedComplex = assertEqual "Failed a mix of dup strategies in nested block"+ (Right $ M.fromList+ [('@',1),('A',2),('B',1000),('C',1000),('D',10),('E',20),('F',30),('G',300),('H',199),('I',299)])+ (runMap $ do+ mapK succ . mapK succ $ mkMapABC (##)+ mapK succ . mapK succ . mapK succ . mapV pred $+ mkMapAEF (#?) + mapK succ ((mapV (const 1000) $ mkMapABC (##)) >>+ mkMapAEF (#?)) + mkMapDEF (##) + mapK pred $ mkMapABC (#?) + )++nestedComplexErr :: IO ()+nestedComplexErr = assertEqual+ "Failed to detect dup in complex nested block"+ (Left ['B'])+ (runMap $ do+ mapK succ . mapK succ $ mkMapABC (##)+ mapK succ . mapK succ . mapK succ . mapV pred $+ mkMapAEF (#?) + mapK succ ((mapV (const 1000) $ mkMapABC (##)) >>+ mkMapAEF (#?))+ mapK pred $ mkMapABC (#!)+ mkMapDEF (##) + mapK pred $ mkMapABC (#?)+ )+++------------------------------------------------------------------------------+-- |Monoid Laws+prop_leftId :: ArbMapSyntax String Int -> Bool+prop_leftId a = runMap (mempty <> m) == runMap m+ where m = unArbSyntax a++prop_rightId :: ArbMapSyntax String Int -> Bool+prop_rightId a = runMap (m <> mempty) == runMap m+ where m = unArbSyntax a++prop_assoc :: ArbMapSyntax String Int+ -> ArbMapSyntax String Int+ -> ArbMapSyntax String Int+ -> Bool+prop_assoc a' b' c' = runMap ((a <> b) <> c) == runMap (a <> (b <> c))+ where a = unArbSyntax a'+ b = unArbSyntax b'+ c = unArbSyntax c'
+ test/Data/Map/Syntax/Util.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.Map.Syntax.Util where++------------------------------------------------------------------------------+import qualified Data.Map as M+import qualified Data.Set as Set+import Test.QuickCheck (Arbitrary (arbitrary))+import Test.QuickCheck.Gen (listOf, elements)+------------------------------------------------------------------------------+import Data.Map.Syntax+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- |All elements that appear more than once in a list (once each)+dups :: (Eq a,Ord a) => [a] -> Set.Set a+dups xs = let countMap = M.fromListWith (+) (zip xs $ repeat (1::Int))+ in Set.fromList . map fst . M.toList $ M.filter (>1) countMap++newtype ArbMapSyntax a b = ArbMapSyntax { unArbSyntax :: MapSyntax a b }++------------------------------------------------------------------------------+instance (Arbitrary a, Arbitrary b) => Arbitrary (ArbMapSyntax a b) where+ arbitrary = do+ ks <- arbitrary+ vs <- arbitrary+ strats <- listOf $ elements [Replace,Ignore,Error]+ return . ArbMapSyntax $+ mapM_ (\(s, k, v) -> add s k v) (zip3 strats ks vs)+++------------------------------------------------------------------------------+-- |An (invalid) show instance - to have something for QuickCheck to print+instance (Show a, Ord a, Show b) => Show (ArbMapSyntax a b) where+ show m = "<MapSyntax> state " ++ show (runMap . unArbSyntax $ m)+++------------------------------------------------------------------------------+-- | Some sample MapSyntax's with various degrees of overlap+mkMapABC :: (Char -> Int -> MapSyntax Char Int) -> MapSyntax Char Int+mkMapABC strat = do+ 'A' `strat` 1+ 'B' `strat` 2+ 'C' `strat` 3++mkMapDEF :: (Char -> Int -> MapSyntax Char Int) -> MapSyntax Char Int+mkMapDEF strat = do+ 'D' `strat` 10+ 'E' `strat` 20+ 'F' `strat` 30++mkMapAEF :: (Char -> Int -> MapSyntax Char Int) -> MapSyntax Char Int+mkMapAEF strat = do+ 'A' `strat` 100+ 'E' `strat` 200+ 'F' `strat` 300
+ test/TestSuite.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++------------------------------------------------------------------------------+import Test.Framework (defaultMain, testGroup, Test)+import Data.Map.Syntax.Tests+++------------------------------------------------------------------------------+tests :: [Test]+tests = [testGroup "Simple insertion testing" insTests+ ,testGroup "Monoid laws" monoidLaws+ ,testGroup "Nested block insertion testing" nestingTests]+++------------------------------------------------------------------------------+main :: IO ()+main = defaultMain tests