hedn 0.1.9.1 → 0.2.0.0

raw patch · 30 files changed

+2109/−1738 lines, 30 filesdep +deriving-compatdep +hedgehogdep +megaparsecdep −HUnitdep −QuickCheckdep −attoparsecdep ~basedep ~containersdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: deriving-compat, hedgehog, megaparsec, parser-combinators, prettyprinter, uuid

Dependencies removed: HUnit, QuickCheck, attoparsec, base-compat, bytestring, hspec, hspec-contrib, mtl, stringsearch, time-locale-compat, utf8-string

Dependency ranges changed: base, containers, deepseq, hedn, scientific, template-haskell, text, time, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−4
• LICENSE +1/−1
• README.md +184/−0
• example.edn +12/−0
• hedn.cabal +79/−68
• lib/Data/EDN.hs +70/−0
• lib/Data/EDN/AST/Lexer.hs +42/−0
• lib/Data/EDN/AST/Parser.hs +249/−0
• lib/Data/EDN/AST/Printer.hs +95/−0
• lib/Data/EDN/AST/Types.hs +14/−0
• lib/Data/EDN/AST/Types/Tagged.hs +18/−0
• lib/Data/EDN/AST/Types/Value.hs +58/−0
• lib/Data/EDN/Class.hs +495/−0
• lib/Data/EDN/Class/Parser.hs +134/−0
• lib/Data/EDN/QQ.hs +147/−0
• src/Data/EDN.hs +0/−34
• src/Data/EDN/Encode.hs +0/−93
• src/Data/EDN/Parser.hs +0/−281
• src/Data/EDN/Types.hs +0/−200
• src/Data/EDN/Types/Class.hs +0/−539
• src/Data/Parser.hs +0/−139
• tests/Data/EDN/AST/Gen.hs +159/−0
• tests/Data/EDN/AST/Test.hs +43/−0
• tests/Data/EDN/Class/Gen.hs +7/−0
• tests/Data/EDN/Class/Test.hs +183/−0
• tests/Data/EDN/QQ/Test.hs +74/−0
• tests/Data/EDN/Test/QuickCheck.hs +0/−74
• tests/Data/EDN/Test/QuickCheck/TH.hs +0/−60
• tests/Data/EDN/Test/Unit.hs +0/−238
• tests/Main.hs +19/−7

@@ -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

@@ -1,4 +1,4 @@-Copyright (c) 2012, Alexander Bondarenko+Copyright (c) 2019, Alexander Bondarenko  All rights reserved. 

@@ -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+        )+    }+  |]+```

@@ -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

@@ -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 <https://github.com/edn-format/edn>.+-- 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 <https://github.com/edn-format/edn>.+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

@@ -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 @<stdin>@+  -> Text   -- ^ EDN document body+  -> m a+decodeText sourceName source =+  parseText sourceName source >>= fromEDN

@@ -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

@@ -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 @<stdin>@+  -> 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 = ".*<>!?$%&=+_-"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 #-}

@@ -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)

@@ -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)

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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

@@ -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

@@ -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 "<generated>" :: ASTParser)++prop_regr_empty_containers :: Property+prop_regr_empty_containers = withTests 1 . property $ do+  emptyList <- EDN.parseText "<regr_empty_containers>" "( )"+  emptyList === EDN.NoTag (EDN.List mempty)++  emptyVec <- EDN.parseText "<regr_empty_containers>" "[ ]"+  emptyVec === EDN.NoTag (EDN.Vec mempty)++  emptySet <- EDN.parseText "<regr_empty_containers>" "#{ }"+  emptySet === EDN.NoTag (EDN.Set mempty)++  emptyMap <- EDN.parseText "<regr_empty_containers>" "{ }"+  emptyMap === EDN.NoTag (EDN.Map mempty)

@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}++-- TODO: generate values for types with EDN instances++module Data.EDN.Class.Gen+  (+  ) where

@@ -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)

@@ -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)

@@ -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-                   ])

@@ -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

@@ -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))-                   ]

@@ -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+  ]