From 0ae9bd4a27306d1e69792922f56dafe64b8f34d6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sun, 22 Oct 2023 17:03:22 +0100 Subject: [PATCH 1/2] Correct parenthesisation in generic Show --- src/Generics/SOP/Show.hs | 76 ++++++++++++++++++++++++++-------------- 1 file changed, 50 insertions(+), 26 deletions(-) diff --git a/src/Generics/SOP/Show.hs b/src/Generics/SOP/Show.hs index fe6a216..a716afb 100644 --- a/src/Generics/SOP/Show.hs +++ b/src/Generics/SOP/Show.hs @@ -3,9 +3,9 @@ -- This module contains a generic show function defined using -- @generics-sop@. -- -module Generics.SOP.Show (gshow) where +module Generics.SOP.Show (gshowsPrec, gshow) where -import Data.List (intercalate) +import Data.List (intersperse) import Generics.SOP @@ -16,44 +16,68 @@ import Generics.SOP -- 'deriving Show'. -- -- It serves as an example of an SOP-style generic function that makes --- use of metadata. However, it does currently not handle parentheses --- correctly, and is therefore not really usable as a replacement. +-- use of metadata. -- --- If you want to use it anyway on a datatype @T@ for which you have --- a 'Generics.SOP.Generic' instance, you can use 'gshow' as follows: +-- If you want to use it on a datatype @T@ for which you have a +-- 'Generics.SOP.Generic' instance, you can use 'gshowsPrec' as +-- follows: -- -- > instance Show T where --- > show = gshow +-- > showsPrec = gshowsPrec -- -gshow :: forall a. (Generic a, HasDatatypeInfo a, All2 Show (Code a)) - => a -> String -gshow a = - gshow' (constructorInfo (datatypeInfo (Proxy :: Proxy a))) (from a) +gshowsPrec :: forall a. (Generic a, HasDatatypeInfo a, All2 Show (Code a)) + => Int -> a -> ShowS +gshowsPrec prec a = + gshowsPrec' prec (constructorInfo (datatypeInfo (Proxy :: Proxy a))) (from a) -gshow' :: (All2 Show xss, SListI xss) => NP ConstructorInfo xss -> SOP I xss -> String -gshow' cs (SOP sop) = hcollapse $ hcliftA2 allp goConstructor cs sop +gshow :: (Generic a, HasDatatypeInfo a, All2 Show (Code a)) => a -> String +gshow a = gshowsPrec 0 a "" -goConstructor :: All Show xs => ConstructorInfo xs -> NP I xs -> K String xs -goConstructor (Constructor n) args = - K $ intercalate " " (n : args') +gshowsPrec' :: (All2 Show xss, SListI xss) => Int -> NP ConstructorInfo xss -> SOP I xss -> ShowS +gshowsPrec' prec cs (SOP sop) = + hcollapse $ hcliftA2 allp (goConstructor prec) cs sop + +goConstructor :: All Show xs => Int -> ConstructorInfo xs -> NP I xs -> K ShowS xs +goConstructor prec (Constructor n) args = + K $ + showParen + (fixity <= prec) + (foldr (.) id $ intersperse (showString " ") (showString n : args')) where - args' :: [String] - args' = hcollapse $ hcliftA p (K . show . unI) args + args' :: [ShowS] + args' = hcollapse $ hcliftA p (K . showsPrec 11 . unI) args + + -- With fixity = 11 the parens will be shown only if the enclosing + -- context is a function application. This is correct because + -- function application is the only thing that binds tightly + -- enough to force parens around this expression. + fixity = 11 -goConstructor (Record n ns) args = - K $ n ++ " {" ++ intercalate ", " args' ++ "}" +goConstructor prec (Record n ns) args = + K $ + showParen + (fixity <= prec) + (showString n . showString " {" . foldr (.) id (intersperse (showString ", ") args') . showString "}") where - args' :: [String] + args' :: [ShowS] args' = hcollapse $ hcliftA2 p goField ns args -goConstructor (Infix n _ _) (arg1 :* arg2 :* Nil) = - K $ show arg1 ++ " " ++ show n ++ " " ++ show arg2 + -- With fixity = 12 the parens will never be shown. This is + -- correct because record construction binds tighter than even + -- function application! + fixity = 12 + +goConstructor prec (Infix n _ fixity) (I arg1 :* I arg2 :* Nil) = + K $ + showParen + (fixity <= prec) + (showsPrec fixity arg1 . showString " " . showString n . showString " " . showsPrec fixity arg2) #if __GLASGOW_HASKELL__ < 800 -goConstructor (Infix _ _ _) _ = error "inaccessible" +goConstructor _ (Infix _ _ _) _ = error "inaccessible" #endif -goField :: Show a => FieldInfo a -> I a -> K String a -goField (FieldInfo field) (I a) = K $ field ++ " = " ++ show a +goField :: Show a => FieldInfo a -> I a -> K ShowS a +goField (FieldInfo field) (I a) = K $ showString field . showString " = " . showsPrec 0 a p :: Proxy Show p = Proxy From 360fea8972d6be99270bba8e2be61f51c5a9d587 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 8 Nov 2023 10:19:09 +0100 Subject: [PATCH 2/2] Prepare for release 0.3.0 --- CHANGELOG.md | 10 ++++++++++ basic-sop.cabal | 7 ++++--- 2 files changed, 14 insertions(+), 3 deletions(-) create mode 100644 CHANGELOG.md diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..8115081 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Revision history for basic-sop + +## 0.3.0 -- 2023-11-08 + +* Started CHANGELOG.md +* Compatibility with ghc up to 9.8 (#9, tomjaguarpaw) +* Correct parenthesis, avoid spurious I (#10, tomjaguarpaw) +* Dropped support for ghc prior to 8.10.7 + + diff --git a/basic-sop.cabal b/basic-sop.cabal index 0d9305f..67dfa5a 100644 --- a/basic-sop.cabal +++ b/basic-sop.cabal @@ -1,5 +1,5 @@ name: basic-sop -version: 0.2.0.3 +version: 0.3.0 synopsis: Basic examples and functions for generics-sop description: This library contains various small examples of generic functions @@ -15,8 +15,9 @@ author: Edsko de Vries , Andres Löh =1.10 -tested-with: GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.7, GHC==9.6.3, GHC==9.8.1 +cabal-version: 1.24 +extra-doc-files: CHANGELOG.md +tested-with: GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.7, GHC==9.6.3, GHC==9.8.1 source-repository head type: git