{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeOperators        #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric        #-}
#else
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeSynonymInstances #-}
#endif

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds            #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE StandaloneDeriving   #-}
#endif
{-|
Module:      TextShow.Generic
Copyright:   (C) 2014-2015 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

Generic versions of 'TextShow' and 'TextShow1' class functions, as an alternative to
"TextShow.TH", which uses Template Haskell. Because there is no 'Generic2'
class, 'TextShow2' cannot be implemented generically.

This implementation is based off of the @Generics.Deriving.Show@ module from the
@generic-deriving@ library.

/Since: 2/
-}
module TextShow.Generic (
      -- * Generic @show@ functions
      -- $generics

      -- ** Understanding a compiler error
      -- $generic_err
      genericShowt
    , genericShowtl
    , genericShowtPrec
    , genericShowtlPrec
    , genericShowtList
    , genericShowtlList
    , genericShowb
    , genericShowbPrec
    , genericShowbList
    , genericPrintT
    , genericPrintTL
    , genericHPrintT
    , genericHPrintTL
    , genericShowbPrecWith
    , genericShowbPrec1
      -- * The 'GTextShow' and 'GTextShow1' classes
    , GTextShow(..)
    , GTextShow1(..)
    , ConType(..)
    ) where

import           Data.Monoid.Compat ((<>))
import qualified Data.Text    as TS (Text)
import qualified Data.Text.IO as TS (putStrLn, hPutStrLn)
import           Data.Text.Lazy (toStrict)
import           Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText)
import qualified Data.Text.Lazy    as TL (Text)
import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn)
import           Data.Typeable (Typeable)

import           Generics.Deriving.Base
#if __GLASGOW_HASKELL__ < 702
import qualified Generics.Deriving.TH as Generics (deriveAll)
#endif
import           GHC.Show (appPrec, appPrec1)

import           Prelude ()
import           Prelude.Compat

import           System.IO (Handle)

import           TextShow.Classes (TextShow(showbPrec), TextShow1(..),
                                   showbListWith, showbParen, showbSpace)
import           TextShow.Instances ()
import           TextShow.Utils (isInfixTypeCon, isTupleString)

#include "inline.h"

{- $generics

'TextShow' instances can be easily defined for data types that are 'Generic' instances.
The easiest way to do this is to use the @DeriveGeneric@ extension.

@
&#123;-&#35; LANGUAGE DeriveGeneric &#35;-&#125;
import GHC.Generics
import TextShow
import TextShow.Generic

data D a = D a
  deriving (Generic, Generic1)

instance TextShow a => TextShow (D a) where
    showbPrec = 'genericShowbPrec'

instance TextShow1 D where
    showbPrecWith = 'genericShowbPrecWith'
@
-}

{- $generic_err

Suppose you intend to use 'genericShowbPrec' to define a 'TextShow' instance.

@
data Oops = Oops
    -- forgot to add \"deriving Generic\" here!

instance TextShow Oops where
    showbPrec = 'genericShowbPrec'
@

If you forget to add a @deriving 'Generic'@ clause to your data type, at
compile-time, you will get an error message that begins roughly as follows:

@
No instance for ('GTextShow' (Rep Oops))
@

This error can be confusing, but don't let it intimidate you. The correct fix is
simply to add the missing \"@deriving 'Generic'@\" clause.

Similarly, if the compiler complains about not having an instance for @('GTextShow1'
(Rep1 Oops1))@, add a \"@deriving 'Generic1'@\" clause.
-}

-- | A 'Generic' implementation of 'showt'.
--
-- /Since: 2/
genericShowt :: (Generic a, GTextShow (Rep a)) => a -> TS.Text
genericShowt = toStrict . genericShowtl

-- | A 'Generic' implementation of 'showtl'.
--
-- /Since: 2/
genericShowtl :: (Generic a, GTextShow (Rep a)) => a -> TL.Text
genericShowtl = toLazyText . genericShowb

-- | A 'Generic' implementation of 'showPrect'.
--
-- /Since: 2/
genericShowtPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> TS.Text
genericShowtPrec p = toStrict . genericShowtlPrec p

-- | A 'Generic' implementation of 'showtlPrec'.
--
-- /Since: 2/
genericShowtlPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> TL.Text
genericShowtlPrec p = toLazyText . genericShowbPrec p

-- | A 'Generic' implementation of 'showtList'.
--
-- /Since: 2/
genericShowtList :: (Generic a, GTextShow (Rep a)) => [a] -> TS.Text
genericShowtList = toStrict . genericShowtlList

-- | A 'Generic' implementation of 'showtlList'.
--
-- /Since: 2/
genericShowtlList :: (Generic a, GTextShow (Rep a)) => [a] -> TL.Text
genericShowtlList = toLazyText . genericShowbList

-- | A 'Generic' implementation of 'showb'.
--
-- /Since: 2/
genericShowb :: (Generic a, GTextShow (Rep a)) => a -> Builder
genericShowb = genericShowbPrec 0

