diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,26 @@ All notable changes to this project will be documented in this file. This project adheres to [Semantic Versioning](http://semver.org/). +## [0.2.0.0] - 2019-01-18 + +### Changed + +- Complete rewrite in Megaparsec. +- Text types changed to, well, `Text` +- Document with `prettyprinter` +- Test suite changed to Hedgehog +- Code repository moved to GitLab + +### Removed + +- GHC < 8.0 (Stackage LTS < 7) aren't supported due to Semigroup-Monoid changes. + +## [0.1.9.1] - 2018-12-03 + +### Changed + +- GHC 8.4 compatibility fixes + ## [0.1.9.0] - 2018-04-05 ### Fixed @@ -31,7 +51,9 @@ - Use utf8-string parsing for unicode literals. -[0.1.9.0]: https://bitbucket.org/dpwiz/hedn/commits/tag/0.1.9.0 -[0.1.8.2]: https://bitbucket.org/dpwiz/hedn/commits/tag/0.1.8.2 -[0.1.8.1]: https://bitbucket.org/dpwiz/hedn/commits/tag/0.1.8.1 -[0.1.8.0]: https://bitbucket.org/dpwiz/hedn/commits/tag/0.1.8.0 +[0.2.0.0]: https://gitlab.com/dpwiz/hedn/tree/0.2.0.0 +[0.1.9.1]: https://gitlab.com/dpwiz/hedn/tree/0.1.9.1 +[0.1.9.0]: https://gitlab.com/dpwiz/hedn/tree/0.1.9.0 +[0.1.8.2]: https://gitlab.com/dpwiz/hedn/tree/0.1.8.2 +[0.1.8.1]: https://gitlab.com/dpwiz/hedn/tree/0.1.8.1 +[0.1.8.0]: https://gitlab.com/dpwiz/hedn/tree/0.1.8.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, Alexander Bondarenko +Copyright (c) 2019, Alexander Bondarenko All rights reserved. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,184 @@ +# Haskell EDN + +An EDN parsing and encoding library inspired by `aeson`. + +Based on [spec] and [hints] published on GitHub. + +Hackage: https://hackage.haskell.org/package/hedn + +Stackage: https://www.stackage.org/package/hedn + +[spec]: https://github.com/edn-format/edn +[hints]: https://github.com/wagjo/serialization-formats + +# Examples + +## AST + +```clojure +(#haskell/edn example/kitchensink ; tagged symbol + nil ; ugh.. + \space ; character + "dynamic \"typing\"" ; string + {:numbers ; keyword + [42 ; integer + 42.0 ; floating + ] ; Vector + :bools + #{true, false} ; Set (with optional commas) + } ; Map +) ; List +``` + +```haskell +import qualified Data.EDN as EDN +import qualified Data.Text.IO as Text + +main = do + edn <- Text.readFile "example.edn" + value <- EDN.parseText "example.edn" edn + print value +``` + +```haskell +NoTag + (List + [ Tagged "haskell" "edn" (Symbol "example" "kitchensink") + , NoTag Nil + , NoTag (Character ' ') + , NoTag (String "dynamic \"typing\"") + , NoTag + (Map + (fromList + [ ( NoTag (Keyword "bools") + , NoTag + (Set (fromList [ NoTag (Boolean False) , NoTag (Boolean True) ])) + ) + , ( NoTag (Keyword "numbers") + , NoTag (Vec [ NoTag (Integer 42) , NoTag (Floating 42.0) ]) + ) + ])) + ]) +``` + +## Conversion + +More examples in `tests/Data/EDN/Class/Test.hs`. + +```haskell +data Person = Person + { personFirst :: Text + , personLast :: Text + } deriving (Eq, Show) + +instance ToEDN Person where + toEDN Person{..} = + toEDNtagged "myapp" "Person" $ Map.fromList + [ (EDN.Keyword "first", toEDN personFirst) + , (EDN.Keyword "last", toEDN personLast) + ] + +instance FromEDN Person where + parseEDN = \case + EDN.Tagged "myapp" "Person" v -> Person + <$> EDN.mapGetKeyword "first" v + <*> EDN.mapGetKeyword "last" v + _ -> + fail "myapp/Person expected" +``` + +```haskell +import qualified Data.EDN as EDN +import qualified Data.Text.IO as Text + +main = Text.putStrLn $ + encodeText (Person "Fred" "Mertz") +``` + +```clojure +#myapp/Person {:first "Fred" :last "Mertz"} +``` + +## Quasiquoter + +Embed EDN AST literals with `edn`: + +```haskell +fredEDN = [edn| + #myapp/Person {:first "Fred" :last "Mertz"} +|] +``` + +Additionally there are QQs for untagged collections. +They simply wrap the block in appropriate symbols. + +* Lists, `()` + ```haskell + EDN.List (items :: [TaggedValue]) = + [ednList| + this is a list of symbols, commas are whitespace + |] + ``` +* Vectors, `[]` + ```haskell + EDN.Vec (items :: Vector TaggedValue) = + [ednVec| + 42 is #the/answer true + |] + ``` +* Sets, `#{}` + ```haskell + EDN.Set (items :: Set TaggedValue) = + [ednSet| + badger badger badger badger + badger badger badger badger + mushroom mushroom + |] + ``` +* Maps, `{}` + ```haskell + EDN.Map (dict :: Map TaggedValue TaggedValue) = + [ednMap| + :keywords "as you like it" + or/symbols "I won't judge" + #uuid "d748ab62-9cb1-41fb-b8dc-e23f3ffc5f9b" + (tagged values, collections, anything goes) + |] + ``` + +### EDN as DSL syntax + +You can add quasiquoters for your values by specializing `fromEDN` QuasiQuoter. + +> Usual TH shenanigans apply. +> Define things in a separate module. +> Either `Data.Data.Data` or `Language.Haskell.TH.Syntax.Lift` instance required to convert values to Haskell AST. + +```haskell +module My.Data.QQ (myData) where + +import Data.EDN.QQ (fromEDN) +import My.Data.Types (MyData) + +myData :: QuasiQuoter +myData = fromEDN @MyData +``` + +```haskell +module Main where + +import My.Data.QQ (myData) + +main :: IO () +main = cobc + [myData| + {:identification-division + [#program/id hello] + :procedure-division + ((display "Hello, world!" + end-display) + stop-run + ) + } + |] +``` diff --git a/example.edn b/example.edn new file mode 100644 --- /dev/null +++ b/example.edn @@ -0,0 +1,12 @@ +(#haskell/edn example/kitchensink ; tagged symbol + nil ; ugh.. + \space ; character + "dynamic \"typing\"" ; string + {:numbers ; keyword + [42 ; integer + 42.0 ; floating + ] ; Vector + :bools + #{true false} ; Set + } ; Map +) ; List diff --git a/hedn.cabal b/hedn.cabal --- a/hedn.cabal +++ b/hedn.cabal @@ -1,78 +1,89 @@ -name: hedn -version: 0.1.9.1 -synopsis: EDN parsing and encoding -homepage: https://bitbucket.org/dpwiz/hedn -license: BSD3 -license-file: LICENSE -author: Alexander Bondarenko -maintainer: aenor.realm@gmail.com -copyright: (c) 2012 Alexander Bondarenko -category: Data -build-type: Simple -cabal-version: >=1.8 -tested-with: - GHC==7.4.2, - GHC==7.6.3, - GHC==7.8.4, - GHC==7.10.3, - GHC==8.0.1, - GHC==8.2.2, - GHC==8.4.4 +cabal-version: 1.12 -description: - A EDN parsing and encoding library inspired by Data.Aeson. - . - Based on specs published at . +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: ca74a2494ad480664d2ec10fd783cd811fee1231966abb8f2415d6c92159be1a +name: hedn +version: 0.2.0.0 +synopsis: EDN parsing and encoding +description: A EDN parsing and encoding library. + . + Based on "specs" published at . +category: Data +author: Alexander Bondarenko +maintainer: aenor.realm@gmail.com +copyright: (c) 2019 Alexander Bondarenko +license: BSD3 +license-file: LICENSE +tested-with: GHC==8.0.1, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3 +build-type: Simple extra-source-files: - CHANGELOG.md - tests/Main.hs - tests/Data/EDN/Test/*.hs - tests/Data/EDN/Test/QuickCheck/TH.hs + CHANGELOG.md + LICENSE + README.md + example.edn +source-repository head + type: git + location: https://gitlab.com/dpwiz/hedn + library exposed-modules: - Data.EDN, - Data.EDN.Types, - Data.EDN.Types.Class, - Data.EDN.Parser, - Data.EDN.Encode - + Data.EDN + Data.EDN.AST.Lexer + Data.EDN.AST.Parser + Data.EDN.AST.Printer + Data.EDN.AST.Types + Data.EDN.AST.Types.Tagged + Data.EDN.AST.Types.Value + Data.EDN.Class + Data.EDN.Class.Parser + Data.EDN.QQ other-modules: - Data.Parser - - hs-source-dirs: src/ + Paths_hedn + hs-source-dirs: + lib + ghc-options: -Wall build-depends: - base >=4.5 && <5, - base-compat >=0.6.0, - attoparsec, - text, - bytestring >=0.10, - scientific, - utf8-string, - containers, - vector, - stringsearch, - mtl, - deepseq, - time, - time-locale-compat - - ghc-options: -Wall -fno-warn-unused-do-bind + base >=4.9 && <4.13 + , containers >=0.5.7 && <0.7 + , deepseq >=1.4 && <2 + , deriving-compat >=0.3.6 && <0.6 + , megaparsec >=7.0 && <8 + , parser-combinators >=1.0 && <2 + , prettyprinter >=1.2 && <2 + , scientific >=0.3 && <0.4 + , template-haskell >=2.11 && <3 + , text >=1.2 && <2 + , time >=1.6 && <2 + , uuid >=1.3 && <2 + , vector >=0.11 && <1 + default-language: Haskell2010 -Test-Suite tests - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: tests/ +test-suite edn-test + type: exitcode-stdio-1.0 + main-is: Main.hs other-modules: - Data.EDN.Test.QuickCheck - Data.EDN.Test.QuickCheck.TH - Data.EDN.Test.Unit - - build-depends: base, hedn, bytestring, text, containers, vector, template-haskell, time, - QuickCheck >= 2.5.1, hspec >= 1.5.1, HUnit >= 1.2.5, hspec-contrib - ghc-options: -Wall - -source-repository head - type: git - location: https://bitbucket.org/dpwiz/hedn + Data.EDN.AST.Gen + Data.EDN.AST.Test + Data.EDN.Class.Gen + Data.EDN.Class.Test + Data.EDN.QQ.Test + Paths_hedn + hs-source-dirs: + tests + ghc-options: -Wall + build-depends: + base >=4.9 && <4.13 + , containers >=0.5.7 && <0.7 + , hedgehog >=0.6 && <0.7 + , hedn >=0.2 && <1 + , megaparsec >=7.0 && <8 + , text >=1.2 && <2 + , time >=1.6 && <2 + , uuid >=1.3 && <2 + , vector >=0.11 && <1 + default-language: Haskell2010 diff --git a/lib/Data/EDN.hs b/lib/Data/EDN.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN.hs @@ -0,0 +1,70 @@ +module Data.EDN + ( decodeText + , encodeText + + -- * EDN AST + , parseText + , renderText + , TaggedValue + , Tagged(..) + , stripTag + , Value(..) + , EDNList, EDNVec, EDNMap, EDNSet + , mkList, mkVec, mkMap, mkSet + + -- * Encoding to EDN AST + , ToEDN(..) + , toEDNtagged + + -- * Decoding EDN AST + , FromEDN(..) + , fromEDN + -- ** AST-parsing wrappers + , withTagged + , withNoTag + , withNil + , withBoolean + , withString + , withCharacter + , withSymbol + , withKeyword + , withTextual + , withInteger + , withIntegral + , withFloating + , withFractional + , withList + , withVec + , withMap + , withSet + , unexpected + -- ** Additional helpers + , vecGet + , mapGetKeyword + , mapGetString + , mapGetSymbol + , mapGetSymbolNS +) where + +import Data.Text (Text) + +import Data.EDN.AST.Parser (parseText) +import Data.EDN.AST.Printer (renderText) +import Data.EDN.AST.Types.Tagged +import Data.EDN.AST.Types.Value +import Data.EDN.Class + +-- | Convert value to AST using 'ToEDN' instance and render it. +encodeText :: ToEDN a => a -> Text +encodeText = + renderText . toEDN + +-- | Decode EDN document into AST and parse value using its 'FromEDN' instance. +decodeText + :: (FromEDN a, Monad m) + => String -- ^ Source name, for megaparsec error reports + -- e.g. @/path/to/file.edn@ or @@ + -> Text -- ^ EDN document body + -> m a +decodeText sourceName source = + parseText sourceName source >>= fromEDN diff --git a/lib/Data/EDN/AST/Lexer.hs b/lib/Data/EDN/AST/Lexer.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/AST/Lexer.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.EDN.AST.Lexer + ( dropWS + , lexeme + , symbol + , integer + , hexadecimal + , floating + ) where + +import Data.Text (Text) + +import qualified Control.Monad.Combinators as P +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as L + +import Data.EDN.AST.Types (Parser) + +dropWS :: Parser () +dropWS = P.skipMany $ P.choice + [ P.hidden P.space1 + , P.hidden $ () <$ P.char ',' + , P.hidden $ L.skipLineComment ";" + ] + +-- | Whitespace will be consumed after every lexeme automatically, but not before it. +lexeme :: Parser a -> Parser a +lexeme = L.lexeme dropWS + +symbol :: Text -> Parser Text +symbol = L.symbol dropWS + +integer :: Parser Int +integer = lexeme $ L.signed (pure ()) L.decimal + +hexadecimal :: Parser Int +hexadecimal = lexeme L.hexadecimal + +floating :: Parser Double +floating = lexeme $ L.signed (pure ()) L.float diff --git a/lib/Data/EDN/AST/Parser.hs b/lib/Data/EDN/AST/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/AST/Parser.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.EDN.AST.Parser + ( parseText + -- * EDN document + , parseDoc + -- * Single value + , parseTagged + , parseValue + -- * Primitive parsers + , parseDiscard + , parseNil + , parseBool + , parseNumber + , parseKeyword + , parseSymbol + , parseCollections + -- * Character classes + , tagChars + , keywordInitialChars + , keywordChars + , symbolInitialChars + , symbolChars + -- ** Basic characters + , digitChars + , lowerChars + , upperChars + , miscChars + ) where + +import Control.Applicative ((<|>)) +import Data.Char (chr) +import Data.Text (Text) + +import qualified Data.Text as Text +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P + +import Data.EDN.AST.Types (Parser, Tagged(..), TaggedValue, Value(..)) + +import qualified Data.EDN.AST.Lexer as L +import qualified Data.EDN.AST.Types as EDN + +parseText + :: Monad m + => String -- ^ Source name, for megaparsec error reports + -- e.g. @/path/to/file.edn@ or @@ + -> Text -- ^ EDN document body + -> m TaggedValue +parseText sourceName source = + case P.parse parseDoc sourceName source of + Right tv -> + pure tv + Left err -> + fail (P.errorBundlePretty err) + +parseDoc :: Parser TaggedValue +parseDoc = do + L.dropWS + parseTagged <* P.eof + +parseTagged :: Parser TaggedValue +parseTagged = P.choice + [ P.try withNS + , P.try withoutNS + , withoutTag + ] + where + withNS = Tagged + <$> (P.char '#' *> parseIdent) + <*> (P.char '/' *> parseIdent) + <*> (L.dropWS *> parseValue) + + withoutNS = Tagged + <$> pure mempty + <*> (P.char '#' *> parseIdent) + <*> (L.dropWS *> parseValue) + + withoutTag = NoTag + <$> parseValue + + parseIdent :: Parser Text + parseIdent = + P.takeWhile1P (Just "tag") (`elem` tagChars) + +parseValue :: Parser Value +parseValue = do + P.skipMany parseDiscard + P.choice + [ parseNil + , parseBool + , P.try parseNumber + , parseSymbol + , parseCharacter + , parseString + , P.try parseKeyword + , parseCollections + ] + +parseDiscard :: Parser () +parseDiscard = do + _ <- P.try $ L.symbol "#_" + () <$ parseValue + +parseCollections :: Parser Value +parseCollections = L.lexeme . P.try $ do + start <- P.oneOf ['#', '{', '[', '('] + case start of + '#' -> do + _ <- P.char '{' + EDN.mkSet <$> parseItemsTill '}' parseTagged + '{' -> do + let pairs = (,) <$> parseTagged <*> parseTagged + EDN.mkMap <$> parseItemsTill '}' pairs + '[' -> + EDN.mkVec <$> parseItemsTill ']' parseTagged + '(' -> + EDN.mkList <$> parseItemsTill ')' parseTagged + _ -> + error "assert: start is one of the collection openers" + where + parseItemsTill end p = do + L.dropWS + P.manyTill (L.dropWS *> p) (L.dropWS *> P.char end) + +parseNil :: Parser Value +parseNil = Nil <$ L.symbol "nil" + +parseBool :: Parser Value +parseBool = P.choice + [ Boolean True <$ L.symbol "true" + , Boolean False <$ L.symbol "false" + ] + +parseSymbol :: Parser Value +parseSymbol = P.label "symbol" . L.lexeme $ do + initial <- P.eitherP (P.char '/') (P.oneOf symbolInitialChars) + (ns, name) <- case initial of + Left _slash -> + pure ("", "/") + Right char -> + P.try (withNS char) <|> withoutNS char + pure $ Symbol ns name + where + withNS :: Char -> Parser (Text, Text) + withNS nsInitial = do + ns <- P.takeWhileP (Just "symbol namespace") (`elem` symbolChars) + _ <- P.char '/' + nameInitial <- P.oneOf symbolInitialChars + name <- P.takeWhileP (Just "symbol name") (`elem` symbolChars) + pure (Text.cons nsInitial ns, Text.cons nameInitial name) + + withoutNS :: Char -> Parser (Text, Text) + withoutNS nameInitial = do + name <- P.takeWhileP (Just "symbol name") (`elem` symbolChars) + pure ("", Text.cons nameInitial name) + +parseCharacter :: Parser Value +parseCharacter = do + _ <- P.char '\\' + fmap Character (P.try unicode <|> named <|> L.lexeme P.printChar) + where + unicode = P.label "hex-encoded unicode character" $ do + _ <- P.char 'u' + fmap chr L.hexadecimal + + named = P.label "whitespace character name" $ P.choice + [ '\n' <$ L.symbol "newline" + , '\r' <$ L.symbol "return" + , ' ' <$ L.symbol "space" + , '\t' <$ L.symbol "tab" + ] + +parseString :: Parser Value +parseString = L.lexeme $ + P.between (P.char '"') (P.char '"') $ + String . Text.pack <$> P.many (escaped <|> plain) + where + escaped :: Parser Char + escaped = do + _ <- P.char '\\' + c <- P.anySingle + pure $ case c of + 'n' -> '\n' + 't' -> '\t' + 'r' -> '\r' + -- 'u' -> error "TODO: unicode escapes \u1234" + _ -> c + plain = P.anySingleBut '"' + +parseNumber :: Parser Value +parseNumber = P.try parseFloating <|> parseInteger + where + parseFloating = Floating <$> L.floating + parseInteger = Integer <$> L.integer + +parseKeyword :: Parser Value +parseKeyword = P.label "keyword" . L.lexeme $ do + c <- P.char ':' *> P.satisfy (`elem` keywordInitialChars) + cs <- P.takeWhileP Nothing (`elem` keywordChars) + pure $ Keyword (Text.cons c cs) + +tagChars :: [Char] +tagChars = mconcat + [ lowerChars + , upperChars + , digitChars + , "-" + ] + +keywordInitialChars :: [Char] +keywordInitialChars = mconcat + [ lowerChars + , upperChars + , miscChars + ] + +keywordChars :: [Char] +keywordChars = mconcat + [ keywordInitialChars + , digitChars + , "/#:" + ] + +symbolInitialChars :: [Char] +symbolInitialChars = mconcat + [ lowerChars + , upperChars + , miscChars + ] + +symbolChars :: [Char] +symbolChars = mconcat + [ symbolInitialChars + , digitChars + , "#:" + ] + +digitChars :: [Char] +digitChars = ['0' .. '9'] + +upperChars :: [Char] +upperChars = ['A' .. 'Z'] + +lowerChars :: [Char] +lowerChars = ['a' .. 'z'] + +miscChars :: [Char] +miscChars = ".*<>!?$%&=+_-" diff --git a/lib/Data/EDN/AST/Printer.hs b/lib/Data/EDN/AST/Printer.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/AST/Printer.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.EDN.AST.Printer + ( renderText + , prettyTaggedValue + , prettyValue + ) where + +import Data.Char (ord) +import Data.Foldable (toList) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc, pretty, (<+>)) +import Text.Printf (printf) + +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.Prettyprint.Doc as PP +import qualified Data.Text.Prettyprint.Doc.Render.Text as PP + +import qualified Data.EDN.AST.Types as EDN + +-- | Render EDN document to 'Text' +renderText :: EDN.TaggedValue -> Text +renderText = + PP.renderStrict . PP.layoutPretty options . prettyTaggedValue + where + options = PP.defaultLayoutOptions + +-- | Prepare 'EDN.TaggedValue' +prettyTaggedValue :: EDN.TaggedValue -> Doc a +prettyTaggedValue = \case + EDN.Tagged "" tag value -> + "#" <> pretty tag <+> prettyValue value + EDN.Tagged ns tag value -> + "#" <> pretty ns <> "/" <> pretty tag <+> prettyValue value + EDN.NoTag value -> + prettyValue value + +-- | Prepare 'EDN.Value' +prettyValue :: EDN.Value -> Doc a +prettyValue = PP.fuse PP.Shallow . \case + EDN.Nil -> + "nil" + EDN.Boolean bool -> + if bool then "true" else "false" + EDN.Character char -> + mappend "\\" $ case char of + '\n' -> "newline" + '\t' -> "tab" + '\r' -> "return" + ' ' -> "space" + _ -> + case show char of + '\'' : '\\' : _ -> + pretty (printf "u%04X" (ord char) :: [Char]) + _ -> + pretty char + EDN.Symbol "" name -> + pretty name + EDN.Symbol ns name -> + pretty ns <> "/" <> pretty name + EDN.Keyword ident -> + ":" <> pretty ident + EDN.Integer int -> + pretty int + EDN.Floating double -> + pretty double + EDN.String str -> + PP.enclose "\"" "\"" . pretty $ escapeText str + EDN.List items -> + PP.parens . PP.hsep $ + map prettyTaggedValue items + EDN.Vec items -> + PP.brackets . PP.hsep $ + map prettyTaggedValue (toList items) + EDN.Set items -> + mappend "#" . PP.braces . PP.hsep $ + map prettyTaggedValue (toList items) + EDN.Map pairs -> + PP.braces . PP.hsep $ + [ prettyTaggedValue k <+> prettyTaggedValue v + | (k, v) <- Map.toList pairs + ] + +escapeText :: Text -> Text +escapeText = Text.concatMap escape + where + escape = \case + '\n' -> "\\n" + '\r' -> "\\r" + '\t' -> "\\t" + '"' -> "\\\"" + c -> Text.singleton c diff --git a/lib/Data/EDN/AST/Types.hs b/lib/Data/EDN/AST/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/AST/Types.hs @@ -0,0 +1,14 @@ +module Data.EDN.AST.Types + ( Parser + , module Data.EDN.AST.Types.Value + , module Data.EDN.AST.Types.Tagged + ) where + +import Data.Text (Text) +import Data.Void (Void) +import Text.Megaparsec (Parsec) + +import Data.EDN.AST.Types.Tagged +import Data.EDN.AST.Types.Value + +type Parser = Parsec Void Text diff --git a/lib/Data/EDN/AST/Types/Tagged.hs b/lib/Data/EDN/AST/Types/Tagged.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/AST/Types/Tagged.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} + +module Data.EDN.AST.Types.Tagged + ( Tagged(..) + , stripTag + ) where + +import Data.Data (Data) + +data Tagged tag a + = Tagged !tag !tag !a + | NoTag !a + deriving (Eq, Ord, Show, Data, Functor) + +stripTag :: Tagged tag a -> a +stripTag (NoTag value) = value +stripTag (Tagged _ns _tag value) = value diff --git a/lib/Data/EDN/AST/Types/Value.hs b/lib/Data/EDN/AST/Types/Value.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/AST/Types/Value.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.EDN.AST.Types.Value + ( TaggedValue + , Value(..) + , EDNList + , EDNVec + , EDNMap + , EDNSet + , mkList + , mkVec + , mkMap + , mkSet + ) where + +import Data.Data (Data) +import Data.Foldable (toList) +import Data.Text (Text) + +import qualified Data.Vector as V +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Data.EDN.AST.Types.Tagged (Tagged) + +type TaggedValue = Tagged Text Value + +data Value + = Nil + | Boolean !Bool + | String !Text + | Character !Char + | Symbol !Text !Text + | Keyword !Text + | Integer !Int + | Floating !Double + | List !EDNList + | Vec !EDNVec + | Map !EDNMap + | Set !EDNSet + deriving (Eq, Ord, Show, Data) + +type EDNList = [TaggedValue] +type EDNVec = V.Vector TaggedValue +type EDNMap = M.Map TaggedValue TaggedValue +type EDNSet = S.Set TaggedValue + +mkList :: Foldable f => f TaggedValue -> Value +mkList = List . toList + +mkVec :: Foldable f => f TaggedValue -> Value +mkVec = Vec . V.fromList . toList + +mkMap :: Foldable f => f (TaggedValue, TaggedValue) -> Value +mkMap = Map . M.fromList . toList + +mkSet :: Foldable f => f TaggedValue -> Value +mkSet = Set . S.fromList . toList diff --git a/lib/Data/EDN/Class.hs b/lib/Data/EDN/Class.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/Class.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Data.EDN.Class + ( ToEDN(..) + , toEDNtagged + , FromEDN(..) + , fromEDN + , withTagged + , withNoTag + , withNil + , withBoolean + , withString + , withCharacter + , withSymbol + , withKeyword + , withTextual + , withInteger + , withIntegral + , withFloating + , withFractional + , withList + , withVec + , withMap + , withSet + , unexpected + , DP.Expected + , DP.Label + , vecGet + , mapGetP + , mapGetKeyword + , mapGetString + , mapGetSymbol + , mapGetSymbolNS + ) where + +import Control.Applicative ((<|>)) +import Data.Map (Map) +import Data.Set (Set) +import Data.Vector (Vector) +import Data.Void (Void, absurd) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Time (UTCTime, defaultTimeLocale, formatTime, parseTimeM) +import Data.UUID (UUID) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import qualified Data.UUID as UUID +import qualified Data.Vector as Vector + +import Data.EDN.AST.Printer (renderText) + +import qualified Data.EDN.AST.Types as EDN +import qualified Data.EDN.Class.Parser as DP + +-- * Encoding + +-- | A type that can be converted to EDN AST. +class ToEDN a where + {-# MINIMAL toEDN | toEDNv #-} + + toEDN :: a -> EDN.TaggedValue + toEDN = EDN.NoTag . toEDNv + {-# INLINE toEDN #-} + + toEDNv :: a -> EDN.Value + toEDNv = EDN.stripTag . toEDN + {-# INLINE toEDNv #-} + +toEDNtagged :: ToEDN a => Text -> Text -> a -> EDN.TaggedValue +toEDNtagged tagNS tag = EDN.Tagged tagNS tag . toEDNv + +instance ToEDN EDN.TaggedValue where + toEDN = id + +instance ToEDN EDN.Value where + toEDNv = id + +instance ToEDN Void where + toEDNv = absurd + +instance ToEDN () where + toEDN () = EDN.NoTag EDN.Nil + +instance ToEDN Bool where + toEDNv = EDN.Boolean + +instance ToEDN Text where + toEDNv = EDN.String + +instance ToEDN LText.Text where + toEDNv = EDN.String . LText.toStrict + +instance ToEDN Char where + toEDNv = EDN.Character + +instance ToEDN Int where + toEDNv = EDN.Integer + +instance ToEDN Double where + toEDNv = EDN.Floating + +instance ToEDN a => ToEDN (Maybe a) where + toEDN Nothing = EDN.NoTag EDN.Nil + toEDN (Just a) = toEDN a + +instance ToEDN a => ToEDN [a] where + toEDNv = EDN.List . map toEDN + +instance ToEDN a => ToEDN (Vector a) where + toEDNv = EDN.Vec . fmap toEDN + +instance ToEDN a => ToEDN (Set a) where + toEDNv = EDN.Set . Set.fromList . map toEDN . Set.toList + +instance (ToEDN k, ToEDN v) => ToEDN (Map k v) where + toEDNv + = EDN.Map + . Map.fromList + . map (\(k, v) -> (toEDN k, toEDN v)) + . Map.toList + +instance (ToEDN a, ToEDN b) => ToEDN (a, b) where + toEDNv (a, b) = EDN.Vec $ Vector.fromList + [ toEDN a + , toEDN b + ] + +instance (ToEDN a, ToEDN b, ToEDN c) => ToEDN (a, b, c) where + toEDNv (a, b, c) = EDN.Vec $ Vector.fromList + [ toEDN a + , toEDN b + , toEDN c + ] + +instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d) => ToEDN (a, b, c, d) where + toEDNv (a, b, c, d) = EDN.Vec $ Vector.fromList + [ toEDN a + , toEDN b + , toEDN c + , toEDN d + ] + +instance ToEDN UTCTime where + toEDN + = toEDNtagged "" "inst" + . Text.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%EZ" + +instance ToEDN UUID where + toEDN = toEDNtagged "" "uuid" . UUID.toText + +-- * Decoding + +withTagged + :: Text + -> Text + -> (EDN.Value -> DP.Parser a) + -> EDN.TaggedValue + -> DP.Parser a +withTagged tagNS tag p tv = + case tv of + EDN.Tagged tagNS' tag' v + | tagNS' == tagNS && tag == tag' -> + p v + | otherwise -> + fail . Text.unpack $ mconcat + [ "unexpected tag. " + , "expecting: #" + , nsToText tagNS' tag' + , "; got: #" + , nsToText tagNS tag + ] + _ -> + fail "expected tagged value" + +withNoTag :: (EDN.Value -> DP.Parser a) -> EDN.TaggedValue -> DP.Parser a +withNoTag p tv = + case tv of + EDN.NoTag v -> + p v + EDN.Tagged tagNS tag _v -> + fail $ "no tag expected, got #" <> Text.unpack (nsToText tagNS tag) + +withNil :: DP.Parser a -> EDN.Value -> DP.Parser a +withNil p = \case + EDN.Nil -> + p + got -> + got `unexpected` "nil" + +withBoolean :: (Bool -> DP.Parser a) -> EDN.Value -> DP.Parser a +withBoolean p = \case + EDN.Boolean b -> + p b + got -> + got `unexpected` "boolean" + +withString :: (Text -> DP.Parser a) -> EDN.Value -> DP.Parser a +withString p = \case + EDN.String t -> + p t + got -> + got `unexpected` "string" + +withCharacter :: (Char -> DP.Parser a) -> EDN.Value -> DP.Parser a +withCharacter p = \case + EDN.Character c -> + p c + got -> + got `unexpected` "char" + +withSymbol :: (Text -> Text -> DP.Parser a) -> EDN.Value -> DP.Parser a +withSymbol p = \case + EDN.Symbol ns n -> + p ns n + got -> + got `unexpected` "symbol" + +withKeyword :: (Text -> DP.Parser a) -> EDN.Value -> DP.Parser a +withKeyword p = \case + EDN.Keyword t -> + p t + got -> + got `unexpected` "keyword" + +withTextual :: (Text -> DP.Parser a) -> EDN.Value -> DP.Parser a +withTextual p tv = + withString p tv <|> + withCharacter (p . Text.singleton) tv <|> + withKeyword p tv <|> + withSymbol (\ns n -> p $ nsToText ns n) tv + +withInteger :: (Int -> DP.Parser a) -> EDN.Value -> DP.Parser a +withInteger p = \case + EDN.Integer i -> + p i + got -> + got `unexpected` "integer" + +withIntegral :: Integral i => (i -> DP.Parser a) -> EDN.Value -> DP.Parser a +withIntegral p = \case + EDN.Integer i -> + p (fromIntegral i) + got -> + got `unexpected` "integer" + +withFloating :: (Double -> DP.Parser a) -> EDN.Value -> DP.Parser a +withFloating p = \case + EDN.Floating d -> + p d + got -> + got `unexpected` "double" + +withFractional :: Fractional f => (f -> DP.Parser a) -> EDN.Value -> DP.Parser a +withFractional p = \case + EDN.Floating d -> + p (realToFrac d) + got -> + got `unexpected` "double" + +withList :: (EDN.EDNList -> DP.Parser a) -> EDN.Value -> DP.Parser a +withList p = \case + EDN.List tvs -> + p tvs + got -> + got `unexpected` "list" + +withVec :: (EDN.EDNVec -> DP.Parser a) -> EDN.Value -> DP.Parser a +withVec p = \case + EDN.Vec v -> + p v + got -> + got `unexpected` "vector" + +withMap :: (EDN.EDNMap -> DP.Parser a) -> EDN.Value -> DP.Parser a +withMap p = \case + EDN.Map m -> + p m + got -> + got `unexpected` "map" + +withSet :: (EDN.EDNSet -> DP.Parser a) -> EDN.Value -> DP.Parser a +withSet p = \case + EDN.Set m -> + p m + got -> + got `unexpected` "set" + +-- | Report an decoding error due to unexpected AST node given. +-- The 'DP.Parser' combines and reports alternatives expected. +unexpected :: EDN.Value -> DP.Label -> DP.Parser a +unexpected value label = DP.Parser $ \kf _ks -> + kf (pure label) $ "Unexpected " <> label' + where + label' = case value of + EDN.Nil -> "nil" + EDN.Boolean{} -> "boolean" + EDN.String{} -> "string" + EDN.Character{} -> "character" + EDN.Symbol{} -> "symbol" + EDN.Keyword{} -> "keyword" + EDN.Integer{} -> "integer" + EDN.Floating{} -> "floating" + EDN.List{} -> "list" + EDN.Vec{} -> "vector" + EDN.Map{} -> "map" + EDN.Set{} -> "set" + +-- | A type that can be converted from EDN, with a possibility of failure. +-- +-- When writing an instance, use 'unexpected' or 'fail' to make a +-- conversion fail, e.g. if an 'Map.Map' is missing a required key, or +-- the value is of the wrong type. +class FromEDN a where + {-# MINIMAL parseEDN | parseEDNv #-} + + parseEDN :: EDN.TaggedValue -> DP.Parser a + parseEDN = parseEDNv . EDN.stripTag + {-# INLINE parseEDN #-} + + parseEDNv :: EDN.Value -> DP.Parser a + parseEDNv = parseEDN . EDN.NoTag + {-# INLINE parseEDNv #-} + +-- | Apply appropriate parsers for a value to decode AST. +fromEDN :: (FromEDN a, Monad m) => EDN.TaggedValue -> m a +fromEDN = DP.parseM parseEDN + +instance FromEDN EDN.TaggedValue where + parseEDN = pure + +instance FromEDN EDN.Value where + parseEDNv = pure + +instance FromEDN Void where + parseEDN = fail "absurd" + +instance FromEDN () where + parseEDNv = withNil $ pure () + +instance FromEDN Bool where + parseEDNv = withBoolean pure + +instance FromEDN Text where + parseEDNv = withTextual pure + +instance FromEDN LText.Text where + parseEDNv = withTextual (pure . LText.fromStrict) + +instance FromEDN Char where + parseEDNv = withCharacter pure + +instance FromEDN Int where + parseEDNv = withInteger pure + +instance FromEDN Double where + parseEDNv = withFloating pure + +instance FromEDN a => FromEDN (Maybe a) where + parseEDN = \case + EDN.NoTag EDN.Nil -> pure Nothing + EDN.Tagged _ _ EDN.Nil -> pure Nothing + tv -> Just <$> parseEDN tv + + parseEDNv = \case + EDN.Nil -> pure Nothing + v -> Just <$> parseEDNv v + +instance FromEDN a => FromEDN [a] where + parseEDNv = withList (traverse parseEDN) + +instance FromEDN a => FromEDN (Vector a) where + parseEDNv = withVec (traverse parseEDN) + +-- | Get ix-th element of 'EDN.EDNVec' or fail with appropriate message. +vecGet + :: FromEDN a + => Int -- ^ Element index + -> EDN.EDNVec -- ^ 'Vector.Vector' of EDN values + -> DP.Parser a +vecGet ix v = + case v Vector.!? ix of + Nothing -> + fail $ unwords + [ "expected vector with at least" + , show (succ ix) + , "elements" + ] + Just x -> + parseEDN x + +instance (FromEDN a, Ord a) => FromEDN (Set a) where + parseEDNv = withSet $ \s -> + Set.fromList <$> traverse parseEDN (Set.toList s) + +instance (FromEDN k, FromEDN v, Ord k) => FromEDN (Map k v) where + parseEDNv = withMap $ \m -> + Map.fromList <$> traverse parsePair (Map.toList m) + where + parsePair (k, v) = (,) <$> parseEDN k <*> parseEDN v + +-- | Get a value from 'EDN.EDNMap' and apply a parser to it +mapGetP + :: Monad m + => EDN.TaggedValue -- ^ Map key + -> (EDN.TaggedValue -> m a) -- ^ Parser to apply to a value + -> EDN.EDNMap -- ^ Map with EDN keys and values + -> m a +mapGetP key inner m = + case Map.lookup key m of + Just tv -> + inner tv + Nothing -> + fail . Text.unpack $ "key not found: " <> renderText key + +-- | Get a value from 'EDN.EDNMap' for a 'EDN.Keyword' key. +mapGetKeyword :: FromEDN a => Text -> EDN.EDNMap -> DP.Parser a +mapGetKeyword key = mapGetP (EDN.NoTag $ EDN.Keyword key) parseEDN + +-- | Get a value from 'EDN.EDNMap' for a 'EDN.String' key. +mapGetString :: FromEDN a => Text -> EDN.EDNMap -> DP.Parser a +mapGetString key = mapGetP (EDN.NoTag $ EDN.String key) parseEDN + +-- | Get a value from 'EDN.EDNMap' for a 'EDN.Symbol' (empty namespace) key. +mapGetSymbol :: FromEDN a => Text -> EDN.EDNMap -> DP.Parser a +mapGetSymbol = mapGetSymbolNS "" + +-- | Get a value from 'EDN.EDNMap' for a 'EDN.Symbol' (empty namespace) key. +mapGetSymbolNS + :: FromEDN a + => Text -- ^ Symbol namespace + -> Text -- ^ Symbol name + -> EDN.EDNMap + -> DP.Parser a +mapGetSymbolNS ns name = mapGetP (EDN.NoTag $ EDN.Symbol ns name) parseEDN + +instance (FromEDN a, FromEDN b) => FromEDN (a, b) where + parseEDNv = withVec $ \case + [a, b] -> + (,) <$> parseEDN a <*> parseEDN b + _ -> + fail "vector of size 2 expected" + +instance (FromEDN a, FromEDN b, FromEDN c) => FromEDN (a, b, c) where + parseEDNv = withVec $ \case + [a, b, c] -> + (,,) <$> parseEDN a <*> parseEDN b <*> parseEDN c + _ -> + fail "vector of size 3 expected" + +instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d) => FromEDN (a, b, c, d) where + parseEDNv = withVec $ \case + [a, b, c, d] -> + (,,,) <$> parseEDN a <*> parseEDN b <*> parseEDN c <*> parseEDN d + _ -> + fail "vector of size 3 expected" + +instance FromEDN UTCTime where + parseEDN tv = parseTaggedUTCTime tv <|> parseUntaggedUTCTime tv + where + parseTaggedUTCTime = + withTagged "" "inst" $ withString parseUTCTime + + parseUntaggedUTCTime = + withNoTag $ withString parseUTCTime + + parseUTCTime = + parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" . Text.unpack + +instance FromEDN UUID where + parseEDN tv = parseTaggedUUID tv <|> parseUntaggedUUID tv + where + parseTaggedUUID = withTagged "" "uuid" $ withString parseUUID + + parseUntaggedUUID = withNoTag $ withString parseUUID + + parseUUID t = + case UUID.fromText t of + Nothing -> + fail "invalid UUID string" + Just uuid -> + pure uuid + +nsToText + :: Text -- ^ Namespace + -> Text -- ^ Name + -> Text -- ^ Resulting text +nsToText "" n = n +nsToText ns n = ns <> "/" <> n diff --git a/lib/Data/EDN/Class/Parser.hs b/lib/Data/EDN/Class/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/Class/Parser.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} + +-- | Generic continuation-based parser + +module Data.EDN.Class.Parser + ( parseEither + , parseM + , Parser(..) + , Success + , Failure + , Expected + , Label + ) where + +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..)) +import Data.Semigroup (Semigroup(..)) + +import qualified Control.Monad.Fail as Fail +import qualified Data.List as List + +-- | Run a 'Parser' reporting to arbitrary 'Monad' with 'fail'. +parseM :: Monad m => (a -> Parser b) -> a -> m b +parseM p v = runParser (p v) (unexpected fail) pure + +-- | Run a 'Parser' reporting to an 'Either'. +parseEither :: (a -> Parser b) -> a -> Either String b +parseEither p v = runParser (p v) (unexpected Left) Right + +-- | Helper to convert expected labels to a failure value. +unexpected + :: (String -> a) -- ^ Smart-constructor for failure value + -> Expected -- ^ Accumulated expected labels + -> String -- ^ Failure message + -> a +unexpected failWith [] err = + failWith err +unexpected failWith es err = + failWith $ unlines + [ err + , "expected" + , " " <> List.intercalate ", " es + ] + +-- | A continuation-based parser type. +newtype Parser a = Parser + { runParser + :: forall f r. + Failure f r + -> Success a f r + -> f r + } + +-- | Megaparsec-style collection of elements expected by combined parser alternatives. +type Expected = [Label] + +-- | Single element expected by a parser. 'String' because 'Control.Monad.Fail.MonadFail' method. +type Label = String + +-- | Failure continuation. +type Failure f r = Expected -> String -> f r + +-- | Success continuation. +type Success a f r = a -> f r + +instance Functor Parser where + fmap f p = + Parser $ \kf ks -> + runParser p kf $ \a -> + ks (f a) + {-# INLINE fmap #-} + +instance Applicative Parser where + pure a = + Parser $ \_kf ks -> + ks a + {-# INLINE pure #-} + + d <*> e = + d >>= \b -> fmap b e + {-# INLINE (<*>) #-} + +instance Alternative Parser where + empty = + Parser $ \kf _ks -> + kf mempty "empty" + {-# INLINE empty #-} + + a <|> b = + Parser $ \kf ks -> + let + kf' expected _ = runParser b (kf . mappend expected) ks + in + runParser a kf' ks + {-# INLINE (<|>) #-} + +instance Fail.MonadFail Parser where + fail msg = + Parser $ \kf _ks -> + kf mempty msg + {-# INLINE fail #-} + +instance Monad Parser where + m >>= g = + Parser $ \kf ks -> + let + ks' a = runParser (g a) kf ks + in + runParser m kf ks' + {-# INLINE (>>=) #-} + + return = pure + {-# INLINE return #-} + + fail = Fail.fail + {-# INLINE fail #-} + +instance MonadPlus Parser where + mzero = fail "mzero" + {-# INLINE mzero #-} + + mplus a b = a <|> b + {-# INLINE mplus #-} + +instance Semigroup (Parser a) where + (<>) = mplus + +instance Monoid (Parser a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + + mappend = (<>) + {-# INLINE mappend #-} diff --git a/lib/Data/EDN/QQ.hs b/lib/Data/EDN/QQ.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/QQ.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- XXX: Lift instances. Don't want to pollute main module with TH shenanigans. +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.EDN.QQ + ( edn + , ednList + , ednMap + , ednVec + , ednSet + , fromEDN + ) where + +import Data.Data (Data) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Typeable (cast) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (Exp(..), Lift(..), Q, dataToExpQ, loc_filename, qLocation) + +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +import Data.EDN (FromEDN, parseText, decodeText) +import Data.EDN.AST.Types (Tagged(..), Value(..)) + +-- | Quasiquoter for 'Data.EDN.TaggedValue'. +-- +-- @ +-- Tagged "foo" "bar" Nil === [edn| #foo/bar nil |] +-- @ +edn :: QuasiQuoter +edn = ednQQ $ \str -> do + src <- fmap loc_filename qLocation + tv <- parseText src (Text.pack str) + lift tv + +-- | Quasiquoter for untagged 'Value' wrapped in a List. +-- +-- @ +-- [ednList| #foo/bar nil |] +-- === +-- List [ Tagged "foo" "bar" Nil ] +-- @ +ednList :: QuasiQuoter +ednList = ednQQ $ \str -> do + src <- fmap loc_filename qLocation + NoTag tv <- parseText src $ "(" <> Text.pack str <> ")" + lift tv + +-- | Quasiquoter for untagged 'Value' wrapped in a Vec. +-- +-- @ +-- [ednVec| #foo/bar nil |] +-- === +-- Vec [ Tagged "foo" "bar" Nil ] +-- @ +ednVec :: QuasiQuoter +ednVec = ednQQ $ \str -> do + src <- fmap loc_filename qLocation + NoTag tv <- parseText src $ "[" <> Text.pack str <> "]" + lift tv + +-- | Quasiquoter for untagged 'Value' wrapped in a Set. +-- +-- @ +-- [ednList| #foo/bar nil |] +-- === +-- List [ Tagged "foo" "bar" Nil ] +-- @ +ednSet :: QuasiQuoter +ednSet = ednQQ $ \str -> do + src <- fmap loc_filename qLocation + NoTag tv <- parseText src $ "#{" <> Text.pack str <> "}" + lift tv + +-- | Quasiquoter for untagged 'Value' wrapped in a Map. +-- +-- @ +-- [ednMap| :key value |] +-- === +-- Map [ (NoTag (Keyword "key"), NoTag (Symbol "" "value")) ] +-- @ +ednMap :: QuasiQuoter +ednMap = ednQQ $ \str -> do + src <- fmap loc_filename qLocation + NoTag tv <- parseText src $ "{" <> Text.pack str <> "}" + lift tv + +-- | Specializable QuasiQuoter for compile-time decoding. +-- +-- > ednPerson = fromEDN @Person +-- +-- And in another module (a TH restriction): +-- +-- > theFred = [ednPerson| #myapp/Person { :first "Fred" } |] +fromEDN :: forall a. (Lift a, FromEDN a) => QuasiQuoter +fromEDN = ednQQ $ \str -> do + src <- fmap loc_filename qLocation + val <- decodeText src (Text.pack str) :: Q a + lift val + +ednQQ :: (String -> Q Exp) -> QuasiQuoter +ednQQ qexp = QuasiQuoter + { quoteExp = qexp + , quotePat = error "EDN unavailable in patterns" + , quoteType = error "EDN unavailable in types" + , quoteDec = error "EDN unavailable in declarations" + } + +-- XXX: Workaround for Text.pack not present in the same module with Text constructors. +-- See https://stackoverflow.com/a/38182444 +liftData' :: Data a => a -> Q Exp +liftData' = dataToExpQ $ fmap liftText . cast + +liftText :: Text.Text -> Q Exp +liftText txt = AppE (VarE 'Text.pack) <$> lift (Text.unpack txt) + +-- XXX: Workaround for undefined toConstr in Data instance for Vector. +instance Data a => Lift (Tagged Text a) where + lift = \case + NoTag val -> do + val' <- liftData' val + pure $ ConE 'NoTag `AppE` val' + Tagged tagNS tag val -> do + tagNS' <- liftText tagNS + tag' <- liftText tag + val' <- liftData' val + pure $ ConE 'Tagged `AppE` tagNS' `AppE` tag' `AppE` val' + +instance Lift Value where + lift = \case + Vec items -> + AppE (ConE 'Vec) <$> liftVector items + val -> + liftData' val + +liftVector :: Lift a => Vector.Vector a -> Q Exp +liftVector vec = + AppE (VarE 'Vector.fromList) <$> lift (Vector.toList vec) diff --git a/src/Data/EDN.hs b/src/Data/EDN.hs deleted file mode 100644 --- a/src/Data/EDN.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Data.EDN ( - -- * Encoding and decoding - decode, encode, - - -- * Core EDN types - Value(..), TaggedValue, Tagged(..), - - -- * Type conversion - ToEDN, FromEDN, toEDN, fromEDN, fromEDNv, (.:), (.:?), (.!=), - - -- * Constructors - tag, notag, - - -- ** Basic values - nil, - bool, true, false, - char, string, - symbol, symbolNS, keyword, - integer, floating, - - -- ** Containers - makeList, makeVec, makeSet, makeMap, Pair, (.=), - - -- * Tag manipulation - setTag, getTag, stripTag, - - -- * Parsing - parseMaybe -) where - -import Data.EDN.Types -import Data.EDN.Types.Class (decode, FromEDN, ToEDN, toEDN, fromEDN, fromEDNv, (.:), (.:?), (.!=), (.=)) -import Data.EDN.Encode (encode) -import Data.EDN.Parser (parseMaybe) diff --git a/src/Data/EDN/Encode.hs b/src/Data/EDN/Encode.hs deleted file mode 100644 --- a/src/Data/EDN/Encode.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.EDN.Encode (fromValue, fromTagged, encode) where - -import Data.Monoid ((<>)) -import qualified Data.Text as T -import Data.Text.Lazy.Builder -import Data.Text.Lazy.Builder.Int (decimal) -import Data.Text.Lazy.Builder.RealFloat (realFloat) -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as L - -import qualified Data.Vector as V -import qualified Data.Map as M -import qualified Data.Set as S - -import qualified Data.EDN.Types as E -import Data.EDN.Types.Class (ToEDN, toEDN) - --- | Encode a Tagged EDN value to a 'Builder'. -fromTagged :: E.TaggedValue -> Builder -fromTagged (E.NoTag v) = fromValue v -fromTagged (E.Tagged v "" t) = singleton '#' <> string t <> singleton ' ' <> fromValue v -fromTagged (E.Tagged v ns t) = singleton '#' <> string ns <> singleton '/' <> string t <> singleton ' ' <> fromValue v - --- | Encode a raw EDN value to a 'Builder'. -fromValue :: E.Value -> Builder - -fromValue E.Nil = "nil" - -fromValue (E.Boolean b) = if b then "true" else "false" - -fromValue (E.String t) = singleton '"' <> quote t <> singleton '"' - -fromValue (E.Character c) = singleton '\\' <> quoteChar c - -fromValue (E.Symbol "" v) = string v -fromValue (E.Symbol ns v) = string ns <> singleton '/' <> string v - -fromValue (E.Keyword kw) = singleton ':' <> string kw - -fromValue (E.Integer i) = decimal i - -fromValue (E.Floating f) = realFloat f - -fromValue (E.List xs) = singleton '(' <> fromList xs <> singleton ')' - -fromValue (E.Vec xs) = singleton '[' <> fromList (V.toList xs) <> singleton ']' - -fromValue (E.Set xs) = "#{" <> fromList (S.toList xs) <> singleton '}' - -fromValue (E.Map as) = singleton '{' <> fromAssoc (M.assocs as) <> singleton '}' - -string :: BS.ByteString -> Builder -string s = fromLazyText . decodeUtf8 . L.fromChunks $ [s] - -quote :: T.Text -> Builder -quote q = case T.uncons t of - Nothing -> fromText h - Just (c, t') -> fromText h <> escape c <> quote t' - where - (h, t) = T.break isEscape q - isEscape c = c == '\"' || c == '\\' || c < '\x20' - escape '\"' = "\\\"" - escape '\\' = "\\\\" - escape '\n' = "\\n" - escape '\r' = "\\r" - escape '\t' = "\\t" - escape c = singleton c - -quoteChar :: Char -> Builder -quoteChar c = case c of - '\n' -> string "newline" - '\r' -> string "return" - '\t' -> string "tab" - ' ' -> string "space" - _ -> singleton c - -fromList :: [E.TaggedValue] -> Builder -fromList [] = "" -fromList [x] = fromTagged x -fromList (x:xs) = fromTagged x <> singleton ' ' <> fromList xs - -fromAssoc :: [(E.Value, E.TaggedValue)] -> Builder -fromAssoc [] = "" -fromAssoc [(k, v)] = fromValue k <> singleton ' ' <> fromTagged v -fromAssoc ((k, v):as) = fromValue k <> singleton ' ' <> fromTagged v <> singleton ' ' <> fromAssoc as - --- | Serialize a value as a lazy 'L.ByteString'. -encode :: ToEDN a => a -> L.ByteString -encode = encodeUtf8 . toLazyText . fromTagged . toEDN -{-# INLINE encode #-} diff --git a/src/Data/EDN/Parser.hs b/src/Data/EDN/Parser.hs deleted file mode 100644 --- a/src/Data/EDN/Parser.hs +++ /dev/null @@ -1,281 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Parse an UTF-8 encoded EDN string into a haskell representation of EDN objects. --- Use 'Data.EDN.decode' to get actual types. - -module Data.EDN.Parser ( - -- * Data parsers - parseMaybe, parseEither, parseBSL, parseBS, parseT, parseTL, parseS, - -- * Attoparsec implementation - parseValue, parseTagged -) where - -import Prelude () -import Prelude.Compat hiding (String, takeWhile) - -import Control.Applicative ((<|>)) -import Control.Monad (void) -import Data.Attoparsec.ByteString.Char8 as A -import Data.Attoparsec.Combinator () -import qualified Data.Attoparsec.Lazy as AL -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.ByteString.Search (replace) -import qualified Data.ByteString.UTF8 as UTF8 -import Data.Functor (($>)) -import Data.Maybe (fromJust) -import Data.Scientific as Sci -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE - -import Data.EDN.Types (Tagged (..), TaggedValue, - Value (..), makeMap, makeSet, - makeVec) -import qualified Prelude as P - -isSpaceOrComma :: Char -> Bool -isSpaceOrComma ' ' = True -isSpaceOrComma '\r' = True -isSpaceOrComma '\n' = True -isSpaceOrComma '\t' = True -isSpaceOrComma ',' = True -isSpaceOrComma _ = False - -spaceOrComma :: Parser Char -spaceOrComma = satisfy isSpaceOrComma "space/comma" - -skipSoC :: Parser () -skipSoC = skipWhile isSpaceOrComma - -parseNil :: Parser Value -parseNil = do - skipSoC - string "nil" $> Nil - -parseBool :: Parser Value -parseBool = do - skipSoC - choice [ string "true" *> pure (Boolean True) - , string "false" *> pure (Boolean False) - ] - -parseString :: Parser Value -parseString = do - skipSoC - void $ char '"' - - x <- A.scan False $ \s c -> if s - then Just False - else if c == '"' - then Nothing - else Just (c == '\\') - void $ char '"' - - let prepare = if '\\' `BS.elem` x - then rep "\\\"" "\"" - . rep "\\\\" "\\" - . rep "\\n" "\n" - . rep "\\r" "\r" - . rep "\\t" "\t" - else id - - return $! String $ TE.decodeUtf8 $ prepare x - - where - rep f t s = BS.concat . BSL.toChunks - $! replace (BS.pack f) (BS.pack t) s - -parseCharacter :: Parser Value -parseCharacter = do - skipSoC - char '\\' *> (simple <|> anyCharUtf8) - - where - simple :: Parser Value - simple = do - x <- string "newline" - <|> string "return" - <|> string "space" - <|> string "tab" - <|> string "\\" - - return . Character $! case x of - "newline" -> '\n' - "return" -> '\r' - "space" -> ' ' - "tab" -> '\t' - "\\" -> '\\' - _ -> error ("EDN.parseCharacter: impossible - simple" ++ show x) - - anyCharUtf8 :: Parser Value - anyCharUtf8 = do - bs <- scan BS.empty go - case UTF8.decode bs of - Just (c, _) -> return $! Character c - Nothing -> error $ "EDN.parseCharacter: bad utf8 data? " ++ show bs - - go :: BS.ByteString -> Char -> Maybe BS.ByteString - go s c - | BS.null s = Just (BS.singleton c) - | otherwise = case UTF8.decode s of - Nothing -> Just (s `BS.snoc` c) - Just (uc, _) -> if uc == UTF8.replacement_char - then Just (s `BS.snoc` c) - else Nothing - -parseSymbol :: Parser Value -parseSymbol = do - skipSoC - c <- satisfy (inClass "a-zA-Z.*/<>!?$%&=+_-") - (ns, val) <- withNS c <|> withoutNS c - return $! Symbol ns val - where - withNS c = do - ns <- takeWhile (inClass "a-zA-Z0-9#:.*<>!?$%&=+_-") - vc <- char '/' *> satisfy (inClass "a-zA-Z.*/<>!?$%&=+_-") - val <- takeWhile1 (inClass "a-zA-Z0-9#:.*<>!?$%&=+_-") - return (c `BS.cons` ns, vc `BS.cons` val) - - withoutNS c = do - val <- takeWhile (inClass "a-zA-Z0-9#:.*<>!?$%&=+_-") - return ("", c `BS.cons` val) - -parseKeyword :: Parser Value -parseKeyword = do - skipSoC - c <- char ':' *> satisfy (inClass "a-zA-Z.*/<>!?$%&=+_-") - x <- takeWhile (inClass "a-zA-Z0-9#:.*/<>!?$%&=+_-") - return $! Keyword (c `BS.cons` x) - -parseNumber :: Parser Value -parseNumber = do - skipSoC - n <- A.scientific - return $! - if Sci.isInteger n - then Integer (fromIntegral (fromJust (Sci.toBoundedInteger n) :: P.Int)) - else Floating (Sci.toRealFloat n) - - -parseColl :: Parser t1 -- opening bracket - -> Parser t2 -- closing bracket - -> Parser a -- item parser - -> ([a] -> Value) -- Value constructor - -> Parser Value -parseColl openingBr closingBr item construct = do - skipSoC - _ <- openingBr - A.skipSpace - vs <- item `sepBy` spaceOrComma - A.skipSpace - _<- closingBr - return $! construct vs - -parseList :: Parser Value -parseList = - parseColl (char '(') (char ')') parseTagged List - -parseVector :: Parser Value -parseVector = - parseColl (char '[') (char ']') parseTagged makeVec - -parseSet :: Parser Value -parseSet = - parseColl (char '#' *> char '{') (char '}') parseTagged makeSet - -parseMap :: Parser Value -parseMap = - parseColl (char '{') (char '}') parseAssoc makeMap - where - parseAssoc = do - key <- parseValue - val <- parseTagged - return (key, val) - - -skipComment :: Parser () -skipComment = skipSoC *> char ';' *> skipWhile (/= '\n') - -parseDiscard :: Parser () -parseDiscard = do - skipSoC - void $ string "#_" - void parseValue - --- | Parse a \"raw\" EDN value into a 'Value'. -parseValue :: Parser Value -parseValue = do - skipSoC - skipMany skipComment - skipMany parseDiscard - - parseSet <|> parseMap - <|> parseVector <|> parseList - <|> parseNil <|> parseBool - <|> parseNumber - <|> parseKeyword <|> parseSymbol - <|> parseCharacter - <|> parseString - --- | Parse a probably tagged EDN value into a 'TaggedValue'. -parseTagged :: Parser TaggedValue -parseTagged = do - skipSoC - withNS <|> withoutNS <|> noTag - where - withNS = do - ns <- char '#' *> parseIdent - tag <- char '/' *> parseIdent - value <- parseValue - return $! Tagged value ns tag - - withoutNS = do - tag <- char '#' *> parseIdent - value <- parseValue - return $! Tagged value "" tag - - parseIdent = takeWhile1 (inClass "a-zA-Z0-9-") - - noTag = do - value <- parseValue - return $! NoTag value - -{- | Parse a lazy 'BSL.ByteString' into a 'TaggedValue'. -If fails due to incomplete or invalid input, 'Nothing' is returned. --} -parseMaybe :: BSL.ByteString -> Maybe TaggedValue -parseMaybe = AL.maybeResult . parseBSL - -{- | Parse a lazy 'BSL.ByteString' into a 'TaggedValue'. -If fails due to incomplete or invalid input, -'Left' is returned with the error message. --} -parseEither :: BSL.ByteString -> Either P.String TaggedValue -parseEither = AL.eitherResult . parseBSL - --- | Parse a lazy 'BSL.ByteString'. -parseBSL :: BSL.ByteString -> AL.Result TaggedValue -parseBSL = AL.parse parseTagged -{-# INLINE parseBSL #-} - --- | Parse a strict 'BS.ByteString', but without continutations. -parseBS :: BS.ByteString -> AL.Result TaggedValue -parseBS s = parseBSL . BSL.fromChunks $ [s] -{-# INLINE parseBS #-} - --- | Parse a lazy 'TL.Text'. -parseTL :: TL.Text -> AL.Result TaggedValue -parseTL = parseBSL . TLE.encodeUtf8 -{-# INLINE parseTL #-} - --- | Parse a strict 'T.Text'. -parseT :: T.Text -> AL.Result TaggedValue -parseT = parseBS . TE.encodeUtf8 -{-# INLINE parseT #-} - --- | Parse a string AKA '[Char]'. Not really useful other than for debugging purposes. -parseS :: P.String -> AL.Result TaggedValue -parseS = parseBSL . BSL.pack -{-# INLINE parseS #-} diff --git a/src/Data/EDN/Types.hs b/src/Data/EDN/Types.hs deleted file mode 100644 --- a/src/Data/EDN/Types.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Data.EDN.Types ( - -- * Types - Value(..), Tagged(..), TaggedValue, - - -- ** Internal containers - EDNList, EDNVec, EDNSet, EDNMap, Pair, - - -- * Tag manipulation - setTag, getTag, stripTag, - - -- * Constructors - tag, notag, - - -- ** Trivial values - nil, - bool, true, false, - char, string, - symbol, symbolNS, keyword, - integer, floating, - - -- ** Containers - makeList, makeVec, makeSet, makeMap -) where - -import Data.String (IsString(..)) -import Control.DeepSeq (NFData(..)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.Vector as V -import qualified Data.Map as M -import qualified Data.Set as S - --- | Abstract namespaced tag. -data Tagged a = NoTag !a - | Tagged !a !ByteString !ByteString - deriving (Eq, Ord, Show) - -instance Functor Tagged where - fmap f (NoTag v) = NoTag (f v) - fmap f (Tagged v ns t) = Tagged (f v) ns t - -instance NFData a => NFData (Tagged a) where - rnf (NoTag v) = rnf v - rnf (Tagged v ns t) = rnf v `seq` rnf ns `seq` rnf t - -type TaggedValue = Tagged Value - -type EDNList = [TaggedValue] -- ^ An EDN list (head:tail container). -type EDNVec = V.Vector TaggedValue -- ^ An EDN vector (position-indexed container) of EDN values. -type EDNMap = M.Map Value TaggedValue -- ^ An EDN map (key/value container). Keys are untagged and values are tagged. -type EDNSet = S.Set TaggedValue -- ^ An EDN set (unordered container of unique values). - --- | A \"raw\" EDN value represented as a Haskell value. -data Value = Nil - | Boolean !Bool - | String !Text - | Character !Char - | Symbol !ByteString !ByteString - | Keyword !ByteString - | Integer !Integer - | Floating !Double - | List EDNList - | Vec !EDNVec - | Map !EDNMap - | Set !EDNSet - deriving (Eq, Ord, Show) - --- | Strings starting with \":\" will become keywords. -instance IsString Value where - fromString (':':s) = Keyword . BS.pack $ s - fromString s = String . T.pack $ s - {-# INLINE fromString #-} - --- | Strings will become an tagless EDN strings. -instance IsString (Tagged Value) where - fromString = string . T.pack - {-# INLINE fromString #-} - -instance NFData Value where - rnf (Map m) = rnf m - rnf (Set s) = rnf s - rnf (Vec v) = V.foldl' (\x y -> rnf y `seq` x) () v - rnf (List l) = rnf l - rnf (Floating f) = rnf f - rnf (Integer i) = rnf i - rnf (Symbol ns s) = rnf ns `seq` rnf s - rnf (Keyword kw) = rnf kw - rnf (String t) = rnf t - rnf (Character c) = rnf c - rnf (Boolean b) = rnf b - rnf Nil = () - --- | Basic EDN nil. -nil :: TaggedValue -nil = NoTag Nil -{-# INLINE nil #-} - --- | Basic EDN boolean. -bool :: Bool -> TaggedValue -bool = NoTag . Boolean -{-# INLINE bool #-} - --- | Const EDN True. -true :: TaggedValue -true = bool True -{-# INLINE true #-} - --- | Const EDN False. -false :: TaggedValue -false = bool False -{-# INLINE false #-} - --- | Basic EDN character. -char :: Char -> TaggedValue -char = NoTag . Character -{-# INLINE char #-} - --- | Basic EDN string. -string :: Text -> TaggedValue -string = NoTag . String -{-# INLINE string #-} - --- | A namespaced symbol. -symbolNS :: ByteString -> ByteString -> TaggedValue -symbolNS ns value = NoTag $ Symbol ns value -{-# INLINE symbolNS #-} - --- | \"Bare\" symbol. -symbol :: ByteString -> TaggedValue -symbol = symbolNS BS.empty -{-# INLINE symbol #-} - --- | Basic EDN keyword. -keyword :: ByteString -> TaggedValue -keyword = NoTag . Keyword -{-# INLINE keyword #-} - --- | Basic EDN integer. -integer :: Integer -> TaggedValue -integer = NoTag . Integer -{-# INLINE integer #-} - --- | Basic EDN fp number. -floating :: Double -> TaggedValue -floating = NoTag . Floating -{-# INLINE floating #-} - --- | 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 :: a -> Tagged a -notag = NoTag -{-# INLINE notag #-} - --- | 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 #-} - --- | Extract namespace and tag from a tagged container. Will be a pair of 'BS.empty' for tagless containers. -getTag :: TaggedValue -> (ByteString, ByteString) -getTag (NoTag _) = (BS.empty, BS.empty) -getTag (Tagged _ ns t) = (ns, t) - --- | Extract bare value from a tagged or tagless container. -stripTag :: Tagged a -> a -stripTag (NoTag v) = v -stripTag (Tagged v _ _) = v -{-# INLINE stripTag #-} - --- | Create an EDN 'List' from a 'Value' list wrapping them into empty tags. -makeList :: [TaggedValue] -> Value -makeList = List -{-# INLINE makeList #-} - --- | Create an EDN 'Vector' from a 'TaggedValue' list. -makeVec :: [TaggedValue] -> Value -makeVec = Vec . V.fromList -{-# INLINE makeVec #-} - --- | Create an EDN 'Set' from a 'TaggedValue' list. -makeSet :: [TaggedValue] -> Value -makeSet = Set . S.fromList -{-# INLINE makeSet #-} - --- | A key\/value pair for a EDN Map -type Pair = (Value, TaggedValue) - --- | Create an EDN 'Map' from a assoc list with untagged keys and tagged values. -makeMap :: [Pair] -> Value -makeMap = Map . M.fromList -{-# INLINE makeMap #-} diff --git a/src/Data/EDN/Types/Class.hs b/src/Data/EDN/Types/Class.hs deleted file mode 100644 --- a/src/Data/EDN/Types/Class.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE OverloadedStrings #-} -module Data.EDN.Types.Class ( - -- * Type conversion - ToEDN(..), FromEDN(..), fromEDN, fromEDNv, - - -- * EDN value decoding - decode, eitherDecode, DP.parse, DP.parseEither, DP.parseMaybe, DP.Parser, DP.Result(..), - - -- * Convenience functions - (.=), (.:), (.:?), (.!=), typeMismatch -) where - -import Prelude () -import Prelude.Compat - -import Control.Monad (liftM2) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Monoid (First (..)) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Data.Time.Clock (UTCTime) -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format (formatTime, parseTimeM) -#else -import Data.Time.Format (formatTime, parseTime) -#endif -import Data.Time.Locale.Compat (defaultTimeLocale) -import qualified Data.Vector as V - -import qualified Data.EDN.Parser as P -import qualified Data.EDN.Types as E -import Data.Parser (Parser, Result) -import qualified Data.Parser as DP - --- | A type that can be converted to JSON. -class ToEDN a where - {-# MINIMAL toEDN | toEDNv #-} - - toEDN :: a -> E.TaggedValue - toEDN = E.notag . toEDNv - {-# INLINE toEDN #-} - - toEDNv :: a -> E.Value - toEDNv = E.stripTag . toEDN - {-# INLINE toEDNv #-} - --- | A type that can be converted from EDN, with a possibility of failure. --- --- When writing an instance, use 'empty', 'mzero', or 'fail' to make a --- conversion fail, e.g. if an 'M.Map' is missing a required key, or --- the value is of the wrong type. -class FromEDN a where - {-# MINIMAL parseEDN | parseEDNv #-} - - parseEDN :: E.TaggedValue -> Parser a - parseEDN = parseEDNv . E.stripTag - {-# INLINE parseEDN #-} - - parseEDNv :: E.Value -> Parser a - parseEDNv = parseEDN . E.notag - {-# INLINE parseEDNv #-} - -instance (ToEDN a) => ToEDN (Maybe a) where - toEDN (Just a) = toEDN a - toEDN Nothing = E.nil - {-# INLINE toEDN #-} - -instance (FromEDN a) => (FromEDN (Maybe a)) where - parseEDN (E.NoTag E.Nil) = pure Nothing - parseEDN a = Just <$> parseEDN a - {-# INLINE parseEDN #-} - -instance (ToEDN a, ToEDN b) => ToEDN (Either a b) where - toEDN (Left a) = E.tag "either" "left" $ toEDNv a - toEDN (Right b) = E.tag "either" "right" $ toEDNv b - {-# INLINE toEDN #-} - -instance (FromEDN a, FromEDN b) => FromEDN (Either a b) where - parseEDN (E.Tagged v "either" "left") = Left <$> parseEDNv v - parseEDN (E.Tagged v "either" "right") = Right <$> parseEDNv v - parseEDN E.Tagged{} = fail "incorrect tag" - 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 #-} - -instance FromEDN Bool where - parseEDNv (E.Boolean b) = pure b - parseEDNv v = typeMismatch "Boolean" v - {-# INLINE parseEDNv #-} - -instance ToEDN () where - toEDNv _ = E.List [] - {-# INLINE toEDNv #-} - -instance FromEDN () where - parseEDNv (E.List l) | null l = pure () - parseEDNv v = typeMismatch "()" v - {-# INLINE parseEDNv #-} - -instance ToEDN [Char] where - toEDNv = E.String . T.pack - {-# INLINE toEDNv #-} - -instance FromEDN [Char] where - parseEDNv (E.String t) = pure $ T.unpack t - parseEDNv (E.Symbol "" s) = pure $ BS.unpack s - parseEDNv (E.Symbol ns s) = pure . BS.unpack $ BS.concat [ns, "/", s] - parseEDNv (E.Keyword k) = pure . BS.unpack $ BS.cons ':' k - parseEDNv v = typeMismatch "String/Symbol/Keyword" v - {-# INLINE parseEDNv #-} - -instance ToEDN T.Text where - toEDNv = E.String - {-# INLINE toEDNv #-} - -instance FromEDN T.Text where - parseEDNv (E.String t) = pure t - parseEDNv v = typeMismatch "String" v - {-# INLINE parseEDNv #-} - -instance ToEDN TL.Text where - toEDNv = E.String . TL.toStrict - {-# INLINE toEDNv #-} - -instance FromEDN TL.Text where - parseEDNv (E.String t) = pure $ TL.fromStrict t - parseEDNv v = typeMismatch "String" v - {-# INLINE parseEDNv #-} - -instance ToEDN BS.ByteString where - toEDNv = E.String . TE.decodeUtf8 - {-# INLINE toEDNv #-} - -instance FromEDN BS.ByteString where - parseEDNv (E.String t) = pure $ TE.encodeUtf8 t - parseEDNv v = typeMismatch "String" v - {-# INLINE parseEDNv #-} - -instance ToEDN BSL.ByteString where - toEDNv = E.String . TL.toStrict . TLE.decodeUtf8 - {-# INLINE toEDNv #-} - -instance FromEDN BSL.ByteString where - parseEDNv (E.String t) = pure . TLE.encodeUtf8 . TL.fromStrict $ t - parseEDNv v = typeMismatch "String" v - {-# INLINE parseEDNv #-} - -instance ToEDN Char where - toEDNv = E.Character - {-# INLINE toEDNv #-} - -instance FromEDN Char where - parseEDNv (E.Character c) = pure c - parseEDNv v = typeMismatch "Character" v - {-# INLINE parseEDNv #-} - -instance ToEDN Double where - toEDNv = E.Floating - {-# INLINE toEDNv #-} - -instance FromEDN Double where - parseEDNv (E.Floating d) = pure d - parseEDNv v = typeMismatch "Floating" v - {-# INLINE parseEDNv #-} - -instance ToEDN Integer where - toEDNv = E.Integer - {-# INLINE toEDNv #-} - -instance FromEDN Integer where - parseEDNv (E.Integer i) = pure i - parseEDNv v = typeMismatch "Integer" v - {-# INLINE parseEDNv #-} - -instance ToEDN Int where - toEDNv = E.Integer . fromIntegral - {-# INLINE toEDNv #-} - -instance FromEDN Int where - parseEDNv (E.Integer i) = return (fromIntegral i) - parseEDNv v = typeMismatch "Int" v - - -showRFC3339 :: UTCTime -> String -showRFC3339 time = - concat [fm "%FT%T." time - , take 3 $ fm "%-q" time - , "+00:00"] - where - fm = formatTime defaultTimeLocale - -instance ToEDN UTCTime where - toEDN time = E.Tagged (E.String . T.pack $ showRFC3339 time) - "" - "inst" - {-# INLINE toEDN #-} - -instance FromEDN UTCTime where - parseEDN val@(E.Tagged (E.String ts) "" "inst") = do - let result = getFirst . mconcat $ map (First . parseTime') validRFC3339 - case result of - Just time -> return time - Nothing -> typeMismatch "UTCTime" $ E.stripTag val - where - tsStr = T.unpack ts -#if MIN_VERSION_time(1,5,0) - parseTime' fmt = parseTimeM True defaultTimeLocale fmt tsStr -#else - parseTime' fmt = parseTime defaultTimeLocale fmt tsStr -#endif - validRFC3339 = [ "%FT%T%Q%z" - , "%FT%T%QZ" - , "%FT%T%z" - , "%FT%TZ" ] - parseEDN v = typeMismatch "UTCTime" $ E.stripTag v - {-# INLINE parseEDN #-} - - -instance ToEDN a => ToEDN [a] where - toEDNv = E.List . map toEDN - {-# INLINE toEDNv #-} - -instance FromEDN a => FromEDN [a] where - parseEDNv (E.Vec vs) = V.toList <$> V.mapM parseEDN vs - parseEDNv (E.List vs) = mapM parseEDN vs - parseEDNv v = typeMismatch "List" v - {-# INLINE parseEDNv #-} - -instance ToEDN a => ToEDN (V.Vector a) where - toEDNv = E.Vec . V.map toEDN - {-# INLINE toEDNv #-} - -instance FromEDN a => FromEDN (V.Vector a) where - parseEDNv (E.Vec as) = V.mapM parseEDN as - parseEDNv v = typeMismatch "Vec" v - {-# INLINE parseEDNv #-} - -instance (Ord a, ToEDN a) => ToEDN (S.Set a) where - toEDNv = E.Set . S.map toEDN - {-# INLINE toEDNv #-} - -instance (Ord a, FromEDN a) => FromEDN (S.Set a) where - parseEDNv (E.Set s) = mapMset parseEDN s - parseEDNv v = typeMismatch "Set" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b) => ToEDN (M.Map a b) where - toEDNv m = E.Map $! M.fromList [(toEDNv k, toEDN v) | (k, v) <- M.assocs m] - {-# INLINE toEDNv #-} - -instance (Ord a, FromEDN a, FromEDN b) => FromEDN (M.Map a b) where - parseEDNv (E.Map m) = mapMmap parseEDNv parseEDN m - parseEDNv v = typeMismatch "Map" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b) => ToEDN (a, b) where - toEDNv (a, b) = E.Vec $! V.fromList [toEDN a, toEDN b] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b) => FromEDN (a, b) where - parseEDNv v@(E.Vec vec) - | V.length vec == 2 = (,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - | otherwise = typeMismatch "(a, b)" v - parseEDNv v = typeMismatch "(a, b)" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b, ToEDN c) => ToEDN (a, b, c) where - toEDNv (a, b, c) = E.Vec $! V.fromList [toEDN a, toEDN b, toEDN c] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b, FromEDN c) => FromEDN (a, b, c) where - parseEDNv v@(E.Vec vec) - | V.length vec == 3 = (,,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - <*> parseEDN (vec V.! 2) - | otherwise = typeMismatch "(a, b, c)" v - parseEDNv v = typeMismatch "(a, b, c)" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d) => ToEDN (a, b, c, d) where - toEDNv (a, b, c, d) = E.Vec $! V.fromList [toEDN a, toEDN b, toEDN c, toEDN d] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d) => FromEDN (a, b, c, d) where - parseEDNv v@(E.Vec vec) - | V.length vec == 4 = (,,,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - <*> parseEDN (vec V.! 2) - <*> parseEDN (vec V.! 3) - | otherwise = typeMismatch "(a, b, c, d)" v - parseEDNv v = typeMismatch "(a, b, c, d)" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e) => ToEDN (a, b, c, d, e) where - toEDNv (a, b, c, d, e) = E.Vec $! V.fromList [ - toEDN a - , toEDN b - , toEDN c - , toEDN d - , toEDN e ] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, FromEDN e) - => FromEDN (a, b, c, d, e) where - parseEDNv v@(E.Vec vec) - | V.length vec == 5 = (,,,,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - <*> parseEDN (vec V.! 2) - <*> parseEDN (vec V.! 3) - <*> parseEDN (vec V.! 4) - | otherwise = typeMismatch "(a, b, c, d, e)" v - parseEDNv v = typeMismatch "(a, b, c, d, e)" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e, ToEDN f) - => ToEDN (a, b, c, d, e, f) where - toEDNv (a, b, c, d, e, f) = E.Vec $! V.fromList [ - toEDN a - , toEDN b - , toEDN c - , toEDN d - , toEDN e - , toEDN f] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, FromEDN e, FromEDN f) - => FromEDN (a, b, c, d, e, f) where - parseEDNv v@(E.Vec vec) - | V.length vec == 6 = (,,,,,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - <*> parseEDN (vec V.! 2) - <*> parseEDN (vec V.! 3) - <*> parseEDN (vec V.! 4) - <*> parseEDN (vec V.! 5) - | otherwise = typeMismatch "(a, b, c, d, e, f)" v - parseEDNv v = typeMismatch "(a, b, c, d, e, f)" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e, ToEDN f, ToEDN g) - => ToEDN (a, b, c, d, e, f, g) where - toEDNv (a, b, c, d, e, f, g) = - E.Vec $! V.fromList [ toEDN a - , toEDN b - , toEDN c - , toEDN d - , toEDN e - , toEDN f - , toEDN g] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, FromEDN e, FromEDN f, FromEDN g) - => FromEDN (a, b, c, d, e, f, g) where - parseEDNv v@(E.Vec vec) - | V.length vec == 7 = (,,,,,,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - <*> parseEDN (vec V.! 2) - <*> parseEDN (vec V.! 3) - <*> parseEDN (vec V.! 4) - <*> parseEDN (vec V.! 5) - <*> parseEDN (vec V.! 6) - | otherwise = typeMismatch "(a, b, c, d, e, f, g)" v - parseEDNv v = typeMismatch "(a, b, c, d, e, f, g)" v - {-# INLINE parseEDNv #-} - -instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e, ToEDN f, ToEDN g, ToEDN h) - => ToEDN (a, b, c, d, e, f, g, h) where - toEDNv (a, b, c, d, e, f, g, h) = - E.Vec $! V.fromList [ toEDN a - , toEDN b - , toEDN c - , toEDN d - , toEDN e - , toEDN f - , toEDN g - , toEDN h] - {-# INLINE toEDNv #-} - -instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, - FromEDN e, FromEDN f, FromEDN g, FromEDN h) - => FromEDN (a, b, c, d, e, f, g, h) where - parseEDNv v@(E.Vec vec) - | V.length vec == 8 = (,,,,,,,) <$> parseEDN (vec V.! 0) - <*> parseEDN (vec V.! 1) - <*> parseEDN (vec V.! 2) - <*> parseEDN (vec V.! 3) - <*> parseEDN (vec V.! 4) - <*> parseEDN (vec V.! 5) - <*> parseEDN (vec V.! 6) - <*> parseEDN (vec V.! 7) - | otherwise = typeMismatch "(a, b, c, d, e, f, g, h)" v - parseEDNv v = typeMismatch "(a, b, c, d, e, f, g, h)" v - {-# INLINE parseEDNv #-} - - -instance ToEDN E.Value where - toEDNv = id - -instance FromEDN E.Value where - parseEDNv = pure - -instance ToEDN E.TaggedValue where - toEDN = id - -instance FromEDN E.TaggedValue where - parseEDN = pure - --- | Convert a value from 'E.TaggedValue', failing if the types do not match. -fromEDN :: FromEDN a => E.TaggedValue -> Result a -fromEDN = DP.parse parseEDN -{-# INLINE fromEDN #-} - --- | Convert a value from 'E.Value', failing if the types do not match. -fromEDNv :: FromEDN a => E.Value -> Result a -fromEDNv = DP.parse parseEDNv -{-# INLINE fromEDNv #-} - --- | Deserializes a EDN value from a lazy 'BSL.ByteString'. --- If this fails to to incomplete or invalid input, 'Nothing' is returned. -decode :: FromEDN a => BSL.ByteString -> Maybe a -decode s = case P.parseMaybe s of - Just tv -> DP.parseMaybe parseEDN tv - Nothing -> Nothing - --- | Deserializes a EDN value from a lazy 'BSL.ByteString'. --- If this fails to to incomplete or invalid input, 'Left' is returned --- with an error message. -eitherDecode :: FromEDN a => BSL.ByteString -> Either String a -eitherDecode s = case P.parseEither s of - Right tv -> DP.parseEither parseEDN tv - Left e -> Left e - --- | Construct a 'Pair' from a key (as EDN keyword) and a value. -(.=) :: ToEDN a => BS.ByteString -> a -> E.Pair -name .= value = (E.Keyword name, toEDN value) -{-# INLINE (.=) #-} - --- | 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 -> 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 -> Parser (Maybe a) -emap .:? key = case M.lookup (toEDNv key) emap of - Nothing -> pure Nothing - Just v -> parseEDN v -{-# INLINE (.:?) #-} - --- | Helper for use in combination with '.:?' to provide default --- values for optional JSON object fields. --- --- This combinator is most useful if the key and value can be absent --- from an object without affecting its validity and we know a default --- value to assign in that case. If the key and value are mandatory, --- use '(.:)' instead. --- --- Example usage: --- --- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\" --- v2 <- o '.:' \"mandatory_field\" --- v3 <- o '.:?' \"opt_field2\" --- @ -(.!=) :: Parser (Maybe a) -> a -> Parser a -pmval .!= val = fromMaybe val <$> pmval -{-# 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. - -> Parser a -typeMismatch expected actual = - fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++ - " instead" - where - name = case actual of - E.Nil -> "Nil" - E.Boolean _ -> "Boolean" - E.String _ -> "String" - E.Character _ -> "Character" - E.Symbol _ _ -> "Symbol" - E.Keyword _ -> "Keyword" - E.Integer _ -> "Integer" - E.Floating _ -> "Floating" - E.List _ -> "List" - E.Vec _ -> "Vec" - E.Map _ -> "Map" - E.Set _ -> "Set" - -mapMset :: (Applicative m, Monad m, Ord b) - => (a -> m b) - -> S.Set a - -> m (S.Set b) -mapMset f s = S.fromList <$> traverse f (S.toList s) -{-# 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 = fmap M.fromList . mapM (\(k, v) -> liftM2 (,) (kf k) (vf v)) . M.assocs -{-# INLINE mapMmap #-} diff --git a/src/Data/Parser.hs b/src/Data/Parser.hs deleted file mode 100644 --- a/src/Data/Parser.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE Rank2Types, DeriveDataTypeable #-} - --- | Generic continuation-based parser type. - -module Data.Parser ( - Parser, Result(..), - parse, parseMaybe, parseEither -) where - -import Prelude () -import Prelude.Compat - -import Control.Applicative -import Control.DeepSeq (NFData(..)) -import Control.Monad.State.Strict -import Data.Semigroup (Semigroup, (<>)) -import Data.Typeable (Typeable) - --- | The result of running a 'Parser'. -data Result a = Error String - | Success a - deriving (Eq, Show, Typeable) - -instance (NFData a) => NFData (Result a) where - rnf (Success a) = rnf a - rnf (Error err) = rnf err - -instance Functor Result where - fmap f (Success a) = Success (f a) - fmap _ (Error err) = Error err - {-# INLINE fmap #-} - -instance Monad Result where - return = Success - {-# INLINE return #-} - Success a >>= k = k a - Error err >>= _ = Error err - {-# INLINE (>>=) #-} - -instance Applicative Result where - pure = return - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} - -instance MonadPlus Result where - mzero = fail "mzero" - {-# INLINE mzero #-} - mplus a@(Success _) _ = a - mplus _ b = b - {-# INLINE mplus #-} - -instance Alternative Result where - empty = mzero - {-# INLINE empty #-} - (<|>) = mplus - {-# INLINE (<|>) #-} - -instance Semigroup (Result a) where - (<>) = mplus - -instance Monoid (Result a) where - mempty = fail "mempty" - {-# INLINE mempty #-} - mappend = (<>) - {-# INLINE mappend #-} - --- | Failure continuation. -type Failure f r = String -> f r --- | Success continuation. -type Success a f r = a -> f r - --- | A continuation-based parser type. -newtype Parser a = Parser { - runParser :: forall f r. - Failure f r - -> Success a f r - -> f r - } - -instance Monad Parser where - m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks - in runParser m kf ks' - {-# INLINE (>>=) #-} - return a = Parser $ \_kf ks -> ks a - {-# INLINE return #-} - fail msg = Parser $ \kf _ks -> kf msg - {-# INLINE fail #-} - -instance Functor Parser where - fmap f m = Parser $ \kf ks -> let ks' a = ks (f a) - in runParser m kf ks' - {-# INLINE fmap #-} - -instance Applicative Parser where - pure = return - {-# INLINE pure #-} - (<*>) = apP - {-# INLINE (<*>) #-} - -instance Alternative Parser where - empty = fail "empty" - {-# INLINE empty #-} - (<|>) = mplus - {-# INLINE (<|>) #-} - -instance MonadPlus Parser where - mzero = fail "mzero" - {-# INLINE mzero #-} - mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks - in runParser a kf' ks - {-# INLINE mplus #-} - -instance Semigroup (Parser a) where - (<>) = mplus - -instance Monoid (Parser a) where - mempty = fail "mempty" - {-# INLINE mempty #-} - mappend = (<>) - {-# INLINE mappend #-} - -apP :: Parser (a -> b) -> Parser a -> Parser b -apP d e = do - b <- d - b <$> e -{-# INLINE apP #-} - --- | Run a 'Parser'. -parse :: (a -> Parser b) -> a -> Result b -parse m v = runParser (m v) Error Success - --- | Run a 'Parser' with a 'Maybe' result type. -parseMaybe :: (a -> Parser b) -> a -> Maybe b -parseMaybe m v = runParser (m v) (const Nothing) Just - --- | Run a 'Parser' with an 'Either' result type. -parseEither :: (a -> Parser b) -> a -> Either String b -parseEither m v = runParser (m v) Left Right diff --git a/tests/Data/EDN/AST/Gen.hs b/tests/Data/EDN/AST/Gen.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/AST/Gen.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.EDN.AST.Gen + ( module Data.EDN.AST.Gen + ) where + +import Data.Text (Text) +import Data.Function (on) +import Data.List (nubBy) +import Hedgehog (Gen) + +import qualified Data.Text as Text +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import qualified Data.EDN.AST.Types as EDN +import qualified Data.EDN.AST.Parser as EDN + +genTaggedValue :: Gen EDN.TaggedValue +genTaggedValue = genTagged genValue + +genTagged :: Gen a -> Gen (EDN.Tagged Text a) +genTagged gen = Gen.choice + [ withoutTag + , withNS + , withoutNS + ] + where + withNS = EDN.Tagged + <$> genTagIdent + <*> genTagIdent + <*> gen + + -- XXX: the spec says only some raw names are valid + withoutNS = EDN.Tagged + <$> pure "" + <*> genTagIdent + <*> gen + + withoutTag = EDN.NoTag <$> gen + +genTagIdent :: Gen Text +genTagIdent = genText EDN.tagChars + +genValue :: Gen EDN.Value +genValue = Gen.recursive Gen.choice atomic collections + +atomic :: [Gen EDN.Value] +atomic = + [ genNil + , genBool + , genString + , genChar + , genInteger + , genFloating + , genKeyword + , genSymbol + ] + +collections :: [Gen EDN.Value] +collections = + [ genSet + , genMap + , genVector + , genList + ] + +genBool :: Gen EDN.Value +genBool = EDN.Boolean + <$> Gen.element [True, False] + +genNil :: Gen EDN.Value +genNil = pure EDN.Nil + +genString :: Gen EDN.Value +genString = EDN.String + <$> Gen.text (Range.exponential 4 16) Gen.unicode + +genChar :: Gen EDN.Value +genChar = EDN.Character + <$> Gen.unicode + +genInteger :: Gen EDN.Value +genInteger = (EDN.Integer . fromIntegral) + <$> Gen.int64 Range.exponentialBounded + +genFloating :: Gen EDN.Value +genFloating = EDN.Floating + <$> Gen.double (Range.exponentialFloat (-1e-308) 1e308) -- XXX: 🤷 + +genKeyword :: Gen EDN.Value +genKeyword = EDN.Keyword + <$> genKeywordName + +genKeywordName :: Gen Text +genKeywordName = genTextInitial EDN.keywordInitialChars EDN.keywordChars + +genSymbol :: Gen EDN.Value +genSymbol = EDN.Symbol + <$> genSymbolName + <*> genSymbolName + +genSymbolName :: Gen Text +genSymbolName = genTextInitial EDN.symbolInitialChars EDN.symbolChars + +genSet :: Gen EDN.Value +genSet = EDN.mkSet + <$> genNubList (0, 16) 0 id genTaggedValue + +genMap :: Gen EDN.Value +genMap = do + keys <- genNubList (0, 16) 0 id genMapKey + values <- Gen.list (Range.singleton $ length keys) genTaggedValue + pure . EDN.mkMap $ zip keys values + +genMapKey :: Gen EDN.TaggedValue +genMapKey = genTagged $ Gen.choice atomic + +genVector :: Gen EDN.Value +genVector = EDN.mkVec + <$> Gen.list (Range.exponential 0 16) genTaggedValue + +genList :: Gen EDN.Value +genList = EDN.mkList + <$> Gen.list (Range.exponential 0 16) genTaggedValue + +-- * Helpers + +genText :: [Char] -> Gen Text +genText = Gen.text (Range.exponential 4 16) . Gen.element + +genTextInitial :: [Char] -> [Char] -> Gen Text +genTextInitial initial chars = Gen.choice + [ genSingleton + , genLong'ish + ] + where + genSingleton = Text.singleton + <$> Gen.element initial + + genLong'ish = Text.cons + <$> Gen.element initial + <*> genText chars + +genNubList + :: Eq key + => (Int, Int) + -> Int + -> (a -> key) + -> Gen a + -> Gen [a] +genNubList (from, to) atLeast key gen = do + items <- Gen.list (Range.exponential from to) gen + let unique = nubBy ((==) `on` key) items + if length unique < atLeast + then + Gen.discard + else + pure $ take to unique diff --git a/tests/Data/EDN/AST/Test.hs b/tests/Data/EDN/AST/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/AST/Test.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.EDN.AST.Test + ( tests + ) where + +import Hedgehog + ( Group, Property + , discover, forAll, property, tripping, withTests + , (===) + ) + +import Data.Text (Text) + +import qualified Data.EDN.AST.Types as EDN +import qualified Data.EDN.AST.Gen as EDN +import qualified Data.EDN.AST.Parser as EDN +import qualified Data.EDN.AST.Printer as EDN + +tests :: Group +tests = $$(discover) + +type ASTParser = Text -> Either String EDN.TaggedValue + +prop_generated :: Property +prop_generated = property $ do + tv <- forAll EDN.genTaggedValue + tripping tv EDN.renderText (EDN.parseText "" :: ASTParser) + +prop_regr_empty_containers :: Property +prop_regr_empty_containers = withTests 1 . property $ do + emptyList <- EDN.parseText "" "( )" + emptyList === EDN.NoTag (EDN.List mempty) + + emptyVec <- EDN.parseText "" "[ ]" + emptyVec === EDN.NoTag (EDN.Vec mempty) + + emptySet <- EDN.parseText "" "#{ }" + emptySet === EDN.NoTag (EDN.Set mempty) + + emptyMap <- EDN.parseText "" "{ }" + emptyMap === EDN.NoTag (EDN.Map mempty) diff --git a/tests/Data/EDN/Class/Gen.hs b/tests/Data/EDN/Class/Gen.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/Class/Gen.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- TODO: generate values for types with EDN instances + +module Data.EDN.Class.Gen + ( + ) where diff --git a/tests/Data/EDN/Class/Test.hs b/tests/Data/EDN/Class/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/Class/Test.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.EDN.Class.Test + ( tests + ) where + +import Hedgehog + ( Group, Property + , discover, property, withTests + , tripping + , (===) + ) +import Data.Text (Text) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Data.UUID (UUID) +import Data.Void (Void) + +import qualified Data.Vector as Vector +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Data.EDN.Class (ToEDN(..), FromEDN(..), toEDNtagged, fromEDN) + +import qualified Data.EDN as EDN + +tests :: Group +tests = $$(discover) + +type Example = Property + +codecExample :: forall a. (ToEDN a, FromEDN a, Eq a, Show a) => Text -> a -> Example +codecExample encoded value = withTests 1 . property $ do + tripping value toEDN (fromEDN :: EDN.TaggedValue -> Either String a) + EDN.renderText (toEDN value) === encoded + +-- * Atomic types + +-- ** The Singleton Value + +prop_nil_unit :: Example +prop_nil_unit = codecExample "nil" () + +-- ** Bools + +prop_bool_true :: Example +prop_bool_true = codecExample "true" True + +prop_bool_false :: Example +prop_bool_false = codecExample "false" False + +-- ** Strings + +prop_text :: Example +prop_text = codecExample + "\"stringly \\\"typed\\\" languages\"" + ("stringly \"typed\" languages" :: Text) + +-- ** Characters + +prop_char_unicode_hex :: Example +prop_char_unicode_hex = codecExample "\\uA650" 'Ꙑ' + +prop_char_named_WS :: Example +prop_char_named_WS = codecExample "\\space" ' ' + +prop_char_basic :: Example +prop_char_basic = codecExample "\\n" 'n' + +-- ** Numeric + +prop_int :: Example +prop_int = codecExample "42" (42 :: Int) + +prop_double :: Example +prop_double = codecExample "42.0" (42.0 :: Double) + +-- * Containers + +items :: [EDN.Value] +items = + [ toEDNv (1 :: Int) + , toEDNv True + , EDN.Symbol "sort-of" "hetero" + ] + +prop_nil_maybe :: Example +prop_nil_maybe = codecExample "nil" (Nothing :: Maybe Void) + +prop_list_empty :: Example +prop_list_empty = codecExample "()" ([] :: [Void]) + +prop_list :: Example +prop_list = codecExample "(1 true sort-of/hetero)" items + +prop_vector_empty :: Example +prop_vector_empty = codecExample "[]" (mempty :: Vector.Vector Void) + +prop_vector :: Example +prop_vector = codecExample "[1 true sort-of/hetero]" $ Vector.fromList items + +prop_set_empty :: Example +prop_set_empty = codecExample "#{}" (mempty :: Set.Set Void) + +prop_set :: Example +prop_set = codecExample "#{true sort-of/hetero 1}" $ Set.fromList items + +prop_map_empty :: Example +prop_map_empty = codecExample "{}" (mempty :: Map.Map () ()) + +prop_map :: Example +prop_map = codecExample "{the/question \\? :the-answer 42.0}" $ Map.fromList + [ ( EDN.Keyword "the-answer" + , EDN.Floating 42.0 + ) + , ( EDN.Symbol "the" "question" + , EDN.Character '?' + ) + ] + +-- ** Tuples + +prop_tuple_2 :: Example +prop_tuple_2 = codecExample "[true nil]" (True, ()) + +prop_tuple_3 :: Example +prop_tuple_3 = codecExample "[true nil \\space]" (True, (), ' ') + +prop_tuple_4 :: Example +prop_tuple_4 = codecExample "[true nil \\space ()]" (True, (), ' ', [] :: [Void]) + +-- * Tagged + +prop_tagged_utctime :: Example +prop_tagged_utctime = codecExample + "#inst \"1985-04-12T23:20:50.52Z\"" + (parseTimeOrError + False + defaultTimeLocale + "%Y-%m-%dT%H:%M:%S%Q%Z" + "1985-04-12T23:20:50.52Z" + :: UTCTime + ) + +prop_tagged_uuid :: Example +prop_tagged_uuid = codecExample + "#uuid \"f81d4fae-7dec-11d0-a765-00a0c91e6bf6\"" + (read "f81d4fae-7dec-11d0-a765-00a0c91e6bf6" :: UUID) + +-- ** User type + +data Person = Person + { personFirst :: Text + , personLast :: Text + } deriving (Eq, Show) + +instance ToEDN Person where + toEDN Person{..} = + toEDNtagged "myapp" "Person" $ Map.fromList + [ (EDN.Keyword "first", toEDN personFirst) + , (EDN.Keyword "last", toEDN personLast) + ] + +instance FromEDN Person where + parseEDN = + EDN.withTagged "myapp" "Person" . EDN.withMap $ \m -> Person + <$> EDN.mapGetKeyword "first" m + <*> EDN.mapGetKeyword "last" m + +prop_tagged_person :: Example +prop_tagged_person = codecExample + "#myapp/Person {:first \"Fred\" :last \"Mertz\"}" + (Person "Fred" "Mertz") + +-- * Expected stuff + +prop_unexpected :: Property +prop_unexpected = property $ do + uuid <- EDN.decodeText "Test.hs:184" "#uuid \"f81d4fae-7dec-11d0-a765-00a0c91e6bf6\"" + uuid === (read "f81d4fae-7dec-11d0-a765-00a0c91e6bf6" :: UUID) diff --git a/tests/Data/EDN/QQ/Test.hs b/tests/Data/EDN/QQ/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/QQ/Test.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.EDN.QQ.Test + ( tests + ) where + +import Hedgehog (Group, Property, discover, property, withTests, (===)) + +import qualified Data.EDN as EDN +import qualified Data.EDN.QQ as QQ + +prop_tagged_value :: Property +prop_tagged_value = withTests 1 . property $ + EDN.Tagged "test" "tagged" EDN.Nil === [QQ.edn| #test/tagged nil |] + +prop_list :: Property +prop_list = withTests 1 . property $ do + EDN.mkList items === [QQ.ednList| + false, + 42 + #my/tagged symbol + |] + +prop_vector :: Property +prop_vector = withTests 1 . property $ do + EDN.mkVec items === [QQ.ednVec| + false, + 42 + #my/tagged symbol + |] + +prop_set :: Property +prop_set = withTests 1 . property $ do + EDN.mkSet items === [QQ.ednSet| + false, + 42 + #my/tagged symbol + |] + +prop_map :: Property +prop_map = withTests 1 . property $ do + EDN.mkMap pairs === [QQ.ednMap| + this/is false, + :the-answer 42 + #my/tagged key value + |] + where + pairs = + [ ( EDN.NoTag $ EDN.Symbol "this" "is" + , EDN.NoTag $ EDN.Boolean False) + , ( EDN.NoTag $ EDN.Keyword "the-answer" + , EDN.NoTag $ EDN.Integer 42 + ) + , ( EDN.Tagged "my" "tagged" $ EDN.Symbol "" "key" + , EDN.NoTag $ EDN.Symbol "" "value" + ) + ] + +items :: [EDN.TaggedValue] +items = + [ EDN.NoTag $ EDN.Boolean False + , EDN.NoTag $ EDN.Integer 42 + , EDN.Tagged "my" "tagged" $ EDN.Symbol "" "symbol" + ] + +-- XXX: type application must be in some other module. +-- prop_from_value :: Property +-- prop_from_value = withTests 1 . property $ do +-- () === [fromEDN @()| nil |] + +tests :: Group +tests = $$(discover) diff --git a/tests/Data/EDN/Test/QuickCheck.hs b/tests/Data/EDN/Test/QuickCheck.hs deleted file mode 100644 --- a/tests/Data/EDN/Test/QuickCheck.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.EDN.Test.QuickCheck where - -import Data.EDN.Test.QuickCheck.TH -import Data.Time (UTCTime) - -import qualified Data.Time.Calendar as Calendar -import Data.Time.Clock (UTCTime (..), UniversalTime (..), - secondsToDiffTime) -import Data.Time.LocalTime (localTimeToUT1, localTimeToUTC, - ut1ToLocalTime, utc, - utcToLocalTime) - -import qualified Test.QuickCheck as QC - --- * UTCTime Arbitrary instance ------------------------------------------------ - -fromGregorian :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime -fromGregorian year month day hours minutes seconds = - UTCTime day' (secondsToDiffTime . fromIntegral $ seconds') - where - day' = Calendar.fromGregorian year month day - seconds' = 3600 * hours + 60 * minutes + seconds - -fromUniversalTime :: UniversalTime -> UTCTime -fromUniversalTime = localTimeToUTC utc . ut1ToLocalTime 0 - -toUniversalTime :: UTCTime -> UniversalTime -toUniversalTime = localTimeToUT1 0 . utcToLocalTime utc - -fromGregorian' :: Integer -> Int -> Int -> UTCTime -fromGregorian' y m d = fromGregorian y m d 0 0 0 - -startOfTime :: UTCTime -startOfTime = fromGregorian' 1970 1 1 - -fromMJD :: Rational -> UTCTime -fromMJD = fromUniversalTime . ModJulianDate - -fromMJD' :: Float -> UTCTime -fromMJD' = fromMJD . realToFrac - -startOfTimeMJD :: Rational -startOfTimeMJD = toMJD startOfTime - -toMJD :: UTCTime -> Rational -toMJD = getModJulianDate . toUniversalTime - -instance QC.Arbitrary UTCTime where - -- coarbitrary = undefined - arbitrary = do - offset <- QC.choose (0, 20000) :: QC.Gen Float - return . fromMJD' $ offset + fromRational startOfTimeMJD - --------------------------------------------------------------------------------- - -type MUTCTime = Maybe UTCTime -type Tuple = (Int, Int) -type Triple = (Int, String, UTCTime) -type Tuple4 = (Int, String, [Maybe UTCTime], [Maybe Bool]) -type Tuple5 = (Int, [String], [Maybe UTCTime], [Maybe Bool], (Bool, Bool)) - -$(mkSerializeSpecs [ - -- ''Char -- encode/decode are not isomorphic with Char - -- ''Double -- encode/decode are not isomorphic with Double - -- ''String - ''UTCTime - , ''MUTCTime - -- , ''Tuple - -- , ''Triple - -- , ''Tuple4 - -- , ''Tuple5 - ]) diff --git a/tests/Data/EDN/Test/QuickCheck/TH.hs b/tests/Data/EDN/Test/QuickCheck/TH.hs deleted file mode 100644 --- a/tests/Data/EDN/Test/QuickCheck/TH.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Data.EDN.Test.QuickCheck.TH where - -import Control.Applicative ((<$>), (<*>)) -import Language.Haskell.TH -import Test.Hspec (Spec, describe) -import Test.Hspec.QuickCheck (prop) - - - -import qualified Data.EDN as E - --------------------------------------------------------------------------------- - -serializeProperty :: (Eq a, E.ToEDN a, E.FromEDN a) => a -> Bool -serializeProperty object = - case decoded of - Just result -> result == object - Nothing -> False - where - encoded = E.encode object - decoded = E.decode encoded - -getTestPropertyName :: Name -> Name -getTestPropertyName qualTypeName = - mkName $ "test" ++ nameBase qualTypeName ++ "Serialization" - -mkEDNSerializeSpecGroup :: [Name] -> Q [Dec] -mkEDNSerializeSpecGroup names = do - let fnName = mkName "ednSerializationProperties" - specType <- [t| Spec |] - describeFn <- [| describe |] - return [ SigD fnName specType - , ValD (VarP fnName) - (NormalB (AppE (AppE describeFn - (LitE (StringL "EDN.Serialization"))) - (DoE (map (NoBindS . VarE . getTestPropertyName) - names)))) []] - -mkSerializeSpec :: Name -> Q [Dec] -mkSerializeSpec qualTypeName = do - let typeName = nameBase qualTypeName - fnName = getTestPropertyName qualTypeName - propFn <- [| prop |] - serializePropertyFn <- [| serializeProperty |] - boolType <- [t| Bool |] - specType <- [t| Spec |] - return [ SigD fnName specType - , ValD (VarP fnName) - (NormalB (AppE - (AppE propFn - (LitE (StringL $ typeName ++ " serialization/deserialization"))) - (SigE serializePropertyFn - (AppT (AppT ArrowT (ConT qualTypeName)) - boolType)))) []] - -mkSerializeSpecs :: [Name] -> Q [Dec] -mkSerializeSpecs types = - (++) <$> (concat `fmap` mapM mkSerializeSpec types) - <*> mkEDNSerializeSpecGroup types diff --git a/tests/Data/EDN/Test/Unit.hs b/tests/Data/EDN/Test/Unit.hs deleted file mode 100644 --- a/tests/Data/EDN/Test/Unit.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ExistentialQuantification #-} -module Data.EDN.Test.Unit (tests) where - -import Test.HUnit - -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 (encode, decode, ToEDN, toEDN, FromEDN, fromEDN) -import Data.EDN.Types as E -import Data.EDN.Types.Class (Result(..), (.=)) -import Data.EDN.Parser (parseMaybe) - -tests :: Test -tests = TestList [ TestLabel "BSL -> TV parser" $ TestList $ map makeParserCase parserCases - , TestLabel "TV -> BSL encoder" $ TestList $ map makeEncodeCase encodeCases - , TestLabel "ToEDN conversion" $ TestList $ map makeToEDNcase toEDNcases - , TestLabel "FromEDN converter/decoder" $ TestList $ map makeFromEDNcase fromEDNcases - , TestLabel "decoder fail" (TestCase (assertEqual "bad unicode" Nothing (parseMaybe "№"))) - , TestLabel "'Tagged a' conversion" $ TestList taggedConversion - ] - -makeParserCase :: (BSL.ByteString, E.TaggedValue) -> Test -makeParserCase (i, o) = TestCase (assertEqual (BSL.unpack i) (Just o) (parseMaybe i)) - -makeEncodeCase :: (E.TaggedValue, BSL.ByteString) -> Test -makeEncodeCase (i, o) = TestCase (assertEqual (BSL.unpack o) o (encode i)) - -parserCases :: [(BSL.ByteString, E.TaggedValue)] -parserCases = [ ("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 '\r', "\\return") - , (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" .= E.string "Fred", "last" .= E.string "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 (Just '!') (E.char '!') - - , 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" .= E.string "shmest", "foo" .= E.string "bar"]) - ] - -data FromEDNCase = forall a. (FromEDN a, Show a, Eq a) => FromEDNCase !BSL.ByteString !a - -makeFromEDNcase :: FromEDNCase -> Test -makeFromEDNcase (FromEDNCase i o) = TestCase $ assertEqual (BSL.unpack i) (Just o) (decode i) - -fromEDNcases :: [FromEDNCase] -fromEDNcases = [ FromEDNCase "nil" (Nothing :: Maybe Bool) - - , FromEDNCase "false" False - , FromEDNCase "true" True - - , FromEDNCase "#either/left hi" (Left "hi" :: Either String ()) - , FromEDNCase "#either/right z" (Right "z" :: Either () String) - , FromEDNCase "\"ok fine\"" (Just "ok fine" :: Maybe T.Text) - , FromEDNCase "nil" (Nothing :: Maybe BSL.ByteString) - - , FromEDNCase "\\newline" '\n' - , FromEDNCase "\\z" 'z' - - , FromEDNCase "42" (42 :: Integer) - , FromEDNCase "-3.14" (-3.14 :: Double) - - , FromEDNCase "([1 2] [3 4])" ([(1,2), (3,4)]:: [(Int,Int)]) - , FromEDNCase "((1 2) (3 4))" ([[1,2], [3,4]]:: [[Int]]) - , FromEDNCase "[[1 2] [3 4]]" ([(1,2), (3,4)]:: [(Int, Int)]) - , FromEDNCase "[[1 2] [3 4]]" ([[1,2], [3,4]]:: [[Int]]) - , FromEDNCase "(hello world)" (["hello", "world"] :: [String]) - - , FromEDNCase "[3 2 1 \"Kaboom!\"]" $ E.makeVec [E.integer 3, E.integer 2, E.integer 1, "Kaboom!"] - , FromEDNCase "#{a/bag :of \"bugs\"}" $ E.makeSet [E.symbolNS "a" "bag", E.keyword "of", E.string "bugs"] - , FromEDNCase "{json: \"like\", but/not: \"really\"}" (M.fromList [("json:", "like"), ("but/not:", "really")] :: M.Map String String) - , FromEDNCase "{ json: \"like\", but/not: \"really\" }" (M.fromList [("json:", "like"), ("but/not:", "really")] :: M.Map String String) - ] - -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/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,11 +1,23 @@ module Main where -import Test.Hspec.Contrib.HUnit (fromHUnitTest) -import Test.Hspec.Runner (hspec) -import Data.EDN.Test.QuickCheck (ednSerializationProperties) -import Data.EDN.Test.Unit (tests) +import Control.Monad (unless) +import Hedgehog (checkParallel) +-- import Hedgehog (checkSequential) +import System.Exit (exitFailure) +import qualified Data.EDN.AST.Test as AST +import qualified Data.EDN.Class.Test as Class +import qualified Data.EDN.QQ.Test as QQ + main :: IO () -main = hspec $ do - fromHUnitTest tests - ednSerializationProperties +main = do + putStrLn "" + ok <- tests + unless ok exitFailure + +tests :: IO Bool +tests = fmap and . sequence $ map checkParallel + [ AST.tests + , Class.tests + , QQ.tests + ]