{-# 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
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
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
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
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
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
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 []
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
([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
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
)
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)