Merge pull request #190 from unsplash/pretty-json

Prettified JSON

README.md

@@ -50,7 +50,7 @@ Hoist selectors up as much as possible. This is often preferred by translators.
 ```console
 $ cat translations.json
 {"openSource":{"message": "Open source at {company} is {company, select, Unsplash {encouraged!} other {unknown}}"}}
-$ intlc flatten translations.json
+$ intlc flatten --minify translations.json
 {"openSource":{"message":"{company, select, Unsplash {Open source at {company} is encouraged!} other {Open source at {company} is unknown}}"}}
 ```
 

cli/CLI.hs

@@ -1,12 +1,13 @@
 module CLI (Opts (..), getOpts) where
 
-import           Intlc.Core          (Locale (..))
+import qualified Intlc.Backend.JSON.Compiler as JSON
+import           Intlc.Core                  (Locale (..))
 import           Options.Applicative
 import           Prelude
 
 data Opts
   = Compile FilePath Locale
-  | Flatten FilePath
+  | Flatten FilePath JSON.Formatting
   | Lint    FilePath
   | Prettify Text
 
@@ -26,7 +27,7 @@ compile :: Parser Opts
 compile = Compile <$> pathp <*> localep
 
 flatten :: Parser Opts
-flatten = Flatten <$> pathp
+flatten = Flatten <$> pathp <*> minifyp
 
 lint :: Parser Opts
 lint = Lint <$> pathp
@@ -40,5 +41,8 @@ pathp = argument str (metavar "filepath")
 localep :: Parser Locale
 localep = Locale <$> strOption (short 'l' <> long "locale")
 
+minifyp :: Parser JSON.Formatting
+minifyp = flag JSON.Pretty JSON.Minified (long "minify")
+
 prettify :: Parser Opts
 prettify = Prettify <$> msgp

cli/Main.hs

@@ -1,20 +1,22 @@
 module Main where
 
-import           CLI                (Opts (..), getOpts)
-import qualified Data.Text          as T
-import           Intlc.Compiler     (compileDataset, compileFlattened)
+import           CLI                         (Opts (..), getOpts)
+import qualified Data.Text                   as T
+import qualified Intlc.Backend.JSON.Compiler as JSON
+import           Intlc.Compiler              (compileDataset, compileFlattened)
 import           Intlc.Core
-import           Intlc.ICU          (AnnNode, Message, Node, sansAnn)
+import           Intlc.ICU                   (AnnNode, Message, Node, sansAnn)
 import           Intlc.Linter
-import           Intlc.Parser       (parseDataset, parseMessage, printErr)
-import           Intlc.Parser.Error (ParseFailure)
-import           Intlc.Prettify     (prettify)
+import           Intlc.Parser                (parseDataset, parseMessage,
+                                              printErr)
+import           Intlc.Parser.Error          (ParseFailure)
+import           Intlc.Prettify              (prettify)
 import           Prelude
 
 main :: IO ()
 main = getOpts >>= \case
   Compile path loc -> tryGetParsedAtSansAnn path >>= compile loc
-  Flatten path     -> tryGetParsedAtSansAnn path >>= flatten
+  Flatten path fo  -> tryGetParsedAtSansAnn path >>= flatten fo
   Lint    path     -> lint path
   Prettify msg     -> tryPrettify msg
 
@@ -23,8 +25,8 @@ compile loc = compileDataset loc >>> \case
   Left es -> die . T.unpack . ("Invalid keys:\n" <>) . T.intercalate "\n" . fmap ("\t" <>) . toList $ es
   Right x -> putTextLn x
 
-flatten :: MonadIO m => Dataset (Translation (Message Node)) -> m ()
-flatten = putTextLn . compileFlattened
+flatten :: MonadIO m => JSON.Formatting -> Dataset (Translation (Message Node)) -> m ()
+flatten fo = putTextLn . compileFlattened fo
 
 lint :: MonadIO m => FilePath -> m ()
 lint path = do

internal/CLI.hs

@@ -1,12 +1,13 @@
 module CLI (Opts (..), getOpts) where
 
+import qualified Intlc.Backend.JSON.Compiler as JSON
 import           Options.Applicative
 import           Prelude
 
 data Opts
   = Lint FilePath
   -- Takes stdin.
-  | ExpandPlurals
+  | ExpandPlurals JSON.Formatting
 
 getOpts :: IO Opts
 getOpts = execParser (info (opts <**> helper) (progDesc h))
@@ -22,7 +23,10 @@ lint :: Parser Opts
 lint = Lint <$> pathp
 
 expandPlurals :: Parser Opts
-expandPlurals = pure ExpandPlurals
+expandPlurals = ExpandPlurals <$> minifyp
 
 pathp :: Parser FilePath
 pathp = argument str (metavar "filepath")
+
+minifyp :: Parser JSON.Formatting
+minifyp = flag JSON.Pretty JSON.Minified (long "minify")

