module Generics.EMGM.Functions.Show (
Show(..),
showsPrec,
shows,
show,
) where
import Prelude hiding (Show, showsPrec, show, shows)
import qualified Prelude as P (Show, showsPrec, show)
import qualified GHC.Show as GHC (showList__)
import Generics.EMGM.Base
type ShowsPrec a = Int -> a -> ShowS
newtype Show a = Show { selShow :: ConType -> Int -> a -> ShowS }
showSpace :: Bool -> ShowS
showSpace c = if c then showChar ' ' else id
showBraces :: ShowsPrec a -> ShowsPrec a
showBraces showsPrec' p x =
showChar '{' .
showsPrec' p x .
showChar '}'
showTuple :: [ShowS] -> ShowS
showTuple ss = showParen True $
foldr1 (\s r -> s . showChar ',' . r) ss
rsumShow :: Show a -> Show b -> ConType -> ShowsPrec (a :+: b)
rsumShow ra _ _ p (L a) = selShow ra UnknownC p a
rsumShow _ rb _ p (R b) = selShow rb UnknownC p b
rprodShow :: Show a -> Show b -> ConType -> ShowsPrec (a :*: b)
rprodShow ra rb ct p (a :*: b) =
case ct of
NormalC ->
selShowStep ra NormalC p a .
showSpace True .
selShowStep rb NormalC p b
InfixC symbol ->
selShowStep ra NormalC p a .
showSpace True .
showString symbol .
showSpace True .
selShowStep rb NormalC p b
RecordC ->
let p' = p + 1 in
selShowStep ra RecordC p' a .
showString ", " .
selShowStep rb RecordC p' b
other ->
error $ "rprodShow: Unexpected constructor: '" ++ P.show other ++ "'"
where selShowStep r ct' = selShow r ct' . (+1)
rconShow :: ConDescr -> Show a -> ConType -> ShowsPrec a
rconShow cd ra _ p a =
case cd of
ConDescr name arity False Prefix ->
let hasArgs = arity > 0 in
showParen (p > appPrec && hasArgs) $
showString name .
showSpace hasArgs .
step NormalC appPrec a
ConDescr name _ False fixity ->
let conPrec = prec fixity in
showParen (p > conPrec) $
step (InfixC name) conPrec a
ConDescr name _ True Prefix ->
showParen (p > appPrec) $
showString name .
showSpace True .
showBraces (selShow ra RecordC) minPrec a
ConDescr name _ True _ ->
showParen True (showString name) .
showSpace True .
showBraces (step RecordC) p a
where
step ct = selShow ra ct . (+1)
rlblShow :: LblDescr -> Show a -> ConType -> ShowsPrec a
rlblShow (LblDescr label) ra _ _ a =
showString label .
showString " = " .
selShow ra UnknownC minPrec a
rtypeShow :: EP b a -> Show a -> ConType -> ShowsPrec b
rtypeShow ep ra ct p = selShow ra ct p . from ep
instance Generic Show where
rint = Show $ const P.showsPrec
rinteger = Show $ const P.showsPrec
rfloat = Show $ const P.showsPrec
rdouble = Show $ const P.showsPrec
rchar = Show $ const P.showsPrec
runit = Show $ \_ _ _ -> id
rsum ra rb = Show $ rsumShow ra rb
rprod ra rb = Show $ rprodShow ra rb
rcon cd ra = Show $ rconShow cd ra
rlbl ld ra = Show $ rlblShow ld ra
rtype ep ra = Show $ rtypeShow ep ra
instance (Rep Show a) => Rep Show [a] where
rep = Show $ const $ const $ GHC.showList__ $ selShow rep UnknownC minPrec
instance Rep Show String where
rep = Show $ const P.showsPrec
instance Rep Show () where
rep = Show $ const P.showsPrec
instance (Rep Show a, Rep Show b) => Rep Show (a,b) where
rep = Show s
where s _ _ (a,b) =
showTuple [shows a, shows b]
instance (Rep Show a, Rep Show b, Rep Show c)
=> Rep Show (a,b,c) where
rep = Show s
where s _ _ (a,b,c) =
showTuple [shows a, shows b, shows c]
instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d)
=> Rep Show (a,b,c,d) where
rep = Show s
where s _ _ (a,b,c,d) =
showTuple [shows a, shows b, shows c, shows d]
instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d,
Rep Show e)
=> Rep Show (a,b,c,d,e) where
rep = Show s
where s _ _ (a,b,c,d,e) =
showTuple [shows a, shows b, shows c, shows d,
shows e]
instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d,
Rep Show e, Rep Show f)
=> Rep Show (a,b,c,d,e,f) where
rep = Show s
where s _ _ (a,b,c,d,e,f) =
showTuple [shows a, shows b, shows c, shows d,
shows e, shows f]
instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d,
Rep Show e, Rep Show f, Rep Show h)
=> Rep Show (a,b,c,d,e,f,h) where
rep = Show s
where s _ _ (a,b,c,d,e,f,h) =
showTuple [shows a, shows b, shows c, shows d,
shows e, shows f, shows h]
showsPrec ::
(Rep Show a)
=> Int
-> a
-> ShowS
showsPrec = selShow rep UnknownC
shows :: (Rep Show a) => a -> ShowS
shows = showsPrec 0
show :: (Rep Show a) => a -> String
show = flip shows ""