Introduce FIeldGrammar.

This commit reworks how GenericPackageDescription is parsed from
`[Field Position]` and pretty-printed to `Doc`.

This also fixes few issues:
- Fix haskell#4697: `cabal format` doesn't output custom-setup stanza (nor
  foreign-lib stanzas)
- Fix haskell#4719: `parse . pretty . parse = parse`  for all Hackage cabal files.
    - `parser-hackage-tests roundtrip` is the test program.

The handling of `license-file` and `license-files` is changed.
Now they behave the same.

Author: phadej

Cabal/Cabal.cabal

@@ -33,9 +33,12 @@ extra-source-files:
   -- Do NOT edit this section manually; instead, run the script.
   -- BEGIN gen-extra-source-files
   tests/ParserTests/regressions/Octree-0.5.cabal
+  tests/ParserTests/regressions/elif.cabal
   tests/ParserTests/regressions/encoding-0.8.cabal
+  tests/ParserTests/regressions/generics-sop.cabal
   tests/ParserTests/regressions/issue-774.cabal
   tests/ParserTests/regressions/nothing-unicode.cabal
+  tests/ParserTests/regressions/shake.cabal
   tests/ParserTests/warnings/bom.cabal
   tests/ParserTests/warnings/bool.cabal
   tests/ParserTests/warnings/deprecatedfield.cabal
@@ -274,18 +277,22 @@ library
     parsec >= 3.1.9 && <3.2
   exposed-modules:
     Distribution.Compat.Parsec
+    Distribution.FieldGrammar
+    Distribution.FieldGrammar.Class
+    Distribution.FieldGrammar.Parsec
+    Distribution.FieldGrammar.Pretty
+    Distribution.PackageDescription.FieldGrammar
     Distribution.PackageDescription.Parsec
-    Distribution.PackageDescription.Parsec.FieldDescr
-    Distribution.PackageDescription.Parsec.Quirks
+    Distribution.PackageDescription.Quirks
     Distribution.Parsec.Class
+    Distribution.Parsec.Common
     Distribution.Parsec.ConfVar
+    Distribution.Parsec.Field
     Distribution.Parsec.Lexer
     Distribution.Parsec.LexerMonad
+    Distribution.Parsec.Newtypes
+    Distribution.Parsec.ParseResult
     Distribution.Parsec.Parser
-    Distribution.Parsec.Types.Common
-    Distribution.Parsec.Types.Field
-    Distribution.Parsec.Types.FieldDescr
-    Distribution.Parsec.Types.ParseResult
 
   -- Lens functionality
   exposed-modules:
@@ -400,6 +407,7 @@ test-suite parser-tests
   type: exitcode-stdio-1.0
   hs-source-dirs: tests
   main-is: ParserTests.hs
+  build-depends: containers
   build-depends:
     base,
     bytestring,
@@ -450,7 +458,7 @@ test-suite parser-hackage-tests
 
   if flag(parsec-struct-diff)
     build-depends:
-      generics-sop >= 0.2.5 && <0.3,
+      generics-sop >= 0.3.1.0 && <0.4,
       these >=0.7.1 && <0.8,
       singleton-bool >=0.1.1.0 && <0.2,
       keys

Cabal/Distribution/Compat/Map/Strict.hs

@@ -12,6 +12,7 @@ module Distribution.Compat.Map.Strict
 #ifdef HAVE_containers_050
 #else
     , insertWith
+    , fromSet
 #endif
     ) where
 