internal/Main.hs

@@ -3,7 +3,7 @@ module Main where
 import           CLI                         (Opts (..), getOpts)
 import qualified Data.Text                   as T
 import           Data.Text.IO                (getContents)
-import           Intlc.Backend.JSON.Compiler (compileDataset)
+import qualified Intlc.Backend.JSON.Compiler as JSON
 import           Intlc.Compiler              (expandPlurals)
 import           Intlc.Core
 import           Intlc.ICU                   (AnnNode, Message, Node)
@@ -14,17 +14,18 @@ import           Prelude                     hiding (filter)
 
 main :: IO ()
 main = getOpts >>= \case
-  Lint path     -> lint path
-  ExpandPlurals -> tryGetParsedStdinSansAnn >>= compileExpandedPlurals
+  Lint path        -> lint path
+  ExpandPlurals fo -> tryGetParsedStdinSansAnn >>= compileExpandedPlurals fo
 
 lint :: MonadIO m => FilePath -> m ()
 lint path = do
   raw <- readFileAt path
   dataset <- parserDie $ parseDataset path raw
   whenJust (lintDatasetInternal path raw dataset) $ die . T.unpack
 
-compileExpandedPlurals :: MonadIO m => Dataset (Translation (Message Node)) -> m ()
-compileExpandedPlurals = putTextLn . compileDataset . fmap (\x -> x { message = expandPlurals x.message })
+compileExpandedPlurals :: MonadIO m => JSON.Formatting -> Dataset (Translation (Message Node)) -> m ()
+compileExpandedPlurals fo = putTextLn . JSON.compileDataset fo . fmap f
+  where f x = x { message = expandPlurals x.message }
 
 tryGetParsedStdinSansAnn :: IO (Dataset (Translation (Message Node)))
 tryGetParsedStdinSansAnn = parserDie . fmap datasetSansAnn =<< getParsedStdin

lib/Intlc/Backend/JSON/Compiler.hs

@@ -3,12 +3,28 @@ module Intlc.Backend.JSON.Compiler where
 import           Data.List.Extra            (escapeJSON)
 import qualified Data.Map                   as M
 import qualified Data.Text                  as T
-import           Intlc.Backend.ICU.Compiler (Formatting (SingleLine),
-                                             compileMsg)
+import qualified Intlc.Backend.ICU.Compiler as ICU
 import           Intlc.Core
 import           Intlc.ICU                  (Message, Node)
 import           Prelude
 
+type Compiler = Reader Config
+
+data Config = Config
+  -- Expected to be potentially supplied externally.
+  { fmt          :: Formatting
+  -- Expected to be supplied internally.
+  , indentLevels :: Int
+  }
+
+-- | For prettified formatting we simply indent and inject newlines at objects.
+data Formatting
+  = Minified
+  | Pretty
+
+increment :: Compiler a -> Compiler a
+increment = local $ \x -> x { indentLevels = x.indentLevels + 1 }
+
 -- Assumes unescaped input.
 dblqts :: Text -> Text
 dblqts v = "\"" <> escapeJSONText v <> "\""
@@ -23,20 +39,31 @@ nullVal = "null"
 objKey :: Text -> Text
 objKey = dblqts
 
-objPair :: Text -> Text -> Text
-objPair k v = objKey k <> ":" <> v
-
-obj :: [(Text, Text)] -> Text
-obj xs = "{" <> ys <> "}"
-  where ys = T.intercalate "," . fmap (uncurry objPair) $ xs
+-- | This is where we'll manage indentation for all objects, hence taking a
+-- monadic input.
+obj :: Compiler [(Text, Text)] -> Compiler Text
+obj xs = asks fmt >>= \case
+  Minified -> do
+    let objPair k v = objKey k <> ":" <> v
+    contents <- T.intercalate "," . fmap (uncurry objPair) <$> xs
+    pure $ "{" <> contents <> "}"
+  Pretty   -> do
+    i <- asks indentLevels
+    let objPair k v = newline <> indentBy (i + 1) <> objKey k <> ": " <> v
+    contents <- fmap (T.intercalate "," . fmap (uncurry objPair)) . increment $ xs
+    pure $ "{" <> contents <> newline <> indentBy i <> "}"
+    where newline = "\n"
+          indentBy = flip T.replicate "\t"
 
-compileDataset :: Dataset (Translation (Message Node)) -> Text
-compileDataset = obj . M.toList . M.map translation
+compileDataset :: Formatting -> Dataset (Translation (Message Node)) -> Text
+compileDataset fo ds = runReader (dataset ds) (Config fo 0)
+  where dataset = obj . traverse (uncurry f) . M.toList
+        f x = fmap (x,) . translation
 
-translation :: Translation (Message Node) -> Text
-translation Translation { message, backend, mdesc } = obj . fromList $ ys
+translation :: Translation (Message Node) -> Compiler Text
+translation Translation { message, backend, mdesc } = obj . pure . fromList $ ys
   where ys =
