{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}


module Fmt.Internal.Generic where


import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Sequence (Seq)
#if MIN_VERSION_base(4,9,0)
import Data.List.NonEmpty (NonEmpty)
#endif

import Data.List as L
import Data.Text.Lazy.Builder hiding (fromString)
import GHC.Generics
import Formatting.Buildable

import Fmt.Internal.Formatters
import Fmt.Internal.Template
import Fmt.Internal.Tuple


-- $setup
-- >>> import Fmt

{- | Format an arbitrary value without requiring a 'Buildable' instance:

>>> data Foo = Foo { x :: Bool, y :: [Int] } deriving Generic

>>> fmt (genericF (Foo True [1,2,3]))
Foo:
  x: True
  y: [1, 2, 3]

It works for non-record constructors too:

>>> data Bar = Bar Bool [Int] deriving Generic

>>> fmtLn (genericF (Bar True [1,2,3]))
<Bar: True, [1, 2, 3]>

Any fields inside the type must either be 'Buildable' or one of the following
types:

* a function
* a tuple (up to 8-tuples)
* list, 'NonEmpty', 'Seq'
* 'Map', 'IntMap', 'Set', 'IntSet'
* 'Maybe', 'Either'

The exact format of 'genericF' might change in future versions, so don't rely
on it. It's merely a convenience function.
-}
genericF :: (Generic a, GBuildable (Rep a)) => a -> Builder
genericF :: a -> Builder
genericF = Rep a Any -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild (Rep a Any -> Builder) -> (a -> Rep a Any) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

{- | A newtype for deriving a generic 'Buildable' instance for any type
using @DerivingVia@.

>>> :set -XDerivingVia
>>> :{
data Bar = Bar { x :: Bool, y :: [Int] }
  deriving stock Generic
  deriving Buildable via GenericBuildable Bar
:}

>>> pretty (Bar True [1,2,3])
Bar:
  x: True
  y: [1, 2, 3]

-}
newtype GenericBuildable a = GenericBuildable a

instance (GBuildable (Rep a), Generic a) => Buildable (GenericBuildable a) where
  build :: GenericBuildable a -> Builder
build (GenericBuildable a
a) = a -> Builder
forall a. (Generic a, GBuildable (Rep a)) => a -> Builder
genericF a
a

----------------------------------------------------------------------------
-- GBuildable
----------------------------------------------------------------------------

class GBuildable f where
  gbuild :: f a -> Builder

instance Buildable' c => GBuildable (K1 i c) where
  gbuild :: K1 i c a -> Builder
gbuild (K1 c
a) = c -> Builder
forall a. Buildable' a => a -> Builder
build' c
a

instance (GBuildable a, GBuildable b) => GBuildable (a :+: b) where
  gbuild :: (:+:) a b a -> Builder
gbuild (L1 a a
x) = a a -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild a a
x
  gbuild (R1 b a
x) = b a -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild b a
x

instance GBuildable a => GBuildable (M1 D d a) where
  gbuild :: M1 D d a a -> Builder
gbuild (M1 a a
x) = a a -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild a a
x

instance (GetFields a, Constructor c) => GBuildable (M1 C c a) where
  -- A note on fixity:
  --   * Ordinarily e.g. "Foo" is prefix and e.g. ":|" is infix
  --   * However, "Foo" can be infix when defined as "a `Foo` b"
  --   * And ":|" can be prefix when defined as "(:|) a b"
  gbuild :: M1 C c a a -> Builder
gbuild c :: M1 C c a a
c@(M1 a a
x) = case M1 C c a a -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c a a
c of
    Infix Associativity
_ Int
_
      | [Builder
a, Builder
b] <- [Builder]
fields -> Format -> Builder -> [Char] -> Builder -> Builder
forall r. (HasCallStack, FormatType r) => Format -> r
format Format
"({} {} {})" Builder
a [Char]
infixName Builder
b
      -- this case should never happen, but still
      | Bool
