{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Internal format starters.

module Formatting.Internal where

import           Control.Category (Category(..))
import           Data.Monoid
import qualified Data.Semigroup
import           Data.String
import qualified Data.Text as S (Text)
import           Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy as TL
import           Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as T
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.IO as T
import           Prelude hiding ((.),id)
import           System.IO

-- | A formatter. When you construct formatters the first type
-- parameter, @r@, will remain polymorphic.  The second type
-- parameter, @a@, will change to reflect the types of the data that
-- will be formatted.  For example, in
--
-- @
-- myFormat :: Formatter r (Text -> Int -> r)
-- myFormat = \"Person's name is \" % text % \", age is \" % hex
-- @
--
-- the first type parameter remains polymorphic, and the second type
-- parameter is @Text -> Int -> r@, which indicates that it formats a
-- 'Text' and an 'Int'.
--
-- When you run the 'Format', for example with 'format', you provide
-- the arguments and they will be formatted into a string.
--
-- @
-- \> format (\"Person's name is \" % text % \", age is \" % hex) \"Dave\" 54
-- \"Person's name is Dave, age is 36\"
-- @
newtype Format r a =
  Format {Format r a -> (Builder -> r) -> a
runFormat :: (Builder -> r) -> a}

-- | Not particularly useful, but could be.
instance Functor (Format r) where
  fmap :: (a -> b) -> Format r a -> Format r b
fmap a -> b
f (Format (Builder -> r) -> a
k) = ((Builder -> r) -> b) -> Format r b
forall r a. ((Builder -> r) -> a) -> Format r a
Format (\Builder -> r
br -> a -> b
f ((Builder -> r) -> a
k Builder -> r
br))

-- | Useful instance for applying two formatters to the same input
-- argument. For example: @format (year <> "/" % month) now@ will
-- yield @"2015/01"@.
instance Monoid (Format r (a -> r)) where
  mappend :: Format r (a -> r) -> Format r (a -> r) -> Format r (a -> r)
mappend Format r (a -> r)
m Format r (a -> r)
n =
    ((Builder -> r) -> a -> r) -> Format r (a -> r)
forall r a. ((Builder -> r) -> a) -> Format r a
Format (\Builder -> r
k a
a ->
              Format r (a -> r) -> (Builder -> r) -> a -> r
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format r (a -> r)
m (\Builder
b1 -> Format r (a -> r) -> (Builder -> r) -> a -> r
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format r (a -> r)
n (\Builder
b2 -> Builder -> r
k (Builder
b1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b2)) a
a) a
a)
  mempty :: Format r (a -> r)
mempty = ((Builder -> r) -> a -> r) -> Format r (a -> r)
forall r a. ((Builder -> r) -> a) -> Format r a
Format (\Builder -> r
k a
_ -> Builder -> r
k Builder
forall a. Monoid a => a
mempty)

instance Data.Semigroup.Semigroup (Format r (a -> r)) where
  <> :: Format r (a -> r) -> Format r (a -> r) -> Format r (a -> r)
(<>) = Format r (a -> r) -> Format r (a -> r) -> Format r (a -> r)
forall a. Monoid a => a -> a -> a
mappend

-- | Useful instance for writing format string. With this you can
-- write @"Foo"@ instead of @now "Foo!"@.
instance (a ~ r) => IsString (Format r a) where
  fromString :: String -> Format r a
fromString = Builder -> Format r r
forall r. Builder -> Format r r
now (Builder -> Format r r)
-> (String -> Builder) -> String -> Format r r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Builder
forall a. IsString a => String -> a
fromString

-- | The same as (%). At present using 'Category' has an import
-- overhead, but one day it might be imported as standard.
instance Category Format where
  id :: Format a a
id = Builder -> Format a a
forall r. Builder -> Format r r
now Builder
forall a. Monoid a => a
mempty
  Format b c
f . :: Format b c -> Format a b -> Format a c
. Format a b
g =
    Format b c
f Format b c -> (Builder -> Format a b) -> Format a c
forall r a r'.
Format r a -> (Builder -> Format r' r) -> Format r' a
`bind`
    \Builder
a ->
      Format a b
g Format a b -> (Builder -> Format a a) -> Format a b
forall r a r'.
Format r a -> (Builder -> Format r' r) -> Format r' a
`bind`
      \Builder
b -> Builder -> Format a a
forall r. Builder -> Format r r
now (Builder
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b)

-- | Concatenate two formatters.
--
-- @formatter1 % formatter2@ is a formatter that accepts arguments for
-- @formatter1@ and @formatter2@ and concatenates their results.  For example
--
-- @
-- format1 :: Format r (Text -> r)
-- format1 = \"Person's name is \" % text
-- @
--
-- @
-- format2 :: Format r r
-- format2 = \", \"
-- @
--
-- @
-- format3 :: Format r (Int -> r)
-- format3 = \"age is \" % hex
-- @
--
-- @
-- myFormat :: Formatter r (Text -> Int -> r)
-- myFormat = format1 % format2 % format3
-- @
--
-- Notice how the argument types of @format1@ and @format3@ are
-- gathered into the type of @myFormat@.
--
-- (This is actually the composition operator for 'Format''s
-- 'Category' instance, but that is (at present) inconvenient to use
-- with regular "Prelude". So this function is provided as a
-- convenience.)
(%) :: Format r a -> Format r' r -> Format r' a
% :: Format r a -> Format r' r -> Format r' a
(%) = Format r a -> Format r' r -> Format r' a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)
infixr 9 %

-- | Function compose two formatters. Will feed the result of one
-- formatter into another.
(%.) :: Format r (Builder -> r') -> Format r' a -> Format r a
%. :: Format r (Builder -> r') -> Format r' a -> Format r a
(%.) (Format (Builder -> r) -> Builder -> r'
a) (Format (Builder -> r') -> a
b) = ((Builder -> r) -> a) -> Format r a
forall r a. ((Builder -> r) -> a) -> Format r a
Format ((Builder -> r') -> a
b ((Builder -> r') -> a)
-> ((Builder -> r) -> Builder -> r') -> (Builder -> r) -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Builder -> r) -> Builder -> r'
a)
infixr 8 %.

-- | Don't format any data, just output a constant 'Builder'.
now :: Builder -> Format r r
now :: Builder -> Format r r
now Builder
a = ((Builder -> r) -> r) -> Format r r
forall r a. ((Builder -> r) -> a) -> Format r a
Format ((Builder -> r) -> Builder -> r
forall a b. (a -> b) -> a -> b
$ Builder
a)

-- | Monadic indexed bind for holey monoids.
bind :: Format r a -> (Builder -> Format r' r) -> Format r' a
Format r a
m bind :: Format r a -> (Builder -> Format r' r) -> Format r' a
`bind` Builder -> Format r' r
f = ((Builder -> r') -> a) -> Format r' a
forall r a. ((Builder -> r) -> a) -> Format r a
Format (((Builder -> r') -> a) -> Format r' a)
-> ((Builder -> r') -> a) -> Format r' a
forall a b. (a -> b) -> a -> b
$ \Builder -> r'
k -> Format r a -> (Builder -> r) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format r a
m (\Builder
a -> Format r' r -> (Builder -> r') -> r
forall r a. Format r a -> (Builder -> r) -> a
runFormat (Builder -> Format r' r
f Builder
a) Builder -> r'
k)

-- | Functorial map over a formatter's input. Example: @format (mapf (drop 1) string) \"hello\"@
mapf :: (a -> b) -> Format r (b -> t) -> Format r (a -> t)
mapf :: (a -> b) -> Format r (b -> t) -> Format r (a -> t)
mapf a -> b
f Format r (b -> t)
m = ((Builder -> r) -> a -> t) -> Format r (a -> t)
forall r a. ((Builder -> r) -> a) -> Format r a
Format (\Builder -> r
k -> Format r (b -> t) -> (Builder -> r) -> b -> t
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format r (b -> t)
m Builder -> r
k (b -> t) -> (a -> b) -> a -> t
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)

-- | Format a value of type @a@ using a function of type @a ->
-- 'Builder'@. For example, @later (f :: Int -> Builder)@ produces
-- @Format r (Int -> r)@.
later :: (a -> Builder) -> Format r (a -> r)
later :: (a -> Builder) -> Format r (a -> r)
later a -> Builder
f = ((Builder -> r) -> a -> r) -> Format r (a -> r)
forall r a. ((Builder -> r) -> a) -> Format r a
Format ((Builder -> r) -> (a -> Builder) -> a -> r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Builder
f)

-- | Run the formatter and return a lazy 'Text' value.
format :: Format Text a -> a
format :: Format Text a -> a
format Format Text a
m = Format Text a -> (Builder -> Text) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format Text a
m Builder -> Text
T.toLazyText

-- | Run the formatter and return a strict 'S.Text' value.
sformat :: Format S.Text a -> a
sformat :: Format Text a -> a
sformat Format Text a
m = Format Text a -> (Builder -> Text) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format Text a
m (Text -> Text
T.toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Text
T.toLazyText)

-- | Run the formatter and return a 'Builder' value.
bprint :: Format Builder a -> a
bprint :: Format Builder a -> a
bprint Format Builder a
m = Format Builder a -> (Builder -> Builder) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format Builder a
m Builder -> Builder
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Run the formatter and print out the text to stdout.
fprint :: Format (IO ()) a -> a
fprint :: Format (IO ()) a -> a
fprint Format (IO ()) a
m = Format (IO ()) a -> (Builder -> IO ()) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format (IO ()) a
m (Text -> IO ()
T.putStr (Text -> IO ()) -> (Builder -> Text) -> Builder -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Text
T.toLazyText)

-- | Run the formatter and put the output onto the given 'Handle'.
hprint :: Handle -> Format (IO ()) a -> a
hprint :: Handle -> Format (IO ()) a -> a
hprint Handle
h Format (IO ()) a
m = Format (IO ()) a -> (Builder -> IO ()) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format (IO ()) a
m (Handle -> Text -> IO ()
T.hPutStr Handle
h (Text -> IO ()) -> (Builder -> Text) -> Builder -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Text
T.toLazyText)

-- | Run the formatter and return a list of characters.
formatToString :: Format [Char] a -> a
formatToString :: Format String a -> a
formatToString Format String a
m = Format String a -> (Builder -> String) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format String a
m (Text -> String
TL.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Text
TLB.toLazyText)