diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pretty-simple.cabal b/pretty-simple.cabal new file mode 100644 --- /dev/null +++ b/pretty-simple.cabal @@ -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 diff --git a/src/Text/Pretty/Simple.hs b/src/Text/Pretty/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple.hs @@ -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" +-- ] +-- } diff --git a/src/Text/Pretty/Simple/Internal/Expr.hs b/src/Text/Pretty/Simple/Internal/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Expr.hs @@ -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) diff --git a/src/Text/Pretty/Simple/Internal/Parser.hs b/src/Text/Pretty/Simple/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Parser.hs @@ -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)" diff --git a/src/Text/Pretty/Simple/Internal/Printer.hs b/src/Text/Pretty/Simple/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Printer.hs @@ -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 diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -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" + ]