WIP [ci skip]

Cabal/Cabal.cabal

@@ -133,6 +133,7 @@ library
     Distribution.Compat.Graph
     Distribution.Compat.Internal.TempFile
     Distribution.Compat.Map.Strict
+    Distribution.Compat.Newtype
     Distribution.Compat.Prelude.Internal
     Distribution.Compat.ReadP
     Distribution.Compat.Semigroup
@@ -281,6 +282,7 @@ library
     Distribution.Parsec.Types.Common
     Distribution.Parsec.Types.Field
     Distribution.Parsec.Types.FieldDescr
+    Distribution.Parsec.Types.FieldParser
     Distribution.Parsec.Types.ParseResult
 
   other-modules:
@@ -380,6 +382,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,

Cabal/Distribution/Compat/Newtype.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+-- | Per Conor McBride, the 'Newtype' typeclass represents the packing and
+-- unpacking of a newtype, and allows you to operatate under that newtype with
+-- functions such as 'ala'.
+module Distribution.Compat.Newtype where
+
+-- TODO: export only Newtype (..), ala
+
+import           Data.Functor.Identity (Identity (..))
+
+-- tmp
+import           Control.Applicative (many)
+import           Distribution.Text (Text)
+import qualified Distribution.Compat.Parsec            as Parsec
+import           Distribution.Parsec.Class
+
+class Newtype n o | n -> o where
+    pack   :: o -> n
+    unpack :: n -> o
+
+instance Newtype (Identity a) a where
+    pack   = Identity
+    unpack = runIdentity
+
+ala :: (Newtype n o, Newtype n' o') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o')
+ala pa hof = ala' pa hof id
+
+ala' :: (Newtype n o, Newtype n' o') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o')
+ala' _ hof f = unpack . hof (pack . f)
+
+-------------------------------------------------------------------------------
+-- Move to own module
+-------------------------------------------------------------------------------
+
+newtype CommaListWithSep a = CommaListWithSep { getCommaListWithSep :: [a] }
+
+instance Newtype (CommaListWithSep a) [a] where
+    pack = CommaListWithSep
+    unpack = getCommaListWithSep
+
+instance Parsec a => Parsec (CommaListWithSep a) where
+    parsec = pack <$> parsecOptCommaList parsec
+
+instance Text a => Text (CommaListWithSep a) where
+
+--
+newtype Token = Token { getToken :: String }
+
+instance Parsec Token where
+    parsec = pack <$> parsecToken
+
+instance Newtype Token String where
+    pack = Token
+    unpack = getToken
+
+instance Text Token
+
+--
+newtype FreeText = FreeText { getFreeText :: String }
+
+instance Parsec FreeText where
+    parsec = pack <$> many Parsec.anyChar 
+
+instance Newtype FreeText String where
+    pack = FreeText
+    unpack = getFreeText
+
+instance Text FreeText
+
+--
+newtype FilePathNT = FilePathNT { getFilePathNT ::  FilePath }
+
+instance Parsec FilePathNT where
+    parsec = pack <$> parsecFilePath
+
+instance Newtype FilePathNT FilePath where
+    pack = FilePathNT
+    unpack = getFilePathNT
+
+instance Text FilePathNT
+
+-------------------------------------------------------------------------------
+-- Identity
+-------------------------------------------------------------------------------
+--
+instance Parsec a => Parsec (Identity a) where
+    parsec = pack <$> parsec
+
+instance Text (Identity a) where

Cabal/Distribution/PackageDescription/Parsec.hs

@@ -48,6 +48,7 @@ import           Distribution.Parsec.Parser
 import           Distribution.Parsec.Types.Common
 import           Distribution.Parsec.Types.Field                   (getName)
 import           Distribution.Parsec.Types.FieldDescr
+import           Distribution.Parsec.Types.FieldParser
 import           Distribution.Parsec.Types.ParseResult
 import           Distribution.Simple.Utils
                  (die', fromUTF8BS, warn)
@@ -65,6 +66,8 @@ import           System.Directory
 import qualified Text.Parsec                                       as P
 import qualified Text.Parsec.Error                                 as P
 
+import Debug.Trace
+
 -- ---------------------------------------------------------------
 -- Parsing
 
@@ -297,7 +300,18 @@ parseGenericPackageDescription' lexWarnings fs = do
                 _ -> do
                     parseFailure pos $ "Invalid source-repository kind " ++ show args
                     pure RepoHead
-            sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields
+
+            let (fs, ss) = partitionFields fields
+            -- traverse_ (traverse_ warnSubsection) ss
+
+            sr <- runFieldFancy fs $ SourceRepo kind -- todo "pure fields"
+                <$> optionalField    "type"                repoType
+                <*> optionalFieldAla "location" FreeText   repoLocation
+                <*> optionalFieldAla "module"   Token      repoModule
+                <*> optionalFieldAla "branch"   Token      repoBranch
+                <*> optionalFieldAla "tag"      Token      repoTag
+                <*> optionalFieldAla "subdir"   FilePathNT repoSubdir
+
             -- I want lens
             let pd =  packageDescription gpd
             let srs = sourceRepos pd

Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs

@@ -27,8 +27,6 @@ module Distribution.PackageDescription.Parsec.FieldDescr (
     validateBenchmark,
     -- * Flag
     flagFieldDescrs,
-    -- * Source repository
-    sourceRepoFieldDescrs,
     -- * Setup build info
     setupBInfoFieldDescrs,
     ) where
@@ -551,32 +549,6 @@ flagFieldDescrs =
         flagManual       (\val fl -> fl{ flagManual = val })
     ]
 
--------------------------------------------------------------------------------
--- SourceRepo
--------------------------------------------------------------------------------
-
-sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
-sourceRepoFieldDescrs =
-    [ simpleField "type"
-        (maybe mempty disp)         (Just <$> parsec)
-        repoType                    (\val repo -> repo { repoType = val })
-    , simpleField "location"
-        (maybe mempty showFreeText) (Just <$> freeTextFieldParser)
-        repoLocation                (\val repo -> repo { repoLocation = val })
-    , simpleField "module"
-        (maybe mempty showToken)    (Just <$> parsecToken)
-        repoModule                  (\val repo -> repo { repoModule = val })
-    , simpleField "branch"
-        (maybe mempty showToken)    (Just <$> parsecToken)
-        repoBranch                  (\val repo -> repo { repoBranch = val })
-    , simpleField "tag"
-        (maybe mempty showToken)    (Just <$> parsecToken)
-        repoTag                     (\val repo -> repo { repoTag = val })
-    , simpleField "subdir"
-        (maybe mempty showFilePath) (Just <$> parsecFilePath)
-        repoSubdir                  (\val repo -> repo { repoSubdir = val })
-    ]
-
 -------------------------------------------------------------------------------
 -- SetupBuildInfo
 -------------------------------------------------------------------------------