sugar-json (empty) → 0.0.0

raw patch · 6 files changed

+215/−0 lines, 6 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, cereal, containers, megaparsec, ordered-containers, safe, scientific, sugar, tasty, tasty-hspec, text, text-conversions, text-show, unordered-containers, vector

Files

CHANGELOG.md +7/−0
LICENSE +29/−0
README.md +0/−0
src/Sugar/Json.hs +108/−0
sugar-json.cabal +59/−0
test-suite/Main.hs +12/−0

+ CHANGELOG.md view

@@ -0,0 +1,7 @@+# Change log++sugar uses [Semantic Versioning][].+The change log is available through the [releases on GitHub][].++[Semantic Versioning]: http://semver.org/spec/v2.0.0.html+[releases on GitHub]: https://github.com/jxv/sugar/releases

+ LICENSE view

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2022, Joe Vargas+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

+ src/Sugar/Json.hs view

@@ -0,0 +1,108 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Sugar.Json+  ( SugarCube(..)+  , sugarCubeMay+  , writeJsonAsSugarBinary+  , writeJsonAsSugar+  ) where++import Data.Text (Text)+import Data.Map (Map)+import Data.Scientific (floatingOrInteger)+import TextShow (showt)++import qualified Data.Map as Map++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as AesonKey+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif++import qualified Data.Serialize as Serialize+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Aeson as Json+import qualified Data.Vector as V+import qualified Data.Text.IO as TIO++import Sugar++-- SugarCube is a refined type of Sugar.+-- This is a useful interface when a Json-like format is easier.+-- Differences:+-- * No notes+-- * No list wrap+-- * Maps are string-key value pairs+data SugarCube+  = SugarCube'Unit+  | SugarCube'Text Text+  | SugarCube'List [SugarCube]+  | SugarCube'Map (Map Text SugarCube)+  deriving (Eq, Show)++class ToSugarCube a where+  toSugarCube :: a -> SugarCube++sugarCubeMay :: Sugar -> Maybe SugarCube+sugarCubeMay (Sugar'Unit _) = Just SugarCube'Unit+sugarCubeMay (Sugar'Text t _) = Just $ SugarCube'Text t+sugarCubeMay (Sugar'List xs _ _) = do+  xs' <- mapM sugarCubeMay xs+  return $ SugarCube'List xs'+sugarCubeMay (Sugar'Map xs _) = do+  xs' <- mapM (\(k,v) -> (,) <$> sugarTextMay k <*> sugarCubeMay v) xs+  return $ SugarCube'Map (Map.fromList xs')++  +writeJsonAsSugarBinary :: FilePath -> FilePath -> IO ()+writeJsonAsSugarBinary src des = do+  bsl <- BL.readFile src+  let value' = Json.decode' bsl :: Maybe Sugar+  case value' of+    Nothing -> putStrLn "Can not decode"+    Just sugar ->  BS.writeFile des $ Serialize.encode sugar++writeJsonAsSugar :: FilePath -> FilePath -> IO ()+writeJsonAsSugar src des = do+  bsl <- BL.readFile src+  let value' = Json.decode' bsl :: Maybe Sugar+  case value' of+    Nothing -> putStrLn "Can not decode"+    Just sugar ->  TIO.writeFile des $ prettyPrintSugar sugar+++instance ToSugar SugarCube where+  toSugar SugarCube'Unit = Sugar'Unit Nothing+  toSugar (SugarCube'Text t) = Sugar'Text t Nothing+  toSugar (SugarCube'List xs) = Sugar'List (map (toSugarWithWrap Wrap'Paren) xs) Wrap'Square Nothing+    where+      -- Alternate nesting between Wrap types+      toSugarWithWrap w c = case c of+        SugarCube'List ys -> Sugar'List (map (toSugarWithWrap (case w of Wrap'Square -> Wrap'Paren; Wrap'Paren -> Wrap'Square)) ys) w Nothing+        _ -> toSugar c+  toSugar (SugarCube'Map m) = Sugar'Map (map (\(k,v) -> (toSugar k, toSugar v)) $ Map.toList m) Nothing++instance ToSugarCube Json.Value where+  toSugarCube Json.Null = SugarCube'Unit+  toSugarCube (Json.Bool b) = SugarCube'Text (showt b)+  toSugarCube (Json.String t) = SugarCube'Text t+  toSugarCube (Json.Number n) = SugarCube'Text (showNumber n)+    where+      showNumber s = either showt showt $ (floatingOrInteger s :: Either Double Integer)+  toSugarCube (Json.Array a) = SugarCube'List $ map toSugarCube (V.toList a)+  toSugarCube (Json.Object o) = SugarCube'Map . Map.fromList . map (\(k,v) -> (keyText k, toSugarCube v)) . KeyMap.toList $ o+    where+#if MIN_VERSION_aeson(2,0,0)+      keyText = AesonKey.toText+#else+      keyText = id+#endif+  +instance Json.FromJSON SugarCube where+  parseJSON v = pure $ toSugarCube v+  +instance Json.FromJSON Sugar where+  parseJSON v = pure . toSugar . toSugarCube $ v

+ sugar-json.cabal view

@@ -0,0 +1,59 @@+name: sugar-json+version: 0.0.0+synopsis: Sugar with JSON+homepage: https://github.com/jxv/sugar#readme+description: Please see the README on GitHub at <https://github.com/jxv/sugar#readme>+category: Text, Configuration+bug-reports: https://github.com/jxv/sugar/issues+author: Joe Vargas+maintainer: Joe Vargas+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: 1.14+extra-source-files:+    CHANGELOG.md+    LICENSE+    README.md++source-repository head+  type: git+  location: https://github.com/jxv/sugar++library+  exposed-modules:+      Sugar.Json+  hs-source-dirs:+      src+  default-extensions:+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , cereal+    , containers >0.5 && <1+    , megaparsec+    , ordered-containers+    , safe+    , scientific+    , sugar == 0.0.0+    , text+    , text-conversions+    , text-show+    , unordered-containers+    , vector+  default-language: Haskell2010++test-suite sugar-json-test-suite+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test-suite+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base+    , sugar+    , tasty+    , tasty-hspec+  default-language: Haskell2010

+ test-suite/Main.hs view

@@ -0,0 +1,12 @@+import qualified Test.Tasty+import Test.Tasty.Hspec++main :: IO ()+main = do+    test <- testSpec "sugar" spec+    Test.Tasty.defaultMain test++spec :: Spec+spec = parallel $ do+    it "is trivially true" $ do+        True `shouldBe` True