stackage-query 0.1.2 → 0.1.3
raw patch · 4 files changed
+441/−5 lines, 4 filesdep +aesondep +exceptionsdep +hashabledep −stackage-types
Dependencies added: aeson, exceptions, hashable, safe, semigroups, time, unordered-containers, vector
Dependencies removed: stackage-types
Files
- ChangeLog.md +4/−0
- Main.hs +7/−3
- Stackage/Types.hs +419/−0
- stackage-query.cabal +11/−2
ChangeLog.md view
@@ -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
Main.hs view
@@ -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 ()
+ Stackage/Types.hs view
@@ -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
stackage-query.cabal view
@@ -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