[WIP] Implement External Custom Setup

Cabal/Distribution/Package.hs

@@ -18,6 +18,7 @@
 
 module Distribution.Package (
         -- * Package ids
+        UnqualComponentName, unUnqualComponentName, mkUnqualComponentName,
         PackageName, unPackageName, mkPackageName,
         PackageIdentifier(..),
         PackageId,
@@ -41,6 +42,7 @@ module Distribution.Package (
 
         -- * Package source dependencies
         Dependency(..),
+        ExeDependency(..),
         thisPackageVersion,
         notThisPackageVersion,
         simplifyDependency,
@@ -69,6 +71,44 @@ import Distribution.ModuleName
 
 import Text.PrettyPrint ((<+>), text)
 
+-- | A Component name, or other similarly-parsed identifier.
+--
+newtype UnqualComponentName = UnqualComponentName ShortText
+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,
+              Semigroup, Monoid) -- TODO: bad enabler of bad monoids
+
+-- | Convert 'UnqualComponentName' to 'String'
+unUnqualComponentName :: UnqualComponentName -> String
+unUnqualComponentName (UnqualComponentName s) = fromShortText s
+
+-- | Construct a 'UnqualComponentName' from a 'String'
+--
+-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName'
+--
+-- Note: No validations are performed to ensure that the resulting
+-- 'UnqualComponentName' is valid
+--
+-- @since 2.0
+mkUnqualComponentName :: String -> UnqualComponentName
+mkUnqualComponentName = UnqualComponentName . toShortText
+
+instance Binary UnqualComponentName
+
+instance Text UnqualComponentName where
+  disp = Disp.text . unUnqualComponentName
+  parse = do
+    ns <- Parse.sepBy1 component (Parse.char '-')
+    return (mkUnqualComponentName (intercalate "-" ns))
+    where
+      component = do
+        cs <- Parse.munch1 isAlphaNum
+        if all isDigit cs then Parse.pfail else return cs
+        -- each component must contain an alphabetic character, to avoid
+        -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+instance NFData UnqualComponentName where
+    rnf (UnqualComponentName pkg) = rnf pkg
+
 -- | A package name.
 --
 -- Use 'mkPackageName' and 'unPackageName' to convert from/to a
@@ -77,12 +117,13 @@ import Text.PrettyPrint ((<+>), text)
 -- This type is opaque since @Cabal-2.0@
 --
 -- @since 2.0
-newtype PackageName = PackageName ShortText
-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+newtype PackageName = PackageName UnqualComponentName
+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,
+              Binary, Text, NFData)
 
 -- | Convert 'PackageName' to 'String'
 unPackageName :: PackageName -> String
-unPackageName (PackageName s) = fromShortText s
+unPackageName (PackageName n) = unUnqualComponentName n
 
 -- | Construct a 'PackageName' from a 'String'
 --
@@ -93,24 +134,7 @@ unPackageName (PackageName s) = fromShortText s
 --
 -- @since 2.0
 mkPackageName :: String -> PackageName
-mkPackageName = PackageName . toShortText
-
-instance Binary PackageName
-
-instance Text PackageName where
-  disp = Disp.text . unPackageName
-  parse = do
-    ns <- Parse.sepBy1 component (Parse.char '-')
-    return (mkPackageName (intercalate "-" ns))
-    where
-      component = do
-        cs <- Parse.munch1 isAlphaNum
-        if all isDigit cs then Parse.pfail else return cs
-        -- each component must contain an alphabetic character, to avoid
-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).
-
-instance NFData PackageName where
-    rnf (PackageName pkg) = rnf pkg
+mkPackageName = PackageName . mkUnqualComponentName
 
 -- | Type alias so we can use the shorter name PackageId.
 type PackageId = PackageIdentifier
@@ -291,7 +315,16 @@ mkLegacyUnitId = newSimpleUnitId . mkComponentId . display
 data Dependency = Dependency PackageName VersionRange
                   deriving (Generic, Read, Show, Eq, Typeable, Data)
 
+-- | Describes a dependency on an executable from a package
+--
+data ExeDependency = ExeDependency
+                     PackageName
+                     UnqualComponentName -- ^ name of executable component of package
+                     VersionRange
+                     deriving (Generic, Read, Show, Eq, Typeable, Data)
+
 instance Binary Dependency
+instance Binary ExeDependency
 
 instance Text Dependency where
   disp (Dependency name ver) =
@@ -303,7 +336,20 @@ instance Text Dependency where
              Parse.skipSpaces
              return (Dependency name ver)
 
+instance Text ExeDependency where
+  disp (ExeDependency name exe ver) =
+    (disp name <<>> Disp.text ":" <<>> disp exe) <+> disp ver
+
+  parse = do name <- parse
+             _ <- Parse.char ':'
+             exe <- parse
+             Parse.skipSpaces
+             ver <- parse <++ return anyVersion
+             Parse.skipSpaces
+             return (ExeDependency name exe ver)
+
 instance NFData Dependency where rnf = genericRnf
