VarFormat.hs

{-# LANGUAGE OverloadedStrings #-}

module Data.Text.Format.Heavy.Parse.VarFormat
where

import Control.Applicative ((<|>))
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import Text.Parsec hiding ((<|>))

import Data.Text.Format.Heavy.Formats
import Data.Text.Format.Heavy.Types

-- | Parsec parser for generic (Python-like) variable format.
pGenericFormat :: Parsec TL.Text st GenericFormat
pGenericFormat = do
  mbFillAlign <- optionMaybe (try pFillAlign <?> "fill and align specification")
  let fill = fromMaybe ' ' $ fst `fmap` mbFillAlign
  let align = snd `fmap` mbFillAlign
  mbSign <- optionMaybe (pSign <?> "sign specification")
  let sign = fromMaybe OnlyNegative mbSign
  mbLeading0x <- optionMaybe (pLeading0x <?> "leading 0x specification")
  let leading0x = fromMaybe False mbLeading0x
  mbWidth <- optionMaybe (pWidth <?> "width specification")
  mbPrecision <- optionMaybe (pPrecision <?> "precision specification")
  mbRadixConvert <- optionMaybe (pRadix <?> "radix specification")
  mbConvert <- optionMaybe (pConvert <?> "conversion specification")
  return $
    GenericFormat
      { gfFillChar = fill
      , gfAlign = align
      , gfSign = sign
      , gfLeading0x = leading0x
      , gfWidth = mbWidth
      , gfPrecision = mbPrecision
      , gfRadix = fst <$> mbRadixConvert
      , gfConvert = mbConvert <|> fmap snd mbRadixConvert
      }
 where
  pAlign :: Parsec TL.Text st Align
  pAlign = do
    alignChar <- oneOf "<>^"
    align <- case alignChar of
      '<' -> return AlignLeft
      '>' -> return AlignRight
      '^' -> return AlignCenter
      _ -> fail $ "Unexpected align char: " ++ [alignChar]
    return align

  pAlignWithFill :: Parsec TL.Text st (Char, Align)
  pAlignWithFill = do
    fill <- noneOf "<>=^"
    align <- pAlign
    return (fill, align)

  pAlignWithoutFill :: Parsec TL.Text st (Char, Align)
  pAlignWithoutFill = do
    align <- pAlign
    return (' ', align)

  pFillAlign :: Parsec TL.Text st (Char, Align)
  pFillAlign = do
    try pAlignWithoutFill <|> pAlignWithFill

  pSign :: Parsec TL.Text st Sign
  pSign = do
    signChar <- oneOf "+- "
    sign <- case signChar of
      '+' -> return Always
      '-' -> return OnlyNegative
      ' ' -> return SpaceForPositive
      _ -> fail $ "Unexpected sign char: " ++ [signChar]
    return sign

  pLeading0x :: Parsec TL.Text st Bool
  pLeading0x = do
    mbSharp <- optionMaybe $ char '#'
    case mbSharp of
      Nothing -> return False
      Just _ -> return True

  natural :: Parsec TL.Text st Int
  natural = do
    ws <- many1 $ oneOf "0123456789"
    return $ read ws

  pWidth :: Parsec TL.Text st Int
  pWidth = natural

  pPrecision :: Parsec TL.Text st Int
  pPrecision = do
    char '.'
    natural

  pRadix :: Parsec TL.Text st (Radix, Conversion)
  pRadix = do
    rc <- oneOf "xXhHd"
    case rc of
      'x' -> return (Hexadecimal, LowerCase)
      'X' -> return (Hexadecimal, UpperCase)
      'h' -> return (Hexadecimal, LowerCase)
      'H' -> return (Hexadecimal, UpperCase)
      'd' -> return (Decimal, LowerCase)

  pConvert :: Parsec TL.Text st Conversion
  pConvert = do
    char '~'
    conv <- oneOf "ult"
    case conv of
      'u' -> return UpperCase
      'l' -> return LowerCase
      't' -> return TitleCase

-- | Parse generic variable format.
--
-- Syntax is:
--
-- @
-- [[fill]align][sign][#][width][.precision][radix][~conversion]
-- @
--
-- where:
--
-- * fill - padding character (space by default)
-- * align - alignment indicator (@<@, @>@, or @^@)
-- * sign - when to show number's sign (@+@, @-@, or space)
-- * @#@ - if specified, then for hexadecimal numbers the leading @0x@ will be added
-- * width - minimum length of the field
-- * precision - number of decimal places after point, for floatting-point numbers
-- * radix - @h@ or @x@ for hexadecimal, @d@ for decimal (default).
-- * conversion - text conversion symbol. Supported are: @u@ - convert to upper case,
--   @l@ - convert to lower case, @t@ - convert to title case (capitalize all words).
parseGenericFormat :: TL.Text -> Either ParseError GenericFormat
parseGenericFormat text = runParser pGenericFormat () "<variable format specification>" text

-- | Parsec parser for Bool format
pBoolFormat :: Parsec TL.Text st BoolFormat
pBoolFormat = do
  true <- many $ noneOf ":,;"
  oneOf ":,;"
  false <- many $ anyChar
  return $ BoolFormat (TL.pack true) (TL.pack false)

-- | Parse Bool format.
--
-- Syntax is:
--
-- @
-- TRUE:FALSE
-- @
--
-- Colon can be replaced with comma or semicolon.
--
-- For example, valid format specifications are @true:false@ (the default one),
-- @True:False@, @yes:no@, and so on.
parseBoolFormat :: TL.Text -> Either ParseError BoolFormat
parseBoolFormat text = runParser pBoolFormat () "<boolean format specification>" text

-- | Try to parse format for @Maybe x@ type.
-- The syntax is:
--
-- @
-- someformat|nothing
-- @
--
-- where @someformat@ is format for the @x@ type, and @nothing@ is the string
-- to be substituted for @Nothing@ value.
--
-- Returns Nothing, if format does not contain @|@. Otherwise, returns
-- @Just (someformat, nothing)@.
parseMaybeFormat :: TL.Text -> Maybe (TL.Text, TL.Text)
parseMaybeFormat text =
  let (xFmtStr, nothingStr) = TL.breakOnEnd "|" text
   in if TL.null xFmtStr
        then Nothing
        else Just (TL.init xFmtStr, nothingStr)