prettyprinter 1.2.1.1 → 1.3.0
raw patch · 13 files changed
+150/−98 lines, 13 filesdep +base-compatdep +faildep +ghc-primdep ~QuickCheckdep ~basedep ~semigroups
Dependencies added: base-compat, fail, ghc-prim
Dependency ranges changed: QuickCheck, base, semigroups
Files
- CHANGELOG.md +4/−2
- bench/LargeOutput.hs +5/−6
- misc/version-compatibility-macros.h +4/−1
- prettyprinter.cabal +18/−9
- src/Data/Text/Prettyprint/Doc.hs +6/−0
- src/Data/Text/Prettyprint/Doc/Internal.hs +67/−43
- src/Data/Text/Prettyprint/Doc/Render/Text.hs +1/−2
- src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +3/−4
- src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs +6/−5
- src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +18/−19
- src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs +6/−3
- test/Testsuite/Main.hs +2/−3
- test/Testsuite/StripTrailingSpace.hs +10/−1
CHANGELOG.md view
@@ -1,6 +1,8 @@-# 1.2.1.1+# 1.3.0 -- Fix dependency of doctest suite+- Add alignment to Pretty [a] instance+- Fix removal of blank lines in `removeTrailingWhitespace`+- Widened support for GHC versions 7.4–8.8 # 1.2.1
bench/LargeOutput.hs view
@@ -1,21 +1,20 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where -+import Prelude ()+import Prelude.Compat import Control.DeepSeq-import Control.Monad+import Control.Monad.Compat import Criterion import Criterion.Main import Data.Char import Data.Map (Map) import qualified Data.Map as M-import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -98,7 +97,7 @@ prettyExp = (<+> pretty body) instance Pretty Expr where- pretty = \case+ pretty = \expr -> case expr of Let binds body -> align (vsep [ "let" <+> align (pretty binds) , "in" <+> pretty body ])@@ -141,7 +140,7 @@ prettyExp = (WL.<+> WL.pretty body) instance WL.Pretty Expr where- pretty = \case+ pretty = \expr -> case expr of Let binds body -> WL.align (WL.vsep [ "let" WL.<+> WL.align (WL.pretty binds) , "in" WL.<+> WL.pretty body ])
misc/version-compatibility-macros.h view
@@ -14,7 +14,10 @@ #define MONOID_IN_PRELUDE MIN_VERSION_base(4,8,0) #define NATURAL_IN_BASE MIN_VERSION_base(4,8,0) -#define MONAD_FAIL MIN_VERSION_base(4,9,0) #define SEMIGROUP_IN_BASE MIN_VERSION_base(4,9,0)++#define SEMIGROUP_MONOID_SUPERCLASS MIN_VERSION_base(4,11,0)++#define NO_FAIL_IN_MONAD_MONAD_FAIL MIN_VERSION_base(4,13,0) #endif
prettyprinter.cabal view
@@ -1,5 +1,5 @@ name: prettyprinter-version: 1.2.1.1+version: 1.3.0 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible pretty-printer.@@ -56,20 +56,22 @@ other-extensions: BangPatterns , CPP- , LambdaCase , OverloadedStrings- , QuasiQuotes , DefaultSignatures , ScopedTypeVariables build-depends:- base >= 4.7 && < 5+ base >= 4.5 && < 5 , text >= 1.2 + if !impl(ghc >= 7.6)+ build-depends: ghc-prim+ if impl(ghc >= 8.0) ghc-options: -Wcompat if !impl(ghc >= 8.0) build-depends: semigroups >= 0.1+ build-depends: fail >= 4.9.0.0 if !impl(ghc >= 7.10) build-depends: void @@ -93,6 +95,7 @@ other-modules: MultilineTh other-extensions: OverloadedStrings , TemplateHaskell+ , QuasiQuotes if flag(buildReadme) buildable: True else@@ -107,7 +110,6 @@ build-depends: base >= 4.7 && < 5 , doctest >= 0.9- , QuickCheck ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 if impl (ghc < 7.10)@@ -142,7 +144,7 @@ hs-source-dirs: bench main-is: Fusion.hs build-depends:- base >= 4.7 && < 5+ base >= 4.5 && < 5 , prettyprinter , criterion >= 1.1@@ -153,11 +155,11 @@ , ansi-wl-pprint >= 0.6 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010- other-extensions: NumDecimals, OverloadedStrings+ other-extensions: OverloadedStrings benchmark faster-unsafe-text build-depends:- base >= 4.7 && < 5+ base >= 4.5 && < 5 , prettyprinter , criterion >= 1.1@@ -172,7 +174,8 @@ benchmark large-output build-depends:- base >= 4.7 && < 5+ base >= 4.5 && < 5+ , base-compat >=0.9.3 && <0.11 , prettyprinter , ansi-wl-pprint @@ -187,3 +190,9 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 type: exitcode-stdio-1.0++ if !impl(ghc >= 7.6)+ build-depends: ghc-prim++ if !impl(ghc >= 8.0)+ build-depends: semigroups
src/Data/Text/Prettyprint/Doc.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}++#include "version-compatibility-macros.h"+ -- | -- Module : Data.Text.Prettyprint.Doc -- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan@@ -287,7 +291,9 @@ +#if !(SEMIGROUP_MONOID_SUPERCLASS) import Data.Semigroup+#endif import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Symbols.Ascii
src/Data/Text/Prettyprint/Doc/Internal.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -30,6 +29,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as Lazy+import Data.Typeable (Typeable) import Data.Void import Data.Word import GHC.Generics (Generic)@@ -132,7 +132,7 @@ -- | Add an annotation to the enclosed 'Doc'. Can be used for example to add -- styling directives or alt texts that can then be used by the renderer. | Annotated ann (Doc ann)- deriving (Generic)+ deriving (Generic, Typeable) -- | -- @@@ -197,10 +197,24 @@ -- >>> prettyList [1, 23, 456] -- [1, 23, 456] prettyList :: [a] -> Doc ann- prettyList = list . map pretty+ prettyList = align . list . map pretty {-# MINIMAL pretty #-} +-- $+-- Issue #67: Nested lists were not aligned with »pretty«, leading to non-pretty+-- output, violating the Pretty class law.+--+-- >>> pretty (replicate 2 (replicate 4 (1, replicate 8 2)))+-- [ [ (1, [2, 2, 2, 2, 2, 2, 2, 2])+-- , (1, [2, 2, 2, 2, 2, 2, 2, 2])+-- , (1, [2, 2, 2, 2, 2, 2, 2, 2])+-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ]+-- , [ (1, [2, 2, 2, 2, 2, 2, 2, 2])+-- , (1, [2, 2, 2, 2, 2, 2, 2, 2])+-- , (1, [2, 2, 2, 2, 2, 2, 2, 2])+-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] ]+ instance Pretty a => Pretty (Const a b) where pretty = pretty . getConst @@ -232,9 +246,8 @@ -- | >>> pretty True -- True instance Pretty Bool where- pretty = \case- True -> "True"- False -> "False"+ pretty True = "True"+ pretty False = "False" -- | Instead of @('pretty' '\n')@, consider using @'line'@ as a more readable -- alternative.@@ -286,7 +299,7 @@ instance Pretty Float where pretty = unsafeViaShow -- | >>> pretty (exp 1 :: Double)--- 2.718281828459045+-- 2.71828182845904... instance Pretty Double where pretty = unsafeViaShow -- | >>> pretty (123, "hello")@@ -532,7 +545,7 @@ -- if the document is static (e.g. contains only a plain 'Empty' node). See -- [Group: special flattening] for further explanations. changesUponFlattening :: Doc ann -> Maybe (Doc ann)-changesUponFlattening = \case+changesUponFlattening = \doc -> case doc of FlatAlt _ y -> Just (flatten y) Line -> Just Fail Union x _ -> changesUponFlattening x <|> Just x@@ -556,7 +569,7 @@ where -- Flatten, but don’t report whether anything changes. flatten :: Doc ann -> Doc ann- flatten = \case+ flatten = \doc -> case doc of FlatAlt _ y -> flatten y Cat x y -> Cat (flatten x) (flatten y) Nest i x -> Nest i (flatten x)@@ -1230,7 +1243,7 @@ alterAnnotations :: (ann -> [ann']) -> Doc ann -> Doc ann' alterAnnotations re = go where- go = \case+ go = \doc -> case doc of Fail -> Fail Empty -> Empty Char c -> Char c@@ -1256,7 +1269,7 @@ unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx unAnnotateS = go where- go = \case+ go = \doc -> case doc of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go rest)@@ -1269,7 +1282,7 @@ reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' reAnnotateS re = go where- go = \case+ go = \doc -> case doc of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go rest)@@ -1279,6 +1292,7 @@ SAnnPush ann rest -> SAnnPush (re ann) (go rest) data AnnotationRemoval = Remove | DontRemove+ deriving Typeable -- | Change the annotation of a document to a different annotation, or none at -- all. 'alterAnnotations' for 'SimpleDocStream'.@@ -1292,7 +1306,7 @@ where -- We keep a stack of whether to remove a pop so that we can remove exactly -- the pops corresponding to annotations that mapped to Nothing.- go stack = \case+ go stack = \sds -> case sds of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go stack rest)@@ -1323,7 +1337,7 @@ -- This value should only be used if profiling shows it is significantly -- faster than using 'Shallow'. | Deep- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable) -- | @('fuse' depth doc)@ combines text nodes so they can be rendered more -- efficiently. A fused document is always laid out identical to its unfused@@ -1355,7 +1369,7 @@ fuse :: FusionDepth -> Doc ann -> Doc ann fuse depth = go where- go = \case+ go = \doc -> case doc of Cat Empty x -> go x Cat x Empty -> go x Cat (Char c1) (Char c2) -> Text 2 (T.singleton c1 <> T.singleton c2)@@ -1426,7 +1440,7 @@ -- | Remove a previously pushed annotation. | SAnnPop (SimpleDocStream ann)- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Show, Generic, Typeable) -- | Remove all trailing space characters. --@@ -1438,21 +1452,17 @@ -- whitespace, for example a renderer that colors the background of trailing -- whitespace, as e.g. @git diff@ can be configured to do. removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann-removeTrailingWhitespace = go (WssWithheldWhitespace Nothing 0)+removeTrailingWhitespace = go (WssWithheldWhitespace [] 0) where- commitSpaces :: Maybe Int -> Int -> SimpleDocStream ann -> SimpleDocStream ann- commitSpaces mWithheldNewline withheldSpaces = nl . sp- where- nl = case mWithheldNewline of- Just withheldLine -> SLine withheldLine- Nothing -> id- sp = case withheldSpaces of- 0 -> id- 1 -> SChar ' '- n -> SText n (T.replicate n " ")+ commitSpaces :: [Int] -> Int -> SimpleDocStream ann -> SimpleDocStream ann+ commitSpaces [] 0 = id+ commitSpaces [] 1 = SChar ' '+ commitSpaces [] n = SText n (T.replicate n " ")+ commitSpaces [i] _ = SLine i+ commitSpaces (_:is) _ = SLine 0 . commitSpaces is 0 go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann- go annLevel@(WssAnnotationLevel annotationLevel) = \case+ go annLevel@(WssAnnotationLevel annotationLevel) = \sds -> case sds of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go annLevel rest)@@ -1461,31 +1471,43 @@ SAnnPush ann rest -> SAnnPush ann (go (WssAnnotationLevel (annotationLevel+1)) rest) SAnnPop rest | annotationLevel > 1 -> SAnnPop (go (WssAnnotationLevel (annotationLevel-1)) rest)- | otherwise -> SAnnPop (go (WssWithheldWhitespace Nothing 0) rest)- go (WssWithheldWhitespace withheldLine withheldSpaces) = \case+ | otherwise -> SAnnPop (go (WssWithheldWhitespace [] 0) rest)+ go (WssWithheldWhitespace withheldLines withheldSpaces) = \sds -> case sds of SFail -> SFail SEmpty -> SEmpty SChar c rest- | c == ' ' -> go (WssWithheldWhitespace withheldLine (withheldSpaces+1)) rest- | otherwise -> commitSpaces withheldLine withheldSpaces (SChar c (go (WssWithheldWhitespace Nothing 0) rest))+ | c == ' ' -> go (WssWithheldWhitespace withheldLines (withheldSpaces+1)) rest+ | otherwise -> commitSpaces withheldLines withheldSpaces (SChar c (go (WssWithheldWhitespace [] 0) rest)) SText textLength text rest -> let stripped = T.dropWhileEnd (== ' ') text strippedLength = T.length stripped trailingLength = textLength - strippedLength isOnlySpace = strippedLength == 0 in if isOnlySpace- then go (WssWithheldWhitespace withheldLine (withheldSpaces + textLength)) rest- else commitSpaces withheldLine withheldSpaces (SText strippedLength stripped (go (WssWithheldWhitespace Nothing trailingLength) rest))- SLine i rest -> go (WssWithheldWhitespace (Just i) 0) rest- SAnnPush ann rest -> commitSpaces withheldLine withheldSpaces (SAnnPush ann (go (WssAnnotationLevel 1) rest))+ then go (WssWithheldWhitespace withheldLines (withheldSpaces + textLength)) rest+ else commitSpaces withheldLines withheldSpaces (SText strippedLength stripped (go (WssWithheldWhitespace [] trailingLength) rest))+ SLine i rest -> go (WssWithheldWhitespace (i:withheldLines) 0) rest+ SAnnPush ann rest -> commitSpaces withheldLines withheldSpaces (SAnnPush ann (go (WssAnnotationLevel 1) rest)) SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'." data WhitespaceStrippingState = WssAnnotationLevel !Int- | WssWithheldWhitespace (Maybe Int) !Int+ | WssWithheldWhitespace [Int] !Int+ -- ^ [Newline with indentation i] Spaces+ deriving Typeable +-- $+-- >>> import qualified Data.Text.IO as T+-- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum"+-- >>> go = T.putStrLn . renderStrict . removeTrailingWhitespace . layoutPretty defaultLayoutOptions+-- >>> go doc+-- lorem+-- <BLANKLINE>+-- ipsum ++ -- | Alter the document’s annotations. -- -- This instance makes 'SimpleDocStream' more flexible (because it can be used in@@ -1499,7 +1521,7 @@ instance Foldable SimpleDocStream where foldMap f = go where- go = \case+ go = \sds -> case sds of SFail -> mempty SEmpty -> mempty SChar _ rest -> go rest@@ -1513,7 +1535,7 @@ instance Traversable SimpleDocStream where traverse f = go where- go = \case+ go = \sds -> case sds of SFail -> pure SFail SEmpty -> pure SEmpty SChar c rest -> SChar c <$> go rest@@ -1533,12 +1555,14 @@ -> Maybe Int -> SimpleDocStream ann -> Bool)+ deriving Typeable -- | List of nesting level/document pairs yet to be laid out. data LayoutPipeline ann = Nil | Cons !Int (Doc ann) (LayoutPipeline ann) | UndoAnn (LayoutPipeline ann)+ deriving Typeable -- | Maximum number of characters that fit in one line. The layout algorithms -- will try not to exceed the set limit by inserting line breaks when applicable@@ -1559,7 +1583,7 @@ | Unbounded -- ^ Layouters should not introduce line breaks on their own. - deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable) -- $ Test to avoid surprising behaviour -- >>> Unbounded > AvailablePerLine maxBound 1@@ -1567,7 +1591,7 @@ -- | Options to influence the layout algorithms. newtype LayoutOptions = LayoutOptions { layoutPageWidth :: PageWidth }- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable) -- | The default layout options, suitable when you just want some output, and -- don’t particularly care about the details. Used by the 'Show' instance, for@@ -1801,7 +1825,7 @@ -- 'showsPrec' _ = 'renderShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty' -- @ renderShowS :: SimpleDocStream ann -> ShowS-renderShowS = \case+renderShowS = \sds -> case sds of SFail -> panicUncaughtFail SEmpty -> id SChar c x -> showChar c . renderShowS x
src/Data/Text/Prettyprint/Doc/Render/Text.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h"@@ -79,7 +78,7 @@ renderIO h = go where go :: SimpleDocStream ann -> IO ()- go = \case+ go = \sds -> case sds of SFail -> panicUncaughtFail SEmpty -> pure () SChar c rest -> do hPutChar h c
src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}@@ -94,7 +93,7 @@ -- The equivalent to this in the tree based rendering approach is -- 'Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial.renderTree'. renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml ()-renderStackMachine = \case+renderStackMachine = \sds -> case sds of SFail -> panicUncaughtFail SEmpty -> pure () SChar c x -> do@@ -119,7 +118,7 @@ -- | Convert a 'SimpleHtml' annotation to a pair of opening and closing tags. -- This is where the translation of style to raw output happens. htmlTag :: SimpleHtml -> (TLB.Builder, TLB.Builder)-htmlTag = \case+htmlTag = \sh -> case sh of Bold -> ("<strong>", "</strong>") Italics -> ("<em>", "</em>") Color c -> ("<span style=\"color: " <> hexCode c <> "\">", "</span>")@@ -127,7 +126,7 @@ Headline -> ("<h1>", "</h1>") where hexCode :: Color -> TLB.Builder- hexCode = \case+ hexCode = \c -> case c of Red -> "#f00" Green -> "#0f0" Blue -> "#00f"
src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h"@@ -20,7 +19,6 @@ -import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB@@ -31,6 +29,9 @@ #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) import Data.Foldable (foldMap) #endif+#if !(SEMIGROUP_MONOID_SUPERCLASS)+import Data.Semigroup+#endif @@ -91,7 +92,7 @@ -- 'Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial.renderStackMachine' -- in the stack machine rendering tutorial. renderTree :: SimpleDocTree SimpleHtml -> TLB.Builder-renderTree = \case+renderTree sds = case sds of STEmpty -> mempty STChar c -> TLB.singleton c STText _ t -> TLB.fromText t@@ -102,7 +103,7 @@ -- | Convert a 'SimpleHtml' to a function that encloses a 'TLB.Builder' in HTML -- tags. This is where the translation of style to raw output happens. encloseInTagFor :: SimpleHtml -> TLB.Builder -> TLB.Builder-encloseInTagFor = \case+encloseInTagFor sh = case sh of Bold -> \x -> "<strong>" <> x <> "</strong>" Italics -> \x -> "<em>" <> x <> "</em>" Color c -> \x -> "<span style=\"color: " <> hexCode c <> "\">" <> x <> "</span>"@@ -110,7 +111,7 @@ Headline -> \x -> "<h1>" <> x <> "</h1>" where hexCode :: Color -> TLB.Builder- hexCode = \case+ hexCode c = case c of Red -> "#f00" Green -> "#0f0" Blue -> "#00f"
src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h"@@ -29,14 +28,13 @@ import Control.Applicative import Data.Text (Text) import qualified Data.Text as T+import Data.Typeable (Typeable) import GHC.Generics import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Util.Panic -#if MONAD_FAIL-import Control.Monad.Fail-#endif+import qualified Control.Monad.Fail as Fail #if !(MONOID_IN_PRELUDE) import Data.Monoid (Monoid (..))@@ -73,7 +71,7 @@ -> out renderSimplyDecorated text renderAnn = go where- go = \case+ go = \sdt -> case sdt of STEmpty -> mempty STChar c -> text (T.singleton c) STText _ t -> text t@@ -91,7 +89,7 @@ -> f out renderSimplyDecoratedA text renderAnn = go where- go = \case+ go = \sdt -> case sdt of STEmpty -> pure mempty STChar c -> text (T.singleton c) STText _ t -> text t@@ -106,6 +104,7 @@ -- -- Hand-written to avoid a dependency on a parser lib. newtype UniqueParser s a = UniqueParser { runParser :: s -> Maybe (a, s) }+ deriving Typeable instance Functor (UniqueParser s) where fmap f (UniqueParser mx) = UniqueParser (\s ->@@ -127,12 +126,12 @@ (a'', s'') <- runParser (f a') s' pure (a'', s'') ) - fail _err = empty+#if !(NO_FAIL_IN_MONAD_MONAD_FAIL)+ fail = Fail.fail+#endif -#if MONAD_FAIL-instance MonadFail (UniqueParser s) where+instance Fail.MonadFail (UniqueParser s) where fail _err = empty-#endif instance Alternative (UniqueParser s) where empty = UniqueParser (const empty)@@ -145,7 +144,7 @@ | TokLine Int | TokAnnPush ann | TokAnnPop- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable) -- | A 'SimpleDocStream' is a linked list of different annotated cons cells -- ('SText' and then some further 'SimpleDocStream', 'SLine' and then some@@ -171,7 +170,7 @@ -- | Horizontal concatenation of multiple documents. | STConcat [SimpleDocTree ann]- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Show, Generic, Typeable) -- | Alter the document’s annotations. --@@ -184,7 +183,7 @@ -- | Get the next token, consuming it in the process. nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)-nextToken = UniqueParser (\case+nextToken = UniqueParser (\sds -> case sds of SFail -> panicUncaughtFail SEmpty -> empty SChar c rest -> Just (TokChar c , rest)@@ -199,12 +198,12 @@ where wrap :: [SimpleDocTree ann] -> SimpleDocTree ann- wrap = \case+ wrap = \sdts -> case sdts of [] -> STEmpty [x] -> x xs -> STConcat xs - contentPiece = nextToken >>= \case+ contentPiece = nextToken >>= \tok -> case tok of TokEmpty -> pure STEmpty TokChar c -> pure (STChar c) TokText l t -> pure (STText l t)@@ -244,7 +243,7 @@ alterAnnotationsST :: (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann' alterAnnotationsST re = go where- go = \case+ go = \sdt -> case sdt of STEmpty -> STEmpty STChar c -> STChar c STText l t -> STText l t@@ -256,7 +255,7 @@ instance Foldable SimpleDocTree where foldMap f = go where- go = \case+ go = \sdt -> case sdt of STEmpty -> mempty STChar _ -> mempty STText _ _ -> mempty@@ -269,7 +268,7 @@ instance Traversable SimpleDocTree where traverse f = go where- go = \case+ go = \sdt -> case sdt of STEmpty -> pure STEmpty STChar c -> pure (STChar c) STText l t -> pure (STText l t)
src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h"@@ -34,13 +33,17 @@ import Control.Applicative-import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Prettyprint.Doc (SimpleDocStream (..)) import Data.Text.Prettyprint.Doc.Render.Util.Panic +#if !(SEMIGROUP_MONOID_SUPERCLASS)+import Data.Monoid+#endif++ -- $setup -- -- (Definitions for the doctests)@@ -145,7 +148,7 @@ -- -- If the stack is empty, this raises an 'error'. unsafePopStyle :: Monoid output => StackMachine output style style-unsafePopStyle = StackMachine (\case+unsafePopStyle = StackMachine (\stack -> case stack of x:xs -> (x, mempty, xs) [] -> panicPoppedEmpty )
test/Testsuite/Main.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h"@@ -163,7 +162,7 @@ docPerformanceTest :: Doc ann -> Assertion docPerformanceTest doc- = timeout 10000000 (forceDoc doc) >>= \case+ = timeout 10000000 (forceDoc doc) >>= \doc' -> case doc' of Nothing -> assertFailure "Timeout!" Just _success -> pure () where@@ -204,5 +203,5 @@ regressionAlterAnnotationsS = let sdoc, sdoc' :: SimpleDocStream Int sdoc = layoutSmart defaultLayoutOptions (annotate 1 (annotate 2 (annotate 3 "a")))- sdoc' = alterAnnotationsS (\case 2 -> Just 2; _ -> Nothing) sdoc+ sdoc' = alterAnnotationsS (\ann -> case ann of 2 -> Just 2; _ -> Nothing) sdoc in assertEqual "" (SAnnPush 2 (SChar 'a' (SAnnPop SEmpty))) sdoc'
test/Testsuite/StripTrailingSpace.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +#include "version-compatibility-macros.h"+ module StripTrailingSpace (testStripTrailingSpace) where @@ -13,6 +16,12 @@ import Test.Tasty import Test.Tasty.HUnit +#if !(APPLICATIVE_MONAD)+import Control.Applicative+#endif+++ box :: Text -> Text box singleLine = unlines' [ "┌─" <> T.replicate (T.length singleLine) "─" <> "─┐"@@ -40,7 +49,7 @@ , testCase "Multiple spaces inside" (testStripping ("Multiple spaces" <> " " <> "inside")) , testCase "Whitespace inside text"- (testStripping ("Whitespace inside text "))+ (testStripping "Whitespace inside text ") , testCase "Indented blank line" (testStripping (nest 4 (vcat ["Indented blank line", "", "<end>"]))) , testCase "Multiple indented blank lines"