{-# 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 filename = do
t <- Data.Text.IO.readFile filename
t' <- processText env t
-- If updates are needed, write to the file.
when (t /= t') $ Data.Text.IO.writeFile filename t'
processText :: Env -> Text -> IO Text
processText env t = do
(es, t') <- runM env (updatesFromText t <&> (`updateSpans` t))
traverse_ (sayLog env Normal . formatWarning) es
maybe exitFailure pure $ case dryness env of
Wet -> t'
Dry -> Just 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 t = do
let nixLines = V.fromList (T.lines t)
getComment sourceLines =
annotation . getCompose . unFix . annotateWithComments sourceLines
tree <- do
expr <- fromEither $ ourParseNixText t
findUpdates (getComment nixLines) expr
us <- evalUpdates =<< filterUpdates tree
case us of
[] -> logVerbose "Made no updates"
[_] -> logVerbose "Made 1 update"
_ -> logVerbose ("Made " <> T.pack (show (length us)) <> " updates")
pure us
----------------------------------------------------------------
-- Finding updates
----------------------------------------------------------------
findUpdates :: (NExprLoc -> Maybe Comment) -> NExprLoc -> M FetchTree
findUpdates getComment e = do
Env {..} <- 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 not (null updateLocations || any (containsPosition e) updateLocations)
then pure $ Node Nothing []
else
let
updaters = ($ e) <$> fetchers onlyCommented getComment
bindingTrees = \case
NamedVar p e' _ | Just t <- pathText p ->
(: []) . (Just t, ) <$> findUpdates getComment e'
b ->
traverse (fmap (Nothing, ) . findUpdates getComment) . toList $ b
in
case asum updaters of
Just u -> UpdaterNode <$> u
Nothing -> case e of
[matchNixLoc|{ _version = ^version; }|] | NSet_ _ _ bs <- unFix e ->
Node version . concat <$> traverse bindingTrees bs
[matchNixLoc|let _version = ^version; in ^x|]
| NLet_ _ bs _ <- unFix e -> do
bs' <- concat <$> traverse bindingTrees bs
x' <- findUpdates getComment x
pure $ Node version ((Nothing, x') : bs')
_ -> Node Nothing <$> traverse
(fmap (Nothing, ) . findUpdates getComment)
(toList (unFix e))
filterUpdates :: FetchTree -> M FetchTree
filterUpdates t = do
Env {..} <- ask
let matches s = any (`match` s) 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 = \case
Node v cs -> Node
v
[ (n, c')
| (n, c) <- cs
, let c' = if maybe False matches n then c else go c
]
UpdaterNode _ -> Node Nothing []
-- If there are no patterns, don't do any filtering
pure $ if null attrPatterns then t else go t
evalUpdates :: FetchTree -> M [SpanUpdate]
evalUpdates = fmap snd . go
where
go :: FetchTree -> M (Maybe Day, [SpanUpdate])
go = \case
UpdaterNode (Updater u) -> u
Node versionExpr cs -> do
-- Run over all children
(ds, ss) <- unzip . catMaybes <$> traverse (tolerate . go . snd) cs
-- Update version string with the maximum of versions in the children
let latestDate = maximumMay (catMaybes ds)
pure
( latestDate
, [ SpanUpdate (exprSpan v)
(quoteString . ("unstable-" <>) . pack . show $ d)
| Just d <- pure latestDate
, Just v <- pure versionExpr
]
<> concat ss
)
----------------------------------------------------------------
-- Utils
----------------------------------------------------------------
maximumMay :: Ord a => [a] -> Maybe a
maximumMay = \case
[] -> Nothing
xs -> Just (maximum xs)