Format.hs

{-# LANGUAGE FlexibleInstances, UndecidableInstances, DefaultSignatures #-}

-- | Format string with named args
--
-- >-- Named args
-- >"My name is {name}, I am {age} years old" ~~ ("name" ~% "Joe") ~~ ("age" ~% 24) ≡ "My name is Joe, I am 24 years old"
-- >-- Arg can have default value
-- >"{var:x} = {val:10}" ~~ ("var" ~% y) ≡ "y = 10"
-- >-- Numeric position can be used
-- >"{0} {1} {0}" ~~ "foo" ~~ "bar" ≡ "foo bar foo"
-- >-- Positions can be omitted
-- >"{} {}" ~~ "foo" ~~ 10 ≡ "foo 10"
-- >-- Double braces to escape them
-- >"{} and {{}}" ~~ 10 ≡ "10 and {}"
module Text.Format (
	FormattedPart(..), Formatted(..), withFlags,
	FormatArg(..), Format(..), Formatter(..),
	prebuild, build,
	Formattable(..), Hole(..), fmt, FormatResult(..),
	format, formats, (~~), (~%),

	module Text.Format.Flags
	) where

import Prelude.Unicode

import Control.Applicative
import Data.Char (intToDigit)
import Data.List (find, intercalate, nub)
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Text as T
import Data.Text.Lazy (Text, unpack)
import Data.String
import Numeric
import Text.Read (readMaybe)
import Text.ParserCombinators.ReadP

import Text.Format.Flags

data FormattedPart = FormattedPart {
	formattedFlags ∷ FormatFlags,
	formattedValue ∷ String }
		deriving (Eq, Ord, Show)

instance IsString FormattedPart where
	fromString = FormattedPart [] ∘ fromString

newtype Formatted = Formatted { formattedParts ∷ [FormattedPart] } deriving (Eq, Ord, Show)

instance IsString Formatted where
	fromString = Formatted ∘ return ∘ fromString

instance Monoid Formatted where
	mempty = Formatted []
	Formatted l `mappend` Formatted r = Formatted $ l ++ r

withFlags ∷ String → [String] → Formatted
withFlags v fs = Formatted [FormattedPart fs v]

data FormatArg = FormatNamed String ([String] → Formatted) | FormatPos ([String] → Formatted)

data Format = Format {
	formatString ∷ String,
	formatArgs ∷ [FormatArg] }

instance Show Format where
	show = mconcat ∘ map formattedValue ∘ formattedParts ∘ prebuild

instance IsString Format where
	fromString str = Format str []

data Formatter = Formatter {
	formatter ∷ Either String Int,
	formatterDefault ∷ Maybe String,
	formatterFlags ∷ [String] }

instance Show Formatter where
	show (Formatter f def cfgs) = "{" ++ concat parts ++ "}" where
		parts = [either id show f, fromMaybe "" (fmap ('=':) def), if null cfgs then "" else (':' : intercalate "," cfgs)]

instance Read Formatter where
	readsPrec _ = readP_to_S $ between (char '{') (char '}') $ do
		n ← munch (∉ "=:}")
		v ← option Nothing $ do
			_ ← char '='
			v' ← munch1 (∉ ":}")
			return $ Just v'
		cs ← option [] $ do
			_ ← char ':'
			flip sepBy (char ',') (munch1 (∉ ",}"))
		return $ Formatter (maybe (Left n) Right $ readMaybe n) v cs

prebuild ∷ Format → Formatted
prebuild = buildFormat True

build ∷ Format → Formatted
build = buildFormat False

buildFormat ∷ Bool → Format → Formatted
buildFormat pre fstr = build' 0 fstr where
	build' ∷ Int → Format → Formatted
	build' _ (Format "" _) = mempty
	build' i (Format ('{':'{':fstr') args) = fromString "{" `mappend` build' i (Format fstr' args)
	build' i (Format ('}':'}':fstr') args) = fromString "}" `mappend` build' i (Format fstr' args)
	build' i (Format ('{':'}':fstr') args) = formatArg' (Formatter (Right i) Nothing []) args `mappend` 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 `mappend` build' i (Format fstr'' args)
	build' i (Format fstr' args) = fromString s `mappend` build' i (Format fstr'' args) where
		(s, fstr'') = break (∈ "{}") fstr'
	formatArg' ∷ Formatter → [FormatArg] → Formatted
	formatArg' f@(Formatter (Left name) defVal fmtCfgs) args
		| pre = fromMaybe (formatted f fmtCfgs) lookArg
		| otherwise = fromMaybe (error $ "Argument " ++ name ++ " not set") (lookArg <|> fmap (flip formatted fmtCfgs) defVal)
		where
			lookArg = do
				FormatNamed _ fval ← find byName args
				return $ fval fmtCfgs
			byName (FormatNamed n _) = n ≡ name
			byName _ = False
	formatArg' f@(Formatter (Right i) defVal fmtCfgs) args
		| pre = fromMaybe (formatted f fmtCfgs) lookIdx
		| otherwise = fromMaybe (error $ "Argument at index " ++ show i ++ " not set") (lookIdx <|> fmap (flip formatted fmtCfgs) defVal)
		where
			lookIdx = do
				FormatPos fval ← listToMaybe $ drop i $ filter isPos args
				return $ fval fmtCfgs
			isPos (FormatPos _) = True
			isPos _ = False

