diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-info.cabal b/cabal-info.cabal new file mode 100644 --- /dev/null +++ b/cabal-info.cabal @@ -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 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 diff --git a/cabal-info/Args.hs b/cabal-info/Args.hs new file mode 100644 --- /dev/null +++ b/cabal-info/Args.hs @@ -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) diff --git a/cabal-info/Describe.hs b/cabal-info/Describe.hs new file mode 100644 --- /dev/null +++ b/cabal-info/Describe.hs @@ -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)] diff --git a/cabal-info/Fields.hs b/cabal-info/Fields.hs new file mode 100644 --- /dev/null +++ b/cabal-info/Fields.hs @@ -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 diff --git a/cabal-info/Main.hs b/cabal-info/Main.hs new file mode 100644 --- /dev/null +++ b/cabal-info/Main.hs @@ -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 diff --git a/library/Cabal/Info.hs b/library/Cabal/Info.hs new file mode 100644 --- /dev/null +++ b/library/Cabal/Info.hs @@ -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