Instances.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module contains Formatable and VarContainer instances for most used types.
module Data.Text.Format.Heavy.Instances (
  -- * Utility data types
  Single (..),
  Several (..),
  Shown (..),

  -- * Combinators
  DefaultValue (..),
  ThenCheck (..),
  WithDefault,
  withDefault,
  optional,

  -- * Generic formatters
  genericIntFormat,
  genericFloatFormat,
) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Char
import Data.Default
import Data.Int
import Data.List (union)
import qualified Data.Map as M
import Data.Maybe
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Word

import Data.Text.Format.Heavy.Build
import Data.Text.Format.Heavy.Formats
import Data.Text.Format.Heavy.Parse
import Data.Text.Format.Heavy.Types

instance IsString Format where
  fromString str = parseFormat' (fromString str)

----------------------- IsVarFormat instances --------------------------------------

instance IsVarFormat GenericFormat where
  parseVarFormat text = either (Left . show) Right $ parseGenericFormat text

instance IsVarFormat BoolFormat where
  parseVarFormat text = either (Left . show) Right $ parseBoolFormat text

---------------------- Generic formatters -------------------------------------------

-- | Generic formatter for integer types
genericIntFormat :: (Integral a) => VarFormat -> a -> Either String B.Builder
genericIntFormat Nothing x = Right $ formatInt def x
genericIntFormat (Just fmtStr) x =
  case parseGenericFormat fmtStr of
    Left err -> Left $ show err
    Right fmt -> Right $ formatInt fmt x

-- | Generic formatter for floating-point types
genericFloatFormat :: (RealFloat a) => VarFormat -> a -> Either String B.Builder
genericFloatFormat Nothing x = Right $ formatFloat def x
genericFloatFormat (Just fmtStr) x =
  case parseGenericFormat fmtStr of
    Left err -> Left $ show err
    Right fmt -> Right $ formatFloat fmt x

------------------------ Formatable instances -------------------------------------------

-- | Unit type is formatted as empty string
instance Formatable () where
  formatVar _ _ = Right mempty

instance Formatable Int where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Int8 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Int16 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Int32 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Int64 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Word8 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Word16 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Word32 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Word64 where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Integer where
  formatVar fmt x = genericIntFormat fmt x

instance Formatable Float where
  formatVar fmt x = genericFloatFormat fmt x

instance Formatable Double where
  formatVar fmt x = genericFloatFormat fmt x

instance Formatable String where
  formatVar Nothing text = Right $ formatStr def (fromString text)
  formatVar (Just fmtStr) text =
    case parseGenericFormat fmtStr of
      Left err -> Left $ show err
      Right fmt -> Right $ formatStr fmt (fromString text)

instance Formatable T.Text where
  formatVar Nothing text = Right $ formatStr def $ TL.fromStrict text
  formatVar (Just fmtStr) text =
    case parseGenericFormat fmtStr of
      Left err -> Left $ show err
      Right fmt -> Right $ formatStr fmt $ TL.fromStrict text

instance Formatable TL.Text where
  formatVar Nothing text = Right $ formatStr def text
  formatVar (Just fmtStr) text =
    case parseGenericFormat fmtStr of
      Left err -> Left $ show err
      Right fmt -> Right $ formatStr fmt text

instance Formatable BS.ByteString where
  formatVar Nothing text = Right $ formatStr def $ TL.fromStrict $ TE.decodeUtf8 text
  formatVar (Just fmtStr) text =
    case parseGenericFormat fmtStr of
      Left err -> Left $ show err
      Right fmt -> Right $ formatStr fmt $ TL.fromStrict $ TE.decodeUtf8 text

instance Formatable BSL.ByteString where
  formatVar Nothing text = Right $ formatStr def $ TLE.decodeUtf8 text
  formatVar (Just fmtStr) text =
    case parseGenericFormat fmtStr of
      Left err -> Left $ show err
      Right fmt -> Right $ formatStr fmt $ TLE.decodeUtf8 text

