{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DeriveGeneric #-}
module Language.Haskell.Printf.Lib
( toSplices
, OutputType (..)
)
where
import Control.Applicative ( (<$>)
, pure
)
import Data.Maybe
import Data.Semigroup ( (<>) )
import Data.String ( fromString )
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 GHC.Generics ( Generic )
import Parser ( parseStr )
import Parser.Types hiding ( lengthSpec
, width
)
import Buildable ( finalize
, SizedStr
, SizedBuilder
)
data OutputType = OutputString | OutputText
deriving (Show, Eq, Ord, Generic, Enum, Bounded)
toSplices :: String -> OutputType -> Q ([Pat], Exp)
toSplices s' ot = case parseStr s' of
Left x -> fail $ show x
Right (y, warns) -> do
mapM_ (qReport False) (concat warns)
(lhss, rhss) <- unzip <$> mapM extractExpr y
rhss' <- appE
[|finalize|]
(sigE (foldr1 (\x y' -> infixApp x [|(<>)|] y') rhss) otype)
return (map VarP $ concat lhss, rhss')
where
otype = case ot of
OutputString -> [t|SizedStr|]
OutputText -> [t|SizedBuilder|]
extractExpr :: Atom -> Q ([Name], ExpQ)
extractExpr (Str s') = return ([], [|fromString $(stringE s')|])
extractExpr (Arg (FormatArg flags' width' precision' spec' lengthSpec')) = do
(warg, wexp) <- extractArgs width'
(parg, pexp) <- extractArgs precision'
varg <- newName "arg"
return
( catMaybes [warg, parg, Just varg]
, appE
[|formatOne|]
(appE
formatter
[|PrintfArg { flagSet = $(lift flags')
, width = $(wexp)
, prec = $(pexp)
, value = $(varE varg)
, lengthSpec = $(lift lengthSpec')
, fieldSpec = $(lift spec') }|]
)
)
where
extractArgs n = case n of
Just Need -> do
a <- newName "arg"
pure (Just a, [|Just (fromInteger (fromIntegral $(varE a)))|])
Just (Given n') -> pure (Nothing, [|Just $(litE $ integerL n')|])
Nothing -> pure (Nothing, [|Nothing|])
formatter = case spec' of
's' -> [|Printers.printfString|]
'q' -> [|Printers.printfLazyText|]
'Q' -> [|Printers.printfStrictText|]
'?' -> [|Printers.printfShow|]
'd' -> [|Printers.printfDecimal|]
'i' -> [|Printers.printfDecimal|]
'p' -> [|Printers.printfPtr|]
'c' -> [|Printers.printfChar|]
'u' -> [|Printers.printfUnsigned|]
'x' -> [|Printers.printfHex False|]
'X' -> [|Printers.printfHex True|]
'o' -> [|Printers.printfOctal|]
'f' -> [|Printers.printfFloating False|]
'F' -> [|Printers.printfFloating True|]
'e' -> [|Printers.printfScientific False|]
'E' -> [|Printers.printfScientific True|]
'g' -> [|Printers.printfGeneric False|]
'G' -> [|Printers.printfGeneric True|]
'a' -> [|Printers.printfFloatHex False|]
'A' -> [|Printers.printfFloatHex True|]
_ -> undefined