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.Common
type ShowsPrec a = Int -> a -> ShowS
newtype Show a = Show { selShow :: ConType -> Int -> a -> ShowS }
showSpace :: ShowS
showSpace = showChar ' '
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
recEntry :: Bool -> String -> ShowsPrec a -> ShowsPrec a
recEntry comma label showsPrec' _ x =
showString label .
showString " = " .
showsPrec' minPrec x .
showString (if comma then ", " else "")
rconstantShow :: (P.Show a) => ConType -> ShowsPrec a
rconstantShow ct =
case ct of
ConStd -> P.showsPrec
ConRec (label:[]) -> recEntry False label P.showsPrec
other ->
error $ "rconstantShow: Unexpected constructor: '" ++ P.show other ++ "'"
rsumShow :: Show a -> Show b -> ConType -> ShowsPrec (a :+: b)
rsumShow ra _ _ p (L a) = selShow ra ConStd p a
rsumShow _ rb _ p (R b) = selShow rb ConStd p b
rprodShow :: Show a -> Show b -> ConType -> ShowsPrec (a :*: b)
rprodShow ra rb ct p (a :*: b) =
case ct of
ConStd ->
selShowStep ra ConStd p a .
showSpace .
selShowStep rb ConStd p b
ConIfx symbol ->
selShowStep ra ConStd p a .
showSpace .
showString symbol .
showSpace .
selShowStep rb ConStd p b
ConRec (label:labels) ->
let p' = p + 1 in
recEntry True label (selShowStep ra ConStd) p' a .
selShowStep rb (ConRec (labels)) 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 [] Nonfix ->
let hasArgs = arity > 0 in
showParen (p > appPrec && hasArgs) $
showString name .
showString (if hasArgs then " " else "") .
showConStep ConStd appPrec a
ConDescr name _ [] fixity ->
let conPrec = prec fixity in
showParen (p > conPrec) $
showConStep (ConIfx name) conPrec a
ConDescr name _ labels Nonfix ->
showParen (p > appPrec) $
showString name .
showSpace .
showBraces (selShow ra (ConRec labels)) minPrec a
ConDescr name _ labels _ ->
showParen True (showString name) .
showSpace .
showBraces (showConStep (ConRec labels)) p a
where showConStep ct = selShow ra ct . (+1)
rtypeShow :: EP b a -> Show a -> ConType -> ShowsPrec b
rtypeShow ep ra ct =
case ct of
ConStd ->
selShowFrom ConStd
ConRec (label:[]) ->
recEntry False label (selShowFrom ConStd)
other ->
error $ "rtypeShow: Unexpected constructor: '" ++ P.show other ++ "'"
where selShowFrom ct' p = selShow ra ct' p . from ep
instance Generic Show where
rconstant = Show rconstantShow
rsum ra rb = Show (rsumShow ra rb)
rprod ra rb = Show (rprodShow ra rb)
rcon cd ra = Show (rconShow cd ra)
rtype ep ra = Show (rtypeShow ep ra)
instance (Rep Show a) => Rep Show [a] where
rep = Show $ const $ const $ GHC.showList__ $ selShow rep ConStd 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 ConStd
shows :: (Rep Show a) => a -> ShowS
shows = showsPrec 0
show :: (Rep Show a) => a -> String
show = flip shows ""