{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Text.Format.Class
( Formatter
, FormatArg(..)
, FormatType(..)
, Options(..)
, defaultOptions
, genericFormatArg
, (:=) (..)
, formatString
, formatChar
, formatInt
, formatWord
, formatInteger
, formatRealFloat
, defaultSpecs
) where
import Control.Monad.Catch
import Data.Char
import Data.Either
import Data.Int
import Data.List ((!!))
import Data.Map hiding (map)
import Data.Maybe
import Data.Word
import GHC.Generics
import Numeric
import Numeric.Natural
import Text.Format.ArgFmt
import Text.Format.ArgKey
import Text.Format.Error
import Text.Format.Format
type Formatter = ArgKey -> ArgFmt -> Either SomeException String
class FormatArg a where
formatArg :: a -> Formatter
default formatArg :: (Generic a, GFormatArg (Rep a)) => a -> Formatter
formatArg = genericFormatArg defaultOptions
formatArgList :: [a] -> Formatter
formatArgList xs (Index i) = formatArg (xs !! i) mempty
formatArgList xs (Nest (Index i) k) = formatArg (xs !! i) k
formatArgList _ _ = const $ throwM ArgKeyError
keyOf :: a -> ArgKey
keyOf _ = mempty
instance FormatArg Bool
instance FormatArg Char where
formatArg = formatChar
formatArgList = formatString
instance FormatArg Float where
formatArg = formatRealFloat
instance FormatArg Double where
formatArg = formatRealFloat
instance FormatArg Int where
formatArg = formatInt
instance FormatArg Int8 where
formatArg = formatInt
instance FormatArg Int16 where
formatArg = formatInt
instance FormatArg Int32 where
formatArg = formatInt
instance FormatArg Int64 where
formatArg = formatInt
instance FormatArg Integer where
formatArg = formatInteger
instance FormatArg Natural where
formatArg = formatIntegral False . toInteger
instance FormatArg Word where
formatArg = formatWord
instance FormatArg Word8 where
formatArg = formatWord
instance FormatArg Word16 where
formatArg = formatWord
instance FormatArg Word32 where
formatArg = formatWord
instance FormatArg Word64 where
formatArg = formatWord
instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg [a] where
{-# SPECIALIZE instance FormatArg [Char] #-}
formatArg = formatArgList
instance FormatArg a => FormatArg (Map String a) where
formatArg x (Name n) = formatArg (x ! n) mempty
formatArg x (Nest (Name n) k) = formatArg (x ! n) k
formatArg _ _ = const $ throwM ArgKeyError
instance FormatArg a => FormatArg (Map Int a) where
formatArg x (Index i) = formatArg (x ! i) mempty
formatArg x (Nest (Index i) k) = formatArg (x ! i) k
formatArg _ _ = const $ throwM ArgKeyError
data Options = Options { fieldLabelModifier :: String -> String
}
defaultOptions = Options { fieldLabelModifier = id
}
genericFormatArg :: (Generic a, GFormatArg (Rep a)) => Options -> a -> Formatter
genericFormatArg opts x = gformatArg (from x) opts
class GFormatArg f where
gformatArg :: f p -> Options -> Formatter
instance GFormatArg f => GFormatArg (D1 c f) where
gformatArg (M1 x) = gformatArg x
instance (GFormatArg f, GFormatArg g) => GFormatArg (f :+: g) where
gformatArg (L1 x) = gformatArg x
gformatArg (R1 x) = gformatArg x
instance (Constructor c, GFormatArg f) => GFormatArg (C1 c f) where
gformatArg (M1 x) = gformatArg x
instance {-# OVERLAPPING #-} Constructor c => GFormatArg (C1 c U1) where
gformatArg c _ = formatArg (conName c)
instance (GFormatArg f, GFormatArg g) => GFormatArg (f :*: g) where
gformatArg (x :*: y) opts k fmt =
gformatArg x opts k fmt <|> gformatArg y opts (dec1 k) fmt
where
x <|> y = catchIf isArgKeyError x $ const y
dec1 :: ArgKey -> ArgKey
dec1 (Index i) = Index (i - 1)
dec1 (Nest k1 k2) = mappend (dec1 k1) k2
dec1 k = k
instance (Selector c, GFormatArg f) => GFormatArg (S1 c f) where
gformatArg s@(M1 x) opts (Index 0)
| selName s == "" = gformatArg x opts mempty
gformatArg s@(M1 x) opts (Nest (Index 0) k)
| selName s == "" = gformatArg x opts k
gformatArg s@(M1 x) opts@(Options{..}) (Name record)
| (fieldLabelModifier $ selName s) == record = gformatArg x opts mempty
gformatArg s@(M1 x) opts@(Options{..}) (Nest (Name record) k)
| (fieldLabelModifier $ selName s) == record = gformatArg x opts k
gformatArg _ _ _ = const $ throwM ArgKeyError
instance (FormatArg c) => GFormatArg (K1 i c) where
gformatArg (K1 c) _ = formatArg c
class FormatType t where
sfmt :: Format -> Map ArgKey Formatter -> t
instance (FormatArg a, FormatType r) => FormatType (a -> r) where
sfmt fmt args = \arg -> sfmt fmt $
insert (fixIndex $ keyOf arg) (formatArg arg) args
where
fixIndex k
| k == mempty = Index $ length [n | Index n <- keys args]
| otherwise = k
instance FormatType String where
sfmt fmt args = formats (unFormat fmt)
where
formats :: [FmtItem] -> String
formats = concat . (map formats1)
onError :: (ArgKey, ArgFmt) -> SomeException -> String
onError (key, fmt) = catchArgError (errorArgKey $ show key)
(errorArgFmt $ prettyArgFmt $ fmt)
formats1 :: FmtItem -> String
formats1 (Lit cs) = cs
formats1 (Arg key ifmt) = either (onError (key, ifmt)) id $
(getFormatter key) (popKey key) (fixArgFmt ifmt)
fixArgFmt :: ArgFmt -> ArgFmt
fixArgFmt ifmt@(ArgFmt{fmtWidth=(Right key)}) =
fixArgFmt $ ifmt {fmtWidth = Left $ formatWidth key}
fixArgFmt ifmt@(ArgFmt{fmtPrecision=(Right key)}) =
fixArgFmt $ ifmt {fmtPrecision = Left $ formatPrecision key}
fixArgFmt ifmt = ifmt
formatWidth, formatPrecision :: ArgKey -> Int
formatWidth key =
let fmt = read "0.0d"
in read $ either (onError (key, fmt)) id $ (getFormatter key) key fmt
formatPrecision = formatWidth
getFormatter :: ArgKey -> Formatter
getFormatter = maybe (\_ _ -> throwM ArgKeyError) id . (args !?) . topKey
data (:=) a = String := a
infixr 6 :=
instance FormatArg a => FormatArg ((:=) a) where
formatArg (_ := x) k = formatArg x k
keyOf (ks := _) = Name ks
formatString :: String -> Formatter
formatString _ k _ | k /= mempty = throwM ArgKeyError
formatString x _ fmt@(ArgFmt{fmtSpecs = ""}) = Right $ formatText fmt x
formatString x _ fmt@(ArgFmt{fmtSpecs = "s"}) = Right $ formatText fmt x
formatString _ _ _ = throwM ArgFmtError
formatIntegral :: Bool -> Integer -> Formatter
formatIntegral _ _ k _ | k /= mempty = throwM ArgKeyError
formatIntegral signed x _ fmt@ArgFmt{fmtSpecs=specs} =
formatNumber fmt signed (sepw specs) (flag specs) <$> (showx specs x)
where
sepw :: String -> Int
sepw "b" = 4
sepw "o" = 4
sepw "x" = 4
sepw "X" = 4
sepw _ = 3
flag :: String -> Maybe Char
flag "b" = Just 'b'
flag "o" = Just 'o'
flag "x" = Just 'x'
flag "X" = Just 'X'
flag _ = Nothing
encodeSign :: [Char] -> [Char]
encodeSign "+" = "++"
encodeSign "-" = "--"
encodeSign cs = cs
showx :: String -> Integer -> Either SomeException String
showx specs x
| x < 0 = ('-' :) <$> showx specs (-x)
showx "" x = showx "d" x
showx "b" x = Right $ showIntAtBase 2 intToDigit x ""
showx "c" x = Right $ encodeSign $ [chr $ fromInteger x]
showx "d" x = Right $ show x
showx "o" x = Right $ showIntAtBase 8 intToDigit x ""
showx "x" x = Right $ showIntAtBase 16 intToDigit x ""
showx "X" x = map toUpper <$> showx "x" x
showx _ _ = throwM ArgFmtError
formatChar :: Char -> Formatter
formatChar = formatWord . ord
formatInt :: (Integral a, Bounded a) => a -> Formatter
formatInt = formatIntegral True . toInteger
formatWord :: (Integral a, Bounded a) => a -> Formatter
formatWord = formatIntegral False . toInteger
formatInteger :: Integer -> Formatter
formatInteger = formatIntegral True
formatRealFloat :: RealFloat a => a -> Formatter
formatRealFloat _ k _ | k /= mempty = throwM ArgKeyError
formatRealFloat x _ fmt@ArgFmt{fmtSpecs=specs, fmtPrecision=prec} =
formatNumber fmt True 3 Nothing <$> showx specs prec1 x
where
prec1 = either (\i -> Just $ if i < 0 then 6 else i) (const $ Just 0) prec
showx :: RealFloat a
=> String -> Maybe Int -> a -> Either SomeException String
showx specs p x
| x < 0 = ('-' :) <$> showx specs p (-x)
showx "" p x = showx "g" p x
showx "e" p x = Right $ showEFloat p x ""
showx "E" p x = map toUpper <$> showx "e" p x
showx "f" p x = Right $ showFFloat p x ""
showx "F" p x = map toUpper <$> showx "f" p x
showx "g" p x = Right $ showGFloat p x ""
showx "G" p x = map toUpper <$> showx "g" p x
showx "%" p x = (++ "%") <$> (showx "f" p (x * 100))
showx _ _ _ = throwM ArgFmtError
defaultSpecs :: String -> (a -> Formatter) -> a -> Formatter
defaultSpecs specs f x k fmt
| fmtSpecs fmt == "" = f x k $ fmt {fmtSpecs = specs}
| otherwise = f x k fmt