├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── printcess.cabal ├── src └── Printcess │ ├── Combinators.hs │ ├── Config.hs │ ├── Core.hs │ └── PrettyPrinting.hs └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | dist/ 3 | .stack-work/ 4 | .#* 5 | auto/ 6 | *.aux 7 | *.log 8 | *.out 9 | *.synctex.gz 10 | *.fls 11 | *.fdb_latexmk 12 | *.swp 13 | src/highlight.js 14 | src/style.css 15 | default.nix 16 | shell.nix 17 | stack.yaml 18 | output/ 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # printcess 2 | Haskell pretty printing library supporting indentation, mixfix operators, and automatic line breaks. 3 | 4 | Documentation is provided on [hackage](https://hackage.haskell.org/package/printcess/docs/Printcess-PrettyPrinting.html). 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /printcess.cabal: -------------------------------------------------------------------------------- 1 | name: 2 | printcess 3 | version: 4 | 0.1.0.3 5 | synopsis: 6 | Pretty printing with indentation, mixfix operators, and automatic line breaks. 7 | description: 8 | Pretty printing library supporting indentation, parenthesis-elision according 9 | to fixity and associativity, and automatic line breaks after text width 10 | exceedance. 11 | homepage: 12 | https://github.com/m0rphism/printcess/ 13 | bug-reports: 14 | https://github.com/m0rphism/printcess/issues 15 | license: 16 | BSD3 17 | license-file: 18 | LICENSE 19 | author: 20 | Hannes Saffrich 21 | maintainer: 22 | Hannes Saffrich 23 | copyright: 24 | 2016 Hannes Saffrich 25 | category: 26 | Pretty Printer 27 | build-type: 28 | Custom 29 | cabal-version: 30 | >=1.10 31 | stability: 32 | Beta 33 | tested-with: 34 | GHC == 8.0.1 35 | 36 | library 37 | hs-source-dirs: 38 | src 39 | default-language: 40 | Haskell2010 41 | build-depends: 42 | base >= 4.8 && < 5, 43 | containers >= 0.5.6 && < 0.6, 44 | mtl >= 2.2 && < 2.3, 45 | transformers >= 0.4.2 && < 0.6, 46 | lens >= 4.10 && < 4.16 47 | if impl(ghc<8) 48 | build-depends: 49 | semigroups >= 0.18 && < 0.19 50 | ghc-options: 51 | -Wall -fno-warn-partial-type-signatures 52 | exposed-modules: 53 | Printcess.PrettyPrinting 54 | other-modules: 55 | Printcess.Config, 56 | Printcess.Core, 57 | Printcess.Combinators 58 | 59 | source-repository head 60 | type: 61 | git 62 | location: 63 | https://github.com/m0rphism/printcess.git 64 | 65 | test-suite spec 66 | type: 67 | exitcode-stdio-1.0 68 | hs-source-dirs: 69 | test 70 | main-is: 71 | Spec.hs 72 | build-depends: 73 | base >= 4.8 && < 5, 74 | containers >= 0.5.7 && < 0.6, 75 | mtl >= 2.2 && < 2.3, 76 | transformers >= 0.5 && < 0.6, 77 | lens >= 4.10 && < 4.16, 78 | HUnit >= 1.3 && < 1.6, 79 | QuickCheck >= 2.8 && < 2.10, 80 | hspec >= 2.2, 81 | printcess 82 | 83 | -------------------------------------------------------------------------------- /src/Printcess/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UnicodeSyntax #-} 2 | 3 | module Printcess.Combinators where 4 | 5 | import Control.Lens 6 | import qualified Data.Map as M 7 | 8 | import Printcess.Core 9 | import Printcess.Config -- For haddock links to work... 10 | 11 | -- Basic Combinators ----------------------------------------------------------- 12 | 13 | -- | Print two 'Pretty' printable things in sequence. 14 | -- 15 | -- Example: 16 | -- 17 | -- > pretty defConfig $ "x" +> 1 -- ↪ "x1" 18 | -- 19 | -- Convenience function, defined as 20 | -- 21 | -- > a +> b = pp a >> pp b 22 | infixr 5 +> 23 | (+>) :: (Pretty a, Pretty b) => a → b → PrettyM () 24 | a +> b = pp a >> pp b 25 | 26 | -- | Print two 'Pretty' printable things in sequence, separated by a space. 27 | -- 28 | -- Example: 29 | -- 30 | -- > pretty defConfig $ "x" ~> 1 -- ↪ "x 1" 31 | -- 32 | -- Convenience function, defined as 33 | -- 34 | -- > a ~> b = a +> " " +> b 35 | infixr 4 ~> 36 | (~>) :: (Pretty a, Pretty b) => a → b → PrettyM () 37 | a ~> b = a +> sp +> b 38 | 39 | -- | Print two 'Pretty' printable things in sequence, separated by a newline. 40 | -- 41 | -- Example: 42 | -- 43 | -- > pretty defConfig $ "x" \> 1 -- ↪ "x 44 | -- > 1" 45 | -- 46 | -- Convenience function, defined as 47 | -- 48 | -- > a \> b = a +> "\n" +> b 49 | infixr 3 \> 50 | (\>) :: (Pretty a, Pretty b) => a → b → PrettyM () 51 | a \> b = a +> nl +> b 52 | 53 | -- Composite Combinators ------------------------------------------------------- 54 | 55 | -- | Print an @a@ between each @b@. 56 | -- 57 | -- Examples: 58 | -- 59 | -- > pretty defConfig $ "," `betweenEach` [] -- ↪ "" 60 | -- > pretty defConfig $ "," `betweenEach` ["x"] -- ↪ "x" 61 | -- > pretty defConfig $ "," `betweenEach` ["x", "y"] -- ↪ "x,y" 62 | infixl 6 `betweenEach` 63 | betweenEach :: (Pretty a, Pretty b) => a → [b] → PrettyM () 64 | betweenEach s as = sepByA_ (map pp as) (pp s) 65 | 66 | -- | Print an @a@ before each @b@. 67 | -- 68 | -- Examples: 69 | -- 70 | -- > pretty defConfig $ "," `beforeEach` [] -- ↪ "" 71 | -- > pretty defConfig $ "," `beforeEach` ["x"] -- ↪ ",x" 72 | -- > pretty defConfig $ "," `beforeEach` ["x", "y"] -- ↪ ",x,y" 73 | infixl 6 `beforeEach` 74 | beforeEach :: (Pretty a, Pretty b) => a → [b] → PrettyM () 75 | beforeEach a bs = foldl (>>) (pure ()) $ map pp bs `sepByL'` pp a 76 | 77 | -- | Print an @a@ after each @b@. 78 | -- 79 | -- Examples: 80 | -- 81 | -- > pretty defConfig $ "," `afterEach` [] -- ↪ "" 82 | -- > pretty defConfig $ "," `afterEach` ["x"] -- ↪ "x," 83 | -- > pretty defConfig $ "," `afterEach` ["x", "y"] -- ↪ "x,y," 84 | infixl 6 `afterEach` 85 | afterEach :: (Pretty a, Pretty b) => a → [b] → PrettyM () 86 | afterEach a bs = foldl (>>) (pure ()) $ map pp bs `sepByR'` pp a 87 | 88 | sepByA :: Applicative f => [f a] → f a → f [a] 89 | sepByA [] _ = pure [] 90 | sepByA [a] _ = (:[]) <$> a 91 | sepByA (a:as) s = (\x y z → x:y:z) <$> a <*> s <*> sepByA as s 92 | 93 | sepByA_ :: Applicative f => [f a] → f a → f () 94 | sepByA_ as s = () <$ sepByA as s 95 | 96 | sepByL', sepByR' :: [a] → a → [a] 97 | sepByL' xs0 s = foldl (\xs x → xs ++ [s,x]) [] xs0 98 | sepByR' xs0 s = foldl (\xs x → xs ++ [x,s]) [] xs0 99 | 100 | -- | Print a @[a]@ as a block, meaning that the indentation level is 101 | -- increased, and each @a@ is printed on a single line. 102 | -- 103 | -- Example: 104 | -- 105 | -- > pretty defConfig $ "do" ~> block ["putStrLn hello", "putStrLn world"] 106 | -- > -- ↪ "do 107 | -- > -- putStrLn hello 108 | -- > -- putStrLn world" 109 | block :: Pretty a => [a] → PrettyM () 110 | block xs = indented $ nl `beforeEach` xs 111 | 112 | -- | Same as 'block', but starts the block on the current line. 113 | -- 114 | -- Example: 115 | -- 116 | -- > pretty defConfig $ "do" ~> block' ["putStrLn hello", "putStrLn world"] 117 | -- > -- ↪ "do putStrLn hello 118 | -- > -- putStrLn world" 119 | block' :: Pretty a => [a] → PrettyM () 120 | block' xs = indentedToCurPos $ nl `betweenEach` xs 121 | 122 | -- | Print a @[a]@ similar to its 'Show' instance. 123 | -- 124 | -- Example: 125 | -- 126 | -- > pretty defConfig $ ppList [ "x", "y" ] -- ↪ "[ x, y ]" 127 | ppList :: Pretty a => [a] → PrettyM () 128 | ppList ps = "[" ~> ", " `betweenEach` ps ~> "]" 129 | 130 | -- | Print a list map @[(k,v)]@ as 'ppList', but render @(k,v)@ pairs as @"k → v"@. 131 | -- 132 | -- Example: 133 | -- 134 | -- > pretty defConfig $ ppListMap [ ("k1", "v1"), ("k2", "v2") ] 135 | -- > -- ↪ "[ k1 → v1, k2 → v2 ]" 136 | ppListMap :: (Pretty a, Pretty b) => [(a, b)] → PrettyM () 137 | ppListMap = ppList . map (\(a,b) → a ~> "→" ~> b) 138 | 139 | -- | Print a @Data.Map@ in the same way as 'ppListMap'. 140 | ppMap :: (Pretty a, Pretty b) => M.Map a b → PrettyM () 141 | ppMap = ppListMap . M.assocs 142 | 143 | -- | Print a horizontal bar consisting of a 'Char' as long as 'cMaxLineWidth' 144 | -- (or 80 if it is @Nothing@). 145 | -- 146 | -- Example: 147 | -- 148 | -- > pretty defConfig $ bar '-' 149 | -- > -- ↪ "-----------------------------------------…" 150 | bar :: Char → PrettyM () 151 | bar c = do 152 | w ← maybe 80 id <$> use maxLineWidth 153 | pp $ replicate w c 154 | 155 | -- | Print a horizontal bar consisting of a 'Char' as long as 'cMaxLineWidth' 156 | -- (or 80 if it is @Nothing@). The horizontal bar has a title 'String' printed 157 | -- at column 6. 158 | -- 159 | -- Example: 160 | -- 161 | -- > pretty defConfig $ titleBar '-' "Foo" 162 | -- > -- ↪ "----- Foo -------------------------------…" 163 | titleBar :: Pretty a => Char → a → PrettyM () 164 | titleBar c s = do 165 | w ← maybe 80 id <$> use maxLineWidth 166 | replicate 5 c ~> s ~> replicate (w - (7 + length (pretty (pure ()) s))) c +> "\n" 167 | 168 | -- | Print a newline (line break). 169 | nl :: PrettyM () 170 | nl = pp "\n" 171 | 172 | -- | Print a space. 173 | sp :: PrettyM () 174 | sp = pp " " 175 | -------------------------------------------------------------------------------- /src/Printcess/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, UnicodeSyntax #-} 2 | 3 | module Printcess.Config where 4 | 5 | import Control.Monad.State.Strict 6 | import Control.Lens 7 | 8 | -- | A 'Config' allows to specify various pretty printing options, e.g. 9 | -- the maximum line width. 10 | -- 11 | -- As the rendering functions, like 'pretty', take updates to an internal 12 | -- default 'Config', only the lenses of the 'Config' fields are exported. 13 | -- 14 | -- A custom 'Config' can be specified as in the following example: 15 | -- 16 | -- > foo :: String 17 | -- > foo = pretty config "foo bar baz" 18 | -- > where config :: State Config () 19 | -- > config = do cMaxLineWidth .= Just 6 20 | -- > cInitIndent .= 2 21 | -- > cIndentAfterBreaks .= 0 22 | data Config = Config 23 | { _configMaxLineWidth :: Maybe Int 24 | , _configInitPrecedence :: Int 25 | , _configInitIndent :: Int 26 | , _configIndentChar :: Char 27 | , _configIndentDepth :: Int 28 | , _configIndentAfterBreaks :: Int 29 | } 30 | 31 | def :: Config 32 | def = Config 33 | { _configMaxLineWidth = Just 80 34 | , _configInitPrecedence = -1 35 | , _configInitIndent = 0 36 | , _configIndentChar = ' ' 37 | , _configIndentDepth = 2 38 | , _configIndentAfterBreaks = 4 39 | } 40 | 41 | -- | Leaves the default @Config@ unchanged and returns @()@. 42 | -- 43 | -- Convenience function defined as: 44 | -- 45 | -- > defConfig = pure () 46 | -- 47 | -- See example in 'pretty'. 48 | defConfig :: State Config () 49 | defConfig = pure () 50 | 51 | makeLenses ''Config 52 | 53 | -- | When a line gets longer, it is broken after the latest space, 54 | -- that still allows the line to remain below this maximum. 55 | -- 56 | -- If there is no such space, an over-long line with a single indented word is 57 | -- printed. 58 | -- 59 | -- This guarantees both progress and not to break identifiers into parts. 60 | -- 61 | -- Default: @Just 80@ 62 | cMaxLineWidth :: Lens' Config (Maybe Int) 63 | cMaxLineWidth = configMaxLineWidth 64 | 65 | -- | The character used for indentation. 66 | -- Usually @' '@ for spaces or @'\t'@ for tabs. 67 | -- 68 | -- Default: @' '@ 69 | cIndentChar :: Lens' Config Char 70 | cIndentChar = configIndentChar 71 | 72 | -- | How many 'cIndentChar' characters for one indentation level. 73 | -- 74 | -- Default: @2@ 75 | cIndentDepth :: Lens' Config Int 76 | cIndentDepth = configIndentDepth 77 | 78 | -- | How many 'cIndentChar' characters to indent additionally, when a line break 79 | -- occurs, because 'cMaxLineWidth' was exceeded. 80 | -- 81 | -- Assuming the line to print has to be broken multiple times, the 82 | -- indentation of all resulting lines, except the first one, is increased by this amount. 83 | -- For example 84 | -- 85 | -- > pretty (do cMaxLineWidth .= Just 8; cIndentAfterBreaks .= 4) "foo bar baz boo" 86 | -- evaluates to 87 | -- 88 | -- > foo bar 89 | -- > baz 90 | -- > boo 91 | -- 92 | -- Default: @4@ 93 | cIndentAfterBreaks :: Lens' Config Int 94 | cIndentAfterBreaks = configIndentAfterBreaks 95 | 96 | -- | Indentation level to start pretty printing with. 97 | -- 98 | -- Default: @0@ 99 | cInitIndent :: Lens' Config Int 100 | cInitIndent = configInitIndent 101 | 102 | -- | Precendence level to start pretty printing with. 103 | -- 104 | -- Default: @(-1)@ 105 | cInitPrecedence :: Lens' Config Int 106 | cInitPrecedence = configInitPrecedence 107 | -------------------------------------------------------------------------------- /src/Printcess/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, MultiWayIf #-} 3 | {-# LANGUAGE TemplateHaskell, UnicodeSyntax #-} 4 | 5 | module Printcess.Core where 6 | 7 | import Control.Monad.State.Strict 8 | import Control.Lens 9 | import qualified Data.List.NonEmpty as NE 10 | import Data.List.NonEmpty (NonEmpty(..)) 11 | 12 | import Printcess.Config 13 | 14 | -- Associativity --------------------------------------------------------------- 15 | 16 | data Assoc = AssocN | AssocL | AssocR 17 | deriving (Eq, Ord, Read, Show) 18 | 19 | -- Pretty Printing State ------------------------------------------------------- 20 | 21 | data PrettySt = PrettySt 22 | { _indentation :: Int 23 | , _precedence :: Int 24 | , _assoc :: Assoc 25 | , _maxLineWidth :: Maybe Int 26 | , _text :: NE.NonEmpty String 27 | , _indentChar :: Char 28 | , _indentDepth :: Int 29 | , _indentAfterBreaks :: Int 30 | } 31 | 32 | stFromConfig :: Config → PrettySt 33 | stFromConfig c = PrettySt 34 | { _indentation = _configInitIndent c 35 | , _precedence = _configInitPrecedence c 36 | , _assoc = AssocN 37 | , _maxLineWidth = _configMaxLineWidth c 38 | , _text = "" :| [] 39 | , _indentChar = _configIndentChar c 40 | , _indentDepth = _configIndentDepth c 41 | , _indentAfterBreaks = _configIndentAfterBreaks c 42 | } 43 | 44 | makeLenses ''PrettySt 45 | 46 | -- Pretty Printing ------------------------------------------------------------- 47 | 48 | -- | Render a 'Pretty' printable @a@ to 'String' using a 'Config', that 49 | -- specifies how the @a@ should be rendered. For example 50 | -- 51 | -- > pretty defConfig (1 :: Int) -- evaluates to "1" 52 | pretty 53 | :: Pretty a 54 | => State Config () -- ^ Updates for the default pretty printing 'Config'. 55 | -> a -- ^ A 'Pretty' printable @a@. 56 | -> String -- ^ The pretty printed @a@. 57 | pretty c 58 | = concat 59 | . (`sepByList` "\n") 60 | . reverse 61 | . NE.toList 62 | . view text 63 | . (`execState` stFromConfig (execState c def)) 64 | . runPrettyM 65 | . pp 66 | 67 | -- | Render a 'Pretty' printable @a@ to @stdout@ using a 'Config', that 68 | -- specifies how the @a@ should be rendered. 69 | -- 70 | -- Convenience function, defined as: 71 | -- 72 | -- > prettyPrint c = liftIO . putStrLn . pretty c 73 | prettyPrint 74 | :: (MonadIO m, Pretty a) 75 | => State Config () -- ^ Updates for the default pretty printing 'Config'. 76 | -> a -- ^ A 'Pretty' printable @a@. 77 | -> m () -- ^ An 'IO' action pretty printing the @a@ to @stdout@. 78 | prettyPrint c = 79 | liftIO . putStrLn . pretty c 80 | 81 | -- Type Classes ---------------------------------------------------------------- 82 | 83 | -- | Instanciating this class for a type, declares how values of that type 84 | -- should be pretty printed. 85 | -- 86 | -- As pretty printing may depend on some context, e.g. the current indentation 87 | -- level, a 'State' monad for pretty printing ('PrettyM') is used. 88 | -- 89 | -- A default implementation is provided copying behavior from a 'Show' instance. 90 | -- This can be convenient for deriving 'Pretty', e.g. for base types or 91 | -- debugging. The default implementation is defined by @pp = pp . show@. 92 | class Pretty a where 93 | -- | Pretty print an @a@ as a 'PrettyM' action. 94 | pp :: a → PrettyM () 95 | 96 | default 97 | pp :: Show a => a → PrettyM (); 98 | pp = pp . show 99 | 100 | head1L :: Lens' (NE.NonEmpty a) a 101 | head1L = lens NE.head (\(_ :| xs) x → x :| xs) 102 | 103 | tail1L :: Lens' (NE.NonEmpty a) [a] 104 | tail1L = lens NE.tail (\(x :| _) xs → x :| xs) 105 | 106 | charsBeforeWord :: Int -> (Char -> Bool) -> String -> Int 107 | charsBeforeWord nWords0 cIndent s0 = 108 | go s0 nWords0 109 | where 110 | go s n = 111 | length sIndent + if n == 0 then 0 else length sWord + go sAfterWord (n-1) 112 | where 113 | (sIndent, sBeforeWord) = break (not . cIndent) s 114 | (sWord, sAfterWord) = break cIndent sBeforeWord 115 | 116 | charsBeforeWordM :: Int -> PrettyM Int 117 | charsBeforeWordM n0 = do 118 | cIndent ← use indentChar 119 | curText ← use $ text . head1L 120 | pure $ charsBeforeWord n0 (`elem` [' ', '\t', cIndent]) curText 121 | 122 | -- Isomorphic lines and unlines implementations 123 | lines' :: String → [String] 124 | lines' = go "" where 125 | go s = \case 126 | "" → [s] 127 | c:cs | c == '\n' → s : go "" cs 128 | | otherwise → go (s++[c]) cs 129 | 130 | unlines' :: [String] → String 131 | unlines' = \case 132 | [] → "" 133 | [x] → x 134 | x:xs → x ++ '\n' : unlines' xs 135 | 136 | isWS, isNoWS :: Char → Bool 137 | isWS = (`elem` [' ', '\t']) 138 | isNoWS = not . isWS 139 | 140 | dropWhileEnd :: (a → Bool) → [a] → [a] 141 | dropWhileEnd f = reverse . dropWhile f . reverse 142 | 143 | -- | In contrast to 'Show', @"foo"@ is printed as @"foo"@ and not @"\\"foo\\""@. 144 | -- Most of the other instances are defined in terms of this instance. 145 | -- If the 'String' contains newline characters (@'\n'@), indentation is inserted 146 | -- automatically afterwards. 147 | -- If the current line gets too long, it is automatically broken. 148 | instance Pretty String where 149 | pp = go . lines' where 150 | go :: [String] -> PrettyM () 151 | go [] = pure () 152 | go [s] = ppLine True s 153 | go (s:ss) = do ppLine True s; text %= ("" NE.<|); go ss 154 | 155 | ppLine :: Bool -> String -> PrettyM () 156 | ppLine first s = do 157 | oldLine ← use $ text . head1L 158 | when (null oldLine) addIndent 159 | text . head1L %= (++s) 160 | curLine ← use $ text . head1L 161 | -- We have to allow at least indentation + 1 word, otherwise indenting after 162 | -- line break due to line continuation can cause infinite loop 163 | mMaxLineLength ← use maxLineWidth 164 | forM_ mMaxLineLength $ \maxLineLength → do 165 | maxLineLength' ← max <$> charsBeforeWordM 1 <*> pure maxLineLength 166 | when (length curLine > maxLineLength') $ do 167 | let (curLine', lineRest) = splitAt maxLineLength curLine -- length s1 == maxLineLength 168 | let (wordRest, curLine'') 169 | | isNoWS (head lineRest) 170 | = both %~ reverse $ break (==' ') $ reverse curLine' 171 | | otherwise 172 | = ("", curLine') 173 | text . head1L .= dropWhileEnd isWS curLine'' 174 | -- Increase indentation once after the first forced line break, this results into: 175 | -- this line was too long 176 | -- still the first line 177 | -- it won't stop 178 | i ← use indentAfterBreaks 179 | let f | first = indentedByChars i 180 | | otherwise = id 181 | f $ do text %= ("" NE.<|); ppLine False $ dropWhile isWS $ wordRest ++ lineRest 182 | 183 | -- | In contrast to 'Show', @\'c\'@ is printed as @"c"@ and not @"\'c\'"@. 184 | instance Pretty Char where pp = pp . (:"") 185 | 186 | -- | Behaves like 'Show': @1@ is printed to @"1"@. 187 | instance Pretty Int 188 | 189 | -- | Behaves like 'Show': @1.2@ is printed to @"1.2"@. 190 | instance Pretty Float 191 | 192 | -- | Behaves like 'Show': @1.2@ is printed to @"1.2"@. 193 | instance Pretty Double 194 | 195 | -- -- | Print a map @M.fromList [("k1","v1"), ("k2","v2")]@ 196 | -- -- as @"[ k1 → v1, k2 → v2 ]"@. 197 | -- instance (Pretty k, Pretty v) => Pretty (M.Map k v) where 198 | -- pp = foldl pp' (pp "") . M.toList where 199 | -- pp' s (k, v) = s +> k ~> "=>" ~> indented v +> nl 200 | 201 | -- | The 'Pretty1' type class lifts 'Pretty' printing to unary type constructors. 202 | -- It can be used in special cases to abstract over type constructors which 203 | -- are 'Pretty' printable for any 'Pretty' printable type argument. 204 | class Pretty1 f where 205 | pp1 :: Pretty a => f a → PrettyM () 206 | default pp1 :: Pretty (f a) => f a -> PrettyM () 207 | pp1 = pp 208 | 209 | -- | The 'Pretty2' type class lifts 'Pretty' printing to binary type constructors. 210 | -- It can be used in special cases to abstract over type constructors which 211 | -- are 'Pretty' printable for any 'Pretty' printable type arguments. 212 | class Pretty2 (f :: * → * → *) where 213 | pp2 :: (Pretty a, Pretty b) => f a b → PrettyM () 214 | default pp2 :: Pretty (f a b) => f a b -> PrettyM () 215 | pp2 = pp 216 | 217 | -- Pretty Monad ---------------------------------------------------------------- 218 | 219 | -- | The 'PrettyM' monad is run in the pretty printing process, e.g. in 220 | -- 'pretty' or 'prettyPrint'. 221 | -- 222 | -- 'PrettyM' is internally a 'State' monad manipulating a 'Config' and a list of 223 | -- pretty printed lines. 224 | -- 225 | -- Most of the combinators from this library take values of 'Pretty' printable types, 226 | -- convert them to @'PrettyM' ()@ actions using 'pp', and combine the actions in 227 | -- some way resulting in a new @'PrettyM' ()@ action. 228 | newtype PrettyM a = PrettyM { runPrettyM :: State PrettySt a } 229 | deriving (Functor, Applicative, Monad, MonadState PrettySt) 230 | 231 | -- | This instance makes it possible to nest operators like @('+>')@. 232 | -- Implemented as: @pp = id@ 233 | instance Pretty (PrettyM ()) where pp = id 234 | 235 | 236 | sepByList :: [[a]] → [a] → [[a]] 237 | sepByList [] _ = [] 238 | sepByList [s] _ = [s] 239 | sepByList (s:ss) s' = s : s' : sepByList ss s' 240 | 241 | addIndent :: PrettyM () 242 | addIndent = do 243 | i <- use indentation 244 | c <- use indentChar 245 | text . head1L %= (++ replicate i c) 246 | 247 | -- Indentation ----------------------------------------------------------------- 248 | 249 | indentByChars 250 | :: Int 251 | -> PrettyM () 252 | indentByChars = 253 | (indentation +=) 254 | 255 | indentByLevels 256 | :: Int 257 | -> PrettyM () 258 | indentByLevels i = 259 | (indentation +=) . (i *) =<< use indentDepth 260 | 261 | -- | Print an @a@ with indentation increased by a certain amount of 262 | -- 'cIndentChar' characters. 263 | -- 264 | -- Example: 265 | -- 266 | -- > pretty defConfig $ 267 | -- > "while (true) {" \> 268 | -- > indentedByChars 2 ("f();" \> "g();") \> 269 | -- > "}" 270 | -- > -- ↪ "while (true) { 271 | -- > -- f(); 272 | -- > -- g(); 273 | -- > -- }" 274 | indentedByChars 275 | :: Pretty a 276 | => Int -- ^ Number of characters to increase indentation. 277 | -> a -- ^ A 'Pretty' printable @a@ 278 | -> PrettyM () -- ^ An action printing the @a@ with increased indentation. 279 | indentedByChars i a = do 280 | indentByChars i 281 | pp a 282 | indentByChars (-i) 283 | 284 | -- | Same as 'indentedByChars' but increases indentation in 'cIndentDepth' steps. 285 | indentedBy 286 | :: Pretty a 287 | => Int -- ^ Number of indentation levels to increase. 288 | -- One indentation level consists of 'cIndentDepth' characters. 289 | -> a -- ^ A 'Pretty' printable @a@ 290 | -> PrettyM () -- ^ An action printing the @a@ with increased indentation. 291 | indentedBy i a = do 292 | indentByLevels i 293 | pp a 294 | indentByLevels (-i) 295 | 296 | -- | Convenience function defined as: 297 | -- 298 | -- > indented = indentedBy 1 299 | indented 300 | :: Pretty a 301 | => a -- ^ A 'Pretty' printable @a@ 302 | -> PrettyM () -- ^ An action printing the @a@ indented 1 level deeper. 303 | indented = 304 | indentedBy 1 305 | 306 | indentToCurPos :: PrettyM () 307 | indentToCurPos = do 308 | curLine ← use $ text . head1L 309 | indentation .= length curLine 310 | 311 | indentedToCurPos :: PrettyM a → PrettyM a 312 | indentedToCurPos ma = do 313 | i ← use indentation 314 | indentToCurPos 315 | a ← ma 316 | indentation .= i 317 | pure a 318 | 319 | -- Associativity & Fixity ------------------------------------------------------ 320 | 321 | withPrecedence :: (Assoc, Int) → PrettyM () → PrettyM () 322 | withPrecedence (a, p) ma = do 323 | p' ← use precedence 324 | a' ← use assoc 325 | precedence .= p 326 | assoc .= a 327 | if | p' == p && a' == a && a /= AssocN → ma 328 | | p' < p → ma 329 | | otherwise → do pp "("; ma; pp ")" 330 | precedence .= p' 331 | assoc .= a' 332 | 333 | -- | Print an @a@ as a left-associative operator of a certain fixity. 334 | assocL :: Pretty a => Int → a → PrettyM () 335 | assocL i = withPrecedence (AssocL, i) . pp 336 | 337 | -- | Print an @a@ as a right-associative operator of a certain fixity. 338 | assocR :: Pretty a => Int → a → PrettyM () 339 | assocR i = withPrecedence (AssocR, i) . pp 340 | 341 | -- | Print an @a@ as a non-associative operator of a certain fixity. 342 | assocN :: Pretty a => Int → a → PrettyM () 343 | assocN i = withPrecedence (AssocN, i) . pp 344 | 345 | -- | The constructors of this type can be used as short forms of 'left', 346 | -- 'right', and 'inner'. 347 | data AssocAnn a 348 | = L a -- ^ Print an @a@ as the left argument of a mixfix operator (behaves like 'left'). 349 | | R a -- ^ Print an @a@ as the right argument of a mixfix operator (behaves like 'right'). 350 | | I a -- ^ Print an @a@ as the inner argument of a mixfix operator (behaves like 'inner'). 351 | deriving (Eq, Ord, Read, Show) 352 | 353 | instance Pretty1 AssocAnn 354 | 355 | -- | Let the associativity annotations for arguments ('L', 'R', 'I') 356 | -- behave as the 'left', 'right', and 'inner' functions. 357 | instance Pretty a => Pretty (AssocAnn a) where 358 | pp = \case 359 | L a → left a 360 | R a → right a 361 | I a → inner a 362 | 363 | -- | Print an @a@ as the left argument of a mixfix operator. 364 | left :: Pretty a => a → PrettyM () 365 | left = assocDir AssocL 366 | 367 | -- | Print an @a@ as the right argument of a mixfix operator. 368 | right :: Pretty a => a → PrettyM () 369 | right = assocDir AssocR 370 | 371 | -- | Print an @a@ as an inner argument of a mixfix operator. 372 | inner :: Pretty a => a → PrettyM () 373 | inner ma = do 374 | p' ← use precedence 375 | a' ← use assoc 376 | precedence .= (-1) 377 | assoc .= AssocN 378 | pp ma 379 | precedence .= p' 380 | assoc .= a' 381 | 382 | assocDir :: Pretty a => Assoc → a → PrettyM () 383 | assocDir a ma = do 384 | a' ← use assoc 385 | if | a' == a → pp ma 386 | | otherwise → do 387 | assoc .= AssocN 388 | pp ma 389 | assoc .= a' 390 | -------------------------------------------------------------------------------- /src/Printcess/PrettyPrinting.hs: -------------------------------------------------------------------------------- 1 | module Printcess.PrettyPrinting ( 2 | -- * Overview 3 | -- $overview 4 | 5 | -- * Example 6 | -- $example 7 | 8 | -- * Rendering 9 | pretty, 10 | prettyPrint, 11 | 12 | -- * Config 13 | Config, 14 | cMaxLineWidth, cIndentChar, cIndentDepth, cIndentAfterBreaks, 15 | cInitIndent, cInitPrecedence, 16 | defConfig, 17 | 18 | -- * Type Class 19 | Pretty(..), 20 | 21 | -- * Monad 22 | PrettyM, 23 | 24 | -- * Sequencing 25 | (+>), (~>), (\>), 26 | 27 | -- * Indentation 28 | indentedByChars, indentedBy, indented, 29 | block, block', 30 | 31 | -- * Associativity & Fixity 32 | assocL, assocR, assocN, 33 | left, right, inner, AssocAnn(..), 34 | 35 | -- * Folding @Pretty@ Things 36 | betweenEach, beforeEach, afterEach, 37 | ppList, ppListMap, ppMap, 38 | 39 | -- * Other combinators 40 | bar, titleBar, 41 | 42 | -- * Constants 43 | nl, sp, 44 | 45 | -- * Lifted Type Classes 46 | Pretty1(..), Pretty2(..), 47 | 48 | -- * Reexports 49 | State, (.=), 50 | ) where 51 | 52 | import Control.Monad.State.Strict 53 | import Control.Lens 54 | 55 | import Printcess.Config 56 | import Printcess.Core 57 | import Printcess.Combinators 58 | 59 | {- $overview 60 | The main features of the @printcess@ pretty printing library are 61 | 62 | * /Indentation/. Printing-actions are relative to the indentation level 63 | of their context. Special actions can be used to control the indentation 64 | level. Indentation is automatically inserted after newlines. 65 | 66 | * /Automatic parenthesizing of mixfix operators/. 67 | Special printing-actions can be used to specify the associativity 68 | and fixity of operators and to mark the positions of their arguments. 69 | This makes it easy to print for example @"λx. λy. x y (x y)"@ 70 | instead of @"(λx. (λy. ((x y) (x y))))"@. 71 | 72 | * /Automatic line breaks after exceeding a maximum line width/. 73 | A maximum line width can be specified, after which lines are 74 | automatically broken. If the break point is inside a word, 75 | it is moved to the left until a white space character is reached. 76 | This avoids splitting identifiers into two. 77 | -} 78 | 79 | {- $example 80 | In this section, a small example is presented, which pretty prints a 81 | lambda calculus expression. 82 | 83 | First we define an abstract syntax tree for lambda calculus expressions. 84 | 85 | > data Expr 86 | > = EVar String 87 | > | EAbs String Expr 88 | > | EApp Expr Expr 89 | 90 | Then we make @Expr@ an instance of the 'Pretty' type class, which 91 | declares one method 'pp'. This method takes an @Expr@ and returns a 92 | 'PrettyM' @()@ action, which describes how to 'pretty' print the @Expr@. 93 | 94 | > instance Pretty Expr where 95 | > pp (EVar x) = pp x 96 | > pp (EApp e1 e2) = assocL 9 $ L e1 ~> R e2 97 | > pp (EAbs x e) = assocR 0 $ "λ" +> I x +> "." ~> R e 98 | 99 | We print 100 | 101 | * a variable @EVar x@ by printing the identifier 'String' @x@. 102 | 103 | * a function application @EApp e1 e2@ as a left-associative operator of 104 | fixity 9 ('assocL' @9@), where e1 is the left argument ('L') and @e2@ is 105 | the right argument ('R'). The ('~>') combinator separates its first 106 | argument with a space from its second argument. 107 | 108 | * a function abstraction @EAbs x e@ as a right-associative operator of 109 | fixity 0 ('assocR' @0@), where @x@ is an inner 110 | argument ('I') and @e@ is the right argument ('R'). 111 | The ('+>') combinator behaves as ('~>'), but without inserting a space. 112 | 113 | Then we define a simple test expression @e1@ representing @λx. λy. x y (x y)@ 114 | 115 | > e1 :: Expr 116 | > e1 = EAbs "x" $ EAbs "y" $ EApp (EApp (EVar "x") (EVar "y")) 117 | > (EApp (EVar "x") (EVar "y")) 118 | 119 | and pretty print it to 'String' using the 'pretty' function 120 | 121 | > s1, s2 :: String 122 | > s1 = pretty defConfig e1 -- evaluates to "λx. λy. x y (x y)" 123 | > s2 = pretty (cMaxLineWidth .= Just 12) e1 -- evaluates to "λx. λy. x y 124 | > -- (x y)" 125 | -} 126 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# lANGUAGE LambdaCase #-} 2 | 3 | import Test.Hspec 4 | import Printcess.PrettyPrinting 5 | import Control.Lens 6 | 7 | main :: IO () 8 | main = hspec $ do 9 | describe "basic" $ do 10 | it "prints a string" $ 11 | pretty defConfig 12 | "foo" `shouldBe` 13 | "foo" 14 | it "handles newlines" $ 15 | pretty defConfig 16 | "foo\nbar" `shouldBe` 17 | "foo\nbar" 18 | it "indents after newlines" $ 19 | pretty defConfig 20 | (indented "foo\nbar") `shouldBe` 21 | " foo\n bar" 22 | it "respects initial indentation" $ 23 | pretty (cInitIndent .= 2) 24 | "foo\nbar" `shouldBe` 25 | " foo\n bar" 26 | 27 | describe "automatic line breaks" $ do 28 | it "breaks too long lines" $ 29 | pretty (cMaxLineWidth .= Just 10) 30 | "foo bar baz boo" `shouldBe` 31 | "foo bar\n baz\n boo" 32 | it "breaks too long lines" $ 33 | pretty (cMaxLineWidth .= Just 11) 34 | "foo bar baz boo" `shouldBe` 35 | "foo bar baz\n boo" 36 | it "breaks too long lines twice" $ 37 | pretty (cMaxLineWidth .= Just 10) 38 | "foo bar baz boo r" `shouldBe` 39 | "foo bar\n baz\n boo r" 40 | it "breaks too long lines four times" $ 41 | pretty (cMaxLineWidth .= Just 10) 42 | "foo bar baz boo raz roo" `shouldBe` 43 | "foo bar\n baz\n boo\n raz\n roo" 44 | it "breaks too long lines" $ 45 | pretty (cMaxLineWidth .= Just 11) 46 | "foo bar baz boo r" `shouldBe` 47 | "foo bar baz\n boo r" 48 | it "breaks too long lines twice" $ 49 | pretty (cMaxLineWidth .= Just 11) 50 | "foo bar baz boo raz roo" `shouldBe` 51 | "foo bar baz\n boo raz\n roo" 52 | it "breaks too long lines" $ 53 | pretty (cMaxLineWidth .= Just 12) 54 | "foo bar baz boo r" `shouldBe` 55 | "foo bar baz\n boo r" 56 | it "breaks too long lines & setting indentChar works" $ 57 | pretty (do cMaxLineWidth .= Just 10; cIndentChar .= '~') 58 | "foo bar baz boo r" `shouldBe` 59 | "foo bar\n~~~~baz\n~~~~boo r" 60 | it "removes spaces around broken lines" $ 61 | pretty (cMaxLineWidth .= Just 10) 62 | "foo bar baz boo" `shouldBe` 63 | "foo bar\n baz\n boo" 64 | 65 | describe "Lambda Calculus" $ do 66 | it "respects associativity" $ 67 | pretty defConfig 68 | e1 `shouldBe` 69 | "λx. λy. x y (x y)" 70 | 71 | describe "Blocks" $ do 72 | it "blocks starting on next line" $ 73 | pretty defConfig 74 | ("do" ~> block [ "ma", "mb" ]) `shouldBe` 75 | "do \n ma\n mb" 76 | it "blocks starting on same line" $ 77 | pretty defConfig 78 | ("do" ~> block' [ "ma", "mb" ]) `shouldBe` 79 | "do ma\n mb" 80 | 81 | data Expr 82 | = EVar String 83 | | EAbs String Expr 84 | | EApp Expr Expr 85 | 86 | instance Pretty Expr where 87 | pp = \case 88 | EVar x -> pp x 89 | EAbs x e -> assocR 0 $ "λ" +> x +> "." ~> R e 90 | EApp e1 e2 -> assocL 9 $ L e1 ~> R e2 91 | 92 | e1 = EAbs "x" $ EAbs "y" $ EApp (EApp (EVar "x") (EVar "y")) 93 | (EApp (EVar "x") (EVar "y")) 94 | --------------------------------------------------------------------------------