#if __GLASGOW_HASKELL__ < 710
# define _OVERLAPPING_
# define _OVERLAPPABLE_
# define _OVERLAPS_
#else
# define _OVERLAPPING_ {-# OVERLAPPING #-}
# define _OVERLAPPABLE_ {-# OVERLAPPABLE #-}
# define _OVERLAPS_ {-# OVERLAPS #-}
#endif
module Fmt.Internal
(
FromBuilder(..),
FormatAsHex(..),
FormatAsBase64(..),
TupleF(..),
GBuildable(..),
GetFields(..),
Buildable'(..),
FormatType(..),
groupInt,
atBase,
showSigned',
intToDigit',
indentF',
fixedF,
ordinalF,
)
where
import Data.Monoid
import Numeric
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Text.Buildable
import qualified Data.Text.Format as TF
import Data.Text.Lazy.Builder hiding (fromString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base16.Lazy as B16L
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.Lazy as B64L
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.ByteString.Base64.URL.Lazy as B64UL
class FromBuilder a where
fromBuilder :: Builder -> a
instance FromBuilder Builder where
fromBuilder = id
instance (a ~ Char) => FromBuilder [a] where
fromBuilder = TL.unpack . toLazyText
instance FromBuilder T.Text where
fromBuilder = TL.toStrict . toLazyText
instance FromBuilder TL.Text where
fromBuilder = toLazyText
instance (a ~ ()) => FromBuilder (IO a) where
fromBuilder = TL.putStr . toLazyText
class FormatAsHex a where
hexF :: a -> Builder
instance FormatAsHex BS.ByteString where
hexF = fromText . T.decodeLatin1 . B16.encode
instance FormatAsHex BSL.ByteString where
hexF = fromLazyText . TL.decodeLatin1 . B16L.encode
instance _OVERLAPPABLE_ Integral a => FormatAsHex a where
hexF = TF.hex
class FormatAsBase64 a where
base64F :: a -> Builder
base64UrlF :: a -> Builder
instance FormatAsBase64 BS.ByteString where
base64F = fromText . T.decodeLatin1 . B64.encode
base64UrlF = fromText . T.decodeLatin1 . B64U.encode
instance FormatAsBase64 BSL.ByteString where
base64F = fromLazyText . TL.decodeLatin1 . B64L.encode
base64UrlF = fromLazyText . TL.decodeLatin1 . B64UL.encode
class TupleF a where
tupleF :: a -> Builder
class GBuildable f where
gbuild :: f a -> Builder
class GetFields f where
getFields :: f a -> [(String, Builder)]
class Buildable' a where
build' :: a -> Builder
class FormatType r where
format' :: TF.Format -> [Builder] -> r
instance (Buildable a, FormatType r) => FormatType (a -> r) where
format' f xs = \x -> format' f (build x : xs)
instance _OVERLAPPABLE_ FromBuilder r => FormatType r where
format' f xs = fromBuilder $ TF.build f (reverse xs)
groupInt :: (Buildable a, Integral a) => Int -> Char -> a -> Builder
groupInt 0 _ n = build n
groupInt i c n =
fromLazyText . TL.reverse .
foldr merge "" .
TL.zip (zeros <> cycle' zeros') .
TL.reverse .
toLazyText . build
$ n
where
zeros = TL.replicate (fromIntegral i) (TL.singleton '0')
zeros' = TL.singleton c <> TL.tail zeros
merge (f, c') rest
| f == c = TL.singleton c <> TL.singleton c' <> rest
| otherwise = TL.singleton c' <> rest
cycle' xs = xs <> cycle' xs
_ = toInteger n
atBase :: Integral a => Int -> a -> String
atBase b _ | b < 2 || b > 36 = error ("baseF: Invalid base " ++ show b)
atBase b n =
showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) ""
showSigned' :: Real a => (a -> ShowS) -> a -> ShowS
showSigned' f n
| n < 0 = showChar '-' . f (negate n)
| otherwise = f n
intToDigit' :: Int -> Char
intToDigit' i
| i >= 0 && i < 10 = chr (ord '0' + i)
| i >= 10 && i < 36 = chr (ord 'a' + i 10)
| otherwise = error ("intToDigit': Invalid int " ++ show i)
indentF' :: Int -> T.Text -> Builder -> Builder
indentF' n pref a = case TL.lines (toLazyText a) of
[] -> fromText pref <> "\n"
(x:xs) -> fromLazyText $
TL.unlines $ (TL.fromStrict pref <> x) : map (spaces <>) xs
where
spaces = TL.replicate (fromIntegral n) (TL.singleton ' ')
fixedF :: Real a => Int -> a -> Builder
fixedF = TF.fixed
ordinalF :: (Buildable a, Integral a) => a -> Builder
ordinalF n
| tens > 3 && tens < 21 = build n <> "th"
| otherwise = build n <> case n `mod` 10 of
1 -> "st"
2 -> "nd"
3 -> "rd"
_ -> "th"
where
tens = n `mod` 100