instance Formatable Bool where
  formatVar Nothing x = Right $ formatBool def x
  formatVar (Just fmtStr) x =
    case parseBoolFormat fmtStr of
      Left err -> Left $ show err
      Right fmt -> Right $ formatBool fmt x

-- | Container for single parameter.
-- Example usage:
--
-- @
-- format "Hello, {}!" (Single name)
-- @
data Single a = Single {getSingle :: a}
  deriving (Eq, Show)

instance (Formatable a) => Formatable (Single a) where
  formatVar fmt (Single x) = formatVar fmt x

-- | Container for several parameters of the same type.
-- Example usage:
--
-- @
-- format "{} + {} = {}" $ Several [2, 3, 5]
-- @
data Several a = Several {getSeveral :: [a]}
  deriving (Eq, Show)

-- | Values packed in Shown will be formatted using their Show instance.
--
-- For example,
--
-- @
-- formatText "values: {}." (Shown (True, False)) ==> "values: (True, False)."
-- @
data Shown a = Shown {shown :: a}
  deriving (Eq)

instance (Show a) => Show (Shown a) where
  show (Shown x) = show x

instance (Show a) => Formatable (Shown a) where
  formatVar _ (Shown x) = Right $ B.fromLazyText $ TL.pack $ show x

instance (Formatable a) => Formatable (Maybe a) where
  formatVar Nothing Nothing = Right mempty
  formatVar Nothing (Just x) = formatVar Nothing x
  formatVar (Just fmtStr) m =
    case parseMaybeFormat fmtStr of
      Nothing -> case m of
        Nothing -> Right mempty
        Just x -> formatVar (Just fmtStr) x
      Just (xFmtStr, nothingStr) ->
        case m of
          Nothing -> Right $ B.fromLazyText nothingStr
          Just x -> formatVar (Just xFmtStr) x

instance (Formatable a, Formatable b) => Formatable (Either a b) where
  formatVar fmt (Left x) = formatVar fmt x
  formatVar fmt (Right y) = formatVar fmt y

------------------------------- VarContainer instances -------------------------------------

instance (Formatable a) => VarContainer (Single a) where
  lookupVar "0" (Single x) = Just $ Variable x
  lookupVar _ _ = Nothing

instance (Formatable a) => ClosedVarContainer (Single a) where
  allVarNames _ = ["0"]

instance VarContainer () where
  lookupVar _ _ = Nothing

instance ClosedVarContainer () where
  allVarNames _ = []

-- | Maybe container contains one variable (named 0); Nothing contains an empty string.
instance (Formatable a) => VarContainer (Maybe a) where
  lookupVar "0" (Just x) = Just $ Variable x
  lookupVar "0" Nothing = Just $ Variable ()
  lookupVar _ _ = Nothing

instance (Formatable a) => ClosedVarContainer (Maybe a) where
  allVarNames Nothing = []
  allVarNames (Just _) = ["0"]

instance (Formatable a, Formatable b) => VarContainer (a, b) where
  lookupVar "0" (a, _) = Just $ Variable a
  lookupVar "1" (_, b) = Just $ Variable b
  lookupVar _ _ = Nothing

instance (Formatable a, Formatable b) => ClosedVarContainer (a, b) where
  allVarNames _ = ["0", "1"]

instance (Formatable a, Formatable b, Formatable c) => VarContainer (a, b, c) where
  lookupVar "0" (a, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _) = Just $ Variable b
  lookupVar "2" (_, _, c) = Just $ Variable c
  lookupVar _ _ = Nothing

instance (Formatable a, Formatable b, Formatable c) => ClosedVarContainer (a, b, c) where
  allVarNames _ = ["0", "1", "2"]

instance (Formatable a, Formatable b, Formatable c, Formatable d) => VarContainer (a, b, c, d) where
  lookupVar "0" (a, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d) = Just $ Variable d
  lookupVar _ _ = Nothing

instance (Formatable a, Formatable b, Formatable c, Formatable d) => ClosedVarContainer (a, b, c, d) where
  allVarNames _ = ["0", "1", "2", "3"]

