Merge pull request #149 from phadej/subextralibs

Allow sublibraries in extra-package option

cabal-docspec/cabal-docspec.cabal

@@ -67,6 +67,7 @@ library cabal-docspec-internal
     CabalDocspec.ExprVars
     CabalDocspec.GHCi
     CabalDocspec.Lexer
+    CabalDocspec.Library
     CabalDocspec.Located
     CabalDocspec.Man
     CabalDocspec.Man.Content

cabal-docspec/src/CabalDocspec/Library.hs

@@ -0,0 +1,30 @@
+module CabalDocspec.Library where
+
+import Peura
+
+import qualified Distribution.Compat.CharParsing as P
+import qualified Distribution.Parsec                    as C
+import qualified Distribution.Pretty                    as C
+import qualified Distribution.Types.PackageName         as C
+import qualified Distribution.Types.UnqualComponentName as C
+import qualified Text.PrettyPrint                       as PP
+
+data Library = Library !PackageName !LibraryName
+  deriving (Eq, Ord, Show)
+
+instance C.Parsec Library where
+    parsec = do
+        pn <- C.parsec
+        ln  <- fmap (fromMaybe LMainLibName) $ optional $ do
+            _ <- P.char ':'
+            qn <- C.parsec
+            return $
+                if C.unPackageName pn == C.unUnqualComponentName qn
+                then LMainLibName
+                else LSubLibName qn
+
+        return (Library pn ln)
+
+instance C.Pretty Library where
+    pretty (Library pn LMainLibName)     = C.pretty pn
+    pretty (Library pn (LSubLibName ln)) = C.pretty pn <> PP.colon <> C.pretty ln

cabal-docspec/src/CabalDocspec/Main.hs

@@ -15,6 +15,8 @@ import qualified Cabal.Config                                 as Cabal
 import qualified Cabal.Plan                                   as Plan
 import qualified Data.Map.Strict                              as Map
 import qualified Data.Set                                     as Set
+import qualified Data.Text                                    as T
+import qualified Distribution.Compat.NonEmptySet              as NES
 import qualified Distribution.Compiler                        as C
 import qualified Distribution.ModuleName                      as C
 import qualified Distribution.Package                         as C
@@ -26,8 +28,8 @@ import qualified Distribution.Types.Flag                      as C
 import qualified Distribution.Types.GenericPackageDescription as C
 import qualified Distribution.Types.InstalledPackageInfo      as IPI
 import qualified Distribution.Types.Library                   as C
-import qualified Distribution.Types.LibraryName               as C
 import qualified Distribution.Types.PackageDescription        as C
+import qualified Distribution.Types.UnqualComponentName       as C
 import qualified Distribution.Utils.Path                      as C
 import qualified Distribution.Version                         as C
 import qualified Language.Haskell.Extension                   as Ext
@@ -37,6 +39,7 @@ import qualified System.FilePath                              as FP
 import CabalDocspec.Doctest.Extract
 import CabalDocspec.Doctest.Parse
 import CabalDocspec.Lexer
+import CabalDocspec.Library
 import CabalDocspec.Located
 import CabalDocspec.Man
 import CabalDocspec.Opts
@@ -307,31 +310,31 @@ testComponentNo tracer0 tracerTop dynOptsCli ghcInfo cabalCfg dbG pkg = do
     -- Once dynOpts is read we can read adjust verbosity of our tracer
     let tracer = adjustTracer (optVerbosity dynOpts) tracer0
 
-    let findUnit :: PackageName -> Peu r (UnitId, PackageIdentifier)
-        findUnit pn = do
+    let findUnit :: Library -> Peu r (UnitId, PackageIdentifier, LibraryName)
+        findUnit lib'@(Library pn ln) = do
             let units =
