diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,3 @@ +:set -XOverloadedStrings +:set -Wall +:set -isrc diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/map-syntax.cabal b/map-syntax.cabal new file mode 100644 --- /dev/null +++ b/map-syntax.cabal @@ -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 diff --git a/src/Data/Map/Syntax.hs b/src/Data/Map/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Map/Syntax.hs @@ -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 diff --git a/test/Data/Map/Syntax/Tests.hs b/test/Data/Map/Syntax/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Data/Map/Syntax/Tests.hs @@ -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' diff --git a/test/Data/Map/Syntax/Util.hs b/test/Data/Map/Syntax/Util.hs new file mode 100644 --- /dev/null +++ b/test/Data/Map/Syntax/Util.hs @@ -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 = " 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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -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