Generic.hs

{-# 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 = gbuild . 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) = genericF a

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

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

instance Buildable' c => GBuildable (K1 i c) where
  gbuild (K1 a) = build' a

instance (GBuildable a, GBuildable b) => GBuildable (a :+: b) where
  gbuild (L1 x) = gbuild x
  gbuild (R1 x) = gbuild x

instance GBuildable a => GBuildable (M1 D d a) where
  gbuild (M1 x) = gbuild 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 c@(M1 x) = case conFixity c of
    Infix _ _
      | [a, b] <- fields -> format "({} {} {})" a infixName b
      -- this case should never happen, but still
      | otherwise        -> format "<{}: {}>"
                              prefixName
                              (mconcat (intersperse ", " fields))
    Prefix
      | isTuple -> tupleF fields
      | conIsRecord c -> nameF (build prefixName) (blockMapF fieldsWithNames)
      | null (getFields x) -> build prefixName
      -- I believe that there will be only one field in this case
      | null (conName c) -> mconcat (intersperse ", " fields)
      | otherwise -> format "<{}: {}>"
                       prefixName
                       (mconcat (intersperse ", " fields))
    where
      (prefixName, infixName)
        | ":" `isPrefixOf` conName c = ("(" ++ conName c ++ ")", conName c)
        | otherwise                  = (conName c, "`" ++ conName c ++ "`")
      fields          = map snd (getFields x)
      fieldsWithNames = getFields x
      isTuple         = "(," `isPrefixOf` 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' _ = "()"

instance (Buildable' a1, Buildable' a2)
  => Buildable' (a1, a2) where
  build' (a1, a2) = tupleF
    [build' a1, build' a2]

instance (Buildable' a1, Buildable' a2, Buildable' a3)
  => Buildable' (a1, a2, a3) where
  build' (a1, a2, a3) = tupleF
    [build' a1, build' a2, build' a3]

instance (Buildable' a1, Buildable' a2, Buildable' a3, Buildable' a4)
  => Buildable' (a1, a2, a3, a4) where
  build' (a1, a2, a3, a4) = tupleF
    [build' a1, build' a2, build' a3, build' 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) = tupleF
    [build' a1, build' a2, build' a3, build' a4,
     build' 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) = tupleF
    [build' a1, build' a2, build' a3, build' a4,
     build' a5, build' 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) = tupleF
    [build' a1, build' a2, build' a3, build' a4,
     build' a5, build' a6, build' 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) = tupleF
    [build' a1, build' a2, build' a3, build' a4,
     build' a5, build' a6, build' a7, build' a8]

instance {-# OVERLAPPING #-} Buildable' [Char] where
  build' = build

instance Buildable' a => Buildable' [a] where
  build' = listF' build'

#if MIN_VERSION_base(4,9,0)
instance Buildable' a => Buildable' (NonEmpty a) where
  build' = listF' build'
#endif

instance Buildable' a => Buildable' (Seq a) where
  build' = listF' build'

instance (Buildable' k, Buildable' v) => Buildable' (Map k v) where
  build' = mapF' build' build' . Map.toList

instance (Buildable' v) => Buildable' (Set v) where
  build' = listF' build'

instance (Buildable' v) => Buildable' (IntMap v) where
  build' = mapF' build' build' . IntMap.toList

instance Buildable' IntSet where
  build' = listF' build' . IntSet.toList

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

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

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

instance {-# OVERLAPPABLE #-} Buildable a => Buildable' a where
  build' = 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) = getFields a ++ getFields b

instance (GBuildable a, Selector c) => GetFields (M1 S c a) where
  getFields s@(M1 a) = [(selName s, gbuild a)]

instance GBuildable a => GetFields (M1 D c a) where
  getFields (M1 a) = [("", gbuild a)]

instance GBuildable a => GetFields (M1 C c a) where
  getFields (M1 a) = [("", gbuild a)]

instance GetFields U1 where
  getFields _ = []