{-# 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)
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0))
#else
import Data.Monoid (Monoid)
#endif
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