From c0421d6fd3965fe9c88223c67359ff611a938f26 Mon Sep 17 00:00:00 2001 From: "Sam A. Horvath-Hunt" Date: Wed, 19 Oct 2022 17:48:24 +0100 Subject: [PATCH 1/6] Refactor ICU compiler Now supports effectful recursion. The catamorphism cases are a bit easier to read now as well. --- lib/Intlc/Backend/ICU/Compiler.hs | 155 +++++++++++++++++++++++------- 1 file changed, 120 insertions(+), 35 deletions(-) diff --git a/lib/Intlc/Backend/ICU/Compiler.hs b/lib/Intlc/Backend/ICU/Compiler.hs index 8415ea0..2412ea5 100644 --- a/lib/Intlc/Backend/ICU/Compiler.hs +++ b/lib/Intlc/Backend/ICU/Compiler.hs @@ -12,44 +12,129 @@ 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 +node ast = runReader (cata go ast) (0 :: Int) where + go :: Monad m => NodeF (m Text) -> m Text + go = \case + FinF -> pure mempty -dateTimeFmt :: DateTimeFmt -> Text -dateTimeFmt Short = "short" -dateTimeFmt Medium = "medium" -dateTimeFmt Long = "long" -dateTimeFmt Full = "full" + (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 -> [Case] -> Text +cardinal n x = typedInterp "plural" n (pure . cases $ x) + +ordinal :: Arg -> [Case] -> Text +ordinal n x = typedInterp "selectordinal" n (pure . cases $ x) + +select :: Arg -> [Case] -> Text +select n x = typedInterp "select" n (pure . cases $ x) + +boolean :: Arg -> [Case] -> Text +boolean n x = typedInterp "boolean" n (pure . cases $ x) + +datetime :: Text -> Arg -> DateTimeFmt -> Text +datetime t n f = typedInterp t n (pure . dateTimeFmt $ f) + +date :: Arg -> DateTimeFmt -> Text +date = datetime "date" -exactPluralCase :: PluralCaseF PluralExact Text -> Text -exactPluralCase (PluralExact n, x) = "=" <> n <> " {" <> x <> "}" +time :: Arg -> DateTimeFmt -> Text +time = datetime "time" -rulePluralCase :: PluralCaseF PluralRule Text -> Text -rulePluralCase (r, x) = pluralRule r <> " {" <> x <> "}" +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) + +cases :: [Case] -> Text +cases = unwords . fmap (uncurry case') + +case' :: Text -> Text -> Text +case' n x = n <> " {" <> x <> "}" + +wildcard :: Text -> Case +wildcard = ("other",) + +selectCases :: (Traversable t, Applicative f) => t (SelectCaseF (f Text)) -> f [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, Applicative f) => t (PluralCaseF PluralExact (f Text)) -> f [Case] +exactPluralCases = fmap toList . traverse exactPluralCaseF + +exactPluralCaseF :: Functor f => PluralCaseF PluralExact (f Text) -> f Case +exactPluralCaseF (n, mx) = exactPluralCase . (n,) <$> mx + +exactPluralCase :: PluralCaseF PluralExact Text -> Case +exactPluralCase (PluralExact n, x) = ("=" <> n, x) + +rulePluralCases :: (Traversable t, Applicative f) => t (PluralCaseF PluralRule (f Text)) -> f [Case] +rulePluralCases = fmap toList . traverse rulePluralCaseF + +rulePluralCaseF :: Functor f => PluralCaseF PluralRule (f Text) -> f Case +rulePluralCaseF (r, mx) = rulePluralCase . (r,) <$> mx + +rulePluralCase :: PluralCaseF PluralRule Text -> Case +rulePluralCase = first pluralRule pluralRule :: PluralRule -> Text pluralRule Zero = "zero" @@ -58,8 +143,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" From 62ee73d772089705a31d073600683d4e4d426c98 Mon Sep 17 00:00:00 2001 From: "Sam A. Horvath-Hunt" Date: Fri, 21 Oct 2022 18:20:53 +0100 Subject: [PATCH 2/6] Add monadic type alias and thread effect through --- lib/Intlc/Backend/ICU/Compiler.hs | 54 +++++++++++++++++-------------- 1 file changed, 29 insertions(+), 25 deletions(-) diff --git a/lib/Intlc/Backend/ICU/Compiler.hs b/lib/Intlc/Backend/ICU/Compiler.hs index 2412ea5..af94959 100644 --- a/lib/Intlc/Backend/ICU/Compiler.hs +++ b/lib/Intlc/Backend/ICU/Compiler.hs @@ -17,9 +17,13 @@ import Utils ((<>^)) compileMsg :: Message -> Text compileMsg = node . unMessage -node :: Node -> Text -node ast = runReader (cata go ast) (0 :: Int) where - go :: Monad m => NodeF (m Text) -> m Text +type Indents = Int + +type Compiler = Reader Indents + +node :: Formatting -> Node -> Text +node fo ast = runReader (cata go ast) 0 where + go :: NodeF (Compiler Text) -> Compiler Text go = \case FinF -> pure mempty @@ -27,7 +31,7 @@ node ast = runReader (cata go ast) (0 :: Int) where (BoolF { nameF, trueCaseF, falseCaseF, nextF }) -> let cs = sequence [("true",) <$> trueCaseF, ("false",) <$> falseCaseF] - in (boolean nameF <$> cs) <>^ nextF + in (boolean nameF =<< cs) <>^ nextF (StringF n next) -> (string n <>) <$> next @@ -37,39 +41,39 @@ node ast = runReader (cata go ast) (0 :: Int) where (TimeF n fmt next) -> (time n fmt <>) <$> next - (CardinalExactF n xs next) -> (cardinal n <$> exactPluralCases xs) <>^ 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 + 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 + in (ordinal n =<< cs) <>^ next (PluralRefF _ next) -> ("#" <>) <$> next - (SelectNamedF n xs y) -> (select n <$> selectCases xs) <>^ y + (SelectNamedF n xs y) -> (select n =<< selectCases xs) <>^ y - (SelectWildF n w x) -> (select n . pure . wildcard <$> w) <>^ x + (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 + in (select n =<< cs) <>^ next (CallbackF n xs next) -> (callback n <$> xs) <>^ next -cardinal :: Arg -> [Case] -> Text -cardinal n x = typedInterp "plural" n (pure . cases $ x) +cardinal :: Arg -> [Case] -> Compiler Text +cardinal n x = typedInterp "plural" n <$> (pure <$> cases x) -ordinal :: Arg -> [Case] -> Text -ordinal n x = typedInterp "selectordinal" n (pure . cases $ x) +ordinal :: Arg -> [Case] -> Compiler Text +ordinal n x = typedInterp "selectordinal" n <$> (pure <$> cases x) -select :: Arg -> [Case] -> Text -select n x = typedInterp "select" n (pure . cases $ x) +select :: Arg -> [Case] -> Compiler Text +select n x = typedInterp "select" n <$> (pure <$> cases x) -boolean :: Arg -> [Case] -> Text -boolean n x = typedInterp "boolean" n (pure . cases $ x) +boolean :: Arg -> [Case] -> Compiler Text +boolean n x = typedInterp "boolean" n <$> (pure <$> cases x) datetime :: Text -> Arg -> DateTimeFmt -> Text datetime t n f = typedInterp t n (pure . dateTimeFmt $ f) @@ -100,8 +104,8 @@ callback n x = "<" <> unArg n <> ">" <> x <> " unArg n <> ">" type Case = (Text, Text) -cases :: [Case] -> Text -cases = unwords . fmap (uncurry case') +cases :: [Case] -> Compiler Text +cases = pure . unwords . fmap (uncurry case') case' :: Text -> Text -> Text case' n x = n <> " {" <> x <> "}" @@ -109,7 +113,7 @@ case' n x = n <> " {" <> x <> "}" wildcard :: Text -> Case wildcard = ("other",) -selectCases :: (Traversable t, Applicative f) => t (SelectCaseF (f Text)) -> f [Case] +selectCases :: Traversable t => t (SelectCaseF (Compiler Text)) -> Compiler [Case] selectCases = fmap toList . traverse selectCaseF selectCaseF :: Functor f => SelectCaseF (f Text) -> f Case @@ -118,19 +122,19 @@ selectCaseF (n, mx) = selectCase . (n,) <$> mx selectCase :: SelectCaseF Text -> Case selectCase = id -exactPluralCases :: (Traversable t, Applicative f) => t (PluralCaseF PluralExact (f Text)) -> f [Case] +exactPluralCases :: Traversable t => t (PluralCaseF PluralExact (Compiler Text)) -> Compiler [Case] exactPluralCases = fmap toList . traverse exactPluralCaseF -exactPluralCaseF :: Functor f => PluralCaseF PluralExact (f Text) -> f Case +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, Applicative f) => t (PluralCaseF PluralRule (f Text)) -> f [Case] +rulePluralCases :: Traversable t => t (PluralCaseF PluralRule (Compiler Text)) -> Compiler [Case] rulePluralCases = fmap toList . traverse rulePluralCaseF -rulePluralCaseF :: Functor f => PluralCaseF PluralRule (f Text) -> f Case +rulePluralCaseF :: PluralCaseF PluralRule (Compiler Text) -> Compiler Case rulePluralCaseF (r, mx) = rulePluralCase . (r,) <$> mx rulePluralCase :: PluralCaseF PluralRule Text -> Case From 41bd50c0a9e419cf05bbe0986081426e40523c78 Mon Sep 17 00:00:00 2001 From: "Sam A. Horvath-Hunt" Date: Sun, 23 Oct 2022 16:43:08 +0100 Subject: [PATCH 3/6] Support multiline/prettified ICU compilation output --- intlc.cabal | 2 + lib/Intlc/Backend/ICU/Compiler.hs | 60 ++++++++++++++++++++---------- lib/Intlc/Backend/JSON/Compiler.hs | 5 ++- lib/Intlc/Prettify.hs | 8 ++++ test/Intlc/EndToEndSpec.hs | 5 ++- test/Intlc/PrettifySpec.hs | 57 ++++++++++++++++++++++++++++ 6 files changed, 114 insertions(+), 23 deletions(-) create mode 100644 lib/Intlc/Prettify.hs create mode 100644 test/Intlc/PrettifySpec.hs diff --git a/intlc.cabal b/intlc.cabal index 9489808..52410a4 100644 --- a/intlc.cabal +++ b/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 diff --git a/lib/Intlc/Backend/ICU/Compiler.hs b/lib/Intlc/Backend/ICU/Compiler.hs index af94959..8b9c264 100644 --- a/lib/Intlc/Backend/ICU/Compiler.hs +++ b/lib/Intlc/Backend/ICU/Compiler.hs @@ -6,7 +6,7 @@ -- 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 @@ -14,15 +14,27 @@ import Intlc.ICU import Prelude import Utils ((<>^)) -compileMsg :: Message -> Text -compileMsg = node . unMessage +compileMsg :: Formatting -> Message -> Text +compileMsg x y = node x (unMessage y) -type Indents = Int +data Formatting + = SingleLine + | MultiLine -type Compiler = Reader Indents +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) 0 where +node fo ast = runReader (cata go ast) (Config fo 0) where go :: NodeF (Compiler Text) -> Compiler Text go = \case FinF -> pure mempty @@ -31,7 +43,7 @@ node fo ast = runReader (cata go ast) 0 where (BoolF { nameF, trueCaseF, falseCaseF, nextF }) -> let cs = sequence [("true",) <$> trueCaseF, ("false",) <$> falseCaseF] - in (boolean nameF =<< cs) <>^ nextF + in (boolean nameF cs) <>^ nextF (StringF n next) -> (string n <>) <$> next @@ -41,38 +53,38 @@ node fo ast = runReader (cata go ast) 0 where (TimeF n fmt next) -> (time n fmt <>) <$> next - (CardinalExactF n xs next) -> (cardinal n =<< exactPluralCases xs) <>^ 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 + 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 + in (ordinal n cs) <>^ next (PluralRefF _ next) -> ("#" <>) <$> next - (SelectNamedF n xs y) -> (select n =<< selectCases xs) <>^ y + (SelectNamedF n xs y) -> (select n $ selectCases xs) <>^ y - (SelectWildF n w x) -> (select n . pure . wildcard =<< w) <>^ x + (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 + in (select n cs) <>^ next (CallbackF n xs next) -> (callback n <$> xs) <>^ next -cardinal :: Arg -> [Case] -> Compiler Text +cardinal :: Arg -> Compiler [Case] -> Compiler Text cardinal n x = typedInterp "plural" n <$> (pure <$> cases x) -ordinal :: Arg -> [Case] -> Compiler Text +ordinal :: Arg -> Compiler [Case] -> Compiler Text ordinal n x = typedInterp "selectordinal" n <$> (pure <$> cases x) -select :: Arg -> [Case] -> Compiler Text +select :: Arg -> Compiler [Case] -> Compiler Text select n x = typedInterp "select" n <$> (pure <$> cases x) -boolean :: Arg -> [Case] -> Compiler Text +boolean :: Arg -> Compiler [Case] -> Compiler Text boolean n x = typedInterp "boolean" n <$> (pure <$> cases x) datetime :: Text -> Arg -> DateTimeFmt -> Text @@ -104,8 +116,18 @@ callback n x = "<" <> unArg n <> ">" <> x <> " unArg n <> ">" type Case = (Text, Text) -cases :: [Case] -> Compiler Text -cases = pure . unwords . fmap (uncurry case') +-- | 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 <> "}" diff --git a/lib/Intlc/Backend/JSON/Compiler.hs b/lib/Intlc/Backend/JSON/Compiler.hs index 25a7cc8..d6f3efc 100644 --- a/lib/Intlc/Backend/JSON/Compiler.hs +++ b/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) ] diff --git a/lib/Intlc/Prettify.hs b/lib/Intlc/Prettify.hs new file mode 100644 index 0000000..821aab5 --- /dev/null +++ b/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 diff --git a/test/Intlc/EndToEndSpec.hs b/test/Intlc/EndToEndSpec.hs index 37610d4..8a31beb 100644 --- a/test/Intlc/EndToEndSpec.hs +++ b/test/Intlc/EndToEndSpec.hs @@ -1,7 +1,8 @@ module Intlc.EndToEndSpec (spec) where import qualified Data.Text as T -import Intlc.Backend.ICU.Compiler (compileMsg) +import Intlc.Backend.ICU.Compiler (Formatting (SingleLine), + compileMsg) import Intlc.Compiler (compileDataset, expandPlurals) import Intlc.Core (Locale (Locale)) import Intlc.Parser (parseDataset) @@ -19,7 +20,7 @@ parseAndCompileDataset :: Text -> Either (NonEmpty Text) Text parseAndCompileDataset = compileDataset (Locale "en-US") <=< first (pure . show) . parseDataset "test" parseAndExpandMsg :: Text -> Either ParseFailure Text -parseAndExpandMsg = fmap (compileMsg . expandPlurals) . parseMsg +parseAndExpandMsg = fmap (compileMsg SingleLine . expandPlurals) . parseMsg where parseMsg = runParser (runReaderT msg (emptyState { endOfInput = eof })) "test" golden :: String -> Text -> Golden String diff --git a/test/Intlc/PrettifySpec.hs b/test/Intlc/PrettifySpec.hs new file mode 100644 index 0000000..af824c7 --- /dev/null +++ b/test/Intlc/PrettifySpec.hs @@ -0,0 +1,57 @@ +module Intlc.PrettifySpec where + +import qualified Data.Text as T +import Intlc.ICU +import Intlc.Prettify (prettify) +import Prelude +import Test.Hspec + +spec :: Spec +spec = describe "prettify" $ do + let f = prettify . Message + + it "compiles to ICU with multiline formatting" $ do + let ast = mconcat + [ Bool' "hasTags" + (SelectNamed' "type" + (fromList + [ ("overLimit", mconcat [Number' "upperLimit", "+ best free ", String' "formattedListOfTags", " photos on Unsplash"]) + , ("belowLimit", mconcat [Number' "photoTotal", " best free ", String' "formattedListOfTags", " photos on Unsplash"]) + ] + ) + ) + (SelectNamed' "type" + (fromList + [ ("overLimit", mconcat [Number' "upperLimit", "+ best free photos on Unsplash"]) + , ("belowLimit", mconcat [Number' "photoTotal", " best free photos on Unsplash"]) + ] + ) + ) + , " " + , SelectNamed' "sibling" + (fromList + [ ("a", String' "foo") + , ("b", "bar") + ] + ) + ] + let toTabs = T.replace " " "\t" + -- Can't use QuasiQuotes as stylish-haskell removes the trailing whitespace + -- which exists in the current implementation. + let expected = T.intercalate "\n" + [ "{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}" + , " }}" + , "} {sibling, select, " + , " a {{foo}}" + , " b {bar}" + , "}" + ] + -- Some trailing spaces are expected with the current implementation. + f ast `shouldBe` toTabs expected From 17dac5602f21ed9941ac9071ff696d553bff64eb Mon Sep 17 00:00:00 2001 From: "Sam A. Horvath-Hunt" Date: Sun, 23 Oct 2022 16:43:47 +0100 Subject: [PATCH 4/6] Add prettify CLI command --- cli/CLI.hs | 14 +++++++++++--- cli/Main.hs | 7 ++++++- lib/Intlc/Parser.hs | 6 ++++++ lib/Intlc/Parser/ICU.hs | 8 ++++++++ 4 files changed, 31 insertions(+), 4 deletions(-) diff --git a/cli/CLI.hs b/cli/CLI.hs index 7475c48..c947f2a 100644 --- a/cli/CLI.hs +++ b/cli/CLI.hs @@ -8,6 +8,7 @@ data Opts = Compile FilePath Locale | Flatten FilePath | Lint FilePath + | Prettify Text getOpts :: IO Opts getOpts = execParser (info (opts <**> helper) (progDesc h)) @@ -15,9 +16,10 @@ getOpts = execParser (info (opts <**> helper) (progDesc h)) 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 diff --git a/cli/Main.hs b/cli/Main.hs index 6547170..02d2959 100644 --- a/cli/Main.hs +++ b/cli/Main.hs @@ -5,8 +5,9 @@ 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 () @@ -14,6 +15,7 @@ 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 diff --git a/lib/Intlc/Parser.hs b/lib/Intlc/Parser.hs index 04a3cd7..2e7c294 100644 --- a/lib/Intlc/Parser.hs +++ b/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 diff --git a/lib/Intlc/Parser/ICU.hs b/lib/Intlc/Parser/ICU.hs index 79e62c4..fd3cf85 100644 --- a/lib/Intlc/Parser/ICU.hs +++ b/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 From 1455ac15f2e1dd1202bf478249931a40f6374069 Mon Sep 17 00:00:00 2001 From: "Sam A. Horvath-Hunt" Date: Mon, 24 Oct 2022 12:12:56 +0100 Subject: [PATCH 5/6] Formatting --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index bb0e7c2..fdf6867 100644 --- a/README.md +++ b/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,7 +59,7 @@ 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 From ad7cd5461e4d7ca1c7f725855c4b7234810f7f11 Mon Sep 17 00:00:00 2001 From: "Sam A. Horvath-Hunt" Date: Mon, 24 Oct 2022 12:16:29 +0100 Subject: [PATCH 6/6] Add formatting to README --- README.md | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/README.md b/README.md index fdf6867..9f4dae4 100644 --- a/README.md +++ b/README.md @@ -65,6 +65,27 @@ 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: