{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Haskell.Printf.Lib (
  toSplices,
  OutputType (..),
) where

import Data.Maybe
import Data.String (fromString)
import GHC.Generics (Generic)
import Language.Haskell.Printf.Geometry (
  formatOne,
 )
import qualified Language.Haskell.Printf.Printers as Printers
import Language.Haskell.PrintfArg
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import Buf (
  SizedBuilder,
  SizedStr,
  finalize,
 )
import Control.Monad (mapAndUnzipM)
import Parser (parseStr)
import Parser.Types hiding (
  lengthSpec,
  width,
 )

data OutputType = OutputString | OutputText
  deriving (Int -> OutputType -> ShowS
[OutputType] -> ShowS
OutputType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputType] -> ShowS
$cshowList :: [OutputType] -> ShowS
show :: OutputType -> String
$cshow :: OutputType -> String
showsPrec :: Int -> OutputType -> ShowS
$cshowsPrec :: Int -> OutputType -> ShowS
Show, OutputType -> OutputType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputType -> OutputType -> Bool
$c/= :: OutputType -> OutputType -> Bool
== :: OutputType -> OutputType -> Bool
$c== :: OutputType -> OutputType -> Bool
Eq, Eq OutputType
OutputType -> OutputType -> Bool
OutputType -> OutputType -> Ordering
OutputType -> OutputType -> OutputType
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 :: OutputType -> OutputType -> OutputType
$cmin :: OutputType -> OutputType -> OutputType
max :: OutputType -> OutputType -> OutputType
$cmax :: OutputType -> OutputType -> OutputType
>= :: OutputType -> OutputType -> Bool
$c>= :: OutputType -> OutputType -> Bool
> :: OutputType -> OutputType -> Bool
$c> :: OutputType -> OutputType -> Bool
<= :: OutputType -> OutputType -> Bool
$c<= :: OutputType -> OutputType -> Bool
< :: OutputType -> OutputType -> Bool
$c< :: OutputType -> OutputType -> Bool
compare :: OutputType -> OutputType -> Ordering
$ccompare :: OutputType -> OutputType -> Ordering
Ord, forall x. Rep OutputType x -> OutputType
forall x. OutputType -> Rep OutputType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OutputType x -> OutputType
$cfrom :: forall x. OutputType -> Rep OutputType x
Generic, Int -> OutputType
OutputType -> Int
OutputType -> [OutputType]
OutputType -> OutputType
OutputType -> OutputType -> [OutputType]
OutputType -> OutputType -> OutputType -> [OutputType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OutputType -> OutputType -> OutputType -> [OutputType]
$cenumFromThenTo :: OutputType -> OutputType -> OutputType -> [OutputType]
enumFromTo :: OutputType -> OutputType -> [OutputType]
$cenumFromTo :: OutputType -> OutputType -> [OutputType]
enumFromThen :: OutputType -> OutputType -> [OutputType]
$cenumFromThen :: OutputType -> OutputType -> [OutputType]
enumFrom :: OutputType -> [OutputType]
$cenumFrom :: OutputType -> [OutputType]
fromEnum :: OutputType -> Int
$cfromEnum :: OutputType -> Int
toEnum :: Int -> OutputType
$ctoEnum :: Int -> OutputType
pred :: OutputType -> OutputType
$cpred :: OutputType -> OutputType
succ :: OutputType -> OutputType
$csucc :: OutputType -> OutputType
Enum, OutputType
forall a. a -> a -> Bounded a
maxBound :: OutputType
$cmaxBound :: OutputType
minBound :: OutputType
$cminBound :: OutputType
Bounded)

{- | Takes a format string as input and produces a tuple @(args, outputExpr)@.

This function processes character escapes as they would appear in Haskell source code.
It will emit warnings (or throw an error, as appropriate) when given an invalid format
string.

Use if you wish to leverage @th-printf@ in conjunction with, for example, an existing
logging library.
-}
toSplices :: String -> OutputType -> Q ([Pat], Exp)
toSplices :: String -> OutputType -> Q ([Pat], Exp)
toSplices String
s' OutputType
ot = case String -> Either ParseError ([Atom], [[String]])
parseStr String
s' of
  Left ParseError
x -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ParseError
x
  Right ([Atom]
y, [[String]]
warns) -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
False) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
warns)
    ([[Name]]
lhss, [ExpQ]
rhss) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Atom -> Q ([Name], ExpQ)
extractExpr [Atom]
y
    Exp