-- | Formattable class, by default using @show@
class Formattable a where
	formattable ∷ a → FormatFlags → Formatted
	default formattable ∷ Show a ⇒ a → FormatFlags → Formatted
	formattable x _ = fromString ∘ show $ x

formatted ∷ Formattable a ⇒ a → FormatFlags → Formatted
formatted v fmts = Formatted ∘ map addFmts ∘ formattedParts ∘ formattable v $ fmts where
	addFmts (FormattedPart flags' v') = FormattedPart (nub $ fmts ++ flags') v'

instance Formattable String where
	formattable s _ = fromString s

instance Formattable Char where
	formattable ch _ = fromString [ch]

instance Formattable Int where
	formattable i fmts = fromString ∘ formatInt (baseFlag fmts) $ i
instance Formattable Integer where
	formattable i fmts = fromString ∘ formatInt (baseFlag fmts) $ i
instance Formattable Double where
	formattable d fmts = fromString ∘ formatDouble (preciseFlag fmts) $ d
instance Formattable Float where
	formattable f fmts = fromString ∘ formatDouble (preciseFlag fmts) $ f
instance Formattable Bool

instance Formattable Text where
	formattable s _ = fromString ∘ unpack $ s

instance Formattable T.Text where
	formattable s _ = fromString ∘ T.unpack $ s

instance Formattable Formatter where
	formattable s _ = fromString ∘ show $ s

class Hole a where
	hole ∷ a → [FormatArg]

instance Hole Formatted where
	hole v = [FormatPos $ const v]

instance {-# OVERLAPPING #-} Hole FormatArg where
	hole = return

instance {-# OVERLAPPING #-} Hole [FormatArg] where
	hole = id

instance {-# OVERLAPPING #-} Hole [[FormatArg]] where
	hole = concat

instance {-# OVERLAPPABLE #-} Formattable a ⇒ Hole a where
	hole v = [FormatPos $ formatted v]

fmt ∷ Formattable a ⇒ a → FormatArg
fmt v = FormatPos $ formatted v

class FormatResult r where
	formatResult ∷ Format → r

instance FormatResult Format where
	formatResult = id

instance {-# OVERLAPPING #-} FormatResult String where
	formatResult = mconcat ∘ map formattedValue ∘ formattedParts ∘ build

instance {-# OVERLAPPABLE #-} IsString s ⇒ FormatResult s where
	formatResult = fromString ∘ formatResult

instance {-# OVERLAPPABLE #-} FormatResult Formatted where
	formatResult = build

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 ~%

(~%) ∷ Formattable a ⇒ String → a → FormatArg
name ~% value = FormatNamed name (formatted value)

-- * Util

formatInt ∷ (Show a, Integral a) ⇒ a → a → String
formatInt base v = showIntAtBase base intToDigit v ""

formatDouble ∷ RealFloat a ⇒ Maybe Int → a → String
formatDouble p v = showGFloat p v ""