Sprintf.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use <$>" #-}
module Puppet.Interpreter.Resolve.Sprintf
  ( sprintf,
  )
where

import Data.Attoparsec.Text
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Lazy.Builder.Int as TB
import qualified Data.Text.Lazy.Builder.Scientific as TB
import Puppet.Interpreter.Helpers
import Puppet.Interpreter.PrettyPrinter ()
import Puppet.Interpreter.Types
import XPrelude

data Flag = Minus | Plus | Space | Zero | Hash
  deriving (Show, Eq)

data FLen = Lhh | Lh | Ll | Lll | LL | Lz | Lj | Lt
  deriving (Show, Eq)

data FType = TPct | Td | Tu | Tf | TF | Te | TE | Tg | TG | Tx | TX | To | Ts | Tc | Tp | Ta | TA
  deriving (Show, Eq)

data PrintfFormat = PrintfFormat
  { _pfFlags :: [Flag],
    _pfWidth :: Maybe Int,
    _pfPrec :: Maybe Int,
    _pfLen :: Maybe FLen,
    _pfType :: FType
  }
  deriving (Show, Eq)

data FormatStringPart
  = Raw Text
  | Format PrintfFormat
  deriving (Show, Eq)

parseFormat :: Text -> [FormatStringPart]
parseFormat t
  | Text.null t = []
  | Text.null nxt = [Raw raw]
  | otherwise = Raw raw : rformat
  where
    (raw, nxt) = Text.break (== '%') t
    tryNext = case parseFormat (Text.tail nxt) of
      (Raw nt : nxt') -> Raw (Text.cons '%' nt) : nxt'
      nxt' -> Raw (Text.singleton '%') : nxt'
    rformat = case parse format nxt of
      Fail {} -> tryNext
      Partial _ -> tryNext
      Done remaining f -> Format f : parseFormat remaining

flag :: Parser Flag
flag =
  (Minus <$ char '-')
    <|> (Plus <$ char '+')
    <|> (Space <$ char ' ')
    <|> (Zero <$ char '0')
    <|> (Hash <$ char '#')

lenModifier :: Parser FLen
lenModifier =
  (Lhh <$ string "hh")
    <|> (Lh <$ char 'h')
    <|> (Lll <$ string "ll")
    <|> (Ll <$ char 'l')
    <|> (LL <$ char 'L')
    <|> (Lz <$ char 'z')
    <|> (Lj <$ char 'j')
    <|> (Lt <$ char 't')

ftype :: Parser FType
ftype =
  (TPct <$ char '%')
    <|> (Td <$ char 'd')
    <|> (Td <$ char 'i')
    <|> (Tu <$ char 'u')
    <|> (Tf <$ char 'f')
    <|> (TF <$ char 'F')
    <|> (Te <$ char 'e')
    <|> (TE <$ char 'E')
    <|> (Tg <$ char 'g')
    <|> (TG <$ char 'G')
    <|> (Tx <$ char 'x')
    <|> (TX <$ char 'X')
    <|> (To <$ char 'o')
    <|> (Ts <$ char 's')
    <|> (Tc <$ char 'c')
    <|> (Ta <$ char 'a')
    <|> (Tp <$ char 'p')
    <|> (TA <$ char 'A')

format :: Parser PrintfFormat
format = do
  void $ char '%'
  flags <- many flag
  width <- optional decimal
  prec <- optional $ do
    void $ char '.'
    decimal
  len <- optional lenModifier
  ft <- ftype
  return (PrintfFormat flags width prec len ft)

sprintf :: Text -> [PValue] -> InterpreterMonad PValue
sprintf str oargs = PString . TL.toStrict . TB.toLazyText . mconcat <$> go (parseFormat str) oargs
  where
    go (Raw x : xs) args = (TB.fromText x :) <$> go xs args
    go (Format f : _) _ | Hash `elem` _pfFlags f = throwPosError "sprintf: the # modifier is not supported"
    go (Format f : xs) (arg : args) = do
      let numeric = case arg of
            PNumber n -> pure n
            PString s -> maybe (throwError "sprintf: Don't know how to convert this to a number") return (text2Scientific s)
            _ -> throwError "sprintf: Don't know how to convert this to a number"
          flags = _pfFlags f
          sh mkBuilder n
            | has_ Minus = TL.justifyLeft padlen ' ' (sprefix <> content)
            | has_ Plus && has_ Zero = sprefix <> TL.justifyRight mpadlen '0' content
            | has_ Plus = TL.justifyRight padlen ' ' (sprefix <> content)
            | has_ Zero = TL.justifyRight padlen '0' content
            | otherwise = TL.justifyRight padlen ' ' content
            where
              (mpadlen, sprefix)
                | Plus `elem` flags && n >= 0 = (padlen - 1, "+")
                | Space `elem` flags && n >= 0 = (padlen - 1, " ")
                | otherwise = (padlen, mempty)
              padlen = maybe 0 fromIntegral (_pfWidth f)
              has_ flg = flg `elem` flags
              content = TB.toLazyText (mkBuilder n)
      baseString <- case _pfType f of
        Td -> sh (TB.formatScientificBuilder TB.Fixed (Just 0)) <$> numeric
        Tf -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric
        TF -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric
        Tg -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric
        TG -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric
        Te -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric
        TE -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric
        Tx -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric
        TX -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric
        Ts -> return $ case arg of
          PString s -> TL.fromStrict s
          _ -> TL.pack (show (pretty arg))
        _ -> throwPosError "sprintf: not yet supported"
      (TB.fromLazyText baseString :) <$> go xs args
    go [] [] = return []
    go _ [] = throwPosError "sprintf: not enough arguments"
    go [] _ = [] <$ let msg = "sprintf: too many arguments" in checkStrict msg msg