-- | A 'Generic' implementation of 'showbPrec'.
--
-- /Since: 2/
genericShowbPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> Builder
genericShowbPrec p = gShowbPrec Pref p . from

-- | A 'Generic' implementation of 'showbList'.
--
-- /Since: 2/
genericShowbList :: (Generic a, GTextShow (Rep a)) => [a] -> Builder
genericShowbList = showbListWith genericShowb

-- | A 'Generic' implementation of 'printT'.
--
-- /Since: 2/
genericPrintT :: (Generic a, GTextShow (Rep a)) => a -> IO ()
genericPrintT = TS.putStrLn . genericShowt

-- | A 'Generic' implementation of 'printTL'.
--
-- /Since: 2/
genericPrintTL :: (Generic a, GTextShow (Rep a)) => a -> IO ()
genericPrintTL = TL.putStrLn . genericShowtl

-- | A 'Generic' implementation of 'hPrintT'.
--
-- /Since: 2/
genericHPrintT :: (Generic a, GTextShow (Rep a)) => Handle -> a -> IO ()
genericHPrintT h = TS.hPutStrLn h . genericShowt

-- | A 'Generic' implementation of 'hPrintTL'.
--
-- /Since: 2/
genericHPrintTL :: (Generic a, GTextShow (Rep a)) => Handle -> a -> IO ()
genericHPrintTL h = TL.hPutStrLn h . genericShowtl

-- | A 'Generic1' implementation of 'showbPrecWith'.
--
-- /Since: 2/
genericShowbPrecWith :: (Generic1 f, GTextShow1 (Rep1 f))
                     => (Int -> a -> Builder) -> Int -> f a -> Builder
genericShowbPrecWith sp p = gShowbPrecWith Pref sp p . from1

-- | A 'Generic'/'Generic1' implementation of 'showbPrec1'.
--
-- /Since: 2/
genericShowbPrec1 :: (Generic a, Generic1 f, GTextShow (Rep a), GTextShow1 (Rep1 f))
                  => Int -> f a -> Builder
genericShowbPrec1 = genericShowbPrecWith genericShowbPrec

-------------------------------------------------------------------------------

-- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'),
-- or infix ('Inf').
--
-- /Since: 2/
data ConType = Rec | Tup | Pref | Inf String
  deriving ( Eq
           , Ord
           , Read
           , Show
           , Typeable
#if __GLASGOW_HASKELL__ >= 702
           , Generic
#endif
           )

instance TextShow ConType where
    showbPrec = genericShowbPrec
    INLINE_INST_FUN(showbPrec)

-- | Class of generic representation types ('Rep') that can be converted to
-- a 'Builder'.
--
-- /Since: 2/
class GTextShow f where
    -- | This is used as the default generic implementation of 'showbPrec'.
    gShowbPrec :: ConType -> Int -> f a -> Builder
    -- | Whether a representation type has any constructors.
    isNullary :: f a -> Bool
    isNullary = error "generic showbPrec (isNullary): unnecessary case"
#if __GLASGOW_HASKELL__ >= 708
    {-# MINIMAL gShowbPrec #-}

deriving instance Typeable GTextShow
#endif

instance GTextShow U1 where
    gShowbPrec _ _ U1 = mempty
    isNullary _ = True

instance TextShow c => GTextShow (K1 i c) where
    gShowbPrec _ n (K1 a) = showbPrec n a
    isNullary _ = False

instance (Constructor c, GTextShow f) => GTextShow (C1 c f) where
    gShowbPrec = gShowbConstructor gShowbPrec isNullary

instance (Selector s, GTextShow f) => GTextShow (S1 s f) where
    gShowbPrec = gShowbSelector gShowbPrec
    isNullary (M1 x) = isNullary x

instance GTextShow f => GTextShow (D1 d f) where
    gShowbPrec t n (M1 x) = gShowbPrec t n x

instance (GTextShow f, GTextShow g) => GTextShow (f :+: g) where
    gShowbPrec t n (L1 x) = gShowbPrec t n x
    gShowbPrec t n (R1 x) = gShowbPrec t n x

instance (GTextShow f, GTextShow g) => GTextShow (f :*: g) where
    gShowbPrec = gShowbProduct gShowbPrec gShowbPrec
    -- If we have a product then it is not a nullary constructor
    isNullary _ = False

-------------------------------------------------------------------------------

-- | Class of generic representation types ('Rep1') that can be converted to
-- a 'Builder' by lifting through a unary type constructor.
--
-- /Since: 2/
class GTextShow1 f where
    -- | This is used as the default generic implementation of 'showbPrecWith'.
    gShowbPrecWith :: ConType -> (Int -> a -> Builder) -> Int -> f a -> Builder
    -- | Whether a representation type has any constructors.
    isNullary1 :: f a -> Bool
    isNullary1 = error "generic showbPrecWith (isNullary1): unnecessary case"
#if __GLASGOW_HASKELL__ >= 708
    {-# MINIMAL gShowbPrecWith #-}

deriving instance Typeable GTextShow1
#endif

instance GTextShow1 U1 where
    gShowbPrecWith _ _ _ U1 = mempty
    isNullary1 _ = True

instance GTextShow1 Par1 where
    gShowbPrecWith _ sp n (Par1 p) = sp n p
    isNullary1 _ = False

instance TextShow c => GTextShow1 (K1 i c) where
    gShowbPrecWith _ _ n (K1 a) = showbPrec n a
    isNullary1 _ = False

instance TextShow1 f => GTextShow1 (Rec1 f) where
    gShowbPrecWith _ sp n (Rec1 r) = showbPrecWith sp n r
    isNullary1 _ = False

instance (Constructor c, GTextShow1 f) => GTextShow1 (C1 c f) where
    gShowbPrecWith t sp = gShowbConstructor (flip gShowbPrecWith sp) isNullary1 t

instance (Selector s, GTextShow1 f) => GTextShow1 (S1 s f) where
    gShowbPrecWith t sp = gShowbSelector (flip gShowbPrecWith sp) t
    isNullary1 (M1 x) = isNullary1 x

instance GTextShow1 f => GTextShow1 (D1 d f) where
    gShowbPrecWith t sp n (M1 x) = gShowbPrecWith t sp n x

instance (GTextShow1 f, GTextShow1 g) => GTextShow1 (f :+: g) where
    gShowbPrecWith t sp n (L1 x) = gShowbPrecWith t sp n x
    gShowbPrecWith t sp n (R1 x) = gShowbPrecWith t sp n x

instance (GTextShow1 f, GTextShow1 g) => GTextShow1 (f :*: g) where
    gShowbPrecWith t sp = gShowbProduct (flip gShowbPrecWith sp) (flip gShowbPrecWith sp) t
    -- If we have a product then it is not a nullary constructor
    isNullary1 _ = False

instance (TextShow1 f, GTextShow1 g) => GTextShow1 (f :.: g) where
    gShowbPrecWith t sp n (Comp1 c) = showbPrecWith (gShowbPrecWith t sp) n c
    isNullary1 _ = False

-------------------------------------------------------------------------------
-- Shared code between GTextShow and GTextShow1
-------------------------------------------------------------------------------

gShowbConstructor :: forall c f p. Constructor c
                  => (ConType -> Int -> f p -> Builder)
                  -> (f p -> Bool)
                  -> ConType -> Int -> C1 c f p -> Builder
gShowbConstructor gs isNull _ n c@(M1 x) = case fixity of
    Prefix -> showbParen ( n > appPrec
                           && not ( isNull x
                                    || conIsTuple c
#if __GLASGOW_HASKELL__ >= 711
                                    || conIsRecord c
#endif
                                  )
                         ) $
           (if conIsTuple c
               then mempty
               else let cn = conName c
                    in showbParen (isInfixTypeCon cn) $ fromString cn
           )
        <> (if isNull x || conIsTuple c
               then mempty
               else singleton ' '
           )
        <> showbBraces t (gs t appPrec1 x)
    Infix _ m -> showbParen (n > m) . showbBraces t $ gs t (m+1) x
  where
    fixity :: Fixity
    fixity = conFixity c

    t :: ConType
    t = if conIsRecord c
        then Rec
        else case conIsTuple c of
            True  -> Tup
            False -> case fixity of
                Prefix    -> Pref
                Infix _ _ -> Inf $ conName c

    showbBraces :: ConType -> Builder -> Builder
    showbBraces Rec     b = singleton '{' <> b <> singleton '}'
    showbBraces Tup     b = singleton '(' <> b <> singleton ')'
    showbBraces Pref    b = b
    showbBraces (Inf _) b = b

    conIsTuple :: C1 c f p -> Bool
    conIsTuple = isTupleString . conName

gShowbSelector :: Selector s
               => (ConType -> Int -> f p -> Builder)
               -> ConType -> Int -> S1 s f p -> Builder
gShowbSelector gs t n sel@(M1 x)
    | selName sel == "" = gs t n x
    | otherwise         = fromString (selName sel) <> " = " <> gs t 0 x

gShowbProduct :: (ConType -> Int -> f p -> Builder)
              -> (ConType -> Int -> g p -> Builder)
              -> ConType -> Int -> ((f :*: g) p) -> Builder
gShowbProduct gsa gsb t@Rec _ (a :*: b) =
       gsa t 0 a
    <> ", "
    <> gsb t 0 b
gShowbProduct gsa gsb t@(Inf o) n (a :*: b) =
       gsa t n a
    <> showbSpace
    <> infixOp
    <> showbSpace
    <> gsb t n b
  where
    infixOp :: Builder
    infixOp = if isInfixTypeCon o
                 then fromString o
                 else singleton '`' <> fromString o <> singleton '`'
gShowbProduct gsa gsb t@Tup _ (a :*: b) =
       gsa t 0 a
    <> singleton ','
    <> gsb t 0 b
gShowbProduct gsa gsb t@Pref n (a :*: b) =
       gsa t n a
    <> showbSpace
    <> gsb t n b

-------------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ < 702
$(Generics.deriveAll ''ConType)
#endif