instance
  (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e)
  => VarContainer (a, b, c, d, e)
  where
  lookupVar "0" (a, _, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d, _) = Just $ Variable d
  lookupVar "4" (_, _, _, _, e) = Just $ Variable e
  lookupVar _ _ = Nothing

instance
  (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e)
  => ClosedVarContainer (a, b, c, d, e)
  where
  allVarNames _ = ["0", "1", "2", "3", "4"]

instance
  (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e, Formatable f)
  => VarContainer (a, b, c, d, e, f)
  where
  lookupVar "0" (a, _, _, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _, _, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d, _, _) = Just $ Variable d
  lookupVar "4" (_, _, _, _, e, _) = Just $ Variable e
  lookupVar "5" (_, _, _, _, _, f) = Just $ Variable f
  lookupVar _ _ = Nothing

instance
  (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e, Formatable f)
  => ClosedVarContainer (a, b, c, d, e, f)
  where
  allVarNames _ = ["0", "1", "2", "3", "4", "5"]

instance
  (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e, Formatable f, Formatable g)
  => VarContainer (a, b, c, d, e, f, g)
  where
  lookupVar "0" (a, _, _, _, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _, _, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _, _, _, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d, _, _, _) = Just $ Variable d
  lookupVar "4" (_, _, _, _, e, _, _) = Just $ Variable e
  lookupVar "5" (_, _, _, _, _, f, _) = Just $ Variable f
  lookupVar "6" (_, _, _, _, _, _, g) = Just $ Variable g
  lookupVar _ _ = Nothing

instance
  (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e, Formatable f, Formatable g)
  => ClosedVarContainer (a, b, c, d, e, f, g)
  where
  allVarNames _ = ["0", "1", "2", "3", "4", "5", "6"]

instance
  ( Formatable a
  , Formatable b
  , Formatable c
  , Formatable d
  , Formatable e
  , Formatable f
  , Formatable g
  , Formatable h
  )
  => VarContainer (a, b, c, d, e, f, g, h)
  where
  lookupVar "0" (a, _, _, _, _, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _, _, _, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _, _, _, _, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d, _, _, _, _) = Just $ Variable d
  lookupVar "4" (_, _, _, _, e, _, _, _) = Just $ Variable e
  lookupVar "5" (_, _, _, _, _, f, _, _) = Just $ Variable f
  lookupVar "6" (_, _, _, _, _, _, g, _) = Just $ Variable g
  lookupVar "7" (_, _, _, _, _, _, _, h) = Just $ Variable h
  lookupVar _ _ = Nothing

instance
  ( Formatable a
  , Formatable b
  , Formatable c
  , Formatable d
  , Formatable e
  , Formatable f
  , Formatable g
  , Formatable h
  )
  => ClosedVarContainer (a, b, c, d, e, f, g, h)
  where
  allVarNames _ = ["0", "1", "2", "3", "4", "5", "6", "7"]

instance
  ( Formatable a
  , Formatable b
  , Formatable c
  , Formatable d
  , Formatable e
  , Formatable f
  , Formatable g
  , Formatable h
  , Formatable i
  )
  => VarContainer (a, b, c, d, e, f, g, h, i)
  where
  lookupVar "0" (a, _, _, _, _, _, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _, _, _, _, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _, _, _, _, _, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d, _, _, _, _, _) = Just $ Variable d
  lookupVar "4" (_, _, _, _, e, _, _, _, _) = Just $ Variable e
  lookupVar "5" (_, _, _, _, _, f, _, _, _) = Just $ Variable f
  lookupVar "6" (_, _, _, _, _, _, g, _, _) = Just $ Variable g
  lookupVar "7" (_, _, _, _, _, _, _, h, _) = Just $ Variable h
  lookupVar "8" (_, _, _, _, _, _, _, _, i) = Just $ Variable i
  lookupVar _ _ = Nothing

instance
  ( Formatable a
  , Formatable b
  , Formatable c
  , Formatable d
  , Formatable e
  , Formatable f
  , Formatable g
  , Formatable h
  , Formatable i
  )
  => ClosedVarContainer (a, b, c, d, e, f, g, h, i)
  where
  allVarNames _ = ["0", "1", "2", "3", "4", "5", "6", "7", "8"]

