Merge pull request #173 from unsplash/prettify

Add ICU prettifier

README.md

@@ -34,7 +34,7 @@ Take a JSON object of ICU messages, and a locale, and output TypeScript to stdou
 
 ```console
 $ cat translations.json
-{"welcome": {"message": "Hello {name}"}}
+{"welcome":{"message": "Hello {name}"}}
 $ intlc compile translations.json -l en-US > translations.ts
 $ cat translations.ts
 export const welcome: (x: { name: string }) => string = x => `Hello ${x.name}`
@@ -59,12 +59,33 @@ Lint against suboptimal use of ICU syntax.
 
 ```console
 $ cat translations.json
-{"welcome": {"message": "Hello {name, select, other {{name}}}"}}
+{"welcome":{"message": "Hello {name, select, other {{name}}}"}}
 $ intlc lint translation.json
 welcome:
   Redundant select: name
 ```
 
+### Formatting
+
+Pretty-print an ICU message. Useful for inspecting larger messages such as flattened ones.
+
+```console
+$ cat translations.json
+{"tagline": {"message":"{hasTags, boolean, true {{type, select, overLimit {{upperLimit, number}+ best free {formattedListOfTags} photos on Unsplash} belowLimit {{photoTotal, number} best free {formattedListOfTags} photos on Unsplash}}} false {{type, select, overLimit {{upperLimit, number}+ best free photos on Unsplash} belowLimit {{photoTotal, number} best free photos on Unsplash}}}}"}}
+$ intlc prettify $(cat translations.json | jq -r .tagline.message)
+{hasTags, boolean,
+  true {{type, select,
+    overLimit {{upperLimit, number}+ best free {formattedListOfTags} photos on Unsplash}
+    belowLimit {{photoTotal, number} best free {formattedListOfTags} photos on Unsplash}
+  }}
+  false {{type, select,
+    overLimit {{upperLimit, number}+ best free photos on Unsplash}
+    belowLimit {{photoTotal, number} best free photos on Unsplash}
+  }}
+}
+
+```
+
 ## Schema
 
 Translation files should be encoded as JSON and might look something like this:

cli/CLI.hs

@@ -8,16 +8,18 @@ data Opts
   = Compile FilePath Locale
   | Flatten FilePath
   | Lint    FilePath
+  | Prettify Text
 
 getOpts :: IO Opts
 getOpts = execParser (info (opts <**> helper) (progDesc h))
   where h = "Compile ICU messages into code."
 
 opts :: Parser Opts
 opts = subparser . mconcat $
-  [ command "compile" (info (compile <**> helper) mempty)
-  , command "flatten" (info (flatten <**> helper) mempty)
-  , command "lint"    (info (lint    <**> helper) mempty)
+  [ command "compile"  (info (compile  <**> helper) mempty)
+  , command "flatten"  (info (flatten  <**> helper) mempty)
+  , command "lint"     (info (lint     <**> helper) mempty)
+  , command "prettify" (info (prettify <**> helper) mempty)
   ]
 
 compile :: Parser Opts
@@ -29,8 +31,14 @@ flatten = Flatten <$> pathp
 lint :: Parser Opts
 lint = Lint <$> pathp
 
+msgp :: Parser Text
+msgp = argument str (metavar "message")
+
 pathp :: Parser FilePath
 pathp = argument str (metavar "filepath")
 
 localep :: Parser Locale
 localep = Locale <$> strOption (short 'l' <> long "locale")
+
+prettify :: Parser Opts
+prettify = Prettify <$> msgp

cli/Main.hs

@@ -5,15 +5,17 @@ import qualified Data.Text          as T
 import           Intlc.Compiler     (compileDataset, compileFlattened)
 import           Intlc.Core
 import           Intlc.Linter
-import           Intlc.Parser       (parseDataset, printErr)
+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 -> tryGetParsedAt path >>= compile loc
   Flatten path     -> tryGetParsedAt path >>= flatten
   Lint    path     -> tryGetParsedAt path >>= lint
+  Prettify msg     -> tryPrettify msg
 
 compile :: MonadIO m => Locale -> Dataset Translation -> m ()
 compile loc = compileDataset loc >>> \case
@@ -26,6 +28,9 @@ flatten = putTextLn . compileFlattened
 lint :: MonadIO m => Dataset Translation -> m ()
 lint xs = whenJust (lintDatasetExternal xs) $ die . T.unpack
 
+tryPrettify :: MonadIO m => Text -> m ()
+tryPrettify = either (die . printErr) (putTextLn . prettify) . parseMessage "input"
+
 tryGetParsedAt :: MonadIO m => FilePath -> m (Dataset Translation)
 tryGetParsedAt = parserDie <=< getParsedAt
 

intlc.cabal

@@ -70,6 +70,7 @@ library
     Intlc.Parser.Error
     Intlc.Parser.JSON
     Intlc.Parser.ICU
+    Intlc.Prettify
     Utils
 
 test-suite test-intlc
@@ -97,3 +98,4 @@ test-suite test-intlc
     Intlc.LinterSpec
     Intlc.Parser.JSONSpec
     Intlc.Parser.ICUSpec
+    Intlc.PrettifySpec

lib/Intlc/Backend/ICU/Compiler.hs

@@ -6,50 +6,161 @@
 -- instead used post-flattening. Additionally it only operates upon individual
 -- ICU messages, offloading JSON handling to the caller.
 
-module Intlc.Backend.ICU.Compiler where
+module Intlc.Backend.ICU.Compiler (compileMsg, Formatting (..)) where
 
 import           Data.Functor.Foldable (cata)
 import qualified Data.Text             as T
 import           Intlc.ICU
 import           Prelude
+import           Utils                 ((<>^))
 
-compileMsg :: Message -> Text
-compileMsg = node . unMessage
-
-node :: Node -> Text
-node = cata $ \case
-  FinF -> mempty
-  (CharF c x)     -> T.singleton c <> x
-  x@(BoolF {})    -> "{" <> (unArg . nameF $ x) <> ", boolean, true {" <> trueCaseF x <> "} false {" <> falseCaseF x <> "}}" <> nextF x
-  (StringF n x)   -> "{" <> unArg n <> "}" <> x
-  (NumberF n x)   -> "{" <> unArg n <> ", number}" <> x
-  (DateF n fmt x) -> "{" <> unArg n <> ", date, " <> dateTimeFmt fmt  <> "}" <> x
-  (TimeF n fmt x) -> "{" <> unArg n <> ", time, " <> dateTimeFmt fmt  <> "}" <> x
-  (CardinalExactF n xs y)        -> "{" <> unArg n <> ", plural, " <> cases <> "}" <> y
-    where cases = unwords . toList . fmap exactPluralCase $ xs
-  (CardinalInexactF n xs ys w z) -> "{" <> unArg n <> ", plural, " <> cases <> "}" <> z
-    where cases = unwords . mconcat $ [exactPluralCase <$> xs, rulePluralCase <$> ys, pure $ wildcard w]
-  (OrdinalF n xs ys w z)         -> "{" <> unArg n <> ", selectordinal, " <> cases <> "}" <> z
-    where cases = unwords $ (exactPluralCase <$> xs) <> (rulePluralCase <$> ys) <> pure (wildcard w)
-  (PluralRefF _ x)    -> "#" <> x
-  (SelectNamedF n xs y)       -> "{" <> unArg n <> ", select, " <> cases <> "}" <> y
-    where cases = unwords . fmap selectCase . toList $ xs
-  (SelectWildF n w x)         -> "{" <> unArg n <> ", select, " <> wildcard w <> "}" <> x
-  (SelectNamedWildF n xs w y) -> "{" <> unArg n <> ", select, " <> cases <> "}" <> y
-    where cases = unwords . (<> pure (wildcard w)) . fmap selectCase . toList $ xs
-  (CallbackF n xs y) -> "<" <> unArg n <> ">" <> xs <> "</" <> unArg n <> ">" <> y
+compileMsg :: Formatting -> Message -> Text
+compileMsg x y = node x (unMessage y)
 
-dateTimeFmt :: DateTimeFmt -> Text
-dateTimeFmt Short  = "short"
-dateTimeFmt Medium = "medium"
-dateTimeFmt Long   = "long"
-dateTimeFmt Full   = "full"
+data Formatting
+  = SingleLine
+  | MultiLine
+
+data Config = Config
+  -- Expected to be potentially supplied externally.
+  { fmt          :: Formatting
+  -- Expected to be supplied internally.
+  , indentLevels :: Int
+  }
+
+type Compiler = Reader Config
+
+increment :: Compiler a -> Compiler a
+increment = local $ \x -> x { indentLevels = x.indentLevels + 1 }
+
+node :: Formatting -> Node -> Text
+node fo ast = runReader (cata go ast) (Config fo 0) where
+  go :: NodeF (Compiler Text) -> Compiler Text
+  go = \case
+    FinF -> pure mempty
+
+    (CharF c next) -> (T.singleton c <>) <$> next
+
+    (BoolF { nameF, trueCaseF, falseCaseF, nextF }) ->
+      let cs = sequence [("true",) <$> trueCaseF, ("false",) <$> falseCaseF]
+       in (boolean nameF cs) <>^ nextF
+
+    (StringF n next) -> (string n <>) <$> next
+
+    (NumberF n next) -> (number n <>) <$> next
+
+    (DateF n fmt next) -> (date n fmt <>) <$> next
+
+    (TimeF n fmt next) -> (time n fmt <>) <$> next
+
+    (CardinalExactF n xs next) -> (cardinal n $ exactPluralCases xs) <>^ next
+
+    (CardinalInexactF n xs ys w next) ->
+      let cs = join <$> sequence [exactPluralCases xs, rulePluralCases ys, pure . wildcard <$> w]
+       in (cardinal n cs) <>^ next
+
+    (OrdinalF n xs ys w next) ->
+      let cs = join <$> sequence [exactPluralCases xs, rulePluralCases ys, pure . wildcard <$> w]
+       in (ordinal n cs) <>^ next
+
+    (PluralRefF _ next) -> ("#" <>) <$> next
+
+    (SelectNamedF n xs y) -> (select n $ selectCases xs) <>^ y
+
+    (SelectWildF n w x) -> (select n $ pure . wildcard <$> w) <>^ x
+
+    (SelectNamedWildF n xs w next) ->
+      let cs = (<>) <$> selectCases xs <*> (pure . wildcard <$> w)
+       in (select n cs) <>^ next
+
+    (CallbackF n xs next) -> (callback n <$> xs) <>^ next
+
+cardinal :: Arg -> Compiler [Case] -> Compiler Text
+cardinal n x = typedInterp "plural" n <$> (pure <$> cases x)
+
+ordinal :: Arg -> Compiler [Case] -> Compiler Text
+ordinal n x = typedInterp "selectordinal" n <$> (pure <$> cases x)
+
+select :: Arg -> Compiler [Case] -> Compiler Text
+select n x = typedInterp "select" n <$> (pure <$> cases x)
+
+boolean :: Arg -> Compiler [Case] -> Compiler Text
+boolean n x = typedInterp "boolean" n <$> (pure <$> cases x)
 
-exactPluralCase :: PluralCaseF PluralExact Text -> Text
-exactPluralCase (PluralExact n, x) = "=" <> n <> " {" <> x <> "}"
+datetime :: Text -> Arg -> DateTimeFmt -> Text
+datetime t n f = typedInterp t n (pure . dateTimeFmt $ f)
 
-rulePluralCase :: PluralCaseF PluralRule Text -> Text
-rulePluralCase (r, x) = pluralRule r <> " {" <> x <> "}"
+date :: Arg -> DateTimeFmt -> Text
+date = datetime "date"
+
+time :: Arg -> DateTimeFmt -> Text
+time = datetime "time"
+
+typedInterp :: Text -> Arg -> [Text] -> Text
+typedInterp t n xs = interp n (t : xs)
+
+number :: Arg -> Text
+number = flip interp (pure "number")
+
+string :: Arg -> Text
+string = flip interp mempty
+
+interp :: Arg -> [Text] -> Text
+interp n xs = "{" <> interpPieces (unArg n : xs) <> "}"
+
+interpPieces :: [Text] -> Text
+interpPieces = T.intercalate ", "
+
+callback :: Arg -> Text -> Text
+callback n x = "<" <> unArg n <> ">" <> x <> "</" <> unArg n <> ">"
+
+type Case = (Text, Text)
+
+-- | This is where we'll manage indentation for all case-style interpolations,
+-- hence taking a monadic input.
+cases :: Compiler [Case] -> Compiler Text
+cases mcs = asks fmt >>= \case
+  SingleLine -> unwords . fmap (uncurry case') <$> mcs
+  MultiLine  -> do
+    i <- asks indentLevels
+    let indentedCase = (indentBy (i + 1) <>) . uncurry case'
+    cs <- fmap indentedCase <$> increment mcs
+    pure $ newline <> T.intercalate newline cs <> newline <> indentBy i
+    where newline = "\n"
+          indentBy = flip T.replicate "\t"
+
+case' :: Text -> Text -> Text
+case' n x = n <> " {" <> x <> "}"
+
+wildcard :: Text -> Case
+wildcard = ("other",)
+
+selectCases :: Traversable t => t (SelectCaseF (Compiler Text)) -> Compiler [Case]
+selectCases = fmap toList . traverse selectCaseF
+
+selectCaseF :: Functor f => SelectCaseF (f Text) -> f Case
+selectCaseF (n, mx) = selectCase . (n,) <$> mx
+
+selectCase :: SelectCaseF Text -> Case
+selectCase = id
+
+exactPluralCases :: Traversable t => t (PluralCaseF PluralExact (Compiler Text)) -> Compiler [Case]
+exactPluralCases = fmap toList . traverse exactPluralCaseF
+
+exactPluralCaseF :: PluralCaseF PluralExact (Compiler Text) -> Compiler Case
+exactPluralCaseF (n, mx) = exactPluralCase . (n,) <$> mx
+
+exactPluralCase :: PluralCaseF PluralExact Text -> Case
+exactPluralCase (PluralExact n, x) = ("=" <> n, x)
+
+rulePluralCases :: Traversable t => t (PluralCaseF PluralRule (Compiler Text)) -> Compiler [Case]
+rulePluralCases = fmap toList . traverse rulePluralCaseF
+
+rulePluralCaseF :: PluralCaseF PluralRule (Compiler Text) -> Compiler Case
+rulePluralCaseF (r, mx) = rulePluralCase . (r,) <$> mx
+
+rulePluralCase :: PluralCaseF PluralRule Text -> Case
+rulePluralCase = first pluralRule
 
 pluralRule :: PluralRule -> Text
 pluralRule Zero = "zero"
@@ -58,8 +169,8 @@ pluralRule Two  = "two"
 pluralRule Few  = "few"
 pluralRule Many = "many"
 
-selectCase :: SelectCaseF Text -> Text
-selectCase (n, x) = n <> " {" <> x <> "}"
-
-wildcard :: Text -> Text
-wildcard x = "other {" <> x <> "}"
+dateTimeFmt :: DateTimeFmt -> Text
+dateTimeFmt Short  = "short"
+dateTimeFmt Medium = "medium"
+dateTimeFmt Long   = "long"
+dateTimeFmt Full   = "full"

lib/Intlc/Backend/JSON/Compiler.hs

@@ -3,7 +3,8 @@ 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 (compileMsg)
+import           Intlc.Backend.ICU.Compiler (Formatting (SingleLine),
+                                             compileMsg)
 import           Intlc.Core
 import           Prelude
 
@@ -34,7 +35,7 @@ compileDataset = obj . M.toList . M.map translation
 translation :: Translation -> Text
 translation Translation { message, backend, mdesc } = obj . fromList $ ys
   where ys =
-          [ ("message", strVal . compileMsg $ message)
+          [ ("message", strVal . compileMsg SingleLine $ message)
           , ("backend", backendVal)
           , ("description", maybe nullVal strVal mdesc)
           ]

lib/Intlc/Parser.hs

@@ -1,7 +1,10 @@
 module Intlc.Parser where
 
+import qualified Data.Text             as T
 import           Intlc.Core
+import qualified Intlc.ICU             as ICU
 import           Intlc.Parser.Error    (ParseFailure)
+import           Intlc.Parser.ICU      (msg')
 import           Intlc.Parser.JSON     (ParserState (ParserState), dataset)
 import           Prelude
 import           Text.Megaparsec       (runParser)
@@ -10,5 +13,8 @@ import           Text.Megaparsec.Error
 parseDataset :: FilePath -> Text -> Either ParseFailure (Dataset Translation)
 parseDataset = runParser (evalStateT dataset (ParserState mempty))
 
+parseMessage :: Text -> Text -> Either ParseFailure ICU.Message
+parseMessage src = runParser msg' (T.unpack src)
+
 printErr :: ParseFailure -> String
 printErr = errorBundlePretty

lib/Intlc/Parser/ICU.hs

@@ -41,6 +41,14 @@ ident = label "alphabetic identifier" $ T.pack <$> some letterChar
 arg :: Parser Arg
 arg = Arg <$> ident
 
+-- | Parse a message until end of input.
+--
+-- To instead parse a message as part of a broader data structure, instead look
+-- at `msg` and its `endOfInput` state property.
+msg' :: Parsec ParseErr Text Message
+msg' = runReaderT msg cfg where
+  cfg = emptyState { endOfInput = eof }
+
 -- Parse a message until the end of input parser matches.
 msg :: Parser Message
 msg = msgTill =<< asks endOfInput

lib/Intlc/Prettify.hs

@@ -0,0 +1,8 @@
+module Intlc.Prettify (prettify) where
+
+import           Intlc.Backend.ICU.Compiler (Formatting (..), compileMsg)
+import qualified Intlc.ICU                  as ICU
+import           Prelude
+
+prettify :: ICU.Message -> Text
+prettify = compileMsg MultiLine