#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 706
#endif
#if __GLASGOW_HASKELL__ >= 800
#endif
module TextShow.Generic (
genericShowt
, genericShowtl
, genericShowtPrec
, genericShowtlPrec
, genericShowtList
, genericShowtlList
, genericShowb
, genericShowbPrec
, genericShowbList
, genericPrintT
, genericPrintTL
, genericHPrintT
, genericHPrintTL
, genericLiftShowbPrec
, genericShowbPrec1
, GTextShow(..)
, GTextShowCon(..)
, IsNullary(..)
, ConType(..)
, Zero
, One
) where
import Data.Monoid.Compat ((<>))
import Data.Proxy (Proxy(..))
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.Exts (Char(C#), Double(D#), Float(F#), Int(I#), Word(W#))
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.Lift
import Prelude ()
import Prelude.Compat
import System.IO (Handle)
import TextShow.Classes (TextShow(..), TextShow1(..),
showbListWith, showbParen, showbSpace)
import TextShow.Instances ()
import TextShow.Utils (isInfixTypeCon, isTupleString)
#include "inline.h"
genericShowt :: (Generic a, GTextShow Zero (Rep a)) => a -> TS.Text
genericShowt = toStrict . genericShowtl
genericShowtl :: (Generic a, GTextShow Zero (Rep a)) => a -> TL.Text
genericShowtl = toLazyText . genericShowb
genericShowtPrec :: (Generic a, GTextShow Zero (Rep a)) => Int -> a -> TS.Text
genericShowtPrec p = toStrict . genericShowtlPrec p
genericShowtlPrec :: (Generic a, GTextShow Zero (Rep a)) => Int -> a -> TL.Text
genericShowtlPrec p = toLazyText . genericShowbPrec p
genericShowtList :: (Generic a, GTextShow Zero (Rep a)) => [a] -> TS.Text
genericShowtList = toStrict . genericShowtlList
genericShowtlList :: (Generic a, GTextShow Zero (Rep a)) => [a] -> TL.Text
genericShowtlList = toLazyText . genericShowbList
genericShowb :: (Generic a, GTextShow Zero (Rep a)) => a -> Builder
genericShowb = genericShowbPrec 0
genericShowbPrec :: (Generic a, GTextShow Zero (Rep a)) => Int -> a -> Builder
genericShowbPrec p = gShowbPrec (Proxy :: Proxy Zero) undefined undefined p . from
genericShowbList :: (Generic a, GTextShow Zero (Rep a)) => [a] -> Builder
genericShowbList = showbListWith genericShowb
genericPrintT :: (Generic a, GTextShow Zero (Rep a)) => a -> IO ()
genericPrintT = TS.putStrLn . genericShowt
genericPrintTL :: (Generic a, GTextShow Zero (Rep a)) => a -> IO ()
genericPrintTL = TL.putStrLn . genericShowtl
genericHPrintT :: (Generic a, GTextShow Zero (Rep a)) => Handle -> a -> IO ()
genericHPrintT h = TS.hPutStrLn h . genericShowt
genericHPrintTL :: (Generic a, GTextShow Zero (Rep a)) => Handle -> a -> IO ()
genericHPrintTL h = TL.hPutStrLn h . genericShowtl
genericLiftShowbPrec :: (Generic1 f, GTextShow One (Rep1 f))
=> (Int -> a -> Builder) -> ([a] -> Builder)
-> Int -> f a -> Builder
genericLiftShowbPrec sp sl p = gShowbPrec (Proxy :: Proxy One) sp sl p . from1
genericShowbPrec1 :: ( Generic a, Generic1 f
, GTextShow Zero (Rep a)
, GTextShow One (Rep1 f)
)
=> Int -> f a -> Builder
genericShowbPrec1 = genericLiftShowbPrec genericShowbPrec genericShowbList
data ConType = Rec | Tup | Pref | Inf String
deriving ( Eq
, Ord
, Read
, Show
, Typeable
#if __GLASGOW_HASKELL__ >= 702
, Generic
#endif
#if __GLASGOW_HASKELL__ >= 800
, Lift
#endif
)
instance TextShow ConType where
showbPrec = genericShowbPrec
INLINE_INST_FUN(showbPrec)
data Zero
data One
class GTextShow arity f where
gShowbPrec :: Proxy arity
-> (Int -> a -> Builder) -> ([a] -> Builder)
-> Int -> f a -> Builder
#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable GTextShow
#endif
instance GTextShow arity f => GTextShow arity (D1 d f) where
gShowbPrec pa sp sl p (M1 x) = gShowbPrec pa sp sl p x
instance GTextShow Zero V1 where
gShowbPrec _ _ _ _ !_ = error "Void showbPrec"
instance GTextShow One V1 where
gShowbPrec _ _ _ _ !_ = error "Void liftShowbPrec"
instance (GTextShow arity f, GTextShow arity g) => GTextShow arity (f :+: g) where
gShowbPrec pa sp sl p (L1 x) = gShowbPrec pa sp sl p x
gShowbPrec pa sp sl p (R1 x) = gShowbPrec pa sp sl p x
instance (Constructor c, GTextShowCon arity f, IsNullary f)
=> GTextShow arity (C1 c f) where
gShowbPrec pa sp sl p c@(M1 x) = case fixity of
Prefix -> showbParen ( p > appPrec
&& not (isNullary x || conIsTuple c)
) $
(if conIsTuple c
then mempty
else let cn = conName c
in showbParen (isInfixTypeCon cn) $ fromString cn)
<> (if isNullary x || conIsTuple c
then mempty
else singleton ' ')
<> showbBraces t (gShowbPrecCon pa t sp sl appPrec1 x)
Infix _ m -> showbParen (p > m) $ gShowbPrecCon pa t sp sl (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
class GTextShowCon arity f where
gShowbPrecCon :: Proxy arity -> ConType
-> (Int -> a -> Builder) -> ([a] -> Builder)
-> Int -> f a -> Builder
#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable GTextShowCon
#endif
instance GTextShowCon arity U1 where
gShowbPrecCon _ _ _ _ _ U1 = mempty
instance GTextShowCon One Par1 where
gShowbPrecCon _ _ sp _ p (Par1 x) = sp p x
instance TextShow c => GTextShowCon arity (K1 i c) where
gShowbPrecCon _ _ _ _ p (K1 x) = showbPrec p x
instance TextShow1 f => GTextShowCon One (Rec1 f) where
gShowbPrecCon _ _ sp sl p (Rec1 x) = liftShowbPrec sp sl p x
instance (Selector s, GTextShowCon arity f) => GTextShowCon arity (S1 s f) where
gShowbPrecCon pa t sp sl p sel@(M1 x)
| selName sel == "" = gShowbPrecCon pa t sp sl p x
| otherwise = fromString (selName sel)
<> " = "
<> gShowbPrecCon pa t sp sl 0 x
instance (GTextShowCon arity f, GTextShowCon arity g)
=> GTextShowCon arity (f :*: g) where
gShowbPrecCon pa t@Rec sp sl _ (a :*: b) =
gShowbPrecCon pa t sp sl 0 a
<> ", "
<> gShowbPrecCon pa t sp sl 0 b
gShowbPrecCon pa t@(Inf o) sp sl p (a :*: b) =
gShowbPrecCon pa t sp sl p a
<> showbSpace
<> infixOp
<> showbSpace
<> gShowbPrecCon pa t sp sl p b
where
infixOp :: Builder
infixOp = if isInfixTypeCon o
then fromString o
else singleton '`' <> fromString o <> singleton '`'
gShowbPrecCon pa t@Tup sp sl _ (a :*: b) =
gShowbPrecCon pa t sp sl 0 a
<> singleton ','
<> gShowbPrecCon pa t sp sl 0 b
gShowbPrecCon pa t@Pref sp sl p (a :*: b) =
gShowbPrecCon pa t sp sl p a
<> showbSpace
<> gShowbPrecCon pa t sp sl p b
instance (TextShow1 f, GTextShowCon One g) => GTextShowCon One (f :.: g) where
gShowbPrecCon pa t sp sl p (Comp1 x) =
liftShowbPrec (gShowbPrecCon pa t sp sl)
(showbListWith (gShowbPrecCon pa t sp sl 0))
p x
instance GTextShowCon arity UChar where
gShowbPrecCon _ _ _ _ p (UChar c) = showbPrec (hashPrec p) (C# c) <> oneHash
instance GTextShowCon arity UDouble where
gShowbPrecCon _ _ _ _ p (UDouble d) = showbPrec (hashPrec p) (D# d) <> twoHash
instance GTextShowCon arity UFloat where
gShowbPrecCon _ _ _ _ p (UFloat f) = showbPrec (hashPrec p) (F# f) <> oneHash
instance GTextShowCon arity UInt where
gShowbPrecCon _ _ _ _ p (UInt i) = showbPrec (hashPrec p) (I# i) <> oneHash
instance GTextShowCon arity UWord where
gShowbPrecCon _ _ _ _ p (UWord w) = showbPrec (hashPrec p) (W# w) <> twoHash
oneHash, twoHash :: Builder
hashPrec :: Int -> Int
#if __GLASGOW_HASKELL__ >= 711
oneHash = singleton '#'
twoHash = fromString "##"
hashPrec = const 0
#else
oneHash = mempty
twoHash = mempty
hashPrec = id
#endif
class IsNullary f where
isNullary :: f a -> Bool
instance IsNullary U1 where
isNullary _ = True
instance IsNullary Par1 where
isNullary _ = False
instance IsNullary (K1 i c) where
isNullary _ = False
instance IsNullary f => IsNullary (S1 s f) where
isNullary (M1 x) = isNullary x
instance IsNullary (Rec1 f) where
isNullary _ = False
instance IsNullary (f :*: g) where
isNullary _ = False
instance IsNullary (f :.: g) where
isNullary _ = False
instance IsNullary UChar where
isNullary _ = False
instance IsNullary UDouble where
isNullary _ = False
instance IsNullary UFloat where
isNullary _ = False
instance IsNullary UInt where
isNullary _ = False
instance IsNullary UWord where
isNullary _ = False
#if __GLASGOW_HASKELL__ < 702
$(Generics.deriveAll ''ConType)
#endif
#if __GLASGOW_HASKELL__ < 800
$(deriveLift ''ConType)
#endif