+instance NFData ExeDependency where rnf = genericRnf
 
 thisPackageVersion :: PackageIdentifier -> Dependency
 thisPackageVersion (PackageIdentifier n v) =

Cabal/Distribution/PackageDescription/Check.hs

@@ -184,13 +184,15 @@ checkSanity pkg =
         ++ "Only the non-internal library can have the same name as the package."
 
   , check (not (null duplicateNames)) $
-      PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames
+      PackageBuildImpossible $ "Duplicate sections: "
+        ++ commaSep (unUnqualComponentName <$> duplicateNames)
         ++ ". The name of every library, executable, test suite,"
         ++ " and benchmark section in"
         ++ " the package must be unique."
 
   -- NB: but it's OK for executables to have the same name!
-  , check (any (== display (packageName pkg)) subLibNames) $
+  -- TODO shouldn't need to compare on the string level
+  , check (any (== display (packageName pkg)) (display <$> subLibNames)) $
       PackageBuildImpossible $ "Illegal internal library name "
         ++ display (packageName pkg)
         ++ ". Internal libraries cannot have the same name as the package."
@@ -205,6 +207,7 @@ checkSanity pkg =
   ++ concatMap (checkExecutable pkg) (executables pkg)
   ++ concatMap (checkTestSuite  pkg) (testSuites pkg)
   ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)
+  ++ concatMap (checkSetup      pkg) (maybeToList $ setupBuildInfo pkg)
 
   ++ catMaybes [
 
@@ -238,7 +241,7 @@ checkLibrary pkg lib =
       PackageDistSuspiciousWarn $
            "Library " ++ (case libName lib of
                             Nothing -> ""
-                            Just n -> n
+                            Just n -> display n
                             ) ++ "does not expose any modules"
 
     -- check use of signatures sections
@@ -272,7 +275,7 @@ checkExecutable pkg exe =
 
     check (null (modulePath exe)) $
       PackageBuildImpossible $
-        "No 'main-is' field found for executable " ++ exeName exe
+        "No 'main-is' field found for executable " ++ display (exeName exe)
 
   , check (not (null (modulePath exe))
        && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $
@@ -290,14 +293,14 @@ checkExecutable pkg exe =
 
   , check (not (null moduleDuplicates)) $
        PackageBuildImpossible $
-            "Duplicate modules in executable '" ++ exeName exe ++ "': "
+            "Duplicate modules in executable '" ++ display (exeName exe) ++ "': "
          ++ commaSep (map display moduleDuplicates)
 
     -- check that all autogen-modules appear on other-modules
   , check
       (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $
       PackageBuildImpossible $
-           "On executable '" ++ exeName exe ++ "' an 'autogen-module' is not "
+           "On executable '" ++ display (exeName exe) ++ "' an 'autogen-module' is not "
         ++ "on 'other-modules'"
 
   ]
@@ -324,7 +327,7 @@ checkTestSuite pkg test =
 
   , check (not $ null moduleDuplicates) $
       PackageBuildImpossible $
-           "Duplicate modules in test suite '" ++ testName test ++ "': "
+           "Duplicate modules in test suite '" ++ display (testName test) ++ "': "
         ++ commaSep (map display moduleDuplicates)
 
   , check mainIsWrongExt $
@@ -345,7 +348,7 @@ checkTestSuite pkg test =
         (testModulesAutogen test)
       ) $
       PackageBuildImpossible $
-           "On test suite '" ++ testName test ++ "' an 'autogen-module' is not "
+           "On test suite '" ++ display (testName test) ++ "' an 'autogen-module' is not "
         ++ "on 'other-modules'"
   ]
   where
@@ -379,7 +382,7 @@ checkBenchmark _pkg bm =
 
   , check (not $ null moduleDuplicates) $
       PackageBuildImpossible $
-           "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "
+           "Duplicate modules in benchmark '" ++ display (benchmarkName bm) ++ "': "
         ++ commaSep (map display moduleDuplicates)
 
   , check mainIsWrongExt $
@@ -394,7 +397,7 @@ checkBenchmark _pkg bm =
         (benchmarkModulesAutogen bm)
       ) $
       PackageBuildImpossible $
-             "On benchmark '" ++ benchmarkName bm ++ "' an 'autogen-module' is "
+             "On benchmark '" ++ display (benchmarkName bm) ++ "' an 'autogen-module' is "
           ++ "not on 'other-modules'"
   ]
   where
@@ -404,6 +407,16 @@ checkBenchmark _pkg bm =
       BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
       _                   -> False
 
