add section

the constraints are missing? make a non trival test pass remove unused imports make comment clearer
haskell · Nov 13, 2023 · f434639 · f434639
1 parent d12c1cd
commit f434639
Show file tree

Hide file tree

Showing 4 changed files with 45 additions and 58 deletions.
diff --git 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,45 +60,55 @@ 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
       spacing = foldr ($+$) mempty ("" <$  [1..rows])
     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
@@ -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
@@ -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
diff --git 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