{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
 
--------------------------------------------------------------------------------
-- |
-- Module      :  Text.XFormat.Show
-- Copyright   :  (c) 2009 Sean Leather
-- License     :  BSD3
--
-- Maintainer  :  leather@cs.uu.nl
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module defines an extensible, type-indexed function for showing
-- well-typed values with a format descriptor. This may be considered a Haskell
-- variant of the C @printf@ function.
--
-- If you are primarily interested in using this library, you will want to see
-- 'showsf' and 'showf', the more user-friendly functions.
--
-- If you are also interested in extending this library with your own format
-- descriptors, you should read about the 'Format' class.
--------------------------------------------------------------------------------
 
module Text.XFormat.Show (
 
  -- * The Classes
 
  Format(..),
  Apply(..),
 
  -- * The Functions
 
  showsf,
  showf,
 
  -- * Format Descriptors
 
  -- | These are used to indicate which values and types to show.
 
  -- ** Basic Format Descriptors
 
  CharF(..),
  IntF(..),
  IntegerF(..),
  FloatF(..),
  DoubleF(..),
  StringF(..),
 
  -- ** Class-based Format Descriptors
 
  ShowF(..),
  NumF(..),
 
  -- ** Recursive Format Descriptors
 
  (:%:)(..),
  (%),
 
  WrapF(..),
  AlignF(..),
  Dir(..),
 
  -- ** Other Format Descriptors
 
  SpacesF(..),
 
  -- * Utilities for Defining Instances
 
  Id(..),
  Arr(..),
  (:.:)(..),
  (<>),
 
) where
 
--------------------------------------------------------------------------------
 
 
-- | This class provides the signature for an extensible, type-indexed function
-- that uses a format descriptor to print a variable number of well-typed
-- arguments to a string. The type variable @d@ is the format descriptor, and
-- the 'Functor' variable @f@ determines the type of the value to be shown.
--
-- An instance of @Format@ adds a (type) case to the function. Before defining
-- an instance, you must first define a format descriptor for your specific type
-- and expected input. The descriptor is often very simple. See the descriptors
-- in this module for examples.
--
-- Here is the instance for types that are instances of 'Prelude.Show'.
--
-- @
--   data 'ShowF' a = 'Show' -- Format descriptor
-- @
--
-- @
--   instance ('Prelude.Show' a) => Format ('ShowF' a) ('Arr' a) where
--     'showsf'' 'Show' = 'Arr' 'shows'
-- @
--
-- The 'Arr' type is one of several 'Functor' wrappers necessary for defining
-- these instances.
 
class (Functor f) => Format d f | d -> f where
 
  -- | Given a format descriptor @d@, return a 'Functor' wrapping a @'String' ->
  -- 'String'@ type. This function may not be very useful outside of defining an
  -- instance for 'Format'. Instead, consider using 'showsf' or 'showf'.
 
  showsf' :: d -> f ShowS
 
--------------------------------------------------------------------------------
 
-- | Given a format descriptor @d@, a variable number of arguments represented
-- by @a@ (and determined by @d@), and a 'String', return a 'String' result.
-- This function removes the 'Functor' wrappers from the output of 'showsf'' to
-- get the variable number of arguments.
 
showsf :: (Format d f, Apply f ShowS a) => d -> a
showsf d = apply (showsf' d)
 
-- | Given a format descriptor @d@ and a variable number of arguments
-- represented by @a@ (and determined by @d@), return a 'String' result. This
-- function is the same as 'showsf' but has already been applied to a 'String'
-- input.
 
showf :: (Format d f, Apply f String a) => d -> a
showf d = apply (fmap (\f -> f "") (showsf' d))
 
--------------------------------------------------------------------------------
 
--
-- Functor wrappers
--
 
-- | Wrapper for a format constant that does not take any arguments. Used in
-- @instance 'Format' 'String' Id@ for example.
 
newtype Id a = Id a
 
instance Functor Id where
  fmap f (Id x) = Id (f x)
 
-- | Wrapper for a format descriptor that takes an argument. Used in @instance
-- ('Prelude.Show' a) => 'Format' ('ShowF' a) (Arr a)@ for example.
 
newtype Arr a b = Arr (a -> b)
 
instance Functor (Arr a) where
  fmap f (Arr g) = Arr (f . g)
 
-- | Wrapper for a format descriptor that composes two descriptors. Used in
-- @instance ('Format' d1 f1, 'Format' d2 f2) => 'Format' (d1 :%: d2) (f1 :.:
-- f2)@ for example.
 
newtype (:.:) f g a = Comp (f (g a))
 
infixr 8 :.:
 
instance (Functor f, Functor g) => Functor (f :.: g) where
  fmap f (Comp fga) = Comp (fmap (fmap f) fga)
 
-- | Helpful function for defining instances of composed format descriptors.
 
(<>) :: (Functor f, Functor g) => f (b -> c) -> g (a -> b) -> (:.:) f g (a -> c)
f <> g = Comp (fmap (\s -> fmap (\t -> s . t) g) f)
infixr 8 <>
 
--------------------------------------------------------------------------------
 
--
-- Functor wrapper removal
--
 
class (Functor f) => Apply f a b | f a -> b where
  apply :: f a -> b
 
instance Apply Id a a where
  apply (Id a) = a
 
instance Apply (Arr a) b (a -> b) where
  apply (Arr f) = f
 
instance (Apply f b c, Apply g a b) => Apply (f :.: g) a c where
  apply (Comp fga) = apply (fmap apply fga)
 
--------------------------------------------------------------------------------
 
--
-- Format constants
--
-- These are not descriptors in the traditional sense. These are constants that
-- are shown directly without taking arguments.
--
 
-- | Print the enclosed 'String'.
 
instance Format String Id where
  showsf' s = Id (showString s)
 
-- | Print the enclosed 'Char'.
 
instance Format Char Id where
  showsf' c = Id (showChar c)
 
--------------------------------------------------------------------------------
 
--
-- Basic format descriptors
--
 
-- | Print a character argument.
 
data CharF = Char
 
instance Format CharF (Arr Char) where
  showsf' Char = Arr showChar
 
-- | Print a string argument.
 
data StringF = String
 
instance Format StringF (Arr String) where
  showsf' String = Arr showString
 
-- | Print an 'Int' argument.
 
data IntF = Int
 
instance Format IntF (Arr Int) where
  showsf' Int = Arr shows
 
-- | Print an 'Integer' argument.
 
data IntegerF = Integer
 
instance Format IntegerF (Arr Integer) where
  showsf' Integer = Arr shows
 
-- | Print a 'Float' argument.
 
data FloatF = Float
 
instance Format FloatF (Arr Float) where
  showsf' Float = Arr shows
 
-- | Print a 'Double' argument.
 
data DoubleF = Double
 
instance Format DoubleF (Arr Double) where
  showsf' Double = Arr shows
 
--------------------------------------------------------------------------------
 
--
-- Class format descriptors
--
 
-- | Print an argument whose type is an instance of the class 'Prelude.Show'.
 
data ShowF a = Show
 
instance (Show a) => Format (ShowF a) (Arr a) where
  showsf' Show = Arr shows
 
-- | Print an argument whose type is an instance of the class 'Prelude.Num'.
 
data NumF a = Num
 
instance (Num a) => Format (NumF a) (Arr a) where
  showsf' Num = Arr shows
 
--------------------------------------------------------------------------------
 
--
-- Other format descriptors
--
 
-- | Print a specified number of spaces.
 
data SpacesF = Spaces Int
 
instance Format SpacesF Id where
  showsf' (Spaces n) = Id (showString (replicate n ' '))
 
--------------------------------------------------------------------------------
 
--
-- Recursive format descriptors
--
 
-- | Right-associative pair. First print a @a@-type format and then a @b@-type
-- format.
 
data a :%: b = a :%: b
  deriving (Eq, Show)
 
infixr 8 :%:
 
-- | Right-associative pair. This is a shorter, functional equivalent to the
-- type @(:%:)@.
 
(%) :: a -> b -> a :%: b
(%) = (:%:)
 
infixr 8 %
 
instance (Format d1 f1, Format d2 f2) => Format (d1 :%: d2) (f1 :.: f2) where
  showsf' (d1 :%: d2) = showsf' d1 <> showsf' d2
 
-- | Print a format of one type wrapped by two other formats of a different
-- type.
 
data WrapF inner outer = Wrap outer inner outer
 
instance (Format din fin, Format dout fout)
  => Format (WrapF din dout) (fout :.: fin :.: fout) where
  showsf' (Wrap doutl din doutr) = showsf' doutl <> showsf' din <> showsf' doutr
 
-- | Print a format aligned left or right within a column of the given width.
 
data AlignF a = Align Dir Int a
 
-- | Direction (left or right) used for 'AlignF'.
 
data Dir = L | R
 
align :: Dir -> Int -> ShowS -> ShowS
align dir wid f =
  case dir of
    L -> f . g
    R -> g . f
  where
    len = length (f "")
    g = if len < wid then showString (replicate (wid - len) ' ') else id
 
instance (Format d f) => Format (AlignF d) f where
  showsf' (Align dir wid d) = fmap (align dir wid) (showsf' d)
 
--------------------------------------------------------------------------------
 
--
-- Tuple format descriptors: These all follow the same pattern.
--
 
instance
  (Format d1 f1, Format d2 f2)
  => Format
  (d1, d2)
  (f1 :.: f2)
  where
  showsf' (d1, d2) =
    showsf' d1 <> showsf' d2
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3)
  => Format
  (d1, d2, d3)
  (f1 :.: f2 :.: f3)
  where
  showsf' (d1, d2, d3) =
    showsf' d1 <> showsf' d2 <> showsf' d3
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4)
  => Format
  (d1, d2, d3, d4)
  (f1 :.: f2 :.: f3 :.: f4)
  where
  showsf' (d1, d2, d3, d4) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5)
  => Format
  (d1, d2, d3, d4, d5)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5)
  where
  showsf' (d1, d2, d3, d4, d5) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6)
  => Format
  (d1, d2, d3, d4, d5, d6)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6)
  where
  showsf' (d1, d2, d3, d4, d5, d6) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7)
  => Format
  (d1, d2, d3, d4, d5, d6, d7)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10,
   Format d11 f11)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.: f11)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <>
    showsf' d11
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10,
   Format d11 f11, Format d12 f12)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.:
   f11 :.: f12)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <>
    showsf' d11 <> showsf' d12
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10,
   Format d11 f11, Format d12 f12, Format d13 f13)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.:
   f11 :.: f12 :.: f13)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <>
    showsf' d11 <> showsf' d12 <> showsf' d13
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10,
   Format d11 f11, Format d12 f12, Format d13 f13, Format d14 f14)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.:
   f11 :.: f12 :.: f13 :.: f14)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <>
    showsf' d11 <> showsf' d12 <> showsf' d13 <> showsf' d14
 
instance
  (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5,
   Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10,
   Format d11 f11, Format d12 f12, Format d13 f13, Format d14 f14,
   Format d15 f15)
  => Format
  (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15)
  (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.:
   f11 :.: f12 :.: f13 :.: f14 :.: f15)
  where
  showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15) =
    showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <>
    showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <>
    showsf' d11 <> showsf' d12 <> showsf' d13 <> showsf' d14 <> showsf' d15