{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
module Stack.Types.Package where
import Stack.Prelude
import Foreign.C.Types (CTime)
import qualified RIO.Text as T
import Data.Aeson (ToJSON (..), FromJSON (..), (.=), (.:), object, withObject)
import qualified Data.Map as M
import qualified Data.Set as Set
import Distribution.Parsec.Common (PError (..), PWarning (..), showPos)
import qualified Distribution.SPDX.License as SPDX
import Distribution.License (License)
import Distribution.ModuleName (ModuleName)
import Distribution.PackageDescription (TestSuiteInterface, BuildType)
import Distribution.System (Platform (..))
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.SourceMap
import Stack.Types.Version
data PackageException
= PackageInvalidCabalFile
!(Either PackageIdentifierRevision (Path Abs File))
!(Maybe Version)
![PError]
![PWarning]
| MismatchedCabalIdentifier !PackageIdentifierRevision !PackageIdentifier
deriving Typeable
instance Exception PackageException
instance Show PackageException where
show (PackageInvalidCabalFile loc _mversion errs warnings) = concat
[ "Unable to parse cabal file "
, case loc of
Left pir -> "for " ++ T.unpack (utf8BuilderToText (display pir))
Right fp -> toFilePath fp
, "\n\n"
, unlines $ map
(\(PError pos msg) -> concat
[ "- "
, showPos pos
, ": "
, msg
])
errs
, unlines $ map
(\(PWarning _ pos msg) -> concat
[ "- "
, showPos pos
, ": "
, msg
])
warnings
]
show (MismatchedCabalIdentifier pir ident) = concat
[ "Mismatched package identifier."
, "\nFound: "
, packageIdentifierString ident
, "\nExpected: "
, T.unpack $ utf8BuilderToText $ display pir
]
data PackageLibraries
= NoLibraries
| HasLibraries !(Set Text)
deriving (Show,Typeable)
newtype ExeName = ExeName { unExeName :: Text }
deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData, Data, Typeable)
data Package =
Package {packageName :: !PackageName
,packageVersion :: !Version
,packageLicense :: !(Either SPDX.License License)
,packageFiles :: !GetPackageFiles
,packageDeps :: !(Map PackageName DepValue)
,packageUnknownTools :: !(Set ExeName)
,packageAllDeps :: !(Set PackageName)
,packageGhcOptions :: ![Text]
,packageCabalConfigOpts :: ![Text]
,packageFlags :: !(Map FlagName Bool)
,packageDefaultFlags :: !(Map FlagName Bool)
,packageLibraries :: !PackageLibraries
,packageInternalLibraries :: !(Set Text)
,packageTests :: !(Map Text TestSuiteInterface)
,packageBenchmarks :: !(Set Text)
,packageExes :: !(Set Text)
,packageOpts :: !GetPackageOpts
,packageHasExposedModules :: !Bool
,packageBuildType :: !BuildType
,packageSetupDeps :: !(Maybe (Map PackageName VersionRange))
,packageCabalSpec :: !VersionRange
}
deriving (Show,Typeable)
packageIdent :: Package -> PackageIdentifier
packageIdent p = PackageIdentifier (packageName p) (packageVersion p)
data DepValue = DepValue
{ dvVersionRange :: !VersionRange
, dvType :: !DepType
}
deriving (Show,Typeable)
instance Semigroup DepValue where
DepValue a x <> DepValue b y = DepValue (intersectVersionRanges a b) (x <> y)
data DepType = AsLibrary | AsBuildTool
deriving (Show, Eq)
instance Semigroup DepType where
AsLibrary <> _ = AsLibrary
AsBuildTool <> x = x
packageIdentifier :: Package -> PackageIdentifier
packageIdentifier pkg =
PackageIdentifier (packageName pkg) (packageVersion pkg)
packageDefinedFlags :: Package -> Set FlagName
packageDefinedFlags = M.keysSet . packageDefaultFlags
type InstallMap = Map PackageName (InstallLocation, Version)
newtype GetPackageOpts = GetPackageOpts
{ getPackageOpts :: forall env. HasEnvConfig env
=> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> RIO env
(Map NamedComponent (Map ModuleName (Path Abs File))
,Map NamedComponent [DotCabalPath]
,Map NamedComponent BuildInfoOpts)
}
instance Show GetPackageOpts where
show _ = "<GetPackageOpts>"
data BuildInfoOpts = BuildInfoOpts
{ bioOpts :: [String]
, bioOneWordOpts :: [String]
, bioPackageFlags :: [String]
, bioCabalMacros :: Path Abs File
} deriving Show
data CabalFileType
= AllFiles
| Modules
newtype GetPackageFiles = GetPackageFiles
{ getPackageFiles :: forall env. HasEnvConfig env
=> Path Abs File
-> RIO env
(Map NamedComponent (Map ModuleName (Path Abs File))
,Map NamedComponent [DotCabalPath]
,Set (Path Abs File)
,[PackageWarning])
}
instance Show GetPackageFiles where
show _ = "<GetPackageFiles>"
data PackageWarning
= UnlistedModulesWarning NamedComponent [ModuleName]
data PackageConfig =
PackageConfig {packageConfigEnableTests :: !Bool
,packageConfigEnableBenchmarks :: !Bool
,packageConfigFlags :: !(Map FlagName Bool)
,packageConfigGhcOptions :: ![Text]
,packageConfigCabalConfigOpts :: ![Text]
,packageConfigCompilerVersion :: ActualCompiler
,packageConfigPlatform :: !Platform
}
deriving (Show,Typeable)
instance Ord Package where
compare = on compare packageName
instance Eq Package where
(==) = on (==) packageName
data PackageSource
= PSFilePath LocalPackage
| PSRemote PackageLocationImmutable Version FromSnapshot CommonPackage
instance Show PackageSource where
show (PSFilePath lp) = concat ["PSFilePath (", show lp, ")"]
show (PSRemote pli v fromSnapshot _) =
concat
[ "PSRemote"
, "(", show pli, ")"
, "(", show v, ")"
, show fromSnapshot
, "<CommonPackage>"
]
psVersion :: PackageSource -> Version
psVersion (PSFilePath lp) = packageVersion $ lpPackage lp
psVersion (PSRemote _ v _ _) = v
data LocalPackage = LocalPackage
{ lpPackage :: !Package
, lpComponents :: !(Set NamedComponent)
, lpUnbuildable :: !(Set NamedComponent)
, lpWanted :: !Bool
, lpTestDeps :: !(Map PackageName VersionRange)
, lpBenchDeps :: !(Map PackageName VersionRange)
, lpTestBench :: !(Maybe Package)
, lpCabalFile :: !(Path Abs File)
, lpBuildHaddocks :: !Bool
, lpForceDirty :: !Bool
, lpDirtyFiles :: !(MemoizedWith EnvConfig (Maybe (Set FilePath)))
, lpNewBuildCaches :: !(MemoizedWith EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo)))
, lpComponentFiles :: !(MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File))))
}
deriving Show
newtype MemoizedWith env a = MemoizedWith { unMemoizedWith :: RIO env a }
deriving (Functor, Applicative, Monad)
memoizeRefWith :: MonadIO m => RIO env a -> m (MemoizedWith env a)
memoizeRefWith action = do
ref <- newIORef Nothing
pure $ MemoizedWith $ do
mres <- readIORef ref
res <-
case mres of
Just res -> pure res
Nothing -> do
res <- tryAny action
writeIORef ref $ Just res
pure res
either throwIO pure res
runMemoizedWith
:: (HasEnvConfig env, MonadReader env m, MonadIO m)
=> MemoizedWith EnvConfig a
-> m a
runMemoizedWith (MemoizedWith action) = do
envConfig <- view envConfigL
runRIO envConfig action
instance Show (MemoizedWith env a) where
show _ = "<<MemoizedWith>>"
lpFiles :: HasEnvConfig env => LocalPackage -> RIO env (Set.Set (Path Abs File))
lpFiles = runMemoizedWith . fmap (Set.unions . M.elems) . lpComponentFiles
data InstallLocation = Snap | Local
deriving (Show, Eq)
instance Semigroup InstallLocation where
Local <> _ = Local
_ <> Local = Local
Snap <> Snap = Snap
instance Monoid InstallLocation where
mempty = Snap
mappend = (<>)
data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal
deriving (Show, Eq)
data FileCacheInfo = FileCacheInfo
{ fciModTime :: !CTime
, fciSize :: !FileSize
, fciHash :: !SHA256
}
deriving (Generic, Show, Eq, Typeable)
instance NFData FileCacheInfo
instance ToJSON FileCacheInfo where
toJSON (FileCacheInfo time size hash') = object
[ "modtime" .= time
, "size" .= size
, "hash" .= hash'
]
instance FromJSON FileCacheInfo where
parseJSON = withObject "FileCacheInfo" $ \o -> FileCacheInfo
<$> o .: "modtime"
<*> o .: "size"
<*> o .: "hash"
data DotCabalDescriptor
= DotCabalModule !ModuleName
| DotCabalMain !FilePath
| DotCabalFile !FilePath
| DotCabalCFile !FilePath
deriving (Eq,Ord,Show)
dotCabalModule :: DotCabalDescriptor -> Maybe ModuleName
dotCabalModule (DotCabalModule m) = Just m
dotCabalModule _ = Nothing
dotCabalMain :: DotCabalDescriptor -> Maybe FilePath
dotCabalMain (DotCabalMain m) = Just m
dotCabalMain _ = Nothing
data DotCabalPath
= DotCabalModulePath !(Path Abs File)
| DotCabalMainPath !(Path Abs File)
| DotCabalFilePath !(Path Abs File)
| DotCabalCFilePath !(Path Abs File)
deriving (Eq,Ord,Show)
dotCabalModulePath :: DotCabalPath -> Maybe (Path Abs File)
dotCabalModulePath (DotCabalModulePath fp) = Just fp
dotCabalModulePath _ = Nothing
dotCabalMainPath :: DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath (DotCabalMainPath fp) = Just fp
dotCabalMainPath _ = Nothing
dotCabalCFilePath :: DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath (DotCabalCFilePath fp) = Just fp
dotCabalCFilePath _ = Nothing
dotCabalGetPath :: DotCabalPath -> Path Abs File
dotCabalGetPath dcp =
case dcp of
DotCabalModulePath fp -> fp
DotCabalMainPath fp -> fp
DotCabalFilePath fp -> fp
DotCabalCFilePath fp -> fp
type InstalledMap = Map PackageName (InstallLocation, Installed)
data Installed
= Library PackageIdentifier GhcPkgId (Maybe (Either SPDX.License License))
| Executable PackageIdentifier
deriving (Show, Eq)
installedPackageIdentifier :: Installed -> PackageIdentifier
installedPackageIdentifier (Library pid _ _) = pid
installedPackageIdentifier (Executable pid) = pid
installedVersion :: Installed -> Version
installedVersion i =
let PackageIdentifier _ version = installedPackageIdentifier i
in version