otherwise        -> Format -> [Char] -> Builder -> Builder
forall r. (HasCallStack, FormatType r) => Format -> r
format Format
"<{}: {}>"
                              [Char]
prefixName
                              ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
fields))
    Fixity
Prefix
      | Bool
isTuple -> [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF [Builder]
fields
      | M1 C c a a -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord M1 C c a a
c -> Builder -> Builder -> Builder
nameF ([Char] -> Builder
forall p. Buildable p => p -> Builder
build [Char]
prefixName) ([([Char], Builder)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF [([Char], Builder)]
fieldsWithNames)
      | [([Char], Builder)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (a a -> [([Char], Builder)]
forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
x) -> [Char] -> Builder
forall p. Buildable p => p -> Builder
build [Char]
prefixName
      -- I believe that there will be only one field in this case
      | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (M1 C c a a -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName M1 C c a a
c) -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
fields)
      | Bool
otherwise -> Format -> [Char] -> Builder -> Builder
forall r. (HasCallStack, FormatType r) => Format -> r
format Format
"<{}: {}>"
                       [Char]
prefixName
                       ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
fields))
    where
      ([Char]
prefixName, [Char]
infixName)
        | [Char]
":" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` M1 C c a a -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName M1 C c a a
c = ([Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ M1 C c a a -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName M1 C c a a
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")", M1 C c a a -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName M1 C c a a
c)
        | Bool
otherwise                  = (M1 C c a a -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName M1 C c a a
c, [Char]
"`" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ M1 C c a a -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName M1 C c a a
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`")
      fields :: [Builder]
fields          = (([Char], Builder) -> Builder) -> [([Char], Builder)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Builder) -> Builder
forall a b. (a, b) -> b
snd (a a -> [([Char], Builder)]
forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
x)
      fieldsWithNames :: [([Char], Builder)]
fieldsWithNames = a a -> [([Char], Builder)]
forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
x
      isTuple :: Bool
isTuple         = [Char]
"(," [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
prefixName

----------------------------------------------------------------------------
-- Buildable'
----------------------------------------------------------------------------

-- | A more powerful 'Buildable' used for 'genericF'. Can build functions,
-- tuples, lists, maps, etc., as well as combinations thereof.
class Buildable' a where
  build' :: a -> Builder

instance Buildable' () where
  build' :: () -> Builder
build' ()
_ = Builder
"()"

instance (Buildable' a1, Buildable' a2)
  => Buildable' (a1, a2) where
  build' :: (a1, a2) -> Builder
build' (a1
a1, a2
a2) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2]

instance (Buildable' a1, Buildable' a2, Buildable' a3)
  => Buildable' (a1, a2, a3) where
  build' :: (a1, a2, a3) -> Builder
build' (a1
a1, a2
a2, a3
a3) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2, a3 -> Builder
forall a. Buildable' a => a -> Builder
build' a3
a3]

instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4)
  => Buildable' (a1, a2, a3, a4) where
  build' :: (a1, a2, a3, a4) -> Builder
build' (a1
a1, a2
a2, a3
a3, a4
a4) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2, a3 -> Builder
forall a. Buildable' a => a -> Builder
build' a3
a3, a4 -> Builder
forall a. Buildable' a => a -> Builder
build' a4
a4]

instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4,
          Buildable' a5)
  => Buildable' (a1, a2, a3, a4, a5) where
  build' :: (a1, a2, a3, a4, a5) -> Builder
build' (a1
a1, a2
a2, a3
a3, a4
a4, a5
a5) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2, a3 -> Builder
forall a. Buildable' a => a -> Builder
build' a3
a3, a4 -> Builder
forall a. Buildable' a => a -> Builder
build' a4
a4,
     a5 -> Builder
forall a. Buildable' a => a -> Builder
build' a5
a5]

instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4,
          Buildable' a5, Buildable' a6)
  => Buildable' (a1, a2, a3, a4, a5, a6) where
  build' :: (a1, a2, a3, a4, a5, a6) -> Builder
build' (a1
a1, a2
a2, a3
a3, a4
a4, a5
a5, a6
a6) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2, a3 -> Builder
forall a. Buildable' a => a -> Builder
build' a3
a3, a4 -> Builder
forall a. Buildable' a => a -> Builder
build' a4
a4,
     a5 -> Builder
forall a. Buildable' a => a -> Builder
build' a5
a5, a6 -> Builder
forall a. Buildable' a => a -> Builder
build' a6
a6]

instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4,
          Buildable' a5, Buildable' a6, Buildable' a7)
  => Buildable' (a1, a2, a3, a4, a5, a6, a7) where
  build' :: (a1, a2, a3, a4, a5, a6, a7) -> Builder
build' (a1
a1, a2
a2, a3
a3, a4
a4, a5
a5, a6
a6, a7
a7) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2, a3 -> Builder
forall a. Buildable' a => a -> Builder
build' a3
a3, a4 -> Builder
forall a. Buildable' a => a -> Builder
build' a4
a4,
     a5 -> Builder
forall a. Buildable' a => a -> Builder
build' a5
a5, a6 -> Builder
forall a. Buildable' a => a -> Builder
build' a6
a6, a7 -> Builder
forall a. Buildable' a => a -> Builder
build' a7
a7]

instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4,
          Buildable' a5, Buildable' a6, Buildable' a7, Buildable' a8)
  => Buildable' (a1, a2, a3, a4, a5, a6, a7, a8) where
  build' :: (a1, a2, a3, a4, a5, a6, a7, a8) -> Builder
build' (a1
a1, a2
a2, a3
a3, a4
a4, a5
a5, a6
a6, a7
a7, a8
a8) = [Builder] -> Builder
forall a. TupleF a => a -> Builder
tupleF
    [a1 -> Builder
forall a. Buildable' a => a -> Builder
build' a1
a1, a2 -> Builder
forall a. Buildable' a => a -> Builder
build' a2
a2, a3 -> Builder
forall a. Buildable' a => a -> Builder
build' a3
a3, a4 -> Builder
forall a. Buildable' a => a -> Builder
build' a4
a4,
     a5 -> Builder
forall a. Buildable' a => a -> Builder
build' a5
a5, a6 -> Builder
forall a. Buildable' a => a -> Builder
build' a6
a6, a7 -> Builder
forall a. Buildable' a => a -> Builder
build' a7
a7, a8 -> Builder
forall a. Buildable' a => a -> Builder
build' a8
a8]

instance {-# OVERLAPPING #-} Buildable' [Char] where
  build' :: [Char] -> Builder
build' = [Char] -> Builder
forall p. Buildable p => p -> Builder
build

instance Buildable' a => Buildable' [a] where
  build' :: [a] -> Builder
build' = (a -> Builder) -> [a] -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' a -> Builder
forall a. Buildable' a => a -> Builder
build'

#if MIN_VERSION_base(4,9,0)
instance Buildable' a => Buildable' (NonEmpty a) where
  build' :: NonEmpty a -> Builder
build' = (a -> Builder) -> NonEmpty a -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' a -> Builder
forall a. Buildable' a => a -> Builder
build'
#endif

instance Buildable' a => Buildable' (Seq a) where
  build' :: Seq a -> Builder
build' = (a -> Builder) -> Seq a -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' a -> Builder
forall a. Buildable' a => a -> Builder
build'

instance (Buildable' k, Buildable' v) => Buildable' (Map k v) where
  build' :: Map k v -> Builder
build' = (k -> Builder) -> (v -> Builder) -> [(k, v)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v)) =>
(k -> Builder) -> (v -> Builder) -> t -> Builder
mapF' k -> Builder
forall a. Buildable' a => a -> Builder
build' v -> Builder
forall a. Buildable' a => a -> Builder
build' ([(k, v)] -> Builder)
-> (Map k v -> [(k, v)]) -> Map k v -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList

instance (Buildable' v) => Buildable' (Set v) where
  build' :: Set v -> Builder
build' = (v -> Builder) -> Set v -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' v -> Builder
forall a. Buildable' a => a -> Builder
build'

instance (Buildable' v) => Buildable' (IntMap v) where
  build' :: IntMap v -> Builder
build' = (Int -> Builder) -> (v -> Builder) -> [(Int, v)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v)) =>
(k -> Builder) -> (v -> Builder) -> t -> Builder
mapF' Int -> Builder
forall a. Buildable' a => a -> Builder
build' v -> Builder
forall a. Buildable' a => a -> Builder
build' ([(Int, v)] -> Builder)
-> (IntMap v -> [(Int, v)]) -> IntMap v -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap v -> [(Int, v)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList

instance Buildable' IntSet where
  build' :: IntSet -> Builder
build' = (Int -> Builder) -> [Int] -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' Int -> Builder
forall a. Buildable' a => a -> Builder
build' ([Int] -> Builder) -> (IntSet -> [Int]) -> IntSet -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IntSet.toList

instance (Buildable' a) => Buildable' (Maybe a) where
  build' :: Maybe a -> Builder
build' Maybe a
Nothing  = Maybe Builder -> Builder
forall a. Buildable a => Maybe a -> Builder
maybeF (Maybe Builder
forall a. Maybe a
Nothing         :: Maybe Builder)
  build' (Just a
a) = Maybe Builder -> Builder
forall a. Buildable a => Maybe a -> Builder
maybeF (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (a -> Builder
forall a. Buildable' a => a -> Builder
build' a
a) :: Maybe Builder)

instance (Buildable' a, Buildable' b) => Buildable' (Either a b) where
  build' :: Either a b -> Builder
build' (Left  a
a) = Either Builder Builder -> Builder
forall a b. (Buildable a, Buildable b) => Either a b -> Builder
eitherF (Builder -> Either Builder Builder
forall a b. a -> Either a b
Left  (a -> Builder
forall a. Buildable' a => a -> Builder
build' a
a) :: Either Builder Builder)
  build' (Right b
a) = Either Builder Builder -> Builder
forall a b. (Buildable a, Buildable b) => Either a b -> Builder
eitherF (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right (b -> Builder
forall a. Buildable' a => a -> Builder
build' b
a) :: Either Builder Builder)

instance Buildable' (a -> b) where
  build' :: (a -> b) -> Builder
build' a -> b
_ = Builder
"<function>"

instance {-# OVERLAPPABLE #-} Buildable a => Buildable' a where
  build' :: a -> Builder
build' = a -> Builder
forall p. Buildable p => p -> Builder
build

----------------------------------------------------------------------------
-- GetFields
----------------------------------------------------------------------------

class GetFields f where
  -- | Get fields, together with their names if available
  getFields :: f a -> [(String, Builder)]

instance (GetFields a, GetFields b) => GetFields (a :*: b) where
  getFields :: (:*:) a b a -> [([Char], Builder)]
getFields (a a
a :*: b a
b) = a a -> [([Char], Builder)]
forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
a [([Char], Builder)] -> [([Char], Builder)] -> [([Char], Builder)]
forall a. [a] -> [a] -> [a]
++ b a -> [([Char], Builder)]
forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields b a
b

instance (GBuildable a, Selector c) => GetFields (M1 S c a) where
  getFields :: M1 S c a a -> [([Char], Builder)]
getFields s :: M1 S c a a
s@(M1 a a
a) = [(M1 S c a a -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName M1 S c a a
s, a a -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild a a
a)]

instance GBuildable a => GetFields (M1 D c a) where
  getFields :: M1 D c a a -> [([Char], Builder)]
getFields (M1 a a
a) = [([Char]
"", a a -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild a a
a)]

instance GBuildable a => GetFields (M1 C c a) where
  getFields :: M1 C c a a -> [([Char], Builder)]
getFields (M1 a a
a) = [([Char]
"", a a -> Builder
forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild a a
a)]

instance GetFields U1 where
  getFields :: U1 a -> [([Char], Builder)]
getFields U1 a
_ = []