summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorlyxia <>2018-02-25 19:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-02-25 19:48:00 (GMT)
commit4975adf74e9402510024521efda19c952670a370 (patch)
tree4dfe455519c0dbeb445fd84b2bf703e9e3ca384b
version 0.1.0.00.1.0.0
-rw-r--r--LICENSE19
-rw-r--r--README.md19
-rw-r--r--Setup.hs2
-rw-r--r--show-combinators.cabal38
-rw-r--r--src/Text/Show/Combinators.hs132
-rw-r--r--test/test.hs42
6 files changed, 252 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..b4a9b96
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,19 @@
+Copyright Li-yao Xia (c) 2018
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the “Software”), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE. \ No newline at end of file
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..3ee4003
--- /dev/null
+++ b/README.md
@@ -0,0 +1,19 @@
+# Show combinators
+
+A minimal set of convenient combinators to write `Show` instances.
+
+```haskell
+data MyType a
+ = C a a -- a regular constructor
+ | a :+: a -- an infix constructor
+ | R { f1 :: a, f2 :: a } -- a record
+
+infixl 4 :+:
+
+instance Show a => Show (MyType a) where
+ showsPrec = flip precShows where
+ precShows (C a b) = showCon "C" @| a @| b
+ precShows (c :+: d) = showInfix ":+:" 4 c d
+ precShows (R {f1 = e, f2 = f}) =
+ showRecord "R" ("f1" .=. e &| "f2" .=. f)
+```
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/show-combinators.cabal b/show-combinators.cabal
new file mode 100644
index 0000000..e5d0fde
--- /dev/null
+++ b/show-combinators.cabal
@@ -0,0 +1,38 @@
+name: show-combinators
+version: 0.1.0.0
+synopsis: Combinators to write Show instances
+description:
+ A minimal pretty-printing library for Show instances in Haskell.
+homepage: https://github.com/Lysxia/show-combinators#readme
+license: MIT
+license-file: LICENSE
+author: Li-yao Xia
+maintainer: lysxia@gmail.com
+copyright: 2018 Li-yao Xia
+category: Text
+build-type: Simple
+extra-source-files: README.md
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules:
+ Text.Show.Combinators
+ build-depends:
+ base >= 4.9 && < 5
+ ghc-options: -Wall
+ default-language: Haskell2010
+
+test-suite test
+ hs-source-dirs: test
+ main-is: test.hs
+ build-depends:
+ show-combinators,
+ base
+ ghc-options: -Wall
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+
+source-repository head
+ type: git
+ location: https://github.com/Lysxia/show-combinators
diff --git a/src/Text/Show/Combinators.hs b/src/Text/Show/Combinators.hs
new file mode 100644
index 0000000..e785024
--- /dev/null
+++ b/src/Text/Show/Combinators.hs
@@ -0,0 +1,132 @@
+-- | Combinators for 'Show'
+--
+-- The combinators below can be used to write 'Show' instances.
+--
+-- The following type illustrates the common use cases.
+--
+-- @
+-- data MyType a
+-- = C a a -- a regular constructor
+-- | a :+: a -- an infix constructor
+-- | R { f1 :: a, f2 :: a } -- a record
+--
+-- infixl 4 :+:
+--
+-- instance 'Show' a => 'Show' (MyType a) where
+-- 'showsPrec' = 'flip' precShows where
+-- precShows (C a b) = 'showCon' "C" '@|' a '@|' b
+-- precShows (c :+: d) = 'showInfix'' ":+:" 4 c d
+-- precShows (R {f1 = e, f2 = f}) =
+-- 'showRecord' "R" ("f1" '.=.' e '&|' "f2" '.=.' f)
+-- @
+
+module Text.Show.Combinators
+ ( module Text.Show
+ , PrecShowS
+ , showCon
+ , showApp
+ , (@|)
+ , showInfix
+ , showInfix'
+ , ShowFields
+ , showRecord
+ , showField
+ , (.=.)
+ , noFields
+ , appendFields
+ , (&|)
+ ) where
+
+import Text.Show
+
+-- | Type of strings representing expressions, parameterized by the surrounding
+-- precedence level.
+--
+-- This is the return type of @'flip' 'showsPrec'@.
+type PrecShowS = Int -> ShowS
+
+-- | Show a constructor.
+showCon :: String -> PrecShowS
+showCon con _ = showString con
+
+infixl 2 `showApp`, @|
+
+-- | Show a function application.
+showApp :: PrecShowS -> PrecShowS -> PrecShowS
+showApp showF showX d = showParen (d > appPrec)
+ (showF appPrec . showSpace . showX appPrec1)
+
+-- | Show a function application.
+--
+-- This is an infix shorthand for 'showApp' when the argument type is an
+-- instance of 'Show'.
+--
+-- > showF @| x = showApp showF (flip showsPrec x)
+(@|) :: Show a => PrecShowS -> a -> PrecShowS
+(@|) showF x = showApp showF (flip showsPrec x)
+
+-- | Show an applied infix operator with a given precedence.
+showInfix :: String -> Int -> PrecShowS -> PrecShowS -> PrecShowS
+showInfix op prec showX showY d = showParen (d > prec)
+ (showX (prec + 1) . showSpace . showString op . showSpace . showY (prec + 1))
+
+-- | Show an applied infix operator with a given precedence.
+--
+-- This is a shorthand for 'showInfix' when the arguments types are instances
+-- of 'Show'.
+--
+-- > showInfix' op prec x y =
+-- > showInfix op prec (flip showsPrec x) (flip showsPrec y)
+showInfix' :: (Show a, Show b) => String -> Int -> a -> b -> PrecShowS
+showInfix' op prec x y = showInfix op prec (flip showsPrec x) (flip showsPrec y)
+
+-- | Strings representing a set of record fields separated by commas.
+-- They can be constructed using ('.=.') and ('@|'), or using 'showField' and
+-- 'appendFields'.
+type ShowFields = ShowS
+
+-- | Show a record. The first argument is the constructor name.
+-- The second represents the set of record fields.
+showRecord :: String -> ShowFields -> PrecShowS
+showRecord con showFields _ =
+ showString con . showSpace . showChar '{' . showFields . showChar '}'
+
+-- | Show a single record field: a field name and a value separated by @\'=\'@.
+showField :: String -> PrecShowS -> ShowFields
+showField field showX =
+ showString field . showString " = " . showX 0
+
+infixr 8 .=.
+
+-- | Show a single record field: a field name and a value separated by @\'=\'@.
+--
+-- This is an infix shorthand for 'showField' when the value type is an
+-- instance of 'Show'.
+--
+-- > field .=. x = showField field (flip showsPrec x)
+(.=.) :: Show a => String -> a -> ShowFields
+field .=. x = showField field (flip showsPrec x)
+
+-- | Empty set of record fields.
+noFields :: ShowFields
+noFields = id
+
+infixr 1 `appendFields`, &|
+
+-- | Separate two nonempty sets of record fields by a comma.
+appendFields :: ShowFields -> ShowFields -> ShowFields
+appendFields showFds1 showFds2 = showFds1 . showString ", " . showFds2
+
+-- | An infix synonym of 'appendFields'.
+(&|) :: ShowFields -> ShowFields -> ShowFields
+(&|) = appendFields
+
+
+-- Helpers
+
+showSpace :: ShowS
+showSpace = (' ' :)
+
+appPrec, appPrec1 :: Int
+appPrec = 10
+appPrec1 = 11
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
index 0000000..a73eabb
--- /dev/null
+++ b/test/test.hs
@@ -0,0 +1,42 @@
+import Text.Show.Combinators
+
+data MyType a
+ = C a a -- a regular constructor
+ | a :+: a -- an infix constructor
+ | R { f1 :: a, f2 :: a } -- a record
+ deriving Show
+
+infixl 4 :+:
+
+showsMyType :: (a -> PrecShowS) -> MyType a -> PrecShowS
+showsMyType showA (C a b) = showCon "C" `showApp` showA a `showApp` showA b
+showsMyType showA (c :+: d) = showInfix ":+:" 4 (showA c) (showA d)
+showsMyType showA (R {f1 = e, f2 = f}) =
+ showRecord "R" ("f1" `showField` showA e &| "f2" `showField` showA f)
+
+-- Just making sure this typechecks
+_showsMyType' :: Show a => MyType a -> PrecShowS
+_showsMyType' (C a b) = showCon "C" @| a @| b
+_showsMyType' (c :+: d) = showInfix' ":+:" 4 c d
+_showsMyType' (R {f1 = e, f2 = f}) =
+ showRecord "R" ("f1" .=. e &| "f2" .=. f)
+
+check :: Show a => (a -> PrecShowS) -> a -> IO ()
+check show' x =
+ if s == s' then
+ return ()
+ else
+ fail $ show (s, s')
+ where
+ s = show x
+ s' = show' x 0 ""
+
+main :: IO ()
+main = do
+ check smt1 (C () ())
+ check smt2 (C (C () ()) (() :+: ()))
+ check smt2 ((() :+: ()) :+: (() :+: ()))
+ check smt2 (R (C () ()) (C () ()))
+ where
+ smt1 = showsMyType (flip showsPrec)
+ smt2 = showsMyType smt1