WIP [ci skip]

haskell · Aug 16, 2017 · 861bdb2 · 861bdb2
1 parent e3ca680
commit 861bdb2
Show file tree

Hide file tree

Showing 7 changed files with 602 additions and 29 deletions.
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -281,6 +281,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 +381,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,

diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/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"
+                <$> affineField    "type"                repoType
+                <*> affineFieldAla "location" FreeText   repoLocation
+                <*> affineFieldAla "module"   Token      repoModule
+                <*> affineFieldAla "branch"   Token      repoBranch
+                <*> affineFieldAla "tag"      Token      repoTag
+                <*> affineFieldAla "subdir"   FilePathNT repoSubdir
+
             -- I want lens
             let pd =  packageDescription gpd
             let srs = sourceRepos pd

diff --git a/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs b/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
 -------------------------------------------------------------------------------