diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for stackage-query +## 0.1.3 -- 2018-11-15 +- bundle Stackage.Types from old stackage-types package +- updates to build with Cabal-2 etc + ## 0.1.2 -- 2017-09-11 * drop update command * always update to latest Stackage data from git diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} import Control.Monad import Data.Char (isDigit) import Data.List import qualified Data.Map.Strict (assocs, keys, lookup) import Data.Maybe +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,11,1)) +#else import Data.Monoid +#endif import qualified Data.Set as Set import qualified Data.Text as T import Data.Version @@ -19,7 +23,7 @@ import Stackage.Types hiding (unPackageName) import Data.Foldable (traverse_) import Data.Yaml hiding (Parser) -import Distribution.Package (PackageName(..), unPackageName) +import Distribution.Package (PackageName, unPackageName) import Distribution.Text (disp) import Paths_stackage_query (version) @@ -98,7 +102,7 @@ command "package" (info (Package <$> parseSnap <*> parsePkg "PKG") (progDesc "Show version of PKG in SNAP")) <> - command "users" (info (Users <$> parseSnap <*> (parsePkg "PKG")) + command "users" (info (Users <$> parseSnap <*> parsePkg "PKG") (progDesc "Revdeps for PKG in SNAP")) <> command "github" (info (Github <$> parseSnap <*> parsePkg "PKG") @@ -311,7 +315,7 @@ evalPackageBuildPlan :: Snapshot -> Pkg -> (PackagePlan -> String) -> IO () evalPackageBuildPlan snap pkg expr = do bp <- getBuildPlan snap - let mpkgplan = Data.Map.Strict.lookup (PackageName pkg) $ bpPackages bp + let mpkgplan = Data.Map.Strict.lookup (mkPackageName pkg) $ bpPackages bp putStrLn $ maybe (error "Package not found") expr mpkgplan buildplanPackage :: Snapshot -> Pkg -> IO () diff --git a/Stackage/Types.hs b/Stackage/Types.hs new file mode 100644 --- /dev/null +++ b/Stackage/Types.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +-- | Shared types for various stackage packages. +module Stackage.Types + ( -- * Types + SnapshotType (..) + , DocMap + , PackageDocs (..) + , BuildPlan (..) + , PackagePlan (..) + , PackageConstraints (..) + , ParseFailedException (..) + , TestState (..) + , SystemInfo (..) + , Maintainer (..) + , ExeName (..) + , SimpleDesc (..) + , DepInfo (..) + , Component (..) + -- * Helper functions + , display + , simpleParse + , unPackageName + , mkPackageName + , unFlagName + , mkFlagName + , intersectVersionRanges + ) where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Arrow ((&&&)) +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow, throwM) +import Data.Aeson (FromJSON (..), ToJSON (..), + object, withObject, withText, + (.!=), (.:), (.:?), (.=)) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup, (<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString, fromString) +import Data.Text (Text, pack, unpack) +import Data.Time (Day) +import qualified Data.Traversable as T +import Data.Typeable (TypeRep, Typeable, typeOf) +import Data.Vector (Vector) +import Data.Version +#if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,0) +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagName, mkFlagName, unFlagName) +import Distribution.Types.PackageName (mkPackageName, unPackageName) +#else +import Distribution.Package (PackageName (PackageName)) +import Distribution.PackageDescription (FlagName (..)) +#endif +import Distribution.System (Arch, OS) +import qualified Distribution.Text as DT +import Distribution.Version (VersionRange) +import qualified Distribution.Version as C +import Safe (readMay) + +data SnapshotType = STNightly + | STNightly2 !Day + | STLTS !Int !Int -- ^ major, minor + deriving (Show, Read, Eq, Ord) + +instance ToJSON SnapshotType where + toJSON STNightly = object + [ "type" .= asText "nightly" + ] + toJSON (STNightly2 day) = object + [ "type" .= asText "nightly" + , "date" .= show day + ] + toJSON (STLTS major minor) = object + [ "type" .= asText "lts" + , "major" .= major + , "minor" .= minor + ] +instance FromJSON SnapshotType where + parseJSON = withObject "SnapshotType" $ \o -> do + t <- o .: "type" + case asText t of + "nightly" -> (STNightly2 <$> (o .: "date" >>= readFail)) <|> return STNightly + "lts" -> STLTS + <$> o .: "major" + <*> o .: "minor" + _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t + where + readFail t = + case readMay t of + Nothing -> fail "read failed" + Just x -> return x + +-- | Package name is key +type DocMap = Map Text PackageDocs + +asText :: Text -> Text +asText = id + +data PackageDocs = PackageDocs + { pdVersion :: Text + , pdModules :: Map Text [Text] + -- ^ module name, path + } +instance ToJSON PackageDocs where + toJSON PackageDocs {..} = object + [ "version" .= pdVersion + , "modules" .= pdModules + ] +instance FromJSON PackageDocs where + parseJSON = withObject "PackageDocs" $ \o -> PackageDocs + <$> o .: "version" + <*> o .: "modules" + +data BuildPlan = BuildPlan + { bpSystemInfo :: SystemInfo + , bpTools :: Vector (PackageName, Version) + , bpPackages :: Map PackageName PackagePlan + , bpGithubUsers :: Map Text (Set Text) + , bpBuildToolOverrides :: Map Text (Set Text) + } + deriving (Show, Eq) + +instance ToJSON BuildPlan where + toJSON BuildPlan {..} = object + [ "system-info" .= bpSystemInfo + , "tools" .= fmap goTool bpTools + , "packages" .= Map.mapKeysWith const unPackageName bpPackages + , "github-users" .= bpGithubUsers + , "build-tool-overrides" .= bpBuildToolOverrides + ] + where + goTool (k, v) = object + [ "name" .= display k + , "version" .= display v + ] +instance FromJSON BuildPlan where + parseJSON = withObject "BuildPlan" $ \o -> do + bpSystemInfo <- o .: "system-info" + bpTools <- (o .: "tools") >>= T.mapM goTool + bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + bpGithubUsers <- o .:? "github-users" .!= mempty + bpBuildToolOverrides <- o .:? "build-tool-overrides" .!= mempty + return BuildPlan {..} + where + goTool = withObject "Tool" $ \o -> (,) + <$> ((o .: "name") >>= + either (fail . show) return . simpleParse . asText) + <*> ((o .: "version") >>= + either (fail . show) return . simpleParse . asText) + +data PackagePlan = PackagePlan + { ppVersion :: Version + , ppGithubPings :: Set Text + , ppUsers :: Set PackageName + , ppConstraints :: PackageConstraints + , ppDesc :: SimpleDesc + } + deriving (Show, Eq) + +instance ToJSON PackagePlan where + toJSON PackagePlan {..} = object + [ "version" .= asText (display ppVersion) + , "github-pings" .= ppGithubPings + , "users" .= Set.map unPackageName ppUsers + , "constraints" .= ppConstraints + , "description" .= ppDesc + ] +instance FromJSON PackagePlan where + parseJSON = withObject "PackageBuild" $ \o -> do + ppVersion <- o .: "version" + >>= either (fail . show) return + . simpleParse . asText + ppGithubPings <- o .:? "github-pings" .!= mempty + ppUsers <- Set.map mkPackageName <$> (o .:? "users" .!= mempty) + ppConstraints <- o .: "constraints" + ppDesc <- o .: "description" + return PackagePlan {..} + +display :: DT.Text a => a -> Text +display = fromString . DT.display + +simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a +simpleParse orig = withTypeRep $ \rep -> + case DT.simpleParse str of + Nothing -> throwM (ParseFailedException rep (pack str)) + Just v -> return v + where + str = unpack orig + + withTypeRep :: Typeable a => (TypeRep -> m a) -> m a + withTypeRep f = + res + where + res = f (typeOf (unwrap res)) + + unwrap :: m a -> a + unwrap _ = error "unwrap" + +data ParseFailedException = ParseFailedException TypeRep Text + deriving (Show, Typeable) +instance Exception ParseFailedException + +#if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,0) +#else +unPackageName :: PackageName -> String +unPackageName (PackageName str) = str + +mkPackageName :: String -> PackageName +mkPackageName = PackageName +#endif + +data PackageConstraints = PackageConstraints + { pcVersionRange :: VersionRange + , pcMaintainer :: Maybe Maintainer + , pcTests :: TestState + , pcHaddocks :: TestState + , pcBuildBenchmarks :: Bool + , pcFlagOverrides :: Map FlagName Bool + , pcEnableLibProfile :: Bool + , pcSkipBuild :: Bool + -- ^ Don't even bother building this library, useful when dealing with + -- OS-specific packages. See: + -- https://github.com/fpco/stackage-curator/issues/3 + } + deriving (Show, Eq) +instance ToJSON PackageConstraints where + toJSON PackageConstraints {..} = object $ addMaintainer + [ "version-range" .= display pcVersionRange + , "tests" .= pcTests + , "haddocks" .= pcHaddocks + , "build-benchmarks" .= pcBuildBenchmarks + , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides + , "library-profiling" .= pcEnableLibProfile + , "skip-build" .= pcSkipBuild + ] + where + addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer +instance FromJSON PackageConstraints where + parseJSON = withObject "PackageConstraints" $ \o -> do + pcVersionRange <- (o .: "version-range") + >>= either (fail . show) return . simpleParse + pcTests <- o .: "tests" + pcHaddocks <- o .: "haddocks" + pcBuildBenchmarks <- o .: "build-benchmarks" + pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags" + pcMaintainer <- o .:? "maintainer" + pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") + pcSkipBuild <- o .:? "skip-build" .!= False + return PackageConstraints {..} + +data TestState = ExpectSuccess + | ExpectFailure + | DontBuild -- ^ when the test suite will pull in things we don't want + deriving (Show, Eq, Ord, Bounded, Enum) + +testStateToText :: TestState -> Text +testStateToText ExpectSuccess = "expect-success" +testStateToText ExpectFailure = "expect-failure" +testStateToText DontBuild = "do-not-build" + +instance ToJSON TestState where + toJSON = toJSON . testStateToText +instance FromJSON TestState where + parseJSON = withText "TestState" $ \t -> + case HashMap.lookup t states of + Nothing -> fail $ "Invalid state: " ++ unpack t + Just v -> return v + where + states = HashMap.fromList + $ map (\x -> (testStateToText x, x)) [minBound..maxBound] + +data SystemInfo = SystemInfo + { siGhcVersion :: Version + , siOS :: OS + , siArch :: Arch + , siCorePackages :: Map PackageName Version + , siCoreExecutables :: Set ExeName + } + deriving (Show, Eq, Ord) +instance ToJSON SystemInfo where + toJSON SystemInfo {..} = object + [ "ghc-version" .= display siGhcVersion + , "os" .= display siOS + , "arch" .= display siArch + , "core-packages" .= Map.mapKeysWith const unPackageName (fmap display siCorePackages) + , "core-executables" .= siCoreExecutables + ] +instance FromJSON SystemInfo where + parseJSON = withObject "SystemInfo" $ \o -> do + let helper name = (o .: name) >>= either (fail . show) return . simpleParse + siGhcVersion <- helper "ghc-version" + siOS <- helper "os" + siArch <- helper "arch" + siCorePackages <- (o .: "core-packages") >>= goPackages + siCoreExecutables <- o .: "core-executables" + return SystemInfo {..} + where + goPackages = either (fail . show) return + . T.mapM simpleParse + . Map.mapKeysWith const mkPackageName + +#if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,0) +#else +unFlagName :: FlagName -> Text +unFlagName (FlagName str) = pack str + +mkFlagName :: Text -> FlagName +mkFlagName = FlagName . unpack +#endif + +newtype Maintainer = Maintainer { unMaintainer :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + +-- | Name of an executable. +newtype ExeName = ExeName { unExeName :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + +-- | A simplified package description that tracks: +-- +-- * Package dependencies +-- +-- * Build tool dependencies +-- +-- * Provided executables +-- +-- It has fully resolved all conditionals +data SimpleDesc = SimpleDesc + { sdPackages :: Map PackageName DepInfo + , sdTools :: Map ExeName DepInfo + , sdProvidedExes :: Set ExeName + , sdModules :: Set Text + -- ^ modules exported by the library + } + deriving (Show, Eq) +instance Semigroup SimpleDesc where + (SimpleDesc a b c d) <> (SimpleDesc w x y z) = SimpleDesc + (Map.unionWith (<>) a w) + (Map.unionWith (<>) b x) + (c <> y) + (d <> z) +instance Monoid SimpleDesc where + mempty = SimpleDesc mempty mempty mempty mempty +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,11,1)) +#else + mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc + (Map.unionWith (<>) a w) + (Map.unionWith (<>) b x) + (c <> y) + (d <> z) +#endif +instance ToJSON SimpleDesc where + toJSON SimpleDesc {..} = object + [ "packages" .= Map.mapKeysWith const unPackageName sdPackages + , "tools" .= Map.mapKeysWith const unExeName sdTools + , "provided-exes" .= sdProvidedExes + , "modules" .= sdModules + ] +instance FromJSON SimpleDesc where + parseJSON = withObject "SimpleDesc" $ \o -> do + sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools") + sdProvidedExes <- o .: "provided-exes" + sdModules <- o .: "modules" + return SimpleDesc {..} + +data DepInfo = DepInfo + { diComponents :: Set Component + , diRange :: VersionRange + } + deriving (Show, Eq) + +instance Semigroup DepInfo where + DepInfo a x <> DepInfo b y = DepInfo + (a <> b) + (intersectVersionRanges x y) +instance ToJSON DepInfo where + toJSON DepInfo {..} = object + [ "components" .= diComponents + , "range" .= display diRange + ] +instance FromJSON DepInfo where + parseJSON = withObject "DepInfo" $ \o -> do + diComponents <- o .: "components" + diRange <- o .: "range" >>= either (fail . show) return . simpleParse + return DepInfo {..} + +data Component = CompLibrary + | CompExecutable + | CompTestSuite + | CompBenchmark + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +compToText :: Component -> Text +compToText CompLibrary = "library" +compToText CompExecutable = "executable" +compToText CompTestSuite = "test-suite" +compToText CompBenchmark = "benchmark" + +instance ToJSON Component where + toJSON = toJSON . compToText +instance FromJSON Component where + parseJSON = withText "Component" $ \t -> maybe + (fail $ "Invalid component: " ++ unpack t) + return + (HashMap.lookup t comps) + where + comps = HashMap.fromList $ map (compToText &&& id) [minBound..maxBound] + +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y diff --git a/stackage-query.cabal b/stackage-query.cabal --- a/stackage-query.cabal +++ b/stackage-query.cabal @@ -1,5 +1,5 @@ name: stackage-query -version: 0.1.2 +version: 0.1.3 synopsis: Stackage package query description: Tool to query package metadata in Stackage license: MIT @@ -23,13 +23,22 @@ main-is: Main.hs build-depends: base >= 4.7 && < 5, Cabal >= 1.22, + aeson, containers, directory, + exceptions >= 0.6, + hashable, filepath, optparse-applicative >= 0.13, process, - stackage-types, + safe, + semigroups, text, + time, + unordered-containers, + vector, yaml + other-modules: Stackage.Types, + Paths_stackage_query GHC-options: -fwarn-missing-signatures -Wall default-language: Haskell2010