instance
  ( Formatable a
  , Formatable b
  , Formatable c
  , Formatable d
  , Formatable e
  , Formatable f
  , Formatable g
  , Formatable h
  , Formatable i
  , Formatable j
  )
  => VarContainer (a, b, c, d, e, f, g, h, i, j)
  where
  lookupVar "0" (a, _, _, _, _, _, _, _, _, _) = Just $ Variable a
  lookupVar "1" (_, b, _, _, _, _, _, _, _, _) = Just $ Variable b
  lookupVar "2" (_, _, c, _, _, _, _, _, _, _) = Just $ Variable c
  lookupVar "3" (_, _, _, d, _, _, _, _, _, _) = Just $ Variable d
  lookupVar "4" (_, _, _, _, e, _, _, _, _, _) = Just $ Variable e
  lookupVar "5" (_, _, _, _, _, f, _, _, _, _) = Just $ Variable f
  lookupVar "6" (_, _, _, _, _, _, g, _, _, _) = Just $ Variable g
  lookupVar "7" (_, _, _, _, _, _, _, h, _, _) = Just $ Variable h
  lookupVar "8" (_, _, _, _, _, _, _, _, i, _) = Just $ Variable i
  lookupVar "9" (_, _, _, _, _, _, _, _, _, j) = Just $ Variable j
  lookupVar _ _ = Nothing

instance
  ( Formatable a
  , Formatable b
  , Formatable c
  , Formatable d
  , Formatable e
  , Formatable f
  , Formatable g
  , Formatable h
  , Formatable i
  , Formatable j
  )
  => ClosedVarContainer (a, b, c, d, e, f, g, h, i, j)
  where
  allVarNames _ = ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]

instance (Formatable a) => VarContainer (Several a) where
  lookupVar name (Several lst) =
    if not $ TL.all isDigit name
      then Nothing
      else
        let n = read (TL.unpack name)
         in if n >= length lst
              then Nothing
              else Just $ Variable (lst !! n)

instance (Formatable a) => ClosedVarContainer (Several a) where
  allVarNames (Several lst) = map (TL.pack . show) [0 .. length lst - 1]

instance (Formatable x) => VarContainer [(TL.Text, x)] where
  lookupVar name pairs = Variable `fmap` lookup name pairs

instance (Formatable x) => ClosedVarContainer [(TL.Text, x)] where
  allVarNames pairs = map fst pairs

instance (Formatable x) => VarContainer (M.Map TL.Text x) where
  lookupVar name pairs = Variable `fmap` M.lookup name pairs

instance (Formatable x) => ClosedVarContainer (M.Map TL.Text x) where
  allVarNames pairs = M.keys pairs

-- | Variable container which contains fixed value for any variable name.
data DefaultValue = DefaultValue Variable

instance VarContainer DefaultValue where
  lookupVar _ (DefaultValue var) = Just var

-- | Combiled variable container, which uses parameters from @c1@,
-- and if variable is not found there it will check in @c2@.
data ThenCheck c1 c2 = ThenCheck c1 c2

-- | Convenience type synonym.
type WithDefault c = ThenCheck c DefaultValue

instance (VarContainer c1, VarContainer c2) => VarContainer (ThenCheck c1 c2) where
  lookupVar name (ThenCheck c1 c2) =
    case lookupVar name c1 of
      Just result -> Just result
      Nothing -> lookupVar name c2

instance (ClosedVarContainer c1, ClosedVarContainer c2) => ClosedVarContainer (ThenCheck c1 c2) where
  allVarNames (ThenCheck c1 c2) =
    allVarNames c1 `union` allVarNames c2

-- | Use variables from specified container, or use default value if
-- variable is not found in container.
withDefault :: (VarContainer c) => c -> Variable -> WithDefault c
withDefault c value = c `ThenCheck` DefaultValue value

-- | Use variables from specified container, or use empty string
-- variable is not found in container.
optional :: (VarContainer c) => c -> WithDefault c
optional c = c `withDefault` (Variable TL.empty)