summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcdepillabout <>2019-08-19 01:04:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-08-19 01:04:00 (GMT)
commit3689e04505a09f617eef8d646db41cc33115156d (patch)
tree43a134e7fe6c2ae282a9d39cbbdde698e5268e0b
parent6e597317a30f51c1f8143f6cf7ad0e04fd2f4150 (diff)
version 3.1.0.03.1.0.0
-rw-r--r--CHANGELOG.md6
-rw-r--r--Setup.hs31
-rw-r--r--pretty-simple.cabal14
-rw-r--r--src/Text/Pretty/Simple/Internal/Color.hs2
-rw-r--r--src/Text/Pretty/Simple/Internal/Expr.hs6
-rw-r--r--src/Text/Pretty/Simple/Internal/ExprParser.hs86
-rw-r--r--src/Text/Pretty/Simple/Internal/ExprToOutput.hs6
-rw-r--r--src/Text/Pretty/Simple/Internal/Output.hs6
-rw-r--r--src/Text/Pretty/Simple/Internal/OutputPrinter.hs6
-rw-r--r--test/DocTest.hs44
10 files changed, 158 insertions, 49 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 1b216c7..eea25de 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,4 +1,10 @@
+## 3.1.0.0
+
+* Numbers are now highlighted in green by default. Implemented in
+ [#51](https://github.com/cdepillabout/pretty-simple/pull/51).
+ Thanks [lawrencebell](https://github.com/lawrencebell)!
+
## 3.0.0.0
* pretty-simple now escapes non-printable characters by default. A field
diff --git a/Setup.hs b/Setup.hs
index 9a994af..1715887 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,33 @@
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wall #-}
+module Main (main) where
+
+#ifndef MIN_VERSION_cabal_doctest
+#define MIN_VERSION_cabal_doctest(x,y,z) 0
+#endif
+
+#if MIN_VERSION_cabal_doctest(1,0,0)
+
+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
+main :: IO ()
+main = defaultMainWithDoctests "pretty-simple-doctest"
+
+#else
+
+#ifdef MIN_VERSION_Cabal
+-- If the macro is defined, we have new cabal-install,
+-- but for some reason we don't have cabal-doctest in package-db
+--
+-- Probably we are running cabal sdist, when otherwise using new-build
+-- workflow
+#warning You are configuring this package without cabal-doctest installed. \
+ The doctests test-suite will not work as a result. \
+ To fix this, install cabal-doctest before configuring.
+#endif
+
import Distribution.Simple
+
+main :: IO ()
main = defaultMain
+
+#endif
diff --git a/pretty-simple.cabal b/pretty-simple.cabal
index 9be28ab..ecfd38c 100644
--- a/pretty-simple.cabal
+++ b/pretty-simple.cabal
@@ -1,5 +1,5 @@
name: pretty-simple
-version: 3.0.0.0
+version: 3.1.0.0
synopsis: pretty printer for data types with a 'Show' instance.
description: Please see <https://github.com/cdepillabout/pretty-simple#readme README.md>.
homepage: https://github.com/cdepillabout/pretty-simple
@@ -9,12 +9,17 @@ author: Dennis Gosnell
maintainer: cdep.illabout@gmail.com
copyright: 2017-2019 Dennis Gosnell
category: Text
-build-type: Simple
+build-type: Custom
extra-source-files: CHANGELOG.md
, README.md
, img/pretty-simple-example-screenshot.png
cabal-version: >=1.10
+custom-setup
+ setup-depends: base
+ , Cabal
+ , cabal-doctest >=1.0.2
+
flag buildexe
description: Build an small command line program that pretty-print anything from stdin.
default: False
@@ -36,6 +41,7 @@ library
, Text.Pretty.Simple.Internal.OutputPrinter
build-depends: base >= 4.8 && < 5
, ansi-terminal >= 0.6
+ , containers
, mtl >= 2.2
, text >= 1.2
, transformers >= 0.4
@@ -95,8 +101,10 @@ test-suite pretty-simple-doctest
main-is: DocTest.hs
hs-source-dirs: test
build-depends: base
- , doctest
+ , doctest >= 0.13
, Glob
+ , QuickCheck
+ , template-haskell
default-language: Haskell2010
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
diff --git a/src/Text/Pretty/Simple/Internal/Color.hs b/src/Text/Pretty/Simple/Internal/Color.hs
index 3185514..65a3ad1 100644
--- a/src/Text/Pretty/Simple/Internal/Color.hs
+++ b/src/Text/Pretty/Simple/Internal/Color.hs
@@ -46,7 +46,7 @@ data ColorOptions = ColorOptions
, colorError :: Builder
-- ^ (currently not used)
, colorNum :: Builder
- -- ^ (currently not used)
+ -- ^ Color to use for numbers.
, colorRainbowParens :: [Builder]
-- ^ A list of 'Builder' colors to use for rainbow parenthesis output. Use
-- '[]' if you don't want rainbow parenthesis. Use just a single item if you
diff --git a/src/Text/Pretty/Simple/Internal/Expr.hs b/src/Text/Pretty/Simple/Internal/Expr.hs
index a8773bc..5fb3b6f 100644
--- a/src/Text/Pretty/Simple/Internal/Expr.hs
+++ b/src/Text/Pretty/Simple/Internal/Expr.hs
@@ -36,5 +36,11 @@ data Expr
| Braces !(CommaSeparated [Expr])
| Parens !(CommaSeparated [Expr])
| StringLit !String
+ | NumberLit !String
+ -- ^ We could store this as a 'Rational', say, instead of a 'String'.
+ -- However, we will never need to use its value for anything. Indeed, the
+ -- only thing we will be doing with it is turning it /back/ into a string
+ -- at some stage, so we might as well cut out the middle man and store it
+ -- directly like this.
| Other !String
deriving (Data, Eq, Generic, Show, Typeable)
diff --git a/src/Text/Pretty/Simple/Internal/ExprParser.hs b/src/Text/Pretty/Simple/Internal/ExprParser.hs
index 7a94db5..af7e5e0 100644
--- a/src/Text/Pretty/Simple/Internal/ExprParser.hs
+++ b/src/Text/Pretty/Simple/Internal/ExprParser.hs
@@ -20,9 +20,15 @@ module Text.Pretty.Simple.Internal.ExprParser
import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))
import Control.Arrow (first)
+import Data.Char (isAlpha, isDigit)
-testString1, testString2 :: String
+-- | 'testString1' and 'testString2' are convenient to use in GHCi when playing
+-- around with how parsing works.
+testString1 :: String
testString1 = "Just [TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}, TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}]"
+
+-- | See 'testString1'.
+testString2 :: String
testString2 = "some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)"
expressionParse :: String -> [Expr]
@@ -33,8 +39,15 @@ parseExpr ('(':rest) = first (Parens . CommaSeparated) $ parseCSep ')' rest
parseExpr ('[':rest) = first (Brackets . CommaSeparated) $ parseCSep ']' rest
parseExpr ('{':rest) = first (Braces . CommaSeparated) $ parseCSep '}' rest
parseExpr ('"':rest) = first StringLit $ parseStringLit rest
+parseExpr (c:rest) | isDigit c = first NumberLit $ parseNumberLit c rest
parseExpr other = first Other $ parseOther other
+-- |
+--
+-- Handle escaped characters correctly
+--
+-- >>> parseExprs $ "Foo \"hello \\\"world!\""
+-- ([Other "Foo ",StringLit "hello \\\"world!"],"")
parseExprs :: String -> ([Expr], String)
parseExprs [] = ([], "")
parseExprs s@(c:_)
@@ -63,11 +76,70 @@ parseStringLit ('\\':c:cs) = ('\\':c:cs', rest)
parseStringLit (c:cs) = (c:cs', rest)
where (cs', rest) = parseStringLit cs
-parseOther :: String -> (String, String)
-parseOther = span . flip notElem $ ("{[()]}\"," :: String)
+-- | Parses integers and reals, like @123@ and @45.67@.
+--
+-- To be more precise, any numbers matching the regex @\\d+(\\.\\d+)?@ should
+-- get parsed by this function.
+--
+-- >>> parseNumberLit '3' "456hello world []"
+-- ("3456","hello world []")
+-- >>> parseNumberLit '0' ".12399880 foobar"
+-- ("0.12399880"," foobar")
+parseNumberLit :: Char -> String -> (String, String)
+parseNumberLit firstDigit rest1 =
+ case rest2 of
+ [] -> (firstDigit:remainingDigits, "")
+ '.':rest3 ->
+ let (digitsAfterDot, rest4) = span isDigit rest3
+ in ((firstDigit : remainingDigits) ++ ('.' : digitsAfterDot), rest4)
+ _ -> (firstDigit:remainingDigits, rest2)
+ where
+ remainingDigits :: String
+ rest2 :: String
+ (remainingDigits, rest2) = span isDigit rest1
--- |
--- Handle escaped characters correctly
+-- | This function consumes input, stopping only when it hits a special
+-- character or a digit. However, if the digit is in the middle of a
+-- Haskell-style identifier (e.g. @foo123@), then keep going
+-- anyway.
--
--- >>> parseExprs $ "Foo \"hello \\\"world!\""
--- ([Other "Foo ",StringLit "hello \\\"world!"],"")
+-- This is almost the same as the function
+--
+-- > parseOtherSimple = span $ \c ->
+-- > notElem c ("{[()]}\"," :: String) && not (isDigit c)
+--
+-- except 'parseOther' ignores digits that appear in Haskell-like identifiers.
+--
+-- >>> parseOther "hello world []"
+-- ("hello world ","[]")
+-- >>> parseOther "hello234 world"
+-- ("hello234 world","")
+-- >>> parseOther "hello 234 world"
+-- ("hello ","234 world")
+-- >>> parseOther "hello{[ 234 world"
+-- ("hello","{[ 234 world")
+-- >>> parseOther "H3110 World"
+-- ("H3110 World","")
+parseOther :: String -> (String, String)
+parseOther = go False
+ where
+ go
+ :: Bool
+ -- ^ in an identifier?
+ -> String
+ -> (String, String)
+ go _ [] = ("", "")
+ go insideIdent cs@(c:cs')
+ | c `elem` ("{[()]}\"," :: String) = ("", cs)
+ | isDigit c && not insideIdent = ("", cs)
+ | insideIdent = first (c :) (go (isIdentRest c) cs')
+ | otherwise = first (c :) (go (isIdentBegin c) cs')
+
+ isIdentBegin :: Char -> Bool
+ isIdentBegin '_' = True
+ isIdentBegin c = isAlpha c
+
+ isIdentRest :: Char -> Bool
+ isIdentRest '_' = True
+ isIdentRest '\'' = True
+ isIdentRest c = isAlpha c || isDigit c
diff --git a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs
index 5d8f038..859df9c 100644
--- a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs
+++ b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs
@@ -38,7 +38,9 @@ import GHC.Generics (Generic)
import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))
import Text.Pretty.Simple.Internal.Output
(NestLevel(..), Output(..), OutputType(..), unNestLevel)
+
-- $setup
+-- >>> :set -XOverloadedStrings
-- >>> import Control.Monad.State (State)
-- >>> :{
-- let test :: PrinterState -> State PrinterState [Output] -> [Output]
@@ -225,6 +227,10 @@ putExpression (StringLit string) = do
nest <- gets nestLevel
when (nest < 0) $ addToNestLevel 1
addOutputs [OutputStringLit string, OutputOther " "]
+putExpression (NumberLit integer) = do
+ nest <- gets nestLevel
+ when (nest < 0) $ addToNestLevel 1
+ (:[]) <$> (addOutput $ OutputNumberLit integer)
putExpression (Other string) = do
nest <- gets nestLevel
when (nest < 0) $ addToNestLevel 1
diff --git a/src/Text/Pretty/Simple/Internal/Output.hs b/src/Text/Pretty/Simple/Internal/Output.hs
index 6904402..f38ade8 100644
--- a/src/Text/Pretty/Simple/Internal/Output.hs
+++ b/src/Text/Pretty/Simple/Internal/Output.hs
@@ -70,11 +70,13 @@ data OutputType
-- of the other tokens.
| OutputStringLit !String
-- ^ This represents a string literal. For instance, @\"foobar\"@.
+ | OutputNumberLit !String
+ -- ^ This represents a numeric literal. For example, @12345@ or @3.14159@.
deriving (Data, Eq, Generic, Read, Show, Typeable)
-- | 'IsString' (and 'fromString') should generally only be used in tests and
--- debugging. There is no way to represent 'OutputIndent' and
--- 'OutputStringLit'.
+-- debugging. There is no way to represent 'OutputIndent', 'OutputNumberLit'
+-- and 'OutputStringLit'.
instance IsString OutputType where
fromString :: String -> OutputType
fromString "}" = OutputCloseBrace
diff --git a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs
index 51d859d..36137b1 100644
--- a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs
+++ b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs
@@ -148,6 +148,12 @@ renderOutput (Output _ (OutputOther string)) = do
let spaces = replicate (indentSpaces + 2) ' '
-- TODO: This probably shouldn't be a string to begin with.
pure $ fromString $ indentSubsequentLinesWith spaces string
+renderOutput (Output _ (OutputNumberLit number)) = do
+ sequenceFold
+ [ useColorNum
+ , pure (fromString number)
+ , useColorReset
+ ]
renderOutput (Output _ (OutputStringLit string)) = do
options <- ask
diff --git a/test/DocTest.hs b/test/DocTest.hs
index b60f775..93f7655 100644
--- a/test/DocTest.hs
+++ b/test/DocTest.hs
@@ -1,40 +1,12 @@
+module Main where
-module Main (main) where
-
-import Prelude
-
-import Data.Monoid ((<>))
-import System.FilePath.Glob (glob)
+import Build_doctests (flags, pkgs, module_sources)
+-- import Data.Foldable (traverse_)
import Test.DocTest (doctest)
main :: IO ()
-main = glob "src/**/*.hs" >>= doDocTest
-
-doDocTest :: [String] -> IO ()
-doDocTest options = doctest $ options <> ghcExtensions
-
-ghcExtensions :: [String]
-ghcExtensions =
- [
- -- "-XConstraintKinds"
- -- , "-XDataKinds"
- "-XDeriveDataTypeable"
- , "-XDeriveGeneric"
- -- , "-XEmptyDataDecls"
- , "-XFlexibleContexts"
- -- , "-XFlexibleInstances"
- -- , "-XGADTs"
- -- , "-XGeneralizedNewtypeDeriving"
- -- , "-XInstanceSigs"
- -- , "-XMultiParamTypeClasses"
- -- , "-XNoImplicitPrelude"
- , "-XOverloadedStrings"
- -- , "-XPolyKinds"
- -- , "-XRankNTypes"
- -- , "-XRecordWildCards"
- , "-XScopedTypeVariables"
- -- , "-XStandaloneDeriving"
- -- , "-XTupleSections"
- -- , "-XTypeFamilies"
- -- , "-XTypeOperators"
- ]
+main = do
+ -- traverse_ putStrLn args
+ doctest args
+ where
+ args = flags ++ pkgs ++ module_sources