From 352a40431219e3c6ac5e60cc34ea0b61e3d007db Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 27 Jul 2025 18:31:51 +0200 Subject: [PATCH 1/5] Remove trailing whitespace and turn tabs to spaces --- src/Text/PrettyPrint.hs | 4 +- src/Text/PrettyPrint/Annotated.hs | 4 +- src/Text/PrettyPrint/HughesPJClass.hs | 2 +- tests/BugSep.hs | 2 +- tests/Test.hs | 158 +++++++++++++------------- tests/TestGenerators.hs | 8 +- tests/TestStructures.hs | 24 ++-- 7 files changed, 101 insertions(+), 101 deletions(-) diff --git a/src/Text/PrettyPrint.hs b/src/Text/PrettyPrint.hs index 8e5e2c1..fb8dd86 100644 --- a/src/Text/PrettyPrint.hs +++ b/src/Text/PrettyPrint.hs @@ -6,7 +6,7 @@ -- Module : Text.PrettyPrint -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) --- +-- -- Maintainer : David Terei -- Stability : stable -- Portability : portable @@ -21,7 +21,7 @@ -- ----------------------------------------------------------------------------- -module Text.PrettyPrint ( +module Text.PrettyPrint ( -- * The document type Doc, diff --git a/src/Text/PrettyPrint/Annotated.hs b/src/Text/PrettyPrint/Annotated.hs index 9b85f11..f2fda70 100644 --- a/src/Text/PrettyPrint/Annotated.hs +++ b/src/Text/PrettyPrint/Annotated.hs @@ -6,7 +6,7 @@ -- Module : Text.PrettyPrint.Annotated -- Copyright : (c) Trevor Elliott 2015 -- License : BSD-style (see the file LICENSE) --- +-- -- Maintainer : David Terei -- Stability : stable -- Portability : portable @@ -21,7 +21,7 @@ -- ----------------------------------------------------------------------------- -module Text.PrettyPrint.Annotated ( +module Text.PrettyPrint.Annotated ( -- * The document type Doc, diff --git a/src/Text/PrettyPrint/HughesPJClass.hs b/src/Text/PrettyPrint/HughesPJClass.hs index a60ddeb..66e681a 100644 --- a/src/Text/PrettyPrint/HughesPJClass.hs +++ b/src/Text/PrettyPrint/HughesPJClass.hs @@ -12,7 +12,7 @@ -- Stability : stable -- Portability : portable -- --- Pretty printing class, simlar to 'Show' but nicer looking. +-- Pretty printing class, simlar to 'Show' but nicer looking. -- -- Note that the precedence level is a 'Rational' so there is an unlimited -- number of levels. This module re-exports 'Text.PrettyPrint.HughesPJ'. diff --git a/tests/BugSep.hs b/tests/BugSep.hs index fe16b80..bdca036 100644 --- a/tests/BugSep.hs +++ b/tests/BugSep.hs @@ -9,7 +9,7 @@ main :: IO () main = do putStrLn "" putStrLn "Note that the correct definition of sep is currently unclear" - putStrLn "It is neither foldr ($+$) empty nor foldr ($$) empty" + putStrLn "It is neither foldr ($+$) empty nor foldr ($$) empty" putStrLn "------------------------------------------------------------" let test1 = [ text "" $+$ text "c", nest 3 ( text "a") ] let test2 = [ text "c", nest 3 ( text "b") ] diff --git a/tests/Test.hs b/tests/Test.hs index 2f2919c..23eb017 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -4,7 +4,7 @@ -- License : BSD-style -- -- QuickChecks for HughesPJ pretty printer. --- +-- -- 1) Testing laws (blackbox) -- - CDoc (combinator datatype) -- 2) Testing invariants (whitebox) @@ -41,7 +41,7 @@ main = do check_non_prims -- hpc full coverage check_rendering check_list_def - + -- unit tests testPP1 testT3911 @@ -94,18 +94,18 @@ docEq rd1 rd2 = case (rd1, rd2) of (Nest k1 d1, Nest k2 d2) | k1 == k2 -> docEq d1 d2 (Union d11 d12, Union d21 d22) -> docEq d11 d21 && docEq d12 d22 (d1,d2) -> False - + -- algebraic equality, with text reduction deq :: Doc () -> Doc () -> Bool deq d1 d2 = docEq (reduceDoc' d1) (reduceDoc' d2) where reduceDoc' = mergeTexts . reduceDoc deqs :: [Doc ()] -> [Doc ()] -> Bool -deqs ds1 ds2 = +deqs ds1 ds2 = case zipE ds1 ds2 of Nothing -> False (Just zds) -> all (uncurry deq) zds - + zipLayouts :: Doc () -> Doc () -> Maybe [(Doc (),Doc ())] zipLayouts d1 d2 = zipE (reducedDocs d1) (reducedDocs d2) where reducedDocs = map mergeTexts . flattenDoc @@ -208,10 +208,10 @@ Laws for nest -} prop_n1 x = nest 0 x `deq` x prop_n2 k k' x = nest k (nest k' x) `deq` nest (k+k') x -prop_n3 k k' x = nest k (nest k' x) `deq` nest (k+k') x +prop_n3 k k' x = nest k (nest k' x) `deq` nest (k+k') x prop_n4 k x y = nest k (x $$ y) `deq` nest k x $$ nest k y prop_n5 k = nest k empty `deq` empty -prop_n6 x k y = not (isEmpty x) ==> +prop_n6 x k y = not (isEmpty x) ==> x <> nest k y `deq` x <> y check_n = do putStrLn "Nest laws" @@ -223,13 +223,13 @@ check_n = do myTest "n6" (\k -> liftDoc2 (\x -> prop_n6 x k)) {- - (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + (text s <> x) $$ y = text s <> ((text "" <> x)) $$ nest (-length s) y) (x $$ y) <> z = x $$ (y <> z) if y non-empty --} -prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$ +-} +prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$ nest (-length (unText s)) y) prop_m2 x y z = not (isEmpty y) ==> (x $$ y) <> z `deq` x $$ (y <> z) @@ -247,14 +247,14 @@ Laws for list versions [ Fails for fill ! ] nest k (sep ps) = sep (map (nest k) ps) ...ditto hsep, hcat, vcat, fill... --} -prop_l1 sp ps qs = +-} +prop_l1 sp ps qs = sp (ps++[empty]++qs) `rdeq` sp (ps ++ qs) prop_l2 sp k ps = nest k (sep ps) `deq` sep (map (nest k) ps) prop_l1' sp cps cqs = - let [ps,qs] = map buildDocList [cps,cqs] in + let [ps,qs] = map buildDocList [cps,cqs] in layoutCountBounded maxLayouts (sp (ps++qs)) ==> prop_l1 sp ps qs prop_l2' sp k ps = prop_l2 sp k (buildDocList ps) check_l = do @@ -269,13 +269,13 @@ prop_l1_fail_2 = [ text "a" $$ text "b" ] Laws for oneLiner ~~~~~~~~~~~~~~~~~ oneLiner (nest k p) = nest k (oneLiner p) - oneLiner (x <> y) = oneLiner x <> oneLiner y + oneLiner (x <> y) = oneLiner x <> oneLiner y [One liner only takes reduced arguments] --} +-} oneLinerR = oneLiner . reduceDoc prop_o1 k p = oneLinerR (nest k p) `deq` nest k (oneLinerR p) -prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y +prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y check_o = do putStrLn "oneliner laws" @@ -311,23 +311,23 @@ sepDef docs = let ds = filter (not . isEmpty) docs in case ds of [] -> empty [d] -> d - ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds) + ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds) `Union` (reduceDoc $ foldr ($+$) empty ds)) -check_list_def = do - myTest "hcat def" (prop_hcat . buildDocList) - myTest "hsep def" (prop_hsep . buildDocList) - myTest "vcat def" (prop_vcat . buildDocList) +check_list_def = do + myTest "hcat def" (prop_hcat . buildDocList) + myTest "hsep def" (prop_hsep . buildDocList) + myTest "vcat def" (prop_vcat . buildDocList) -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT]) myTest "sep def" (expectFailure . prop_sep . buildDocList) {- Definition of fill (fcat/fsep) --- Specification: +-- Specification: -- fill [] = empty -- fill [p] = p --- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) -- (fill (oneLiner p2 : ps)) -- `union` -- p1 $$ fill ps @@ -339,9 +339,9 @@ Definition of fill (fcat/fsep) -- fillIndent k (p1:p2:ps) = -- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps) -- `Union` --- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) -- --- $*$ is defined for layouts (not Docs) as +-- $*$ is defined for layouts (not Docs) as -- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2 -- | otherwise = layout1 $$ layout2 -- @@ -363,7 +363,7 @@ Definition of fill (fcat/fsep) -- expected: (nest 1; text "a"; text "b"; nest -3; "c") -- actual : (nest 1; text "a"; text "b"; nest -5; "c") -- === (nest 1; text a) <> (fill (-2) (p2:ps)) --- ==> (nest 2 (text "b") $+$ text "c") +-- ==> (nest 2 (text "b") $+$ text "c") -- ==> (nest 2 (text "b") `nilabove` nest (-3) (text "c")) -- ==> (nest 1; text a; text b; nest -5 c) @@ -383,7 +383,7 @@ prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty prop_fcat_old_old :: [Doc ()] -> Bool prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds) -prop_restrict_sz :: (Testable a) => Int -> ([Doc ()] -> a) -> ([Doc ()] -> Property) +prop_restrict_sz :: (Testable a) => Int -> ([Doc ()] -> a) -> ([Doc ()] -> Property) prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds prop_restrict_ol :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property) @@ -396,7 +396,7 @@ fillDef :: Bool -> [Doc ()] -> Doc () fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc where fill' _ [] = Empty - fill' _ [x] = x + fill' _ [x] = x fill' k (p1:p2:ps) = reduceDoc (oneLiner p1 `append` (fill' (k + firstLineLength p1 + (if g then 1 else 0)) $ (oneLiner' p2) : ps)) `union` @@ -404,7 +404,7 @@ fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc union = Union - append = if g then (<+>) else (<>) + append = if g then (<+>) else (<>) oneLiner' (Nest k d) = oneLiner' d oneLiner' d = oneLiner d @@ -412,16 +412,16 @@ fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc ($*$) :: RDoc () -> RDoc () -> RDoc () ($*$) p ps = case flattenDoc p of [] -> NoDoc - ls -> foldr1 Union (map combine ls) + ls -> foldr1 Union (map combine ls) where combine p | isOneLiner p = p $+$ ps | otherwise = p $$ ps fillDefOld :: Bool -> [Doc ()] -> Doc () -fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where +fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where fill' [] = Empty fill' [p1] = p1 - fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1) + fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1) (fill' (oneLiner p2 : ps)))) `union` (p1 $$ fill' (p2:ps)) @@ -432,12 +432,12 @@ check_fill_prop :: Testable a => String -> ([Doc ()] -> a) -> IO () check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList) check_fill_def_fail :: IO () -check_fill_def_fail = do +check_fill_def_fail = do check_fill_prop "fcat defOld vs fcatOld (ol)" (prop_restrict_ol prop_fcat_old_old) check_fill_prop "fcat defOld vs fcatOld" prop_fcat_old_old check_fill_prop "fcat def (ol) vs fcatOld" (prop_restrict_ol prop_fcat_old) - check_fill_prop "fcat def vs fcatOld" prop_fcat_old + check_fill_prop "fcat def vs fcatOld" prop_fcat_old check_fill_def_ok :: IO () check_fill_def_ok = do @@ -467,7 +467,7 @@ Zero width text (Neil) Here it would be convenient to generate functions (or replace empty / text bz z-w-t) -} -- TODO -{- +{- All laws: monoid, text, nest, misc, list versions, oneLiner, list def -} check_laws :: IO () @@ -491,7 +491,7 @@ stop a = (a,False) recurse :: a -> (a, Bool) recurse a = (a,True) --- strategy: generic synthesize with stop condition +-- strategy: generic synthesize with stop condition -- terms are combined top-down, left-right (latin text order) genericProp :: (a -> a -> a) -> (Doc () -> (a,Bool)) -> Doc () -> a genericProp c q doc = @@ -521,15 +521,15 @@ prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where nilAboveNotEmpty _ = recurse True {- - * The argument of @TextBeside@ is never @Nest@. + * The argument of @TextBeside@ is never @Nest@. -} prop_inv2 :: Doc () -> Bool prop_inv2 = genericProp (&&) textBesideNotNest where textBesideNotNest (TextBeside _ (Nest _ _)) = stop False textBesideNotNest _ = recurse True {- - * The layouts of the two arguments of @Union@ both flatten to the same - string + * The layouts of the two arguments of @Union@ both flatten to the same + string -} prop_inv3 :: Doc () -> Bool prop_inv3 = genericProp (&&) unionsFlattenSame where @@ -550,7 +550,7 @@ prop_inv4 = genericProp (&&) unionArgs where goodUnionArg (TextBeside _ _) = True goodUnionArg (NilAbove _) = True goodUnionArg _ = False - + {- * A @NoDoc@ may only appear on the first line of the left argument of an union. Therefore, the right argument of an union can never be equivalent @@ -601,12 +601,12 @@ prop_inv7 = genericProp (&&) firstLonger where firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True) firstLonger _ = (True, True) -{- +{- * If we take as precondition: the arguments of cat,sep,fill do not start with Nest, invariant 7 holds -} prop_inv7_pre :: CDoc -> Bool prop_inv7_pre cdoc = nestStart True cdoc where - nestStart nestOk doc = + nestStart nestOk doc = case doc of CList sep ds -> all (nestStart False) ds CBeside _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2 @@ -620,7 +620,7 @@ prop_inv7_pre cdoc = nestStart True cdoc where -} prop_inv7_a :: CDoc -> Property prop_inv7_a cdoc = prop_inv7_pre cdoc ==> prop_inv7 (buildDoc cdoc) - + check_invariants :: IO () check_invariants = do myTest "Invariant 1" (prop_inv1 . buildDoc) @@ -633,12 +633,12 @@ check_invariants = do -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT]) myTest "Invariant 7 (fails in HughesPJ:20080621)" (expectFailure . prop_inv7 . buildDoc) --- `negative indent' --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- `negative indent' +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -{- +{- In the documentation we have: - + (spaces n) generates a list of n spaces It should never be called with 'n' < 0, but that can happen for reasons I don't understand @@ -658,7 +658,7 @@ prop_negative_indent cdoc = noNegNest cdoc ==> noNegSpaces (buildDoc cdoc) noNegNest = genericCProp (&&) notIsNegNest where notIsNegNest (CNest k _) | k < 0 = stop False notIsNegNest _ = recurse True -noNegSpaces = go 0 . reduceDoc where +noNegSpaces = go 0 . reduceDoc where go k Empty = True go k (NilAbove d) = go k d go k (TextBeside _ d) | k < 0 = False @@ -697,17 +697,17 @@ while(true) /* indented comment */ skip; -} - + -- (3) Touching non-prims -- ~~~~~~~~~~~~~~~~~~~~~~ check_non_prims :: IO () check_non_prims = do - myTest "Non primitive: show = renderStyle style" $ \cd -> let d = buildDoc cd in + myTest "Non primitive: show = renderStyle style" $ \cd -> let d = buildDoc cd in show ((zeroWidthText "a") <> d) /= renderStyle style d myAssert "symbols" $ (semi <> comma <> colon <> equals <> lparen <> rparen <> lbrack <> rbrack <> lbrace <> rbrace) - `deq` + `deq` (text ";,:=()[]{}") myAssert "quoting" $ (quotes . doubleQuotes . parens . brackets .braces $ (text "a" $$ text "b")) @@ -716,22 +716,22 @@ check_non_prims = do myAssert "numbers" $ fsep [int 42, integer 42, float 42, double 42, rational 42] `rdeq` - (fsep . map text) + (fsep . map text) [show (42 :: Int), show (42 :: Integer), show (42 :: Float), show (42 :: Double), show (42 :: Rational)] - myTest "Definition of <+>" $ \cd1 cd2 -> - let (d1,d2) = (buildDoc cd1, buildDoc cd2) in + myTest "Definition of <+>" $ \cd1 cd2 -> + let (d1,d2) = (buildDoc cd1, buildDoc cd2) in layoutsCountBounded maxLayouts [d1,d2] ==> not (isEmpty d1) && not (isEmpty d2) ==> - d1 <+> d2 `rdeq` d1 <> space <> d2 - + d1 <+> d2 `rdeq` d1 <> space <> d2 + myTest "hang" $ liftDoc2 (\d1 d2 -> hang d1 2 d2 `deq` sep [d1, nest 2 d2]) - + let pLift f cp cds = f (buildDoc cp) (buildDocList cds) myTest "punctuate" $ pLift (\p ds -> (punctuate p ds) `deqs` (punctuateDef p ds)) check_rendering = do - myTest' 20 10000 "one - line rendering" $ \cd -> - let d = buildDoc cd in + myTest' 20 10000 "one - line rendering" $ \cd -> + let d = buildDoc cd in (renderStyle (Style OneLineMode undefined undefined) d) == oneLineRender d myTest' 20 10000 "left-mode rendering" $ \cd -> let d = buildDoc cd in @@ -742,7 +742,7 @@ check_rendering = do myTest' 20 10000 "zigzag mode rendering" $ \cd -> let d = buildDoc cd in extractTextZZ (renderStyle (Style ZigZagMode 6 1.7) d) == extractText (oneLineRender d) - + extractText :: String -> String extractText = filter (not . isSpace) @@ -751,10 +751,10 @@ extractTextZZ = filter (\c -> not (isSpace c) && c /= '/' && c /= '\\') punctuateDef :: Doc () -> [Doc ()] -> [Doc ()] punctuateDef p [] = [] -punctuateDef p ps = +punctuateDef p ps = let (dsInit,dLast) = (init ps, last ps) in map (\d -> d <> p) dsInit ++ [dLast] - + -- (4) QuickChecking improvments and bug fixes -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -771,7 +771,7 @@ prop_fill_empty_reduce ds = fill True ds `deq` fillOld True (filter (not.isEmpty check_improvements :: IO () check_improvements = do - myTest "fill = fillOld . filter (not.isEmpty) [if no argument starts with nest]" + myTest "fill = fillOld . filter (not.isEmpty) [if no argument starts with nest]" (prop_fill_empty_reduce . filter (not .isNest) . buildDocList) -- old implementation of fill @@ -798,7 +798,7 @@ fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where fillNB g (Nest _ p) k ys = fillNB g p k ys fillNB _ Empty _ [] = Empty fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) - `mkUnion` + `mkUnion` nilAboveNest False k (fillOld g (y:ys)) where k1 | g = k - 1 @@ -806,10 +806,10 @@ fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where fillNB g p k ys = fill1 g p k ys --- Specification: +-- Specification: -- fill [] = empty -- fill [p] = p --- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) -- (fill (oneLiner p2 : ps)) -- `union` -- p1 $$ fill ps @@ -840,7 +840,7 @@ fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where fillNB g p k ys = fill1 g p k ys fillNBE g k y ys = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) - `mkUnion` + `mkUnion` nilAboveNest True k (fill g (y:ys)) where k1 | g = k - 1 @@ -849,8 +849,8 @@ fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where -- (5) Pretty printing RDocs and RDOC properties -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ prettyDoc :: Doc () -> Doc () -prettyDoc d = - case reduceDoc d of +prettyDoc d = + case reduceDoc d of Empty -> text "empty" NilAbove d -> (text "nilabove") <> semi <+> (prettyDoc d) TextBeside s d -> (text ("text \""++tdToStr (annotToTd s) ++ "\"" ++ show (annotSize s))) <> semi <+> (prettyDoc d) @@ -870,7 +870,7 @@ flattenDoc d = flatten (reduceDoc d) where flatten (Union d1 d2) = flattenDoc d1 ++ flattenDoc d2 flatten (Beside d1 b d2) = error $ "flattenDoc Beside" flatten (Above d1 b d2) = error $ "flattenDoc Above" - + normalize :: Doc () -> RDoc () normalize d = norm d where norm NoDoc = NoDoc @@ -880,7 +880,7 @@ normalize d = norm d where norm (TextBeside s d) = (TextBeside s) (norm d) norm (Nest k (Nest k' d)) = norm $ Nest (k+k') d norm (Nest 0 d) = norm d - norm (Nest k d) = (Nest k) (norm d) + norm (Nest k d) = (Nest k) (norm d) -- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. norm (Union d1 d2) = normUnion (norm d1) (norm d2) norm d@(Beside d1 b d2) = norm (reduceDoc d) @@ -903,7 +903,7 @@ topLevelCTor d = tlc d where tlc (Union d1 d2) = "Union" tlc (Above _ _ _) = "Above" tlc (Beside _ _ _) = "Beside" - + -- normalize TextBeside (and consequently apply some laws for simplification) mergeTexts :: RDoc () -> RDoc () mergeTexts = merge where @@ -917,7 +917,7 @@ mergeTexts = merge where mergeText t1 t2 = NoAnnot (Str $ tdToStr (annotToTd t1) ++ tdToStr (annotToTd t2)) (annotSize t1 + annotSize t2) - + isOneLiner :: RDoc () -> Bool isOneLiner = genericProp (&&) iol where iol (NilAbove _) = stop False @@ -943,10 +943,10 @@ extractTexts = map normWS . genericProp combine go where -- modulo whitespace normWS txt = filter (not . isWS) txt where isWS ws | ws == ' ' || ws == '\n' || ws == '\t' = True - | otherwise = False - + | otherwise = False + emptyReduction :: Doc () -> Doc () -emptyReduction doc = +emptyReduction doc = case doc of Empty -> Empty NilAbove d -> case emptyReduction d of Empty -> Empty ; d' -> NilAbove d' @@ -971,7 +971,7 @@ abstractLayout :: Doc () -> [(Int,String)] abstractLayout d = cal 0 Nothing (reduceDoc d) where -- current column -> this line -> doc -> [(indent,line)] cal :: Int -> (Maybe (Int,String)) -> Doc () -> [(Int,String)] - cal k cur Empty = [ addTextEOL k (Str "") cur ] + cal k cur Empty = [ addTextEOL k (Str "") cur ] cal k cur (NilAbove d) = (addTextEOL k (Str "") cur) : cal k Nothing d cal k cur (TextBeside s d) = cal (k + annotSize s) (addText k s cur) d cal k cur (Nest n d) = cal (k+n) cur d @@ -985,7 +985,7 @@ abstractLayout d = cal 0 Nothing (reduceDoc d) where docifyLayout :: [(Int,String)] -> Doc () docifyLayout = vcat . map (\(k,t) -> nest k (text t)) - + oneLineRender :: Doc () -> String oneLineRender = olr . abstractLayout . last . flattenDoc where olr = concat . intersperse " " . map snd @@ -1000,4 +1000,4 @@ firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where noNegativeIndent :: Doc () -> Bool noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where noNegIndent = all ( (>= 0) . fst) - + diff --git a/tests/TestGenerators.hs b/tests/TestGenerators.hs index 56dc93a..b7c9d9f 100644 --- a/tests/TestGenerators.hs +++ b/tests/TestGenerators.hs @@ -24,9 +24,9 @@ instance Arbitrary CDoc where (1, return CList `ap` arbitrary `ap` (liftM unDocList $ resize (pred n) arbitrary)) ,(1, binaryComb n CBeside) ,(1, binaryComb n CAbove) - ,(1, choose (0,10) >>= \k -> return (CNest k) `ap` (resize (pred n) arbitrary)) + ,(1, choose (0,10) >>= \k -> return (CNest k) `ap` (resize (pred n) arbitrary)) ] - binaryComb n f = + binaryComb n f = split2 (n-1) >>= \(n1,n2) -> return f `ap` arbitrary `ap` (resize n1 arbitrary) `ap` (resize n2 arbitrary) split2 n = flip liftM ( choose (0,n) ) $ \sz -> (sz, n - sz) @@ -38,14 +38,14 @@ instance CoArbitrary CDoc where coarbitrary (CBeside b d1 d2) = variant 3 . coarbitrary b . coarbitrary d1 . coarbitrary d2 coarbitrary (CAbove b d1 d2) = variant 4 . coarbitrary b . coarbitrary d1 . coarbitrary d2 coarbitrary (CNest k d) = variant 5 . coarbitrary k . coarbitrary d - + instance Arbitrary CList where arbitrary = oneof $ map return [ CCat, CSep, CFCat, CFSep ] instance CoArbitrary CList where coarbitrary cl = variant (case cl of CCat -> 0; CSep -> 1; CFCat -> 2; CFSep -> 3) --- we assume that the list itself has no size, so that +-- we assume that the list itself has no size, so that -- sizeof (a $$ b) = sizeof (sep [a,b]) = sizeof(a) + sizeof(b)+1 instance Arbitrary CDocList where arbitrary = liftM CDocList $ sized $ \n -> arbDocList n where diff --git a/tests/TestStructures.hs b/tests/TestStructures.hs index a68191b..801fb2e 100644 --- a/tests/TestStructures.hs +++ b/tests/TestStructures.hs @@ -28,7 +28,7 @@ data CDoc = CEmpty -- empty data CList = CCat | CSep | CFCat | CFSep deriving (Eq,Ord) -newtype CDocList = CDocList { unDocList :: [CDoc] } +newtype CDocList = CDocList { unDocList :: [CDoc] } -- wrapper for String argument of `text' newtype Text = Text { unText :: String } deriving (Eq, Ord, Show) @@ -37,23 +37,23 @@ instance Show CDoc where showsPrec k CEmpty = showString "empty" showsPrec k (CText s) = showParen (k >= 10) (showString " text " . shows s) showsPrec k (CList sp ds) = showParen (k >= 10) $ (shows sp . showList ds) - showsPrec k (CBeside sep d1 d2) = showParen (k >= 6) $ - (showsPrec 6 d1) . showString (if sep then " <+> " else " <> ") . (showsPrec 6 d2) - showsPrec k (CAbove noOvlap d1 d2) = showParen (k >= 5) $ - (showsPrec 5 d1) . showString (if noOvlap then " $+$ " else " $$ ") . (showsPrec 5 d2) + showsPrec k (CBeside sep d1 d2) = showParen (k >= 6) $ + (showsPrec 6 d1) . showString (if sep then " <+> " else " <> ") . (showsPrec 6 d2) + showsPrec k (CAbove noOvlap d1 d2) = showParen (k >= 5) $ + (showsPrec 5 d1) . showString (if noOvlap then " $+$ " else " $$ ") . (showsPrec 5 d2) showsPrec k (CNest n d) = showParen (k >= 10) $ showString " nest " . showsPrec 10 n . showString " ". showsPrec 10 d -instance Show CList where - show cs = case cs of CCat -> "cat" ; CSep -> "sep" ; CFCat -> "fcat" ; CFSep -> "fsep" +instance Show CList where + show cs = case cs of CCat -> "cat" ; CSep -> "sep" ; CFCat -> "fcat" ; CFSep -> "fsep" instance Show CDocList where show = show . unDocList - + buildDoc :: CDoc -> Doc () buildDoc CEmpty = empty buildDoc (CText s) = text s buildDoc (CList sp ds) = (listComb sp) $ map buildDoc ds -buildDoc (CBeside sep d1 d2) = (if sep then (<+>) else (<>)) (buildDoc d1) (buildDoc d2) -buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2) +buildDoc (CBeside sep d1 d2) = (if sep then (<+>) else (<>)) (buildDoc d1) (buildDoc d2) +buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2) buildDoc (CNest k d) = nest k $ buildDoc d listComb :: CList -> ([Doc ()] -> Doc ()) @@ -64,7 +64,7 @@ liftDoc2 f cd1 cd2 = f (buildDoc cd1) (buildDoc cd2) liftDoc3 :: (Doc () -> Doc () -> Doc () -> a) -> (CDoc -> CDoc -> CDoc -> a) liftDoc3 f cd1 cd2 cd3 = f (buildDoc cd1) (buildDoc cd2) (buildDoc cd3) - + buildDocList :: CDocList -> [Doc ()] buildDocList = map buildDoc . unDocList @@ -84,7 +84,7 @@ tdToStr (PStr s) = s -- synthesize with stop for cdoc -- constructor order genericCProp :: (a -> a -> a) -> (CDoc -> (a, Bool)) -> CDoc -> a -genericCProp c q cdoc = +genericCProp c q cdoc = case q cdoc of (v,False) -> v (v,True) -> foldl c v subs From e8383d823b50ce63a0e8856af545a763700d521a Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 27 Jul 2025 18:42:31 +0200 Subject: [PATCH 2/5] Fix building testsuite (import conflict) --- tests/Test.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/Test.hs b/tests/Test.hs index 23eb017..365fda6 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -31,6 +31,10 @@ import Data.List (intersperse) import Debug.Trace import Test.QuickCheck + ( Args(..), Property, Testable, Result(Failure) + , (==>) + , classify, expectFailure, forAll, quickCheckWithResult, stdArgs + ) main :: IO () main = do From aa159e48d03d8fbb5a1e8370b727327902067927 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 27 Jul 2025 18:47:19 +0200 Subject: [PATCH 3/5] Make benchmarks build again (fix import conflicts) --- bench/Bench.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/bench/Bench.hs b/bench/Bench.hs index af26059..800051b 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -3,17 +3,19 @@ {-# LANGUAGE PackageImports #-} module Main where -import Criterion.Main -import Data.List +import Prelude hiding ( (<>) ) + +import Criterion.Main ( bench, bgroup, defaultMain, nf) +import qualified Data.List as List import Text.PrettyPrint.HughesPJ -------------------------------------------------------------------------------- f_left :: Int -> Doc -f_left n = foldl' (<>) empty (map (text . show) [10001..10000+n]) +f_left n = List.foldl' (<>) empty (map (text . show) [10001..10000+n]) -------------------------------------------------------------------------------- f_right :: Int -> Doc -f_right n = foldr (<>) empty (map (text . show) [10001..10000+n]) +f_right n = List.foldr (<>) empty (map (text . show) [10001..10000+n]) -------------------------------------------------------------------------------- stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc From dd40cd9f9cf27cadec712cd9be3185545f20b2f3 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 28 Jul 2025 09:34:51 +0200 Subject: [PATCH 4/5] CI: enable testsuite for GHC <= 9.6 Building the testsuite broke with GHC 9.8 because containers started to depend on template-haskell which depends on pretty. --- .github/workflows/ci.yml | 16 +++++++++++----- .github/workflows/haskell-ci.yml | 5 ++++- cabal.haskell-ci | 7 ++++++- 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7512a2c..76c4120 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -55,11 +55,17 @@ jobs: - run: cabal build --dependencies-only - run: cabal build - # Cannot build the testsuite because template-haskell depends on pretty - # and containers and QuickCheck depend on template-haskell. - # See also https://github.com/haskell/containers/issues/1156 - # - run: cabal build -c 'QuickCheck -templatehaskell' --enable-tests - # - run: cabal test -c 'QuickCheck -templatehaskell' --enable-tests + - name: Tests (not possible for GHC 9.8 and up) + if: matrix.ghc == '9.6' + run: | + cabal build -c 'QuickCheck -templatehaskell' --enable-tests + cabal test -c 'QuickCheck -templatehaskell' --enable-tests + # Since 9.8, containers depends on template-haskell which depends on pretty. + # This cycle cannot be solved by cabal. + # See https://github.com/haskell/containers/issues/1156 + + # Cannot build the benchmarks because they depend on template-haskell + # which depends on pretty. # - run: cabal build -c 'QuickCheck -templatehaskell' --enable-tests --enable-benchmarks # - run: cabal bench -c 'QuickCheck -templatehaskell' --enable-tests --enable-benchmarks diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index db8d323..0696fc6 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -134,7 +134,7 @@ jobs: echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" - echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" + if [ $((HCNUMVER < 90800)) -ne 0 ] ; then echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" ; else echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" ; fi echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" @@ -239,6 +239,9 @@ jobs: - name: build run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ; fi - name: cabal check run: | cd ${PKGDIR_pretty} || false diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 9271dbb..d0d80c1 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -2,5 +2,10 @@ branches: master installed: +all -pretty -- Tests and benchmarks do not build due to cycling package dependencies. -- QuickCheck/containers -> template-haskell -> pretty. +-- Building the benchmarks requires template-haskell which depends on pretty +-- causing a dependency cycle that cabal cannot handle. benchmarks: False -tests: False + +-- Since GHC 9.8, containers depend also on template-haskell so building +-- the testsuite is broken as well there. +tests: <9.8 From 60657708470125d9062f517ed9d85ea19d14d99a Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 28 Jul 2025 09:58:55 +0200 Subject: [PATCH 5/5] Haskell CI: restrict tests to GHC 9.0 and 9.2 --- .github/workflows/haskell-ci.yml | 4 ++-- cabal.haskell-ci | 9 ++++++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 0696fc6..89a011b 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -134,7 +134,7 @@ jobs: echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" - if [ $((HCNUMVER < 90800)) -ne 0 ] ; then echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" ; else echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" ; fi + if [ $((HCNUMVER >= 90000 && HCNUMVER < 90400)) -ne 0 ] ; then echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" ; else echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" ; fi echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" @@ -241,7 +241,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always - name: tests run: | - if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ; fi + if [ $((HCNUMVER >= 90000 && HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ; fi - name: cabal check run: | cd ${PKGDIR_pretty} || false diff --git a/cabal.haskell-ci b/cabal.haskell-ci index d0d80c1..0b5ea9a 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -6,6 +6,9 @@ installed: +all -pretty -- causing a dependency cycle that cabal cannot handle. benchmarks: False --- Since GHC 9.8, containers depend also on template-haskell so building --- the testsuite is broken as well there. -tests: <9.8 +-- Testsuite broken with GHC 8 because it does some hack +-- dropping the module header when building the testsuite +-- which leads to misplaced LANGUAGE pragmas. +-- Testsuite broken with GHC >= 9.4 due to cycle involving +-- QuickCheck, containers, template-haskell and pretty. +tests: >=9.0 && <9.4