diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2016 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,29 @@ +BSD3 License +============ + +Copyright David Luposchainsky (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + - Neither the name of Author name here nor the names of other contributors may + be used to endorse or promote products derived from this software without + specific prior written permission. + +This software is provided by the copyright holders and contributors "as is" and +any express or implied warranties, including, but not limited to, the implied +warranties of merchantability and fitness for a particular purpose are +disclaimed. In no event shall the copyright owner or contributors be liable for +any direct, indirect, incidental, special, exemplary, or consequential damages +(including, but not limited to, procurement of substitute goods or services; +loss of use, data, or profits; or business interruption) however caused and on +any theory of liability, whether in contract, strict liability, or tort +(including negligence or otherwise) arising in any way out of the use of this +software, even if advised of the possibility of such damage. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,72 +10,30 @@ reacts on parentheses, commas and the like. This makes it fairly robust even in the face of invalid `Show` instances, that may not produce valid Haskell code. - - -## Examples - -### Artificial +For example, consider this nested data structure: ```haskell -Hello Foo ("(Bar", Haha) (Baz (A { foo = C, bar = D, qux = (E,"He)llo World!",G, - H,[A,B,c,d,e,Fghi]) } ) (B,C) [Baz A1 B2, (Baz A3 (B4)), (Baz A5 (B6)), (Baz - (A7) B8)]) (Foo) (Bar) (Baz (A) (B)) - -==> - -Hello Foo ("(Bar",Haha) - (Baz (A {foo = C - ,bar = D - ,qux = (E - ,"He)llo World!" - ,G - ,H - ,[A,B,c,d,e,Fghi])}) - (B,C) - [Baz A1 B2 - ,(Baz A3 (B4)) - ,(Baz A5 (B6)) - ,(Baz (A7) B8)]) - (Foo) - (Bar) - (Baz (A) (B)) +nestedExample = fromList + [ ("hello", Left (Pair True ())) + , ("world", Right (Record { r1 = ('c', -1.2e34), r2 = 123 })) + , ("!" , Left (Pair False ())) ] ``` -### Inspired by a real AST +Applying show to it results in the fairly dense representation ```haskell -Set (fromList [(Name "A string with (parenthesis",Ann (Entry (Quality 1 1) - (Ann False) (Ann (Map [Ann (Bound (Ann (Id "lorem"))),Ann (Variable - (Ann (Id "ipsum")))])))),(Name "string",Ann (Entry (Quality 1 1) (Ann - True) (Ann (Internal (Ann (Reduce (Ann (Id "dolor")) (Ann (Id "sit"))))) - ))),(Name "Another } here",Ann (Entry (Quality 1 1) (Ann (Or [Ann (Not - (Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal (Ann One)) - ]))))),Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal (Ann - Three))]))),Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal - (Ann Two))])))])) (Ann (Internal (Ann (Concat (Ann (Id "amet"))))))))]) +fromList [("!",Left (Pair False ())),("hello",Left (Pair True ())),("world",Right (Record {r1 = ('c',-1.2e34), r2 = 123}))] +``` -==> +With the functions defined in this module, we can make this output a bit more +readable, -Set (fromList [(Name "A string with (parenthesis" - ,Ann (Entry (Quality 1 1) - (Ann False) - (Ann (Map [Ann (Bound (Ann (Id "lorem"))) - ,Ann (Variable (Ann (Id "ipsum")))])))) - ,(Name "string" - ,Ann (Entry (Quality 1 1) - (Ann True) - (Ann (Internal (Ann (Reduce (Ann (Id "dolor")) - (Ann (Id "sit")))))))) - ,(Name "Another } here" - ,Ann (Entry (Quality 1 1) - (Ann (Or [Ann (Not (Ann (Is (Ann Flagged) - (Ann Type) - (Ann (Multi [Ann (Literal (Ann One))]))))) - ,Ann (Is (Ann Flagged) - (Ann Type) - (Ann (Multi [Ann (Literal (Ann Three))]))) - ,Ann (Is (Ann Flagged) - (Ann Type) - (Ann (Multi [Ann (Literal (Ann Two))])))])) - (Ann (Internal (Ann (Concat (Ann (Id "amet"))))))))]) +```haskell +fromList [("!" + ,Left (Pair False ())) + ,("hello",Left (Pair True ())) + ,("world" + ,Right (Record {r1 = ('c' + ,-1.2e34) + ,r2 = 123}))] ``` diff --git a/show-prettyprint.cabal b/show-prettyprint.cabal --- a/show-prettyprint.cabal +++ b/show-prettyprint.cabal @@ -1,11 +1,11 @@ name: show-prettyprint -version: 0.1.0.2 +version: 0.1.2 synopsis: Robust prettyprinter for output of auto-generated Show instances description: See README.md homepage: https://github.com/quchen/show-prettyprint#readme license: BSD3 -license-file: LICENSE +license-file: LICENSE.md author: David Luposchainsky maintainer: David Luposchainsky copyright: David Luposchainsky, 2016 @@ -18,12 +18,15 @@ library hs-source-dirs: src exposed-modules: Text.Show.Prettyprint + , Text.Show.Prettyprint.Diagnostic + , Text.Show.Prettyprint.Internal build-depends: base >= 4.7 && < 5 , trifecta >= 1.6 -- Transitive dependency of Trifecta, so let the - --version be sorted out by that + -- version be sorted out by that , ansi-wl-pprint + ghc-options: -Wall default-language: Haskell2010 test-suite doctest diff --git a/src/Text/Show/Prettyprint.hs b/src/Text/Show/Prettyprint.hs --- a/src/Text/Show/Prettyprint.hs +++ b/src/Text/Show/Prettyprint.hs @@ -1,39 +1,55 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Format a 'show'-generated string to make it nicer to read. -- +-- For example, consider this nested data structure: +-- -- >>> :{ --- (putStrLn . prettyShow . Data.Map.fromList) --- [("hello", Just True), ("world", Nothing), ("!", Just False)] +-- let nestedExample = fromList +-- [ ("hello", Left (Pair True ())) +-- , ("world", Right (Record { r1 = ('c', -1.2e34), r2 = 123 })) +-- , ("!" , Left (Pair False ())) ] -- :} --- fromList [("!",Just False) --- ,("hello",Just True) --- ,("world",Nothing)] -- --- See the readme for some more examples. +-- Applying 'show' to it results in the fairly dense representation +-- +-- >>> print nestedExample +-- fromList [("!",Left (Pair False ())),("hello",Left (Pair True ())),("world",Right (Record {r1 = ('c',-1.2e34), r2 = 123}))] +-- +-- With the functions defined in this module, we can make this output a bit more +-- readable, +-- +-- >>> prettyPrint nestedExample +-- fromList [("!" +-- ,Left (Pair False ())) +-- ,("hello",Left (Pair True ())) +-- ,("world" +-- ,Right (Record {r1 = ('c' +-- ,-1.2e34) +-- ,r2 = 123}))] module Text.Show.Prettyprint ( prettifyShow, prettyShow, - - -- * Diagnostic functions - prettifyShowErr, - prettyShowErr, + prettyPrint, ) where -import Control.Applicative -import Data.Monoid -import Text.PrettyPrint.ANSI.Leijen as Ppr hiding ((<>)) -import Text.Trifecta as Tri +import Text.Trifecta +import Text.Show.Prettyprint.Internal + +-- $setup +-- >>> data Record a b = Record { r1 :: a, r2 :: b } deriving Show +-- >>> data Pair a b = Pair a b deriving Show +-- >>> import Data.Map (fromList) + + + -- | Prettyprint a string produced by 'show'. On parse error, silently fall back -- to a non-prettyprinted version. prettifyShow :: String -> String -prettifyShow s = case parseString conP mempty s of +prettifyShow s = case parseString shownP mempty s of Success x -> show x Failure _ -> s @@ -41,77 +57,6 @@ prettyShow :: Show a => a -> String prettyShow = prettifyShow . show --- | Attempt to prettify a string produced by 'show'. Report error information --- on failure. -prettifyShowErr :: String -> String -prettifyShowErr s = case parseString conP mempty s of - Success x -> show x - Failure ErrInfo{ _errDoc = e } -> "ERROR " <> show e - --- | 'prettifyShowErr' with the 'show' baked in. -prettyShowErr :: Show a => a -> String -prettyShowErr = prettifyShowErr . show - - - -conP :: Parser Doc -conP = do - thing <- (token . choice) - [ word - , number - , fmap (dquotes . Ppr.string) stringLiteral ] - args <- many argP - pure (if null args - then thing - else thing <+> align (sep args) ) - -word :: Parser Doc -word = variable <|> constructor - -number :: Parser Doc -number = p "number" - where - p = integerOrDouble >>= \case - Left i -> pure (Ppr.integer i) - Right d -> pure (Ppr.double d) - -identifierStartingWith :: CharParsing f => f Char -> f Doc -identifierStartingWith x = liftA2 (\c cs -> Ppr.string (c:cs)) (x <|> Tri.char '_') (many (alphaNum <|> oneOf "'_")) - -variable :: Parser Doc -variable = identifierStartingWith lower "variable" - -constructor :: Parser Doc -constructor = identifierStartingWith upper "constructor" - -argP :: Parser Doc -argP = (token . choice) [unitP, tupleP, listP, recordP, conP] - -unitP :: Parser Doc -unitP = p "()" - where - p = fmap Ppr.string (Tri.string "()") - -tupleP :: Parser Doc -tupleP = p "tuple" - where - p = fmap (encloseSep lparen rparen Ppr.comma) (Tri.parens (do - x <- argP - xs <- many (Tri.comma *> argP) - pure (x:xs) )) - -listP :: Parser Doc -listP = p "list" - where - p = fmap (encloseSep lbracket rbracket Ppr.comma) - (Tri.brackets (sepBy argP Tri.comma)) - -recordP :: Parser Doc -recordP = p "{...}" - where - p = fmap (encloseSep lbrace rbrace Ppr.comma) (Tri.braces (sepBy recordEntryP Tri.comma)) - recordEntryP = do - lhs <- token word - _ <- token (Tri.char '=') - rhs <- argP - pure (lhs <+> Ppr.string "=" <+> rhs) +-- | 'prettifyShow' with the 'show' and the 'putStrLn' baked in. +prettyPrint :: Show a => a -> IO () +prettyPrint = putStrLn . prettyShow diff --git a/src/Text/Show/Prettyprint/Diagnostic.hs b/src/Text/Show/Prettyprint/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Prettyprint/Diagnostic.hs @@ -0,0 +1,41 @@ +-- | These functions are identical to the ones in the main module, but instead +-- of falling back to the un-prettyprinted input, they will report an error on +-- failure. +-- +-- >>> putStrLn (prettifyShowErr "Imbalanced (Parenthesis)) here") +-- ERROR (interactive):1:25: error: expected: char literal, +-- end of input, identifier, list, +-- number, record, string literal, +-- tuple, unit +-- Imbalanced (Parenthesis)) here +-- ^ +module Text.Show.Prettyprint.Diagnostic ( + prettifyShowErr, + prettyShowErr, + prettyPrintErr, +) where + + + +import Data.Monoid +import Text.PrettyPrint.ANSI.Leijen as Ppr hiding ((<>)) +import Text.Trifecta as Tri + +import Text.Show.Prettyprint.Internal + + + +-- | Attempt to prettify a string produced by 'show'. Report error information +-- on failure. +prettifyShowErr :: String -> String +prettifyShowErr s = case parseString shownP mempty s of + Success x -> show x + Failure ErrInfo{ _errDoc = e } -> "ERROR " <> show (plain e) + +-- | 'prettifyShowErr' with the 'show' baked in. +prettyShowErr :: Show a => a -> String +prettyShowErr = prettifyShowErr . show + +-- | 'prettifyShowErr' with the 'show' and the 'putStrLn' baked in. +prettyPrintErr :: Show a => a -> IO () +prettyPrintErr = putStrLn . prettyShowErr diff --git a/src/Text/Show/Prettyprint/Internal.hs b/src/Text/Show/Prettyprint/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Prettyprint/Internal.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE LambdaCase #-} + +-- | __This module may change arbitrarily between versions.__ It is exposed only +-- for documentary purposes. +module Text.Show.Prettyprint.Internal ( + shownP, + valueP, + identifierP, + numberP, + stringLitP, + charLitP, + argP, + unitP, + tupleP, + listP, + recordP, +) where + + + +import Control.Applicative +import Text.PrettyPrint.ANSI.Leijen as Ppr hiding ((<>)) +import Text.Trifecta as Tri + + + +-- $setup +-- >>> :{ +-- let testParse p s = case parseString p mempty s of +-- Success x -> print x +-- Failure ErrInfo{ _errDoc = e } -> putStrLn ("ERROR " ++ show (plain e)) +-- :} + + + +-- | Prettyparser for a 'show'-generated string +shownP :: Parser Doc +shownP = valueP <* eof + +-- | Prettyparser for a constructor, which is roughly a word applied to +-- arguments. +-- +-- >>> testParse valueP "Just ('c', Left ())" +-- Just ('c',Left ()) +valueP :: Parser Doc +valueP = do + thing <- choice [identifierP, numberP, stringLitP, charLitP] + args <- many argP + pure (if null args + then thing + else thing <+> align (sep args) ) + +-- | An identifier is a liberal version of a "variable or constructor", which +-- roughly means that it's a printable word without parentheses. +-- +-- >>> testParse identifierP "_foo'bar" +-- _foo'bar +identifierP :: Parser Doc +identifierP = token (p "identifier") + where + p = fmap Ppr.text (some (alphaNum <|> oneOf "'_")) + +-- | Number in integer or scientific notation. +-- +-- >>> testParse numberP "123456" +-- 123456 +-- +-- >>> testParse numberP "-123.4e56" +-- -1.234e58 +numberP :: Parser Doc +numberP = p "number" + where + p = integerOrDouble >>= \case + Left i -> pure (Ppr.integer i) + Right d -> pure (Ppr.double d) + +-- | +-- >>> testParse stringLitP "\"Hello world!\"" +-- "Hello world!" +stringLitP :: Parser Doc +stringLitP = token (p "string literal") + where + p = fmap (dquotes . Ppr.string) stringLiteral + +-- | +-- >>> testParse charLitP "'c'" +-- 'c' +charLitP :: Parser Doc +charLitP = token (p "char literal") + where + p = fmap (squotes . Ppr.char) Tri.charLiteral + +-- | Anything that could be considered an argument to something else. +-- +-- >>> testParse argP "()" +-- () +-- +-- >>> testParse argP "['h', 'e', 'l', 'l', 'o']" +-- ['h','e','l','l','o'] +argP :: Parser Doc +argP = (token . choice) [unitP, tupleP, listP, recordP, valueP] + +-- | +-- >>> testParse unitP "()" +-- () +unitP :: Parser Doc +unitP = p "unit" + where + p = fmap Ppr.string (Tri.string "()") + +-- | Prettyparser for tuples from size 1. Since 1-tuples are just parenthesized +-- expressions to first order approximation, this parser handles those as well. +-- +-- >>> testParse tupleP "((), True, 'c')" +-- ((),True,'c') +tupleP :: Parser Doc +tupleP = p "tuple" + where + p = fmap (encloseSep lparen rparen Ppr.comma) (Tri.parens (do + x <- argP + xs <- many (Tri.comma *> argP) + pure (x:xs) )) + +-- | List prettyparser. Lists can be heterogeneous, which is realistic if we +-- consider ill-defined Show instances. +-- +-- >>> testParse listP "[\"Hello\", World]" +-- ["Hello",World] +listP :: Parser Doc +listP = p "list" + where + p = fmap (encloseSep lbracket rbracket Ppr.comma) + (Tri.brackets (sepBy argP Tri.comma)) + +-- | +-- >>> testParse recordP "{ r1 = (), r2 = Just True }" +-- {r1 = (),r2 = Just True} +recordP :: Parser Doc +recordP = p "record" + where + p = fmap (encloseSep lbrace rbrace Ppr.comma) (Tri.braces (sepBy recordEntryP Tri.comma)) + recordEntryP = do + lhs <- token identifierP + _ <- token (Tri.char '=') + rhs <- argP + pure (lhs <+> Ppr.string "=" <+> rhs)