+checkSetup :: PackageDescription -> SetupBuildInfo -> [PackageCheck]
+checkSetup _pkg sbinfo =
+  catMaybes [
+
+    check (not $ null (setupDepends sbinfo) && null (setupTool sbinfo)) $
+      PackageBuildImpossible $
+           "Cannot specify both setup-depends and setup-tool"
+
+    ]
+
 -- ------------------------------------------------------------
 -- * Additional pure checks
 -- ------------------------------------------------------------
@@ -551,7 +564,8 @@ checkFields pkg =
       , isNoVersion vr ]
 
     internalLibraries =
-        map (maybe (packageName pkg) mkPackageName . libName)
+        -- TODO, avoid around trip
+        map (maybe (packageName pkg) (mkPackageName . unUnqualComponentName) . libName)
             (allLibraries pkg)
     buildDependsRangeOnInternalLibrary =
       [ dep

Cabal/Distribution/PackageDescription/Configuration.hs

@@ -450,8 +450,8 @@ constrainBy left extra =
 -- dependencies as we go.
 flattenTaggedTargets :: TargetSet PDTagged ->
         (Maybe Library
-        , [(String, Library)], [(String, Executable)], [(String, TestSuite)]
-        , [(String, Benchmark)])
+        , [(UnqualComponentName, Library)], [(UnqualComponentName, Executable)]
+        , [(UnqualComponentName, TestSuite)], [(UnqualComponentName, Benchmark)])
 flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], []) targets
   where
     untag (_, Lib _) (Just _, _, _, _, _) = userBug "Only one library expected"
@@ -463,7 +463,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], [])
             }
     untag (deps, SubLib n l) (mb_lib, libs, exes, tests, bms)
         | any ((== n) . fst) libs =
-          userBug $ "There exist several libs with the same name: '" ++ n ++ "'"
+          userBug $ "There exist several libs with the same name: '" ++ unUnqualComponentName n ++ "'"
         -- NB: libraries live in a different namespace than everything else
         -- TODO: no, (new-style) TESTS live in same namespace!!
         | otherwise = (mb_lib, (n, l'):libs, exes, tests, bms)
@@ -473,23 +473,23 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], [])
             }
     untag (deps, Exe n e) (mb_lib, libs, exes, tests, bms)
         | any ((== n) . fst) exes =
-          userBug $ "There exist several exes with the same name: '" ++ n ++ "'"
+          userBug $ "There exist several exes with the same name: '" ++ unUnqualComponentName n ++ "'"
         | any ((== n) . fst) tests =
-          userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"
+          userBug $ "There exists a test with the same name as an exe: '" ++ unUnqualComponentName n ++ "'"
         | any ((== n) . fst) bms =
-          userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"
+          userBug $ "There exists a benchmark with the same name as an exe: '" ++ unUnqualComponentName n ++ "'"
         | otherwise = (mb_lib, libs, (n, e'):exes, tests, bms)
       where
         e' = e {
                 buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
             }
     untag (deps, Test n t) (mb_lib, libs, exes, tests, bms)
         | any ((== n) . fst) tests =
-          userBug $ "There exist several tests with the same name: '" ++ n ++ "'"
+          userBug $ "There exist several tests with the same name: '" ++ unUnqualComponentName n ++ "'"
         | any ((== n) . fst) exes =
-          userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"
+          userBug $ "There exists an exe with the same name as the test: '" ++ unUnqualComponentName n ++ "'"
         | any ((== n) . fst) bms =
-          userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"
+          userBug $ "There exists a benchmark with the same name as the test: '" ++ unUnqualComponentName n ++ "'"
         | otherwise = (mb_lib, libs, exes, (n, t'):tests, bms)
       where
         t' = t {
@@ -498,11 +498,11 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], [])
             }
     untag (deps, Bench n b) (mb_lib, libs, exes, tests, bms)
         | any ((== n) . fst) bms =
-          userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"
+          userBug $ "There exist several benchmarks with the same name: '" ++ unUnqualComponentName n ++ "'"
         | any ((== n) . fst) exes =
-          userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"
+          userBug $ "There exists an exe with the same name as the benchmark: '" ++ unUnqualComponentName n ++ "'"
         | any ((== n) . fst) tests =
-          userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"
+          userBug $ "There exists a test with the same name as the benchmark: '" ++ unUnqualComponentName n ++ "'"
         | otherwise = (mb_lib, libs, exes, tests, (n, b'):bms)
       where
         b' = b {
@@ -520,10 +520,10 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], [])
 --      data PDTagged = PDComp Component
 --                    | PDNull
 data PDTagged = Lib Library
-              | SubLib String Library
-              | Exe String Executable
-              | Test String TestSuite
-              | Bench String Benchmark
+              | SubLib UnqualComponentName Library
+              | Exe UnqualComponentName Executable
+              | Test UnqualComponentName TestSuite
+              | Bench UnqualComponentName Benchmark
               | PDNull
               deriving Show