{-# 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 Data.Semigroup (Semigroup(..))

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 Semigroup Formatted where

	Formatted l <> Formatted r = Formatted $ l ++ r



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 ""