Format.hs

module Text.Format.Format
  ( FmtItem(..)
  , Format(..)
  , Format1(..)
  ) where


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

import           Text.Format.ArgFmt
import           Text.Format.ArgKey
import           Text.Format.Internal


data FmtItem = Lit String
             | Arg ArgKey ArgFmt
             deriving (Show, Eq)

-- | Format is a list of 'FmtItem'
--
-- A format contains a variet of literal chars and arguments to be replaced,
-- argument sytax is as follows:
--
-- > {[key][:fmt]}
--
-- * __{}__ means it must be wraped in a pair of braces,
-- * __[]__ means an optional field (or field group),
-- * __key__ is argument's key, see 'ArgKey',
-- * __fmt__ (must leading with a colon) is argument's format, see 'ArgFmt'.
--
-- If you need to include a brace character in the literal text,
-- it can be escaped by doubling: {{ and }}.
--
-- if key is ommited, it means an automically positioned argument.
--
-- Examples:
--
-- >>> unFormat "a left brace {{"
-- [Lit "a left brace {"]
--
-- >>> unFormat "hello {}"
-- [Lit "hello ", Arg (Index 0) (ArgFmt ...)]
--
-- >>> unFormat "{} {}"
-- [Arg (Index 0) (ArgFmt ...), Arg (Index 1) (ArgFmt ...)]
--
-- >>> unFormat "{1} {0}"
-- [Arg (Index 1) (ArgFmt ...), Arg (Index 0) (ArgFmt ...)]
--
-- >>> unFormat "{gender} {age}"
-- [Arg (Name "gender") (ArgFmt ...), Arg (Name "age") (ArgFmt ...)]
--
-- >>> unFormat "{0!gender}"
-- [Arg (Nest (Index 0) (Name "gender")) (ArgFmt ..)]
--
-- >>> unFormat "{:<30s}"
-- [Arg (Index 0) (ArgFmt { fmtAlgin = AlignLeft, fmtWidth = Left 30, ...})]
--
-- >>> unFormat "{:<{width}s}"
-- [Arg (Index 0) (ArgFmt {fmtWidth = Right (Name "width"), ...})]
--
newtype Format = Format { unFormat :: [FmtItem] } deriving (Show, Eq)

instance IsString Format where
  fromString = Format . (fixIndex 0) . parse
    where
      parse :: String -> [FmtItem]
      parse "" = []
      parse cs =
        case parseLiteral cs of
          ("", _)   ->
            case parseArg cs of
              (cs1, Just cs2, cs3) ->
                (Arg (read cs1) (read cs2)) : (parse cs3)
              _ -> error "format error"
          (ls, cs1) -> (Lit ls) : (parse cs1)

      parseLiteral :: String -> (String, String)
      parseLiteral ""               = ("", "")
      parseLiteral ('{' : '{' : cs) = first ('{' :) (parseLiteral cs)
      parseLiteral ('}' : '}' : cs) = first ('{' :) (parseLiteral cs)
      parseLiteral ('{' : cs)       = ([], '{' : cs)
      parseLiteral ('}' : cs)       = ([], '}' : cs)
      parseLiteral (c : cs)         = first (c :) (parseLiteral cs)

      parseArg :: String -> (String, Maybe String, String)
      parseArg cs@('{' : '{' : _) = ("", Nothing, cs)
      parseArg ('{' : cs) =
        case parseArgKey cs of
          (cs1, '}' : cs2) -> (cs1, Just "", cs2)
          (cs1, ':' : cs2) ->
            case parseArgFmt 0 cs2 of
              (cs11, '}' : cs12) -> (cs1, Just cs11, cs12)
              _                  -> errorCloseTag
          _ -> errorCloseTag

      parseArgKey :: String -> (String, String)
      parseArgKey ""           = ("", "")
      parseArgKey cs@('}' : _) = ("", cs)
      parseArgKey cs@(':' : _) = ("", cs)
      parseArgKey (c : cs)     = first (c :) (parseArgKey cs)

      parseArgFmt :: Int -> String -> (String, String)
      parseArgFmt _ ""           = ("", "")
      parseArgFmt 0 cs@('}' : _) = ("", cs)
      parseArgFmt n ('{' : cs)   = first ('{' :) (parseArgFmt (n + 1) cs)
      parseArgFmt n ('}' : cs)   = first ('}' :) (parseArgFmt (n - 1) cs)
      parseArgFmt n (c : cs)     = first (c :) (parseArgFmt n cs)

      fixIndex :: Int -> [FmtItem] -> [FmtItem]
      fixIndex _ [] = []
      -- auto-positioned arg
      fixIndex next ((Arg (Index (-1)) fmt) : items) =
        (Arg (Index next) fmt) : fixIndex (next + 1) items
      -- once there is an explict arg key, auto-position args not working
      fixIndex next items@((Arg _ _) : _) = items
      fixIndex next (item : items) = item : fixIndex next items

-- | A variant of 'Format',
-- it transforms all argument's key to __Nest (Index 0) key__
newtype Format1 = Format1 { unFormat1 :: [FmtItem] } deriving (Show, Eq)

instance IsString Format1 where
  fromString = Format1 . map zeroKey . unFormat . fromString
    where
      zeroKey :: FmtItem -> FmtItem
      zeroKey (Arg key fmt) = Arg (Nest (Index 0) key) fmt
      zeroKey item          = item