{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Text.Format.Class
( Formatter
, FormatArg(..)
, FromArgKey(..)
, 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.Map as M hiding (drop, 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 k | k == mempty = const $ throwM ArgKeyError
formatArgList xs k | Just i <- fromArgKey (topKey k) =
case drop (i - 1) xs of (x:_) -> formatArg x (popKey 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 FormatArg a => FormatArg [a] where
{-# SPECIALIZE instance FormatArg [Char] #-}
formatArg = formatArgList
instance (Ord k, FromArgKey k, FormatArg v) => FormatArg (Map k v) where
formatArg _ k | k == mempty = const $ throwM ArgKeyError
formatArg x k | (Just k') <- fromArgKey (topKey k) =
case (M.lookup k' x) of (Just x') -> formatArg x' (popKey k)
formatArg _ _ = const $ throwM ArgKeyError
class FromArgKey a where
fromArgKey :: ArgKey -> Maybe a
instance FromArgKey String where
fromArgKey (Name k) = Just k
fromArgKey _ = Nothing
instance Integral k => FromArgKey k where
fromArgKey (Index i) = Just $ toEnum i
fromArgKey _ = Nothing
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