{-# 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 :: 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 :: 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
/= :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c== :: 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
min :: Format -> Format -> Format
$cmin :: Format -> Format -> Format
max :: Format -> Format -> Format
$cmax :: Format -> Format -> Format
>= :: Format -> Format -> Bool
$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
compare :: Format -> Format -> Ordering
$ccompare :: Format -> Format -> Ordering
$cp1Ord :: Eq 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
showList :: [Format] -> ShowS
$cshowList :: [Format] -> ShowS
show :: Format -> String
$cshow :: Format -> String
showsPrec :: Int -> Format -> ShowS
$cshowsPrec :: Int -> 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 p. Semigroup p => [p] -> [p] -> p
go [Builder]
fragments [Builder]
params
  where go :: [p] -> [p] -> p
go (p
f:[p]
fs) (p
y:[p]
ys) = p
f p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
y p -> p -> p
forall a. Semigroup a => a -> a -> a
<> [p] -> [p] -> p
go [p]
fs [p]
ys
        go [p
f] []        = p
f
        go [p]
_ [p]
_  = String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
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 (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 (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
. 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)