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.Error
data FmtItem = Lit String
| Arg ArgKey ArgFmt
deriving (Show, Eq)
newtype Format = Format { unFormat :: [FmtItem] } deriving (Show, Eq)
instance IsString Format where
fromString cs = Format $ fixIndex 0 $ parse cs
where
stack :: String -> String
stack = reverse . (`drop` (reverse cs)) . length
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)
_ -> errorNoParse $ stack ""
(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 $ stack cs2
_ -> errorCloseTag $ stack cs
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 _ [] = []
fixIndex next ((Arg key fmt) : items)
| key == mempty = (Arg (Index next) fmt) : fixIndex (next + 1) items
fixIndex next items@((Arg (Index _) _) : _) = items
fixIndex next (item : items) = item : fixIndex next items
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