rhss' <-
      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
        [|finalize|]
        (forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
x ExpQ
y' -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp ExpQ
x [|(<>)|] ExpQ
y') [ExpQ]
rhss) Q Type
otype)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
lhss, Exp
rhss')
 where
  otype :: Q Type
otype = case OutputType
ot of
    OutputType
OutputString -> [t|SizedStr|]
    OutputType
OutputText -> [t|SizedBuilder|]

extractExpr :: Atom -> Q ([Name], ExpQ)
extractExpr :: Atom -> Q ([Name], ExpQ)
extractExpr (Str String
s') = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [|fromString $(stringE s')|])
extractExpr (Arg (FormatArg FlagSet
flags' Maybe MaySpecify
width' Maybe MaySpecify
precision' Char
spec' Maybe LengthSpecifier
lengthSpec')) = do
  (Maybe Name
warg, ExpQ
wexp) <- forall {m :: * -> *} {m :: * -> *}.
(Quote m, Quote m) =>
Maybe MaySpecify -> m (Maybe Name, m Exp)
extractArgs Maybe MaySpecify
width'
  (Maybe Name
parg, ExpQ
pexp) <- forall {m :: * -> *} {m :: * -> *}.
(Quote m, Quote m) =>
Maybe MaySpecify -> m (Maybe Name, m Exp)
extractArgs Maybe MaySpecify
precision'
  Name
varg <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( forall a. [Maybe a] -> [a]
catMaybes [Maybe Name
warg, Maybe Name
parg, forall a. a -> Maybe a
Just Name
varg]
    , forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
        [|formatOne|]
        ( forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
            ExpQ
formatter
            [|
              PrintfArg
                { flagSet = $(lift flags')
                , width = $(wexp)
                , prec = $(pexp)
                , value = $(varE varg)
                , lengthSpec = $(lift lengthSpec')
                , fieldSpec = $(lift spec')
                }
              |]
        )
    )
 where
  extractArgs :: Maybe MaySpecify -> m (Maybe Name, m Exp)
extractArgs Maybe MaySpecify
n = case Maybe MaySpecify
n of
    Just MaySpecify
Need -> do
      Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Name
a, [|Just (fromInteger (fromIntegral $(varE a)))|])
    Just (Given Integer
n') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, [|Just $(litE $ integerL n')|])
    Maybe MaySpecify
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, [|Nothing|])
  formatter :: ExpQ
formatter = case Char
spec' of
    Char
's' -> [|Printers.printfString|]
    Char
'q' -> [|Printers.printfLazyText|]
    Char
'Q' -> [|Printers.printfStrictText|]
    Char
'?' -> [|Printers.printfShow|]
    Char
'd' -> [|Printers.printfDecimal|]
    Char
'i' -> [|Printers.printfDecimal|]
    Char
'p' -> [|Printers.printfPtr|]
    Char
'c' -> [|Printers.printfChar|]
    Char
'u' -> [|Printers.printfUnsigned|]
    Char
'x' -> [|Printers.printfHex False|]
    Char
'X' -> [|Printers.printfHex True|]
    Char
'o' -> [|Printers.printfOctal|]
    Char
'f' -> [|Printers.printfFloating False|]
    Char
'F' -> [|Printers.printfFloating True|]
    Char
'e' -> [|Printers.printfScientific False|]
    Char
'E' -> [|Printers.printfScientific True|]
    Char
'g' -> [|Printers.printfGeneric False|]
    Char
'G' -> [|Printers.printfGeneric True|]
    Char
'a' -> [|Printers.printfFloatHex False|]
    Char
'A' -> [|Printers.printfFloatHex True|]
    Char
_ -> forall a. HasCallStack => a
undefined