emgm-0.4: src/Generics/EMGM/Functions/Show.hs
-----------------------------------------------------------------------------
-- |
-- Module : Generics.EMGM.Functions.Show
-- Copyright : (c) 2008, 2009 Universiteit Utrecht
-- License : BSD3
--
-- Maintainer : generics@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- Summary: Generic functions that convert values to readable strings.
--
-- The functions in this module involve generically producing a string from a
-- value of a supported datatype. The functions 'showsPrec' and 'show' are
-- modeled after those in the class @Show@, and 'shows' after the related
-- function of the same name.
--
-- The underlying unparser is designed to be as similar to @deriving Show@ as
-- possible. Refer to documentation in "Text.Show" for details.
--
-- Since this library does not have access to the syntax of a @data@
-- declaration, it relies on 'ConDescr' for information. It is important that
-- 'ConDescr' accurately describe, for each constructor, the name, arity, record
-- labels (in same order as declared) if present, and fixity.
--
-- See also "Generics.EMGM.Functions.Read".
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
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
-----------------------------------------------------------------------------
-- Types
-----------------------------------------------------------------------------
type ShowsPrec a = Int -> a -> ShowS
-- | The type of a generic function that takes a constructor-type argument, a
-- number (precedence), and a value and returns a 'ShowS' function.
newtype Show a = Show { selShow :: ConType -> Int -> a -> ShowS }
-----------------------------------------------------------------------------
-- Utility functions
-----------------------------------------------------------------------------
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
-----------------------------------------------------------------------------
-- Generic instance declaration
-----------------------------------------------------------------------------
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
-- Normal prefix
NormalC ->
selShowStep ra NormalC p a .
showSpace True .
selShowStep rb NormalC p b
-- Infix without record syntax
InfixC symbol ->
selShowStep ra NormalC p a .
showSpace True .
showString symbol .
showSpace True .
selShowStep rb NormalC p b
-- Record-style
RecordC ->
let p' = p + 1 in
selShowStep ra RecordC p' a .
showString ", " .
selShowStep rb RecordC p' b
-- No other patterns expected
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
-- Normal prefix
ConDescr name arity False Prefix ->
let hasArgs = arity > 0 in
-- Don't show parens if constructor has no arguments
showParen (p > appPrec && hasArgs) $
showString name .
showSpace hasArgs .
step NormalC appPrec a
-- Infix without record syntax
ConDescr name _ False fixity ->
let conPrec = prec fixity in
showParen (p > conPrec) $
step (InfixC name) conPrec a
-- Record-style prefix
ConDescr name _ True Prefix ->
-- NOTE: Technically, we can use 'recPrec' instead of 'appRec' here. The
-- precedence for record construction is higher than function application.
-- However, since GHC puts parens for application, we'll put them, too.
-- That way, we can test the output with a derived Show instance.
showParen (p > appPrec) $
showString name .
showSpace True .
showBraces (selShow ra RecordC) minPrec a
-- Record-style infix: We don't actually use the fixity info here. We just
-- need to wrap the symbol name in parens.
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 -- Reset precedence in the field
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
-----------------------------------------------------------------------------
-- Rep instance declarations
-----------------------------------------------------------------------------
-- | Ad-hoc instance for lists
instance (Rep Show a) => Rep Show [a] where
rep = Show $ const $ const $ GHC.showList__ $ selShow rep UnknownC minPrec
-- | Ad-hoc instance for strings
instance Rep Show String where
rep = Show $ const P.showsPrec
-- | Ad-hoc instance for @()@
instance Rep Show () where
rep = Show $ const P.showsPrec
-- | Ad-hoc instance for @(a,b)@
instance (Rep Show a, Rep Show b) => Rep Show (a,b) where
rep = Show s
where s _ _ (a,b) =
showTuple [shows a, shows b]
-- | Ad-hoc instance for @(a,b,c)@
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]
-- | Ad-hoc instance for @(a,b,c,d)@
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]
-- | Ad-hoc instance for @(a,b,c,d,e)@
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]
-- | Ad-hoc instance for @(a,b,c,d,e,f)@
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]
-- | Ad-hoc instance for @(a,b,c,d,e,f,h)@
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]
-----------------------------------------------------------------------------
-- Exported functions
-----------------------------------------------------------------------------
-- | Convert a value to a readable string starting with the operator precedence
-- of the enclosing context.
showsPrec ::
(Rep Show a)
=> Int -- ^ Operator precedence of the enclosing context (a number from 0 to 11).
-> a -- ^ The value to be converted to a 'String'.
-> ShowS
showsPrec = selShow rep UnknownC
-- | A variant of 'showsPrec' with the minimum precedence (0).
shows :: (Rep Show a) => a -> ShowS
shows = showsPrec 0
-- | A variant of 'shows' that returns a 'String' instead of 'ShowS'.
show :: (Rep Show a) => a -> String
show = flip shows ""