-          [ ("message", strVal . compileMsg SingleLine $ message)
+          [ ("message", strVal . ICU.compileMsg ICU.SingleLine $ message)
           , ("backend", backendVal)
           , ("description", maybe nullVal strVal mdesc)
           ]

lib/Intlc/Compiler.hs

@@ -36,8 +36,8 @@ compileTranslation l k (Translation v be _) = case be of
   TypeScript      -> TS.compileNamedExport TemplateLit l k v
   TypeScriptReact -> TS.compileNamedExport JSX         l k v
 
-compileFlattened :: Dataset (Translation (ICU.Message ICU.Node)) -> Text
-compileFlattened = JSON.compileDataset . mapMsgs (fmap flatten)
+compileFlattened :: JSON.Formatting -> Dataset (Translation (ICU.Message ICU.Node)) -> Text
+compileFlattened fo = JSON.compileDataset fo . mapMsgs (fmap flatten)
 
 mapMsgs :: (ICU.Message ICU.Node -> ICU.Message ICU.Node) -> Dataset (Translation (ICU.Message ICU.Node)) -> Dataset (Translation (ICU.Message ICU.Node))
 mapMsgs f = fmap $ \x -> x { message = f x.message }

test/Intlc/CompilerSpec.hs

@@ -1,13 +1,15 @@
 module Intlc.CompilerSpec (spec) where
 
-import           Intlc.Compiler    (compileDataset, compileFlattened,
-                                    expandRules, flatten)
-import           Intlc.Core        (Backend (..), Locale (Locale),
-                                    Translation (Translation))
+import qualified Data.Text                   as T
+import qualified Intlc.Backend.JSON.Compiler as JSON
+import           Intlc.Compiler              (compileDataset, compileFlattened,
+                                              expandRules, flatten)
+import           Intlc.Core                  (Backend (..), Locale (Locale),
+                                              Translation (Translation))
 import           Intlc.ICU
-import           Prelude           hiding (one)
+import           Prelude                     hiding (one)
 import           Test.Hspec
-import           Text.RawString.QQ (r)
+import           Text.RawString.QQ           (r)
 
 spec :: Spec
 spec = describe "compiler" $ do
@@ -25,16 +27,45 @@ spec = describe "compiler" $ do
       f [""] `shouldSatisfy` isLeft
 
   describe "compile flattened dataset" $ do
-    it "flattens messages and outputs JSON" $ do
-      compileFlattened (fromList
-        [ ("x", Translation (Message "xfoo") TypeScript Nothing)
-        , ("z", Translation (Message "zfoo") TypeScriptReact (Just "zbar"))
-        , ("y", Translation (Message $ mconcat ["yfoo ", String' "ybar"]) TypeScript Nothing)
-        ])
-          `shouldBe` [r|{"x":{"message":"xfoo","backend":"ts","description":null},"y":{"message":"yfoo {ybar}","backend":"ts","description":null},"z":{"message":"zfoo","backend":"tsx","description":"zbar"}}|]
+    let f = compileFlattened
+
+    describe "flattens messages and outputs JSON" $ do
+      let xs = fromList
+            [ ("x", Translation (Message "xfoo") TypeScript Nothing)
+            , ("z", Translation (Message "zfoo") TypeScriptReact (Just "zbar"))
+            , ("y", Translation (Message $ mconcat ["yfoo ", String' "ybar"]) TypeScript Nothing)
+            ]
+
+      it "minified" $ do
+        f JSON.Minified xs `shouldBe`
+          [r|{"x":{"message":"xfoo","backend":"ts","description":null},"y":{"message":"yfoo {ybar}","backend":"ts","description":null},"z":{"message":"zfoo","backend":"tsx","description":"zbar"}}|]
+
+      it "prettified" $ do
+        let toTabs = T.replace "  " "\t"
+
+        f JSON.Pretty mempty `shouldBe` [r|{
+}|]
+
+        f JSON.Pretty xs `shouldBe` toTabs [r|{
+  "x": {
+    "message": "xfoo",
+    "backend": "ts",
+    "description": null
+  },
+  "y": {
+    "message": "yfoo {ybar}",
+    "backend": "ts",
+    "description": null
+  },
+  "z": {
+    "message": "zfoo",
+    "backend": "tsx",
+    "description": "zbar"
+  }
+}|]
 
     it "escapes double quotes in JSON" $ do
-      compileFlattened (fromList [("x\"y", Translation (Message "\"z\"") TypeScript Nothing)])
+      f JSON.Minified (fromList [("x\"y", Translation (Message "\"z\"") TypeScript Nothing)])
         `shouldBe` [r|{"x\"y":{"message":"\"z\"","backend":"ts","description":null}}|]
 
   describe "flatten message" $ do