{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Types.BuildPlan
(
SnapshotDef (..)
, snapshotDefVC
, sdRawPathName
, PackageLocation (..)
, PackageLocationIndex (..)
, RepoType (..)
, Subdirs (..)
, Repo (..)
, Archive (..)
, ExeName (..)
, LoadedSnapshot (..)
, loadedSnapshotVC
, LoadedPackageInfo (..)
, ModuleName (..)
, fromCabalModuleName
, ModuleInfo (..)
, moduleInfoVC
, setCompilerVersion
, sdWantedCompilerVersion
) where
import Data.Aeson (ToJSON (..), FromJSON (..), withText, object, (.=))
import Data.Aeson.Extended (WithJSONWarnings (..), (..:), (..:?), withObjectWarnings, noJSONWarnings, (..!=))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Store.Version
import Data.Store.VersionTagged
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Distribution.ModuleName as C
import qualified Distribution.Version as C
import Network.HTTP.Client (parseRequest)
import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.FlagName
import Stack.Types.GhcPkgId
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Resolver
import Stack.Types.Version
import Stack.Types.VersionIntervals
data SnapshotDef = SnapshotDef
{ sdParent :: !(Either (CompilerVersion 'CVWanted) SnapshotDef)
, sdResolver :: !LoadedResolver
, sdResolverName :: !Text
, sdLocations :: ![PackageLocationIndex Subdirs]
, sdDropPackages :: !(Set PackageName)
, sdFlags :: !(Map PackageName (Map FlagName Bool))
, sdHidden :: !(Map PackageName Bool)
, sdGhcOptions :: !(Map PackageName [Text])
, sdGlobalHints :: !(Map PackageName (Maybe Version))
}
deriving (Show, Eq, Data, Generic, Typeable)
instance Store SnapshotDef
instance NFData SnapshotDef
snapshotDefVC :: VersionConfig SnapshotDef
snapshotDefVC = storeVersionConfig "sd-v1" "CKo7nln8EXkw07Gq-4ATxszNZiE="
sdRawPathName :: SnapshotDef -> String
sdRawPathName sd =
T.unpack $ go $ sdResolver sd
where
go (ResolverStackage name) = renderSnapName name
go (ResolverCompiler version) = compilerVersionText version
go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> trimmedSnapshotHash hash
setCompilerVersion :: CompilerVersion 'CVWanted -> SnapshotDef -> SnapshotDef
setCompilerVersion cv =
go
where
go sd =
case sdParent sd of
Left _ -> sd { sdParent = Left cv }
Right sd' -> sd { sdParent = Right $ go sd' }
data PackageLocation subdirs
= PLFilePath !FilePath
| PLArchive !(Archive subdirs)
| PLRepo !(Repo subdirs)
deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)
instance (Store a) => Store (PackageLocation a)
instance (NFData a) => NFData (PackageLocation a)
data PackageLocationIndex subdirs
= PLIndex !PackageIdentifierRevision
| PLOther !(PackageLocation subdirs)
deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)
instance (Store a) => Store (PackageLocationIndex a)
instance (NFData a) => NFData (PackageLocationIndex a)
data Archive subdirs = Archive
{ archiveUrl :: !Text
, archiveSubdirs :: !subdirs
, archiveHash :: !(Maybe StaticSHA256)
}
deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)
instance Store a => Store (Archive a)
instance NFData a => NFData (Archive a)
data RepoType = RepoGit | RepoHg
deriving (Generic, Show, Eq, Ord, Data, Typeable)
instance Store RepoType
instance NFData RepoType
data Subdirs
= DefaultSubdirs
| ExplicitSubdirs ![FilePath]
deriving (Generic, Show, Eq, Data, Typeable)
instance Store Subdirs
instance NFData Subdirs
instance FromJSON Subdirs where
parseJSON = fmap ExplicitSubdirs . parseJSON
data Repo subdirs = Repo
{ repoUrl :: !Text
, repoCommit :: !Text
, repoType :: !RepoType
, repoSubdirs :: !subdirs
}
deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)
instance Store a => Store (Repo a)
instance NFData a => NFData (Repo a)
instance subdirs ~ Subdirs => ToJSON (PackageLocationIndex subdirs) where
toJSON (PLIndex ident) = toJSON ident
toJSON (PLOther loc) = toJSON loc
instance subdirs ~ Subdirs => ToJSON (PackageLocation subdirs) where
toJSON (PLFilePath fp) = toJSON fp
toJSON (PLArchive (Archive t DefaultSubdirs Nothing)) = toJSON t
toJSON (PLArchive (Archive t subdirs msha)) = object $ concat
[ ["location" .= t]
, case subdirs of
DefaultSubdirs -> []
ExplicitSubdirs x -> ["subdirs" .= x]
, case msha of
Nothing -> []
Just sha -> ["sha256" .= staticSHA256ToText sha]
]
toJSON (PLRepo (Repo url commit typ subdirs)) = object $ concat
[ case subdirs of
DefaultSubdirs -> []
ExplicitSubdirs x -> ["subdirs" .= x]
, [urlKey .= url]
, ["commit" .= commit]
]
where
urlKey =
case typ of
RepoGit -> "git"
RepoHg -> "hg"
instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocationIndex subdirs)) where
parseJSON v
= (noJSONWarnings . PLIndex <$> parseJSON v)
<|> (fmap PLOther <$> parseJSON v)
instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdirs)) where
parseJSON v
= (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v)
<|> repo v
<|> archiveObject v
<|> github v
where
file t = pure $ PLFilePath $ T.unpack t
http t =
case parseRequest $ T.unpack t of
Left _ -> fail $ "Could not parse URL: " ++ T.unpack t
Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing
repo = withObjectWarnings "PLRepo" $ \o -> do
(repoType, repoUrl) <-
((RepoGit, ) <$> o ..: "git") <|>
((RepoHg, ) <$> o ..: "hg")
repoCommit <- o ..: "commit"
repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs
return $ PLRepo Repo {..}
archiveObject = withObjectWarnings "PLArchive" $ \o -> do
url <- o ..: "archive"
subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs
msha <- o ..:? "sha256"
msha' <-
case msha of
Nothing -> return Nothing
Just t ->
case mkStaticSHA256FromText t of
Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e
Right x -> return $ Just x
return $ PLArchive Archive
{ archiveUrl = url
, archiveSubdirs = subdirs :: Subdirs
, archiveHash = msha'
}
github = withObjectWarnings "PLArchive:github" $ \o -> do
GitHubRepo ghRepo <- o ..: "github"
commit <- o ..: "commit"
subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs
return $ PLArchive Archive
{ archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz"
, archiveSubdirs = subdirs
, archiveHash = Nothing
}
newtype GitHubRepo = GitHubRepo Text
instance FromJSON GitHubRepo where
parseJSON = withText "GitHubRepo" $ \s -> do
case T.split (== '/') s of
[x, y] | not (T.null x || T.null y) -> return (GitHubRepo s)
_ -> fail "expecting \"user/repo\""
newtype ExeName = ExeName { unExeName :: Text }
deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable)
data LoadedSnapshot = LoadedSnapshot
{ lsCompilerVersion :: !(CompilerVersion 'CVActual)
, lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId))
, lsPackages :: !(Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)))
}
deriving (Generic, Show, Data, Eq, Typeable)
instance Store LoadedSnapshot
instance NFData LoadedSnapshot
loadedSnapshotVC :: VersionConfig LoadedSnapshot
loadedSnapshotVC = storeVersionConfig "ls-v4" "a_ljrJRo8hA_-gcIDP9c6NXJ2pE="
data LoadedPackageInfo loc = LoadedPackageInfo
{ lpiVersion :: !Version
, lpiLocation :: !loc
, lpiFlags :: !(Map FlagName Bool)
, lpiGhcOptions :: ![Text]
, lpiPackageDeps :: !(Map PackageName VersionIntervals)
, lpiProvidedExes :: !(Set ExeName)
, lpiNeededExes :: !(Map ExeName VersionIntervals)
, lpiExposedModules :: !(Set ModuleName)
, lpiHide :: !Bool
}
deriving (Generic, Show, Eq, Data, Typeable, Functor)
instance Store a => Store (LoadedPackageInfo a)
instance NFData a => NFData (LoadedPackageInfo a)
data DepInfo = DepInfo
{ _diComponents :: !(Set Component)
, _diRange :: !VersionIntervals
}
deriving (Generic, Show, Eq, Data, Typeable)
instance Store DepInfo
instance NFData DepInfo
instance Semigroup DepInfo where
DepInfo a x <> DepInfo b y = DepInfo
(mappend a b)
(intersectVersionIntervals x y)
instance Monoid DepInfo where
mempty = DepInfo mempty (fromVersionRange C.anyVersion)
mappend = (<>)
data Component = CompLibrary
| CompExecutable
| CompTestSuite
| CompBenchmark
deriving (Generic, Show, Eq, Ord, Data, Typeable, Enum, Bounded)
instance Store Component
instance NFData Component
newtype ModuleName = ModuleName { unModuleName :: ByteString }
deriving (Show, Eq, Ord, Generic, Store, NFData, Typeable, Data)
fromCabalModuleName :: C.ModuleName -> ModuleName
fromCabalModuleName = ModuleName . encodeUtf8 . T.intercalate "." . map T.pack . C.components
newtype ModuleInfo = ModuleInfo
{ miModules :: Map ModuleName (Set PackageName)
}
deriving (Show, Eq, Ord, Generic, Typeable, Data)
instance Store ModuleInfo
instance NFData ModuleInfo
instance Semigroup ModuleInfo where
ModuleInfo x <> ModuleInfo y =
ModuleInfo (Map.unionWith Set.union x y)
instance Monoid ModuleInfo where
mempty = ModuleInfo mempty
mappend = (<>)
moduleInfoVC :: VersionConfig ModuleInfo
moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s="
sdWantedCompilerVersion :: SnapshotDef -> CompilerVersion 'CVWanted
sdWantedCompilerVersion = either id sdWantedCompilerVersion . sdParent