packages feed

pretty-simple (empty) → 0.1.0.0

raw patch · 9 files changed

+654/−0 lines, 9 filesdep +Globdep +basedep +doctestsetup-changed

Dependencies added: Glob, base, doctest, lens, mono-traversable, mtl, parsec, semigroups, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dennis Gosnell (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.
+ README.md view
@@ -0,0 +1,14 @@++Control.FromSum+===============++[![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)++TODO++## Usage++TODO
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pretty-simple.cabal view
@@ -0,0 +1,45 @@+name:                pretty-simple+version:             0.1.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+license:             BSD3+license-file:        LICENSE+author:              Dennis Gosnell+maintainer:          cdep.illabout@gmail.com+copyright:           2016 Dennis Gosnell+category:            Text+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Text.Pretty.Simple+                     , Text.Pretty.Simple.Internal.Expr+                     , Text.Pretty.Simple.Internal.Parser+                     , Text.Pretty.Simple.Internal.Printer+  build-depends:       base >= 4.6 && < 5+                     , lens+                     , mono-traversable+                     , mtl+                     , parsec+                     , semigroups+                     , transformers+  default-language:    Haskell2010+  ghc-options:         -Wall+  other-extensions:    TemplateHaskell++test-suite pretty-simple-doctest+  type:                exitcode-stdio-1.0+  main-is:             DocTest.hs+  hs-source-dirs:      test+  build-depends:       base+                     , doctest+                     , Glob+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++source-repository head+  type:     git+  location: git@github.com:cdepillabout/pretty-simple.git
+ src/Text/Pretty/Simple.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-|+Module      : Text.Pretty.Simple+Copyright   : (c) Dennis Gosnell, 2016+License     : BSD-style (see LICENSE file)+Maintainer  : cdep.illabout@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Text.Pretty.Simple+  ( pShow+  , pPrint+  , pString+  -- * Examples+  -- $examples+  ) 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.Monad.IO.Class (MonadIO, liftIO)++import Text.Pretty.Simple.Internal.Parser (expressionParse)+import Text.Pretty.Simple.Internal.Printer (expressionPrint)++pPrint :: (MonadIO m, Show a) => a -> m ()+pPrint = liftIO . putStrLn . pShow++pShow :: Show a => a -> String+pShow = pString . show++pString :: String -> String+pString string =+  either (const string) expressionPrint $ expressionParse string+++-- $examples+-- Simple Haskell datatype:+--+-- >>> data Foo a = Foo a String deriving Show+--+-- >>> pPrint $ Foo 3 "hello"+-- Foo 3 "hello"+--+-- Lists:+--+-- >>> pPrint $ [1,2,3]+-- [ 1+-- , 2+-- , 3+-- ]+--+-- Slightly more complicated lists:+--+-- >>> pPrint $ [ Foo [ (),    () ] "hello" ]+-- [ Foo+--     [ ()+--     , ()+--     ] "hello"+-- ]+--+-- >>> pPrint $ [ Foo [ "bar", "baz" ] "hello", Foo [] "bye" ]+-- [ Foo+--     [ "bar"+--     , "baz"+--     ] "hello"+-- , Foo [] "bye"+-- ]+--+-- Record:+--+-- >>> :{+-- data Bar b = Bar+--   { barInt :: Int+--   , barA :: b+--   , barList :: [Foo Double]+--   } deriving Show+-- :}+--+-- >>> pPrint $ Bar 1 [10, 11] [Foo 1.1 "", Foo 2.2 "hello"]+-- Bar+--     { barInt = 1+--     , barA =+--         [ 10+--         , 11+--         ]+--     , barList =+--         [ Foo 1.1 ""+--         , Foo 2.2 "hello"+--         ]+--     }
+ src/Text/Pretty/Simple/Internal/Expr.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-|+Module      : Text.Pretty.Simple.Expr+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.Expr+  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 Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++newtype CommaSeparated a = CommaSeparated { unCommaSeparated :: [a] }+  deriving (Data, Eq, Generic, Show, Typeable)++data Expr+  = Brackets !(CommaSeparated [Expr])+  | Braces !(CommaSeparated [Expr])+  | Parens !(CommaSeparated [Expr])+  | StringLit !String+  | Other !String+  deriving (Data, Eq, Generic, Show, Typeable)
+ src/Text/Pretty/Simple/Internal/Parser.hs view
@@ -0,0 +1,158 @@+{-# 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)"
+ src/Text/Pretty/Simple/Internal/Printer.hs view
@@ -0,0 +1,223 @@+{-# 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
+ test/DocTest.hs view
@@ -0,0 +1,40 @@++module Main (main) where++import Prelude++import Data.Monoid ((<>))+import System.FilePath.Glob (glob)+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"+    ]