#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(..)
, ShowFuns(..)
, Zero
, One
) where
import Data.Functor.Contravariant (Contravariant(..))
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.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 NoShowFuns 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 (Show1Funs 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 ShowFuns arity a where
NoShowFuns :: ShowFuns Zero a
Show1Funs :: (Int -> a -> Builder) -> ([a] -> Builder) -> ShowFuns One a
deriving Typeable
instance Contravariant (ShowFuns arity) where
contramap _ NoShowFuns = NoShowFuns
contramap f (Show1Funs sp sl) = Show1Funs (\p -> sp p . f) (sl . map f)
data Zero
data One
class GTextShow arity f where
gShowbPrec :: ShowFuns arity a -> Int -> f a -> Builder
#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable GTextShow
#endif
instance GTextShow arity f => GTextShow arity (D1 d f) where
gShowbPrec sfs p (M1 x) = gShowbPrec sfs 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 sfs p (L1 x) = gShowbPrec sfs p x
gShowbPrec sfs p (R1 x) = gShowbPrec sfs p x
instance (Constructor c, GTextShowCon arity f, IsNullary f)
=> GTextShow arity (C1 c f) where
gShowbPrec sfs 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 t sfs appPrec1 x)
Infix _ m -> showbParen (p > m) $ gShowbPrecCon t sfs (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 :: ConType -> ShowFuns arity a -> 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 _ (Show1Funs 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 _ (Show1Funs sp sl) p (Rec1 x) = liftShowbPrec sp sl p x
instance (Selector s, GTextShowCon arity f) => GTextShowCon arity (S1 s f) where
gShowbPrecCon t sfs p sel@(M1 x)
| selName sel == "" = gShowbPrecCon t sfs p x
| otherwise = fromString (selName sel)
<> " = "
<> gShowbPrecCon t sfs 0 x
instance (GTextShowCon arity f, GTextShowCon arity g)
=> GTextShowCon arity (f :*: g) where
gShowbPrecCon t@Rec sfs _ (a :*: b) =
gShowbPrecCon t sfs 0 a
<> ", "
<> gShowbPrecCon t sfs 0 b
gShowbPrecCon t@(Inf o) sfs p (a :*: b) =
gShowbPrecCon t sfs p a
<> showbSpace
<> infixOp
<> showbSpace
<> gShowbPrecCon t sfs p b
where
infixOp :: Builder
infixOp = if isInfixTypeCon o
then fromString o
else singleton '`' <> fromString o <> singleton '`'
gShowbPrecCon t@Tup sfs _ (a :*: b) =
gShowbPrecCon t sfs 0 a
<> singleton ','
<> gShowbPrecCon t sfs 0 b
gShowbPrecCon t@Pref sfs p (a :*: b) =
gShowbPrecCon t sfs p a
<> showbSpace
<> gShowbPrecCon t sfs p b
instance (TextShow1 f, GTextShowCon One g) => GTextShowCon One (f :.: g) where
gShowbPrecCon t sfs p (Comp1 x) =
let gspc = gShowbPrecCon t sfs
in liftShowbPrec gspc (showbListWith (gspc 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