{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}


-- | Old-style formatting a la @text-format@.
module Fmt.Internal.Template where


import Data.CallStack
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 :: (HasCallStack, FormatType r) => Format -> r
format :: forall r. (HasCallStack, FormatType r) => Format -> r
format Format
f = Format -> [Builder] -> r
forall r. FormatType r => Format -> [Builder] -> r
format' Format
f []
{-# INLINE format #-}

{- | Like 'format', but adds a newline.
-}
formatLn :: (HasCallStack, FormatType r) => Format -> r
formatLn :: forall r. (HasCallStack, FormatType r) => Format -> r
formatLn Format
f = Format -> [Builder] -> r
forall r. FormatType r => Format -> [Builder] -> r
format' (Format
f Format -> Format -> Format
forall a. Semigroup a => a -> a -> a
<> Format
"\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 { Format -> Text
fromFormat :: Text }
  deriving (Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
/= :: Format -> Format -> Bool
Eq, Eq Format
Eq Format =>
(Format -> Format -> Ordering)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Format)
-> (Format -> Format -> Format)
-> Ord Format
Format -> Format -> Bool
Format -> Format -> Ordering
Format -> Format -> Format
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Format -> Format -> Ordering
compare :: Format -> Format -> Ordering
$c< :: Format -> Format -> Bool
< :: Format -> Format -> Bool
$c<= :: Format -> Format -> Bool
<= :: Format -> Format -> Bool
$c> :: Format -> Format -> Bool
> :: Format -> Format -> Bool
$c>= :: Format -> Format -> Bool
>= :: Format -> Format -> Bool
$cmax :: Format -> Format -> Format
max :: Format -> Format -> Format
$cmin :: Format -> Format -> Format
min :: Format -> Format -> Format
Ord, Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> String
show :: Format -> String
$cshowList :: [Format] -> ShowS
showList :: [Format] -> ShowS
Show)

instance Semigroup Format where
  Format Text
a <> :: Format -> Format -> Format
<> Format Text
b = Text -> Format
Format (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)

instance Monoid Format where
  mempty :: Format
mempty = Text -> Format
Format Text
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  mappend = (<>)
#endif

instance IsString Format where
  fromString :: String -> Format
fromString = Text -> Format
Format (Text -> Format) -> (String -> Text) -> String -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
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 :: Format -> [Builder] -> Builder
renderFormat Format
fmt [Builder]
ps = [Builder] -> [Builder] -> Builder
zipParams (Format -> [Builder]
crack Format
fmt) [Builder]
ps
{-# INLINE renderFormat #-}

zipParams :: [Builder] -> [Builder] -> Builder
zipParams :: [Builder] -> [Builder] -> Builder
zipParams [Builder]
fragments [Builder]
params = [Builder] -> [Builder] -> Builder
forall {a}. Semigroup a => [a] -> [a] -> a
go [Builder]
fragments [Builder]
params
  where go :: [a] -> [a] -> a
go (a
f:[a]
fs) (a
y:[a]
ys) = a
f a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y a -> a -> a
forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> a
go [a]
fs [a]
ys
        go [a
f] []        = a
f
        go [a]
_ [a]
_  = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Fmt.format: there were " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Builder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Builder]
fragments Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                          String
" sites, but " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Builder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Builder]
params) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" parameters"

crack :: Format -> [Builder]
crack :: Format -> [Builder]
crack = (Text -> Builder) -> [Text] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Builder
fromText ([Text] -> [Builder]) -> (Format -> [Text]) -> Format -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"{}" (Text -> [Text]) -> (Format -> Text) -> Format -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Text
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' :: Format -> [Builder] -> a -> r
format' Format
f [Builder]
xs = \a
x -> Format -> [Builder] -> r
forall r. FormatType r => Format -> [Builder] -> r
format' Format
f (a -> Builder
forall p. Buildable p => p -> Builder
build a
x Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
xs)

instance {-# OVERLAPPABLE #-} FromBuilder r => FormatType r where
  format' :: Format -> [Builder] -> r
format' Format
f [Builder]
xs = Builder -> r
forall a. FromBuilder a => Builder -> a
fromBuilder (Builder -> r) -> Builder -> r
forall a b. (a -> b) -> a -> b
$ Format -> [Builder] -> Builder
renderFormat Format
f ([Builder] -> [Builder]
forall a. [a] -> [a]
reverse [Builder]
xs)