sr-extra-1.72.1: Extra/Generics/Show.hs
-- | This is a both a working implementation of Generic Show and a
-- template for using GHC.Generics to implement similar functions
-- without requiring that every type it can operate on have a Show
-- instance. It does require an instance for each base type.
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
-- {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS -Wall -Wredundant-constraints #-}
module Extra.Generics.Show
( GShow0, gprecShows, gshowsPrec
, GShow1, gLiftPrecShows, gLiftShowsPrec
, GShow, gshow, gshows
, myshow
) where
--import Debug.Trace
import Data.Foldable (foldl')
import Data.Functor.Classes (Show1(..))
import Data.Functor.Identity (Identity(Identity))
import Data.Proxy (Proxy(Proxy))
import Generic.Data (gconIndex)
import GHC.Generics as G
--import GHC.TypeLits
import Text.Show.Combinators (PrecShowS, {-ShowFields,-} noFields, showField, showListWith, showInfix, showApp, showCon, showRecord)
import qualified Text.Show.Combinators as Show (appendFields)
-- For primitive instances
-- import Data.Typeable (Typeable, typeOf)
-- For tests
#if !__GHCJS__
import Test.HUnit
import Language.Haskell.TH (location)
import Language.Haskell.TH.Lift (lift)
import Language.Haskell.TH.Instances ()
#endif
-- for debug
-- import Debug.Trace
--import GHC.TypeLits
-- The K1 instance had constraint Show a, which means that every field
-- traversed must have a Show instance. I removed this constraint,
-- and then also had to remove it from doK1. Now I needed doK1 to Use
-- the Show instance for a set of base types and otherwise use the
-- Generic instance. This can be done by creating a new class DoK1
-- and using overlapping instances.
type TypeTuple = (String, String, String, Bool)
type ConstrTuple = (Int, String, Fixity)
-- Constraints for doing recusion into subtypes
type DoRep a = (Generic a, DoM1 Proxy (Rep a))
type DoRep1 f = (Generic1 f, DoM1 Identity (Rep1 f))
class DoS1 p f where doS1 :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> S1Result
instance {-# OVERLAPPABLE #-} DoRep a => DoS1 p (K1 R a) where doS1 p ti ci (K1 a) = doRecursion p ti ci a
instance DoRep1 f => DoS1 Identity (Rec1 f) where doS1 (Identity st) ti ci (Rec1 r) = doRec1 st ti ci r
instance DoS1 Identity Par1 where doS1 (Identity st) ti ci (Par1 a) = doPar1 st ti ci a
instance (Show1 f, DoS1 p g) => DoS1 p (f :.: g) where doS1 p ti ci (Comp1 c) = doComp1 p ti ci c
class DoFields p f where doFields :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> [S1Result]
instance (DoFields p f, DoFields p g) => DoFields p (f :*: g) where doFields p ti ci (x :*: y) = doFields p ti ci x <> doFields p ti ci y
instance (DoS1 p f{-, Selector s-}) => DoFields p (M1 S s f) where doFields p ti ci (M1 x) = [doS1 p ti ci x]
instance DoFields p U1 where doFields _ _ _ U1 = []
class DoNamed p f where doNamed :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> [(String, S1Result)]
instance (DoNamed p f, DoNamed p g) => DoNamed p (f :*: g) where doNamed p ti ci (x :*: y) = doNamed p ti ci x <> doNamed p ti ci y
instance (Selector c, DoS1 p f) => DoNamed p (M1 S c f) where doNamed p ti ci x'@(M1 x) = [(G.selName x', doS1 p ti ci x)]
instance DoNamed p U1 where doNamed _ _ _ U1 = []
-- Its tempting to add the Constructor constraint here but it leads to
-- a missing constraint on an unexported GHC.Generics class.
class DoConstructor p c f where doConstructor :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> M1 C c f a -> C1Result
instance (DoFields p f{-, KnownSymbol s-}) => DoConstructor p ('MetaCons s y 'False) f
where doConstructor p ti ci (M1 x) = doNormal ti ci (zip [0..] (doFields p ti ci x))
instance DoNamed p f => DoConstructor p ('MetaCons s y 'True) f where doConstructor p ti ci (M1 x) = doRecord ti ci (zip [0..] (doNamed p ti ci x))
class DoDatatype p d f where doDatatype :: forall a. p (Rd a) -> TypeTuple -> M1 D d f a -> D1Result
instance (DoD1 p f{-, Datatype d-}) => DoDatatype p d f where doDatatype p ti (M1 x) = doD1 p ti x
class DoD1 p f where doD1 :: forall a. p (Rd a) -> TypeTuple -> f a -> D1Result
instance (DoDatatype p d f{-, Datatype d-}) => DoD1 p (M1 D d f) where doD1 p ti x@(M1 _) = doDatatype p ti x
instance (DoD1 p f, DoD1 p g) => DoD1 p (f :+: g) where doD1 p ti (L1 x) = doD1 p ti x
doD1 p ti (R1 y) = doD1 p ti y
instance (Constructor c, DoConstructor p c f) => DoD1 p (M1 C c f) where doD1 p ti x = doConstructor p ti (gconIndex x, G.conName x, G.conFixity x) x
instance DoD1 p V1 where doD1 _ _ v = case v of {}
class DoM1 p f where doM1 :: forall a. p (Rd a) -> f a -> D1Result
instance (DoDatatype p d f, Datatype d) => DoM1 p (M1 D d f) where doM1 p x@(M1 _) = let ti = (G.datatypeName x, G.moduleName x, G.packageName x, G.isNewtype x) in doD1 p ti x
-- customization for generic Show --
-- Instances for primitive types
instance DoS1 p (K1 R Int) where doS1 p ti ci (K1 a) = doLeaf p ti ci a
instance DoS1 p (K1 R Char) where doS1 p ti ci (K1 a) = doLeaf p ti ci a
instance {-# OVERLAPPING #-} DoS1 p (K1 R String) where doS1 p ti ci (K1 a) = doLeaf p ti ci a -- overlaps [a]
instance DoS1 Proxy (K1 R a) =>
DoS1 p (K1 R [a]) where doS1 p ti ci (K1 xs) = doList p ti ci (fmap myshows xs)
instance DoS1 p (K1 R ()) where doS1 p ti ci (K1 ()) = doTuple p ti ci []
instance (DoS1 Proxy (K1 R a),
DoS1 Proxy (K1 R b)) => DoS1 p (K1 R (a, b))
where doS1 p ti ci (K1 (a, b)) = doTuple p ti ci [myshows a, myshows b]
instance (DoS1 Proxy (K1 R a),
DoS1 Proxy (K1 R b),
DoS1 Proxy (K1 R c)) => DoS1 p (K1 R (a, b, c))
where doS1 p ti ci (K1 (a, b, c)) = doTuple p ti ci [myshows a, myshows b, myshows c]
instance (DoS1 Proxy (K1 R a),
DoS1 Proxy (K1 R b),
DoS1 Proxy (K1 R c),
DoS1 Proxy (K1 R d)) => DoS1 p (K1 R (a, b, c, d))
where doS1 p ti ci (K1 (a, b, c, d)) = doTuple p ti ci [myshows a, myshows b, myshows c, myshows d]
instance (DoS1 Proxy (K1 R a),
DoS1 Proxy (K1 R b),
DoS1 Proxy (K1 R c),
DoS1 Proxy (K1 R d),
DoS1 Proxy (K1 R e)) => DoS1 p (K1 R (a, b, c, d, e))
where doS1 p ti ci (K1 (a, b, c, d, e)) = doTuple p ti ci [myshows a, myshows b, myshows c, myshows d, myshows e]
type Rd a = (Int -> a -> ShowS, [a] -> ShowS) -- Like a Reader monad
type S1Result = PrecShowS -- The result of a single field of a constructor
type C1Result = PrecShowS -- Result of processing one constructors
type D1Result = PrecShowS -- Result of processing a type value
doLeaf :: Show a => p -> TypeTuple -> ConstrTuple -> a -> S1Result
doLeaf _p _ti _ci a _prec = shows a
doList :: p -> TypeTuple -> ConstrTuple -> [ShowS] -> S1Result
doList _ _ _ [] = \_ -> showChar '[' . showChar ']'
doList _ _ _ xs = \_ -> showChar '[' . foldl1 (\a b -> a . showString "," . b) xs . showChar ']'
doTuple :: p -> TypeTuple -> ConstrTuple -> [ShowS] -> S1Result
doTuple _ _ _ [] = \_ -> showString "()"
doTuple _ _ _ ks = \_ -> showChar '(' . foldl1 (\a b -> a . showString "," . b) ks . showChar ')'
doUnboxed :: Show a => p -> TypeTuple -> ConstrTuple -> a -> S1Result
doUnboxed _p _ti _ci a _prec s = show a <> s
doRecursion :: (Generic a, DoM1 Proxy (Rep a)) => p -> TypeTuple -> ConstrTuple -> a -> S1Result
doRecursion _p _ti _ci a = flip gshowsPrec a
-- Rec1 marks a field (S1) which is itself a record
doRec1 :: (Generic1 f, DoM1 Identity (Rep1 f)) => forall a. Rd a -> TypeTuple -> ConstrTuple -> f a -> S1Result
doRec1 sp _ti _ci r = flip (uncurry gLiftShowsPrec sp) r
-- Par1 marks a field (S1) which is just a type parameter
doPar1 :: Rd a -> TypeTuple -> ConstrTuple -> a -> S1Result
doPar1 (op1', _) _ti _ci a = flip op1' a
-- Comp1 is the marks a field (S1) of type (:.:), composition
doComp1 :: (Show1 f, DoS1 p g) => p (Rd a) -> TypeTuple -> ConstrTuple -> f (g a) -> S1Result
doComp1 p ti ci c = flip (liftShowsPrec (flip (doS1 p ti ci)) (showListWith (flip (doS1 p ti ci) 0))) c
-- Handle the unnamed fields of a constructor (C1)
doNormal :: TypeTuple -> ConstrTuple -> [(Int, S1Result)] -> C1Result
doNormal _ (_, name, Infix _ fy) (k1 : k2 : ks) = foldl' showApp (showInfix name fy (snd k1) (snd k2)) (fmap snd ks)
doNormal _ (_, name, Infix _ _) ks = foldl' showApp (showCon ("(" ++ name ++ ")")) (fmap snd ks)
doNormal _ (_, name, Prefix) ks = foldl' showApp (showCon name ) (fmap snd ks)
-- Handle the named fields of a constructor (C1)
doRecord :: TypeTuple -> ConstrTuple -> [(Int, (String, S1Result))] -> C1Result
doRecord _ (_, cname, _) [] = showRecord cname noFields
-- Do not render the Top type, it is private to this module and is
-- only used to get the recursion to work.
doRecord ("Top", "Extra.Generics.Show", _, _) _ [(_, (_, r))] = r
doRecord _ (_, cname, Prefix) ks = showRecord cname (foldl1 Show.appendFields (fmap (uncurry showField) (fmap snd ks)))
doRecord _ (_, cname, Infix _ _) ks = showRecord ("(" ++ cname ++ ")") (foldl1 Show.appendFields (fmap (uncurry showField) (fmap snd ks)))
---------------------------------------------------
-- | Generic representation of 'Show' types.
type GShow0 = DoM1 Proxy
newtype Top a = Top {unTop :: a} deriving Generic
infixr 0 `Top`
-- | Generic 'showsPrec'.
--
-- @
-- instance 'Show' MyType where
-- 'showsPrec' = 'gshowsPrec'
-- @
gprecShows :: forall a. GShow a => a -> PrecShowS
gprecShows = doM1 (Proxy :: Proxy (Rd a)) . from
gshowsPrec :: GShow a => Int -> a -> ShowS
gshowsPrec = flip gprecShows
-- | Generic representation of 'Data.Functor.Classes.Show1' types.
-- class Show1 (f :: * -> *) where
-- liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
-- liftShowsList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
type GShow1 = DoM1 Identity
gLiftPrecShows ::
(GShow1 f)
=> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> f a -> PrecShowS
gLiftPrecShows = curry (doM1 . Identity)
-- | Generic 'liftShowsPrec'.
gLiftShowsPrec ::
(Generic1 f, GShow1 (Rep1 f))
=> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> f a -> ShowS
gLiftShowsPrec op1' op2' =
flip (gLiftPrecShows op1' op2' . from1)
type GShow a = (Generic a, GShow0 (Rep a))
gshow :: GShow a => a -> String
gshow x = gshows x ""
gshows :: GShow a => a -> ShowS
gshows = gshowsPrec 0
#if 0
class MyShow a where
myshows :: a -> ShowS
default myshows :: (Generic a, GShow (Rep a)) => a -> ShowS
myshows a = gshows (Top a)
myshow :: a -> String
default myshow :: (Generic a, GShow (Rep a)) => a -> String
myshow a = gshow
#else
myshow :: (DoS1 Proxy (K1 R a)) => a -> String
myshow a = gshow (Top a)
myshows :: (DoS1 Proxy (K1 R a)) => a -> ShowS
myshows a = gshows (Top a)
#endif
#if !__GHCJS__
data Foo = Foo {n :: Int, ch :: Char} deriving (Generic, Show)
data Bar = Bar [Foo] String deriving (Generic, Show)
data Rose a = Fork a [Rose a] deriving (Generic, Show)
data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic, Show)
data WithInt a = WithInt Int a deriving (Generic, Show)
_tests :: IO ()
_tests = do
r@Counts{..} <-
runTestTT
(TestList
[ TestCase (assertEqual "T1" "Foo {n = 1, ch = 'x'}" (myshow (Foo 1 'x')))
, TestCase (assertEqual "T2" "Bar [Foo {n = 1, ch = 'x'}] \"hello\"" (myshow (Bar [Foo 1 'x'] "hello")))
, TestCase (assertEqual "T3" "Fork 'a' [Fork 'b' []]" (myshow (Fork 'a' [Fork 'b' []])))
, TestCase (assertEqual "T4" "Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c'))" (myshow (Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c')))))
, TestCase (assertEqual "T5" "WithInt 5 (WithInt 2 'a')" (myshow (WithInt 5 (WithInt 2 'a'))))
, let (expected, loc) = $(lift =<< (\x -> (show x, x)) <$> location) in
TestCase (assertEqual "T6" expected (myshow loc))
, TestCase (assertEqual "T7" "[1,2,3]" (myshow ([1,2,3] :: [Int])))
, TestCase (assertEqual "T8" "[1]" (myshow ([1] :: [Int])))
, TestCase (assertEqual "T9" "1" (myshow (1 :: Int)))
, TestCase (assertEqual "T10" "('x',2,\"abc\")" (myshow ('x',(2 :: Int),("abc" :: String))))
])
case (errors, failures) of
(0, 0) -> return ()
_ -> error (show r)
#endif