cabal-info (empty) → 0.1.0.0

raw patch · 8 files changed

+766/−0 lines, 8 filesdep +Cabaldep +basedep +cabal-infosetup-changed

Dependencies added: Cabal, base, cabal-info, directory, filepath, optparse-applicative

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• cabal-info.cabal +59/−0
• cabal-info/Args.hs +92/−0
• cabal-info/Describe.hs +107/−0
• cabal-info/Fields.hs +253/−0
• cabal-info/Main.hs +52/−0
• library/Cabal/Info.hs +181/−0

@@ -0,0 +1,20 @@+Copyright (c) 2016 Michael Walker++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,59 @@+-- Initial cabal-info.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                cabal-info+version:             0.1.0.0+synopsis:            Read information from cabal files+description:+  Have you ever needed to get information from a cabal file in a shell+  script? Now you can! cabal-info exposes a simple command-line+  interface to the cabal file format.+  .+  There is also a library interface, to solve tasks based on searching+  for a .cabal file and then doing something with it.+  .+  See the <https://github.com/barrucadu/cabal-info README> for more+  details.++homepage:            https://github.com/barrucadu/cabal-info+license:             MIT+license-file:        LICENSE+author:              Michael Walker+maintainer:          mike@barrucadu.co.uk+-- copyright:           +category:            Development+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/barrucadu/cabal-info.git++source-repository this+  type:     git+  location: https://github.com/barrucadu/cabal-info.git+  tag:      0.1.0.0++library+  exposed-modules:  Cabal.Info+  build-depends:    base >=4.8 && <4.9+                  , Cabal+                  , directory+                  , filepath+                  , optparse-applicative+  hs-source-dirs:   library+  default-language: Haskell2010++executable cabal-info+  main-is:          Main.hs+  other-modules:    Args+                  , Describe+                  , Fields+  build-depends:    base >=4.8 && <4.9+                  , cabal-info+                  , Cabal+                  , filepath+                  , optparse-applicative+  hs-source-dirs:   cabal-info+  default-language: Haskell2010

@@ -0,0 +1,92 @@+-- | Command-line argument handling.+module Args where++import Data.Char (toLower)+import Options.Applicative+import Distribution.PackageDescription (FlagAssignment, FlagName(..))+import Distribution.System (Arch(..), OS(..))+import System.FilePath (FilePath)++import Fields++data Args = Args+  { cabalFile :: Maybe FilePath+  , flags     :: FlagAssignment+  , theArch   :: Maybe Arch+  , theOS     :: Maybe OS+  , field     :: Maybe FieldName+  }+  deriving Show++-- | Parse the command-line arguments.+getArgs :: IO Args+getArgs = execParser opts where+  opts = info (helper <*> argsParser)+    (fullDesc <> progDesc "Print fields from a cabal file.")++-------------------------------------------------------------------------------+-- Parsers++argsParser :: Parser Args+argsParser = Args+  <$> optional (strOption+      $  long "cabal-file"+      <> metavar "FILE"+      <> help "The cabal file to use. If unspecified, the first one found in this directory is used instead.")++  <*> flagAssignmentParser++  <*> optional archParser++  <*> optional osParser++  <*> optional fieldNameParser++flagAssignmentParser :: Parser FlagAssignment+flagAssignmentParser = map go . words <$> strOption (long "flags" <> short 'f' <> metavar "FLAGS" <> help "Force values for the given flags in Cabal conditionals in the .cabal file. E.g. --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and the flag \"usebytestrings\" to false." <> value "") where++  go ('-':flag) = (FlagName flag, False)+  go flag = (FlagName flag, True)++osParser :: Parser OS+osParser = go . map toLower <$> strOption (long "os" <> short 'o' <> metavar "OS" <> help "The operating system to use when expanding conditionals. Allowed values are (case insensitive): linux, windows, osx, freebsd, openbsd, netbsd, dragonfly, solaris, aix, hpux, iric, halvm, ios, ghcjs.") where+  go "linux" = Linux+  go "windows" = Windows+  go "osx" = OSX+  go "freebsd" = FreeBSD+  go "netbsd" = NetBSD+  go "dragonfly" = DragonFly+  go "solaris" = Solaris+  go "aix" = AIX+  go "hpux" = HPUX+  go "irix" = IRIX+  go "halvm" = HaLVM+  go "ios" = IOS+  go "ghcjs" = Ghcjs+  go os = OtherOS os++archParser :: Parser Arch+archParser = go . map toLower <$> strOption (long "arch" <> short 'a' <> metavar "ARCH" <> help "The architecture to use when expanding conditionals. Allowed values are (case insensitive): i386, x86_64, ppc, ppc64, sparc, arm, mips, sh, ia64, s390, alpha, hppa, rs6000, m68k, vax, javascript.") where+  go "i386" = I386+  go "x86_64" = X86_64+  go "ppc" = PPC+  go "ppc64" = PPC64+  go "sparc" = Sparc+  go "arm" = Arm+  go "mips" = Mips+  go "sh" = SH+  go "ia64" = IA64+  go "s390" = S390+  go "alpha" = Alpha+  go "hppa" = Hppa+  go "rs6000" = Rs6000+  go "m68k" = M68k+  go "vax" = Vax+  go "javascript" = JavaScript+  go arch = OtherArch arch++fieldNameParser :: Parser FieldName+fieldNameParser = go <$> argument str (metavar "FIELD" <> help "This is in the format [section:]field, where the section can be the name of a source repository, executable, test suite, or benchmark. If no field is given, then the file is pretty-printed, with any flags applied.") where+  go fname = case break (==':') fname of+    (name, ':':field) -> FieldName (Just $ map toLower name) (map toLower field)+    (field, []) -> FieldName Nothing (map toLower field)

