diff --git a/hedn.cabal b/hedn.cabal --- a/hedn.cabal +++ b/hedn.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hedn -version: 0.1.5.0 +version: 0.1.5.1 synopsis: EDN parsing and encoding homepage: https://bitbucket.org/dpwiz/hedn license: BSD3 @@ -19,8 +19,7 @@ Based on specs published at . extra-source-files: - tests/TestParser.hs - tests/TestEncoder.hs + tests/Main.hs flag developer description: operate in developer mode @@ -30,7 +29,7 @@ exposed-modules: Data.EDN, Data.EDN.Types, Data.EDN.Parser, Data.EDN.Encode other-modules: Data.Parser, Data.EDN.Types.Class hs-source-dirs: src/ - build-depends: base ==4.5.*, attoparsec, text, bytestring, containers, vector, stringsearch, mtl, deepseq + build-depends: base ==4.*, attoparsec, text, bytestring, containers, vector, stringsearch, mtl, deepseq if flag(developer) ghc-options: -Werror @@ -39,18 +38,12 @@ ghc-options: -O2 -Wall -fno-warn-unused-do-bind -Test-Suite test-parser +Test-Suite tests type: exitcode-stdio-1.0 - main-is: TestParser.hs + main-is: Main.hs hs-source-dirs: tests/ - build-depends: base, hedn, attoparsec, bytestring, ansi-terminal + build-depends: base, hedn, HUnit, bytestring, text, containers, vector ghc-options: -Wall - -Test-Suite test-encoder - type: exitcode-stdio-1.0 - main-is: TestEncoder.hs - hs-source-dirs: tests/ - build-depends: base, hedn, attoparsec, bytestring, ansi-terminal source-repository head type: mercurial diff --git a/src/Data/EDN.hs b/src/Data/EDN.hs --- a/src/Data/EDN.hs +++ b/src/Data/EDN.hs @@ -3,7 +3,7 @@ Value(..), TaggedValue, Tagged(..), -- ** Type conversion - ToEDN, FromEDN, toEDN, fromEDN, fromEDNv, + ToEDN, FromEDN, toEDN, fromEDN, fromEDNv, (.:), (.:?), -- * Tag manipulation setTag, getTag, stripTag, @@ -19,16 +19,17 @@ integer, floating, -- ** Containers - makeList, makeVec, makeSet, makeMap, (..=), + makeList, makeVec, makeSet, makeMap, (.=), -- * Encoding encode, fromValue, fromTagged, -- * Parsing - decode, parseValue, parseTagged + decode, parseValue, parseTagged, Result(..) ) where import Data.EDN.Types -import Data.EDN.Types.Class (FromEDN, ToEDN, toEDN, fromEDN, fromEDNv) +import Data.EDN.Types.Class (FromEDN, ToEDN, toEDN, fromEDN, fromEDNv, (.:), (.:?)) import Data.EDN.Encode (encode, fromValue, fromTagged) import Data.EDN.Parser (decode, parseValue, parseTagged) +import Data.Parser (Result(..)) diff --git a/src/Data/EDN/Encode.hs b/src/Data/EDN/Encode.hs --- a/src/Data/EDN/Encode.hs +++ b/src/Data/EDN/Encode.hs @@ -32,7 +32,7 @@ fromValue (E.String t) = singleton '"' <> quote t <> singleton '"' -fromValue (E.Character c) = singleton '\\' <> singleton c +fromValue (E.Character c) = singleton '\\' <> quoteChar c fromValue (E.Symbol "" v) = string v fromValue (E.Symbol ns v) = string ns <> singleton '/' <> string v @@ -67,6 +67,13 @@ escape '\r' = "\\r" escape '\t' = "\\t" escape c = singleton c + +quoteChar :: Char -> Builder +quoteChar c = case c of + '\n' -> string "newline" + '\t' -> string "tab" + ' ' -> string "space" + _ -> singleton c fromList :: [E.TaggedValue] -> Builder fromList [] = "" diff --git a/src/Data/EDN/Types.hs b/src/Data/EDN/Types.hs --- a/src/Data/EDN/Types.hs +++ b/src/Data/EDN/Types.hs @@ -21,7 +21,7 @@ integer, floating, -- ** Containers - makeList, makeVec, makeSet, makeMap, (..=) + makeList, makeVec, makeSet, makeMap, (.=) ) where import Data.String (IsString(..)) @@ -126,18 +126,18 @@ floating = NoTag . Floating {-# INLINE floating #-} --- | Attach a namespaced tag to a 'Value'. -tag :: ByteString -> ByteString -> Value -> TaggedValue +-- | Attach a namespaced tag to a value. +tag :: ByteString -> ByteString -> a -> Tagged a tag ns t value = Tagged value ns t {-# INLINE tag #-} --- | Wrap a 'Value' into tagless container. -notag :: Value -> TaggedValue +-- | Wrap a value into tagless container. +notag :: a -> Tagged a notag = NoTag {-# INLINE notag #-} --- | Replace a tag on a value. -setTag :: ByteString -> ByteString -> TaggedValue -> TaggedValue +-- | Replace a tag on a 'Tagged' value. +setTag :: ByteString -> ByteString -> Tagged a -> Tagged a setTag ns t (NoTag v) = tag ns t v setTag ns t (Tagged v _ _) = tag ns t v {-# INLINE setTag #-} @@ -148,7 +148,7 @@ getTag (Tagged _ ns t) = (ns, t) -- | Extract bare value from a tagged or tagless container. -stripTag :: TaggedValue -> Value +stripTag :: Tagged a -> a stripTag (NoTag v) = v stripTag (Tagged v _ _) = v {-# INLINE stripTag #-} @@ -178,6 +178,6 @@ {-# INLINE makeMap #-} -- | Construct a 'Pair' from a key (as EDN keyword) and a value. -(..=) :: ByteString -> TaggedValue -> Pair -name ..= value = (Keyword name, value) -{-# INLINE (..=) #-} +(.=) :: ByteString -> TaggedValue -> Pair +name .= value = (Keyword name, value) +{-# INLINE (.=) #-} diff --git a/src/Data/EDN/Types/Class.hs b/src/Data/EDN/Types/Class.hs --- a/src/Data/EDN/Types/Class.hs +++ b/src/Data/EDN/Types/Class.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, IncoherentInstances #-} module Data.EDN.Types.Class ( - ToEDN, FromEDN, toEDN, fromEDN, fromEDNv + ToEDN, FromEDN, toEDN, fromEDN, fromEDNv, (.:), (.:?) ) where import Control.Applicative (pure, (<$>)) +import Control.Monad (liftM, liftM2) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE @@ -58,6 +59,16 @@ parseEDN (E.NoTag _) = fail "no tag" {-# INLINE parseEDN #-} +instance (ToEDN a) => ToEDN (E.Tagged a) where + toEDN (E.Tagged v ns t) = E.setTag ns t $ toEDN v + toEDN (E.NoTag v) = toEDN v + {-# INLINE toEDN #-} + +instance (FromEDN a) => FromEDN (E.Tagged a) where + parseEDN (E.Tagged v ns t) = E.tag ns t <$> parseEDNv v + parseEDN (E.NoTag v) = E.notag <$> parseEDNv v + {-# INLINE parseEDN #-} + instance ToEDN Bool where toEDN = E.bool {-# INLINE toEDN #-} @@ -209,6 +220,32 @@ fromEDNv = P.parse parseEDNv {-# INLINE fromEDNv #-} +-- | Retrieve the value associated with the given key of an 'E.EDNMap'. +-- The result is 'empty' if the key is not present or the value cannot +-- be converted to the desired type. +-- +-- This accessor is appropriate if the key and value /must/ be present +-- in an object for it to be valid. If the key and value are +-- optional, use '(.:?)' instead. +(.:) :: (Show k, ToEDN k, FromEDN a) => E.EDNMap -> k -> P.Parser a +emap .: key = case M.lookup (toEDNv key) emap of + Nothing -> fail $ "key " ++ show key ++ " not present" + Just v -> parseEDN v +{-# INLINE (.:) #-} + +-- | Retrieve the value associated with the given key of an 'E.EDNMap'. +-- The result is 'Nothing' if the key is not present, or 'empty' if +-- the value cannot be converted to the desired type. +-- +-- This accessor is most useful if the key and value can be absent +-- from an object without affecting its validity. If the key and +-- value are mandatory, use '(.:)' instead. +(.:?) :: (ToEDN k, FromEDN a) => E.EDNMap -> k -> P.Parser (Maybe a) +emap .:? key = case M.lookup (toEDNv key) emap of + Nothing -> pure Nothing + Just v -> parseEDN v +{-# INLINE (.:?) #-} + -- | Fail parsing due to a type mismatch, with a descriptive message. typeMismatch :: String -- ^ The name of the type you are trying to parse. -> E.Value -- ^ The actual value encountered. @@ -236,13 +273,5 @@ {-# INLINE mapMset #-} mapMmap :: (Ord a2, Monad m) => (a1 -> m a2) -> (b1 -> m b2) -> M.Map a1 b1 -> m (M.Map a2 b2) -mapMmap kf vf m = do - let pairsIn = M.assocs m - pairsOut <- mapM fs pairsIn - return $! M.fromList pairsOut - where - fs (k, v) = do - newK <- kf k - newV <- vf v - return (newK, newV) +mapMmap kf vf = liftM M.fromList . mapM (\(k, v) -> liftM2 (,) (kf k) (vf v)) . M.assocs {-# INLINE mapMmap #-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverloadedStrings, ExistentialQuantification #-} + +module Main where + +import Test.HUnit +import Control.Monad (when) +import System.Exit (exitFailure) + +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text.Lazy as TL +import qualified Data.Text as T + +import qualified Data.Vector as V +import qualified Data.Set as S +import qualified Data.Map as M + +import Data.EDN (ToEDN, toEDN, fromEDN, Result(..)) +import Data.EDN.Types as E +import Data.EDN.Parser (decode) +import Data.EDN.Encode (encode) + +main :: IO () +main = do + (Counts _ _ e f) <- runTestTT tests + when (e > 0 || f > 0) $ exitFailure + +tests :: Test +tests = TestList [ TestLabel "BSL -> TV decoder" $ TestList $ map makeDecodeCase decodeCases + , TestLabel "TV -> BSL encoder" $ TestList $ map makeEncodeCase encodeCases + , TestLabel "decoder fail" (TestCase (assertEqual "bad unicode" Nothing (decode "№"))) + , TestLabel "ToEDN conversion" $ TestList $ map makeToEDNcase toEDNcases + , TestLabel "'Tagged a' conversion" $ TestList taggedConversion + ] + +makeDecodeCase :: (BSL.ByteString, E.TaggedValue) -> Test +makeDecodeCase (i, o) = TestCase (assertEqual (BSL.unpack i) (Just o) (decode i)) + +makeEncodeCase :: (E.TaggedValue, BSL.ByteString) -> Test +makeEncodeCase (i, o) = TestCase (assertEqual (BSL.unpack o) o (encode i)) + +decodeCases :: [(BSL.ByteString, E.TaggedValue)] +decodeCases = [ ("nil", E.nil) + + , ("true", E.true) + , ("false", E.false) + + , ("\"a nice string\"", "a nice string") + , ("\"split\\second \\t\\rai\\n\"", "split\\second \t\rai\n") + , ("\"test \\\"sausage\\\" shmest\"", "test \"sausage\" shmest") + , ("\"\"", "") + + , ("\\c", E.char 'c') + , ("\\\\", E.char '\\') + , ("\\newline", E.char '\n') + , ("\\space", E.char ' ') + , ("\\tab", E.char '\t') + + , ("justasymbol", E.symbol "justasymbol") + , ("with#stuff:inside", E.symbol "with#stuff:inside") + , ("my-namespace/foo", E.symbolNS "my-namespace" "foo") + , ("/", E.symbol "/") + + , (":fred", E.keyword "fred") + , (":my/fred", E.keyword "my/fred") + + , ("42", E.integer 42) + , ("-1", E.integer (-1)) + + , ("100.50", E.floating 100.5) + , ("-3.14", E.floating (-3.14)) + -- ...and many other strange stuff... + + , ("(a b 42)", sampleList) + , ("()", E.notag $ E.makeList []) + + , ("[a b 42]", sampleVec) + , ("[]", E.notag $ E.makeVec []) + + , ("{:a 1, \"foo\" :bar, [1 2 3] four}", sampleMap) + , ("{}", E.notag $ E.makeMap []) + + , ("#{a b [1 2 3]}", sampleSet) + , ("#{}", E.notag $ E.makeSet []) + + , ("[a b #_foo 42]", sampleDiscard) + , ("(1 2 ;more to go!\n 3 4)", sampleComment) + + , ("#myapp/Person {:first \"Fred\" :last \"Mertz\"}", E.tag "myapp" "Person" sampleTaggedMap) + , ("{:first \"Fred\" :last \"Mertz\"}", E.notag sampleTaggedMap) + ] + +encodeCases :: [(E.TaggedValue, BSL.ByteString)] +encodeCases = [ (E.nil, "nil") + + , (E.true, "true") + , (E.false, "false") + + , (E.string "a nice string", "\"a nice string\"") + , ("overloaded", "\"overloaded\"") + , ("escape \rou\te \\ \"\north\"", "\"escape \\rou\\te \\\\ \\\"\\north\\\"\"") + + , (E.char 'c', "\\c") + , (E.char '\\', "\\\\") + , (E.char '\n', "\\newline") + , (E.char '\t', "\\tab") + , (E.char ' ', "\\space") + + , (E.symbol "justasymbol", "justasymbol") + , (E.symbol "with#stuff:inside", "with#stuff:inside") + , (E.symbolNS "whatever" "whenever", "whatever/whenever") + , (E.symbol "/", "/") + + , (E.keyword "fred", ":fred") + , (E.keyword "my/fred", ":my/fred") + , (E.notag ":overloaded", ":overloaded") -- IsString kw transform only for untagged values + + , (E.integer 42, "42") + , (E.integer (-1), "-1") + + , (E.floating 100.50, "100.5") + , (E.floating (-3.14), "-3.14") + + , (sampleList, "(a b 42)") + , (E.notag $ E.makeList [], "()") + + , (sampleVec, "[a b 42]") + , (E.notag $ E.makeVec [], "[]") + + , (sampleMap, "{\"foo\" :bar :a 1 [1 2 3] four}") -- Order not guaranteed + , (E.notag $ E.makeMap [], "{}") + + , (E.tag "myapp" "Person" sampleTaggedMap, "#myapp/Person {:first \"Fred\" :last \"Mertz\"}") + ] + +sampleList :: E.TaggedValue +sampleList = E.notag $ E.makeList [E.symbol "a", E.symbol "b", E.integer 42] + +sampleVec :: E.TaggedValue +sampleVec = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] + +sampleMap :: E.TaggedValue +sampleMap = E.notag $ E.makeMap [ (":a", E.integer 1) + , ("foo", E.keyword "bar") + , (E.makeVec [E.integer 1, E.integer 2, E.integer 3], E.symbol "four") + ] + +sampleSet :: E.TaggedValue +sampleSet = E.notag $ E.makeSet [ E.symbol "a" + , E.symbol "b" + , E.notag $ E.makeVec [E.integer 1, E.integer 2, E.integer 3] + ] + +sampleDiscard :: E.TaggedValue +sampleDiscard = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] + +sampleComment :: E.TaggedValue +sampleComment = E.notag $ E.makeList [E.integer 1, E.integer 2, E.integer 3, E.integer 4] + +sampleTaggedMap :: E.Value +sampleTaggedMap = E.makeMap [ "first" .= "Fred", "last" .= "Mertz" ] + +data ToEDNCase = forall a. ToEDN a => ToEDNCase !a !E.TaggedValue + +makeToEDNcase :: ToEDNCase -> Test +makeToEDNcase (ToEDNCase i o) = TestCase (assertEqual (show o) o (toEDN i)) + +toEDNcases :: [ToEDNCase] +toEDNcases = [ ToEDNCase (Nothing :: Maybe Bool) E.nil + + , ToEDNCase (Left "hi" :: Either String ()) $ E.tag "either" "left" "hi" + , ToEDNCase (Right "z" :: Either () String) $ E.tag "either" "right" "z" + + , ToEDNCase True E.true + , ToEDNCase False E.false + + , ToEDNCase ("test" :: String) (E.string "test") + , ToEDNCase ("test" :: BSL.ByteString) "test" + , ToEDNCase ("test" :: BS.ByteString) "test" + , ToEDNCase ("test" :: TL.Text) "test" + , ToEDNCase ("test" :: T.Text) "test" + + , ToEDNCase 'c' $ E.char 'c' + , ToEDNCase '\n' $ E.char '\n' + , ToEDNCase '\\' $ E.char '\\' + + , ToEDNCase (3.14 :: Double) $ E.floating 3.14 + , ToEDNCase (42 :: Integer) $ E.integer 42 + + , ToEDNCase () (E.notag $ E.makeList []) + , ToEDNCase ([] :: [()]) (E.notag $ E.makeList []) + , ToEDNCase (["yo", "wassup"] :: [String]) (E.notag $ E.makeList ["yo", "wassup"]) + , ToEDNCase [E.string "i", "am", E.symbolNS "boxed" "container"] (E.notag $ E.makeList [E.string "i", "am", E.symbolNS "boxed" "container"]) + + , ToEDNCase (V.fromList ['o', 'm', 'g']) (E.notag $ E.makeVec [E.char 'o', E.char 'm', E.char 'g']) + + , ToEDNCase (S.fromList ['o', 'm', 'g']) (E.notag $ E.makeSet [E.char 'o', E.char 'm', E.char 'g']) + + , ToEDNCase (M.fromList [("test", "shmest"), ("foo", "bar")] :: M.Map String String) (E.notag $ E.makeMap [("test", "shmest"), ("foo", "bar")]) + , ToEDNCase (M.fromList [(":test", "shmest"), (":foo", "bar")] :: EDNMap) (E.notag $ E.makeMap ["test" .= "shmest", "foo" .= "bar"]) + ] + + +taggedConversion :: [Test] +taggedConversion = [ TestCase (assertEqual "toEDN tagged" (E.tag "wo" "ot" (E.Boolean False)) (toEDN $ E.tag "wo" "ot" False)) + , TestCase (assertEqual "toEDN notag" E.false (toEDN $ E.notag False)) + , TestCase (assertEqual "fromEDN tagged" (Success $ E.tag "wo" "ot" False) (fromEDN $ E.tag "wo" "ot" (E.Boolean False))) + , TestCase (assertEqual "fromEDN notag" (Success $ E.notag False) (fromEDN $ E.false)) + ] diff --git a/tests/TestEncoder.hs b/tests/TestEncoder.hs deleted file mode 100644 --- a/tests/TestEncoder.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Data.EDN.Types as E -import Data.EDN.Encode (encode) - -main = do - print . encode . E.NoTag . E.List $ map E.NoTag [E.Keyword "a", E.Keyword "b", E.Integer 42] diff --git a/tests/TestParser.hs b/tests/TestParser.hs deleted file mode 100644 --- a/tests/TestParser.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE OverloadedStrings, Rank2Types #-} - -module Main where - -import Data.Attoparsec.Lazy as A -import qualified Data.ByteString.Lazy.Char8 as BSL - -import Data.EDN.Parser as P -import Data.EDN.Types as E - -import Control.Monad (forM_) -import qualified System.Console.ANSI as ANSI - -main :: IO () -main = forM_ cases $ checkCase (parse P.parseTagged) (parserResult) - -parserResult :: Eq a => Result a -> a -> Bool -parserResult result output = case result of - Done "" o -> o == output - _ -> False - -checkCase :: forall a a1. (Show a1, Show a) => (BSL.ByteString -> a1) - -> (a1 -> a -> Bool) - -> (BSL.ByteString, a) - -> IO () -checkCase runner checker (input, output) = do - putStr "Checking: '" - BSL.putStr input - putStrLn "'" - - putStrLn $ "Should be: " ++ show output - - let result = runner input - let correct = checker result output - - ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid (if correct then ANSI.Green else ANSI.Red)] - putStr "Result: " - ANSI.setSGR [ANSI.Reset] - print result - putStrLn "" - -cases :: [(BSL.ByteString, E.TaggedValue)] -cases = [ ("nil", E.nil) - - , ("true", E.true) - , ("false", E.false) - - , ("\"a nice string\"", "a nice string") - , ("\"split\\second \\t\\rai\\n\"", "split\\second \t\rai\n") - , ("\"test \\\"sausage\\\" shmest\"", "test \"sausage\" shmest") - , ("\"\"", "") - - , ("\\c", E.char 'c') - , ("\\\\", E.char '\\') - , ("\\newline", E.char '\n') - , ("\\space", E.char ' ') - , ("\\tab", E.char '\t') - - , ("justasymbol", E.symbol "justasymbol") - , ("with#stuff:inside", E.symbol "with#stuff:inside") - , ("my-namespace/foo", E.symbolNS "my-namespace" "foo") - , ("/", E.symbol "/") - - , (":fred", E.keyword "fred") - , (":my/fred", E.keyword "my/fred") - - , ("42", E.integer 42) - , ("-1", E.integer (-1)) - - , ("100.50", E.floating 100.5) - , ("-3.14", E.floating (-3.14)) - -- ...and many other strange stuff... - - , ("(a b 42)", sampleList) - , ("()", E.notag $ E.makeList []) - - , ("[a b 42]", sampleVec) - , ("[]", E.notag $ E.makeVec []) - - , ("{:a 1, \"foo\" :bar, [1 2 3] four}", sampleMap) - , ("{}", E.notag $ E.makeMap []) - - , ("#{a b [1 2 3]}", sampleSet) - , ("#{}", E.notag $ E.makeSet []) - - , ("[a b #_foo 42]", sampleDiscard) - , ("(1 2 ;more to go!\n 3 4)", sampleComment) - - , ("#myapp/Person {:first \"Fred\" :last \"Mertz\"}", E.tag "myapp" "Person" sampleTaggedMap) - , ("{:first \"Fred\" :last \"Mertz\"}", E.notag sampleTaggedMap) - ] - -sampleList :: E.TaggedValue -sampleList = E.notag $ E.makeList [E.symbol "a", E.symbol "b", E.integer 42] - -sampleVec :: E.TaggedValue -sampleVec = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] - -sampleMap :: E.TaggedValue -sampleMap = E.notag $ E.makeMap [ (":a", E.integer 1) - , ("foo", E.keyword "bar") - , (E.makeVec [E.integer 1, E.integer 2, E.integer 3], E.symbol "four") - ] - -sampleSet :: E.TaggedValue -sampleSet = E.notag $ E.makeSet [ E.symbol "a" - , E.symbol "b" - , E.notag $ E.makeVec [E.integer 1, E.integer 2, E.integer 3] - ] - -sampleDiscard :: E.TaggedValue -sampleDiscard = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] - -sampleComment :: E.TaggedValue -sampleComment = E.notag $ E.makeList [E.integer 1, E.integer 2, E.integer 3, E.integer 4] - -sampleTaggedMap :: E.Value -sampleTaggedMap = E.makeMap [ "first" ..= "Fred", "last" ..= "Mertz" ]