-                    [ (unitId, IPI.sourcePackageId ipi)
+                    [ (unitId, IPI.sourcePackageId ipi, ln)
                     | (unitId, ipi) <- itoList dbG
                     , C.packageName (IPI.sourcePackageId ipi) == pn
-                    , IPI.sourceLibName ipi == C.LMainLibName
+                    , IPI.sourceLibName ipi == ln
                     ]
 
             case units of
                 [u] -> return u
-                []  -> die tracer $ "Cannot find unit for " ++ prettyShow pn
-                _   -> die tracer $ "Found multiple units for " ++ prettyShow pn ++ ": " ++
-                    unwords (map (prettyShow . fst) units)
+                []  -> die tracer $ "Cannot find unit for " ++ prettyShow lib'
+                _   -> die tracer $ "Found multiple units for " ++ prettyShow lib' ++ ": " ++
+                    unwords (map (prettyShow . fstOf3) units)
 
     -- we don't have install plan, so we look for packages in IPI
-    depends <- for (C.targetBuildDepends bi) $ \dep -> findUnit (C.depPkgName dep)
-    thisUnitId <- findUnit (C.packageName (pkgGpd pkg))
+    depends <- fmap concat $ for (C.targetBuildDepends bi) $ \dep -> traverse findUnit (toList (depLib dep))
+    thisUnitId <- findUnit (Library (C.packageName (pkgGpd pkg)) LMainLibName) -- TODO: libraryname
     extraUnitIds <- traverse findUnit $ Set.toList $ propPkgs dynOpts <> optExtraPkgs dynOpts
 
     let pkgIds :: [PackageIdentifier]
-        pkgIds = map snd depends
+        pkgIds = map sndOf3 depends
 
     let unitIds :: [UnitId]
-        unitIds = ordNub $ map fst $
+        unitIds = ordNub $ map fstOf3 $
             thisUnitId : depends ++ extraUnitIds
 
     -- find library module paths
@@ -371,31 +374,31 @@ testComponentNo tracer0 tracerTop dynOptsCli ghcInfo cabalCfg dbG pkg = do
 findExtraPackages
     :: TracerPeu r Tr
     -> Plan.PlanJson
-    -> [PackageName]
+    -> [Library]
     -> Peu r [UnitId]
-findExtraPackages tracer plan = traverse $ \pn -> do
+findExtraPackages tracer plan = traverse $ \lib@(Library pn ln) -> do
     let units =
           [ toCabal uid
           | (uid, unit) <- itoList (Plan.pjUnits plan)
           , let PackageIdentifier pn' _ = toCabal (Plan.uPId unit)
           , pn == pn'
-          , Plan.CompNameLib `Map.member` Plan.uComps unit
+          , libNameToCompName ln `Map.member` Plan.uComps unit
           ]
 
     case units of
         [u] -> return u
-        []  -> die tracer $ "Cannot find unit for " ++ prettyShow pn
-        _   -> die tracer $ "Found multiple units for " ++ prettyShow pn ++ ": " ++
+        []  -> die tracer $ "Cannot find unit for " ++ prettyShow lib
+        _   -> die tracer $ "Found multiple units for " ++ prettyShow lib ++ ": " ++
             unwords (map prettyShow units)
 
 -------------------------------------------------------------------------------
 -- Utilities
 -------------------------------------------------------------------------------
 
-propPkgs :: DynOpts -> Set PackageName
+propPkgs :: DynOpts -> Set Library
 propPkgs dynOpts = case optProperties dynOpts of
     SkipProperties  -> mempty
-    CheckProperties -> Set.singleton (mkPackageName "QuickCheck")
+    CheckProperties -> Set.singleton (Library (mkPackageName "QuickCheck") LMainLibName)
 
 manglePackageName :: C.PackageName -> String
 manglePackageName = map fixchar . prettyShow where
@@ -513,4 +516,9 @@ filterExpression e =
     strip :: String -> String
     strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
 
+depLib :: C.Dependency -> NonEmpty Library
+depLib (C.Dependency pn _vr lns) = Library pn <$> NES.toNonEmpty lns
 
+libNameToCompName :: LibraryName -> Plan.CompName
+libNameToCompName LMainLibName = Plan.CompNameLib
+libNameToCompName (LSubLibName n) = Plan.CompNameSubLib (T.pack (C.unUnqualComponentName  n))

cabal-docspec/src/CabalDocspec/Opts.hs

@@ -9,6 +9,7 @@ import qualified Distribution.Parsec             as C
 import qualified Distribution.Types.BuildInfo    as C
 import qualified Options.Applicative             as O
 
+import CabalDocspec.Library
 import CabalDocspec.Trace
 import CabalDocspec.Warning
 
@@ -21,7 +22,6 @@ data Opts = Opts
     , optTargets   :: [String]
     }
 
-
 -- | Options which can change per component.
 data DynOpts = DynOpts
     { optPhase          :: Phase
@@ -33,7 +33,7 @@ data DynOpts = DynOpts
     , optTimeoutMsg     :: String          -- ^ timeout response
     , optGhciRtsopts    :: [String]
     , optSetup          :: [String]
-    , optExtraPkgs      :: Set PackageName
+    , optExtraPkgs      :: Set Library
     , optModules        :: Set C.ModuleName
     , optCppIncludeDirs :: [FsPath]
     , optProperties     :: Properties
@@ -225,10 +225,12 @@ propertiesP = lastOpt <$> many (skip <|> simple) where
 extP :: O.Parser String
 extP = O.strOption (O.short 'X' <> O.metavar "EXT" <> O.help "Extensions")
 
-extraPkgP :: O.Parser PackageName
+extraPkgP :: O.Parser Library
 extraPkgP = O.option (O.eitherReader C.eitherParsec) $
     O.long "extra-package" <> O.metavar "PKG" <> O.help "Extra packages to require (should exist in a plan)"
 
+
+
 moduleNameP :: O.Parser C.ModuleName
 moduleNameP = O.option (O.eitherReader C.eitherParsec) $
     O.short 'm' <> O.long "module" <> O.metavar "MODULE" <> O.help "Which modules to check (all if empty)"

peura/src/Peura/Exports.hs

@@ -17,6 +17,7 @@ module Peura.Exports (
     -- * Types
     ExitCode (..),
     LazyByteString,
+    LibraryName (..),
     PackageName,
     PackageIdentifier (..),
     Version,
@@ -32,6 +33,8 @@ module Peura.Exports (
     bracket,
     -- ** Data.List
     sortBy, sortOn, splitOn,
+    -- ** Data.Tuple
+    fstOf3, sndOf3, trdOf3,
     -- * Cabal
     prettyShow,
     mkPackageName,
@@ -68,6 +71,7 @@ import Data.Binary                     (Binary)
 import Data.List                       (sortBy, sortOn)
 import Distribution.Pretty             (prettyShow)
 import Data.These (these)
+import Distribution.Types.LibraryName  (LibraryName (..))
 import Distribution.Types.PackageId    (PackageIdentifier (..))
 import Distribution.Types.PackageName  (PackageName, mkPackageName)
 import Distribution.Types.UnitId       (UnitId)
@@ -100,3 +104,12 @@ splitOn sep = go where
         | otherwise = (x : ys) :| yss
       where
         ~(ys :| yss) = go xs
+
+fstOf3 :: (a, b, c) -> a
+fstOf3 (a, _, _) = a
+
+sndOf3 :: (a, b, c) -> b
+sndOf3 (_, b, _) = b
+
+trdOf3 :: (a, b, c) -> c
+trdOf3 (_, _, c) = c