module Text.Format (
FormatArg(..), Format(..), Formatter(..),
prebuild, build,
FormatBuild(..), Hole(..), fmt, FormatResult(..),
format, formats, (~~), (~%)
) where
import Prelude.Unicode
import Control.Applicative
import Data.List (find)
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Text as T
import Data.Text.Lazy (Text, unpack)
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as B
import Data.String
import Text.Read (readMaybe)
import Text.ParserCombinators.ReadP
data FormatArg = FormatNamed String Builder | FormatPos Builder
data Format = Format {
formatString ∷ String,
formatArgs ∷ [FormatArg] }
instance Show Format where
show = unpack ∘ prebuild
instance IsString Format where
fromString str = Format str []
data Formatter = Formatter {
formatter ∷ Either String Int,
formatterDefault ∷ Maybe String }
instance Show Formatter where
show (Formatter f def) = "{" ++ either id show f ++ maybe "" (':':) def ++ "}"
instance Read Formatter where
readsPrec _ = readP_to_S $ between (char '{') (char '}') $ do
n ← munch1 (∉ ":}")
v ← option Nothing $ do
_ ← char ':'
v' ← munch1 (≢ '}')
return $ Just v'
return $ Formatter (maybe (Left n) Right $ readMaybe n) v
prebuild ∷ Format → Text
prebuild = buildFormat True
build ∷ Format → Text
build = buildFormat False
buildFormat ∷ Bool → Format → Text
buildFormat pre fstr = B.toLazyText $ mconcat $ build' 0 fstr where
build' ∷ Int → Format → [Builder]
build' _ (Format "" _) = []
build' i (Format ('{':'{':fstr') args) = B.singleton '{' : build' i (Format fstr' args)
build' i (Format ('}':'}':fstr') args) = B.singleton '}' : build' i (Format fstr' args)
build' i (Format ('{':'}':fstr') args) = formatArg' (Formatter (Right i) Nothing) args : build' (succ i) (Format fstr' args)
build' i (Format ('{':fstr') args) = case reads ('{':fstr') of
[] → error $ "Can't parse formatter at " ++ fstr'
(f, fstr''):_ → formatArg' f args : build' i (Format fstr'' args)
build' i (Format fstr' args) = fromString s : build' i (Format fstr'' args) where
(s, fstr'') = break (∈ "{}") fstr'
formatArg' ∷ Formatter → [FormatArg] → Builder
formatArg' f@(Formatter (Left name) defVal) args
| pre = fromMaybe (formatBuild f) lookArg
| otherwise = fromMaybe (error $ "Argument " ++ name ++ " not set") (lookArg <|> fmap formatBuild defVal)
where
lookArg = do
FormatNamed _ fval ← find byName args
return fval
byName (FormatNamed n _) = n ≡ name
byName _ = False
formatArg' f@(Formatter (Right i) defVal) args
| pre = fromMaybe (formatBuild f) lookIdx
| otherwise = fromMaybe (error $ "Argument at index " ++ show i ++ " not set") (lookIdx <|> fmap formatBuild defVal)
where
lookIdx = do
FormatPos fval ← listToMaybe $ drop i $ filter isPos args
return fval
isPos (FormatPos _) = True
isPos _ = False
class FormatBuild a where
formatBuild ∷ a → Builder
default formatBuild ∷ Show a ⇒ a → Builder
formatBuild = B.fromString ∘ show
instance FormatBuild String where
formatBuild = B.fromString
instance FormatBuild Char where
formatBuild = B.singleton
instance FormatBuild Int
instance FormatBuild Integer
instance FormatBuild Double
instance FormatBuild Float
instance FormatBuild Bool
instance FormatBuild Text where
formatBuild = B.fromLazyText
instance FormatBuild T.Text where
formatBuild = B.fromText
instance FormatBuild Formatter where
formatBuild = formatBuild ∘ show
class Hole a where
hole ∷ a → [FormatArg]
instance Hole Builder where
hole = return ∘ FormatPos
instance Hole FormatArg where
hole = return
instance Hole [FormatArg] where
hole = id
instance Hole [[FormatArg]] where
hole = concat
instance FormatBuild a ⇒ Hole a where
hole = return ∘ FormatPos ∘ formatBuild
fmt ∷ FormatBuild a ⇒ a → FormatArg
fmt = FormatPos ∘ formatBuild
class FormatResult r where
formatResult ∷ Format → r
instance FormatResult Format where
formatResult = id
instance FormatResult Text where
formatResult = build
instance IsString s ⇒ FormatResult s where
formatResult = fromString ∘ unpack ∘ formatResult
format ∷ FormatResult r ⇒ String → r
format = formatResult ∘ fromString
formats ∷ FormatResult r ⇒ String → [FormatArg] → r
formats f = formatResult ∘ Format f
infixl 7 ~~
(~~) ∷ (Hole a, FormatResult r) ⇒ Format → a → r
fstr ~~ arg = formatResult $ fstr { formatArgs = formatArgs fstr ++ hole arg }
infixr 8 ~%
(~%) ∷ FormatBuild a ⇒ String → a → FormatArg
name ~% value = FormatNamed name (formatBuild value)