{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Ginger.StringFormatting.Printf
where

import Control.Applicative ( (<|>) )
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import Text.Printf (printf, PrintfArg)
import Data.Maybe (fromMaybe)
import Data.Void (Void)
import Data.Char (isDigit)

printfList :: PrintfArg a => String -> [a] -> String
printfList :: forall a. PrintfArg a => [Char] -> [a] -> [Char]
printfList [Char]
fmt [a]
args =
  [Char]
leader [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Char] -> a -> [Char]) -> [[Char]] -> [a] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Char] -> a -> [Char]
forall r. PrintfType r => [Char] -> r
printf [[Char]]
fmts [a]
args)
  where
    ([Char]
leader, [[Char]]
fmts) = [Char] -> ([Char], [[Char]])
splitPrintfFormat [Char]
fmt

splitPrintfFormat :: String -> (String, [String])
splitPrintfFormat :: [Char] -> ([Char], [[Char]])
splitPrintfFormat [Char]
fmt =
  ([Char], [[Char]])
-> Maybe ([Char], [[Char]]) -> ([Char], [[Char]])
forall a. a -> Maybe a -> a
fromMaybe ([Char]
"", []) (Maybe ([Char], [[Char]]) -> ([Char], [[Char]]))
-> Maybe ([Char], [[Char]]) -> ([Char], [[Char]])
forall a b. (a -> b) -> a -> b
$ Parsec Void [Char] ([Char], [[Char]])
-> [Char] -> Maybe ([Char], [[Char]])
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
P.parseMaybe Parsec Void [Char] ([Char], [[Char]])
pPrintfFormats [Char]
fmt

type P a = P.Parsec Void String a

pPrintfFormats :: P (String, [String])
pPrintfFormats :: Parsec Void [Char] ([Char], [[Char]])
pPrintfFormats = (,) ([Char] -> [[Char]] -> ([Char], [[Char]]))
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity ([[Char]] -> ([Char], [[Char]]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [Char] Identity [Char]
pLeader ParsecT Void [Char] Identity ([[Char]] -> ([Char], [[Char]]))
-> ParsecT Void [Char] Identity [[Char]]
-> Parsec Void [Char] ([Char], [[Char]])
forall a b.
ParsecT Void [Char] Identity (a -> b)
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [[Char]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ParsecT Void [Char] Identity [Char]
pPrintfFormat

pLeader :: P String
pLeader :: ParsecT Void [Char] Identity [Char]
pLeader = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char])
-> ParsecT Void [Char] Identity [[Char]]
-> ParsecT Void [Char] Identity [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [[Char]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (([Char]
"%" [Char]
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall a b.
a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void [Char] Identity [Char]
pDoublePercent) ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void [Char] Identity [Char]
pPrintfPlainChars)

pTrailer :: P String
pTrailer :: ParsecT Void [Char] Identity [Char]
pTrailer = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char])
-> ParsecT Void [Char] Identity [[Char]]
-> ParsecT Void [Char] Identity [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [[Char]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (ParsecT Void [Char] Identity [Char]
pDoublePercent ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void [Char] Identity [Char]
pPrintfPlainChars)

pDoublePercent :: P String
pDoublePercent :: ParsecT Void [Char] Identity [Char]
pDoublePercent = Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.chunk [Char]
Tokens [Char]
"%%"

pPrintfPlainChars :: P String
pPrintfPlainChars :: ParsecT Void [Char] Identity [Char]
pPrintfPlainChars = Maybe [Char]
-> (Token [Char] -> Bool)
-> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"plain characters") (Token [Char] -> Token [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token [Char]
'%')

pPrintfFormat :: P String
pPrintfFormat :: ParsecT Void [Char] Identity [Char]
pPrintfFormat = do
  leadingPercent <- Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.chunk [Char]
Tokens [Char]
"%"
  flags <- P.takeWhileP (Just "flags") (`elem` flagChars)
  fieldWidth <- pFieldWidth
  precision <- P.option "" $ (P.chunk "." *> pFieldWidth)
  widthModifier <- P.takeWhileP (Just "width modifier") (`elem` widthChars)
  formatChar <- P.choice
    [ 'd' <$ P.char 'i'
    , 'v' <$ P.satisfy (`elem` stringFormatChars)
    , P.satisfy (`elem` formatChars)
    , pure 'v'
    ]
  remaining <- pTrailer
  pure $ concat
    [ leadingPercent
    , flags
    , fieldWidth
    , precision
    , widthModifier
    , [formatChar]
    , remaining
    ]

  where
    pFieldWidth :: P String
    pFieldWidth :: ParsecT Void [Char] Identity [Char]
pFieldWidth = Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.chunk [Char]
Tokens [Char]
"*" ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void [Char] Identity [Char]
pNumericFieldWidth

    pNumericFieldWidth :: P String
    pNumericFieldWidth :: ParsecT Void [Char] Identity [Char]
pNumericFieldWidth =
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) ([Char] -> [Char] -> [Char])
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option [Char]
"" (Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.chunk [Char]
Tokens [Char]
"-")
           ParsecT Void [Char] Identity ([Char] -> [Char])
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall a b.
ParsecT Void [Char] Identity (a -> b)
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [Char]
-> (Token [Char] -> Bool)
-> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"numeric field width") Char -> Bool
Token [Char] -> Bool
isDigit

    flagChars :: [Char]
    flagChars :: [Char]
flagChars = [Char]
" +-0#"

    widthChars :: [Char]
    widthChars :: [Char]
widthChars = [Char]
"lLhH"

    stringFormatChars :: [Char]
    stringFormatChars :: [Char]
stringFormatChars = [Char]
"rsa"

    formatChars :: [Char]
    formatChars :: [Char]
formatChars = [Char]
"cdobuxXfFgGeEsv"