1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE DataKinds #-}
10{-# LANGUAGE ConstraintKinds #-}
11module Stack.Types.Package where
12
13import           Stack.Prelude
14import qualified RIO.Text as T
15import           Data.Aeson (ToJSON (..), FromJSON (..), (.=), (.:), object, withObject)
16import qualified Data.Map as M
17import qualified Data.Set as Set
18import           Distribution.Parsec (PError (..), PWarning (..), showPos)
19import qualified Distribution.SPDX.License as SPDX
20import           Distribution.License (License)
21import           Distribution.ModuleName (ModuleName)
22import           Distribution.PackageDescription (TestSuiteInterface, BuildType)
23import           Distribution.System (Platform (..))
24import           Stack.Types.Compiler
25import           Stack.Types.Config
26import           Stack.Types.GhcPkgId
27import           Stack.Types.NamedComponent
28import           Stack.Types.SourceMap
29import           Stack.Types.Version
30
31-- | All exceptions thrown by the library.
32data PackageException
33  = PackageInvalidCabalFile
34      !(Either PackageIdentifierRevision (Path Abs File))
35      !(Maybe Version)
36      ![PError]
37      ![PWarning]
38  | MismatchedCabalIdentifier !PackageIdentifierRevision !PackageIdentifier
39  deriving Typeable
40instance Exception PackageException
41instance Show PackageException where
42    show (PackageInvalidCabalFile loc _mversion errs warnings) = concat
43        [ "Unable to parse cabal file "
44        , case loc of
45            Left pir -> "for " ++ T.unpack (utf8BuilderToText (display pir))
46            Right fp -> toFilePath fp
47        {-
48
49         Not actually needed, the errors will indicate if a newer version exists.
50         Also, it seems that this is set to Just the version even if we support it.
51
52        , case mversion of
53            Nothing -> ""
54            Just version -> "\nRequires newer Cabal file parser version: " ++
55                            versionString version
56        -}
57        , "\n\n"
58        , unlines $ map
59            (\(PError pos msg) -> concat
60                [ "- "
61                , showPos pos
62                , ": "
63                , msg
64                ])
65            errs
66        , unlines $ map
67            (\(PWarning _ pos msg) -> concat
68                [ "- "
69                , showPos pos
70                , ": "
71                , msg
72                ])
73            warnings
74        ]
75    show (MismatchedCabalIdentifier pir ident) = concat
76        [ "Mismatched package identifier."
77        , "\nFound:    "
78        , packageIdentifierString ident
79        , "\nExpected: "
80        , T.unpack $ utf8BuilderToText $ display pir
81        ]
82
83-- | Libraries in a package. Since Cabal 2.0, internal libraries are a
84-- thing.
85data PackageLibraries
86  = NoLibraries
87  | HasLibraries !(Set Text) -- ^ the foreign library names, sub libraries get built automatically without explicit component name passing
88 deriving (Show,Typeable)
89
90-- | Name of an executable.
91newtype ExeName = ExeName { unExeName :: Text }
92    deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData, Data, Typeable)
93
94-- | Some package info.
95data Package =
96  Package {packageName :: !PackageName                    -- ^ Name of the package.
97          ,packageVersion :: !Version                     -- ^ Version of the package
98          ,packageLicense :: !(Either SPDX.License License) -- ^ The license the package was released under.
99          ,packageFiles :: !GetPackageFiles               -- ^ Get all files of the package.
100          ,packageDeps :: !(Map PackageName DepValue)     -- ^ Packages that the package depends on, both as libraries and build tools.
101          ,packageUnknownTools :: !(Set ExeName)          -- ^ Build tools specified in the legacy manner (build-tools:) that failed the hard-coded lookup.
102          ,packageAllDeps :: !(Set PackageName)           -- ^ Original dependencies (not sieved).
103          ,packageGhcOptions :: ![Text]                   -- ^ Ghc options used on package.
104          ,packageCabalConfigOpts :: ![Text]              -- ^ Additional options passed to ./Setup.hs configure
105          ,packageFlags :: !(Map FlagName Bool)           -- ^ Flags used on package.
106          ,packageDefaultFlags :: !(Map FlagName Bool)    -- ^ Defaults for unspecified flags.
107          ,packageLibraries :: !PackageLibraries          -- ^ does the package have a buildable library stanza?
108          ,packageInternalLibraries :: !(Set Text)        -- ^ names of internal libraries
109          ,packageTests :: !(Map Text TestSuiteInterface) -- ^ names and interfaces of test suites
110          ,packageBenchmarks :: !(Set Text)               -- ^ names of benchmarks
111          ,packageExes :: !(Set Text)                     -- ^ names of executables
112          ,packageOpts :: !GetPackageOpts                 -- ^ Args to pass to GHC.
113          ,packageHasExposedModules :: !Bool              -- ^ Does the package have exposed modules?
114          ,packageBuildType :: !BuildType                 -- ^ Package build-type.
115          ,packageSetupDeps :: !(Maybe (Map PackageName VersionRange))
116                                                          -- ^ If present: custom-setup dependencies
117          ,packageCabalSpec :: !VersionRange              -- ^ Cabal spec range
118          }
119 deriving (Show,Typeable)
120
121packageIdent :: Package -> PackageIdentifier
122packageIdent p = PackageIdentifier (packageName p) (packageVersion p)
123
124-- | The value for a map from dependency name. This contains both the
125-- version range and the type of dependency, and provides a semigroup
126-- instance.
127data DepValue = DepValue
128  { dvVersionRange :: !VersionRange
129  , dvType :: !DepType
130  }
131  deriving (Show,Typeable)
132instance Semigroup DepValue where
133  DepValue a x <> DepValue b y = DepValue (intersectVersionRanges a b) (x <> y)
134
135-- | Is this package being used as a library, or just as a build tool?
136-- If the former, we need to ensure that a library actually
137-- exists. See
138-- <https://github.com/commercialhaskell/stack/issues/2195>
139data DepType = AsLibrary | AsBuildTool
140  deriving (Show, Eq)
141instance Semigroup DepType where
142  AsLibrary <> _ = AsLibrary
143  AsBuildTool <> x = x
144
145packageIdentifier :: Package -> PackageIdentifier
146packageIdentifier pkg =
147    PackageIdentifier (packageName pkg) (packageVersion pkg)
148
149packageDefinedFlags :: Package -> Set FlagName
150packageDefinedFlags = M.keysSet . packageDefaultFlags
151
152type InstallMap = Map PackageName (InstallLocation, Version)
153
154-- | Files that the package depends on, relative to package directory.
155-- Argument is the location of the .cabal file
156newtype GetPackageOpts = GetPackageOpts
157    { getPackageOpts :: forall env. HasEnvConfig env
158                     => InstallMap
159                     -> InstalledMap
160                     -> [PackageName]
161                     -> [PackageName]
162                     -> Path Abs File
163                     -> RIO env
164                          (Map NamedComponent (Map ModuleName (Path Abs File))
165                          ,Map NamedComponent [DotCabalPath]
166                          ,Map NamedComponent BuildInfoOpts)
167    }
168instance Show GetPackageOpts where
169    show _ = "<GetPackageOpts>"
170
171-- | GHC options based on cabal information and ghc-options.
172data BuildInfoOpts = BuildInfoOpts
173    { bioOpts :: [String]
174    , bioOneWordOpts :: [String]
175    , bioPackageFlags :: [String]
176    -- ^ These options can safely have 'nubOrd' applied to them, as
177    -- there are no multi-word options (see
178    -- https://github.com/commercialhaskell/stack/issues/1255)
179    , bioCabalMacros :: Path Abs File
180    } deriving Show
181
182-- | Files to get for a cabal package.
183data CabalFileType
184    = AllFiles
185    | Modules
186
187-- | Files that the package depends on, relative to package directory.
188-- Argument is the location of the .cabal file
189newtype GetPackageFiles = GetPackageFiles
190    { getPackageFiles :: forall env. HasEnvConfig env
191                      => Path Abs File
192                      -> RIO env
193                           (Map NamedComponent (Map ModuleName (Path Abs File))
194                           ,Map NamedComponent [DotCabalPath]
195                           ,Set (Path Abs File)
196                           ,[PackageWarning])
197    }
198instance Show GetPackageFiles where
199    show _ = "<GetPackageFiles>"
200
201-- | Warning generated when reading a package
202data PackageWarning
203    = UnlistedModulesWarning NamedComponent [ModuleName]
204      -- ^ Modules found that are not listed in cabal file
205
206    -- TODO: bring this back - see
207    -- https://github.com/commercialhaskell/stack/issues/2649
208    {-
209    | MissingModulesWarning (Path Abs File) (Maybe String) [ModuleName]
210      -- ^ Modules not found in file system, which are listed in cabal file
211    -}
212
213-- | Package build configuration
214data PackageConfig =
215  PackageConfig {packageConfigEnableTests :: !Bool                -- ^ Are tests enabled?
216                ,packageConfigEnableBenchmarks :: !Bool           -- ^ Are benchmarks enabled?
217                ,packageConfigFlags :: !(Map FlagName Bool)       -- ^ Configured flags.
218                ,packageConfigGhcOptions :: ![Text]               -- ^ Configured ghc options.
219                ,packageConfigCabalConfigOpts :: ![Text]          -- ^ ./Setup.hs configure options
220                ,packageConfigCompilerVersion :: ActualCompiler   -- ^ GHC version
221                ,packageConfigPlatform :: !Platform               -- ^ host platform
222                }
223 deriving (Show,Typeable)
224
225-- | Compares the package name.
226instance Ord Package where
227  compare = on compare packageName
228
229-- | Compares the package name.
230instance Eq Package where
231  (==) = on (==) packageName
232
233-- | Where the package's source is located: local directory or package index
234data PackageSource
235  = PSFilePath LocalPackage
236  -- ^ Package which exist on the filesystem
237  | PSRemote PackageLocationImmutable Version FromSnapshot CommonPackage
238  -- ^ Package which is downloaded remotely.
239
240instance Show PackageSource where
241    show (PSFilePath lp) = concat ["PSFilePath (", show lp, ")"]
242    show (PSRemote pli v fromSnapshot _) =
243        concat
244            [ "PSRemote"
245            , "(", show pli, ")"
246            , "(", show v, ")"
247            , show fromSnapshot
248            , "<CommonPackage>"
249            ]
250
251
252psVersion :: PackageSource -> Version
253psVersion (PSFilePath lp) = packageVersion $ lpPackage lp
254psVersion (PSRemote _ v _ _) = v
255
256-- | Information on a locally available package of source code
257data LocalPackage = LocalPackage
258    { lpPackage       :: !Package
259    -- ^ The @Package@ info itself, after resolution with package flags,
260    -- with tests and benchmarks disabled
261    , lpComponents    :: !(Set NamedComponent)
262    -- ^ Components to build, not including the library component.
263    , lpUnbuildable   :: !(Set NamedComponent)
264    -- ^ Components explicitly requested for build, that are marked
265    -- "buildable: false".
266    , lpWanted        :: !Bool -- FIXME Should completely drop this "wanted" terminology, it's unclear
267    -- ^ Whether this package is wanted as a target.
268    , lpTestDeps      :: !(Map PackageName VersionRange)
269    -- ^ Used for determining if we can use --enable-tests in a normal build.
270    , lpBenchDeps     :: !(Map PackageName VersionRange)
271    -- ^ Used for determining if we can use --enable-benchmarks in a normal
272    -- build.
273    , lpTestBench     :: !(Maybe Package)
274    -- ^ This stores the 'Package' with tests and benchmarks enabled, if
275    -- either is asked for by the user.
276    , lpCabalFile     :: !(Path Abs File)
277    -- ^ The .cabal file
278    , lpBuildHaddocks :: !Bool
279    , lpForceDirty    :: !Bool
280    , lpDirtyFiles    :: !(MemoizedWith EnvConfig (Maybe (Set FilePath)))
281    -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if
282    -- we forced the build to treat packages as dirty. Also, the Set may not
283    -- include all modified files.
284    , lpNewBuildCaches :: !(MemoizedWith EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo)))
285    -- ^ current state of the files
286    , lpComponentFiles :: !(MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File))))
287    -- ^ all files used by this package
288    }
289    deriving Show
290
291newtype MemoizedWith env a = MemoizedWith { unMemoizedWith :: RIO env a }
292  deriving (Functor, Applicative, Monad)
293
294memoizeRefWith :: MonadIO m => RIO env a -> m (MemoizedWith env a)
295memoizeRefWith action = do
296  ref <- newIORef Nothing
297  pure $ MemoizedWith $ do
298    mres <- readIORef ref
299    res <-
300      case mres of
301        Just res -> pure res
302        Nothing -> do
303          res <- tryAny action
304          writeIORef ref $ Just res
305          pure res
306    either throwIO pure res
307
308runMemoizedWith
309  :: (HasEnvConfig env, MonadReader env m, MonadIO m)
310  => MemoizedWith EnvConfig a
311  -> m a
312runMemoizedWith (MemoizedWith action) = do
313  envConfig <- view envConfigL
314  runRIO envConfig action
315
316instance Show (MemoizedWith env a) where
317  show _ = "<<MemoizedWith>>"
318
319lpFiles :: HasEnvConfig env => LocalPackage -> RIO env (Set.Set (Path Abs File))
320lpFiles = runMemoizedWith . fmap (Set.unions . M.elems) . lpComponentFiles
321
322lpFilesForComponents :: HasEnvConfig env
323                     => Set NamedComponent
324                     -> LocalPackage
325                     -> RIO env (Set.Set (Path Abs File))
326lpFilesForComponents components lp = runMemoizedWith $ do
327  componentFiles <- lpComponentFiles lp
328  pure $ mconcat (M.elems (M.restrictKeys componentFiles components))
329
330-- | A location to install a package into, either snapshot or local
331data InstallLocation = Snap | Local
332    deriving (Show, Eq)
333instance Semigroup InstallLocation where
334    Local <> _ = Local
335    _ <> Local = Local
336    Snap <> Snap = Snap
337instance Monoid InstallLocation where
338    mempty = Snap
339    mappend = (<>)
340
341data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal
342    deriving (Show, Eq)
343
344newtype FileCacheInfo = FileCacheInfo
345    { fciHash :: SHA256
346    }
347    deriving (Generic, Show, Eq, Typeable)
348instance NFData FileCacheInfo
349
350-- Provided for storing the BuildCache values in a file. But maybe
351-- JSON/YAML isn't the right choice here, worth considering.
352instance ToJSON FileCacheInfo where
353  toJSON (FileCacheInfo hash') = object
354    [ "hash" .= hash'
355    ]
356instance FromJSON FileCacheInfo where
357  parseJSON = withObject "FileCacheInfo" $ \o -> FileCacheInfo
358    <$> o .: "hash"
359
360-- | A descriptor from a .cabal file indicating one of the following:
361--
362-- exposed-modules: Foo
363-- other-modules: Foo
364-- or
365-- main-is: Foo.hs
366--
367data DotCabalDescriptor
368    = DotCabalModule !ModuleName
369    | DotCabalMain !FilePath
370    | DotCabalFile !FilePath
371    | DotCabalCFile !FilePath
372    deriving (Eq,Ord,Show)
373
374-- | Maybe get the module name from the .cabal descriptor.
375dotCabalModule :: DotCabalDescriptor -> Maybe ModuleName
376dotCabalModule (DotCabalModule m) = Just m
377dotCabalModule _ = Nothing
378
379-- | Maybe get the main name from the .cabal descriptor.
380dotCabalMain :: DotCabalDescriptor -> Maybe FilePath
381dotCabalMain (DotCabalMain m) = Just m
382dotCabalMain _ = Nothing
383
384-- | A path resolved from the .cabal file, which is either main-is or
385-- an exposed/internal/referenced module.
386data DotCabalPath
387    = DotCabalModulePath !(Path Abs File)
388    | DotCabalMainPath !(Path Abs File)
389    | DotCabalFilePath !(Path Abs File)
390    | DotCabalCFilePath !(Path Abs File)
391    deriving (Eq,Ord,Show)
392
393-- | Get the module path.
394dotCabalModulePath :: DotCabalPath -> Maybe (Path Abs File)
395dotCabalModulePath (DotCabalModulePath fp) = Just fp
396dotCabalModulePath _ = Nothing
397
398-- | Get the main path.
399dotCabalMainPath :: DotCabalPath -> Maybe (Path Abs File)
400dotCabalMainPath (DotCabalMainPath fp) = Just fp
401dotCabalMainPath _ = Nothing
402
403-- | Get the c file path.
404dotCabalCFilePath :: DotCabalPath -> Maybe (Path Abs File)
405dotCabalCFilePath (DotCabalCFilePath fp) = Just fp
406dotCabalCFilePath _ = Nothing
407
408-- | Get the path.
409dotCabalGetPath :: DotCabalPath -> Path Abs File
410dotCabalGetPath dcp =
411    case dcp of
412        DotCabalModulePath fp -> fp
413        DotCabalMainPath fp -> fp
414        DotCabalFilePath fp -> fp
415        DotCabalCFilePath fp -> fp
416
417type InstalledMap = Map PackageName (InstallLocation, Installed)
418
419data Installed
420    = Library PackageIdentifier GhcPkgId (Maybe (Either SPDX.License License))
421    | Executable PackageIdentifier
422    deriving (Show, Eq)
423
424installedPackageIdentifier :: Installed -> PackageIdentifier
425installedPackageIdentifier (Library pid _ _) = pid
426installedPackageIdentifier (Executable pid) = pid
427
428-- | Get the installed Version.
429installedVersion :: Installed -> Version
430installedVersion i =
431  let PackageIdentifier _ version = installedPackageIdentifier i
432   in version
433