module Text.Format.ArgFmt
  ( FmtAlign(..)
  , FmtSign(..)
  , FmtNumSep(..)
  , ArgFmt(..)
  , 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.Internal


-- | How to align argument
--
-- Note: 'AlignNone' is equivalent to 'AlignLeft' unless
-- number's sign aware enabled
--
data FmtAlign = AlignNone     -- ^ alignment is not specified
              | AlignLeft     -- ^ pad chars before argument
              | AlignRight    -- ^ pad chars before argument
              | AlignCenter   -- ^ pad chars before and after argument
              | AlignSign     -- ^ number specified, pad between sign and digits
              deriving (Show, Eq)


-- | How to show number's sign
--
-- Note: 'SignNone' is equivalent to 'SignMinus' for signed numbers
data FmtSign = SignNone      -- ^ sign is not specified
             | SignPlus      -- ^ show \'+\' for positive and \'-\' for negative
             | SignMinus     -- ^ show negative's sign only
             | SignSpace     -- ^ show ' ' for positive and '-' for negative
             deriving (Show, Eq)


-- | Number separator
data FmtNumSep = NumSepNone   -- ^ don't seprate
               | NumSepDash   -- ^ seprate by '_'
               | NumSepComma  -- ^ seprate by ','
               deriving (Show, Eq)


-- | Description of argument format options
--
-- When read from string, the sytax is as follows:
--
-- > [[pad]align][sign][#][0][width][separator][.precision][specs]
--
-- * __[]__ means an optional field (or filed group)
-- * __pad__ means char to be used for padding, it should be a literal 'Char',
--   default is space
-- * __align__ means align option
--
--    @
--      <       AlignLeft
--      >       AlignRight
--      ^       AlignCenter
--      =       AlignSign
--      empty   AlignNone
--    @
--
--  * __sign__ means number sign option
--
--    @
--      +       SignPlus
--      -       SignMinus
--      space   SignSpace
--      empty   SignNone
--    @
--
--  * __#__ means number alternate form option
--
--  * __0__ preceding __width__ option means sign-aware as well as zero-padding
--
--    @
--      number       AlignNone & sign aware = AlignSign & pad '0'
--      other types  means nothing
--    @
--
--  * __width__ means minimum argument width,
--    it may be an 'ArgKey' indicates it's value from another integer argument
--
--    @
--      integer   minimum width
--      empty     no minimum widht constrain
--    @
--
--  * __separator__ number separator option
--
--    @
--      _       NumSepDash
--      ,       NumSepComma
--      empty   NumSepNone
--    @
--
--  * __precision__ (must leading with a dot)
--    number preceding or maximum with option
--    it may be an 'ArgKey' indicates it's value from another integer argument
--
--    @
--      for number (floating point) types   number precision
--      for non-number types                maximum widht
--    @
--
--  * __specs__ type specified options,
--    it determines how data should be presented,
--    see available type presentions below
--
--
--  == String presentions
--  @
--    s               explicitly specified string type
--    empty           implicitly specified string type
--  @
--
--  == Integer presentions
--  @
--    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)
--    empty           same as "d"
--  @
--
--  == Floating point number presentions
--  @
--    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
--    empty           same as "g"
--  @
--
--  == Examples
--  >>> read "*<30s" :: ArgFmt
--  >>> read "<10.20s" :: ArgFmt
--  >>> read "0=10_.20d" :: ArgFmt
--  >>> read "#010_.20b" :: ArgFmt
--
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
                     } deriving (Show, Eq)

instance Read ArgFmt where
  readsPrec _ cs =
      let (align, pad, cs1) = parseAlign cs
          (sign, cs2) = parseSign cs1
          (alternate, cs3) = parseAlternate cs2
          (aware, cs4) = parseSignAware cs3
          (width, cs5) = parseWidth cs4
          (sep, cs6) = parseNumSep cs5
          (precision, specs) = parsePrecision cs6
      in [(ArgFmt align pad sign alternate aware width sep precision specs, "")]
    where
      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
          ("", _)         -> errorCloseTag
          (ks, '}' : cs1) -> (Right (read ks), cs1)
      parseWidth cs         =
        case L.break (not . isDigit) cs of
          ("", cs1) -> (Left (-1), 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
          ("", _)         -> errorCloseTag
          (ks, '}' : cs1) -> (Right (read ks), cs1)
      parsePrecision ('.' : cs)       =
        case L.break (not . isDigit) cs of
          ("", cs1) -> (Left 0, cs)
          (ds, cs1) -> (Left (read ds), cs1)
      parsePrecision cs               = (Left (-1), cs)

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 _ _ = errorArgFmt "this should never happen"

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   True  (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)