pretty-simple 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+799/−391 lines, 11 filesdep +ansi-terminalPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal

API changes (from Hackage documentation)

Files

• README.md +3/−2
• pretty-simple.cabal +7/−3
• src/Text/Pretty/Simple.hs +19/−4
• src/Text/Pretty/Simple/Internal.hs +18/−0
• src/Text/Pretty/Simple/Internal/Expr.hs +1/−1
• src/Text/Pretty/Simple/Internal/ExprParser.hs +158/−0
• src/Text/Pretty/Simple/Internal/ExprToOutput.hs +260/−0
• src/Text/Pretty/Simple/Internal/Output.hs +97/−0
• src/Text/Pretty/Simple/Internal/OutputPrinter.hs +236/−0
• src/Text/Pretty/Simple/Internal/Parser.hs +0/−158
• src/Text/Pretty/Simple/Internal/Printer.hs +0/−223

@@ -1,11 +1,12 @@ -Control.FromSum-===============+Text.Pretty.Simple+==================  [![Build Status](https://secure.travis-ci.org/cdepillabout/pretty-simple.svg)](http://travis-ci.org/cdepillabout/pretty-simple) [![Hackage](https://img.shields.io/hackage/v/pretty-simple.svg)](https://hackage.haskell.org/package/pretty-simple) [![Stackage LTS](http://stackage.org/package/pretty-simple/badge/lts)](http://stackage.org/lts/package/pretty-simple) [![Stackage Nightly](http://stackage.org/package/pretty-simple/badge/nightly)](http://stackage.org/nightly/package/pretty-simple)+![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)  TODO 

@@ -1,5 +1,5 @@ name:                pretty-simple-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Simple pretty printer for any datatype with a 'Show' instance. description:         Please see README.md homepage:            https://github.com/cdepillabout/pretty-simple@@ -16,10 +16,14 @@ library   hs-source-dirs:      src   exposed-modules:     Text.Pretty.Simple+                     , Text.Pretty.Simple.Internal                      , Text.Pretty.Simple.Internal.Expr-                     , Text.Pretty.Simple.Internal.Parser-                     , Text.Pretty.Simple.Internal.Printer+                     , Text.Pretty.Simple.Internal.ExprParser+                     , Text.Pretty.Simple.Internal.ExprToOutput+                     , Text.Pretty.Simple.Internal.Output+                     , Text.Pretty.Simple.Internal.OutputPrinter   build-depends:       base >= 4.6 && < 5+                     , ansi-terminal                      , lens                      , mono-traversable                      , mtl

@@ -31,8 +31,9 @@  import Control.Monad.IO.Class (MonadIO, liftIO) -import Text.Pretty.Simple.Internal.Parser (expressionParse)-import Text.Pretty.Simple.Internal.Printer (expressionPrint)+import Text.Pretty.Simple.Internal+       (defaultOutputOptions, expressionParse, expressionsToOutputs,+        render)  pPrint :: (MonadIO m, Show a) => a -> m () pPrint = liftIO . putStrLn . pShow@@ -42,8 +43,10 @@  pString :: String -> String pString string =-  either (const string) expressionPrint $ expressionParse string-+  case expressionParse string of+    Left _ -> string+    Right expressions ->+      render defaultOutputOptions $ expressionsToOutputs expressions  -- $examples -- Simple Haskell datatype:@@ -98,5 +101,17 @@ --     , barList = --         [ Foo 1.1 "" --         , Foo 2.2 "hello"+--         ]+--     }+--+-- Newtype:+--+-- >>> newtype Baz = Baz { unBaz :: [String] } deriving Show+--+-- >>> pPrint $ Baz ["hello", "bye"]+-- Baz+--     { unBaz =+--         [ "hello"+--         , "bye" --         ] --     }

@@ -0,0 +1,18 @@+{-|+Module      : Text.Pretty.Simple.Internal+Copyright   : (c) Dennis Gosnell, 2016+License     : BSD-style (see LICENSE file)+Maintainer  : cdep.illabout@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Text.Pretty.Simple.Internal+  ( module X+  ) where++import Text.Pretty.Simple.Internal.ExprParser as X+import Text.Pretty.Simple.Internal.Expr as X+import Text.Pretty.Simple.Internal.ExprToOutput as X+import Text.Pretty.Simple.Internal.Output as X+import Text.Pretty.Simple.Internal.OutputPrinter as X

@@ -7,7 +7,7 @@ {-# LANGUAGE TemplateHaskell #-}  {-|-Module      : Text.Pretty.Simple.Expr+Module      : Text.Pretty.Simple.Internal.Expr Copyright   : (c) Dennis Gosnell, 2016 License     : BSD-style (see LICENSE file) Maintainer  : cdep.illabout@gmail.com

@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-|+Module      : Text.Pretty.Simple.Internal.ExprParser+Copyright   : (c) Dennis Gosnell, 2016+License     : BSD-style (see LICENSE file)+Maintainer  : cdep.illabout@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Text.Pretty.Simple.Internal.ExprParser+  where++#if __GLASGOW_HASKELL__ < 710+-- We don't need this import for GHC 7.10 as it exports all required functions+-- from Prelude+import Control.Applicative+#endif++import Control.Applicative ((<|>))+import Data.Functor.Identity (Identity)+import Text.Parsec+       (Parsec, ParseError, between, char, many, noneOf, parserFail,+        runParser)+import Text.Parsec.Language (haskellDef)+import qualified Text.Parsec.Token as Token++import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))++-- $setup+-- >>> import Data.Either (isLeft)+-- >>> :{+-- let test :: Parser a -> String -> Either ParseError a+--     test parser = runParser parser () "(no source)"+-- :}++type Parser = Parsec String ()++----------------------------+-- Lexer helper functions --+----------------------------++lexer :: Token.GenTokenParser String u Identity+lexer = Token.makeTokenParser haskellDef++stringLiteral :: Parser String+stringLiteral = Token.stringLiteral lexer++brackets :: Parser a -> Parser a+brackets = between (char '[') (char ']')++braces :: Parser a -> Parser a+braces = between (char '{') (char '}')++parens :: Parser a -> Parser a+parens = between (char '(') (char ')')++commaSep :: Parser a -> Parser [a]+commaSep = Token.commaSep lexer++lexeme :: Parser a -> Parser a+lexeme = Token.lexeme lexer++------------+-- Parser --+------------++expr :: Parser [Expr]+expr = many expr'++expr' :: Parser Expr+expr' = recursiveExpr <|> nonRecursiveExpr++-- | Parse brackets around a list of expressions.+--+-- >>> test bracketsExpr "[hello\"what\", foo]"+-- Right (Brackets (CommaSeparated {unCommaSeparated = [[Other "hello",StringLit "what"],[Other "foo"]]}))+-- >>> test bracketsExpr "[[] ]"+-- Right (Brackets (CommaSeparated {unCommaSeparated = [[Brackets (CommaSeparated {unCommaSeparated = []}),Other " "]]}))+bracketsExpr :: Parser Expr+bracketsExpr = Brackets <$> recursiveSurroundingExpr brackets++bracesExpr :: Parser Expr+bracesExpr = Braces <$> recursiveSurroundingExpr braces++parensExpr :: Parser Expr+parensExpr = Parens <$> recursiveSurroundingExpr parens++recursiveSurroundingExpr :: (forall a. Parser a -> Parser a)+                         -> Parser (CommaSeparated [Expr])+recursiveSurroundingExpr surround = do+  res <- surround (commaSep expr)+  case res of+      [[]] -> pure $ CommaSeparated []+      [] -> pure $ CommaSeparated []+      _ -> pure $ CommaSeparated res++recursiveExpr :: Parser Expr+recursiveExpr = do+  bracketsExpr <|> parensExpr <|> bracesExpr++-- | Parse a string literal.+--+-- >>> test stringLiteralExpr "\"hello\""+-- Right (StringLit "hello")+--+-- >>> isLeft $ test stringLiteralExpr " \"hello\""+-- True+stringLiteralExpr :: Parser Expr+stringLiteralExpr = StringLit <$> stringLiteral++nonRecursiveExpr :: Parser Expr+nonRecursiveExpr = do+  stringLiteralExpr <|> anyOtherText++-- | Parse anything that doesn't get parsed by the parsers above.+--+-- >>> test anyOtherText " Foo "+-- Right (Other " Foo ")+--+-- Parse empty strings.+--+-- >>> test anyOtherText " "+-- Right (Other " ")+--+-- Stop parsing if we hit @\[@, @\]@, @\(@, @\)@, @\{@, @\}@, @\"@, or @,@.+--+-- >>> test anyOtherText "hello["+-- Right (Other "hello")+--+-- Don\'t parse the empty string.+--+-- >>> isLeft $ test anyOtherText ""+-- True+-- >>> isLeft $ test anyOtherText ","+-- True+anyOtherText :: Parser Expr+anyOtherText = do+  res <- many (Text.Parsec.noneOf "[](){},\"")+  case res of+    "" ->+      parserFail+        "Trying to apply anyOtherText to an empty string.  This doesn't work."+    _ -> pure $ Other res++testString1, testString2 :: 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\"})}]"+testString2 = "some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)"++expressionParse :: String -> Either ParseError [Expr]+expressionParse = runParser expr () "(no source)"

@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module      : Text.Pretty.Simple.Internal.Printer+Copyright   : (c) Dennis Gosnell, 2016+License     : BSD-style (see LICENSE file)+Maintainer  : cdep.illabout@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Text.Pretty.Simple.Internal.ExprToOutput+  where++#if __GLASGOW_HASKELL__ < 710+-- We don't need this import for GHC 7.10 as it exports all required functions+-- from Prelude+import Control.Applicative+#endif++import Control.Lens ((<>=), (+=), (-=), use, view)+import Control.Lens.TH (makeLenses)+import Control.Monad (when)+import Control.Monad.State (MonadState, execState)+import Data.Data (Data)+import Data.Foldable (traverse_)+import Data.Monoid ((<>))+import Data.Sequences (intersperse)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))+import Text.Pretty.Simple.Internal.Output+       (NestLevel(..), Output(..), OutputType(..), unNestLevel)++-- $setup+-- >>> import Control.Monad.State (State)+-- >>> :{+-- let test :: PrinterState -> State PrinterState a -> PrinterState+--     test initState state = execState state initState+--     testInit :: State PrinterState a -> PrinterState+--     testInit = test initPrinterState+-- :}++-- | Newtype around 'Int' to represent a line number.  After a newline, the+-- 'LineNum' will increase by 1.+newtype LineNum = LineNum { unLineNum :: Int }+  deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable)+makeLenses ''LineNum++data PrinterState = PrinterState+  { _currLine :: LineNum+  , _nestLevel :: NestLevel+  , _outputList :: [Output]+  } deriving (Eq, Data, Generic, Show, Typeable)+makeLenses ''PrinterState++-- | Smart-constructor for 'PrinterState'.+printerState :: LineNum -> NestLevel -> [Output] -> PrinterState+printerState currLineNum nestNum output =+  PrinterState+  { _currLine = currLineNum+  , _nestLevel = nestNum+  , _outputList = output+  }++addOutput+  :: MonadState PrinterState m+  => OutputType -> m ()+addOutput outputType = do+  nest <- use nestLevel+  let output = Output nest outputType+  outputList <>= [output]++addOutputs+  :: MonadState PrinterState m+  => [OutputType] -> m ()+addOutputs outputTypes = do+  nest <- use nestLevel+  let outputs = Output nest <$> outputTypes+  outputList <>= outputs++initPrinterState :: PrinterState+initPrinterState = printerState 0 (-1) []++-- | Print a surrounding expression (like @\[\]@ or @\{\}@ or @\(\)@).+--+-- If the 'CommaSeparated' expressions are empty, just print the start and end+-- markers.+--+-- >>> testInit $ putSurroundExpr "[" "]" (CommaSeparated [])+-- PrinterState {_currLine = LineNum {unLineNum = 0}, _nestLevel = NestLevel {_unNestLevel = -1}, _outputList = [Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOpenBracket},Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputCloseBracket}]}+--+-- If there is only one expression, and it will print out on one line, then+-- just print everything all on one line, with spaces around the expressions.+--+-- >>> testInit $ putSurroundExpr "{" "}" (CommaSeparated [[Other "hello"]])+-- PrinterState {_currLine = LineNum {unLineNum = 0}, _nestLevel = NestLevel {_unNestLevel = -1}, _outputList = [Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOpenBrace},Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOther "hello"},Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputCloseBrace}]}+--+-- If there is only one expression, but it will print out on multiple lines,+-- then go to newline and print out on multiple lines.+--+-- >>> 1 + 1  -- TODO: Example here.+-- 2+--+-- If there are multiple expressions, then first go to a newline.+-- Print out on multiple lines.+--+-- >>> 1 + 1  -- TODO: Example here.+-- 2+putSurroundExpr+  :: MonadState PrinterState m+  => OutputType+  -> OutputType+  -> CommaSeparated [Expr] -- ^ comma separated inner expression.+  -> m ()+putSurroundExpr startOutputType endOutputType (CommaSeparated []) = do+  nestLevel += 1+  addOutputs [startOutputType, endOutputType]+  nestLevel -= 1+putSurroundExpr startOutputType endOutputType (CommaSeparated [exprs]) = do+  nestLevel += 1+  let isExprsMultiLine = howManyLines exprs > 1+  when isExprsMultiLine $ do+      newLineAndDoIndent+  addOutputs [startOutputType, OutputOther " "]+  traverse_ putExpression exprs+  if isExprsMultiLine+    then do+      newLineAndDoIndent+    else addOutput $ OutputOther " "+  addOutput endOutputType+  nestLevel -= 1+putSurroundExpr startOutputType endOutputType commaSeparated = do+  nestLevel += 1+  newLineAndDoIndent+  addOutputs [startOutputType, OutputOther " "]+  putCommaSep commaSeparated+  newLineAndDoIndent+  addOutput endOutputType+  nestLevel -= 1+  addOutput $ OutputOther " "++putCommaSep+  :: forall m.+     MonadState PrinterState m+  => CommaSeparated [Expr] -> m ()+putCommaSep (CommaSeparated expressionsList) =+  sequence_ $ intersperse putComma evaledExpressionList+  where+    evaledExpressionList :: [m ()]+    evaledExpressionList =+      traverse_ putExpression <$> expressionsList++putComma+  :: MonadState PrinterState m+  => m ()+putComma = do+  newLineAndDoIndent+  addOutputs [OutputComma, OutputOther " "]++howManyLines :: [Expr] -> LineNum+howManyLines = view currLine . runInitPrinterState++doIndent :: MonadState PrinterState m => m ()+doIndent = do+  nest <- use $ nestLevel . unNestLevel+  addOutputs $ replicate nest OutputIndent++newLine+  :: MonadState PrinterState m+  => m ()+newLine = do+  addOutput OutputNewLine+  currLine += 1++newLineAndDoIndent+  :: MonadState PrinterState m+  => m ()+newLineAndDoIndent = newLine >> doIndent++putExpression :: MonadState PrinterState m => Expr -> m ()+putExpression (Brackets commaSeparated) = do+  putSurroundExpr OutputOpenBracket OutputCloseBracket commaSeparated+putExpression (Braces commaSeparated) = do+  putSurroundExpr OutputOpenBrace OutputCloseBrace commaSeparated+putExpression (Parens commaSeparated) = do+  putSurroundExpr OutputOpenParen OutputCloseParen commaSeparated+putExpression (StringLit string) = do+  nest <- use nestLevel+  when (nest < 0) $ nestLevel += 1+  addOutput $ OutputStringLit string+putExpression (Other string) = do+  nest <- use nestLevel+  when (nest < 0) $ nestLevel += 1+  addOutput $ OutputOther string++runPrinterState :: PrinterState -> [Expr] -> PrinterState+runPrinterState initState expressions =+  execState (traverse_ putExpression expressions) initState++runInitPrinterState :: [Expr] -> PrinterState+runInitPrinterState = runPrinterState initPrinterState++expressionsToOutputs :: [Expr] -> [Output]+expressionsToOutputs =+  view outputList . runInitPrinterState . modificationsExprList++-- | A function that performs optimizations and modifications to a list of+-- input 'Expr's.+--+-- An sample of an optimization is 'removeEmptyInnerCommaSeparatedExprList'+-- which removes empty inner lists in a 'CommaSeparated' value.+modificationsExprList :: [Expr] -> [Expr]+modificationsExprList = removeEmptyInnerCommaSeparatedExprList++removeEmptyInnerCommaSeparatedExprList :: [Expr] -> [Expr]+removeEmptyInnerCommaSeparatedExprList = fmap removeEmptyInnerCommaSeparatedExpr++removeEmptyInnerCommaSeparatedExpr :: Expr -> Expr+removeEmptyInnerCommaSeparatedExpr (Brackets commaSeparated) =+  Brackets $ removeEmptyInnerCommaSeparated commaSeparated+removeEmptyInnerCommaSeparatedExpr (Braces commaSeparated) =+  Braces $ removeEmptyInnerCommaSeparated commaSeparated+removeEmptyInnerCommaSeparatedExpr (Parens commaSeparated) =+  Parens $ removeEmptyInnerCommaSeparated commaSeparated+removeEmptyInnerCommaSeparatedExpr other = other++removeEmptyInnerCommaSeparated :: CommaSeparated [Expr] -> CommaSeparated [Expr]+removeEmptyInnerCommaSeparated (CommaSeparated commaSeps) =+  CommaSeparated . fmap removeEmptyInnerCommaSeparatedExprList $+  removeEmptyList commaSeps++-- | Remove empty lists from a list of lists.+--+-- >>> removeEmptyList [[1,2,3], [], [4,5]]+-- [[1,2,3],[4,5]]+--+-- >>> removeEmptyList [[]]+-- []+--+-- >>> removeEmptyList [[1]]+-- [[1]]+--+-- >>> removeEmptyList [[1,2], [10,20], [100,200]]+-- [[1,2],[10,20],[100,200]]+removeEmptyList :: forall a . [[a]] -> [[a]]+removeEmptyList = foldl f []+  where+    f :: [[a]] -> [a] -> [[a]]+    f accum [] = accum+    f accum a = accum <> [a]

@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module      : Text.Pretty.Simple.Internal.Output+Copyright   : (c) Dennis Gosnell, 2016+License     : BSD-style (see LICENSE file)+Maintainer  : cdep.illabout@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Text.Pretty.Simple.Internal.Output+  where++#if __GLASGOW_HASKELL__ < 710+-- We don't need this import for GHC 7.10 as it exports all required functions+-- from Prelude+import Control.Applicative+#endif++import Control.Lens.TH (makeLenses)+import Data.Data (Data)+import Data.String (IsString, fromString)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++-- | Datatype representing how much something is nested.+--+-- For example, a 'NestLevel' of 0 would mean an 'Output' token+-- is at the very highest level, not in any braces.+--+-- A 'NestLevel' of 1 would mean that an 'Output' token is in one single pair+-- of @\{@ and @\}@, or @\[@ and @\], or @\(@ and @\)@.+--+-- A 'NestLevel' of 2 would mean that an 'Output' token is two levels of+-- brackets, etc.+newtype NestLevel = NestLevel { _unNestLevel :: Int }+  deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable)+makeLenses ''NestLevel++-- | These are the output tokens that we will be printing to the screen.+data OutputType+  = OutputCloseBrace+  -- ^ This represents the @\}@ character.+  | OutputCloseBracket+  -- ^ This represents the @\]@ character.+  | OutputCloseParen+  -- ^ This represents the @\)@ character.+  | OutputComma+  -- ^ This represents the @\,@ character.+  | OutputIndent+  -- ^ This represents an indentation.+  | OutputNewLine+  -- ^ This represents the @\\n@ character.+  | OutputOpenBrace+  -- ^ This represents the @\{@ character.+  | OutputOpenBracket+  -- ^ This represents the @\[@ character.+  | OutputOpenParen+  -- ^ This represents the @\(@ character.+  | OutputOther !String+  -- ^ This represents some collection of characters that don\'t fit into any+  -- of the other tokens.+  | OutputStringLit !String+  -- ^ This represents a string literal.  For instance, @\"foobar\"@.+  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'.+instance IsString OutputType where+    fromString :: String -> OutputType+    fromString "}" = OutputCloseBrace+    fromString "]" = OutputCloseBracket+    fromString ")" = OutputCloseParen+    fromString "," = OutputComma+    fromString "\n" = OutputNewLine+    fromString "{" = OutputOpenBrace+    fromString "[" = OutputOpenBracket+    fromString "(" = OutputOpenParen+    fromString string = OutputOther string++-- | An 'OutputType' token together with a 'NestLevel'.  Basically, each+-- 'OutputType' keeps track of its own 'NestLevel'.+data Output = Output+  { outputNestLevel :: NestLevel+  , outputOutputType :: OutputType+  } deriving (Data, Eq, Generic, Read, Show, Typeable)

@@ -0,0 +1,236 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-|+Module      : Text.Pretty.Simple.Internal.OutputPrinter+Copyright   : (c) Dennis Gosnell, 2016+License     : BSD-style (see LICENSE file)+Maintainer  : cdep.illabout@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Text.Pretty.Simple.Internal.OutputPrinter+  where++#if __GLASGOW_HASKELL__ < 710+-- We don't need this import for GHC 7.10 as it exports all required functions+-- from Prelude+import Control.Applicative+#endif++import Control.Lens (view)+import Control.Lens.TH (makeLenses)+import Control.Monad.Reader (MonadReader, runReader)+import Data.Data (Data)+import Data.Foldable (fold, foldlM)+import Data.Semigroup ((<>))+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import System.Console.ANSI+       (Color(..), ColorIntensity(..), ConsoleIntensity(..),+        ConsoleLayer(..), SGR(..), setSGRCode)++import Text.Pretty.Simple.Internal.Output+       (NestLevel(..), Output(..), OutputType(..))++-- | 'UseColor' describes whether or not we want to use color when printing the+-- 'Output' list.+data UseColor+  = NoColor+  | UseColor+  deriving (Data, Eq, Generic, Read, Show, Typeable)++-- | Data-type wrapping up all the options available when rendering the list+-- of 'Output's.+data OutputOptions = OutputOptions+  { _indentAmount :: Int+  -- ^ Number of spaces to use when indenting.  It should probably be either 2+  -- or 4.+  , _useColor :: UseColor+  -- ^ Whether or not to use ansi escape sequences to print colors.+  } deriving (Data, Eq, Generic, Read, Show, Typeable)+makeLenses ''OutputOptions++-- | Default values for 'OutputOptions'.  '_indentAmount' defaults to 4, and+-- '_useColor' defaults to 'UseColor'.+defaultOutputOptions :: OutputOptions+defaultOutputOptions = OutputOptions {_indentAmount = 4, _useColor = UseColor}++render :: OutputOptions -> [Output] -> String+render options outputs = runReader (renderOutputs outputs) options++renderOutputs+  :: forall m.+     MonadReader OutputOptions m+  => [Output] -> m String+renderOutputs = foldlM foldFunc "" . modificationsOutputList+  where+    foldFunc :: String -> Output -> m String+    foldFunc accum output = mappend accum <$> renderOutput output++renderRaibowParenFor+  :: MonadReader OutputOptions m+  => NestLevel -> String -> m String+renderRaibowParenFor nest string =+  sequenceFold [rainbowParen nest, pure string, colorReset]++renderOutput :: MonadReader OutputOptions m => Output -> m String+renderOutput (Output nest OutputCloseBrace) = renderRaibowParenFor nest "}"+renderOutput (Output nest OutputCloseBracket) = renderRaibowParenFor nest "]"+renderOutput (Output nest OutputCloseParen) = renderRaibowParenFor nest ")"+renderOutput (Output nest OutputComma) = renderRaibowParenFor nest ","+renderOutput (Output _ OutputIndent) = do+    indentSpaces <- view indentAmount+    pure $ replicate indentSpaces ' '+renderOutput (Output _ OutputNewLine) = pure "\n"+renderOutput (Output nest OutputOpenBrace) = renderRaibowParenFor nest "{"+renderOutput (Output nest OutputOpenBracket) = renderRaibowParenFor nest "["+renderOutput (Output nest OutputOpenParen) = renderRaibowParenFor nest "("+renderOutput (Output _ (OutputOther string)) = pure string+renderOutput (Output _ (OutputStringLit string)) = do+  sequenceFold+    [ colorQuote+    , pure "\""+    , colorString+    , pure string+    , colorQuote+    , pure "\""+    , colorReset+    ]++sequenceFold :: (Monad f, Monoid a, Traversable t) => t (f a) -> f a+sequenceFold = fmap fold . sequence++-- | A function that performs optimizations and modifications to a list of+-- input 'Output's.+--+-- An sample of an optimization is 'removeStartingNewLine' which just removes a+-- newline if it is the first item in an 'Output' list.+modificationsOutputList :: [Output] -> [Output]+modificationsOutputList = shrinkWhitespaceInOthers . compressOthers . removeStartingNewLine++-- | Remove a 'OutputNewLine' if it is the first item in the 'Output' list.+--+-- >>> removeStartingNewLine [Output 3 OutputNewLine, Output 3 OutputComma]+-- [Output {outputNestLevel = NestLevel {_unNestLevel = 3}, outputOutputType = OutputComma}]+removeStartingNewLine :: [Output] -> [Output]+removeStartingNewLine ((Output _ OutputNewLine) : t) = t+removeStartingNewLine outputs = outputs++-- | If there are two subsequent 'OutputOther' tokens, combine them into just+-- one 'OutputOther'.+--+-- >>> compressOthers [Output 0 (OutputOther "foo"), Output 0 (OutputOther "bar")]+-- [Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOther "foobar"}]+compressOthers :: [Output] -> [Output]+compressOthers [] = []+compressOthers (Output _ (OutputOther string1):(Output nest (OutputOther string2)):t) =+  compressOthers ((Output nest (OutputOther (string1 <> string2))) : t)+compressOthers (h:t) = h : compressOthers t++-- | In each 'OutputOther' token, compress multiple whitespaces to just one+-- whitespace.+--+-- >>> shrinkWhitespaceInOthers [Output 0 (OutputOther "  hello  ")]+-- [Output {outputNestLevel = NestLevel {_unNestLevel = 0}, outputOutputType = OutputOther " hello "}]+shrinkWhitespaceInOthers :: [Output] -> [Output]+shrinkWhitespaceInOthers = fmap shrinkWhitespaceInOther++shrinkWhitespaceInOther :: Output -> Output+shrinkWhitespaceInOther (Output nest (OutputOther string)) =+  Output nest . OutputOther $ shrinkWhitespace string+shrinkWhitespaceInOther other = other++shrinkWhitespace :: String -> String+shrinkWhitespace (' ':' ':t) = shrinkWhitespace (' ':t)+shrinkWhitespace (h:t) = h : shrinkWhitespace t+shrinkWhitespace "" = ""++-----------------------+-- High-level colors --+-----------------------++colorQuote :: MonadReader OutputOptions m => m String+colorQuote = appendColors colorBold colorVividWhite++colorString :: MonadReader OutputOptions m => m String+colorString = appendColors colorBold colorVividBlue++colorError :: MonadReader OutputOptions m => m String+colorError = appendColors colorBold colorVividRed++colorNum :: MonadReader OutputOptions m => m String+colorNum = appendColors colorBold colorVividGreen++rainbowParen+  :: forall m.+     MonadReader OutputOptions m+  => NestLevel -> m String+rainbowParen (NestLevel nestLevel) =+  let choicesLen = length rainbowParenChoices+  in rainbowParenChoices !! (nestLevel `mod` choicesLen)+  where+    rainbowParenChoices :: [m String]+    rainbowParenChoices =+        [ appendColors colorBold colorVividMagenta+        , appendColors colorBold colorVividCyan+        , appendColors colorBold colorVividYellow+        ]++----------------------+-- Low-level Colors --+----------------------++canUseColor :: MonadReader OutputOptions m => m Bool+canUseColor = do+  color <- view useColor+  case color of+    NoColor -> pure False+    UseColor -> pure True++ifM :: Monad m => m Bool -> a -> a -> m a+ifM comparisonM thenValue elseValue = do+  res <- comparisonM+  case res of+    True -> pure thenValue+    False -> pure elseValue++colorBold :: MonadReader OutputOptions m => m String+colorBold = ifM canUseColor (setSGRCode [SetConsoleIntensity BoldIntensity]) ""++colorReset :: MonadReader OutputOptions m => m String+colorReset = ifM canUseColor (setSGRCode [Reset]) ""++colorVividBlue :: MonadReader OutputOptions m => m String+colorVividBlue = colorHelper Vivid Blue++colorVividCyan :: MonadReader OutputOptions m => m String+colorVividCyan = colorHelper Vivid Cyan++colorVividGreen :: MonadReader OutputOptions m => m String+colorVividGreen = colorHelper Vivid Green++colorVividMagenta :: MonadReader OutputOptions m => m String+colorVividMagenta = colorHelper Vivid Magenta++colorVividRed :: MonadReader OutputOptions m => m String+colorVividRed = colorHelper Vivid Red++colorVividWhite :: MonadReader OutputOptions m => m String+colorVividWhite = colorHelper Vivid White++colorVividYellow :: MonadReader OutputOptions m => m String+colorVividYellow = colorHelper Vivid Yellow++colorHelper :: MonadReader OutputOptions m => ColorIntensity -> Color -> m String+colorHelper colorIntensity color =+  ifM canUseColor (setSGRCode [SetColor Foreground colorIntensity color]) ""++appendColors :: MonadReader OutputOptions m => m String -> m String -> m String+appendColors color1 color2 = mappend <$> color1 <*> color2

@@ -1,158 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--{-|-Module      : Text.Pretty.Simple.Internal.Parser-Copyright   : (c) Dennis Gosnell, 2016-License     : BSD-style (see LICENSE file)-Maintainer  : cdep.illabout@gmail.com-Stability   : experimental-Portability : POSIX---}-module Text.Pretty.Simple.Internal.Parser-  where--#if __GLASGOW_HASKELL__ < 710--- We don't need this import for GHC 7.10 as it exports all required functions--- from Prelude-import Control.Applicative-#endif--import Control.Applicative ((<|>))-import Data.Functor.Identity (Identity)-import Text.Parsec-       (Parsec, ParseError, between, char, lookAhead, many, noneOf,-        optionMaybe, parserFail, runParser, try)-import Text.Parsec.Language (haskellDef)-import qualified Text.Parsec.Token as Token--import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))---- $setup--- >>> import Data.Either (isLeft)--- >>> :{--- let test :: Parser a -> String -> Either ParseError a---     test parser = runParser parser () "(no source)"--- :}--type Parser = Parsec String ()--------------------------------- Lexer helper functions ---------------------------------lexer :: Token.GenTokenParser String u Identity-lexer = Token.makeTokenParser haskellDef--stringLiteral :: Parser String-stringLiteral = Token.stringLiteral lexer--brackets :: Parser a -> Parser a-brackets = between (char '[') (char ']')--braces :: Parser a -> Parser a-braces = between (char '{') (char '}')--parens :: Parser a -> Parser a-parens = between (char '(') (char ')')--commaSep :: Parser a -> Parser [a]-commaSep = Token.commaSep lexer--lexeme :: Parser a -> Parser a-lexeme = Token.lexeme lexer----------------- Parser -----------------expr :: Parser [Expr]-expr = many expr'--expr' :: Parser Expr-expr' = recursiveExpr <|> nonRecursiveExpr---- | Parse brackets around a list of expressions.------ >>> test bracketsExpr "[hello\"what\", foo]"--- Right (Brackets (CommaSeparated {unCommaSeparated = [[Other "hello",StringLit "what"],[Other "foo"]]}))--- >>> test bracketsExpr "[[] ]"--- Right (Brackets (CommaSeparated {unCommaSeparated = [[Brackets (CommaSeparated {unCommaSeparated = []}),Other " "]]}))-bracketsExpr :: Parser Expr-bracketsExpr = Brackets <$> recursiveSurroundingExpr brackets--bracesExpr :: Parser Expr-bracesExpr = Braces <$> recursiveSurroundingExpr braces--parensExpr :: Parser Expr-parensExpr = Parens <$> recursiveSurroundingExpr parens--recursiveSurroundingExpr :: (forall a. Parser a -> Parser a)-                         -> Parser (CommaSeparated [Expr])-recursiveSurroundingExpr surround = do-  res <- surround (commaSep expr)-  case res of-      [[]] -> pure $ CommaSeparated []-      [] -> pure $ CommaSeparated []-      _ -> pure $ CommaSeparated res--recursiveExpr :: Parser Expr-recursiveExpr = do-  bracketsExpr <|> parensExpr <|> bracesExpr---- | Parse a string literal.------ >>> test stringLiteralExpr "\"hello\""--- Right (StringLit "hello")------ >>> isLeft $ test stringLiteralExpr " \"hello\""--- True-stringLiteralExpr :: Parser Expr-stringLiteralExpr = StringLit <$> stringLiteral--nonRecursiveExpr :: Parser Expr-nonRecursiveExpr = do-  stringLiteralExpr <|> anyOtherText---- | Parse anything that doesn't get parsed by the parsers above.------ >>> test anyOtherText " Foo "--- Right (Other " Foo ")------ Parse empty strings.------ >>> test anyOtherText " "--- Right (Other " ")------ Stop parsing if we hit @\[@, @\]@, @\(@, @\)@, @\{@, @\}@, @\"@, or @,@.------ >>> test anyOtherText "hello["--- Right (Other "hello")------ Don\'t parse the empty string.------ >>> isLeft $ test anyOtherText ""--- True--- >>> isLeft $ test anyOtherText ","--- True-anyOtherText :: Parser Expr-anyOtherText = do-  res <- many (Text.Parsec.noneOf "[](){},\"")-  case res of-    "" ->-      parserFail-        "Trying to apply anyOtherText to an empty string.  This doesn't work."-    _ -> pure $ Other res--testString1, testString2 :: 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\"})}]"-testString2 = "some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)"--expressionParse :: String -> Either ParseError [Expr]-expressionParse = runParser expr () "(no source)"

@@ -1,223 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--{-|-Module      : Text.Pretty.Simple.Internal.Printer-Copyright   : (c) Dennis Gosnell, 2016-License     : BSD-style (see LICENSE file)-Maintainer  : cdep.illabout@gmail.com-Stability   : experimental-Portability : POSIX---}-module Text.Pretty.Simple.Internal.Printer-  where--#if __GLASGOW_HASKELL__ < 710--- We don't need this import for GHC 7.10 as it exports all required functions--- from Prelude-import Control.Applicative-#endif--import Control.Lens (Lens', (%=), (<>=), (.=), (+=), lens, use, view)-import Control.Lens.TH (makeLenses)-import Control.Monad (when)-import Control.Monad.State (MonadState, execState)-import Data.Data (Data)-import Data.Foldable (traverse_)-import Data.MonoTraversable (headEx)-import Data.Semigroup ((<>))-import Data.Sequences (intersperse, tailEx)-import Data.Typeable (Typeable)-import Debug.Trace (traceM)-import GHC.Generics (Generic)--import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))---- $setup--- >>> import Control.Monad.State (State)--- >>> :{--- let test :: PrinterState -> State PrinterState a -> PrinterState---     test initState state = execState state initState---     testInit :: State PrinterState a -> PrinterState---     testInit = test initPrinterState--- :}--data PrinterState = PrinterState-  { _currLine :: Int-  , _currCharOnLine :: Int-  , _indentStack :: [Int]-  , _printerString :: String-  } deriving (Eq, Data, Generic, Show, Typeable)-makeLenses ''PrinterState--printerState :: Int -> Int -> [Int] -> String -> PrinterState-printerState currLineNum currCharNum stack string =-  PrinterState-  { _currLine = currLineNum-  , _currCharOnLine = currCharNum-  , _indentStack = stack-  , _printerString = string-  }--initPrinterState :: PrinterState-initPrinterState = printerState 0 0 [0] ""--_headEx :: Lens' [Int] Int-_headEx = lens headEx f-  where-    f :: [Int] -> Int -> [Int]-    f [] _ = []-    f (_:t) a = a:t---- | This assumes that the indent stack is not empty.-latestIndent :: Lens' PrinterState Int-latestIndent = indentStack . _headEx--popIndent :: MonadState PrinterState m => m ()-popIndent = indentStack %= tailEx--setIndentAtCurrChar-  :: MonadState PrinterState m-  => m ()-setIndentAtCurrChar = do-  currChar <- use currCharOnLine-  indents <- use indentStack-  indentStack .= currChar : indents--putOpeningSymbol :: MonadState PrinterState m => String -> m ()-putOpeningSymbol symbol = do-  setIndentAtCurrChar-  let symbolWithSpace = symbol <> " "-  currCharOnLine += length symbolWithSpace-  printerString <>= symbolWithSpace--putClosingSymbol :: MonadState PrinterState m => String -> m ()-putClosingSymbol symbol = do-  popIndent-  currCharOnLine += length symbol-  printerString <>= symbol--putComma-  :: MonadState PrinterState m-  => m ()-putComma = do-  newLineAndDoIndent-  let symbolWithSpace = ", " :: String-  currCharOnLine += length symbolWithSpace-  printerString <>= symbolWithSpace--putCommaSep-  :: forall m.-     MonadState PrinterState m-  => CommaSeparated [Expr] -> m ()-putCommaSep (CommaSeparated expressionsList) =-  sequence_ $ intersperse putComma evaledExpressionList-  where-    evaledExpressionList :: [m ()]-    evaledExpressionList =-      fmap (traverse_ putExpression) expressionsList--putString :: MonadState PrinterState m => String -> m ()-putString string = do-  currCharOnLine += length string-  printerString <>= string---- | Print a surrounding expression (like @\[\]@ or @\{\}@ or @\(\)@).------ If the 'CommaSeparated' expressions are empty, just print the start and end--- markers.------ >>> testInit $ putSurroundExpr "[" "]" (CommaSeparated [])--- PrinterState {_currLine = 0, _currCharOnLine = 2, _indentStack = [0], _printerString = "[]"}------ >>> let state = printerState 1 5 [5,0] "\nhello"--- >>> test state $ putSurroundExpr "(" ")" (CommaSeparated [[]])--- PrinterState {_currLine = 1, _currCharOnLine = 7, _indentStack = [5,0], _printerString = "\nhello()"}------ If there is only one expression, then just print it it all on one line, with--- spaces around the expressions.------ >>> testInit $ putSurroundExpr "{" "}" (CommaSeparated [[Other "hello", Other "bye"]])--- PrinterState {_currLine = 0, _currCharOnLine = 12, _indentStack = [0], _printerString = "{ hellobye }"}------ If there are multiple expressions, and this is indent level 0, then print--- out normally and put each expression on a different line with a comma.--- No indentation happens.------ >>> comma = [[Other "hello"], [Other "bye"]]--- >>> testInit $ putSurroundExpr "[" "]" (CommaSeparated comma)--- PrinterState {_currLine = 2, _currCharOnLine = 1, _indentStack = [0], _printerString = "[ hello\n, bye\n]"}---- If there are multiple expressions, and this is not the first thing on the--- line, then first go to a new line, indent, then continue to print out--- normally like above.------ >>> comma = [[Other "foo"], [Other "bar"]]--- >>> state = printerState 5 [0] "hello"--- >>> test $ putSurroundExpr "{" "}" (CommaSeparated comma)--- PrinterState {_currLine = 3, _currCharOnLine = 4, _indentStack = [0], _printerString = "hello\n    [ foo\n    , bar\n    ]"}-putSurroundExpr-  :: MonadState PrinterState m-  => String -- ^ starting character (@\[@ or @\{@ or @\(@)-  -> String -- ^ ending character (@\]@ or @\}@ or @\)@)-  -> CommaSeparated [Expr] -- ^ comma separated inner expression.-  -> m ()-putSurroundExpr startMarker endMarker (CommaSeparated []) =-  putString $ startMarker <> endMarker-putSurroundExpr startMarker endMarker (CommaSeparated [[]]) =-  putString $ startMarker <> endMarker-putSurroundExpr startMarker endMarker (CommaSeparated [exprs]) = do-  putString $ startMarker <> " "-  startingLineNum <- use currLine-  traverse_ putExpression exprs-  endingLineNum <- use currLine-  if endingLineNum > startingLineNum-    then do-      newLineAndDoIndent-      putString endMarker-    else putString $ " " <> endMarker-putSurroundExpr startMarker endMarker commaSeparated = do-  charOnLine <- use currCharOnLine-  when (charOnLine /= 0) $ do-    newLineAndDoIndent-    putString "    "-  putOpeningSymbol startMarker-  putCommaSep commaSeparated-  newLineAndDoIndent-  putClosingSymbol endMarker--doIndent :: MonadState PrinterState m => m ()-doIndent = do-  indent <- use latestIndent-  currCharOnLine .= indent-  printerString <>= replicate indent ' '--newLine-  :: MonadState PrinterState m-  => m ()-newLine = do-  printerString <>= "\n"-  currCharOnLine .= 0-  currLine += 1--newLineAndDoIndent-  :: MonadState PrinterState m-  => m ()-newLineAndDoIndent = newLine >> doIndent--putExpression :: MonadState PrinterState m => Expr -> m ()-putExpression (Brackets commaSeparated) = putSurroundExpr "[" "]" commaSeparated-putExpression (Braces commaSeparated) = putSurroundExpr "{" "}" commaSeparated-putExpression (Parens commaSeparated) = putSurroundExpr "(" ")" commaSeparated-putExpression (StringLit string) = putString $ "\"" <> string <> "\""-putExpression (Other string) = putString string--expressionPrint :: [Expr] -> String-expressionPrint expressions =-  view printerString $ execState (traverse putExpression expressions) initPrinterState