Initial draft exact printer

Author: jappeace

Cabal-syntax/Cabal-syntax.cabal

@@ -197,6 +197,7 @@ library
     Distribution.Utils.String
     Distribution.Utils.Structured
     Distribution.Version
+    Distribution.PackageDescription.ExactPrint
     Language.Haskell.Extension
 
   other-extensions:

Cabal-syntax/src/Distribution/Fields/Pretty.hs

@@ -15,6 +15,7 @@ module Distribution.Fields.Pretty
   , PrettyField (..)
   , showFields
   , showFields'
+  , prettyFieldAnn
 
     -- * Transformation from 'P.Field'
   , fromParsecFields
@@ -47,6 +48,13 @@ data PrettyField ann
   | PrettyEmpty
   deriving (Functor, Foldable, Traversable)
 
+
+prettyFieldAnn :: PrettyField ann -> Maybe ann
+prettyFieldAnn = \case
+  PrettyField ann _ _ -> Just ann
+  PrettySection ann _ _ _ -> Just ann
+  PrettyEmpty -> Nothing
+
 -- | Prettyprint a list of fields.
 --
 -- Note: the first argument should return 'String's without newlines

Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs

@@ -476,7 +476,7 @@ finalizePD
   (Platform arch os)
   impl
   constraints
-  (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do
+  (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0 _exactPrintMeta) = do
     (targetSet, flagVals) <-
       resolveWithFlags flagChoices enabled os arch impl constraints condTrees check
     let
@@ -556,7 +556,7 @@ resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribu
 -- function.
 flattenPackageDescription :: GenericPackageDescription -> PackageDescription
 flattenPackageDescription
-  (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) =
+  (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0 _exactPrintMeta) =
     pkg
       { library = mlib
       , subLibraries = reverse sub_libs

Cabal-syntax/src/Distribution/PackageDescription/ExactPrint.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Distribution.PackageDescription.ExactPrint
+  (exactPrint
+  ) where
+
+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 qualified Data.Map as Map
+import Data.Map(Map)
+import Distribution.Fields.Pretty
+import qualified Data.Text.Encoding as Text
+import Distribution.Fields.Field(FieldName)
+import Distribution.Parsec.Position
+import Data.List(sortOn)
+import Control.Monad(join)
+import Distribution.PackageDescription(specVersion)
+
+exactPrint :: GenericPackageDescription -> Text
+exactPrint package = foldExactly (exactPrintMeta package) fields
+  where
+    fields :: [PrettyField ()]
+    fields = ppGenericPackageDescription (specVersion  (packageDescription (package))) package
+
+
+
+foldExactly :: ExactPrintMeta -> [PrettyField ()] -> Text
+foldExactly meta' pretty = pack $ PP.render $ currentDoc $ renderLines emptyState positioned
+  where
+    positioned :: [PrettyField (Maybe ExactPosition)]
+    positioned = sortFields $ attachPositions (exactPositions meta') pretty
+
+data RenderState = MkRenderState {
+     currentPosition :: Position
+   , currentDoc :: Doc
+  }
+
+emptyState :: RenderState
+emptyState = MkRenderState {
+     currentPosition = Position 1 1
+   , currentDoc = mempty
+  }
+
+renderLines ::
+  RenderState ->
+  [PrettyField (Maybe ExactPosition)] -> -- ^ assuming the lines are sorted on exact position
+  RenderState
+renderLines state' fields =
+  foldr renderLine state' fields
+
+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,
+          currentPosition = newPosition
+        }
+  PrettySection ann name' ppDoc sectionFields -> previous -- TODO render section
+  PrettyEmpty -> previous
+
+renderWithPositionAdjustment :: (Maybe ExactPosition) -> Position -> FieldName -> Doc -> Doc
+renderWithPositionAdjustment mAnn current  name doc =
+  if rows < 0 then error "unexpected empty negative rows"
+  else
+    let
+      spacing :: Doc
+      spacing = foldr ($+$) mempty ("" <$  [1..rows])
+    in
+  spacing $$
+  (PP.nest columns
+  (PP.text fieldName ) <> ((PP.hsep ("" <$ [0..offset])) <> doc))
+  -- <+> "--" <+> PP.text (show ((rows, columns), mAnn, current, offset)) -- DEBUG
+  where
+     (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
+
+-- pp randomly changes ordering, this undoes that
+sortFields :: [PrettyField (Maybe ExactPosition)] -> [PrettyField (Maybe ExactPosition)]
+sortFields = reverse . sortOn (join . prettyFieldAnn)
+
+attachPositions :: Map FieldName ExactPosition -> [PrettyField ()] -> [PrettyField (Maybe ExactPosition)]
+attachPositions positionLookup = map (annotatePositions positionLookup)
+
+annotatePositions :: Map FieldName ExactPosition -> PrettyField () -> PrettyField (Maybe ExactPosition)
+annotatePositions positionLookup = \case
+  PrettyField _ann name' doc ->
+    PrettyField (Map.lookup name' positionLookup) name' doc
+  PrettySection _ann name' ppDoc sectionFields ->
+    PrettySection (Map.lookup name' positionLookup) name' ppDoc (attachPositions positionLookup sectionFields)
+  PrettyEmpty -> PrettyEmpty

Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs

@@ -41,7 +41,7 @@ import Distribution.Compat.Lens
 import Distribution.FieldGrammar
 import Distribution.FieldGrammar.Parsec (NamelessField (..))
 import Distribution.Fields.ConfVar (parseConditionConfVar)
-import Distribution.Fields.Field (FieldName, getName)
+import Distribution.Fields.Field (FieldName, getName, fieldLineAnn, sectionArgAnn, nameAnn)
 import Distribution.Fields.LexerMonad (LexWarning, toPWarnings)
 import Distribution.Fields.ParseResult
 import Distribution.Fields.Parser
@@ -92,11 +92,11 @@ parseGenericPackageDescription bs = do
     _ -> pure Nothing
 
   case readFields' bs'' of
-    Right (fs, lexWarnings) -> do
+    Right (fields, lexWarnings) -> do
       when patched $
         parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
       -- UTF8 is validated in a prepass step, afterwards parsing is lenient.
-      parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs
+      parseGenericPackageDescription' csv lexWarnings invalidUtf8 fields
     -- TODO: better marshalling of errors
     Left perr -> parseFatalFailure pos (show perr)
       where
@@ -151,11 +151,11 @@ parseGenericPackageDescription'
   -> Maybe Int
   -> [Field Position]
   -> ParseResult GenericPackageDescription
-parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do
+parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fieldPositions = do
   parseWarnings (toPWarnings lexWarnings)
   for_ utf8WarnPos $ \pos ->
     parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
-  let (syntax, fs') = sectionizeFields fs
+  let (syntax, fs') = sectionizeFields fieldPositions
   let (fields, sectionFields) = takeFields fs'
 
   -- cabal-version
@@ -199,7 +199,8 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do
 
   -- Sections
   let gpd =
-        emptyGenericPackageDescription
+        (emptyGenericPackageDescription
+          { exactPrintMeta = ExactPrintMeta { exactPositions = toExact fieldPositions, exactComments = mempty} })
           & L.packageDescription .~ pd
   gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)
 
@@ -234,6 +235,20 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do
               ++ "' must use section syntax. See the Cabal user guide for details."
     maybeWarnCabalVersion _ _ = return ()
 
+toExact :: [Field Position] -> Map FieldName ExactPosition
+toExact = foldr toExactStep mempty
+
+toExactStep :: Field Position -> Map FieldName ExactPosition -> Map FieldName ExactPosition
+toExactStep field prev =  case field of
+  Field name lines' ->
+    Map.insert (getName name)
+               (ExactPosition { namePosition = (nameAnn name), argumentPosition = (fieldLineAnn <$> lines')})
+                prev
+  Section name args fields' ->
+    Map.insert (getName name)
+               (ExactPosition { namePosition = (nameAnn name), argumentPosition = (sectionArgAnn <$> args)})
+                          $ foldr toExactStep prev fields'
+
 goSections :: CabalSpecVersion -> [Field Position] -> SectionParser ()
 goSections specVer = traverse_ process
   where

Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs

@@ -237,6 +237,7 @@ pdToGpd pd =
     , condExecutables = mkCondTree' exeName <$> executables pd
     , condTestSuites = mkCondTree' testName <$> testSuites pd
     , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd
+    , exactPrintMeta = emptyExactPrintMeta
     }
   where
     -- We set CondTree's [Dependency] to an empty list, as it

Cabal-syntax/src/Distribution/Parsec/Position.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module Distribution.Parsec.Position
   ( Position (..)
@@ -8,6 +9,7 @@ module Distribution.Parsec.Position
   , zeroPos
   , positionCol
   , positionRow
+  , difference
   ) where
 
 import Distribution.Compat.Prelude
@@ -18,10 +20,11 @@ data Position
   = Position
       {-# UNPACK #-} !Int -- row
       {-# UNPACK #-} !Int -- column
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show, Generic, Data)
 
 instance Binary Position
 instance NFData Position where rnf = genericRnf
+instance Structured Position
 
 -- | Shift position by n columns to the right.
 incPos :: Int -> Position -> Position
@@ -44,3 +47,6 @@ positionCol (Position _ c) = c
 -- | @since 3.0.0.0
 positionRow :: Position -> Int
 positionRow (Position r _) = r
+
+difference :: Position -> Position -> Position
+difference (Position a1 a2) (Position b1 b2) = Position (a1 - b1) (a2 - b2)

Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs

@@ -5,7 +5,10 @@
 
 module Distribution.Types.GenericPackageDescription
   ( GenericPackageDescription (..)
+  , ExactPrintMeta(..)
+  , ExactPosition(..)
   , emptyGenericPackageDescription
+  , emptyExactPrintMeta
   ) where
 
 import Distribution.Compat.Prelude
@@ -28,6 +31,30 @@ import Distribution.Types.Library
 import Distribution.Types.TestSuite
 import Distribution.Types.UnqualComponentName
 import Distribution.Version
+import Data.Text(Text, pack)
+import Distribution.Fields.Field(FieldName)
+import Distribution.Parsec.Position(Position)
+
+data ExactPosition = ExactPosition {namePosition :: Position
+                                -- argument can be filedline or section args
+                                -- recursive names within sections have their own
+                                -- name identifier so they're not modelled
+                                , argumentPosition :: [Position] }
+  deriving (Show, Eq, Typeable, Data, Generic, Ord)
+instance Structured ExactPosition
+instance NFData ExactPosition where rnf = genericRnf
+instance Binary ExactPosition
+
+
+data ExactPrintMeta = ExactPrintMeta
+  { exactPositions :: Map FieldName ExactPosition
+  , exactComments :: Map Position Text
+  }
+  deriving (Show, Eq, Typeable, Data, Generic)
+
+instance Binary ExactPrintMeta
+instance Structured ExactPrintMeta
+instance NFData ExactPrintMeta where rnf = genericRnf
 
 -- ---------------------------------------------------------------------------
 -- The 'GenericPackageDescription' type
@@ -70,24 +97,42 @@ data GenericPackageDescription = GenericPackageDescription
            , CondTree ConfVar [Dependency] Benchmark
            )
          ]
+  , exactPrintMeta :: ExactPrintMeta
   }
   deriving (Show, Eq, Typeable, Data, Generic)
 
+
 instance Package GenericPackageDescription where
   packageId = packageId . packageDescription
 
-instance Binary GenericPackageDescription
 instance Structured GenericPackageDescription
+
+-- | Required for rebuild monad
+instance Binary GenericPackageDescription
 instance NFData GenericPackageDescription where rnf = genericRnf
 
+emptyExactPrintMeta :: ExactPrintMeta
+emptyExactPrintMeta = ExactPrintMeta mempty mempty
+
 emptyGenericPackageDescription :: GenericPackageDescription
-emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] []
+emptyGenericPackageDescription = GenericPackageDescription
+  { packageDescription = emptyPackageDescription
+  , gpdScannedVersion = Nothing
+  , genPackageFlags = []
+  , condLibrary =  Nothing
+  , condSubLibraries = []
+  , condForeignLibs = []
+  , condExecutables = []
+  , condTestSuites = []
+  , condBenchmarks = []
+  , exactPrintMeta = emptyExactPrintMeta
+  }
 
 -- -----------------------------------------------------------------------------
 -- Traversal Instances
 
 instance L.HasBuildInfos GenericPackageDescription where
-  traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
+  traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6 exactPrintMeta') =
     GenericPackageDescription
       <$> L.traverseBuildInfos f p
       <*> pure v
@@ -98,6 +143,7 @@ instance L.HasBuildInfos GenericPackageDescription where
       <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4
       <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5
       <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6
+      <*> pure exactPrintMeta'
 
 -- We use this traversal to keep [Dependency] field in CondTree up to date.
 traverseCondTreeBuildInfo
@@ -118,3 +164,4 @@ traverseCondTreeBuildInfo g = node
       CondBranch v
         <$> node x
         <*> traverse node y
+

Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs

@@ -81,7 +81,7 @@ allCondTrees
      )
   -> GenericPackageDescription
   -> f GenericPackageDescription
-allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
+allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6 exactPrintMeta) =
   GenericPackageDescription
     <$> pure p
     <*> pure v
@@ -92,6 +92,7 @@ allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
     <*> (traverse . _2) f x4
     <*> (traverse . _2) f x5
     <*> (traverse . _2) f x6
+    <*> pure exactPrintMeta
 
 -------------------------------------------------------------------------------
 -- Flag