packages feed

printcess (empty) → 0.1.0.0

raw patch · 8 files changed

+1003/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basebuild-type:Customsetup-changed

Dependencies added: HUnit, QuickCheck, base, containers, hspec, lens, mtl, printcess, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ printcess.cabal view
@@ -0,0 +1,79 @@+name:+  printcess+version:+  0.1.0.0+synopsis:+  Pretty printing with indentation, mixfix operators, and automatic line breaks.+description:+  Pretty printing library supporting indentation, parenthesis-elision according+  to fixity and associativity, and automatic line breaks after text width+  exceedance.+homepage:+  https://github.com/m0rphism/printcess/+bug-reports:+  https://github.com/m0rphism/printcess/issues+license:+  BSD3+license-file:+  LICENSE+author:+  Hannes Saffrich+maintainer:+  Hannes Saffrich <m0rphism@zankapfel.org>+copyright:+  2016 Hannes Saffrich+category:+  Web+build-type:+  Custom+cabal-version:+  >=1.10+stability:+  Beta+tested-with:+  GHC == 8.0.1++library+  hs-source-dirs:+    src+  default-language:+    Haskell2010+  build-depends:+    base         >= 4.8   && < 5,+    containers   >= 0.5.7 && < 0.6,+    mtl          >= 2.2   && < 2.3,+    transformers >= 0.5   && < 0.6,+    lens         >= 4.10  && < 4.16+  ghc-options:+    -Wall -fno-warn-partial-type-signatures+  exposed-modules:+    Printcess.PrettyPrinting+  other-modules:+    Printcess.Config,+    Printcess.Core,+    Printcess.Combinators++source-repository head+  type:+    git+  location:+    https://github.com/m0rphism/printcess.git++test-suite spec+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    Spec.hs+  build-depends:+    base         >= 4.8   && < 5,+    containers   >= 0.5.7 && < 0.6,+    mtl          >= 2.2   && < 2.3,+    transformers >= 0.5   && < 0.6,+    lens         >= 4.10  && < 4.16,+    HUnit        >= 1.3   && < 1.6,+    QuickCheck   >= 2.8   && < 2.10,+    hspec        >= 2.2   && < 2.4,+    printcess+
+ src/Printcess/Combinators.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE+  UnicodeSyntax+#-}++module Printcess.Combinators where++import Control.Lens+import qualified Data.Map as M++import Printcess.Core+import Printcess.Config -- For haddock links to work...++-- Basic Combinators -----------------------------------------------------------++-- | Print two 'Pretty' printable things in sequence.+--+--   Example:+--+--   > pretty defConfig $ "x" +> 1  -- ↪ "x1"+--+--   Convenience function, defined as+--+--   > a +> b = pp a >> pp b+infixr 5 +>+(+>) :: (Pretty a, Pretty b) => a → b → PrettyM ()+a +> b = pp a >> pp b++-- | Print two 'Pretty' printable things in sequence, separated by a space.+--+--   Example:+--+--   > pretty defConfig $ "x" ~> 1  -- ↪ "x 1"+--+--   Convenience function, defined as+--+--   > a ~> b = a +> " " +> b+infixr 4 ~>+(~>) :: (Pretty a, Pretty b) => a → b → PrettyM ()+a ~> b = a +> sp +> b++-- | Print two 'Pretty' printable things in sequence, separated by a newline.+--+--   Example:+--+--   > pretty defConfig $ "x" \> 1  -- ↪ "x+--   >                                    1"+--+--   Convenience function, defined as+--+--   > a \> b = a +> "\n" +> b+infixr 3 \>+(\>) :: (Pretty a, Pretty b) => a → b → PrettyM ()+a \> b = a +> nl +> b++-- Composite Combinators -------------------------------------------------------++-- | Print an @a@ between each @b@.+--+--   Examples:+--+--   > pretty defConfig $ "," `betweenEach` []          -- ↪ ""+--   > pretty defConfig $ "," `betweenEach` ["x"]       -- ↪ "x"+--   > pretty defConfig $ "," `betweenEach` ["x", "y"]  -- ↪ "x,y"+infixl 6 `betweenEach`+betweenEach :: (Pretty a, Pretty b) => a → [b] → PrettyM ()+betweenEach s as = sepByA_ (map pp as) (pp s)++-- | Print an @a@ before each @b@.+--+--   Examples:+--+--   > pretty defConfig $ "," `beforeEach` []          -- ↪ ""+--   > pretty defConfig $ "," `beforeEach` ["x"]       -- ↪ ",x"+--   > pretty defConfig $ "," `beforeEach` ["x", "y"]  -- ↪ ",x,y"+infixl 6 `beforeEach`+beforeEach :: (Pretty a, Pretty b) => a → [b] → PrettyM ()+beforeEach a bs = foldl (>>) (pure ()) $ map pp bs `sepByL'` pp a++-- | Print an @a@ after each @b@.+--+--   Examples:+--+--   > pretty defConfig $ "," `afterEach` []          -- ↪ ""+--   > pretty defConfig $ "," `afterEach` ["x"]       -- ↪ "x,"+--   > pretty defConfig $ "," `afterEach` ["x", "y"]  -- ↪ "x,y,"+infixl 6 `afterEach`+afterEach :: (Pretty a, Pretty b) => a → [b] → PrettyM ()+afterEach a bs = foldl (>>) (pure ()) $ map pp bs `sepByR'` pp a++sepByA :: Applicative f => [f a] → f a → f [a]+sepByA []     _ = pure []+sepByA [a]    _ = (:[]) <$> a+sepByA (a:as) s = (\x y z → x:y:z) <$> a <*> s <*> sepByA as s++sepByA_ :: Applicative f => [f a] → f a → f ()+sepByA_ as s = () <$ sepByA as s++sepByL', sepByR' :: [a] → a → [a]+sepByL' xs0 s = foldl (\xs x → xs ++ [s,x]) [] xs0+sepByR' xs0 s = foldl (\xs x → xs ++ [x,s]) [] xs0++-- | Print a @[a]@ as a block, meaning that the indentation level is+-- increased, and each @a@ is printed on a single line.+--+-- Example:+--+-- > pretty defConfig $ "do" ~> block ["putStrLn hello", "putStrLn world"]+-- > -- ↪ "do+-- > --      putStrLn hello+-- > --      putStrLn world"+block :: Pretty a => [a] → PrettyM ()+block  xs = indented $ nl `beforeEach` xs++-- | Same as 'block', but starts the block on the current line.+--+-- Example:+--+-- > pretty defConfig $ "do" ~> block' ["putStrLn hello", "putStrLn world"]+-- > -- ↪ "do putStrLn hello+-- > --       putStrLn world"+block' :: Pretty a => [a] → PrettyM ()+block' xs = indentedToCurPos $ nl `betweenEach` xs++-- | Print a @[a]@ similar to its 'Show' instance.+--+--   Example:+--+--   > pretty defConfig $ ppList [ "x", "y" ]  -- ↪ "[ x, y ]"+ppList :: Pretty a => [a] → PrettyM ()+ppList ps = "[" ~> ", " `betweenEach` ps ~> "]"++-- | Print a list map @[(k,v)]@ as 'ppList', but render @(k,v)@ pairs as @"k → v"@.+--+--   Example:+--+--   > pretty defConfig $ ppListMap [ ("k1", "v1"), ("k2", "v2") ]+--   > -- ↪ "[ k1 → v1, k2 → v2 ]"+ppListMap :: (Pretty a, Pretty b) => [(a, b)] → PrettyM ()+ppListMap = ppList . map (\(a,b) → a ~> "→" ~> b)++-- | Print a @Data.Map@ in the same way as 'ppListMap'.+ppMap :: (Pretty a, Pretty b) => M.Map a b → PrettyM ()+ppMap = ppListMap . M.assocs++-- | Print a horizontal bar consisting of a 'Char' as long as 'cMaxLineWidth'+--   (or 80 if it is @Nothing@).+--+--   Example:+--+--   > pretty defConfig $ bar '-'+--   > -- ↪ "-----------------------------------------…"+bar :: Char → PrettyM ()+bar c = do+  w ← maybe 80 id <$> use maxLineWidth+  pp $ replicate w c++-- | Print a horizontal bar consisting of a 'Char' as long as 'cMaxLineWidth'+--   (or 80 if it is @Nothing@). The horizontal bar has a title 'String' printed+--   at column 6.+--+--   Example:+--+--   > pretty defConfig $ titleBar '-' "Foo"+--   > -- ↪ "----- Foo -------------------------------…"+titleBar :: Pretty a => Char → a → PrettyM ()+titleBar c s = do+  w ← maybe 80 id <$> use maxLineWidth+  replicate 5 c ~> s ~> replicate (w - (7 + length (pretty (pure ()) s))) c +> "\n"++-- | Print a newline (line break).+nl :: PrettyM ()+nl = pp "\n"++-- | Print a space.+sp :: PrettyM ()+sp = pp " "
+ src/Printcess/Config.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE+  TemplateHaskell, UnicodeSyntax+#-}++module Printcess.Config where++import Control.Monad.State.Strict+import Control.Lens++-- | A 'Config' allows to specify various pretty printing options, e.g.+-- the maximum line width.+--+-- As the rendering functions, like 'pretty', take updates to an internal+-- default 'Config', only the lenses of the 'Config' fields are exported.+--+-- A custom 'Config' can be specified as in the following example:+--+-- > foo :: String+-- > foo = pretty config "foo bar baz"+-- >   where config :: State Config ()+-- >         config = do cMaxLineWidth      .= Just 6+-- >                     cInitIndent        .= 2+-- >                     cIndentAfterBreaks .= 0+data Config = Config+  { _configMaxLineWidth      :: Maybe Int+  , _configInitPrecedence    :: Int+  , _configInitIndent        :: Int+  , _configIndentChar        :: Char+  , _configIndentDepth       :: Int+  , _configIndentAfterBreaks :: Int+  }++def :: Config+def = Config+  { _configMaxLineWidth      = Just 80+  , _configInitPrecedence    = -1+  , _configInitIndent        = 0+  , _configIndentChar        = ' '+  , _configIndentDepth       = 2+  , _configIndentAfterBreaks = 4+  }++-- | Leaves the default @Config@ unchanged and returns @()@.+--+-- Convenience function defined as:+--+-- > defConfig = pure ()+--+-- See example in 'pretty'.+defConfig :: State Config ()+defConfig = pure ()++makeLenses ''Config++-- | When a line gets longer, it is broken after the latest space,+--   that still allows the line to remain below this maximum.+--+--   If there is no such space, an over-long line with a single indented word is+--   printed.+--+--   This guarantees both progress and not to break identifiers into parts.+--+--   Default: @Just 80@+cMaxLineWidth :: Lens' Config (Maybe Int)+cMaxLineWidth = configMaxLineWidth++-- | The character used for indentation.+--   Usually @' '@ for spaces or @'\t'@ for tabs.+--+--   Default: @' '@+cIndentChar :: Lens' Config Char+cIndentChar = configIndentChar++-- | How many 'cIndentChar' characters for one indentation level.+--+--   Default: @2@+cIndentDepth :: Lens' Config Int+cIndentDepth = configIndentDepth++-- | How many 'cIndentChar' characters to indent additionally, when a line break+--   occurs, because 'cMaxLineWidth' was exceeded.+--+--   Assuming the line to print has to be broken multiple times, the+--   indentation of all resulting lines, except the first one, is increased by this amount.+--   For example+--+--   > pretty (do cMaxLineWidth .= Just 8; cIndentAfterBreaks .= 4) "foo bar baz boo"+--   evaluates to+--+--   > foo bar+--   >     baz+--   >     boo+--+--   Default: @4@+cIndentAfterBreaks :: Lens' Config Int+cIndentAfterBreaks = configIndentAfterBreaks++-- | Indentation level to start pretty printing with.+--+--   Default: @0@+cInitIndent :: Lens' Config Int+cInitIndent = configInitIndent++-- | Precendence level to start pretty printing with.+--+--  Default: @(-1)@+cInitPrecedence :: Lens' Config Int+cInitPrecedence = configInitPrecedence
+ src/Printcess/Core.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE+  DefaultSignatures, FlexibleInstances, GeneralizedNewtypeDeriving,+  KindSignatures, LambdaCase, MultiWayIf, TemplateHaskell, UnicodeSyntax+#-}++module Printcess.Core where++import Control.Monad.State.Strict+import Control.Lens+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))++import Printcess.Config++-- Associativity ---------------------------------------------------------------++data Assoc = AssocN | AssocL | AssocR+  deriving (Eq, Ord, Read, Show)++-- Pretty Printing State -------------------------------------------------------++data PrettySt = PrettySt+  { _indentation       :: Int+  , _precedence        :: Int+  , _assoc             :: Assoc+  , _maxLineWidth      :: Maybe Int+  , _text              :: NE.NonEmpty String+  , _indentChar        :: Char+  , _indentDepth       :: Int+  , _indentAfterBreaks :: Int+  }++stFromConfig :: Config → PrettySt+stFromConfig c = PrettySt+  { _indentation       = _configInitIndent c+  , _precedence        = _configInitPrecedence c+  , _assoc             = AssocN+  , _maxLineWidth      = _configMaxLineWidth c+  , _text              = "" :| []+  , _indentChar        = _configIndentChar c+  , _indentDepth       = _configIndentDepth c+  , _indentAfterBreaks = _configIndentAfterBreaks c+  }++makeLenses ''PrettySt++-- Pretty Printing -------------------------------------------------------------++-- | Render a 'Pretty' printable @a@ to 'String' using a 'Config', that+--   specifies how the @a@ should be rendered. For example+--+--   > pretty defConfig (1 :: Int)  -- evaluates to "1"+pretty+  :: Pretty a+  => State Config () -- ^ Updates for the default pretty printing 'Config'.+  -> a               -- ^ A 'Pretty' printable @a@.+  -> String          -- ^ The pretty printed @a@.+pretty c+  = concat+  . (`sepByList` "\n")+  . reverse+  . NE.toList+  . view text+  . (`execState` stFromConfig (execState c def))+  . runPrettyM+  . pp++-- | Render a 'Pretty' printable @a@ to @stdout@ using a 'Config', that+--   specifies how the @a@ should be rendered.+--+--   Convenience function, defined as:+--+--   > prettyPrint c = liftIO . putStrLn . pretty c+prettyPrint+  :: (MonadIO m, Pretty a)+  => State Config () -- ^ Updates for the default pretty printing 'Config'.+  -> a               -- ^ A 'Pretty' printable @a@.+  -> m ()            -- ^ An 'IO' action pretty printing the @a@ to @stdout@.+prettyPrint c =+  liftIO . putStrLn . pretty c++-- Type Classes ----------------------------------------------------------------++-- | Instanciating this class for a type, declares how values of that type+-- should be pretty printed.+--+-- As pretty printing may depend on some context, e.g. the current indentation+-- level, a 'State' monad for pretty printing ('PrettyM') is used.+--+-- A default implementation is provided copying behavior from a 'Show' instance.+-- This can be convenient for deriving 'Pretty', e.g. for base types or+-- debugging. The default implementation is defined by @pp = pp . show@.+class Pretty a where+  -- | Pretty print an @a@ as a 'PrettyM' action.+  pp :: a → PrettyM ()++  default+    pp :: Show a => a → PrettyM ();+    pp = pp . show++head1L :: Lens' (NE.NonEmpty a) a+head1L = lens NE.head (\(_ :| xs) x → x :| xs)++tail1L :: Lens' (NE.NonEmpty a) [a]+tail1L = lens NE.tail (\(x :| _) xs → x :| xs)++charsBeforeWord :: Int -> (Char -> Bool) -> String -> Int+charsBeforeWord nWords0 cIndent s0 =+  go s0 nWords0+ where+  go s n =+    length sIndent + if n == 0 then 0 else length sWord + go sAfterWord (n-1)+   where+    (sIndent, sBeforeWord) = break (not . cIndent) s+    (sWord, sAfterWord) = break cIndent sBeforeWord++charsBeforeWordM :: Int -> PrettyM Int+charsBeforeWordM n0 = do+  cIndent ← use indentChar+  curText ← use $ text . head1L+  pure $ charsBeforeWord n0 (`elem` [' ', '\t', cIndent]) curText++-- Isomorphic lines and unlines implementations+lines' :: String → [String]+lines' = go "" where+  go s = \case+    ""               → [s]+    c:cs | c == '\n' → s : go "" cs+         | otherwise → go (s++[c]) cs++unlines' :: [String] → String+unlines' = \case+  []   → ""+  [x]  → x+  x:xs → x ++ '\n' : unlines' xs++isWS, isNoWS :: Char → Bool+isWS   = (`elem` [' ', '\t'])+isNoWS = not . isWS++dropWhileEnd :: (a → Bool) → [a] → [a]+dropWhileEnd f = reverse . dropWhile f . reverse++-- | In contrast to 'Show', @"foo"@ is printed as @"foo"@ and not @"\\"foo\\""@.+-- Most of the other instances are defined in terms of this instance.+-- If the 'String' contains newline characters (@'\n'@), indentation is inserted+-- automatically afterwards.+-- If the current line gets too long, it is automatically broken.+instance Pretty String where+  pp = go . lines' where+    go :: [String] -> PrettyM ()+    go []     = pure ()+    go [s]    = ppLine True s+    go (s:ss) = do ppLine True s; text %= ("" NE.<|); go ss++    ppLine :: Bool -> String -> PrettyM ()+    ppLine first s = do+      oldLine ← use $ text . head1L+      when (null oldLine) addIndent+      text . head1L %= (++s)+      curLine ← use $ text . head1L+      -- We have to allow at least indentation + 1 word, otherwise indenting after+      -- line break due to line continuation can cause infinite loop+      mMaxLineLength ← use maxLineWidth+      forM_ mMaxLineLength $ \maxLineLength → do+        maxLineLength' ← max <$> charsBeforeWordM 1 <*> pure maxLineLength+        when (length curLine > maxLineLength') $ do+          let (curLine', lineRest) = splitAt maxLineLength curLine -- length s1 == maxLineLength+          let (wordRest, curLine'')+                | isNoWS (head lineRest)+                  = both %~ reverse $ break (==' ') $ reverse curLine'+                | otherwise+                  = ("", curLine')+          text . head1L .= dropWhileEnd isWS curLine''+          -- Increase indentation once after the first forced line break, this results into:+          --   this line was too long+          --       still the first line+          --       it won't stop+          i ← use indentAfterBreaks+          let f | first     = indentedByChars i+                | otherwise = id+          f $ do text %= ("" NE.<|); ppLine False $ dropWhile isWS $ wordRest ++ lineRest++-- | In contrast to 'Show', @\'c\'@ is printed as @"c"@ and not @"\'c\'"@.+instance Pretty Char   where pp = pp . (:"")++-- | Behaves like 'Show': @1@ is printed to @"1"@.+instance Pretty Int++-- | Behaves like 'Show': @1.2@ is printed to @"1.2"@.+instance Pretty Float++-- | Behaves like 'Show': @1.2@ is printed to @"1.2"@.+instance Pretty Double++-- -- | Print a map @M.fromList [("k1","v1"), ("k2","v2")]@+-- -- as @"[ k1 → v1, k2 → v2 ]"@.+-- instance (Pretty k, Pretty v) => Pretty (M.Map k v) where+--   pp = foldl pp' (pp "") . M.toList where+--     pp' s (k, v) = s +> k ~> "=>" ~> indented v +> nl++-- | The 'Pretty1' type class lifts 'Pretty' printing to unary type constructors.+--   It can be used in special cases to abstract over type constructors which+--   are 'Pretty' printable for any 'Pretty' printable type argument.+class Pretty1 f where+  pp1 :: Pretty a => f a → PrettyM ()+  default pp1 :: Pretty (f a) => f a -> PrettyM ()+  pp1 = pp++-- | The 'Pretty2' type class lifts 'Pretty' printing to binary type constructors.+--   It can be used in special cases to abstract over type constructors which+--   are 'Pretty' printable for any 'Pretty' printable type arguments.+class Pretty2 (f :: * → * → *) where+  pp2 :: (Pretty a, Pretty b) => f a b → PrettyM ()+  default pp2 :: Pretty (f a b) => f a b -> PrettyM ()+  pp2 = pp++-- Pretty Monad ----------------------------------------------------------------++-- | The 'PrettyM' monad is run in the pretty printing process, e.g. in+-- 'pretty' or 'prettyPrint'.+--+-- 'PrettyM' is internally a 'State' monad manipulating a 'Config' and a list of+-- pretty printed lines.+--+-- Most of the combinators from this library take values of 'Pretty' printable types,+-- convert them to @'PrettyM' ()@ actions using 'pp', and combine the actions in+-- some way resulting in a new @'PrettyM' ()@ action.+newtype PrettyM a = PrettyM { runPrettyM :: State PrettySt a }+  deriving (Functor, Applicative, Monad, MonadState PrettySt)++-- | This instance makes it possible to nest operators like @('+>')@.+-- Implemented as: @pp = id@+instance Pretty (PrettyM ()) where pp = id+++sepByList :: [[a]] → [a] → [[a]]+sepByList []  _    = []+sepByList [s] _    = [s]+sepByList (s:ss) s' = s : s' : sepByList ss s'++addIndent :: PrettyM ()+addIndent = do+  i <- use indentation+  c <- use indentChar+  text . head1L %= (++ replicate i c)++-- Indentation -----------------------------------------------------------------++indentByChars+  :: Int+  -> PrettyM ()+indentByChars =+  (indentation +=)++indentByLevels+  :: Int+  -> PrettyM ()+indentByLevels i =+  (indentation +=) . (i *) =<< use indentDepth++-- | Print an @a@ with indentation increased by a certain amount of+--   'cIndentChar' characters.+--+--   Example:+--+--   > pretty defConfig $+--   >   "while (true) {" \>+--   >   indentedByChars 2 ("f();" \> "g();") \>+--   >   "}"+--   > -- ↪ "while (true) {+--   > --      f();+--   > --      g();+--   > --    }"+indentedByChars+  :: Pretty a+  => Int         -- ^ Number of characters to increase indentation.+  -> a           -- ^ A 'Pretty' printable @a@+  -> PrettyM ()  -- ^ An action printing the @a@ with increased indentation.+indentedByChars i a = do+  indentByChars i+  pp a+  indentByChars (-i)++-- | Same as 'indentedByChars' but increases indentation in 'cIndentDepth' steps.+indentedBy+  :: Pretty a+  => Int          -- ^ Number of indentation levels to increase.+                  --   One indentation level consists of 'cIndentDepth' characters.+  -> a            -- ^ A 'Pretty' printable @a@+  -> PrettyM ()   -- ^ An action printing the @a@ with increased indentation.+indentedBy i a = do+  indentByLevels i+  pp a+  indentByLevels (-i)++-- | Convenience function defined as:+--+-- > indented = indentedBy 1+indented+  :: Pretty a+  => a           -- ^ A 'Pretty' printable @a@+  -> PrettyM ()  -- ^ An action printing the @a@ indented 1 level deeper.+indented =+  indentedBy 1++indentToCurPos :: PrettyM ()+indentToCurPos = do+  curLine ← use $ text . head1L+  indentation .= length curLine++indentedToCurPos :: PrettyM a → PrettyM a+indentedToCurPos ma = do+  i ← use indentation+  indentToCurPos+  a ← ma+  indentation .= i+  pure a++-- Associativity & Fixity ------------------------------------------------------++withPrecedence :: (Assoc, Int) → PrettyM () → PrettyM ()+withPrecedence (a, p) ma = do+  p' ← use precedence+  a' ← use assoc+  precedence .= p+  assoc .= a+  if | p' == p && a' == a && a /= AssocN → ma+     | p' < p    → ma+     | otherwise → do pp "("; ma; pp ")"+  precedence .= p'+  assoc .= a'++-- | Print an @a@ as a left-associative operator of a certain fixity.+assocL :: Pretty a => Int → a → PrettyM ()+assocL i = withPrecedence (AssocL, i) . pp++-- | Print an @a@ as a right-associative operator of a certain fixity.+assocR :: Pretty a => Int → a → PrettyM ()+assocR i = withPrecedence (AssocR, i) . pp++-- | Print an @a@ as a non-associative operator of a certain fixity.+assocN :: Pretty a => Int → a → PrettyM ()+assocN i = withPrecedence (AssocN, i) . pp++-- | The constructors of this type can be used as short forms of 'left',+-- 'right', and 'inner'.+data AssocAnn a+  = L a -- ^ Print an @a@ as the left  argument of a mixfix operator (behaves like 'left').+  | R a -- ^ Print an @a@ as the right argument of a mixfix operator (behaves like 'right').+  | I a -- ^ Print an @a@ as the inner argument of a mixfix operator (behaves like 'inner').+  deriving (Eq, Ord, Read, Show)++instance Pretty1 AssocAnn++-- | Let the associativity annotations for arguments ('L', 'R', 'I')+-- behave as the 'left', 'right', and 'inner' functions.+instance Pretty a => Pretty (AssocAnn a) where+  pp = \case+    L a → left a+    R a → right a+    I a → inner a++-- | Print an @a@ as the left argument of a mixfix operator.+left :: Pretty a => a → PrettyM ()+left = assocDir AssocL++-- | Print an @a@ as the right argument of a mixfix operator.+right :: Pretty a => a → PrettyM ()+right = assocDir AssocR++-- | Print an @a@ as an inner argument of a mixfix operator.+inner :: Pretty a => a → PrettyM ()+inner ma = do+  p' ← use precedence+  a' ← use assoc+  precedence .= (-1)+  assoc .= AssocN+  pp ma+  precedence .= p'+  assoc .= a'++assocDir :: Pretty a => Assoc → a → PrettyM ()+assocDir a ma = do+  a' ← use assoc+  if | a' == a → pp ma+     | otherwise → do+       assoc .= AssocN+       pp ma+       assoc .= a'
+ src/Printcess/PrettyPrinting.hs view
@@ -0,0 +1,125 @@+module Printcess.PrettyPrinting (+  -- * Overview+  -- $overview++  -- * Example+  -- $example++  -- * Rendering+  pretty,+  prettyPrint,++  -- * Config+  Config,+  cMaxLineWidth, cIndentChar, cIndentDepth, cIndentAfterBreaks,+  cInitIndent, cInitPrecedence,+  defConfig,++  -- * Type Class+  Pretty(..),++  -- * Monad+  PrettyM,++  -- * Sequencing+  (+>), (~>), (\>),++  -- * Indentation+  indentedByChars, indentedBy, indented,+  block, block',++  -- * Associativity & Fixity+  assocL, assocR, assocN,+  left, right, inner, AssocAnn(..),++  -- * Folding @Pretty@ Things+  betweenEach, beforeEach, afterEach,+  ppList, ppListMap, ppMap,++  -- * Other combinators+  bar, titleBar,++  -- * Constants+  nl, sp,++  -- * Lifted Type Classes+  Pretty1(..), Pretty2(..),++  -- * Reexports+  State, (.=),+  ) where++import Control.Monad.State.Strict+import Control.Lens++import Printcess.Config+import Printcess.Core+import Printcess.Combinators++{- $overview+    The main features of the @printcess@ pretty printing library are++    *   /Indentation/. Printing-actions are relative to the indentation level+        of their context. Special actions can be used to control the indentation+        level. Indentation is automatically inserted after newlines.++    *   /Automatic parenthesizing of mixfix operators/.+        Special printing-actions can be used to specify the associativity+        and fixity of operators and to mark the positions of their arguments.+        This makes it easy to print for example @"λx. λy. x y (x y)"@+        instead of @"(λx. (λy. ((x y) (x y))))"@.++    *   /Automatic line breaks after exceeding a maximum line width/.+        A maximum line width can be specified, after which lines are+        automatically broken. If the break point is inside a word,+        it is moved to the left until a white space character is reached.+        This avoids splitting identifiers into two.+-}++{- $example+    In this section, a small example is presented, which pretty prints a+    lambda calculus expression.++    First we define an abstract syntax tree for lambda calculus expressions.++    > data Expr+    >   = EVar String+    >   | EAbs String Expr+    >   | EApp Expr Expr++    Then we make @Expr@ an instance of the 'Pretty' type class, which+    declares one method 'pp'. This method takes an @Expr@ and returns a+    'PrettyM' @()@ action, which describes how to 'pretty' print the @Expr@.++    > instance Pretty Expr where+    >   pp (EVar x)     = pp x+    >   pp (EApp e1 e2) = assocL 9 $ L e1 ~> R e2+    >   pp (EAbs x e)   = assocR 0 $ "λ" +> I x +> "." ~> R e++    We print++    *   a variable @EVar x@ by printing the identifier 'String' @x@.++    *   a function application @EApp e1 e2@ as a left-associative operator of+        fixity 9 ('assocL' @9@), where e1 is the left argument ('L') and @e2@ is+        the right argument ('R'). The ('~>') combinator separates its first+        argument with a space from its second argument.++    *   a function abstraction @EAbs x e@ as a right-associative operator of+        fixity 0 ('assocR' @0@), where @x@ is an inner+        argument ('I') and @e@ is the right argument ('R').+        The ('+>') combinator behaves as ('~>'), but without inserting a space.++    Then we define a simple test expression @e1@ representing @λx. λy. x y (x y)@++    > e1 :: Expr+    > e1 = EAbs "x" $ EAbs "y" $ EApp (EApp (EVar "x") (EVar "y"))+    >                                 (EApp (EVar "x") (EVar "y"))++    and pretty print it to 'String' using the 'pretty' function++    > s1, s2 :: String+    > s1 = pretty defConfig                  e1    -- evaluates to "λx. λy. x y (x y)"+    > s2 = pretty (cMaxLineWidth .= Just 12) e1    -- evaluates to "λx. λy. x y+    >                                              --                   (x y)"+-}
+ test/Spec.hs view
@@ -0,0 +1,93 @@+{-# lANGUAGE LambdaCase #-}++import Test.Hspec+import Printcess.PrettyPrinting+import Control.Lens++main :: IO ()+main = hspec $ do+  describe "basic" $ do+    it "prints a string" $+      pretty defConfig+        "foo" `shouldBe`+        "foo"+    it "handles newlines" $+      pretty defConfig+        "foo\nbar" `shouldBe`+        "foo\nbar"+    it "indents after newlines" $+      pretty defConfig+        (indented "foo\nbar") `shouldBe`+        "  foo\n  bar"+    it "respects initial indentation" $+      pretty (cInitIndent .= 2)+        "foo\nbar" `shouldBe`+        "  foo\n  bar"++  describe "automatic line breaks" $ do+    it "breaks too long lines" $+      pretty (cMaxLineWidth .= Just 10)+        "foo bar baz boo" `shouldBe`+        "foo bar\n    baz\n    boo"+    it "breaks too long lines" $+      pretty (cMaxLineWidth .= Just 11)+        "foo bar baz boo" `shouldBe`+        "foo bar baz\n    boo"+    it "breaks too long lines twice" $+      pretty (cMaxLineWidth .= Just 10)+        "foo bar baz boo r" `shouldBe`+        "foo bar\n    baz\n    boo r"+    it "breaks too long lines four times" $+      pretty (cMaxLineWidth .= Just 10)+        "foo bar baz boo raz roo" `shouldBe`+        "foo bar\n    baz\n    boo\n    raz\n    roo"+    it "breaks too long lines" $+      pretty (cMaxLineWidth .= Just 11)+        "foo bar baz boo r" `shouldBe`+        "foo bar baz\n    boo r"+    it "breaks too long lines twice" $+      pretty (cMaxLineWidth .= Just 11)+        "foo bar baz boo raz roo" `shouldBe`+        "foo bar baz\n    boo raz\n    roo"+    it "breaks too long lines" $+      pretty (cMaxLineWidth .= Just 12)+        "foo bar baz boo r" `shouldBe`+        "foo bar baz\n    boo r"+    it "breaks too long lines & setting indentChar works" $+      pretty (do cMaxLineWidth .= Just 10; cIndentChar .= '~')+        "foo bar baz boo r" `shouldBe`+        "foo bar\n~~~~baz\n~~~~boo r"+    it "removes spaces around broken lines" $+      pretty (cMaxLineWidth .= Just 10)+        "foo bar        baz boo" `shouldBe`+        "foo bar\n    baz\n    boo"++  describe "Lambda Calculus" $ do+    it "respects associativity" $+      pretty defConfig+        e1 `shouldBe`+        "λx. λy. x y (x y)"++  describe "Blocks" $ do+    it "blocks starting on next line" $+      pretty defConfig+        ("do" ~> block [ "ma", "mb" ]) `shouldBe`+        "do \n  ma\n  mb"+    it "blocks starting on same line" $+      pretty defConfig+        ("do" ~> block' [ "ma", "mb" ]) `shouldBe`+        "do ma\n   mb"++data Expr+  = EVar String+  | EAbs String Expr+  | EApp Expr Expr++instance Pretty Expr where+  pp = \case+    EVar x     -> pp x+    EAbs x e   -> assocR 0 $ "λ" +> x +> "." ~> R e+    EApp e1 e2 -> assocL 9 $ L e1 ~> R e2++e1 = EAbs "x" $ EAbs "y" $ EApp (EApp (EVar "x") (EVar "y"))+                                (EApp (EVar "x") (EVar "y"))