@@ -0,0 +1,107 @@+-- | Pretty-printing packages.+module Describe where++import Data.List (elemIndex, delete, intercalate, isInfixOf, isPrefixOf)+import Data.Maybe (fromJust, maybeToList)+import Distribution.PackageDescription (PackageDescription(..), Library, Executable, TestSuite, Benchmark, SourceRepo)++import Fields++-- | A description of a part of a package.+--+-- For source repos, executables, testsuites, and benchmarks, the name+-- is not included in the list of fields.+data Description =+    Package [(String, String)] [Description]+  | SourceRepo String [(String, String)]+  | Library [(String, String)]+  | Executable String [(String, String)]+  | TestSuite String [(String, String)]+  | Benchmark String [(String, String)]+  deriving Show++-- | Pretty-print a package description.+describe :: PackageDescription -> String+describe = prettyPrint . describePackage where+  prettyPrint (Package fields rest) = intercalate "\n" $ prettyPrintFields fields : map prettyPrint rest+  prettyPrint (SourceRepo name fields) = "source-repository " ++ name ++ "\n" ++ indent 2 (prettyPrintFields fields)+  prettyPrint (Library fields) = "library\n" ++ indent 2 (prettyPrintFields fields)+  prettyPrint (Executable name fields) = "executable " ++ name ++ "\n" ++ indent 2 (prettyPrintFields fields)+  prettyPrint (TestSuite  name fields) = "test-suite " ++ name ++ "\n" ++ indent 2 (prettyPrintFields fields)+  prettyPrint (Benchmark  name fields) = "benchmark "  ++ name ++ "\n" ++ indent 2 (prettyPrintFields fields)++  prettyPrintFields fs = foldl pp "" $ map (\(f,v) -> (align (maxlen + 2) (f ++ ":"), v)) fs where+    maxlen = maximum $ map (length . fst) fs++    -- Pretty-print a field and value.+    pp sofar (f, v) = sofar ++ f ++ ppv f v ++ "\n"++    -- Pretty-print a value. Has some special cases.+    ppv f v+      -- Special case for description: just want to indent further+      -- lines by 2 spaces, and replace blank lines with an indented+      -- '.'.+      | "description" `isPrefixOf` f = indentS 2 . unlines' . map (\l -> if null l then "." else l) . lines $ v++      -- Special case for non-description multi-line fields: want to+      -- indent non-first-lines to the ":" in the field name, and add+      -- commas.+      | "\n" `isInfixOf` v = indentS (length f - 2) $ mapLines (", " ++) v++      -- Normal case is just the value.+      | otherwise = v++    -- Apply padding at the end of the line to the desired length.+    align n s = s ++ replicate (n - length s) ' '++  -- Indent every line.+  indent n = unlines . map (replicate n ' '++) . lines++  -- Indent every line after the first.+  indentS n = mapLines (replicate n ' '++)++  -- Apply a function to all but the first line.+  mapLines f str = case lines str of+    (x:xs) -> unlines' $ x : map f xs+    [] -> ""++-- | Produce all defined fields in a package.+describePackage :: PackageDescription -> Description+describePackage pkg = Package fields sections where+  fields   = getFields packageDescriptionFields getPackageDescriptionField pkg+  sections = repos ++ maybeToList lib ++ exes ++ tests ++ benchs+  repos  = describeSourceRepo <$> sourceRepos pkg+  lib    = describeLibrary    <$> library pkg+  exes   = describeExecutable <$> executables pkg+  tests  = describeTestSuite  <$> testSuites pkg+  benchs = describeBenchmark  <$> benchmarks pkg++-- | Produce all defined fields in a source repository.+describeSourceRepo :: SourceRepo -> Description+describeSourceRepo = section SourceRepo sourceRepoFields getSourceRepoField++-- | Produce all defined fields in a library.+describeLibrary :: Library -> Description+describeLibrary = Library . getFields (libraryFields ++ buildInfoFields) getLibraryField++-- | Produce all defined fields in an executable.+describeExecutable :: Executable -> Description+describeExecutable = section Executable (executableFields ++ buildInfoFields) getExecutableField++-- | Produce all defined fields in a test suite.+describeTestSuite :: TestSuite -> Description+describeTestSuite = section TestSuite (testSuiteFields ++ buildInfoFields) getTestSuiteField++-- | Produce all defined fields in a benchmark.+describeBenchmark :: Benchmark -> Description+describeBenchmark = section Benchmark (benchmarkFields ++ buildInfoFields) getBenchmarkField++-- | Describe a named section.+section :: (String -> [(String, String)] -> Description) -> [String] -> (String -> a -> String) -> a -> Description+section constr fieldNames get a = constr name fields where+  name   = get "name" a+  fields = getFields (delete "name" fieldNames) get a++-- | Get all non-empty fields.+getFields :: [String] -> (String -> a -> String) -> a -> [(String, String)]+getFields fields get a = [(f, v) | f <- fields, let v = get f a, not (null v)]

