{-# LANGUAGE QuasiQuotes #-}

module Update.Nix.FetchGit
  ( processFile,
    processText,
    updatesFromText,
  )
where

import Control.Monad (when)
import Control.Monad.Reader (MonadReader (ask))
import Control.Monad.Validate (MonadValidate (tolerate))
import Data.Fix
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.Text
  ( Text,
    pack,
  )
import qualified Data.Text as T
import qualified Data.Text.IO
import Data.Time (Day)
import qualified Data.Vector as V
import Nix.Comments
import Nix.Expr
import Nix.Match.Typed
import System.Exit
import Text.Regex.TDFA
import Update.Nix.FetchGit.Types
import Update.Nix.FetchGit.Utils
import Update.Nix.Updater
import Update.Span

--------------------------------------------------------------------------------
-- Tying it all together
--------------------------------------------------------------------------------

-- | Provided FilePath, update Nix file in-place
processFile :: Env -> FilePath -> IO ()
processFile :: Env -> FilePath -> IO ()
processFile Env
env FilePath
filename = do
  Text
t <- FilePath -> IO Text
Data.Text.IO.readFile FilePath
filename
  Text
t' <- Env -> Text -> IO Text
processText Env
env Text
t
  -- If updates are needed, write to the file.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
t forall a. Eq a => a -> a -> Bool
/= Text
t') forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
Data.Text.IO.writeFile FilePath
filename Text
t'

processText :: Env -> Text -> IO Text
processText :: Env -> Text -> IO Text
processText Env
env Text
t = do
  ([Warning]
es, Maybe Text
t') <- forall a. Env -> M a -> IO ([Warning], Maybe a)
runM Env
env (Text -> M [SpanUpdate]
updatesFromText Text
t forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([SpanUpdate] -> Text -> Text
`updateSpans` Text
t))
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Env -> Verbosity -> Text -> IO ()
sayLog Env
env Verbosity
Normal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warning -> Text
formatWarning) [Warning]
es
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. IO a
exitFailure forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Env -> Dryness
dryness Env
env of
    Dryness
Wet -> Maybe Text
t'
    Dryness
Dry -> forall a. a -> Maybe a
Just Text
t

-- | Given the path to a Nix file, returns the SpanUpdates
-- all the parts of the file we want to update.
updatesFromText :: Text -> M [SpanUpdate]
updatesFromText :: Text -> M [SpanUpdate]
updatesFromText Text
t = do
  let nixLines :: Vector Text
nixLines = forall a. [a] -> Vector a
V.fromList (Text -> [Text]
T.lines Text
t)
      getComment :: Vector Text -> NExprLoc -> Maybe Text
getComment Vector Text
sourceLines =
        forall ann expr. AnnUnit ann expr -> ann
annotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Text
-> NExprLoc
-> Fix
     (Compose (AnnUnit (Maybe Text)) (Compose (AnnUnit SrcSpan) NExprF))
annotateWithComments Vector Text
sourceLines
  FetchTree
tree <- do
    NExprLoc
expr <- forall a. Either Warning a -> M a
fromEither forall a b. (a -> b) -> a -> b
$ Text -> Either Warning NExprLoc
ourParseNixText Text
t
    (NExprLoc -> Maybe Text)
-> NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
findUpdates (Vector Text -> NExprLoc -> Maybe Text
getComment Vector Text
nixLines) NExprLoc
expr
  [SpanUpdate]
us <- FetchTree -> M [SpanUpdate]
evalUpdates forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FetchTree -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
filterUpdates FetchTree
tree
  case [SpanUpdate]
us of
    [] -> Text -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
logVerbose Text
"Made no updates"
    [SpanUpdate
_] -> Text -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
logVerbose Text
"Made 1 update"
    [SpanUpdate]
_ -> Text -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
logVerbose (Text
"Made " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SpanUpdate]
us)) forall a. Semigroup a => a -> a -> a
<> Text
" updates")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [SpanUpdate]
us

----------------------------------------------------------------
-- Finding updates
----------------------------------------------------------------

findUpdates :: (NExprLoc -> Maybe Comment) -> NExprLoc -> M FetchTree
findUpdates :: (NExprLoc -> Maybe Text)
-> NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
findUpdates NExprLoc -> Maybe Text
getComment NExprLoc
e = do
  Env {Bool
[(Int, Int)]
[Regex]
Dryness
Verbosity -> Text -> IO ()
onlyCommented :: Env -> Bool
attrPatterns :: Env -> [Regex]
updateLocations :: Env -> [(Int, Int)]
onlyCommented :: Bool
dryness :: Dryness
attrPatterns :: [Regex]
updateLocations :: [(Int, Int)]
sayLog :: Verbosity -> Text -> IO ()
dryness :: Env -> Dryness
sayLog :: Env -> Verbosity -> Text -> IO ()
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  -- First of all, if this expression doesn't enclose the requested position,
  -- return an empty tree
  -- Then check against all the updaters, if they match we have a leaf
  if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
updateLocations Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (NExprLoc -> (Int, Int) -> Bool
containsPosition NExprLoc
e) [(Int, Int)]
updateLocations)
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node forall a. Maybe a
Nothing []
    else
      let updaters :: [Maybe (M Updater)]
updaters = (forall a b. (a -> b) -> a -> b
$ NExprLoc
e) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> (NExprLoc -> Maybe Text) -> [NExprLoc -> Maybe (M Updater)]
fetchers Bool
onlyCommented NExprLoc -> Maybe Text
getComment
          bindingTrees :: Binding NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
bindingTrees = \case
            NamedVar NAttrPath NExprLoc
p NExprLoc
e' SourcePos
_
              | Just Text
