diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Michael Snoyman + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +## stackage-types + +This is a repository for sharing data types across multiple packages in the +[Stackage project](https://www.stackage.org). In particular, it started as a +means of sharing code between +[stackage-curator](https://github.com/fpco/stackage-curator) and +[stackage-server](https://github.com/fpco/stackage-server). + +For more information on the overall Stackage project, please see [the main +stackage repo](https://github.com/fpco/stackage). 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/Stackage/Types.hs b/Stackage/Types.hs new file mode 100644 --- /dev/null +++ b/Stackage/Types.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | 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.Monoid (Monoid, mappend, mempty) +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 qualified Data.Text as T +import qualified Data.Traversable as T +import Data.Typeable (TypeRep, Typeable, typeOf) +import Data.Vector (Vector) +import Distribution.Package (PackageName (PackageName)) +import Distribution.PackageDescription (FlagName (..)) +import Distribution.System (Arch, OS) +import qualified Distribution.Text as DT +import Distribution.Version (Version, VersionRange) +import qualified Distribution.Version as C + +data SnapshotType = STNightly + | STLTS !Int !Int -- ^ major, minor + deriving (Show, Read, Eq, Ord) + +instance ToJSON SnapshotType where + toJSON STNightly = object + [ "type" .= asText "nightly" + ] + 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" -> return STNightly + "lts" -> STLTS + <$> o .: "major" + <*> o .: "minor" + _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t + +-- | 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) + } + 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 + ] + 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 + 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 PackageName <$> (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 + +unPackageName :: PackageName -> Text +unPackageName (PackageName str) = pack str + +mkPackageName :: Text -> PackageName +mkPackageName = PackageName . unpack + +data PackageConstraints = PackageConstraints + { pcVersionRange :: VersionRange + , pcMaintainer :: Maybe Maintainer + , pcTests :: TestState + , pcHaddocks :: TestState + , pcBuildBenchmarks :: Bool + , pcFlagOverrides :: Map FlagName Bool + , pcEnableLibProfile :: Bool + } + 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 + ] + 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") + return PackageConstraints {..} + +data TestState = ExpectSuccess + | ExpectFailure + | Don'tBuild -- ^ 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 Don'tBuild = "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 + +unFlagName :: FlagName -> Text +unFlagName (FlagName str) = pack str + +mkFlagName :: Text -> FlagName +mkFlagName = FlagName . unpack + +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 Monoid SimpleDesc where + mempty = SimpleDesc mempty mempty mempty mempty + mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc + (Map.unionWith (<>) a w) + (Map.unionWith (<>) b x) + (c <> y) + (d <> z) +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-types.cabal b/stackage-types.cabal new file mode 100644 --- /dev/null +++ b/stackage-types.cabal @@ -0,0 +1,27 @@ +name: stackage-types +version: 1.0.0 +synopsis: Shared data types between various Stackage packages +description: For more information, see +homepage: https://github.com/fpco/stackage-types +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@fpcomplete.com +category: Data +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Stackage.Types + build-depends: base >= 4.7 && < 5 + , Cabal + , aeson + , containers + , exceptions >= 0.6 + , hashable + , semigroups + , text + , unordered-containers + , vector + default-language: Haskell2010