@@ -0,0 +1,253 @@+-- | Accessing fields from packages.+module Fields where++import Control.Applicative ((<|>))+import Data.Char (toLower)+import Data.Maybe (fromMaybe, listToMaybe, maybeToList)++import Distribution.Compiler (CompilerFlavor(GHC))+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Text (display)+import Distribution.Version++-- | A field name is a string, optionally qualified with a specific+-- executable/test-suite/benchmark.+data FieldName = FieldName (Maybe String) String+  deriving Show++-- | Get a field from a package description, returning a list of+-- values. The empty list indicates that either the field was present,+-- but contained nothing, or the field was not present.+--+-- There are a number of parts of the package description not yet+-- exposed. Doing this nicely may require more than a single-word+-- field name eg, to specify which executable or test suite is being+-- referred to.+--+-- The following don't show up in the Cabal User Guide as of+-- 2016-02-01, and so are intentionally omitted for now:+--+-- - library requiredSignatures+-- - library exposedSignatures+getField :: FieldName -> (GenericPackageDescription, PackageDescription) -> String+-- Special case pseudo-fields+---- First:+getField (FieldName Nothing "flag")       = maybe "" (getFlagField "name") . listToMaybe . genPackageFlags . fst+getField (FieldName Nothing "executable") = maybe "" (getExecutableField "name") . listToMaybe . executables . snd+getField (FieldName Nothing "testsuite")  = maybe "" (getTestSuiteField "name") . listToMaybe . testSuites . snd+getField (FieldName Nothing "benchmark")  = maybe "" (getBenchmarkField "name") . listToMaybe . benchmarks . snd+getField (FieldName Nothing "repository") = maybe "" (getSourceRepoField "name") . listToMaybe . sourceRepos . snd+---- Collection:+getField (FieldName Nothing "flags")        = unlines' . map (getFlagField "name")  . genPackageFlags . fst+getField (FieldName Nothing "executables")  = unlines' . map (getExecutableField "name") . executables . snd+getField (FieldName Nothing "testsuites")   = unlines' . map (getTestSuiteField  "name") . testSuites . snd+getField (FieldName Nothing "benchmarks")   = unlines' . map (getBenchmarkField  "name") . benchmarks . snd+getField (FieldName Nothing "repositories") = unlines' . map (getSourceRepoField "name") . sourceRepos . snd+---- Other+getField (FieldName Nothing "main-is") = maybe "" (getExecutableField "main-is") . listToMaybe . executables . snd+getField (FieldName Nothing "upstream") = maybe "" (getSourceRepoField "location") . listToMaybe . filter ((RepoHead==) . repoKind) . sourceRepos . snd+-- Qualified Fields+getField (FieldName (Just name) field) = \(gpkg, pkg) ->+  let flag  = listToMaybe $ filter (\f -> map toLower (flagName' f) == name) (genPackageFlags gpkg)+      exe   = listToMaybe $ filter (\e -> map toLower (exeName  e) == name) (executables pkg)+      test  = listToMaybe $ filter (\t -> map toLower (testName t) == name) (testSuites  pkg)+      bench = listToMaybe $ filter (\b -> map toLower (benchmarkName b) == name) (benchmarks pkg)+      repo  = listToMaybe $ filter (\r -> display (repoKind r) == name || (map toLower <$> repoTag r) == Just name) (sourceRepos pkg)+  in fromMaybe "" $+       (getFlagField       field <$> flag)  <|>+       (getExecutableField field <$> exe)   <|>+       (getTestSuiteField  field <$> test)  <|>+       (getBenchmarkField  field <$> bench) <|>+       (getSourceRepoField field <$> repo)+-- Catch-all+getField (FieldName Nothing field)+  | field `elem` packageDescriptionFields = getPackageDescriptionField field . snd++  | field `elem` libraryFields = maybe "" (getLibraryField field) . library . snd++  | field `elem` buildInfoFields = \(_, pkg) ->+    let lib = libBuildInfo <$> library pkg+        exe = buildInfo <$> listToMaybe (executables pkg)+    in maybe "" (getBuildInfoField field) (lib <|> exe)++  | otherwise = const ""++-- * 'PackageDescription'++-- | Get a field from a 'PackageDescription'.+getPackageDescriptionField :: String -> PackageDescription -> String+getPackageDescriptionField "extra-source-files" = unlines' . extraSrcFiles+getPackageDescriptionField "extra-doc-files" = unlines' . extraDocFiles+getPackageDescriptionField "extra-tmp-files" = unlines' . extraTmpFiles+getPackageDescriptionField "license-files" = unlines' . licenseFiles+getPackageDescriptionField "build-depends" = unlines' . map display . buildDepends+getPackageDescriptionField "license-file" = unlines' . licenseFiles+getPackageDescriptionField "package-url" = pkgUrl+getPackageDescriptionField "bug-reports" = bugReports+getPackageDescriptionField "description" = description+getPackageDescriptionField "tested-with" = unlines' . map (\(c, v) -> display c ++ " " ++ display v) . testedWith+getPackageDescriptionField "data-files" = unlines' . dataFiles+getPackageDescriptionField "maintainer" = maintainer+getPackageDescriptionField "build-type" = unlines' . map display . maybeToList . buildType+getPackageDescriptionField "copyright" = copyright+getPackageDescriptionField "stability" = stability+getPackageDescriptionField "data-dir" = dataDir+getPackageDescriptionField "homepage" = homepage+getPackageDescriptionField "synopsis" = synopsis+getPackageDescriptionField "category" = category+getPackageDescriptionField "version" = display . pkgVersion . package+getPackageDescriptionField "license" = display . license+getPackageDescriptionField "author" = author+getPackageDescriptionField "name" = unPackageName . pkgName . package+getPackageDescriptionField _ = const ""++-- | All the fields in a 'PackageDescription'.+packageDescriptionFields :: [String]+packageDescriptionFields = ["name", "version", "build-type", "build-depends", "license", "license-files", "copyright", "maintainer", "author", "stability", "homepage", "package-url", "bug-reports", "synopsis", "description", "category", "tested-with", "data-files", "data-dir", "extra-source-files", "extra-doc-files", "extra-tmp-files"]++-- * 'Flag'++-- | Get a field from a 'Flag'.+getFlagField :: String -> Flag -> String+getFlagField "description" = flagDescription+getFlagField "default" = display . flagDefault+getFlagField "manual" = display . flagManual+getFlagField "name" = flagName'+getFlagField _ = const ""++-- | All the fields in a 'Flag'.+flagFields :: [String]+flagFields = ["name", "description", "default", "manual"]++-- * 'SourceRepo'++-- | Get a field from a 'SourceRepo'.+getSourceRepoField :: String -> SourceRepo -> String+getSourceRepoField "name"     = display . repoKind+getSourceRepoField "type"     = maybe "" display . repoType+getSourceRepoField "location" = fromMaybe "" . repoLocation+getSourceRepoField "module"   = fromMaybe "" . repoModule+getSourceRepoField "branch"   = fromMaybe "" . repoBranch+getSourceRepoField "tag"      = fromMaybe "" . repoTag+getSourceRepoField "subdir"   = fromMaybe "" . repoSubdir+getSourceRepoField _ = const ""++-- | All the fields in a 'SourceRepo'.+sourceRepoFields :: [String]+sourceRepoFields = ["name", "type", "location", "module", "branch", "tag", "subdir"]++-- * 'Library'++-- | Get a field from a 'Library'.+getLibraryField :: String -> Library -> String+getLibraryField "exposed" = display . libExposed+getLibraryField "exposed-modules" = unlines' . map display . exposedModules+getLibraryField "reexported-modules" = unlines' . map display . reexportedModules+getLibraryField field = getBuildInfoField field . libBuildInfo++-- | All the fields from a 'Library'.+libraryFields :: [String]+libraryFields = ["exposed", "exposed-modules", "reexported-modules"]++-- * @Executable'++-- | Get a field from an 'Executable'.+getExecutableField :: String -> Executable -> String+getExecutableField "name"    = exeName+getExecutableField "main-is" = modulePath+getExecutableField field = getBuildInfoField field . buildInfo++-- | All the fields in an 'Executable'.+executableFields :: [String]+executableFields = ["name", "main-is"]++-- * 'TestSuite'++-- | Get a field from a 'TestSuite'.+getTestSuiteField :: String -> TestSuite -> String+getTestSuiteField "name" = testName+getTestSuiteField "type" = get . testInterface where+  get (TestSuiteExeV10 _ _) = "exitcode-stdio-1.0"+  get (TestSuiteLibV09 _ _) = "detailed-0.9"+  get (TestSuiteUnsupported (TestTypeExe v)) = "exitcode-stdio-" ++ display v+  get (TestSuiteUnsupported (TestTypeLib v)) = "detailed-" ++ display v+  get (TestSuiteUnsupported (TestTypeUnknown s v)) = s ++ "-" ++ display v+getTestSuiteField "main-is" = get . testInterface where+  get (TestSuiteExeV10 _ f) = f+  get _ = ""+getTestSuiteField "test-module" = get . testInterface where+  get (TestSuiteLibV09 _ m) = display m+  get _ = ""+getTestSuiteField "enabled" = display . testEnabled+getTestSuiteField field = getBuildInfoField field . testBuildInfo++-- | All the fields in a 'TestSuite'.+testSuiteFields :: [String]+testSuiteFields = ["name", "type", "main-is", "test-module", "enabled"]++-- * 'Benchmark'++-- | Get a field from a 'Benchmark'.+getBenchmarkField :: String -> Benchmark -> String+getBenchmarkField "name" = benchmarkName+getBenchmarkField "type" = get . benchmarkInterface where+  get (BenchmarkExeV10 _ _) = "exitcode-stdio-1.0"+  get (BenchmarkUnsupported (BenchmarkTypeExe v)) = "exitcode-stdio-" ++ display v+  get (BenchmarkUnsupported (BenchmarkTypeUnknown s v)) = s ++ "-" ++ display v+getBenchmarkField "main-is" = get . benchmarkInterface where+  get (BenchmarkExeV10 _ f) = f+  get _ = ""+getBenchmarkField "enabled" = display . benchmarkEnabled+getBenchmarkField field = getBuildInfoField field . benchmarkBuildInfo++-- | All the fields in a 'Benchmark'.+benchmarkFields :: [String]+benchmarkFields = ["name", "type", "main-is", "enabled"]++-- * 'BuildInfo'++-- | Get a field from some 'BuildInfo'.+getBuildInfoField :: String -> BuildInfo -> String+getBuildInfoField field = unlines' . get field where+  get "extra-libraries"      = extraLibs+  get "extra-ghci-libraries" = extraGHCiLibs+  get "extra-lib-dirs"       = extraLibDirs+  get "extensions"         = map display . oldExtensions+  get "default-extensions" = map display . defaultExtensions+  get "other-extensions"   = map display . otherExtensions+  get "ghc-options"        = concatMap snd . filter ((==GHC) . fst) . options+  get "ghc-prof-options"   = concatMap snd . filter ((==GHC) . fst) . profOptions+  get "ghc-shared-options" = concatMap snd . filter ((==GHC) . fst) . sharedOptions+  get "pkgconfig-depends"  = map display . pkgconfigDepends+  get "install-includes"   = installIncludes+  get "hs-source-dirs" = hsSourceDirs+  get "build-depends"  = map display . targetBuildDepends+  get "other-modules"  = map display . otherModules+  get "include-dirs"   = includeDirs+  get "build-tools" = map display . buildTools+  get "cc-options"  = ccOptions+  get "cpp-options" = cppOptions+  get "ld-options"  = ldOptions+  get "c-sources"  = cSources+  get "js-sources" = jsSources+  get "frameworks" = frameworks+  get "buildable"  = (:[]) . display . buildable+  get "includes" = includes+  get _ = const []++-- | All the fields in a 'BuildInfo'+buildInfoFields :: [String]+buildInfoFields = ["build-depends", "other-modules", "hs-source-dirs", "extensions", "default-extensions", "other-extensions", "build-tools", "buildable", "ghc-options", "ghc-prof-options", "ghc-shared-options", "includes", "install-includes", "include-dirs", "c-sources", "js-sources", "extra-libraries", "extra-ghci-libraries", "extra-lib-dirs", "cc-options", "ld-options", "pkgconfig-depends", "frameworks"]++-- * Utilities++-- | Like 'unlines', but don't include the trailing newline.+unlines' :: [String] -> String+unlines' = init' . unlines where+  init' [] = []+  init' xs = init xs++-- | Get the name of a flag.+flagName' :: Flag -> String+flagName' = (\(FlagName name) -> name) . flagName

@@ -0,0 +1,52 @@+{-# LANGUAGE TupleSections #-}++module Main where++import Control.Exception (SomeException, catch)+import Control.Monad (unless)++import Data.Maybe (fromMaybe)++import Distribution.PackageDescription (GenericPackageDescription, PackageDescription)+import Distribution.System (buildArch, buildOS)++import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++import Args+import Describe+import Fields++import Cabal.Info++main :: IO ()+main = do+  args  <- getArgs+  gpkgd <- getGenericPackageDescription args+  let pkgd = do+        (g, fp) <- gpkgd+        p <- applyConfiguration args fp g+        pure (g, p)++  case (pkgd, field args) of+    (Right pkg, Just fld) ->+      let fldval = getField fld pkg+      in unless (null fldval) $ putStrLn fldval+    (Right (_, pkg), Nothing) -> putStrLn $ describe pkg+    (Left err, _) -> dieWith $ prettyPrintErr err++-- | Attempt to fetch and parse the package description.+getGenericPackageDescription :: Args -> IO (Either CabalError (GenericPackageDescription, FilePath))+getGenericPackageDescription args = case cabalFile args of+  Just fp -> fmap (,fp) <$> openGenericPackageDescription fp+  Nothing -> findGenericPackageDescription++-- | Evaluate the conditionals in the package description.+applyConfiguration :: Args -> FilePath -> GenericPackageDescription -> Either CabalError PackageDescription+applyConfiguration args = evaluateConditions (flags args) os arch . Just where+  os   = Just . fromMaybe buildOS   $ theOS   args+  arch = Just . fromMaybe buildArch $ theArch args++-- | Print a message to stderr and exit with failure.+dieWith :: String -> IO ()+dieWith err = hPutStrLn stderr err >> exitFailure

@@ -0,0 +1,181 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++-- | Get information from cabal files.+--+-- Motivating example, test discovery based on a library's exposed+-- modules:+--+-- > import Test.Doctest (doctest)+-- > import Cabal.Info (getLibraryModules)+-- >+-- > main :: IO ()+-- > main = getLibraryModules >>= doctest . either (const []) id+--+-- Simple!+module Cabal.Info+  ( -- * Reading .cabal files+    findCabalFile+  , findPackageDescription+  , findPackageDescription'+  , findGenericPackageDescription+  , openPackageDescription+  , openPackageDescription'+  , openGenericPackageDescription++  -- * Errors+  , CabalError(..)+  , prettyPrintErr++  -- * Conditionals+  , evaluateConditions++  -- * Libraries+  , getLibrary+  , getLibraryModules++  -- * Modules+  , moduleFilePath+  ) where++import Control.Exception (SomeException, catch)+import Control.Monad (unless)++import Data.Maybe (fromMaybe, listToMaybe)++import Distribution.Compiler+import Distribution.InstalledPackageInfo (PError(..))+import Distribution.ModuleName+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.Parse+import Distribution.System++import System.FilePath+import System.Directory (getCurrentDirectory, getDirectoryContents)++-- * Errors++-- | Automatically finding and dealing with a .cabal file failed for+-- some reason.+data CabalError =+    NoCabalFile+  -- ^ A .cabal file could not be found in the current directory or+  -- any of its parents.+  | ParseError FilePath PError+  -- ^ A file with the extension .cabal was found, but could not be+  -- parsed.+  | NoFlagAssignment (Maybe FilePath)+  -- ^ A consistent flag assignment could not be found.+  | NoLibrary FilePath+  -- ^ There is no library section.+  deriving (Eq, Show)++-- | Pretty-print an error.+prettyPrintErr :: CabalError -> String+prettyPrintErr NoCabalFile = "Could not find .cabal file."+prettyPrintErr (ParseError fp err) = "Parse error in " ++ fp ++ ": " ++ show' err ++ "." where+  show' (AmbiguousParse _ l) = "ambiguous parse on line " ++ show l+  show' (NoParse _ l) = "no parse on line " ++ show l+  show' (TabsError l) = "tabbing error on line " ++ show l+  show' (FromString _ (Just l)) = "no parse on line " ++ show l+  show' (FromString _ Nothing) = "no parse"+prettyPrintErr (NoFlagAssignment (Just fp)) = "Could not find flag assignment for " ++ fp ++ "."+prettyPrintErr (NoFlagAssignment Nothing) = "Could not find flag assignment."+prettyPrintErr (NoLibrary fp) = "Missing library section in " ++ fp ++ "."++-- * Reading .cabal files++-- | Find the .cabal file.+--+-- If there are .cabal files in the current directory, the first is+-- read. Otherwise, the parent directory is checked. This continues+-- until the filesystem root is reached without finding a .cabal file.+findCabalFile :: IO (Maybe FilePath)+findCabalFile = do+  cwd <- getCurrentDirectory+  listToMaybe <$> findFile ((==".cabal") . takeExtension) (dirs cwd)++  where+    dirs dir = takeWhile (\d -> takeDirectory d /= d) (iterate takeDirectory dir) ++ [takeDrive dir]++    findFile p (d:ds) = (++) <$> (filter p . map (d</>) <$> getDirectoryContents d) <*> findFile p ds+    findFile _ [] = pure []++-- | Find and read the .cabal file, applying the default flags.+findPackageDescription :: IO (Either CabalError (PackageDescription, FilePath))+findPackageDescription = findPackageDescription' [] Nothing Nothing++-- | Find and read the .cabal file, applying the given flags,+-- operating system, and architecture.+findPackageDescription' :: FlagAssignment -> Maybe OS -> Maybe Arch -> IO (Either CabalError (PackageDescription, FilePath))+findPackageDescription' flags os arch = findCabalFile >>=+   maybe (pure $ Left NoCabalFile) (\fp -> fmap (,fp) <$> openPackageDescription' flags os arch fp)++-- | Find and read the .cabal file.+findGenericPackageDescription :: IO (Either CabalError (GenericPackageDescription, FilePath))+findGenericPackageDescription = findCabalFile >>=+  maybe (pure $ Left NoCabalFile) (\fp -> fmap (,fp) <$> openGenericPackageDescription fp)++-- | Open and parse a .cabal file, applying the default flags.+openPackageDescription :: FilePath -> IO (Either CabalError PackageDescription)+openPackageDescription = openPackageDescription' [] Nothing Nothing++-- | Open and parse a .cabal file, and apply the given flags,+-- operating system, and architecture.+openPackageDescription' :: FlagAssignment -> Maybe OS -> Maybe Arch -> FilePath -> IO (Either CabalError PackageDescription)+openPackageDescription' flags os arch fp = openGenericPackageDescription fp <$$> \case+  Right gpkg -> evaluateConditions flags os arch (Just fp) gpkg+  Left err -> Left err++-- | Open and parse a .cabal file.+openGenericPackageDescription :: FilePath -> IO (Either CabalError GenericPackageDescription)+openGenericPackageDescription fp = do+  cabalFile <- readFile fp+  pure $ case parsePackageDescription cabalFile of+    ParseOk _ pkg -> Right pkg+    ParseFailed err -> Left $ ParseError fp err++-- * Conditionals++-- | Apply the given flags, operating system, and architecture.+evaluateConditions :: FlagAssignment -> Maybe OS -> Maybe Arch -> Maybe FilePath -> GenericPackageDescription -> Either CabalError PackageDescription+evaluateConditions flags os arch fp gpkg = either (const . Left $ NoFlagAssignment fp) (Right . fst) $+  finalizePackageDescription flags (const True) platform compiler [] gpkg++  where+    platform = Platform (fromMaybe buildArch arch) (fromMaybe buildOS os)+    compiler = unknownCompilerInfo buildCompilerId NoAbiTag++-- * Libraries++-- | Search for the .cabal file and return its library section.+getLibrary :: IO (Either CabalError Library)+getLibrary = findPackageDescription <$$> \case+  Right (pkgd, fp) -> maybe (Left $ NoLibrary fp) Right $ library pkgd+  Left err -> Left err++-- | Search for the .cabal file and return its exposed library+-- modules, as absolute paths.+getLibraryModules :: IO (Either CabalError [FilePath])+getLibraryModules = findPackageDescription <$$> \case+  Right (pkgd, fp) -> maybe (Left $ NoLibrary fp) (\l -> Right . map (moddir fp l) $ exposedModules l) $ library pkgd+  Left err -> Left err++  where+    moddir fp l m = dropFileName fp </> moduleFilePath (libBuildInfo l) m++-- * Modules++-- | Turn a module name + some build info to a file path taking the+-- hs-source-dirs field into account.+--+-- This path will be relative to the .cabal file.+moduleFilePath :: BuildInfo -> ModuleName -> FilePath+moduleFilePath b m = joinPath ((fromMaybe "" . listToMaybe $ hsSourceDirs b) : components m) <.> "hs"++-- * Utils++-- | Flipped fmap+(<$$>) :: Functor f => f a -> (a -> b) -> f b+(<$$>) = flip fmap