{-# 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 :: forall a. (Generic a, GBuildable (Rep a)) => a -> Builder
genericF = forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = 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 :: forall a. K1 i c a -> Builder
gbuild (K1 c
a) = forall a. Buildable' a => a -> Builder
build' c
a

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

instance GBuildable a => GBuildable (M1 D d a) where
  gbuild :: forall a. M1 D d a a -> Builder
gbuild (M1 a a
x) = 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 :: forall a. M1 C c a a -> Builder
gbuild c :: M1 C c a a
c@(M1 a a
x) = case 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 -> forall r. (HasCallStack, FormatType r) => Format -> r
format Format
"({} {} {})" Builder
a [Char]
infixName Builder
b
      -- this case should never happen, but still
      | Bool
otherwise        -> forall r. (HasCallStack, FormatType r) => Format -> r
format Format
"<{}: {}>"
                              [Char]
prefixName
                              (forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
fields))
    Fixity
Prefix
      | Bool
isTuple -> forall a. TupleF a => a -> Builder
tupleF [Builder]
fields
      | 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 (forall p. Buildable p => p -> Builder
build [Char]
prefixName) (forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF [([Char], Builder)]
fieldsWithNames)
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
x) -> forall p. Buildable p => p -> Builder
build [Char]
prefixName
      -- I believe that there will be only one field in this case
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (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) -> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
fields)
      | Bool
otherwise -> forall r. (HasCallStack, FormatType r) => Format -> r
format Format
"<{}: {}>"
                       [Char]
prefixName
                       (forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
fields))
    where
      ([Char]
prefixName, [Char]
infixName)
        | [Char]
":" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` 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]
"(" forall a. [a] -> [a] -> [a]
++ 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 forall a. [a] -> [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                  = (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]
"`" forall a. [a] -> [a] -> [a]
++ 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 forall a. [a] -> [a] -> [a]
++ [Char]
"`")
      fields :: [Builder]
fields          = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
x)
      fieldsWithNames :: [([Char], Builder)]
fieldsWithNames = forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
x
      isTuple :: Bool
isTuple         = [Char]
"(," 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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, 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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, forall a. Buildable' a => a -> Builder
build' a2
a2, 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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, forall a. Buildable' a => a -> Builder
build' a2
a2, forall a. Buildable' a => a -> Builder
build' a3
a3, 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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, forall a. Buildable' a => a -> Builder
build' a2
a2, forall a. Buildable' a => a -> Builder
build' a3
a3, forall a. Buildable' a => a -> Builder
build' a4
a4,
     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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, forall a. Buildable' a => a -> Builder
build' a2
a2, forall a. Buildable' a => a -> Builder
build' a3
a3, forall a. Buildable' a => a -> Builder
build' a4
a4,
     forall a. Buildable' a => a -> Builder
build' a5
a5, 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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, forall a. Buildable' a => a -> Builder
build' a2
a2, forall a. Buildable' a => a -> Builder
build' a3
a3, forall a. Buildable' a => a -> Builder
build' a4
a4,
     forall a. Buildable' a => a -> Builder
build' a5
a5, forall a. Buildable' a => a -> Builder
build' a6
a6, 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) = forall a. TupleF a => a -> Builder
tupleF
    [forall a. Buildable' a => a -> Builder
build' a1
a1, forall a. Buildable' a => a -> Builder
build' a2
a2, forall a. Buildable' a => a -> Builder
build' a3
a3, forall a. Buildable' a => a -> Builder
build' a4
a4,
     forall a. Buildable' a => a -> Builder
build' a5
a5, forall a. Buildable' a => a -> Builder
build' a6
a6, forall a. Buildable' a => a -> Builder
build' a7
a7, forall a. Buildable' a => a -> Builder
build' a8
a8]

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

instance Buildable' a => Buildable' [a] where
  build' :: [a] -> Builder
build' = forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' 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' = forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' forall a. Buildable' a => a -> Builder
build'
#endif

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

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

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

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

instance Buildable' IntSet where
  build' :: IntSet -> Builder
build' = forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' forall a. Buildable' a => a -> Builder
build' 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  = forall a. Buildable a => Maybe a -> Builder
maybeF (forall a. Maybe a
Nothing         :: Maybe Builder)
  build' (Just a
a) = forall a. Buildable a => Maybe a -> Builder
maybeF (forall a. a -> Maybe a
Just (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) = forall a b. (Buildable a, Buildable b) => Either a b -> Builder
eitherF (forall a b. a -> Either a b
Left  (forall a. Buildable' a => a -> Builder
build' a
a) :: Either Builder Builder)
  build' (Right b
a) = forall a b. (Buildable a, Buildable b) => Either a b -> Builder
eitherF (forall a b. b -> Either a b
Right (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' = 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 :: forall a. (:*:) a b a -> [([Char], Builder)]
getFields (a a
a :*: b a
b) = forall (f :: * -> *) a. GetFields f => f a -> [([Char], Builder)]
getFields a a
a forall a. [a] -> [a] -> [a]
++ 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 :: forall a. M1 S c a a -> [([Char], Builder)]
getFields s :: M1 S c a a
s@(M1 a a
a) = [(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, forall (f :: * -> *) a. GBuildable f => f a -> Builder
gbuild a a
a)]

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

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

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