diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +# 0.6 + +* Switched to `Buildable` from `formatting` (since `text-format` is + unmaintained). + +* Removed the `double-conversion` dependency (which was sometimes causing + compilation issues). As the result, `exptF`, `fixedF` and `floatF` have + become slower. + +* The `precF` formatter was removed completely because its semantics was too + confusing. You can use `Numeric.showGFloat` to achieve a similar effect. + +* `floatF` now always prints a point, even if the number is integral. + +* `tupleLikeF` has been removed. `TupleF` now has an additional instance + that lets `tupleF` be used to format lists. + +* The `base16-bytestring` dependency was removed. + +* Compatibility with GHC 7.6 and 7.8 was dropped. + # 0.5.0.0 * From this version on, `blockListF` never puts blank lines between items. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -10,10 +10,7 @@ import Data.String.Interpolate (i) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Format as TF -import Data.Text.Format.Params as TF -import qualified Data.Text.Lazy as LT -import Fmt ((+|), (|+)) +import Fmt ((+|), (|+), format) import Formatting (Format, formatToString, int, sformat, stext, string, (%)) import Text.Printf (printf) @@ -25,12 +22,6 @@ -- Format utility functions ---------------------------------------------------------------------------- -format' :: TF.Params ps => TF.Format -> ps -> Text -format' f = LT.toStrict . TF.format f - -formatS :: TF.Params ps => TF.Format -> ps -> String -formatS f = LT.unpack . TF.format f - -- Shorter alias for @formatToString@. fs :: Format String a -> a fs = formatToString @@ -69,10 +60,10 @@ [ bTextGroup (1 :: Int, 2 :: Int) [ taggedB "fmt" $ \(a,b) -> "hello "+|a|+" world "+|b|+"" + , taggedB "fmt old-style" $ + \(a,b) -> format "hello {} world {}" a b :: Text , taggedB "formatting" $ \(a,b) -> sformat ("hello "%int%" world "%int) a b - , taggedB "text-format" $ - format' "hello {} world {}" , taggedB "interpolate" $ \(a,b) -> T.pack [i|hello #{a} world #{b}|] , taggedB "show" $ @@ -83,10 +74,10 @@ , bStringGroup (1 :: Int, 2 :: Int) [ taggedB "fmt" $ \(a,b) -> "hello "+|a|+" world "+|b|+"" + , taggedB "fmt old-style" $ + \(a,b) -> format "hello {} world {}" a b :: String , taggedB "formatting" $ \(a,b) -> fs ("hello "%int%" world "%int) a b - , taggedB "text-format" $ - formatS "hello {} world {}" , taggedB "interpolate" $ \(a,b) -> [i|hello #{a} world #{b}|] , taggedB "show" $ @@ -100,10 +91,10 @@ [ bTextGroup (9 :: Int, "Beijing" :: Text) [ taggedB "fmt" $ \(n,city) -> "There are "+|n|+" million bicycles in "+|city|+"." + , taggedB "fmt old-style" $ + \(n,city) -> format "There are {} million bicycles in {}." n city :: Text , taggedB "formatting" $ \(n,city) -> sformat ("There are "%int%" million bicycles in "%stext%".") n city - , taggedB "text-format" $ - format' "There are {} million bicycles in {}." , taggedB "interpolate" $ \(n,city) -> T.pack [i|There are #{n} million bicycles in #{city}.|] , taggedB "show" $ @@ -114,10 +105,10 @@ , bStringGroup (9 :: Int, "Beijing" :: String) [ taggedB "fmt" $ \(n,city) -> "There are "+|n|+" million bicycles in "+|city|+"." + , taggedB "fmt old-style" $ + \(n,city) -> format "There are {} million bicycles in {}." n city :: String , taggedB "formatting" $ \(n,city) -> fs ("There are "%int%" million bicycles in "%string%".") n city - , taggedB "text-format" $ - formatS "There are {} million bicycles in {}." , taggedB "interpolate" $ \(n,city) -> [i|There are #{n} million bicycles in #{city}.|] , taggedB "show" $ diff --git a/fmt.cabal b/fmt.cabal --- a/fmt.cabal +++ b/fmt.cabal @@ -1,5 +1,5 @@ name: fmt -version: 0.5.0.0 +version: 0.6 synopsis: A new formatting library description: A new formatting library that tries to be simple to understand while still @@ -16,7 +16,7 @@ compile-time if you pass wrong arguments or not enough of them. . * takes a - formatting string with angle brackets denoting places where arguments + formatting string with curly braces denoting places where arguments would be substituted (the arguments themselves are provided via a tuple). If you want to apply formatting to some of the arguments, you have to use one of the provided formatters. Like @printf@, it can fail at @@ -46,9 +46,10 @@ maintainer: yom@artyom.me -- copyright: category: Text -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1 +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 build-type: Simple extra-source-files: CHANGELOG.md + tests/doctest-config.json cabal-version: >=1.10 source-repository head @@ -57,39 +58,61 @@ library exposed-modules: Fmt - Fmt.Internal Fmt.Time + Fmt.Internal + Fmt.Internal.Core + Fmt.Internal.Formatters + Fmt.Internal.Template + Fmt.Internal.Tuple + Fmt.Internal.Numeric + Fmt.Internal.Generic + build-depends: base >=4.6 && <5, - base16-bytestring, base64-bytestring, bytestring, containers, + formatting >= 6.3.4, microlens >= 0.3, text, - text-format >= 0.3, time, time-locale-compat + ghc-options: -Wall -fno-warn-unused-do-bind if impl(ghc > 8.0) ghc-options: -Wno-redundant-constraints hs-source-dirs: lib default-language: Haskell2010 + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* test-suite tests main-is: Main.hs type: exitcode-stdio-1.0 build-depends: base >=4.6 && <5 , bytestring + , call-stack , containers , fmt - , hspec >= 2.2 && < 2.5 + , hspec >= 2.2 && < 2.6 , neat-interpolation , text , vector + ghc-options: -Wall -fno-warn-unused-do-bind + hs-source-dirs: tests default-language: Haskell2010 - if impl(ghc < 7.10) + +test-suite doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base >=4.6 && <5 + , doctest + build-tool-depends: doctest-discover:doctest-discover + if impl(ghc < 8.0) buildable: False benchmark benches @@ -105,9 +128,6 @@ , formatting , interpolate , text - , text-format , vector ghc-options: -Wall default-language: Haskell2010 - if impl(ghc < 7.10) - buildable: False diff --git a/lib/Fmt.hs b/lib/Fmt.hs --- a/lib/Fmt.hs +++ b/lib/Fmt.hs @@ -18,1306 +18,329 @@ -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -# define _OVERLAPPING_ -# define _OVERLAPPABLE_ -# define _OVERLAPS_ -#else -# define _OVERLAPPING_ {-# OVERLAPPING #-} -# define _OVERLAPPABLE_ {-# OVERLAPPABLE #-} -# define _OVERLAPS_ {-# OVERLAPS #-} -#endif - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Fmt -( - -- * Overloaded strings - -- $overloadedstrings - - -- * Examples - -- $examples - - -- * Migration guide from @formatting@ - -- $migration - - -- * Basic formatting - -- $brackets - - -- ** Ordinary brackets - -- $god1 - (+|), - (|+), - -- ** 'Show' brackets - -- $god2 - (+||), - (||+), - -- ** Combinations - -- $god3 - (|++|), - (||++||), - (|++||), - (||++|), - - -- * Old-style formatting - format, - formatLn, - TF.Format, - - -- * Helper functions - fmt, - fmtLn, - - Builder, - Buildable(..), - - -- * Formatters - - -- ** Time - module Fmt.Time, - - -- ** Text - indentF, indentF', - nameF, - unwordsF, - unlinesF, - - -- ** Lists - listF, listF', - blockListF, blockListF', - jsonListF, jsonListF', - - -- ** Maps - mapF, mapF', - blockMapF, blockMapF', - jsonMapF, jsonMapF', - - -- ** Tuples - tupleF, - tupleLikeF, - - -- ** ADTs - maybeF, - eitherF, - - -- ** Padding/trimming - prefixF, - suffixF, - padLeftF, - padRightF, - padBothF, - - -- ** Hex - hexF, - - -- ** Bytestrings - base64F, - base64UrlF, - - -- ** Integers - ordinalF, - commaizeF, - -- *** Base conversion - octF, - binF, - baseF, - - -- ** Floating-point - floatF, - exptF, - precF, - fixedF, - - -- ** Conditional formatting - whenF, - unlessF, - - -- ** Generic formatting - genericF, -) -where - --- Generic useful things -import Data.List -import Data.Monoid -import Lens.Micro --- Containers -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.Sequence (Seq) --- Text -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL --- 'Buildable' and text-format -import Data.Text.Buildable -import qualified Data.Text.Format as TF --- Text 'Builder' -import Data.Text.Lazy.Builder hiding (fromString) --- 'Foldable' and 'IsList' for list/map formatters -import Data.Foldable (toList) -#if __GLASGOW_HASKELL__ >= 708 -import GHC.Exts (IsList, Item) -import qualified GHC.Exts as IsList (toList) -#endif --- Generics -import GHC.Generics - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (Foldable) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.List.NonEmpty (NonEmpty) -#endif - -import Fmt.Internal -import Fmt.Time - - -{- $overloadedstrings - -You need @OverloadedStrings@ enabled to use this library. There are three -ways to do it: - - * __In GHCi:__ do @:set -XOverloadedStrings@. - - * __In a module:__ add @\{\-\# LANGUAGE OverloadedStrings \#\-\}@ - to the beginning of your module. - - * __In a project:__ add @OverloadedStrings@ to the @default-extensions@ - section of your @.cabal@ file. --} - -{- $examples - -Here's a bunch of examples because some people learn better by looking at -examples. - -Insert some variables into a string: - ->>> let (a, b, n) = ("foo", "bar", 25) ->>> ("Here are some words: "+|a|+", "+|b|+"\nAlso a number: "+|n|+"") :: String -"Here are some words: foo, bar\nAlso a number: 25" - -Print it: - ->>> fmtLn ("Here are some words: "+|a|+", "+|b|+"\nAlso a number: "+|n|+"") -Here are some words: foo, bar -Also a number: 25 - -Format a list in various ways: - ->>> let xs = ["John", "Bob"] - ->>> fmtLn ("Using show: "+||xs||+"\nUsing listF: "+|listF xs|+"") -Using show: ["John","Bob"] -Using listF: [John, Bob] - ->>> fmt ("YAML-like:\n"+|blockListF xs|+"") -YAML-like: -- John -- Bob - ->>> fmt ("JSON-like: "+|jsonListF xs|+"") -JSON-like: [ - John -, Bob -] - --} - -{- $migration - -Instead of using @%@, surround variables with '+|' and '|+'. You don't have -to use @sformat@ or anything else, and also where you were using @build@, -@int@, @text@, etc in @formatting@, you don't have to use anything in @fmt@: - -@ -formatting __sformat ("Foo: "%build%", bar: "%int) foo bar__ - fmt __"Foo: "+|foo|+", bar: "+|bar|+""__ -@ - -The resulting formatted string is polymorphic and can be used as 'String', -'Text', 'Builder' or even 'IO' (i.e. the string will be printed to the -screen). However, when printing it is recommended to use 'fmt' or 'fmtLn' -for clarity. - -@fmt@ provides lots of formatters (which are simply functions that produce -'Builder'): - -@ -formatting __sformat ("Got another byte ("%hex%")") x__ - fmt __"Got another byte ("+|hexF x|+")"__ -@ - -Instead of the @shown@ formatter, either just use 'show' or double brackets: - -@ -formatting __sformat ("This uses Show: "%shown%") foo__ - fmt #1 __"This uses Show: "+|show foo|+""__ - fmt #2 __"This uses Show: "+||foo||+""__ -@ - -Many formatters from @formatting@ have the same names in @fmt@, but with -added “F”: 'hexF', 'exptF', etc. Some have been renamed, though: - -@ -__Cutting:__ - fitLeft -\> 'prefixF' - fitRight -\> 'suffixF' - -__Padding:__ - left -\> 'padLeftF' - right -\> 'padRightF' - center -\> 'padBothF' - -__Stuff with numbers:__ - ords -\> 'ordinalF' - commas -\> 'commaizeF' -@ - -Also, some formatters from @formatting@ haven't been added to @fmt@ -yet. Specifically: - -* @plural@ and @asInt@ (but instead of @asInt@ you can use 'fromEnum') -* @prefixBin@, @prefixOrd@, @prefixHex@, and @bytes@ -* formatters that use @Scientific@ (@sci@ and @scifmt@) - -They will be added later. (On the other hand, @fmt@ provides some useful -formatters not available in @formatting@, such as 'listF', 'mapF', 'tupleF' -and so on.) --} - ----------------------------------------------------------------------------- --- Operators with 'Buildable' ----------------------------------------------------------------------------- - -{- $brackets - -To format strings, put variables between ('+|') and ('|+'): - ->>> let name = "Alice" ->>> "Meet "+|name|+"!" :: String -"Meet Alice!" - -Of course, 'Text' is supported as well: - ->>> "Meet "+|name|+"!" :: Text -"Meet Alice!" - -You don't actually need any type signatures; however, if you're toying with -this library in GHCi, it's recommended to either add a type signature or use -'fmtLn': - ->>> fmtLn ("Meet "+|name|+"!") -Meet Alice! - -Otherwise the type of the formatted string would be resolved to @IO ()@ and -printed without a newline, which is not very convenient when you're in GHCi. -On the other hand, it's useful for quick-and-dirty scripts: - -@ -main = do - [fin, fout] \<- words \<$\> getArgs - __"Reading data from "+|fin|+"\\n"__ - xs \<- readFile fin - __"Writing processed data to "+|fout|+"\\n"__ - writeFile fout (show (process xs)) -@ - -Anyway, let's proceed. Anything 'Buildable', including numbers, booleans, -characters and dates, can be put between ('+|') and ('|+'): - ->>> let starCount = "173" ->>> fmtLn ("Meet "+|name|+"! She's got "+|starCount|+" stars on Github.") -"Meet Alice! She's got 173 stars on Github." - -Since the only thing ('+|') and ('|+') do is concatenate strings and do -conversion, you can use any functions you want inside them. In this case, -'length': - ->>> fmtLn (""+|name|+"'s name has "+|length name|+" letters") -Alice's name has 5 letters - -If something isn't 'Buildable', just use 'show' on it: - ->>> let pos = (3, 5) ->>> fmtLn ("Character's position: "+|show pos|+"") -Character's position: (3,5) - -Or one of many formatters provided by this library – for instance, for tuples -of various sizes there's 'tupleF': - ->>> fmtLn ("Character's position: "+|tupleF pos|+"") -Character's position: (3, 5) - -Finally, for convenience there's the ('|++|') operator, which can be used if -you've got one variable following the other: - ->>> let (a, op, b, res) = (2, "*", 2, 4) ->>> fmtLn (""+|a|++|op|++|b|+" = "+|res|+"") -2*2 = 4 - -Also, since in some codebases there are /lots/ of types which aren't -'Buildable', there are operators ('+||') and ('||+'), which use 'show' -instead of 'build': - -@ -__(""+|show foo|++|show bar|+"")__ === __(""+||foo||++||bar||+"")__ -@ --} - --- $god1 --- Operators for the operators god! - --- | Concatenate, then convert -(+|) :: (FromBuilder b) => Builder -> Builder -> b -(+|) str rest = fromBuilder (str <> rest) - --- | 'build' and concatenate, then convert -(|+) :: (Buildable a, FromBuilder b) => a -> Builder -> b -(|+) a rest = fromBuilder (build a <> rest) - -infixr 1 +| -infixr 1 |+ - ----------------------------------------------------------------------------- --- Operators with 'Show' ----------------------------------------------------------------------------- - --- $god2 --- More operators for the operators god! - --- | Concatenate, then convert -(+||) :: (FromBuilder b) => Builder -> Builder -> b -(+||) str rest = str +| rest -{-# INLINE (+||) #-} - --- | 'show' and concatenate, then convert -(||+) :: (Show a, FromBuilder b) => a -> Builder -> b -(||+) a rest = show a |+ rest -{-# INLINE (||+) #-} - -infixr 1 +|| -infixr 1 ||+ - ----------------------------------------------------------------------------- --- Combinations ----------------------------------------------------------------------------- - -{- $god3 - -Z̸͠A̵̕͟͠L̡̀́͠G̶̛O͝ ̴͏̀ I͞S̸̸̢͠  ̢̛͘͢C̷͟͡Ó̧̨̧͞M̡͘͟͞I̷͜N̷̕G̷̀̕ - -(Though you can just use @""@ between @+| |+@ instead of using these -operators, and Show-brackets don't have to be used at all because there's -'show' available.) --} - -(|++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b -(|++|) a rest = fromBuilder (build a <> rest) -{-# INLINE (|++|) #-} - -(||++||) :: (Show a, FromBuilder b) => a -> Builder -> b -(||++||) a rest = show a |+ rest -{-# INLINE (||++||) #-} - -(||++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b -(||++|) a rest = a |++| rest -{-# INLINE (||++|) #-} - -(|++||) :: (Show a, FromBuilder b) => a -> Builder -> b -(|++||) a rest = a ||++|| rest -{-# INLINE (|++||) #-} - -infixr 1 |++| -infixr 1 ||++|| -infixr 1 ||++| -infixr 1 |++|| - ----------------------------------------------------------------------------- --- Old-style formatting ----------------------------------------------------------------------------- - -{- | An old-style formatting function taken from @text-format@ (see -"Data.Text.Format"). Unlike 'Data.Text.Format.format' from -"Data.Text.Format", it can produce 'String' and strict 'Text' as well (and -print to console too). Also it's polyvariadic: - ->>> format "{} + {} = {}" 2 2 4 -"2 + 2 = 4" - -You can use arbitrary formatters: - ->>> format "0x{} + 0x{} = 0x{}" (hexF 130) (hexF 270) (hexF (130+270)) -"0x82 + 0x10e = 0x190" --} -format :: FormatType r => TF.Format -> r -format f = format' f [] -{-# INLINE format #-} - -{- | Like 'format', but adds a newline. --} -formatLn :: FormatType r => TF.Format -> r -formatLn f = format' (f <> "\n") [] -{-# INLINE formatLn #-} - ----------------------------------------------------------------------------- --- Helper functions ----------------------------------------------------------------------------- - -{- | 'fmt' converts things to 'String', 'Text' or 'Builder'. - -Most of the time you won't need it, as strings produced with ('+|') and -('|+') can already be used as 'String', 'Text', etc. However, combinators -like 'listF' can only produce 'Builder' (for better type inference), and you -need to use 'fmt' on them. - -Also, 'fmt' can do printing: - ->>> fmt "Hello world!\n" -Hello world! --} -fmt :: FromBuilder b => Builder -> b -fmt = fromBuilder -{-# INLINE fmt #-} - -{- | Like 'fmt', but appends a newline. --} -fmtLn :: FromBuilder b => Builder -> b -fmtLn = fromBuilder . (<> "\n") -{-# INLINE fmtLn #-} - ----------------------------------------------------------------------------- --- Text formatters ----------------------------------------------------------------------------- - -{- | -Indent a block of text. - ->>> fmt $ "This is a list:\n" <> indentF 4 (blockListF [1,2,3]) -This is a list: - - 1 - - 2 - - 3 - -The output will always end with a newline, even when the input doesn't. --} -indentF :: Int -> Builder -> Builder -indentF n a = case TL.lines (toLazyText a) of - [] -> fromLazyText (spaces <> "\n") - xs -> fromLazyText $ TL.unlines (map (spaces <>) xs) - where - spaces = TL.replicate (fromIntegral n) (TL.singleton ' ') - -{- | Attach a name to anything: - ->>> fmt $ nameF "clients" $ blockListF ["Alice", "Bob", "Zalgo"] -clients: - - Alice - - Bob - - Zalgo --} -nameF :: Builder -> Builder -> Builder -nameF k v = case TL.lines (toLazyText v) of - [] -> k <> ":\n" - [l] -> k <> ": " <> fromLazyText l <> "\n" - ls -> k <> ":\n" <> - mconcat [" " <> fromLazyText s <> "\n" | s <- ls] - -{- | Put words between elements. - ->>> fmt $ unwordsF ["hello", "world"] -hello world - -Of course, it works on anything 'Buildable': - ->>> fmt $ unwordsF [1, 2] -1 2 --} -unwordsF :: (Foldable f, Buildable a) => f a -> Builder -unwordsF = mconcat . intersperse " " . map build . toList - -{-# SPECIALIZE unwordsF :: Buildable a => [a] -> Builder #-} - -{- | Arrange elements on separate lines. - ->>> fmt $ unlines ["hello", "world"] -hello -world --} -unlinesF :: (Foldable f, Buildable a) => f a -> Builder -unlinesF = mconcat . map (nl . build) . toList - where - nl x | "\n" `TL.isSuffixOf` toLazyText x = x - | otherwise = x <> "\n" - -{-# SPECIALIZE unlinesF :: Buildable a => [a] -> Builder #-} - ----------------------------------------------------------------------------- --- List formatters ----------------------------------------------------------------------------- - -{- | A simple comma-separated list formatter. - ->>> listF ["hello", "world"] -"[hello, world]" - -For multiline output, use 'jsonListF'. --} -listF :: (Foldable f, Buildable a) => f a -> Builder -listF = listF' build -{-# INLINE listF #-} - -{- | A version of 'listF' that lets you supply your own building function for -list elements. - -For instance, to format a list of lists you'd have to do this (since there's -no 'Buildable' instance for lists): - ->>> listF' listF [[1,2,3],[4,5,6]] -"[[1, 2, 3], [4, 5, 6]]" --} -listF' :: (Foldable f) => (a -> Builder) -> f a -> Builder -listF' fbuild xs = mconcat $ - "[" : - intersperse ", " (map fbuild (toList xs)) ++ - ["]"] - -{-# SPECIALIZE listF' :: (a -> Builder) -> [a] -> Builder #-} - -{- Note [Builder appending] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The documentation for 'Builder' says that it's preferrable to associate -'Builder' appends to the right (i.e. @a <> (b <> c)@). The maximum possible -association-to-the-right is achieved when we avoid appending builders until -the last second (i.e. in the latter scenario): - - -- (a1 <> x) <> (a2 <> x) <> ... - mconcat [a <> x | a <- as] - - -- a1 <> x <> a2 <> x <> ... - mconcat $ concat [[a, x] | a <- as] - -However, benchmarks have shown that the former way is actually faster. --} - -{- | A multiline formatter for lists. - ->>> fmt $ blockListF [1,2,3] -- 1 -- 2 -- 3 - -Multi-line elements are indented correctly: - -@ ->>> __fmt $ blockListF ["hello\\nworld", "foo\\nbar\\nquix"]__ -- hello - world -- foo - bar - quix -@ --} -blockListF :: forall f a. (Foldable f, Buildable a) => f a -> Builder -blockListF = blockListF' "-" build -{-# INLINE blockListF #-} - -{- | A version of 'blockListF' that lets you supply your own building function -for list elements (instead of 'build') and choose the bullet character -(instead of @"-"@). --} -blockListF' - :: forall f a. Foldable f - => T.Text -- ^ Bullet - -> (a -> Builder) -- ^ Builder for elements - -> f a -- ^ Structure with elements - -> Builder -blockListF' bullet fbuild xs = if null items then "[]\n" else mconcat items - where - items = map buildItem (toList xs) - spaces = mconcat $ replicate (T.length bullet + 1) (singleton ' ') - buildItem x = case TL.lines (toLazyText (fbuild x)) of - [] -> bullet |+ "\n" - (l:ls) -> bullet |+ " " +| l |+ "\n" <> - mconcat [spaces <> fromLazyText s <> "\n" | s <- ls] - -{-# SPECIALIZE blockListF' :: T.Text -> (a -> Builder) -> [a] -> Builder #-} - -{- | A JSON-style formatter for lists. - ->>> fmt $ jsonListF [1,2,3] -[ - 1 -, 2 -, 3 -] - -Like 'blockListF', it handles multiline elements well: - ->>> fmt $ jsonListF ["hello\nworld", "foo\nbar\nquix"] -[ - hello - world -, foo - bar - quix -] --} -jsonListF :: forall f a. (Foldable f, Buildable a) => f a -> Builder -jsonListF = jsonListF' build -{-# INLINE jsonListF #-} - -{- | A version of 'jsonListF' that lets you supply your own building function -for list elements. --} -jsonListF' :: forall f a. (Foldable f) => (a -> Builder) -> f a -> Builder -jsonListF' fbuild xs - | null items = "[]\n" - | otherwise = "[\n" <> mconcat items <> "]\n" - where - items = zipWith buildItem (True : repeat False) (toList xs) - -- Item builder - buildItem :: Bool -> a -> Builder - buildItem isFirst x = - case map fromLazyText (TL.lines (toLazyText (fbuild x))) of - [] | isFirst -> "\n" - | otherwise -> ",\n" - ls -> - mconcat . map (<> "\n") $ - ls & _head %~ (if isFirst then (" " <>) else (", " <>)) - & _tail.each %~ (" " <>) - -{-# SPECIALIZE jsonListF' :: (a -> Builder) -> [a] -> Builder #-} - ----------------------------------------------------------------------------- --- Map formatters ----------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 708 -# define MAPTOLIST IsList.toList -#else -# define MAPTOLIST id -#endif - -{- | A simple JSON-like map formatter; works for Map, HashMap, etc, as well as -ordinary lists of pairs. - ->>> mapF [("a", 1), ("b", 4)] -"{a: 1, b: 4}" - -For multiline output, use 'jsonMapF'. --} -mapF :: -#if __GLASGOW_HASKELL__ >= 708 - (IsList t, Item t ~ (k, v), Buildable k, Buildable v) => t -> Builder -#else - (Buildable k, Buildable v) => [(k, v)] -> Builder -#endif -mapF = mapF' build build -{-# INLINE mapF #-} - -{- | A version of 'mapF' that lets you supply your own building function for -keys and values. --} -mapF' :: -#if __GLASGOW_HASKELL__ >= 708 - (IsList t, Item t ~ (k, v)) => - (k -> Builder) -> (v -> Builder) -> t -> Builder -#else - (k -> Builder) -> (v -> Builder) -> [(k, v)] -> Builder -#endif -mapF' fbuild_k fbuild_v xs = - "{" <> mconcat (intersperse ", " (map buildPair (MAPTOLIST xs))) <> "}" - where - buildPair (k, v) = fbuild_k k <> ": " <> fbuild_v v - -{- | A YAML-like map formatter: - ->>> fmt $ blockMapF [("Odds", blockListF [1,3]), ("Evens", blockListF [2,4])] -Odds: - - 1 - - 3 -Evens: - - 2 - - 4 --} -blockMapF :: -#if __GLASGOW_HASKELL__ >= 708 - (IsList t, Item t ~ (k, v), Buildable k, Buildable v) => t -> Builder -#else - (Buildable k, Buildable v) => [(k, v)] -> Builder -#endif -blockMapF = blockMapF' build build -{-# INLINE blockMapF #-} - -{- | A version of 'blockMapF' that lets you supply your own building function -for keys and values. --} -blockMapF' :: -#if __GLASGOW_HASKELL__ >= 708 - (IsList t, Item t ~ (k, v)) => - (k -> Builder) -> (v -> Builder) -> t -> Builder -#else - (k -> Builder) -> (v -> Builder) -> [(k, v)] -> Builder -#endif -blockMapF' fbuild_k fbuild_v xs - | null items = "{}\n" - | otherwise = mconcat items - where - items = map (\(k, v) -> nameF (fbuild_k k) (fbuild_v v)) (MAPTOLIST xs) - -{- | A JSON-like map formatter (unlike 'mapF', always multiline): - ->>> fmt $ jsonMapF [("Odds", jsonListF [1,3]), ("Evens", jsonListF [2,4])] -{ - Odds: - [ - 1 - , 3 - ] -, Evens: - [ - 2 - , 4 - ] -} --} -jsonMapF :: -#if __GLASGOW_HASKELL__ >= 708 - (IsList t, Item t ~ (k, v), Buildable k, Buildable v) => t -> Builder -#else - (Buildable k, Buildable v) => [(k, v)] -> Builder -#endif -jsonMapF = jsonMapF' build build -{-# INLINE jsonMapF #-} - -{- | A version of 'jsonMapF' that lets you supply your own building function -for keys and values. --} -jsonMapF' :: -#if __GLASGOW_HASKELL__ >= 708 - forall t k v. - (IsList t, Item t ~ (k, v)) => - (k -> Builder) -> (v -> Builder) -> t -> Builder -#else - forall k v. - (k -> Builder) -> (v -> Builder) -> [(k, v)] -> Builder -#endif -jsonMapF' fbuild_k fbuild_v xs - | null items = "{}\n" - | otherwise = "{\n" <> mconcat items <> "}\n" - where - items = zipWith buildItem (True : repeat False) (MAPTOLIST xs) - -- Item builder - buildItem :: Bool -> (k, v) -> Builder - buildItem isFirst (k, v) = do - let kb = (if isFirst then " " else ", ") <> fbuild_k k - case map fromLazyText (TL.lines (toLazyText (fbuild_v v))) of - [] -> kb <> ":\n" - [l] -> kb <> ": " <> l <> "\n" - ls -> kb <> ":\n" <> - mconcat [" " <> s <> "\n" | s <- ls] - ----------------------------------------------------------------------------- --- Tuple formatters ----------------------------------------------------------------------------- - -instance (Buildable a1, Buildable a2) - => TupleF (a1, a2) where - tupleF (a1, a2) = tupleLikeF - [build a1, build a2] - -instance (Buildable a1, Buildable a2, Buildable a3) - => TupleF (a1, a2, a3) where - tupleF (a1, a2, a3) = tupleLikeF - [build a1, build a2, build a3] - -instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4) - => TupleF (a1, a2, a3, a4) where - tupleF (a1, a2, a3, a4) = tupleLikeF - [build a1, build a2, build a3, build a4] - -instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, - Buildable a5) - => TupleF (a1, a2, a3, a4, a5) where - tupleF (a1, a2, a3, a4, a5) = tupleLikeF - [build a1, build a2, build a3, build a4, - build a5] - -instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, - Buildable a5, Buildable a6) - => TupleF (a1, a2, a3, a4, a5, a6) where - tupleF (a1, a2, a3, a4, a5, a6) = tupleLikeF - [build a1, build a2, build a3, build a4, - build a5, build a6] - -instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, - Buildable a5, Buildable a6, Buildable a7) - => TupleF (a1, a2, a3, a4, a5, a6, a7) where - tupleF (a1, a2, a3, a4, a5, a6, a7) = tupleLikeF - [build a1, build a2, build a3, build a4, - build a5, build a6, build a7] - -instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, - Buildable a5, Buildable a6, Buildable a7, Buildable a8) - => TupleF (a1, a2, a3, a4, a5, a6, a7, a8) where - tupleF (a1, a2, a3, a4, a5, a6, a7, a8) = tupleLikeF - [build a1, build a2, build a3, build a4, - build a5, build a6, build a7, build a8] - -{- | -Format a list like a tuple. (This function is used to define 'tupleF'.) --} -tupleLikeF :: [Builder] -> Builder -tupleLikeF xs - | True `elem` mls = mconcat (intersperse ",\n" items) - | otherwise = "(" <> mconcat (intersperse ", " xs) <> ")" - where - (mls, items) = unzip $ zipWith3 buildItem - xs (set _head True falses) (set _last True falses) - -- A list of 'False's which has the same length as 'xs' - falses = map (const False) xs - -- Returns 'True' if the item is multiline - buildItem :: Builder - -> Bool -- ^ Is the item the first? - -> Bool -- ^ Is the item the last? - -> (Bool, Builder) - buildItem x isFirst isLast = - case map fromLazyText (TL.lines (toLazyText x)) of - [] | isFirst && isLast -> (False, "()\n") - | isFirst -> (False, "(\n") - | isLast -> (False, " )\n") - | otherwise -> (False, "") - ls -> - (not (null (tail ls)), - mconcat . map (<> "\n") $ - ls & _head %~ (if isFirst then ("( " <>) else (" " <>)) - & _tail.each %~ (" " <>) - & _last %~ (if isLast then (<> " )") else id)) - ----------------------------------------------------------------------------- --- ADT formatters ----------------------------------------------------------------------------- - -{- | Like 'build' for 'Maybe', but displays 'Nothing' as @\@ instead -of an empty string. - -'build': - ->>> build (Nothing :: Maybe Int) -"" ->>> build (Just 1 :: Maybe Int) -"1" - -'maybeF': - ->>> maybeF (Nothing :: Maybe Int) -"" ->>> maybeF (Just 1 :: Maybe Int) -"1" --} -maybeF :: Buildable a => Maybe a -> Builder -maybeF = maybe "" build - -{- | -Format an 'Either': - ->>> eitherF (Right 1) -"" --} -eitherF :: (Buildable a, Buildable b) => Either a b -> Builder -eitherF = either (\x -> " build x <> ">") - (\x -> " build x <> ">") - ----------------------------------------------------------------------------- --- Other formatters ----------------------------------------------------------------------------- - -{- | -Take the first N characters: - ->>> prefixF 3 "hello" -"hel" --} -prefixF :: Buildable a => Int -> a -> Builder -prefixF size = - fromLazyText . TL.take (fromIntegral size) . toLazyText . build - -{- | -Take the last N characters: - ->>> suffixF 3 "hello" -"llo" --} -suffixF :: Buildable a => Int -> a -> Builder -suffixF size = - fromLazyText . - (\t -> TL.drop (TL.length t - fromIntegral size) t) . - toLazyText . build - -{- | -@padLeftF n c@ pads the string with character @c@ from the left side until it -becomes @n@ characters wide (and does nothing if the string is already that -long, or longer): - ->>> padLeftF 5 '0' 12 -"00012" ->>> padLeftF 5 '0' 123456 -"123456" --} -padLeftF :: Buildable a => Int -> Char -> a -> Builder -padLeftF = TF.left - -{- | -@padRightF n c@ pads the string with character @c@ from the right side until -it becomes @n@ characters wide (and does nothing if the string is already -that long, or longer): - ->>> padRightF 5 ' ' "foo" -"foo " ->>> padRightF 5 ' ' "foobar" -"foobar" --} -padRightF :: Buildable a => Int -> Char -> a -> Builder -padRightF = TF.right - -{- | -@padBothF n c@ pads the string with character @c@ from both sides until -it becomes @n@ characters wide (and does nothing if the string is already -that long, or longer): - ->>> padBothF 5 '=' "foo" -"=foo=" ->>> padBothF 5 '=' "foobar" -"foobar" - -When padding can't be distributed equally, the left side is preferred: - ->>> padBoth 8 '=' "foo" -"===foo==" --} -padBothF :: Buildable a => Int -> Char -> a -> Builder -padBothF i c = - fromLazyText . TL.center (fromIntegral i) c . toLazyText . build - -{- | -Break digits in a number: - ->>> commaizeF 15830000 -"15,830,000" --} -commaizeF :: (Buildable a, Integral a) => a -> Builder -commaizeF = groupInt 3 ',' - -{- | -Format a number as octal: - ->>> listF' octF [7,8,9,10] -"[7, 10, 11, 12]" --} -octF :: Integral a => a -> Builder -octF = baseF 8 - -{- | -Format a number as binary: - ->>> listF' binF [7,8,9,10] -"[111, 1000, 1001, 1010]" --} -binF :: Integral a => a -> Builder -binF = baseF 2 - -{- | -Format a number in arbitrary base (up to 36): - ->>> baseF 3 10000 -"111201101" ->>> baseF 7 10000 -"41104" ->>> baseF 36 10000 -"7ps" --} -baseF :: Integral a => Int -> a -> Builder -baseF numBase = build . atBase numBase - -{- | -Format a floating-point number: - ->>> floatF 3.1415 -"3.1415" - -Numbers bigger than 1e21 or smaller than 1e-6 will be displayed using -scientific notation: - ->>> listF' floatF [1e-6,9e-7] -"[0.000001, 9e-7]" ->>> listF' floatF [9e20,1e21] -"[900000000000000000000, 1e21]" --} -floatF :: Real a => a -> Builder -floatF = TF.shortest - -{- | -Format a floating-point number using scientific notation, with given amount -of precision: - ->>> listF' (exptF 5) [pi,0.1,10] -"[3.14159e0, 1.00000e-1, 1.00000e1]" --} -exptF :: Real a => Int -> a -> Builder -exptF = TF.expt - -{- | -Format a floating-point number with given amount of precision. - -For small numbers, it uses scientific notation for everything smaller than -1e-6: - ->>> listF' (precF 3) [1e-5,1e-6,1e-7] -"[0.0000100, 0.00000100, 1.00e-7]" - -For large numbers, it uses scientific notation for everything larger than -1eN, where N is the precision: - ->>> listF' (precF 4) [1e3,5e3,1e4] -"[1000, 5000, 1.000e4]" --} -precF :: Real a => Int -> a -> Builder -precF = TF.prec - ----------------------------------------------------------------------------- --- Conditional formatters ----------------------------------------------------------------------------- - -{- | -Display something only if the condition is 'True' (empty string otherwise). - -@ ->>> __"Hello!" <> whenF showDetails (", details: "+|foobar|+"")__ -@ - -Note that it can only take a 'Builder' (because otherwise it would be -unusable with ('+|')-formatted strings which can resolve to any 'FromBuilder'). Thus, use 'fmt' if you need just one value: - -@ ->>> __"Maybe here's a number: "+|whenF cond (fmt n)|+""__ -@ --} -whenF :: Bool -> Builder -> Builder -whenF True x = x -whenF False _ = mempty -{-# INLINE whenF #-} - -{- | -Display something only if the condition is 'False' (empty string otherwise). --} -unlessF :: Bool -> Builder -> Builder -unlessF False x = x -unlessF True _ = mempty -{-# INLINE unlessF #-} - ----------------------------------------------------------------------------- --- Generic formatting ----------------------------------------------------------------------------- - -{- | Format an arbitrary value without requiring a 'Buildable' instance: - -@ -data Foo = Foo { x :: Bool, y :: [Int] } - deriving Generic -@ - ->>> fmt (genericF (Foo True [1,2,3])) -Foo: - x: True - y: [1, 2, 3] - -It works for non-record constructors too: - -@ -data Bar = Bar Bool [Int] - deriving Generic -@ - ->>> fmtLn (genericF (Bar True [1,2,3])) - - -Any fields inside the type must either be 'Buildable' or one of the following -types: - -* a function -* a tuple (up to 8-tuples) -* list, 'NonEmpty', 'Seq' -* 'Map', 'IntMap', 'Set', 'IntSet' -* 'Maybe', 'Either' - -The exact format of 'genericF' might change in future versions, so don't rely -on it. It's merely a convenience function. --} -genericF :: (Generic a, GBuildable (Rep a)) => a -> Builder -genericF = gbuild . from - -instance GBuildable a => GBuildable (M1 D d a) where - gbuild (M1 x) = gbuild x - -instance (GetFields a, Constructor c) => GBuildable (M1 C c a) where - -- A note on fixity: - -- * Ordinarily e.g. "Foo" is prefix and e.g. ":|" is infix - -- * However, "Foo" can be infix when defined as "a `Foo` b" - -- * And ":|" can be prefix when defined as "(:|) a b" - gbuild c@(M1 x) = case conFixity c of - Infix _ _ - | [a, b] <- fields -> format "({} {} {})" a infixName b - -- this case should never happen, but still - | otherwise -> format "<{}: {}>" - prefixName - (mconcat (intersperse ", " fields)) - Prefix - | isTuple -> tupleLikeF fields - | conIsRecord c -> nameF (build prefixName) (blockMapF fieldsWithNames) - | null (getFields x) -> build prefixName - -- I believe that there will be only one field in this case - | null (conName c) -> mconcat (intersperse ", " fields) - | otherwise -> format "<{}: {}>" - prefixName - (mconcat (intersperse ", " fields)) - where - (prefixName, infixName) - | ":" `isPrefixOf` conName c = ("(" ++ conName c ++ ")", conName c) - | otherwise = (conName c, "`" ++ conName c ++ "`") - fields = map snd (getFields x) - fieldsWithNames = getFields x - isTuple = "(," `isPrefixOf` prefixName - -instance Buildable' c => GBuildable (K1 i c) where - gbuild (K1 a) = build' a - -instance (GBuildable a, GBuildable b) => GBuildable (a :+: b) where - gbuild (L1 x) = gbuild x - gbuild (R1 x) = gbuild x - -instance (GetFields a, GetFields b) => GetFields (a :*: b) where - getFields (a :*: b) = getFields a ++ getFields b - -instance (GBuildable a, Selector c) => GetFields (M1 S c a) where - getFields s@(M1 a) = [(selName s, gbuild a)] - -instance GBuildable a => GetFields (M1 D c a) where - getFields (M1 a) = [("", gbuild a)] - -instance GBuildable a => GetFields (M1 C c a) where - getFields (M1 a) = [("", gbuild a)] - -instance GetFields U1 where - getFields _ = [] - ----------------------------------------------------------------------------- --- A more powerful Buildable used for genericF ----------------------------------------------------------------------------- - -instance Buildable' () where - build' _ = "()" - -instance (Buildable' a1, Buildable' a2) - => Buildable' (a1, a2) where - build' (a1, a2) = tupleLikeF - [build' a1, build' a2] - -instance (Buildable' a1, Buildable' a2, Buildable' a3) - => Buildable' (a1, a2, a3) where - build' (a1, a2, a3) = tupleLikeF - [build' a1, build' a2, build' a3] - -instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4) - => Buildable' (a1, a2, a3, a4) where - build' (a1, a2, a3, a4) = tupleLikeF - [build' a1, build' a2, build' a3, build' a4] - -instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, - Buildable' a5) - => Buildable' (a1, a2, a3, a4, a5) where - build' (a1, a2, a3, a4, a5) = tupleLikeF - [build' a1, build' a2, build' a3, build' a4, - build' a5] - -instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, - Buildable' a5, Buildable' a6) - => Buildable' (a1, a2, a3, a4, a5, a6) where - build' (a1, a2, a3, a4, a5, a6) = tupleLikeF - [build' a1, build' a2, build' a3, build' a4, - build' a5, build' a6] - -instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, - Buildable' a5, Buildable' a6, Buildable' a7) - => Buildable' (a1, a2, a3, a4, a5, a6, a7) where - build' (a1, a2, a3, a4, a5, a6, a7) = tupleLikeF - [build' a1, build' a2, build' a3, build' a4, - build' a5, build' a6, build' a7] - -instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, - Buildable' a5, Buildable' a6, Buildable' a7, Buildable' a8) - => Buildable' (a1, a2, a3, a4, a5, a6, a7, a8) where - build' (a1, a2, a3, a4, a5, a6, a7, a8) = tupleLikeF - [build' a1, build' a2, build' a3, build' a4, - build' a5, build' a6, build' a7, build' a8] - -instance _OVERLAPPING_ Buildable' [Char] where - build' = build - -instance Buildable' a => Buildable' [a] where - build' = listF' build' - -#if MIN_VERSION_base(4,9,0) -instance Buildable' a => Buildable' (NonEmpty a) where - build' = listF' build' -#endif - -instance Buildable' a => Buildable' (Seq a) where - build' = listF' build' - -instance (Buildable' k, Buildable' v) => Buildable' (Map k v) where - build' = mapF' build' build' . Map.toList - -instance (Buildable' v) => Buildable' (Set v) where - build' = listF' build' - -instance (Buildable' v) => Buildable' (IntMap v) where - build' = mapF' build' build' . IntMap.toList - -instance Buildable' IntSet where - build' = listF' build' . IntSet.toList - -instance (Buildable' a) => Buildable' (Maybe a) where - build' Nothing = maybeF (Nothing :: Maybe Builder) - build' (Just a) = maybeF (Just (build' a) :: Maybe Builder) - -instance (Buildable' a, Buildable' b) => Buildable' (Either a b) where - build' (Left a) = eitherF (Left (build' a) :: Either Builder Builder) - build' (Right a) = eitherF (Right (build' a) :: Either Builder Builder) - -instance Buildable' (a -> b) where - build' _ = "" - -instance _OVERLAPPABLE_ Buildable a => Buildable' a where - build' = build +module Fmt +( + -- * Overloaded strings + -- $overloadedstrings + + -- * Examples + -- $examples + + -- * Migration guide from @formatting@ + -- $migration + + -- * Basic formatting + -- $brackets + + -- ** Ordinary brackets + -- $god1 + (+|), + (|+), + -- ** 'Show' brackets + -- $god2 + (+||), + (||+), + -- ** Combinations + -- $god3 + (|++|), + (||++||), + (|++||), + (||++|), + + -- * Old-style formatting + format, + formatLn, + Format, + + -- * Helper functions + fmt, + fmtLn, + + Builder, + Buildable(..), + + -- * Formatters + + -- ** Time + module Fmt.Time, + + -- ** Text + indentF, indentF', + nameF, + unwordsF, + unlinesF, + + -- ** Lists + listF, listF', + blockListF, blockListF', + jsonListF, jsonListF', + + -- ** Maps + mapF, mapF', + blockMapF, blockMapF', + jsonMapF, jsonMapF', + + -- ** Tuples + tupleF, + + -- ** ADTs + maybeF, + eitherF, + + -- ** Padding/trimming + prefixF, + suffixF, + padLeftF, + padRightF, + padBothF, + + -- ** Hex + hexF, + + -- ** Bytestrings + base64F, + base64UrlF, + + -- ** Integers + ordinalF, + commaizeF, + -- *** Base conversion + octF, + binF, + baseF, + + -- ** Floating-point + floatF, + exptF, + fixedF, + + -- ** Conditional formatting + whenF, + unlessF, + + -- ** Generic formatting + genericF, +) +where + + +import Formatting.Buildable (Buildable(..)) +import Data.Text.Lazy.Builder + +import Fmt.Internal +import Fmt.Time + + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :set -XDeriveGeneric +-- >>> import Data.Text (Text) + +{- $overloadedstrings + +You need @OverloadedStrings@ enabled to use this library. There are three +ways to do it: + + * __In GHCi:__ do @:set -XOverloadedStrings@. + + * __In a module:__ add @\{\-\# LANGUAGE OverloadedStrings \#\-\}@ + to the beginning of your module. + + * __In a project:__ add @OverloadedStrings@ to the @default-extensions@ + section of your @.cabal@ file. +-} + +{- $examples + +Here's a bunch of examples because some people learn better by looking at +examples. + +Insert some variables into a string: + +>>> let (a, b, n) = ("foo", "bar", 25) +>>> ("Here are some words: "+|a|+", "+|b|+"\nAlso a number: "+|n|+"") :: String +"Here are some words: foo, bar\nAlso a number: 25" + +Print it: + +>>> fmtLn ("Here are some words: "+|a|+", "+|b|+"\nAlso a number: "+|n|+"") +Here are some words: foo, bar +Also a number: 25 + +Format a list in various ways: + +>>> let xs = ["John", "Bob"] + +>>> fmtLn ("Using show: "+||xs||+"\nUsing listF: "+|listF xs|+"") +Using show: ["John","Bob"] +Using listF: [John, Bob] + +>>> fmt ("YAML-like:\n"+|blockListF xs|+"") +YAML-like: +- John +- Bob + +>>> fmt ("JSON-like: "+|jsonListF xs|+"") +JSON-like: [ + John +, Bob +] + +-} + +{- $migration + +Instead of using @%@, surround variables with '+|' and '|+'. You don't have +to use @sformat@ or anything else, and also where you were using @build@, +@int@, @text@, etc in @formatting@, you don't have to use anything in @fmt@: + +@ +formatting __sformat ("Foo: "%build%", bar: "%int) foo bar__ + fmt __"Foo: "+|foo|+", bar: "+|bar|+""__ +@ + +The resulting formatted string is polymorphic and can be used as 'String', +'Text', 'Builder' or even 'IO' (i.e. the string will be printed to the +screen). However, when printing it is recommended to use 'fmt' or 'fmtLn' +for clarity. + +@fmt@ provides lots of formatters (which are simply functions that produce +'Builder'): + +@ +formatting __sformat ("Got another byte ("%hex%")") x__ + fmt __"Got another byte ("+|hexF x|+")"__ +@ + +Instead of the @shown@ formatter, either just use 'show' or double brackets: + +@ +formatting __sformat ("This uses Show: "%shown%") foo__ + fmt #1 __"This uses Show: "+|show foo|+""__ + fmt #2 __"This uses Show: "+||foo||+""__ +@ + +Many formatters from @formatting@ have the same names in @fmt@, but with +added “F”: 'hexF', 'exptF', etc. Some have been renamed, though: + +@ +__Cutting:__ + fitLeft -\> 'prefixF' + fitRight -\> 'suffixF' + +__Padding:__ + left -\> 'padLeftF' + right -\> 'padRightF' + center -\> 'padBothF' + +__Stuff with numbers:__ + ords -\> 'ordinalF' + commas -\> 'commaizeF' +@ + +Also, some formatters from @formatting@ haven't been added to @fmt@ +yet. Specifically: + +* @plural@ and @asInt@ (but instead of @asInt@ you can use 'fromEnum') +* @prefixBin@, @prefixOrd@, @prefixHex@, and @bytes@ +* formatters that use @Scientific@ (@sci@ and @scifmt@) + +They will be added later. (On the other hand, @fmt@ provides some useful +formatters not available in @formatting@, such as 'listF', 'mapF', 'tupleF' +and so on.) +-} + +---------------------------------------------------------------------------- +-- Documentation for operators +---------------------------------------------------------------------------- + +{- $brackets + +To format strings, put variables between ('+|') and ('|+'): + +>>> let name = "Alice" :: String +>>> "Meet "+|name|+"!" :: String +"Meet Alice!" + +Of course, 'Text' is supported as well: + +>>> "Meet "+|name|+"!" :: Text +"Meet Alice!" + +You don't actually need any type signatures; however, if you're toying with +this library in GHCi, it's recommended to either add a type signature or use +'fmtLn': + +>>> fmtLn ("Meet "+|name|+"!") +Meet Alice! + +Otherwise the type of the formatted string would be resolved to @IO ()@ and +printed without a newline, which is not very convenient when you're in GHCi. +On the other hand, it's useful for quick-and-dirty scripts: + +@ +main = do + [fin, fout] \<- words \<$\> getArgs + __"Reading data from "+|fin|+"\\n"__ + xs \<- readFile fin + __"Writing processed data to "+|fout|+"\\n"__ + writeFile fout (show (process xs)) +@ + +Anyway, let's proceed. Anything 'Buildable', including numbers, booleans, +characters and dates, can be put between ('+|') and ('|+'): + +>>> let starCount = "173" +>>> fmtLn ("Meet "+|name|+"! She's got "+|starCount|+" stars on Github.") +Meet Alice! She's got 173 stars on Github. + +Since the only thing ('+|') and ('|+') do is concatenate strings and do +conversion, you can use any functions you want inside them. In this case, +'length': + +>>> fmtLn (""+|name|+"'s name has "+|length name|+" letters") +Alice's name has 5 letters + +If something isn't 'Buildable', just use 'show' on it: + +>>> let pos = (3, 5) +>>> fmtLn ("Character's position: "+|show pos|+"") +Character's position: (3,5) + +Or one of many formatters provided by this library – for instance, for tuples +of various sizes there's 'tupleF': + +>>> fmtLn ("Character's position: "+|tupleF pos|+"") +Character's position: (3, 5) + +Finally, for convenience there's the ('|++|') operator, which can be used if +you've got one variable following the other: + +>>> let (a, op, b, res) = (2, "*", 2, 4) +>>> fmtLn (""+|a|++|op|++|b|+" = "+|res|+"") +2*2 = 4 + +Also, since in some codebases there are /lots/ of types which aren't +'Buildable', there are operators ('+||') and ('||+'), which use 'show' +instead of 'build': + +prop> (""+|show foo|++|show bar|+"") == (""+||foo||++||bar||+"") +-} + +-- $god1 +-- Operators for the operators god! + +-- $god2 +-- More operators for the operators god! + +{- $god3 + +Z̸͠A̵̕͟͠L̡̀́͠G̶̛O͝ ̴͏̀ I͞S̸̸̢͠  ̢̛͘͢C̷͟͡Ó̧̨̧͞M̡͘͟͞I̷͜N̷̕G̷̀̕ + +(Though you can just use @""@ between @+| |+@ instead of using these +operators, and 'Show'-brackets don't have to be used at all because there's +'show' available.) +-} ---------------------------------------------------------------------------- -- TODOs diff --git a/lib/Fmt/Internal.hs b/lib/Fmt/Internal.hs --- a/lib/Fmt/Internal.hs +++ b/lib/Fmt/Internal.hs @@ -1,109 +1,54 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} --- for FormatAsHex and FormatType -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -# define _OVERLAPPING_ -# define _OVERLAPPABLE_ -# define _OVERLAPS_ -#else -# define _OVERLAPPING_ {-# OVERLAPPING #-} -# define _OVERLAPPABLE_ {-# OVERLAPPABLE #-} -# define _OVERLAPS_ {-# OVERLAPS #-} -#endif {- | A module providing access to internals (in case you really need them). Can change at any time, though probably won't. - -It also provides some functions that are used in 'Fmt.Time' (so that -'Fmt.Time' wouldn't need to import 'Fmt'). -} module Fmt.Internal ( -- * Classes - FromBuilder(..), FormatAsHex(..), FormatAsBase64(..), - TupleF(..), - -- * Classes used for 'genericF' - GBuildable(..), - GetFields(..), - Buildable'(..), - - -- * Polyvariadic 'format' - FormatType(..), - - -- * Helpers - groupInt, - atBase, - showSigned', - intToDigit', - indentF', - - -- * Functions used in 'Fmt.Time' - fixedF, - ordinalF, + -- * Reexports + module Fmt.Internal.Core, + module Fmt.Internal.Formatters, + module Fmt.Internal.Template, + module Fmt.Internal.Tuple, + module Fmt.Internal.Numeric, + module Fmt.Internal.Generic, ) where --- Generic useful things -import Data.Monoid -import Numeric -import Data.Char + -- Text -import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL import qualified Data.Text.Lazy.Encoding as TL --- 'Buildable' and text-format -import Data.Text.Buildable -import qualified Data.Text.Format as TF +-- 'Buildable' and raw 'Builder' formatters +import qualified Formatting.Internal.Raw as F -- Text 'Builder' -import Data.Text.Lazy.Builder hiding (fromString) +import Data.Text.Lazy.Builder hiding (fromString) -- Bytestring import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -- Formatting bytestrings -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Base16.Lazy as B16L +import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.Lazy as B64L import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Base64.URL.Lazy as B64UL ----------------------------------------------------------------------------- --- FromBuilder ----------------------------------------------------------------------------- - -class FromBuilder a where - -- | Convert a 'Builder' to something else. - fromBuilder :: Builder -> a - -instance FromBuilder Builder where - fromBuilder = id - {-# INLINE fromBuilder #-} - -instance (a ~ Char) => FromBuilder [a] where - fromBuilder = TL.unpack . toLazyText - {-# INLINE fromBuilder #-} - -instance FromBuilder T.Text where - fromBuilder = TL.toStrict . toLazyText - {-# INLINE fromBuilder #-} - -instance FromBuilder TL.Text where - fromBuilder = toLazyText - {-# INLINE fromBuilder #-} +import Fmt.Internal.Core +import Fmt.Internal.Formatters +import Fmt.Internal.Template +import Fmt.Internal.Tuple +import Fmt.Internal.Numeric +import Fmt.Internal.Generic -instance (a ~ ()) => FromBuilder (IO a) where - fromBuilder = TL.putStr . toLazyText - {-# INLINE fromBuilder #-} +-- $setup +-- >>> import Fmt ---------------------------------------------------------------------------- -- Hex @@ -121,13 +66,13 @@ hexF :: a -> Builder instance FormatAsHex BS.ByteString where - hexF = fromText . T.decodeLatin1 . B16.encode + hexF = fromLazyText . TL.decodeLatin1 . BB.toLazyByteString . BB.byteStringHex instance FormatAsHex BSL.ByteString where - hexF = fromLazyText . TL.decodeLatin1 . B16L.encode + hexF = fromLazyText . TL.decodeLatin1 . BB.toLazyByteString . BB.lazyByteStringHex -instance _OVERLAPPABLE_ Integral a => FormatAsHex a where - hexF = TF.hex +instance {-# OVERLAPPABLE #-} Integral a => FormatAsHex a where + hexF = F.hex ---------------------------------------------------------------------------- -- Base64 @@ -157,142 +102,3 @@ instance FormatAsBase64 BSL.ByteString where base64F = fromLazyText . TL.decodeLatin1 . B64L.encode base64UrlF = fromLazyText . TL.decodeLatin1 . B64UL.encode - ----------------------------------------------------------------------------- --- Tuples ----------------------------------------------------------------------------- - -class TupleF a where - {- | -Format a tuple (of up to 8 elements): - ->>> tupleF (1,2,"hi") -"(1, 2, hi)" - -If any of the elements takes several lines, an alternate format is used: - -@ ->>> __fmt $ tupleF ("test","foo\\nbar","more test")__ -( test -, - foo - bar -, - more test ) -@ - -} - tupleF :: a -> Builder - ----------------------------------------------------------------------------- --- Classes used for 'genericF' ----------------------------------------------------------------------------- - -class GBuildable f where - gbuild :: f a -> Builder - -class GetFields f where - -- | Get fields, together with their names if available - getFields :: f a -> [(String, Builder)] - --- | A more powerful 'Buildable' used for 'genericF'. Can build functions, --- tuples, lists, maps, etc., as well as combinations thereof. -class Buildable' a where - build' :: a -> Builder - ----------------------------------------------------------------------------- --- Classes used for polyvariadic 'format' ----------------------------------------------------------------------------- - --- | Something like 'Text.Printf.PrintfType' in "Text.Printf". -class FormatType r where - format' :: TF.Format -> [Builder] -> r - -instance (Buildable a, FormatType r) => FormatType (a -> r) where - format' f xs = \x -> format' f (build x : xs) - -instance _OVERLAPPABLE_ FromBuilder r => FormatType r where - format' f xs = fromBuilder $ TF.build f (reverse xs) - ----------------------------------------------------------------------------- --- Helpers ----------------------------------------------------------------------------- - -groupInt :: (Buildable a, Integral a) => Int -> Char -> a -> Builder -groupInt 0 _ n = build n -groupInt i c n = - fromLazyText . TL.reverse . - foldr merge "" . - TL.zip (zeros <> cycle' zeros') . - TL.reverse . - toLazyText . build - $ n - where - zeros = TL.replicate (fromIntegral i) (TL.singleton '0') - zeros' = TL.singleton c <> TL.tail zeros - merge (f, c') rest - | f == c = TL.singleton c <> TL.singleton c' <> rest - | otherwise = TL.singleton c' <> rest - cycle' xs = xs <> cycle' xs - -- Suppress the warning about redundant Integral constraint - _ = toInteger n - -atBase :: Integral a => Int -> a -> String -atBase b _ | b < 2 || b > 36 = error ("baseF: Invalid base " ++ show b) -atBase b n = - showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) "" -{-# INLINE atBase #-} - -showSigned' :: Real a => (a -> ShowS) -> a -> ShowS -showSigned' f n - | n < 0 = showChar '-' . f (negate n) - | otherwise = f n - -intToDigit' :: Int -> Char -intToDigit' i - | i >= 0 && i < 10 = chr (ord '0' + i) - | i >= 10 && i < 36 = chr (ord 'a' + i - 10) - | otherwise = error ("intToDigit': Invalid int " ++ show i) - -{- | Add a prefix to the first line, and indent all lines but the first one. - -The output will always end with a newline, even when the input doesn't. --} -indentF' :: Int -> T.Text -> Builder -> Builder -indentF' n pref a = case TL.lines (toLazyText a) of - [] -> fromText pref <> "\n" - (x:xs) -> fromLazyText $ - TL.unlines $ (TL.fromStrict pref <> x) : map (spaces <>) xs - where - spaces = TL.replicate (fromIntegral n) (TL.singleton ' ') - ----------------------------------------------------------------------------- --- Functions used in Fmt.Time ----------------------------------------------------------------------------- - -{- | -Format a floating-point number without scientific notation: - ->>> listF' (fixedF 5) [pi,0.1,10] -"[3.14159, 0.10000, 10.00000]" --} -fixedF :: Real a => Int -> a -> Builder -fixedF = TF.fixed - -{- | -Add an ordinal suffix to a number: - ->>> ordinalF 15 -"15th" ->>> ordinalF 22 -"22nd" --} -ordinalF :: (Buildable a, Integral a) => a -> Builder -ordinalF n - | tens > 3 && tens < 21 = build n <> "th" - | otherwise = build n <> case n `mod` 10 of - 1 -> "st" - 2 -> "nd" - 3 -> "rd" - _ -> "th" - where - tens = n `mod` 100 diff --git a/lib/Fmt/Internal/Core.hs b/lib/Fmt/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/lib/Fmt/Internal/Core.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Fmt.Internal.Core where + +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL +import Data.Text.Lazy.Builder hiding (fromString) +import Formatting.Buildable (Buildable(..)) + + +---------------------------------------------------------------------------- +-- Class +---------------------------------------------------------------------------- + +class FromBuilder a where + -- | Convert a 'Builder' to something else. + fromBuilder :: Builder -> a + +instance FromBuilder Builder where + fromBuilder = id + {-# INLINE fromBuilder #-} + +instance (a ~ Char) => FromBuilder [a] where + fromBuilder = TL.unpack . toLazyText + {-# INLINE fromBuilder #-} + +instance FromBuilder T.Text where + fromBuilder = TL.toStrict . toLazyText + {-# INLINE fromBuilder #-} + +instance FromBuilder TL.Text where + fromBuilder = toLazyText + {-# INLINE fromBuilder #-} + +instance (a ~ ()) => FromBuilder (IO a) where + fromBuilder = TL.putStr . toLazyText + {-# INLINE fromBuilder #-} + +---------------------------------------------------------------------------- +-- Operators +---------------------------------------------------------------------------- + +-- | Concatenate, then convert. +(+|) :: (FromBuilder b) => Builder -> Builder -> b +(+|) str rest = fromBuilder (str <> rest) + +-- | 'build' and concatenate, then convert. +(|+) :: (Buildable a, FromBuilder b) => a -> Builder -> b +(|+) a rest = fromBuilder (build a <> rest) + +infixr 1 +| +infixr 1 |+ + +-- | Concatenate, then convert. +(+||) :: (FromBuilder b) => Builder -> Builder -> b +(+||) str rest = str +| rest +{-# INLINE (+||) #-} + +-- | 'show' and concatenate, then convert. +(||+) :: (Show a, FromBuilder b) => a -> Builder -> b +(||+) a rest = show a |+ rest +{-# INLINE (||+) #-} + +infixr 1 +|| +infixr 1 ||+ + +(|++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b +(|++|) a rest = fromBuilder (build a <> rest) +{-# INLINE (|++|) #-} + +(||++||) :: (Show a, FromBuilder b) => a -> Builder -> b +(||++||) a rest = show a |+ rest +{-# INLINE (||++||) #-} + +(||++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b +(||++|) a rest = a |++| rest +{-# INLINE (||++|) #-} + +(|++||) :: (Show a, FromBuilder b) => a -> Builder -> b +(|++||) a rest = a ||++|| rest +{-# INLINE (|++||) #-} + +infixr 1 |++| +infixr 1 ||++|| +infixr 1 ||++| +infixr 1 |++|| + +---------------------------------------------------------------------------- +-- Functions +---------------------------------------------------------------------------- + +{- | 'fmt' converts things to 'String', 'Text' or 'Builder'. + +Most of the time you won't need it, as strings produced with ('+|') and +('|+') can already be used as 'String', 'Text', etc. However, combinators +like 'listF' can only produce 'Builder' (for better type inference), and you +need to use 'fmt' on them. + +Also, 'fmt' can do printing: + +>>> fmt "Hello world!\n" +Hello world! +-} +fmt :: FromBuilder b => Builder -> b +fmt = fromBuilder +{-# INLINE fmt #-} + +{- | Like 'fmt', but appends a newline. +-} +fmtLn :: FromBuilder b => Builder -> b +fmtLn = fromBuilder . (<> "\n") +{-# INLINE fmtLn #-} diff --git a/lib/Fmt/Internal/Formatters.hs b/lib/Fmt/Internal/Formatters.hs new file mode 100644 --- /dev/null +++ b/lib/Fmt/Internal/Formatters.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Fmt.Internal.Formatters where + + +-- Generic useful things +import Data.List +import Lens.Micro +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +-- Text +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text (Text) +-- 'Buildable' and text-format stuff +import Formatting.Buildable +import qualified Formatting.Internal.Raw as F +-- Text 'Builder' +import Data.Text.Lazy.Builder hiding (fromString) +-- 'Foldable' and 'IsList' for list/map formatters +import Data.Foldable (toList) +import GHC.Exts (IsList, Item) +import qualified GHC.Exts as IsList (toList) + +import Fmt.Internal.Core + + +---------------------------------------------------------------------------- +-- Text formatters +---------------------------------------------------------------------------- + +{- | +Indent a block of text. + +>>> fmt $ "This is a list:\n" <> indentF 4 (blockListF [1,2,3]) +This is a list: + - 1 + - 2 + - 3 + +The output will always end with a newline, even when the input doesn't. +-} +indentF :: Int -> Builder -> Builder +indentF n a = case TL.lines (toLazyText a) of + [] -> fromLazyText (spaces <> "\n") + xs -> fromLazyText $ TL.unlines (map (spaces <>) xs) + where + spaces = TL.replicate (fromIntegral n) (TL.singleton ' ') + +{- | Add a prefix to the first line, and indent all lines but the first one. + +The output will always end with a newline, even when the input doesn't. +-} +indentF' :: Int -> T.Text -> Builder -> Builder +indentF' n pref a = case TL.lines (toLazyText a) of + [] -> fromText pref <> "\n" + (x:xs) -> fromLazyText $ + TL.unlines $ (TL.fromStrict pref <> x) : map (spaces <>) xs + where + spaces = TL.replicate (fromIntegral n) (TL.singleton ' ') + +{- | Attach a name to anything: + +>>> fmt $ nameF "clients" $ blockListF ["Alice", "Bob", "Zalgo"] +clients: + - Alice + - Bob + - Zalgo +-} +nameF :: Builder -> Builder -> Builder +nameF k v = case TL.lines (toLazyText v) of + [] -> k <> ":\n" + [l] -> k <> ": " <> fromLazyText l <> "\n" + ls -> k <> ":\n" <> + mconcat [" " <> fromLazyText s <> "\n" | s <- ls] + +{- | Put words between elements. + +>>> fmt $ unwordsF ["hello", "world"] +hello world + +Of course, it works on anything 'Buildable': + +>>> fmt $ unwordsF [1, 2] +1 2 +-} +unwordsF :: (Foldable f, Buildable a) => f a -> Builder +unwordsF = mconcat . intersperse " " . map build . toList + +{-# SPECIALIZE unwordsF :: Buildable a => [a] -> Builder #-} + +{- | Arrange elements on separate lines. + +>>> fmt $ unlinesF ["hello", "world"] +hello +world +-} +unlinesF :: (Foldable f, Buildable a) => f a -> Builder +unlinesF = mconcat . map (nl . build) . toList + where + nl x | "\n" `TL.isSuffixOf` toLazyText x = x + | otherwise = x <> "\n" + +{-# SPECIALIZE unlinesF :: Buildable a => [a] -> Builder #-} + +---------------------------------------------------------------------------- +-- List formatters +---------------------------------------------------------------------------- + +{- | A simple comma-separated list formatter. + +>>> listF ["hello", "world"] +"[hello, world]" + +For multiline output, use 'jsonListF'. +-} +listF :: (Foldable f, Buildable a) => f a -> Builder +listF = listF' build +{-# INLINE listF #-} + +{- | A version of 'listF' that lets you supply your own building function for +list elements. + +For instance, to format a list of lists you'd have to do this (since there's +no 'Buildable' instance for lists): + +>>> listF' listF [[1,2,3],[4,5,6]] +"[[1, 2, 3], [4, 5, 6]]" +-} +listF' :: (Foldable f) => (a -> Builder) -> f a -> Builder +listF' fbuild xs = mconcat $ + "[" : + intersperse ", " (map fbuild (toList xs)) ++ + ["]"] + +{-# SPECIALIZE listF' :: (a -> Builder) -> [a] -> Builder #-} + +{- Note [Builder appending] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The documentation for 'Builder' says that it's preferrable to associate +'Builder' appends to the right (i.e. @a <> (b <> c)@). The maximum possible +association-to-the-right is achieved when we avoid appending builders until +the last second (i.e. in the latter scenario): + + -- (a1 <> x) <> (a2 <> x) <> ... + mconcat [a <> x | a <- as] + + -- a1 <> x <> a2 <> x <> ... + mconcat $ concat [[a, x] | a <- as] + +However, benchmarks have shown that the former way is actually faster. +-} + +{- | A multiline formatter for lists. + +>>> fmt $ blockListF [1,2,3] +- 1 +- 2 +- 3 + +Multi-line elements are indented correctly: + +>>> fmt $ blockListF ["hello\nworld", "foo\nbar\nquix"] +- hello + world +- foo + bar + quix + +-} +blockListF :: forall f a. (Foldable f, Buildable a) => f a -> Builder +blockListF = blockListF' "-" build +{-# INLINE blockListF #-} + +{- | A version of 'blockListF' that lets you supply your own building function +for list elements (instead of 'build') and choose the bullet character +(instead of @"-"@). +-} +blockListF' + :: forall f a. Foldable f + => Text -- ^ Bullet + -> (a -> Builder) -- ^ Builder for elements + -> f a -- ^ Structure with elements + -> Builder +blockListF' bullet fbuild xs = if null items then "[]\n" else mconcat items + where + items = map buildItem (toList xs) + spaces = mconcat $ replicate (T.length bullet + 1) (singleton ' ') + buildItem x = case TL.lines (toLazyText (fbuild x)) of + [] -> bullet |+ "\n" + (l:ls) -> bullet |+ " " +| l |+ "\n" <> + mconcat [spaces <> fromLazyText s <> "\n" | s <- ls] + +{-# SPECIALIZE blockListF' :: Text -> (a -> Builder) -> [a] -> Builder #-} + +{- | A JSON-style formatter for lists. + +>>> fmt $ jsonListF [1,2,3] +[ + 1 +, 2 +, 3 +] + +Like 'blockListF', it handles multiline elements well: + +>>> fmt $ jsonListF ["hello\nworld", "foo\nbar\nquix"] +[ + hello + world +, foo + bar + quix +] +-} +jsonListF :: forall f a. (Foldable f, Buildable a) => f a -> Builder +jsonListF = jsonListF' build +{-# INLINE jsonListF #-} + +{- | A version of 'jsonListF' that lets you supply your own building function +for list elements. +-} +jsonListF' :: forall f a. (Foldable f) => (a -> Builder) -> f a -> Builder +jsonListF' fbuild xs + | null items = "[]\n" + | otherwise = "[\n" <> mconcat items <> "]\n" + where + items = zipWith buildItem (True : repeat False) (toList xs) + -- Item builder + buildItem :: Bool -> a -> Builder + buildItem isFirst x = + case map fromLazyText (TL.lines (toLazyText (fbuild x))) of + [] | isFirst -> "\n" + | otherwise -> ",\n" + ls -> + mconcat . map (<> "\n") $ + ls & _head %~ (if isFirst then (" " <>) else (", " <>)) + & _tail.each %~ (" " <>) + +{-# SPECIALIZE jsonListF' :: (a -> Builder) -> [a] -> Builder #-} + +---------------------------------------------------------------------------- +-- Map formatters +---------------------------------------------------------------------------- + +{- | A simple JSON-like map formatter; works for Map, HashMap, etc, as well as +ordinary lists of pairs. + +>>> mapF [("a", 1), ("b", 4)] +"{a: 1, b: 4}" + +For multiline output, use 'jsonMapF'. +-} +mapF :: (IsList t, Item t ~ (k, v), Buildable k, Buildable v) => t -> Builder +mapF = mapF' build build +{-# INLINE mapF #-} + +{- | A version of 'mapF' that lets you supply your own building function for +keys and values. +-} +mapF' + :: (IsList t, Item t ~ (k, v)) + => (k -> Builder) -> (v -> Builder) -> t -> Builder +mapF' fbuild_k fbuild_v xs = + "{" <> mconcat (intersperse ", " (map buildPair (IsList.toList xs))) <> "}" + where + buildPair (k, v) = fbuild_k k <> ": " <> fbuild_v v + +{- | A YAML-like map formatter: + +>>> fmt $ blockMapF [("Odds", blockListF [1,3]), ("Evens", blockListF [2,4])] +Odds: + - 1 + - 3 +Evens: + - 2 + - 4 +-} +blockMapF :: (IsList t, Item t ~ (k, v), Buildable k, Buildable v) => t -> Builder +blockMapF = blockMapF' build build +{-# INLINE blockMapF #-} + +{- | A version of 'blockMapF' that lets you supply your own building function +for keys and values. +-} +blockMapF' + :: (IsList t, Item t ~ (k, v)) + => (k -> Builder) -> (v -> Builder) -> t -> Builder +blockMapF' fbuild_k fbuild_v xs + | null items = "{}\n" + | otherwise = mconcat items + where + items = map (\(k, v) -> nameF (fbuild_k k) (fbuild_v v)) (IsList.toList xs) + +{- | A JSON-like map formatter (unlike 'mapF', always multiline): + +>>> fmt $ jsonMapF [("Odds", jsonListF [1,3]), ("Evens", jsonListF [2,4])] +{ + Odds: + [ + 1 + , 3 + ] +, Evens: + [ + 2 + , 4 + ] +} +-} +jsonMapF :: (IsList t, Item t ~ (k, v), Buildable k, Buildable v) => t -> Builder +jsonMapF = jsonMapF' build build +{-# INLINE jsonMapF #-} + +{- | A version of 'jsonMapF' that lets you supply your own building function +for keys and values. +-} +jsonMapF' + :: forall t k v. + (IsList t, Item t ~ (k, v)) + => (k -> Builder) -> (v -> Builder) -> t -> Builder +jsonMapF' fbuild_k fbuild_v xs + | null items = "{}\n" + | otherwise = "{\n" <> mconcat items <> "}\n" + where + items = zipWith buildItem (True : repeat False) (IsList.toList xs) + -- Item builder + buildItem :: Bool -> (k, v) -> Builder + buildItem isFirst (k, v) = do + let kb = (if isFirst then " " else ", ") <> fbuild_k k + case map fromLazyText (TL.lines (toLazyText (fbuild_v v))) of + [] -> kb <> ":\n" + [l] -> kb <> ": " <> l <> "\n" + ls -> kb <> ":\n" <> + mconcat [" " <> s <> "\n" | s <- ls] + +---------------------------------------------------------------------------- +-- ADT formatters +---------------------------------------------------------------------------- + +{- | Like 'build' for 'Maybe', but displays 'Nothing' as @\@ instead +of an empty string. + +'build': + +>>> build (Nothing :: Maybe Int) +"" +>>> build (Just 1 :: Maybe Int) +"1" + +'maybeF': + +>>> maybeF (Nothing :: Maybe Int) +"" +>>> maybeF (Just 1 :: Maybe Int) +"1" +-} +maybeF :: Buildable a => Maybe a -> Builder +maybeF = maybe "" build + +{- | +Format an 'Either': + +>>> eitherF (Right 1 :: Either Bool Int) +"" +-} +eitherF :: (Buildable a, Buildable b) => Either a b -> Builder +eitherF = either (\x -> " build x <> ">") + (\x -> " build x <> ">") + +---------------------------------------------------------------------------- +-- Other formatters +---------------------------------------------------------------------------- + +{- | +Take the first N characters: + +>>> prefixF 3 "hello" +"hel" +-} +prefixF :: Buildable a => Int -> a -> Builder +prefixF size = + fromLazyText . TL.take (fromIntegral size) . toLazyText . build + +{- | +Take the last N characters: + +>>> suffixF 3 "hello" +"llo" +-} +suffixF :: Buildable a => Int -> a -> Builder +suffixF size = + fromLazyText . + (\t -> TL.drop (TL.length t - fromIntegral size) t) . + toLazyText . build + +{- | +@padLeftF n c@ pads the string with character @c@ from the left side until it +becomes @n@ characters wide (and does nothing if the string is already that +long, or longer): + +>>> padLeftF 5 '0' 12 +"00012" +>>> padLeftF 5 '0' 123456 +"123456" +-} +padLeftF :: Buildable a => Int -> Char -> a -> Builder +padLeftF = F.left + +{- | +@padRightF n c@ pads the string with character @c@ from the right side until +it becomes @n@ characters wide (and does nothing if the string is already +that long, or longer): + +>>> padRightF 5 ' ' "foo" +"foo " +>>> padRightF 5 ' ' "foobar" +"foobar" +-} +padRightF :: Buildable a => Int -> Char -> a -> Builder +padRightF = F.right + +{- | +@padBothF n c@ pads the string with character @c@ from both sides until +it becomes @n@ characters wide (and does nothing if the string is already +that long, or longer): + +>>> padBothF 5 '=' "foo" +"=foo=" +>>> padBothF 5 '=' "foobar" +"foobar" + +When padding can't be distributed equally, the left side is preferred: + +>>> padBothF 8 '=' "foo" +"===foo==" +-} +padBothF :: Buildable a => Int -> Char -> a -> Builder +padBothF i c = + fromLazyText . TL.center (fromIntegral i) c . toLazyText . build + +---------------------------------------------------------------------------- +-- Conditional formatters +---------------------------------------------------------------------------- + +{- | Display something only if the condition is 'True' (empty string +otherwise). + +Note that it can only take a 'Builder' (because otherwise it would be +unusable with ('+|')-formatted strings which can resolve to any +'FromBuilder'). You can use 'build' to convert any value to a 'Builder'. +-} +whenF :: Bool -> Builder -> Builder +whenF True x = x +whenF False _ = mempty +{-# INLINE whenF #-} + +{- | Display something only if the condition is 'False' (empty string +otherwise). +-} +unlessF :: Bool -> Builder -> Builder +unlessF False x = x +unlessF True _ = mempty +{-# INLINE unlessF #-} diff --git a/lib/Fmt/Internal/Generic.hs b/lib/Fmt/Internal/Generic.hs new file mode 100644 --- /dev/null +++ b/lib/Fmt/Internal/Generic.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Fmt.Internal.Generic where + + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Sequence (Seq) +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty (NonEmpty) +#endif + +import Data.List +import Data.Text.Lazy.Builder hiding (fromString) +import GHC.Generics +import Formatting.Buildable + +import Fmt.Internal.Formatters +import Fmt.Internal.Template +import Fmt.Internal.Tuple + + +-- $setup +-- >>> import Fmt + +{- | Format an arbitrary value without requiring a 'Buildable' instance: + +>>> data Foo = Foo { x :: Bool, y :: [Int] } deriving Generic + +>>> fmt (genericF (Foo True [1,2,3])) +Foo: + x: True + y: [1, 2, 3] + +It works for non-record constructors too: + +>>> data Bar = Bar Bool [Int] deriving Generic + +>>> fmtLn (genericF (Bar True [1,2,3])) + + +Any fields inside the type must either be 'Buildable' or one of the following +types: + +* a function +* a tuple (up to 8-tuples) +* list, 'NonEmpty', 'Seq' +* 'Map', 'IntMap', 'Set', 'IntSet' +* 'Maybe', 'Either' + +The exact format of 'genericF' might change in future versions, so don't rely +on it. It's merely a convenience function. +-} +genericF :: (Generic a, GBuildable (Rep a)) => a -> Builder +genericF = gbuild . from + +---------------------------------------------------------------------------- +-- GBuildable +---------------------------------------------------------------------------- + +class GBuildable f where + gbuild :: f a -> Builder + +instance Buildable' c => GBuildable (K1 i c) where + gbuild (K1 a) = build' a + +instance (GBuildable a, GBuildable b) => GBuildable (a :+: b) where + gbuild (L1 x) = gbuild x + gbuild (R1 x) = gbuild x + +instance GBuildable a => GBuildable (M1 D d a) where + gbuild (M1 x) = gbuild x + +instance (GetFields a, Constructor c) => GBuildable (M1 C c a) where + -- A note on fixity: + -- * Ordinarily e.g. "Foo" is prefix and e.g. ":|" is infix + -- * However, "Foo" can be infix when defined as "a `Foo` b" + -- * And ":|" can be prefix when defined as "(:|) a b" + gbuild c@(M1 x) = case conFixity c of + Infix _ _ + | [a, b] <- fields -> format "({} {} {})" a infixName b + -- this case should never happen, but still + | otherwise -> format "<{}: {}>" + prefixName + (mconcat (intersperse ", " fields)) + Prefix + | isTuple -> tupleF fields + | conIsRecord c -> nameF (build prefixName) (blockMapF fieldsWithNames) + | null (getFields x) -> build prefixName + -- I believe that there will be only one field in this case + | null (conName c) -> mconcat (intersperse ", " fields) + | otherwise -> format "<{}: {}>" + prefixName + (mconcat (intersperse ", " fields)) + where + (prefixName, infixName) + | ":" `isPrefixOf` conName c = ("(" ++ conName c ++ ")", conName c) + | otherwise = (conName c, "`" ++ conName c ++ "`") + fields = map snd (getFields x) + fieldsWithNames = getFields x + isTuple = "(," `isPrefixOf` prefixName + +---------------------------------------------------------------------------- +-- Buildable' +---------------------------------------------------------------------------- + +-- | A more powerful 'Buildable' used for 'genericF'. Can build functions, +-- tuples, lists, maps, etc., as well as combinations thereof. +class Buildable' a where + build' :: a -> Builder + +instance Buildable' () where + build' _ = "()" + +instance (Buildable' a1, Buildable' a2) + => Buildable' (a1, a2) where + build' (a1, a2) = tupleF + [build' a1, build' a2] + +instance (Buildable' a1, Buildable' a2, Buildable' a3) + => Buildable' (a1, a2, a3) where + build' (a1, a2, a3) = tupleF + [build' a1, build' a2, build' a3] + +instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4) + => Buildable' (a1, a2, a3, a4) where + build' (a1, a2, a3, a4) = tupleF + [build' a1, build' a2, build' a3, build' a4] + +instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, + Buildable' a5) + => Buildable' (a1, a2, a3, a4, a5) where + build' (a1, a2, a3, a4, a5) = tupleF + [build' a1, build' a2, build' a3, build' a4, + build' a5] + +instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, + Buildable' a5, Buildable' a6) + => Buildable' (a1, a2, a3, a4, a5, a6) where + build' (a1, a2, a3, a4, a5, a6) = tupleF + [build' a1, build' a2, build' a3, build' a4, + build' a5, build' a6] + +instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, + Buildable' a5, Buildable' a6, Buildable' a7) + => Buildable' (a1, a2, a3, a4, a5, a6, a7) where + build' (a1, a2, a3, a4, a5, a6, a7) = tupleF + [build' a1, build' a2, build' a3, build' a4, + build' a5, build' a6, build' a7] + +instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4, + Buildable' a5, Buildable' a6, Buildable' a7, Buildable' a8) + => Buildable' (a1, a2, a3, a4, a5, a6, a7, a8) where + build' (a1, a2, a3, a4, a5, a6, a7, a8) = tupleF + [build' a1, build' a2, build' a3, build' a4, + build' a5, build' a6, build' a7, build' a8] + +instance {-# OVERLAPPING #-} Buildable' [Char] where + build' = build + +instance Buildable' a => Buildable' [a] where + build' = listF' build' + +#if MIN_VERSION_base(4,9,0) +instance Buildable' a => Buildable' (NonEmpty a) where + build' = listF' build' +#endif + +instance Buildable' a => Buildable' (Seq a) where + build' = listF' build' + +instance (Buildable' k, Buildable' v) => Buildable' (Map k v) where + build' = mapF' build' build' . Map.toList + +instance (Buildable' v) => Buildable' (Set v) where + build' = listF' build' + +instance (Buildable' v) => Buildable' (IntMap v) where + build' = mapF' build' build' . IntMap.toList + +instance Buildable' IntSet where + build' = listF' build' . IntSet.toList + +instance (Buildable' a) => Buildable' (Maybe a) where + build' Nothing = maybeF (Nothing :: Maybe Builder) + build' (Just a) = maybeF (Just (build' a) :: Maybe Builder) + +instance (Buildable' a, Buildable' b) => Buildable' (Either a b) where + build' (Left a) = eitherF (Left (build' a) :: Either Builder Builder) + build' (Right a) = eitherF (Right (build' a) :: Either Builder Builder) + +instance Buildable' (a -> b) where + build' _ = "" + +instance {-# OVERLAPPABLE #-} Buildable a => Buildable' a where + build' = build + +---------------------------------------------------------------------------- +-- GetFields +---------------------------------------------------------------------------- + +class GetFields f where + -- | Get fields, together with their names if available + getFields :: f a -> [(String, Builder)] + +instance (GetFields a, GetFields b) => GetFields (a :*: b) where + getFields (a :*: b) = getFields a ++ getFields b + +instance (GBuildable a, Selector c) => GetFields (M1 S c a) where + getFields s@(M1 a) = [(selName s, gbuild a)] + +instance GBuildable a => GetFields (M1 D c a) where + getFields (M1 a) = [("", gbuild a)] + +instance GBuildable a => GetFields (M1 C c a) where + getFields (M1 a) = [("", gbuild a)] + +instance GetFields U1 where + getFields _ = [] diff --git a/lib/Fmt/Internal/Numeric.hs b/lib/Fmt/Internal/Numeric.hs new file mode 100644 --- /dev/null +++ b/lib/Fmt/Internal/Numeric.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + + +module Fmt.Internal.Numeric where + + +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import Numeric +import Data.Char +import Data.Text.Lazy.Builder hiding (fromString) +import Formatting.Buildable (Buildable(..)) +import qualified Formatting.Internal.Raw as F +import qualified Data.Text.Lazy as TL + + +-- $setup +-- >>> import Fmt + +---------------------------------------------------------------------------- +-- Integer +---------------------------------------------------------------------------- + +{- | +Format a number as octal: + +>>> listF' octF [7,8,9,10] +"[7, 10, 11, 12]" +-} +octF :: Integral a => a -> Builder +octF = baseF 8 + +{- | +Format a number as binary: + +>>> listF' binF [7,8,9,10] +"[111, 1000, 1001, 1010]" +-} +binF :: Integral a => a -> Builder +binF = baseF 2 + +{- | +Format a number in arbitrary base (up to 36): + +>>> baseF 3 10000 +"111201101" +>>> baseF 7 10000 +"41104" +>>> baseF 36 10000 +"7ps" +-} +baseF :: Integral a => Int -> a -> Builder +baseF numBase = build . atBase numBase + +---------------------------------------------------------------------------- +-- Floating-point +---------------------------------------------------------------------------- + +{- | +Format a floating-point number: + +>>> floatF 3.1415 +"3.1415" + +Numbers smaller than 1e-6 or bigger-or-equal to 1e21 will be displayed using +scientific notation: + +>>> listF' floatF [1e-6,9e-7] +"[0.000001, 9.0e-7]" +>>> listF' floatF [9e20,1e21] +"[900000000000000000000.0, 1.0e21]" +-} +floatF :: Real a => a -> Builder +floatF a | d < 1e-6 || d >= 1e21 = build $ showEFloat Nothing d "" + | otherwise = build $ showFFloat Nothing d "" + where d = realToFrac a :: Double + +{- | Format a floating-point number using scientific notation, with the given +amount of decimal places. + +>>> listF' (exptF 5) [pi,0.1,10] +"[3.14159e0, 1.00000e-1, 1.00000e1]" +-} +exptF :: Real a => Int -> a -> Builder +exptF decs a = build $ showEFloat (Just decs) (realToFrac a :: Double) "" + +{- | +Format a floating-point number without scientific notation: + +>>> listF' (fixedF 5) [pi,0.1,10] +"[3.14159, 0.10000, 10.00000]" +-} +fixedF :: Real a => Int -> a -> Builder +fixedF = F.fixed + +---------------------------------------------------------------------------- +-- Other +---------------------------------------------------------------------------- + +{- | +Break digits in a number: + +>>> commaizeF 15830000 +"15,830,000" +-} +commaizeF :: (Buildable a, Integral a) => a -> Builder +commaizeF = groupInt 3 ',' + +{- | +Add an ordinal suffix to a number: + +>>> ordinalF 15 +"15th" +>>> ordinalF 22 +"22nd" +-} +ordinalF :: (Buildable a, Integral a) => a -> Builder +ordinalF n + | tens > 3 && tens < 21 = build n <> "th" + | otherwise = build n <> case n `mod` 10 of + 1 -> "st" + 2 -> "nd" + 3 -> "rd" + _ -> "th" + where + tens = n `mod` 100 + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +groupInt :: (Buildable a, Integral a) => Int -> Char -> a -> Builder +groupInt 0 _ n = build n +groupInt i c n = + fromLazyText . TL.reverse . + foldr merge "" . + TL.zip (zeros <> cycle' zeros') . + TL.reverse . + toLazyText . build + $ n + where + zeros = TL.replicate (fromIntegral i) (TL.singleton '0') + zeros' = TL.singleton c <> TL.tail zeros + merge (f, c') rest + | f == c = TL.singleton c <> TL.singleton c' <> rest + | otherwise = TL.singleton c' <> rest + cycle' xs = xs <> cycle' xs + -- Suppress the warning about redundant Integral constraint + _ = toInteger n + +atBase :: Integral a => Int -> a -> String +atBase b _ | b < 2 || b > 36 = error ("baseF: Invalid base " ++ show b) +atBase b n = + showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) "" +{-# INLINE atBase #-} + +showSigned' :: Real a => (a -> ShowS) -> a -> ShowS +showSigned' f n + | n < 0 = showChar '-' . f (negate n) + | otherwise = f n + +intToDigit' :: Int -> Char +intToDigit' i + | i >= 0 && i < 10 = chr (ord '0' + i) + | i >= 10 && i < 36 = chr (ord 'a' + i - 10) + | otherwise = error ("intToDigit': Invalid int " ++ show i) diff --git a/lib/Fmt/Internal/Template.hs b/lib/Fmt/Internal/Template.hs new file mode 100644 --- /dev/null +++ b/lib/Fmt/Internal/Template.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + + +-- | Old-style formatting a la @text-format@. +module Fmt.Internal.Template where + + +import Data.String (IsString(..)) +import Data.Text (Text, splitOn) +import Data.Text.Lazy.Builder hiding (fromString) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Formatting.Buildable (Buildable(..)) +import Fmt.Internal.Core (FromBuilder(..)) + + +-- $setup +-- >>> import Fmt + +{- | An old-style formatting function taken from @text-format@ (see +"Data.Text.Format"). Unlike 'Data.Text.Format.format' from +"Data.Text.Format", it can produce 'String' and strict 'Text' as well (and +print to console too). Also it's polyvariadic: + +>>> format "{} + {} = {}" 2 2 4 +2 + 2 = 4 + +You can use arbitrary formatters: + +>>> format "0x{} + 0x{} = 0x{}" (hexF 130) (hexF 270) (hexF (130+270)) +0x82 + 0x10e = 0x190 +-} +format :: FormatType r => Format -> r +format f = format' f [] +{-# INLINE format #-} + +{- | Like 'format', but adds a newline. +-} +formatLn :: FormatType r => Format -> r +formatLn f = format' (f <> "\n") [] +{-# INLINE formatLn #-} + +-- | A format string. This is intentionally incompatible with other +-- string types, to make it difficult to construct a format string by +-- concatenating string fragments (a very common way to accidentally +-- make code vulnerable to malicious data). +-- +-- This type is an instance of 'IsString', so the easiest way to +-- construct a query is to enable the @OverloadedStrings@ language +-- extension and then simply write the query in double quotes. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Fmt +-- > +-- > f :: Format +-- > f = "hello {}" +-- +-- The underlying type is 'Text', so literal Haskell strings that +-- contain Unicode characters will be correctly handled. +newtype Format = Format { fromFormat :: Text } + deriving (Eq, Ord, Show) + +instance Semigroup Format where + Format a <> Format b = Format (a <> b) + +instance Monoid Format where + mempty = Format mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +instance IsString Format where + fromString = Format . fromString + +-- Format strings are almost always constants, and they're expensive +-- to interpret (which we refer to as "cracking" here). We'd really +-- like to have GHC memoize the cracking of a known-constant format +-- string, so that it occurs at most once. +-- +-- To achieve this, we arrange to have the cracked version of a format +-- string let-floated out as a CAF, by inlining the definitions of +-- build and functions that invoke it. This works well with GHC 7. + +-- | Render a format string and arguments to a 'Builder'. +renderFormat :: Format -> [Builder] -> Builder +renderFormat fmt ps = zipParams (crack fmt) ps +{-# INLINE renderFormat #-} + +zipParams :: [Builder] -> [Builder] -> Builder +zipParams fragments params = go fragments params + where go (f:fs) (y:ys) = f <> y <> go fs ys + go [f] [] = f + go _ _ = error $ "Fmt.format: there were " <> show (length fragments - 1) <> + " sites, but " <> show (length params) <> " parameters" + +crack :: Format -> [Builder] +crack = map fromText . splitOn "{}" . fromFormat + +-- | Something like 'Text.Printf.PrintfType' in "Text.Printf". +class FormatType r where + format' :: Format -> [Builder] -> r + +instance (Buildable a, FormatType r) => FormatType (a -> r) where + format' f xs = \x -> format' f (build x : xs) + +instance {-# OVERLAPPABLE #-} FromBuilder r => FormatType r where + format' f xs = fromBuilder $ renderFormat f (reverse xs) diff --git a/lib/Fmt/Internal/Tuple.hs b/lib/Fmt/Internal/Tuple.hs new file mode 100644 --- /dev/null +++ b/lib/Fmt/Internal/Tuple.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + + +module Fmt.Internal.Tuple where + + +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import Data.List (intersperse) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder +import Formatting.Buildable (Buildable, build) +import Lens.Micro + + +-- $setup +-- >>> import Fmt.Internal.Core + +class TupleF a where + {- | +Format a tuple (of up to 8 elements): + +>>> tupleF (1,2,"hi") +"(1, 2, hi)" + +If any of the elements takes several lines, an alternate format is used: + +>>> fmt $ tupleF ("test","foo\nbar","more test") +( test +, + foo + bar +, + more test ) + +You can also use 'tupleF' on lists to get tuple-like formatting. + -} + tupleF :: a -> Builder + +instance (Buildable a1, Buildable a2) + => TupleF (a1, a2) where + tupleF (a1, a2) = tupleF + [build a1, build a2] + +instance (Buildable a1, Buildable a2, Buildable a3) + => TupleF (a1, a2, a3) where + tupleF (a1, a2, a3) = tupleF + [build a1, build a2, build a3] + +instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4) + => TupleF (a1, a2, a3, a4) where + tupleF (a1, a2, a3, a4) = tupleF + [build a1, build a2, build a3, build a4] + +instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, + Buildable a5) + => TupleF (a1, a2, a3, a4, a5) where + tupleF (a1, a2, a3, a4, a5) = tupleF + [build a1, build a2, build a3, build a4, + build a5] + +instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, + Buildable a5, Buildable a6) + => TupleF (a1, a2, a3, a4, a5, a6) where + tupleF (a1, a2, a3, a4, a5, a6) = tupleF + [build a1, build a2, build a3, build a4, + build a5, build a6] + +instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, + Buildable a5, Buildable a6, Buildable a7) + => TupleF (a1, a2, a3, a4, a5, a6, a7) where + tupleF (a1, a2, a3, a4, a5, a6, a7) = tupleF + [build a1, build a2, build a3, build a4, + build a5, build a6, build a7] + +instance (Buildable a1, Buildable a2, Buildable a3, Buildable a4, + Buildable a5, Buildable a6, Buildable a7, Buildable a8) + => TupleF (a1, a2, a3, a4, a5, a6, a7, a8) where + tupleF (a1, a2, a3, a4, a5, a6, a7, a8) = tupleF + [build a1, build a2, build a3, build a4, + build a5, build a6, build a7, build a8] + +instance Buildable a => TupleF [a] where + tupleF = tupleF . map build + +instance {-# OVERLAPPING #-} TupleF [Builder] where + tupleF xs + | True `elem` mls = mconcat (intersperse ",\n" items) + | otherwise = "(" <> mconcat (intersperse ", " xs) <> ")" + where + (mls, items) = unzip $ zipWith3 buildItem + xs (set _head True falses) (set _last True falses) + -- A list of 'False's which has the same length as 'xs' + falses = map (const False) xs + -- Returns 'True' if the item is multiline + buildItem :: Builder + -> Bool -- ^ Is the item the first? + -> Bool -- ^ Is the item the last? + -> (Bool, Builder) + buildItem x isFirst isLast = + case map fromLazyText (TL.lines (toLazyText x)) of + [] | isFirst && isLast -> (False, "()\n") + | isFirst -> (False, "(\n") + | isLast -> (False, " )\n") + | otherwise -> (False, "") + ls -> + (not (null (tail ls)), + mconcat . map (<> "\n") $ + ls & _head %~ (if isFirst then ("( " <>) else (" " <>)) + & _tail.each %~ (" " <>) + & _last %~ (if isLast then (<> " )") else id)) diff --git a/lib/Fmt/Time.hs b/lib/Fmt/Time.hs --- a/lib/Fmt/Time.hs +++ b/lib/Fmt/Time.hs @@ -17,30 +17,39 @@ @@ from the @@ package. -Most of the time you'll want to use one of these formatters: +Most of the time you'll want to use one of these formatters (all of the +examples below use @"2018-02-14 16:20:45.5 CST"@): -@ ->>> __'dateTimeF' t -- full date and time__ -"Sun May 14 16:16:47 MSK 2017" +* 'dateTimeF' – full date and time: ->>> __'hmF' t -- hours and minutes__ -"16:16" + >>> dateTimeF t + "Wed Feb 14 16:20:45 CST 2018" ->>> __'hmsF' t -- hours, minutes and seconds__ -"16:16:47" +* 'hmF' – hours and minutes: ->>> __'dateDashF' t -- date in ISO 8601 format__ -"2017-05-14" + >>> hmF t + "16:20" ->>> __'diffF' False t -- time period (convenient for humans)__ -"3 seconds" +* 'hmsF' – hours, minutes and seconds: ->>> __'diffF' True t -- point in time (convenient for humans)__ -"3 seconds ago" -@ + >>> hmsF t + "16:20:45" -Note that two formatters from @Formatting.Time@ have been renamed: +* 'dateDashF' – date in ISO 8601 format: + >>> dateDashF t + "2018-02-14" + +* 'diffF' – either a time period or a point in time, in a convenient for + humans format: + + >>> diffF False 130 -- time period (130 seconds) + "2 minutes" + >>> diffF True 130 -- point in time (130 seconds in the future) + "in 2 minutes" + +Note that two formatters from @Formatting.Time@ are called differently here: + @ pico -> 'picosecondF' decimals -> 'subsecondF' @@ -116,7 +125,7 @@ import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Buildable (build) +import Formatting.Buildable (build) import Data.Text.Lazy.Builder (Builder) import Data.Time @@ -124,8 +133,10 @@ import Data.Time.Locale.Compat #endif -import Fmt.Internal (fixedF, ordinalF) +import Fmt.Internal.Numeric (fixedF, ordinalF) +-- $setup +-- >>> let t = read "2018-02-14 16:20:45.5 CST" :: ZonedTime ---------------------------------------------------------------------------- -- Custom @@ -142,25 +153,24 @@ -- | Timezone offset on the format @-HHMM@. -- --- >>> t <- getZonedTime -- >>> t --- 2017-05-14 16:16:47.62135 MSK +-- 2018-02-14 16:20:45.5 CST -- >>> tzF t --- "+0300" +-- "-0600" tzF :: FormatTime a => a -> Builder tzF = timeF "%z" -- | Timezone name. -- -- >>> tzNameF t --- "MSK" +-- "CST" tzNameF :: FormatTime a => a -> Builder tzNameF = timeF "%Z" -- | As 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@). -- -- >>> dateTimeF t --- "Sun May 14 16:16:47 MSK 2017" +-- "Wed Feb 14 16:20:45 CST 2018" dateTimeF :: FormatTime a => a -> Builder dateTimeF = timeF "%c" @@ -171,28 +181,28 @@ -- | Same as @%H:%M@. -- -- >>> hmF t --- "16:16" +-- "16:20" hmF :: FormatTime a => a -> Builder hmF = timeF "%R" -- | Same as @%H:%M:%S@. -- -- >>> hmsF t --- "16:16:47" +-- "16:20:45" hmsF :: FormatTime a => a -> Builder hmsF = timeF "%T" -- | As 'timeFmt' @locale@ (e.g. @%H:%M:%S@). -- -- >>> hmsLF t --- "16:16:47" +-- "16:20:45" hmsLF :: FormatTime a => a -> Builder hmsLF = timeF "%X" -- | As 'time12Fmt' @locale@ (e.g. @%I:%M:%S %p@). -- -- >>> hmsPLF t --- "04:16:47 PM" +-- "04:20:45 PM" hmsPLF :: FormatTime a => a -> Builder hmsPLF = timeF "%r" @@ -214,10 +224,7 @@ -- -- >>> hour24F t -- "16" --- >>> let nightT = read "2017-05-14 00:21:32.714083 UTC" :: UTCTime --- >>> nightT --- 2017-05-14 00:21:32.714083 UTC --- >>> hour24F nightT +-- >>> hour24F midnight -- "00" hour24F :: FormatTime a => a -> Builder hour24F = timeF "%H" @@ -226,45 +233,47 @@ -- -- >>> hour12F t -- "04" --- >>> hour12F nightT +-- >>> hour12F midnight -- "12" hour12F :: FormatTime a => a -> Builder hour12F = timeF "%I" -- | Hour, 24-hour, leading space as needed, @ 0@ - @23@. -- --- >>> hour24SF nightT +-- >>> hour24SF t +-- "16" +-- >>> hour24SF midnight -- " 0" hour24SF :: FormatTime a => a -> Builder hour24SF = timeF "%k" -- | Hour, 12-hour, leading space as needed, @ 1@ - @12@. -- --- >>> hour12SF nightT +-- >>> hour12SF t +-- " 4" +-- >>> hour12SF midnight -- "12" hour12SF :: FormatTime a => a -> Builder hour12SF = timeF "%l" -- | Minute, @00@ - @59@. -- --- >>> otherT --- 2017-05-14 17:12:47.897343 MSK --- >>> minuteF otherT --- "12" +-- >>> minuteF t +-- "20" minuteF :: FormatTime a => a -> Builder minuteF = timeF "%M" -- | Second, without decimal part, @00@ - @60@. -- -- >>> secondF t --- "47" +-- "45" secondF :: FormatTime a => a -> Builder secondF = timeF "%S" -- | Picosecond, including trailing zeros, @000000000000@ - @999999999999@. -- -- >>> picosecondF t --- "621350000000" +-- "500000000000" picosecondF :: FormatTime a => a -> Builder picosecondF = timeF "%q" @@ -272,7 +281,7 @@ -- For a whole number of seconds, this produces an empty string. -- -- >>> subsecondF t --- ".62135" +-- ".5" subsecondF :: FormatTime a => a -> Builder subsecondF = timeF "%Q" @@ -286,7 +295,7 @@ -- Unix epoch is formatted as @-1.1@ with @%s%Q@. -- -- >>> epochF t --- "1494767807" +-- "1518646845" epochF :: FormatTime a => a -> Builder epochF = timeF "%s" @@ -297,35 +306,35 @@ -- | Same as @%m\/%d\/%y@. -- -- >>> dateSlashF t --- "05/14/17" +-- "02/14/18" dateSlashF :: FormatTime a => a -> Builder dateSlashF = timeF "%D" -- | Same as @%Y-%m-%d@. -- -- >>> dateDashF t --- "2017-05-14" +-- "2018-02-14" dateDashF :: FormatTime a => a -> Builder dateDashF = timeF "%F" -- | As 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@). -- -- >>> dateSlashLF t --- "05/14/17" +-- "02/14/18" dateSlashLF :: FormatTime a => a -> Builder dateSlashLF = timeF "%x" -- | Year. -- -- >>> yearF t --- "2017" +-- "2018" yearF :: FormatTime a => a -> Builder yearF = timeF "%Y" -- | Last two digits of year, @00@ - @99@. -- -- >>> yyF t --- "17" +-- "18" yyF :: FormatTime a => a -> Builder yyF = timeF "%y" @@ -339,23 +348,22 @@ -- | Month name, long form ('fst' from 'months' @locale@), @January@ - -- @December@. -- --- >>> let longMonthT = read "2017-01-12 00:21:32.714083 UTC" :: UTCTime --- >>> monthNameF longMonthT --- "January" +-- >>> monthNameF t +-- "February" monthNameF :: FormatTime a => a -> Builder monthNameF = timeF "%B" -- | Month name, short form ('snd' from 'months' @locale@), @Jan@ - @Dec@. -- --- >>> monthNameShortF longMonthT --- "Jan" +-- >>> monthNameShortF t +-- "Feb" monthNameShortF :: FormatTime a => a -> Builder monthNameShortF = timeF "%b" -- | Month of year, leading 0 as needed, @01@ - @12@. -- --- >>> monthF longMonthT --- "01" +-- >>> monthF t +-- "02" monthF :: FormatTime a => a -> Builder monthF = timeF "%m" @@ -383,21 +391,21 @@ -- | Day of year for Ordinal Date format, @001@ - @366@. -- -- >>> dayF t --- "134" +-- "045" dayF :: FormatTime a => a -> Builder dayF = timeF "%j" -- | Year for Week Date format e.g. @2013@. -- -- >>> weekYearF t --- "2017" +-- "2018" weekYearF :: FormatTime a => a -> Builder weekYearF = timeF "%G" -- | Last two digits of year for Week Date format, @00@ - @99@. -- -- >>> weekYYF t --- "17" +-- "18" weekYYF :: FormatTime a => a -> Builder weekYYF = timeF "%g" @@ -411,21 +419,21 @@ -- | Week for Week Date format, @01@ - @53@. -- -- >>> weekF t --- "19" +-- "07" weekF :: FormatTime a => a -> Builder weekF = timeF "%V" -- | Day for Week Date format, @1@ - @7@. -- -- >>> dayOfWeekF t --- "7" +-- "3" dayOfWeekF :: FormatTime a => a -> Builder dayOfWeekF = timeF "%u" -- | Day of week, short form ('snd' from 'wDays' @locale@), @Sun@ - @Sat@. -- -- >>> dayNameShortF t --- "Sun" +-- "Wed" dayNameShortF :: FormatTime a => a -> Builder dayNameShortF = timeF "%a" @@ -433,7 +441,7 @@ -- @Saturday@. -- -- >>> dayNameF t --- "Sunday" +-- "Wednesday" dayNameF :: FormatTime a => a -> Builder dayNameF = timeF "%A" @@ -441,14 +449,14 @@ -- 'sundayStartWeek'), @00@ - @53@. -- -- >>> weekFromZeroF t --- "20" +-- "06" weekFromZeroF :: FormatTime a => a -> Builder weekFromZeroF = timeF "%U" -- | Day of week number, @0@ (= Sunday) - @6@ (= Saturday). -- -- >>> dayOfWeekFromZeroF t --- "0" +-- "3" dayOfWeekFromZeroF :: FormatTime a => a -> Builder dayOfWeekFromZeroF = timeF "%w" @@ -456,7 +464,7 @@ -- 'mondayStartWeek'), @00@ - @53@. -- -- >>> weekOfYearMonF t --- "19" +-- "07" weekOfYearMonF :: FormatTime a => a -> Builder weekOfYearMonF = timeF "%W" @@ -522,10 +530,10 @@ -- | Display the absolute value time span in years. -- --- >>> epochF t --- "1494767807" --- >>> yearsF 3 1494767807 --- "47.399" +-- >>> epochF t -- time passed since Jan 1, 1970 +-- "1518646845" +-- >>> yearsF 3 1518646845 +-- "48.156" yearsF :: RealFrac n => Int -- ^ Decimal places. -> n @@ -535,8 +543,8 @@ -- | Display the absolute value time span in days. -- --- >>> daysF 3 1494767807 --- "17300.553" +-- >>> daysF 3 1518646845 +-- "17576.931" daysF :: RealFrac n => Int -- ^ Decimal places. -> n diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} module Main where @@ -22,6 +23,8 @@ import qualified Data.ByteString.Lazy as BSL -- Generics import GHC.Generics +-- Call stacks +import Data.CallStack -- Tests import Test.Hspec @@ -149,8 +152,6 @@ exptF 2 f1_3 ==#> "1.30e0" it "fixedF" $ do fixedF 2 f1_3 ==#> "1.30" - it "precF" $ do - precF 2 f1_3 ==#> "1.3" test_hex :: Spec test_hex = describe "'hexF'" $ do @@ -508,14 +509,14 @@ test_tuples :: Spec test_tuples = describe "tuples" $ do test_tupleSimple - describe "tupleLikeF" $ do + describe "tupleF on lists" $ do test_tupleOneLine test_tupleMultiline test_tupleSimple :: Spec test_tupleSimple = it "tupleF" $ do -- we don't need complicated tests here, they're all tested in - -- 'tupleLikeF' tests + -- "tupleF on lists" tests tupleF (n, s) ==#> "(25, !)" tupleF (n, s, n, s) ==#> "(25, !, 25, !)" tupleF (n, s, n, s, 'a', 'b', 'c', 'd') ==#> @@ -524,21 +525,21 @@ test_tupleOneLine :: Spec test_tupleOneLine = describe "one-line" $ do it "()" $ do - tupleLikeF [] ==#> "()" + tupleF ([] :: [Builder]) ==#> "()" it "('')" $ do - tupleLikeF [""] ==#> "()" + tupleF ([""] :: [Builder]) ==#> "()" it "(a)" $ do - tupleLikeF ["a"] ==#> "(a)" + tupleF (["a"] :: [Builder]) ==#> "(a)" it "(a,b)" $ do - tupleLikeF ["a", "b"] ==#> "(a, b)" + tupleF (["a", "b"] :: [Builder]) ==#> "(a, b)" it "(a,'')" $ do - tupleLikeF ["a", ""] ==#> "(a, )" + tupleF (["a", ""] :: [Builder]) ==#> "(a, )" it "('',b)" $ do - tupleLikeF ["", "b"] ==#> "(, b)" + tupleF (["", "b"] :: [Builder]) ==#> "(, b)" it "('','')" $ do - tupleLikeF ["", ""] ==#> "(, )" + tupleF (["", ""] :: [Builder]) ==#> "(, )" it "(a,b,c)" $ do - tupleLikeF ["a", "ba", "caba"] ==#> "(a, ba, caba)" + tupleF (["a", "ba", "caba"] :: [Builder]) ==#> "(a, ba, caba)" test_tupleMultiline :: Spec test_tupleMultiline = describe "multiline" $ do @@ -546,45 +547,45 @@ someEmpty it "weird case" $ do -- not sure whether I should fix it or not - tupleLikeF ["a\n"] ==#> "(a\n)" + tupleF ["a\n" :: Builder] ==#> "(a\n)" where allNonEmpty = describe "all non-empty" $ do it "1 element (2 lines)" $ do - tupleLikeF ["a\nx"] ==#> [text| + tupleF ["a\nx" :: Builder] ==#> [text| ( a x ) |] - tupleLikeF ["a\n x"] ==#> [text| + tupleF ["a\n x" :: Builder] ==#> [text| ( a x ) |] - tupleLikeF [" a\nx\n"] ==#> [text| + tupleF [" a\nx\n" :: Builder] ==#> [text| ( a x ) |] it "1 element (3 lines)" $ do - tupleLikeF ["a\nb\nc"] ==#> [text| + tupleF ["a\nb\nc" :: Builder] ==#> [text| ( a b c ) |] it "2 elements (1 line + 2 lines)" $ do - tupleLikeF ["a", "b\nc"] ==#> [text| + tupleF ["a", "b\nc" :: Builder] ==#> [text| ( a , b c ) |] it "2 elements (2 lines + 1 line)" $ do - tupleLikeF ["a\nb", "c"] ==#> [text| + tupleF ["a\nb", "c" :: Builder] ==#> [text| ( a b , c ) |] it "3 elements (each has 2 lines)" $ do - tupleLikeF ["a\nb", "c\nd", "e\nf"] ==#> [text| + tupleF ["a\nb", "c\nd", "e\nf" :: Builder] ==#> [text| ( a b , @@ -597,21 +598,21 @@ someEmpty = describe "some empty" $ do it "2 elements (0 + 2)" $ do - tupleLikeF ["", "a\nb"] ==#> [text| + tupleF ["", "a\nb" :: Builder] ==#> [text| ( , a b ) |] it "2 elements (2 + 0)" $ do - tupleLikeF ["a\nb", ""] ==#> [text| + tupleF ["a\nb", "" :: Builder] ==#> [text| ( a b , ) |] it "3 elements (0 + 2 + 0)" $ do - tupleLikeF ["", "a\nb", ""] ==#> [text| + tupleF ["", "a\nb", "" :: Builder] ==#> [text| ( , a @@ -620,7 +621,7 @@ ) |] it "3 elements (2 + 0 + 2)" $ do - tupleLikeF ["a\nb", "", "c\nd"] ==#> [text| + tupleF ["a\nb", "", "c\nd" :: Builder] ==#> [text| ( a b , @@ -629,7 +630,7 @@ d ) |] it "4 elements (2 + 0 + 0 + 2)" $ do - tupleLikeF ["a\nb", "", "", "c\nd"] ==#> [text| + tupleF ["a\nb", "", "", "c\nd" :: Builder] ==#> [text| ( a b , @@ -706,8 +707,8 @@ -- Utilities ---------------------------------------------------------------------------- -(==%>) :: Text -> Text -> Expectation +(==%>) :: HasCallStack => Text -> Text -> Expectation (==%>) = shouldBe -(==#>) :: Builder -> Text -> Expectation +(==#>) :: HasCallStack => Builder -> Text -> Expectation (==#>) a b = a `shouldBe` build (T.replace "_" " " b) diff --git a/tests/doctest-config.json b/tests/doctest-config.json new file mode 100644 --- /dev/null +++ b/tests/doctest-config.json @@ -0,0 +1,3 @@ +{ + "sourceFolders": ["lib"] +} diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF doctest-discover -optF tests/doctest-config.json #-}