{-# LANGUAGE QuasiQuotes #-}
-- | This module exports a list of 'Fetcher's, programs which match on nix
-- fetching expressions and return programs to update them
module Update.Nix.Updater
  ( fetchers
  ) where

import           Data.Maybe
import           Data.Text                      ( Text
                                                , splitOn
                                                )
import           Nix                            ( NExprLoc )
import           Nix.Comments
import           Nix.Match.Typed
import qualified Update.Nix.FetchGit.Prefetch  as P
import           Update.Nix.FetchGit.Prefetch   ( Revision(..)
                                                , getGitFullName
                                                , getGitHubRevisionDate
                                                , getGitRevision
                                                , nixPrefetchGit
                                                , nixPrefetchUrl
                                                )
import           Update.Nix.FetchGit.Types
import           Update.Nix.FetchGit.Utils
import           Update.Span

type Fetcher
  = Bool -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)

fetchers
  :: Bool -> (NExprLoc -> Maybe Comment) -> [NExprLoc -> Maybe (M Updater)]
fetchers :: Bool
-> (NExprLoc -> Maybe Comment) -> [NExprLoc -> Maybe (M Updater)]
fetchers onlyCommented :: Bool
onlyCommented getComment :: NExprLoc -> Maybe Comment
getComment =
  (((NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Maybe Comment
getComment)
    (((NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
 -> NExprLoc -> Maybe (M Updater))
-> ((Bool
     -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
    -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> (Bool
    -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> NExprLoc
-> Maybe (M Updater)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   ((Bool
 -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> Bool
-> (NExprLoc -> Maybe Comment)
-> NExprLoc
-> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ Bool
onlyCommented)
    ((Bool
  -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
 -> NExprLoc -> Maybe (M Updater))
-> [Bool
    -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)]
-> [NExprLoc -> Maybe (M Updater)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchgitUpdater
        , Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchGitUpdater
        , Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchTarballGithubUpdater
        , Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchTarballUpdater
        , Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchGitHubUpdater
        , Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
hackageDirectUpdater
        ]

fetchgitUpdater :: Fetcher
fetchgitUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchgitUpdater onlyCommented :: Bool
onlyCommented getComment :: NExprLoc -> Maybe Comment
getComment = \case
  [matchNixLoc|
    ^fetcher {
      url = ^url;
      rev = ^rev; # rev
      sha256 = ^sha256;
      _deepClone = ^deepClone;
      _leaveDotGit = ^leaveDotGit;
      _fetchSubmodules = ^fetchSubmodules;
    }|] | NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher Maybe Comment -> [Maybe Comment] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Comment -> Maybe Comment
forall a. a -> Maybe a
Just "fetchgit", Comment -> Maybe Comment
forall a. a -> Maybe a
Just "fetchgitPrivate"]
        , Maybe RevisionRequest
desiredRev <- Maybe Comment -> Maybe RevisionRequest
commentToRequest (NExprLoc -> Maybe Comment
getComment NExprLoc
rev)
        , Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe RevisionRequest -> Bool
forall a. Maybe a -> Bool
isJust Maybe RevisionRequest
desiredRev
    -> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
      RepoLocation
url' <- Either Warning RepoLocation -> M RepoLocation
forall a. Either Warning a -> M a
fromEither (Either Warning RepoLocation -> M RepoLocation)
-> Either Warning RepoLocation -> M RepoLocation
forall a b. (a -> b) -> a -> b
$ Comment -> RepoLocation
URL (Comment -> RepoLocation)
-> Either Warning Comment -> Either Warning RepoLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLoc -> Either Warning Comment
exprText NExprLoc
url
      Bool
deepClone' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
deepClone
      Bool
leaveDotGit' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
deepClone') (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
leaveDotGit
      Bool
fetchSubmodules' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
fetchSubmodules
      Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater RepoLocation
url' Maybe RevisionRequest
desiredRev Bool
deepClone' Bool
leaveDotGit' Bool
fetchSubmodules' NExprLoc
rev (NExprLoc -> Maybe NExprLoc
forall a. a -> Maybe a
Just NExprLoc
sha256)
  _ -> Maybe (M Updater)
forall a. Maybe a
Nothing

builtinsFetchGitUpdater :: Fetcher
builtinsFetchGitUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchGitUpdater onlyCommented :: Bool
onlyCommented getComment :: NExprLoc -> Maybe Comment
getComment = \case
  [matchNixLoc|
    ^fetcher {
      url = ^url;
      rev = ^rev; # rev
      _submodules = ^submodules;
    }|] | Just "fetchGit" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
        , Maybe RevisionRequest
desiredRev <- Maybe Comment -> Maybe RevisionRequest
commentToRequest (NExprLoc -> Maybe Comment
getComment NExprLoc
rev)
        , Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe RevisionRequest -> Bool
forall a. Maybe a -> Bool
isJust Maybe RevisionRequest
desiredRev
    -> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
      RepoLocation
url' <- Either Warning RepoLocation -> M RepoLocation
forall a. Either Warning a -> M a
fromEither (Either Warning RepoLocation -> M RepoLocation)
-> Either Warning RepoLocation -> M RepoLocation
forall a b. (a -> b) -> a -> b
$ Comment -> RepoLocation
URL (Comment -> RepoLocation)
-> Either Warning Comment -> Either Warning RepoLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLoc -> Either Warning Comment
exprText NExprLoc
url
      Bool
submodules' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
submodules
      Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater RepoLocation
url' Maybe RevisionRequest
desiredRev Bool
False Bool
False Bool
submodules' NExprLoc
rev Maybe NExprLoc
forall a. Maybe a
Nothing
  _ -> Maybe (M Updater)
forall a. Maybe a
Nothing

fetchTarballGithubUpdater :: Fetcher
fetchTarballGithubUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchTarballGithubUpdater onlyCommented :: Bool
onlyCommented getComment :: NExprLoc -> Maybe Comment
getComment = \case
  [matchNixLoc|
    ^fetcher {
      url = ^url; # rev
      sha256 = ^sha256;
    }|]
    | Just "fetchTarball" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
    , Right url' :: Comment
url' <- NExprLoc -> Either Warning Comment
exprText NExprLoc
url
    , "https:" : "" : "github.com" : owner :: Comment
owner : repo :: Comment
repo : "archive" : _ <- Comment -> Comment -> [Comment]
splitOn
      "/"
      Comment
url'
    , Maybe Comment
comment <- NExprLoc -> Maybe Comment
getComment NExprLoc
url
    , Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe Comment -> Bool
forall a. Maybe a -> Bool
isJust Maybe Comment
comment
    , Maybe Comment
comment Maybe Comment -> Maybe Comment -> Bool
forall a. Eq a => a -> a -> Bool
/= Comment -> Maybe Comment
forall a. a -> Maybe a
Just "pin" -- Fall back to the regular tarball updater if we've been instructed to not change this URL
    -> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
      let rev :: Revision
rev = Comment -> Revision
Revision (Comment -> Revision) -> Comment -> Revision
forall a b. (a -> b) -> a -> b
$ Comment -> Maybe Comment -> Comment
forall a. a -> Maybe a -> a
fromMaybe "HEAD" Maybe Comment
comment
          repoUrl :: Comment
repoUrl = "https://github.com/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
owner Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> "/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
repo
      Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater)
-> (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate])
-> M Updater
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> M Updater)
-> M (Maybe Day, [SpanUpdate]) -> M Updater
forall a b. (a -> b) -> a -> b
$ do
        Comment
revision <- Comment -> Revision -> M Comment
getGitRevision Comment
repoUrl Revision
rev
        let newUrl :: Comment
newUrl = Comment
repoUrl Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> "/archive/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
revision Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> ".tar.gz"
        let Updater u :: M (Maybe Day, [SpanUpdate])
u = Comment -> NExprLoc -> Updater
tarballUpdater Comment
newUrl NExprLoc
sha256
        Day
date <- Comment -> Comment -> Revision -> M Day
getGitHubRevisionDate Comment
owner Comment
repo (Comment -> Revision
Revision Comment
revision)
        (_, urlUpdate :: [SpanUpdate]
urlUpdate) <- M (Maybe Day, [SpanUpdate])
u
        (Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
date, SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
url) (Comment -> Comment
quoteString Comment
newUrl) SpanUpdate -> [SpanUpdate] -> [SpanUpdate]
forall a. a -> [a] -> [a]
: [SpanUpdate]
urlUpdate)
  _ -> Maybe (M Updater)
forall a. Maybe a
Nothing

builtinsFetchTarballUpdater :: Fetcher
builtinsFetchTarballUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchTarballUpdater onlyCommented :: Bool
onlyCommented getComment :: NExprLoc -> Maybe Comment
getComment = \case
  [matchNixLoc|
    ^fetcher {
      url = ^url; # [pin]
      sha256 = ^sha256;
    }|] | Just "fetchTarball" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
        , Maybe Comment
comment <- NExprLoc -> Maybe Comment
getComment NExprLoc
url
        , Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe Comment -> Bool
forall a. Maybe a -> Bool
isJust Maybe Comment
comment
    -> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
      Comment
url' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
url
      Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ Comment -> NExprLoc -> Updater
tarballUpdater Comment
url' NExprLoc
sha256
  _ -> Maybe (M Updater)
forall a. Maybe a
Nothing

fetchGitHubUpdater :: Fetcher
fetchGitHubUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchGitHubUpdater onlyCommented :: Bool
onlyCommented getComment :: NExprLoc -> Maybe Comment
getComment = \case
  [matchNixLoc|
    ^fetcher {
      owner = ^owner;
      repo = ^repo;
      rev = ^rev;
      sha256 = ^sha256;
      _fetchSubmodules = ^fetchSubmodules;
    }|] | Just fun :: Comment -> Comment -> RepoLocation
fun <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher Maybe Comment
-> (Comment -> Maybe (Comment -> Comment -> RepoLocation))
-> Maybe (Comment -> Comment -> RepoLocation)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        "fetchFromGitHub" -> (Comment -> Comment -> RepoLocation)
-> Maybe (Comment -> Comment -> RepoLocation)
forall a. a -> Maybe a
Just Comment -> Comment -> RepoLocation
GitHub
                        "fetchFromGitLab" -> (Comment -> Comment -> RepoLocation)
-> Maybe (Comment -> Comment -> RepoLocation)
forall a. a -> Maybe a
Just Comment -> Comment -> RepoLocation
GitLab
                        _ -> Maybe (Comment -> Comment -> RepoLocation)
forall a. Maybe a
Nothing
        , Maybe RevisionRequest
desiredRev <- Maybe Comment -> Maybe RevisionRequest
commentToRequest (NExprLoc -> Maybe Comment
getComment NExprLoc
rev)
        , Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe RevisionRequest -> Bool
forall a. Maybe a -> Bool
isJust Maybe RevisionRequest
desiredRev
    -> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
      Comment
owner' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
owner
      Comment
repo' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
repo
      Bool
fetchSubmodules' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
fetchSubmodules
      Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater (Comment -> Comment -> RepoLocation
fun Comment
owner' Comment
repo') Maybe RevisionRequest
desiredRev Bool
False Bool
False Bool
fetchSubmodules' NExprLoc
rev (NExprLoc -> Maybe NExprLoc
forall a. a -> Maybe a
Just NExprLoc
sha256)
  _ -> Maybe (M Updater)
forall a. Maybe a
Nothing

-- |
-- @
-- callHackageDirect = {pkg, ver, sha256}:
--   let pkgver = "${pkg}-${ver}";
--   in self.callCabal2nix pkg (pkgs.fetchzip {
--        url = "mirror://hackage/${pkgver}/${pkgver}.tar.gz";
--        inherit sha256;
--      });
-- @
hackageDirectUpdater :: Fetcher
hackageDirectUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
hackageDirectUpdater onlyCommented :: Bool
onlyCommented _ = \case
  [matchNixLoc|
    ^fetcher {
      pkg = ^pkg;
      ver = ^ver;
      sha256 = ^sha256;
    }
  |] | Just "callHackageDirect" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
     , Bool -> Bool
not Bool
onlyCommented -- no comments on this one
     -> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
      Comment
pkg' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
pkg
      Comment
ver' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
ver
      let pkgver :: Comment
pkgver = Comment
pkg' Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> "-" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
ver'
          url :: Comment
url = "mirror://hackage/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
pkgver Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> "/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
pkgver Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> ".tar.gz"
      Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ Comment -> NExprLoc -> Updater
tarballUpdater Comment
url NExprLoc
sha256
  _ -> Maybe (M Updater)
forall a. Maybe a
Nothing

----------------------------------------------------------------
-- Helpers
----------------------------------------------------------------

data RevisionRequest
  = Pin
  | DoNotPin Revision

commentToRequest :: Maybe Text -> Maybe RevisionRequest
commentToRequest :: Maybe Comment -> Maybe RevisionRequest
commentToRequest = \case
  Nothing    -> Maybe RevisionRequest
forall a. Maybe a
Nothing
  Just "pin" -> RevisionRequest -> Maybe RevisionRequest
forall a. a -> Maybe a
Just RevisionRequest
Pin
  Just r :: Comment
r     -> RevisionRequest -> Maybe RevisionRequest
forall a. a -> Maybe a
Just (Revision -> RevisionRequest
DoNotPin (Comment -> Revision
Revision Comment
r))

gitUpdater
  :: RepoLocation
  -- ^ Repo URL
  -> Maybe RevisionRequest
  -- ^ Desired revision
  -> Bool
  -- ^ Deep Clone
  -> Bool
  -- ^ Leave .git
  -> Bool
  -- ^ Fetch submodules
  -> NExprLoc
  -- ^ rev
  -> Maybe NExprLoc
  -- ^ sha256, not present for some fetchers
  -> Updater
gitUpdater :: RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater repoLocation :: RepoLocation
repoLocation revisionRequest :: Maybe RevisionRequest
revisionRequest deepClone :: Bool
deepClone leaveDotGit :: Bool
leaveDotGit fetchSubmodules :: Bool
fetchSubmodules revExpr :: NExprLoc
revExpr sha256Expr :: Maybe NExprLoc
sha256Expr
  = M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate]) -> Updater
forall a b. (a -> b) -> a -> b
$ do
    let repoUrl :: Comment
repoUrl = RepoLocation -> Comment
extractUrlString RepoLocation
repoLocation
    Comment -> M ()
logVerbose (Comment -> M ()) -> Comment -> M ()
forall a b. (a -> b) -> a -> b
$ "Updating " Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> RepoLocation -> Comment
prettyRepoLocation RepoLocation
repoLocation
    [Comment]
revArgs <- case Maybe RevisionRequest
revisionRequest of
      Nothing  -> [Comment] -> ReaderT Env (ValidateT (Dual [Warning]) IO) [Comment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just req :: RevisionRequest
req -> do
        Comment
rev <- case RevisionRequest
req of
          Pin        -> Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (NExprLoc -> Either Warning Comment
exprText NExprLoc
revExpr)
          DoNotPin r :: Revision
r -> Comment -> Revision -> M Comment
getGitFullName Comment
repoUrl Revision
r
        [Comment] -> ReaderT Env (ValidateT (Dual [Warning]) IO) [Comment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ["--rev", Comment
rev]
    let args :: [Comment]
args =
          [Comment]
revArgs
            [Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> [ "--deepClone" | Bool
deepClone ]
            [Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> [ "--leave-dotGit" | Bool
leaveDotGit ]
            [Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> [ "--fetch-submodules" | Bool
fetchSubmodules ]
    NixPrefetchGitOutput
o <- [Comment] -> Comment -> M NixPrefetchGitOutput
nixPrefetchGit [Comment]
args Comment
repoUrl
    Day
d <- Either Warning Day -> M Day
forall a. Either Warning a -> M a
fromEither (Either Warning Day -> M Day) -> Either Warning Day -> M Day
forall a b. (a -> b) -> a -> b
$ Comment -> Either Warning Day
parseISO8601DateToDay (NixPrefetchGitOutput -> Comment
P.date NixPrefetchGitOutput
o)
    (Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( Day -> Maybe Day
forall a. a -> Maybe a
Just Day
d
      , [ SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
e) (Comment -> Comment
quoteString (NixPrefetchGitOutput -> Comment
P.sha256 NixPrefetchGitOutput
o))
        | Just e :: NExprLoc
e <- Maybe NExprLoc -> [Maybe NExprLoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NExprLoc
sha256Expr
        ]
        [SpanUpdate] -> [SpanUpdate] -> [SpanUpdate]
forall a. Semigroup a => a -> a -> a
<> [SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
revExpr) (Comment -> Comment
quoteString (Comment -> Comment) -> Comment -> Comment
forall a b. (a -> b) -> a -> b
$ NixPrefetchGitOutput -> Comment
P.rev NixPrefetchGitOutput
o)]
      )

tarballUpdater
  :: Text
  -- ^ URL
  -> NExprLoc
  -- ^ sha256
  -> Updater
tarballUpdater :: Comment -> NExprLoc -> Updater
tarballUpdater url :: Comment
url sha256Expr :: NExprLoc
sha256Expr = M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate]) -> Updater
forall a b. (a -> b) -> a -> b
$ do
  Comment -> M ()
logVerbose (Comment -> M ()) -> Comment -> M ()
forall a b. (a -> b) -> a -> b
$ "Updating " Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
url
  Comment
sha256 <- [Comment] -> Comment -> M Comment
nixPrefetchUrl [] Comment
url
  (Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Day
forall a. Maybe a
Nothing, [SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
sha256Expr) (Comment -> Comment
quoteString Comment
sha256)])

(~>) :: Bool -> Bool -> Bool
x :: Bool
x ~> :: Bool -> Bool -> Bool
~> y :: Bool
y = Bool -> Bool
not Bool
x Bool -> Bool -> Bool
|| Bool
y