t <- forall r. NAttrPath r -> Maybe Text
pathText NAttrPath NExprLoc
p ->
                  (forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> Maybe a
Just Text
t,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NExprLoc -> Maybe Text)
-> NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
findUpdates NExprLoc -> Maybe Text
getComment NExprLoc
e'
            Binding NExprLoc
b ->
              forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Maybe a
Nothing,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Maybe Text)
-> NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
findUpdates NExprLoc -> Maybe Text
getComment) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Binding NExprLoc
b
       in case forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe (M Updater)]
updaters of
            Just M Updater
u -> Updater -> FetchTree
UpdaterNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M Updater
u
            Maybe (M Updater)
Nothing -> case NExprLoc
e of
              NExprLoc
[matchNixLoc|{ _version = ^version; }|]
                | NSetAnnF SrcSpan
_ Recursivity
_ [Binding NExprLoc]
bs <- forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e ->
                    Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node Maybe NExprLoc
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Binding NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
bindingTrees [Binding NExprLoc]
bs
              NExprLoc
[matchNixLoc|let _version = ^version; in ^x|]
                | NLetAnnF SrcSpan
_ [Binding NExprLoc]
bs NExprLoc
_ <- forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e -> do
                    [(Maybe Text, FetchTree)]
bs' <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Binding NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
bindingTrees [Binding NExprLoc]
bs
                    FetchTree
x' <- (NExprLoc -> Maybe Text)
-> NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
findUpdates NExprLoc -> Maybe Text
getComment NExprLoc
x
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node Maybe NExprLoc
version ((forall a. Maybe a
Nothing, FetchTree
x') forall a. a -> [a] -> [a]
: [(Maybe Text, FetchTree)]
bs')
              NExprLoc
_ ->
                Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node forall a. Maybe a
Nothing
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Maybe a
Nothing,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Maybe Text)
-> NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
findUpdates NExprLoc -> Maybe Text
getComment)
                    (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e))

filterUpdates :: FetchTree -> M FetchTree
filterUpdates :: FetchTree -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
filterUpdates FetchTree
t = do
  Env {Bool
[(Int, Int)]
[Regex]
Dryness
Verbosity -> Text -> IO ()
onlyCommented :: Bool
dryness :: Dryness
attrPatterns :: [Regex]
updateLocations :: [(Int, Int)]
sayLog :: Verbosity -> Text -> IO ()
onlyCommented :: Env -> Bool
attrPatterns :: Env -> [Regex]
updateLocations :: Env -> [(Int, Int)]
dryness :: Env -> Dryness
sayLog :: Env -> Verbosity -> Text -> IO ()
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let matches :: Text -> Bool
matches Text
s = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall regex source target.
RegexContext regex source target =>
regex -> source -> target
`match` Text
s) [Regex]
attrPatterns
  -- If we're in a branch, include any bindings which match unconditionally,
  -- otherwise recurse
  -- If we reach a leaf, return empty because it hasn't been included by a
  -- binding yet
  let go :: FetchTree -> FetchTree
go = \case
        Node Maybe NExprLoc
v [(Maybe Text, FetchTree)]
cs ->
          Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node
            Maybe NExprLoc
v
            [ (Maybe Text
n, FetchTree
c')
              | (Maybe Text
n, FetchTree
c) <- [(Maybe Text, FetchTree)]
cs,
                let c' :: FetchTree
c' = if forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Text -> Bool
matches Maybe Text
n then FetchTree
c else FetchTree -> FetchTree
go FetchTree
c
            ]
        UpdaterNode Updater
_ -> Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node forall a. Maybe a
Nothing []
  -- If there are no patterns, don't do any filtering
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Regex]
attrPatterns then FetchTree
t else FetchTree -> FetchTree
go FetchTree
t

evalUpdates :: FetchTree -> M [SpanUpdate]
evalUpdates :: FetchTree -> M [SpanUpdate]
evalUpdates = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. FetchTree -> M (Maybe Day, [SpanUpdate])
go
  where
    go :: FetchTree -> M (Maybe Day, [SpanUpdate])
    go :: FetchTree -> M (Maybe Day, [SpanUpdate])
go = \case
      UpdaterNode (Updater M (Maybe Day, [SpanUpdate])
u) -> M (Maybe Day, [SpanUpdate])
u
      Node Maybe NExprLoc
versionExpr [(Maybe Text, FetchTree)]
cs -> do
        -- Run over all children
        ([Maybe Day]
ds, [[SpanUpdate]]
ss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall e (m :: * -> *) a. MonadValidate e m => m a -> m (Maybe a)
tolerate forall b c a. (b -> c) -> (a -> b) -> a -> c
. FetchTree -> M (Maybe Day, [SpanUpdate])
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Maybe Text, FetchTree)]
cs
        -- Update version string with the maximum of versions in the children
        let latestDate :: Maybe Day
latestDate = forall a. Ord a => [a] -> Maybe a
maximumMay (forall a. [Maybe a] -> [a]
catMaybes [Maybe Day]
ds)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( Maybe Day
latestDate,
            [ SrcSpan -> Text -> SpanUpdate
SpanUpdate
                (NExprLoc -> SrcSpan
exprSpan NExprLoc
v)
                (Text -> Text
quoteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"unstable-" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ Day
d)
              | Just Day
d <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Day
latestDate,
                Just NExprLoc
v <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NExprLoc
versionExpr
            ]
              forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SpanUpdate]]
ss
          )

----------------------------------------------------------------
-- Utils
----------------------------------------------------------------

maximumMay :: Ord a => [a] -> Maybe a
maximumMay :: forall a. Ord a => [a] -> Maybe a
maximumMay = \case
  [] -> forall a. Maybe a
Nothing
  [a]
xs -> forall a. a -> Maybe a
Just (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs)