#if __GLASGOW_HASKELL__ >= 702
#else
#endif
#if __GLASGOW_HASKELL__ >= 706
#endif
#if __GLASGOW_HASKELL__ >= 708
#endif
module TextShow.Generic (
genericShowt
, genericShowtl
, genericShowtPrec
, genericShowtlPrec
, genericShowtList
, genericShowtlList
, genericShowb
, genericShowbPrec
, genericShowbList
, genericPrintT
, genericPrintTL
, genericHPrintT
, genericHPrintTL
, genericShowbPrecWith
, genericShowbPrec1
, 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"
genericShowt :: (Generic a, GTextShow (Rep a)) => a -> TS.Text
genericShowt = toStrict . genericShowtl
genericShowtl :: (Generic a, GTextShow (Rep a)) => a -> TL.Text
genericShowtl = toLazyText . genericShowb
genericShowtPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> TS.Text
genericShowtPrec p = toStrict . genericShowtlPrec p
genericShowtlPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> TL.Text
genericShowtlPrec p = toLazyText . genericShowbPrec p
genericShowtList :: (Generic a, GTextShow (Rep a)) => [a] -> TS.Text
genericShowtList = toStrict . genericShowtlList
genericShowtlList :: (Generic a, GTextShow (Rep a)) => [a] -> TL.Text
genericShowtlList = toLazyText . genericShowbList
genericShowb :: (Generic a, GTextShow (Rep a)) => a -> Builder
genericShowb = genericShowbPrec 0
genericShowbPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> Builder
genericShowbPrec p = gShowbPrec Pref p . from
genericShowbList :: (Generic a, GTextShow (Rep a)) => [a] -> Builder
genericShowbList = showbListWith genericShowb
genericPrintT :: (Generic a, GTextShow (Rep a)) => a -> IO ()
genericPrintT = TS.putStrLn . genericShowt
genericPrintTL :: (Generic a, GTextShow (Rep a)) => a -> IO ()
genericPrintTL = TL.putStrLn . genericShowtl
genericHPrintT :: (Generic a, GTextShow (Rep a)) => Handle -> a -> IO ()
genericHPrintT h = TS.hPutStrLn h . genericShowt
genericHPrintTL :: (Generic a, GTextShow (Rep a)) => Handle -> a -> IO ()
genericHPrintTL h = TL.hPutStrLn h . genericShowtl
genericShowbPrecWith :: (Generic1 f, GTextShow1 (Rep1 f))
=> (Int -> a -> Builder) -> Int -> f a -> Builder
genericShowbPrecWith sp p = gShowbPrecWith Pref sp p . from1
genericShowbPrec1 :: (Generic a, Generic1 f, GTextShow (Rep a), GTextShow1 (Rep1 f))
=> Int -> f a -> Builder
genericShowbPrec1 = genericShowbPrecWith genericShowbPrec
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 GTextShow f where
gShowbPrec :: ConType -> Int -> f a -> Builder
isNullary :: f a -> Bool
isNullary = error "generic showbPrec (isNullary): unnecessary case"
#if __GLASGOW_HASKELL__ >= 708
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
isNullary _ = False
class GTextShow1 f where
gShowbPrecWith :: ConType -> (Int -> a -> Builder) -> Int -> f a -> Builder
isNullary1 :: f a -> Bool
isNullary1 = error "generic showbPrecWith (isNullary1): unnecessary case"
#if __GLASGOW_HASKELL__ >= 708
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
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
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