{-# LANGUAGE RecordWildCards #-}

module Text.Format.ArgFmt
  ( FmtAlign(..)
  , FmtSign(..)
  , FmtNumSep(..)
  , ArgFmt(..)
  , prettyArgFmt
  , formatText
  , formatNumber
  ) where

import           Control.Arrow
import           Data.Char          (isDigit)
import qualified Data.List          as L
import           Numeric

import           Text.Format.ArgKey
import           Text.Format.Error


-- | A data type indicates how to align arguments
--
data FmtAlign = AlignNone     -- ^ Not specified, equivalent to 'AlignLeft'
                              -- unless number's sign aware enabled.
              | AlignLeft     -- ^ Forces the argument to be left-aligned
                              -- within the available space.
              | AlignRight    -- ^ Forces the field to be right-aligned within
                              -- the available space.
              | AlignCenter   -- ^ Forces the field to be centered within the
                              -- available space.
              | AlignSign     -- ^ Number specified, forces the padding to be
                              -- placed after the sign (if any) but before
                              -- the digits.
              deriving (Show, Eq)


-- | A data type indicates how to show number's sign
--
data FmtSign = SignNone      -- ^ Not specified, equivalent to 'SignMinus'
                             -- for signed numbers.
             | SignPlus      -- ^ Sign should be used for both positive as well
                             -- as negative numbers.
             | SignMinus     -- ^ Sign should be used only for negative numbers
             | SignSpace     -- ^ A leading space should be used on positive
                             -- numbers, and a minus sign on negative numbers.
             deriving (Show, Eq)


-- | A data type indicates number separator
--
-- e.g. 20,200,101  20_200_202
data FmtNumSep = NumSepNone   -- ^ Don't separate number
               | NumSepDash   -- ^ Use dash as number separator
               | NumSepComma  -- ^ Use comma as number separator
               deriving (Show, Eq)


{-| A data type indicates how to format an argument.

==== The format syntax

  @
  fmt       -> [[pad] align][sign]["#"]["0"][width][sep]["." precision][specs]
  pad       -> char
  align     -> "\<" | "\>" | "^" | "="
  sign      -> "+" | "-" | " "
  width     -> int | ("{" key "}")
  sep       -> "_" | ","
  precision -> int | ("{" key "}")
  specs     -> chars
  key       -> \<see 'ArgKey'\>
  @

  * @#@ will cause the "alternate form" to be used for integers.

      The alternate format is defined differently for different types.

      * add 0b prefix for binary
      * add 0o prefix for octal
      * add 0x prefix for hexadecimal

  * @with@ indicates minimum with of the field

      If omitted, the field width will be determined by the content.

      When align is omitted, preceding width by a zero character enables
      sign-aware zero-padding for numbers.
      This is equivalent to a pad of 0 with an align of =.

  * @precision@ indicates how many digits should be displayed after the decimal
    point for a floating point number, or maximum width for other types.

      When precision is omitted

      * preceding dot is present, indicates precision is 0
      * preceding dot is omitted too, indicates precision not set,
        default value (i.e. 6 for floating point numbers, 0 for others)
        will be used.

  * @specs@ indicates type specified options

      When specs is omitted, the default specs will be used.
      The default specs is defined differently from different types.

  Examples

    >>> read "*<30s" :: ArgFmt
    >>> read "<10.20s" :: ArgFmt
    >>> read "0=10_.20d" :: ArgFmt
    >>> read "#010_.20b" :: ArgFmt

==== String specs

  @
  s
  default         s
  @

==== Integer specs

  @
  b               binary format integer
  c               char point ('Char' will be trasformed by 'Char.ord' first)
  d               decimal format integer
  o               octal format integer
  x               hex format integer (use lower-case letters)
  X               hex format integer (use upper-case letters)
  default         d
  @

==== Floating point number specs

  @
  e               exponent notation, see 'Numeric.showEFloat'
  E               same as "e", but use upper-case 'E' as separator
  f               fixed-point notation see 'Numeric.showFFloat'
  F               same as "f", but converts nan to NAN and inf to INF
  g               general format, see 'Numeric.showGFloat'
  G               same as "g", but use upper-case 'E' as separator and
                  converts nan to NAN and inf to INF
  %               percentage, same as "f" except multiplies 100 first and
                  followed by a percent sign
  default         g
  @

See 'Text.Format.FormatArg' to learn how to define specs for your own types.
-}
data ArgFmt = ArgFmt { fmtAlign     :: FmtAlign
                     , fmtPad       :: Char
                     , fmtSign      :: FmtSign
                     , fmtAlternate :: Bool
                     , fmtSignAware :: Bool
                     , fmtWidth     :: Either Int ArgKey
                     , fmtNumSep    :: FmtNumSep
                     , fmtPrecision :: Either Int ArgKey
                     , fmtSpecs     :: String
                     , fmtRaw       :: String -- ^ When reading from a string,
                                              -- different strings may produce
                                              -- the same 'ArgFmt', this field
                                              -- keeps the original string here
                                              -- in case it is use later.
                     } deriving (Show, Eq)

instance Read ArgFmt where
  readsPrec _ cs =
      let (fmtAlign, fmtPad, cs1) = parseAlign cs
          (fmtSign, cs2) = parseSign cs1
          (fmtAlternate, cs3) = parseAlternate cs2
          (fmtSignAware, cs4) = parseSignAware cs3
          (fmtWidth, cs5) = parseWidth cs4
          (fmtNumSep, cs6) = parseNumSep cs5
          (fmtPrecision, fmtSpecs) = parsePrecision cs6
          fmtRaw = cs
      in [ (ArgFmt{..}, "") ]
    where
      stack :: String -> String
      stack = reverse . (`drop` (reverse cs)) . length

      parseAlign (c : '<' : cs) = (AlignLeft, c, cs)
      parseAlign (c : '>' : cs) = (AlignRight, c, cs)
      parseAlign (c : '^' : cs) = (AlignCenter, c, cs)
      parseAlign (c : '=' : cs) = (AlignSign, c, cs)
      parseAlign ('<' : cs)     = (AlignLeft, ' ', cs)
      parseAlign ('>' : cs)     = (AlignRight,' ', cs)
      parseAlign ('^' : cs)     = (AlignCenter, ' ', cs)
      parseAlign ('=' : cs)     = (AlignSign,' ', cs)
      parseAlign cs             = (AlignNone, ' ', cs)

      parseSign ('+' : cs) = (SignPlus, cs)
      parseSign ('-' : cs) = (SignMinus, cs)
      parseSign (' ' : cs) = (SignSpace, cs)
      parseSign cs         = (SignNone, cs)

      parseAlternate ('#' : cs) = (True, cs)
      parseAlternate cs         = (False, cs)

      parseSignAware ('0' : cs) = (True, cs)
      parseSignAware cs         = (False, cs)

      parseWidth ('{' : cs) =
        case L.break (== '}') cs of
          (ks, '}' : cs1) -> (Right (read ks), cs1)
          _               -> errorCloseTag $ stack cs
      parseWidth cs         =
        case L.break (not . isDigit) cs of
          ("", cs1) -> (Left 0, cs)
          (ds, cs1) -> (Left (read ds), cs1)

      parseNumSep ('_' : cs) = (NumSepDash, cs)
      parseNumSep (',' : cs) = (NumSepComma, cs)
      parseNumSep cs         = (NumSepNone, cs)

      parsePrecision ('.' : '{' : cs) =
        case L.break (== '}') cs of
          (ks, '}' : cs1) -> (Right (read ks), cs1)
          _               -> errorCloseTag $ stack cs
      parsePrecision ('.' : cs)       =
        case L.break (not . isDigit) cs of
          ("", cs1) -> (Left 0, cs)
          (ds, cs1) -> (Left (read ds), cs1)
      parsePrecision cs               = (Left (-1), cs)


prettyFmtAlign :: FmtAlign -> String
prettyFmtAlign AlignNone   = ""
prettyFmtAlign AlignLeft   = "<"
prettyFmtAlign AlignRight  = ">"
prettyFmtAlign AlignCenter = "^"
prettyFmtAlign AlignSign   = "="


prettyFmtSign :: FmtSign -> String
prettyFmtSign SignNone  = ""
prettyFmtSign SignPlus  = "+"
prettyFmtSign SignMinus = "-"
prettyFmtSign SignSpace = " "


prettyFmtNumSep :: FmtNumSep -> String
prettyFmtNumSep NumSepNone  = ""
prettyFmtNumSep NumSepDash  = "_"
prettyFmtNumSep NumSepComma = ","


-- | Pretty showing 'ArgFmt'
--
-- Note: Don't create 'ArgFmt' manually, 'read' from a string, see 'ArgFmt'.
prettyArgFmt :: ArgFmt -> String
prettyArgFmt (ArgFmt{fmtRaw=raw@(_:_)}) = raw
prettyArgFmt (ArgFmt{..}) = concat $
    [pad, align, sign, alternate, aware, width, sep, ".", precision, fmtSpecs]
  where
    showInt i = if i == 0 then "" else show i
    pad = if fmtAlign == AlignNone then "" else [fmtPad]
    align = prettyFmtAlign fmtAlign
    sign = prettyFmtSign fmtSign
    alternate = if fmtAlternate then "#" else ""
    aware = if fmtSignAware then "0" else ""
    width = either showInt (('{' :) . (++ "}") . show) fmtWidth
    sep = prettyFmtNumSep fmtNumSep
    precision = either showInt (('{' :) . (++ "}") . show) fmtPrecision


formatText :: ArgFmt -> ShowS
formatText fmt@ArgFmt{fmtWidth=(Left minw), fmtPrecision=(Left maxw)} cs
    | padw > 0 = pad (fmtAlign fmt) padw (fmtPad fmt)
    | otherwise = cs1
  where
    cs1 = if maxw > 0 && maxw < length cs then take maxw cs else cs
    padw = minw - (length cs1)

    pad :: FmtAlign -> Int -> Char -> String
    pad AlignNone   n c = pad AlignLeft n c
    pad AlignLeft   n c = cs1 ++ replicate n c
    pad AlignRight  n c = replicate n c ++ cs1
    pad AlignCenter n c =
      let ln = div n 2
      in replicate ln c ++ cs1 ++ (replicate (n - ln) c)
formatText fmt _ = errorNoParse $ prettyArgFmt fmt


formatNumber :: ArgFmt -> Bool -> Int -> Maybe Char -> ShowS
formatNumber fmt signed sepWidth flag cs = uncurry (++) $
    pad (fmtAlign fmt) (fmtPad fmt) (fmtSignAware fmt) $
      second (seperate (fmtNumSep fmt) sepWidth) $
        sign (fmtSign fmt) signed $
          alternate (fmtAlternate fmt) flag cs
  where
    pad :: FmtAlign -> Char -> Bool -> (String, String) -> (String, String)
    pad AlignNone   c  False (ps, cs) = (ps, cs)
    pad AlignNone   c  True  (ps, cs) = pad AlignSign '0' False (ps, cs)
    pad AlignLeft   c  _     (ps, cs) = (ps, cs ++ replicate (padw ps cs) c)
    pad AlignRight  c  _     (ps, cs) = (replicate (padw ps cs) c ++ ps, cs)
    pad AlignSign   c  True  (ps, cs) = pad AlignSign c False (ps, cs)
    pad AlignSign  '0' False (ps, cs) =
      let cs1 = fixSep (fmtNumSep fmt) sepWidth (padw ps cs) cs
      in (ps, cs1)
    pad AlignSign   c  False (ps, cs) = (ps, replicate (padw ps cs) c ++ cs)
    pad AlignCenter c  _     (ps, cs) =
      let n = padw ps cs; ln = div n 2
      in (replicate ln c ++ ps, cs ++ (replicate (n - ln) c))

    padw :: String -> String -> Int
    padw ps cs = max 0 $
      case fmtWidth fmt of Left n -> n - (length ps) - (length cs); _ -> 0

    fixSep :: FmtNumSep -> Int -> Int -> String -> String
    fixSep NumSepNone _ n cs = replicate n '0' ++ cs
    fixSep sep        w n cs =
      let sepChar = if sep == NumSepComma then ',' else '_'
          (cs1, cs2) = L.break (== sepChar) cs
          (wc, r) = divMod (n + length cs1) (w + 1)
          n1 = n - wc + if r > 0 then 0 else 1
       in rseperate sepChar w (reverse cs1 ++ replicate n1 '0') ++ cs2

    seperate :: FmtNumSep -> Int -> String -> String
    seperate NumSepNone _ cs = cs
    seperate sep        w cs =
      let sepChar = if sep == NumSepComma then ',' else '_'
          (cs1, cs2) = L.break (== '.') cs
      in rseperate sepChar w $ reverse cs1

    rseperate :: Char -> Int -> String -> String
    rseperate sep w cs =
      case L.splitAt w cs of
        (cs1, "")  -> reverse cs1
        (cs1, cs2) -> rseperate sep w cs2 ++ (sep : reverse cs1)

    sign :: FmtSign -> Bool -> (String, String) -> (String, String)
    sign SignNone  True (ps, cs)       = sign SignMinus True (ps, cs)
    sign SignPlus  True (ps, '-' : cs) = ('-' : ps, cs)
    sign SignPlus  True (ps, '+' : cs) = ('+' : ps, cs)
    sign SignPlus  True (ps, cs)       = ('+' : ps, cs)
    sign SignMinus True (ps, '-': cs)  = ('-' : ps, cs)
    sign SignSpace True (ps, '+' : cs) = (' ' : ps, cs)
    sign SignSpace True (ps, '-' : cs) = ('-' : ps, cs)
    sign SignSpace True (ps, cs)       = (' ' : ps, cs)
    sign _         _    (ps, '+' : cs) = (ps, cs)
    sign _         _    (ps, '-' : cs) = (ps, cs)
    sign _         _    (ps, cs)       = (ps, cs)

    alternate :: Bool -> Maybe Char -> String -> (String, String)
    alternate True (Just c) cs = (['0', c], cs)
    alternate _    _        cs = ("", cs)