From f434639d465b7ec6634938b14dc0e31ca054df33 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 13 Nov 2023 22:05:13 +0100 Subject: [PATCH] add section the constraints are missing? make a non trival test pass remove unused imports make comment clearer --- .../PackageDescription/ExactPrint.hs | 40 ++++++++++----- .../Types/GenericPackageDescription.hs | 2 +- .../ParserTests/exactPrint/bounded.cabal | 10 ++++ Cabal-tests/tests/PrinterTests.hs | 51 +++---------------- 4 files changed, 45 insertions(+), 58 deletions(-) create mode 100644 Cabal-tests/tests/ParserTests/exactPrint/bounded.cabal diff --git a/Cabal-syntax/src/Distribution/PackageDescription/ExactPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/ExactPrint.hs index 0a34a48461f..221661a6df5 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/ExactPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/ExactPrint.hs @@ -1,6 +1,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} + +-- I suppose this is currently more of an exact-ish print +-- anything that makes it warn for example is neglected. module Distribution.PackageDescription.ExactPrint (exactPrint ) where @@ -9,7 +12,7 @@ import Distribution.Types.GenericPackageDescription import Distribution.PackageDescription.PrettyPrint import Data.Text(Text, pack, unpack) import qualified Text.PrettyPrint as PP -import Text.PrettyPrint(Doc, ($+$), ($$), (<+>)) +import Text.PrettyPrint(Doc, ($+$), ($$)) import qualified Data.Map as Map import Data.Map(Map) import Distribution.Fields.Pretty @@ -19,6 +22,7 @@ import Distribution.Parsec.Position import Data.List(sortOn) import Control.Monad(join) import Distribution.PackageDescription(specVersion) +import Data.Foldable(fold) exactPrint :: GenericPackageDescription -> Text exactPrint package = foldExactly (exactPrintMeta package) fields @@ -56,21 +60,34 @@ renderLine :: PrettyField (Maybe ExactPosition) -> RenderState -> RenderState renderLine field (previous@MkRenderState {..}) = case field of PrettyField mAnn name' doc -> let - newPosition = case mAnn of Just position -> retPos (namePosition position) Nothing -> retPos currentPosition in MkRenderState { - currentDoc = currentDoc $+$ renderWithPositionAdjustment mAnn currentPosition name' doc, + currentDoc = currentDoc $+$ renderWithPositionAdjustment mAnn currentPosition ((decodeFieldname name') <> ":") [doc], currentPosition = newPosition } - PrettySection ann name' ppDoc sectionFields -> previous -- TODO render section + PrettySection mAnn name' ppDocs sectionFields -> + let + newPosition = case mAnn of + Just position -> retPos (namePosition position) + Nothing -> retPos currentPosition + + result = MkRenderState { + currentDoc = currentDoc $+$ renderWithPositionAdjustment mAnn currentPosition (decodeFieldname name') ppDocs, + currentPosition = newPosition + } + in renderLines result $ sortFields sectionFields + PrettyEmpty -> previous -renderWithPositionAdjustment :: (Maybe ExactPosition) -> Position -> FieldName -> Doc -> Doc -renderWithPositionAdjustment mAnn current name doc = - if rows < 0 then error "unexpected empty negative rows" +decodeFieldname :: FieldName -> String +decodeFieldname = unpack . Text.decodeUtf8 + +renderWithPositionAdjustment :: (Maybe ExactPosition) -> Position -> String -> [Doc] -> Doc +renderWithPositionAdjustment mAnn current fieldName doc = + if rows < 0 then error ("unexpected empty negative rows" <> show (mAnn, current, fieldName, res)) else let spacing :: Doc @@ -78,23 +95,20 @@ renderWithPositionAdjustment mAnn current name doc = in spacing $$ (PP.nest columns - (PP.text fieldName ) <> ((PP.hsep ("" <$ [0..offset])) <> doc)) + (PP.text fieldName ) <> ((PP.hsep ("" <$ [1..offset])) <> fold doc)) -- <+> "--" <+> PP.text (show ((rows, columns), mAnn, current, offset)) -- DEBUG where - (Position rows columns) = case mAnn of + res@(Position rows columns) = case mAnn of Just position -> (namePosition position) `difference` current Nothing -> zeroPos arguments :: [Position] arguments = foldMap argumentPosition mAnn - fieldName :: String - fieldName = unpack (Text.decodeUtf8 name) <> ":" - offset :: Int offset = (case arguments of ((Position _ cols):_) -> cols - [] -> 0) - length fieldName - 1 + [] -> 0) - length fieldName - columns -- pp randomly changes ordering, this undoes that sortFields :: [PrettyField (Maybe ExactPosition)] -> [PrettyField (Maybe ExactPosition)] diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 8f4247c6604..5341b747f19 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -31,7 +31,7 @@ import Distribution.Types.Library import Distribution.Types.TestSuite import Distribution.Types.UnqualComponentName import Distribution.Version -import Data.Text(Text, pack) +import Data.Text(Text) import Distribution.Fields.Field(FieldName) import Distribution.Parsec.Position(Position) diff --git a/Cabal-tests/tests/ParserTests/exactPrint/bounded.cabal b/Cabal-tests/tests/ParserTests/exactPrint/bounded.cabal new file mode 100644 index 00000000000..cc17edbe003 --- /dev/null +++ b/Cabal-tests/tests/ParserTests/exactPrint/bounded.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: bounded +version: 0 +synopsis: The -any none demo +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: AnyNone + build-depends: base <5 \ No newline at end of file diff --git a/Cabal-tests/tests/PrinterTests.hs b/Cabal-tests/tests/PrinterTests.hs index f2d268c570c..16d6dd141cd 100644 --- a/Cabal-tests/tests/PrinterTests.hs +++ b/Cabal-tests/tests/PrinterTests.hs @@ -6,42 +6,23 @@ module Main import Prelude () import Prelude.Compat -import Data.Foldable(fold) import Data.Maybe(catMaybes) import Test.Tasty import Data.Text(unpack) -import Test.Tasty.Golden.Advanced (goldenTest) import Test.Tasty.HUnit -import Control.Monad (unless, void) -import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) -import Data.Maybe (isNothing) +import Control.Monad (unless) import Distribution.Fields (runParseResult) -import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) -import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Parsec (PWarnType (..), PWarning (..), showPError, showPWarning) -import Distribution.Pretty (prettyShow) -import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) import System.Directory (setCurrentDirectory) import System.Environment (getArgs, withArgs) -import System.FilePath (replaceExtension, ()) -import Data.Text.Encoding(encodeUtf8, decodeUtf8) +import System.FilePath (()) +import Data.Text.Encoding(decodeUtf8) import Distribution.PackageDescription.ExactPrint(exactPrint) import Data.TreeDiff import Text.PrettyPrint hiding ((<>)) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.List.NonEmpty as NE - -import qualified Distribution.InstalledPackageInfo as IPI - -#ifdef MIN_VERSION_tree_diff -import Data.TreeDiff (ansiWlEditExpr, ediff, toExpr) -import Data.TreeDiff.Golden (ediffGolden) -import Data.TreeDiff.Instances.Cabal () -#endif tests :: TestTree tests = testGroup "printer tests" @@ -55,28 +36,10 @@ tests = testGroup "printer tests" -- Parse some cabal file - print it like cabal file printExact :: TestTree printExact = testGroup "printExact" - [ testParsePrintExact "anynone.cabal" - -- , warningTest "nbsp.cabal" - -- , warningTest "tab.cabal" - -- , warningTest "utf8.cabal" - -- , warningTest "bool.cabal" - -- , warningTest "versiontag.cabal" - -- , warningTest "newsyntax.cabal" - -- , warningTest "oldsyntax.cabal" - -- , warningTest "deprecatedfield.cabal" - -- , warningTest "subsection.cabal" - -- , warningTest "unknownfield.cabal" - -- , warningTest "unknownsection.cabal" - -- , warningTest "trailingfield.cabal" - -- , warningTest "doubledash.cabal" - -- , warningTest "multiplesingular.cabal" - -- , warningTest "wildcard.cabal" - -- , warningTest "operator.cabal" - -- , warningTest "specversion-a.cabal" - -- , warningTest "specversion-b.cabal" - -- , warningTest "specversion-c.cabal" - -- -- TODO: not implemented yet - -- , warningTest PWTExtraTestModule "extratestmodule.cabal" + [ testParsePrintExact "bounded.cabal" + -- , testParsePrintExact "anynone.cabal" -- TODO version ranges + -- broken by: instance Pretty VersionRange where + -- however we currently don't retain enough information to do this exact! ] testParsePrintExact :: FilePath -> TestTree