@@ -20,7 +21,11 @@ import Data.Map.Strict as X
 #else
 import Data.Map as X hiding (insertWith, insertWith')
 import qualified Data.Map
+import qualified Data.Set
 
 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
 insertWith = Data.Map.insertWith'
+
+fromSet :: (k -> a) -> Data.Set.Set k -> Map k a
+fromSet f = Data.Map.fromDistinctAscList . Prelude.map (\k -> (k, f k)) . Data.Set.toList
 #endif

Cabal/Distribution/Compat/Parsec.hs

@@ -25,6 +25,7 @@ module Distribution.Compat.Parsec (
     P.satisfy,
     P.space,
     P.spaces,
+    skipSpaces1,
     P.string,
     munch,
     munch1,
@@ -72,3 +73,6 @@ munch
     => (Char -> Bool)
     -> P.ParsecT s u m String
 munch = many . P.satisfy
+
+skipSpaces1 :: P.Stream s m Char => P.ParsecT s u m ()
+skipSpaces1 = P.skipMany1 P.space

Cabal/Distribution/Compat/ReadP.hs

@@ -67,17 +67,23 @@ module Distribution.Compat.ReadP
   -- * Running a parser
   ReadS,      -- :: *; = String -> [(a,String)]
   readP_to_S, -- :: ReadP a -> ReadS a
-  readS_to_P  -- :: ReadS a -> ReadP a
+  readS_to_P, -- :: ReadS a -> ReadP a
+
+  -- ** Parsec
+  parsecToReadP,
   )
  where
 
 import Prelude ()
 import Distribution.Compat.Prelude hiding (many, get)
+import Control.Applicative (liftA2)
 
 import qualified Distribution.Compat.MonadFail as Fail
 
 import Control.Monad( replicateM, (>=>) )
 
+import qualified Text.Parsec as P
+
 infixr 5 +++, <++
 
 -- ---------------------------------------------------------------------------
@@ -414,3 +420,16 @@ readS_to_P :: ReadS a -> ReadP r a
 --   parser, and therefore a possible inefficiency.
 readS_to_P r =
   R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
+
+-- ---------------------------------------------------------------------------
+-- Converting from Parsec to ReadP
+--
+-- | Convert @Parsec@ parser to 'ReadP'.
+parsecToReadP
+    :: P.Parsec [Char] u a
+    -> u                 -- ^ initial user state
+    -> ReadP r a
+parsecToReadP p u = R $ \k -> Look $ \s ->
+    case P.runParser (liftA2 (,) p P.getInput) u "<parsecToReadP>" s of
+        Right (x, s') -> final (run (k x) s')
+        Left _        -> Fail

Cabal/Distribution/Compiler.hs

@@ -51,8 +51,11 @@ import Language.Haskell.Extension
 import Distribution.Version (Version, mkVersion', nullVersion)
 
 import qualified System.Info (compilerName, compilerVersion)
+import Distribution.Parsec.Class (Parsec (..))
+import Distribution.Pretty (Pretty (..))
 import Distribution.Text (Text(..), display)
 import qualified Distribution.Compat.ReadP as Parse
+import qualified Distribution.Compat.Parsec as P
 import qualified Text.PrettyPrint as Disp
 
 data CompilerFlavor =
@@ -66,12 +69,20 @@ instance Binary CompilerFlavor
 knownCompilerFlavors :: [CompilerFlavor]
 knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
 
-instance Text CompilerFlavor where
-  disp (OtherCompiler name) = Disp.text name
-  disp (HaskellSuite name)  = Disp.text name
-  disp NHC                  = Disp.text "nhc98"
-  disp other                = Disp.text (lowercase (show other))
+instance Pretty CompilerFlavor where
+  pretty (OtherCompiler name) = Disp.text name
+  pretty (HaskellSuite name)  = Disp.text name
+  pretty NHC                  = Disp.text "nhc98"
+  pretty other                = Disp.text (lowercase (show other))
+
+instance Parsec CompilerFlavor where
+    parsec = classifyCompilerFlavor <$> component
+      where
+        component = do
+          cs <- P.munch1 isAlphaNum
+          if all isDigit cs then fail "all digits compiler name" else return cs
 
+instance Text CompilerFlavor where
   parse = do
     comp <- Parse.munch1 isAlphaNum
     when (all isDigit comp) Parse.pfail
@@ -81,7 +92,7 @@ classifyCompilerFlavor :: String -> CompilerFlavor
 classifyCompilerFlavor s =
   fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap
   where
-    compilerMap = [ (display compiler, compiler)
+    compilerMap = [ (lowercase (display compiler), compiler)
                   | compiler <- knownCompilerFlavors ]
 
 

Cabal/Distribution/FieldGrammar.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- | This module provides a way to specify a grammar of @.cabal@ -like files.
+module Distribution.FieldGrammar  (
+    -- * Field grammar type
+    FieldGrammar (..),
+    uniqueField,
+    optionalField,
+    optionalFieldDef,
+    optionalFieldDefAla,
+    monoidalField,
+    deprecatedField',
+    -- * Concrete grammar implementations
+    ParsecFieldGrammar,
+    ParsecFieldGrammar',
+    parseFieldGrammar,
+    fieldGrammarKnownFieldList,
+    PrettyFieldGrammar,
+    PrettyFieldGrammar',
+    prettyFieldGrammar,
+    -- * Auxlilary
+    (^^^),
+    Section(..),
+    Fields,
+    partitionFields,
+    takeFields,
+    runFieldParser,
+    runFieldParser',
+    )  where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import qualified Distribution.Compat.Map.Strict as Map
+
+import Distribution.FieldGrammar.Class
+import Distribution.FieldGrammar.Parsec
+import Distribution.FieldGrammar.Pretty
+import Distribution.Parsec.Field
+import Distribution.Utils.Generic (spanMaybe)
+
+type ParsecFieldGrammar' a = ParsecFieldGrammar a a
+type PrettyFieldGrammar' a = PrettyFieldGrammar a a
+
+infixl 5 ^^^
+
+-- | Reverse function application which binds tighter than '<$>' and '<*>'.
+-- Useful for refining grammar specification.
+--
+-- @
+-- \<*\> 'monoidalFieldAla' "extensions"           (alaList' FSep MQuoted)       oldExtensions
+--     ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields."
+-- @
+(^^^) :: a -> (a -> b) -> b
+x ^^^ f = f x
+
+-- | Partitionin state
+data PS ann = PS (Fields ann) [Section ann] [[Section ann]]
+
+-- | Partition field list into field map and groups of sections.
+partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
+partitionFields = finalize . foldl' f (PS mempty mempty mempty)
+  where
+    finalize :: PS ann -> (Fields ann, [[Section ann]])
+    finalize (PS fs s ss)
+        | null s    = (fs, reverse ss)
+        | otherwise = (fs, reverse (reverse s : ss))
+
+    f :: PS ann -> Field ann -> PS ann
+    f (PS fs s ss) (Field (Name ann name) fss) =
+        PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
+      where
+        ss' | null s    = ss
+            | otherwise = reverse s : ss
+    f (PS fs s ss) (Section name sargs sfields) =
+        PS fs (MkSection name sargs sfields : s) ss
+
+-- | Take all fields from the front.
+takeFields :: [Field ann] -> (Fields ann, [Field ann])
+takeFields = finalize . spanMaybe match
+  where
+    finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest)
+
+    match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs])
+    match _ = Nothing