{-# 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.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
t') (IO () -> IO ()) -> IO () -> IO ()
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') <- Env -> M Text -> IO ([Warning], Maybe Text)
forall a. Env -> M a -> IO ([Warning], Maybe a)
runM Env
env (Text -> M [SpanUpdate]
updatesFromText Text
t M [SpanUpdate] -> ([SpanUpdate] -> Text) -> M Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([SpanUpdate] -> Text -> Text
`updateSpans` Text
t))
  (Warning -> IO ()) -> [Warning] -> IO ()
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 (Text -> IO ()) -> (Warning -> Text) -> Warning -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warning -> Text
formatWarning) [Warning]
es
  IO Text -> (Text -> IO Text) -> Maybe Text -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
forall a. IO a
exitFailure Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO Text) -> Maybe Text -> IO Text
forall a b. (a -> b) -> a -> b
$ case Env -> Dryness
dryness Env
env of
    Dryness
Wet -> Maybe Text
t'
    Dryness
Dry -> Text -> Maybe Text
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 = [Text] -> Vector Text
forall a. [a] -> Vector a
V.fromList (Text -> [Text]
T.lines Text
t)
      getComment :: Vector Text -> NExprLoc -> Maybe Text
getComment Vector Text
sourceLines =
        Ann (Maybe Text) (NExprLocF (Fix NExprCommentsF)) -> Maybe Text
forall ann a. Ann ann a -> ann
annotation (Ann (Maybe Text) (NExprLocF (Fix NExprCommentsF)) -> Maybe Text)
-> (NExprLoc -> Ann (Maybe Text) (NExprLocF (Fix NExprCommentsF)))
-> NExprLoc
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose (Ann (Maybe Text)) NExprLocF (Fix NExprCommentsF)
-> Ann (Maybe Text) (NExprLocF (Fix NExprCommentsF))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (Ann (Maybe Text)) NExprLocF (Fix NExprCommentsF)
 -> Ann (Maybe Text) (NExprLocF (Fix NExprCommentsF)))
-> (NExprLoc
    -> Compose (Ann (Maybe Text)) NExprLocF (Fix NExprCommentsF))
-> NExprLoc
-> Ann (Maybe Text) (NExprLocF (Fix NExprCommentsF))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix NExprCommentsF
-> Compose (Ann (Maybe Text)) NExprLocF (Fix NExprCommentsF)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix NExprCommentsF
 -> Compose (Ann (Maybe Text)) NExprLocF (Fix NExprCommentsF))
-> (NExprLoc -> Fix NExprCommentsF)
-> NExprLoc
-> Compose (Ann (Maybe Text)) NExprLocF (Fix NExprCommentsF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Text -> NExprLoc -> Fix NExprCommentsF
annotateWithComments Vector Text
sourceLines
  FetchTree
tree <- do
    NExprLoc
expr <- Either Warning NExprLoc -> M NExprLoc
forall a. Either Warning a -> M a
fromEither (Either Warning NExprLoc -> M NExprLoc)
-> Either Warning NExprLoc -> M NExprLoc
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 (FetchTree -> M [SpanUpdate])
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
-> M [SpanUpdate]
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show ([SpanUpdate] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SpanUpdate]
us)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" updates")
  [SpanUpdate] -> M [SpanUpdate]
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 ()
..} <- ReaderT Env (ValidateT (Dual [Warning]) IO) Env
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 ([(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
updateLocations Bool -> Bool -> Bool
|| ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (NExprLoc -> (Int, Int) -> Bool
containsPosition NExprLoc
e) [(Int, Int)]
updateLocations)
    then FetchTree -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FetchTree
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree)
-> FetchTree
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node Maybe NExprLoc
forall a. Maybe a
Nothing []
    else
      let
        updaters :: [Maybe (M Updater)]
updaters     = ((NExprLoc -> Maybe (M Updater)) -> NExprLoc -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ NExprLoc
e) ((NExprLoc -> Maybe (M Updater)) -> Maybe (M Updater))
-> [NExprLoc -> Maybe (M Updater)] -> [Maybe (M Updater)]
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 <- NAttrPath NExprLoc -> Maybe Text
forall r. NAttrPath r -> Maybe Text
pathText NAttrPath NExprLoc
p ->
            ((Maybe Text, FetchTree)
-> [(Maybe Text, FetchTree)] -> [(Maybe Text, FetchTree)]
forall a. a -> [a] -> [a]
: []) ((Maybe Text, FetchTree) -> [(Maybe Text, FetchTree)])
-> (FetchTree -> (Maybe Text, FetchTree))
-> FetchTree
-> [(Maybe Text, FetchTree)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t, ) (FetchTree -> [(Maybe Text, FetchTree)])
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
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 ->
            (NExprLoc
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree))
-> [NExprLoc]
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((FetchTree -> (Maybe Text, FetchTree))
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Text
forall a. Maybe a
Nothing, ) (ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree))
-> (NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree)
-> NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree)
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) ([NExprLoc]
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)])
-> (Binding NExprLoc -> [NExprLoc])
-> Binding NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding NExprLoc -> [NExprLoc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Binding NExprLoc
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)])
-> Binding NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
forall a b. (a -> b) -> a -> b
$ Binding NExprLoc
b
      in
        case [Maybe (M Updater)] -> Maybe (M Updater)
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 (Updater -> FetchTree)
-> M Updater
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
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; }|] | NSet_ SrcSpan
_ NRecordType
_ [Binding NExprLoc]
bs <- NExprLoc -> NExprLocF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e ->
              Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node Maybe NExprLoc
version ([(Maybe Text, FetchTree)] -> FetchTree)
-> ([[(Maybe Text, FetchTree)]] -> [(Maybe Text, FetchTree)])
-> [[(Maybe Text, FetchTree)]]
-> FetchTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Maybe Text, FetchTree)]] -> [(Maybe Text, FetchTree)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Maybe Text, FetchTree)]] -> FetchTree)
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [[(Maybe Text, FetchTree)]]
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding NExprLoc
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)])
-> [Binding NExprLoc]
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [[(Maybe Text, FetchTree)]]
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|]
              | NLet_ SrcSpan
_ [Binding NExprLoc]
bs NExprLoc
_ <- NExprLoc -> NExprLocF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e -> do
                [(Maybe Text, FetchTree)]
bs' <- [[(Maybe Text, FetchTree)]] -> [(Maybe Text, FetchTree)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Maybe Text, FetchTree)]] -> [(Maybe Text, FetchTree)])
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [[(Maybe Text, FetchTree)]]
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding NExprLoc
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)])
-> [Binding NExprLoc]
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [[(Maybe Text, FetchTree)]]
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
                FetchTree -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FetchTree
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree)
-> FetchTree
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node Maybe NExprLoc
version ((Maybe Text
forall a. Maybe a
Nothing, FetchTree
x') (Maybe Text, FetchTree)
-> [(Maybe Text, FetchTree)] -> [(Maybe Text, FetchTree)]
forall a. a -> [a] -> [a]
: [(Maybe Text, FetchTree)]
bs')
            NExprLoc
_ -> Maybe NExprLoc -> [(Maybe Text, FetchTree)] -> FetchTree
Node Maybe NExprLoc
forall a. Maybe a
Nothing ([(Maybe Text, FetchTree)] -> FetchTree)
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NExprLoc
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree))
-> [NExprLoc]
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) [(Maybe Text, FetchTree)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
              ((FetchTree -> (Maybe Text, FetchTree))
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Text
forall a. Maybe a
Nothing, ) (ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree))
-> (NExprLoc
    -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree)
-> NExprLoc
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Text, FetchTree)
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)
              (NExprLocF NExprLoc -> [NExprLoc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NExprLoc -> NExprLocF NExprLoc
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 ()
..} <- ReaderT Env (ValidateT (Dual [Warning]) IO) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let matches :: Text -> Bool
matches Text
s = (Regex -> Bool) -> [Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Regex -> Text -> Bool
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 Bool -> (Text -> Bool) -> Maybe Text -> Bool
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 Maybe NExprLoc
forall a. Maybe a
Nothing []
  -- If there are no patterns, don't do any filtering
  FetchTree -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FetchTree
 -> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree)
-> FetchTree
-> ReaderT Env (ValidateT (Dual [Warning]) IO) FetchTree
forall a b. (a -> b) -> a -> b
$ if [Regex] -> Bool
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 = ((Maybe Day, [SpanUpdate]) -> [SpanUpdate])
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
-> M [SpanUpdate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Day, [SpanUpdate]) -> [SpanUpdate]
forall a b. (a, b) -> b
snd (ReaderT
   Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
 -> M [SpanUpdate])
-> (FetchTree
    -> ReaderT
         Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate]))
-> FetchTree
-> M [SpanUpdate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FetchTree
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
go
 where
  go :: FetchTree -> M (Maybe Day, [SpanUpdate])
  go :: FetchTree
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
go = \case
    UpdaterNode (Updater ReaderT
  Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
u) -> ReaderT
  Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
u
    Node Maybe NExprLoc
versionExpr [(Maybe Text, FetchTree)]
cs     -> do
      -- Run over all children
      ([Maybe Day]
ds, [[SpanUpdate]]
ss) <- [(Maybe Day, [SpanUpdate])] -> ([Maybe Day], [[SpanUpdate]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Day, [SpanUpdate])] -> ([Maybe Day], [[SpanUpdate]]))
-> ([Maybe (Maybe Day, [SpanUpdate])]
    -> [(Maybe Day, [SpanUpdate])])
-> [Maybe (Maybe Day, [SpanUpdate])]
-> ([Maybe Day], [[SpanUpdate]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Maybe Day, [SpanUpdate])] -> [(Maybe Day, [SpanUpdate])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Maybe Day, [SpanUpdate])]
 -> ([Maybe Day], [[SpanUpdate]]))
-> ReaderT
     Env
     (ValidateT (Dual [Warning]) IO)
     [Maybe (Maybe Day, [SpanUpdate])]
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) ([Maybe Day], [[SpanUpdate]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe Text, FetchTree)
 -> ReaderT
      Env
      (ValidateT (Dual [Warning]) IO)
      (Maybe (Maybe Day, [SpanUpdate])))
-> [(Maybe Text, FetchTree)]
-> ReaderT
     Env
     (ValidateT (Dual [Warning]) IO)
     [Maybe (Maybe Day, [SpanUpdate])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ReaderT
  Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
-> ReaderT
     Env
     (ValidateT (Dual [Warning]) IO)
     (Maybe (Maybe Day, [SpanUpdate]))
forall e (m :: * -> *) a. MonadValidate e m => m a -> m (Maybe a)
tolerate (ReaderT
   Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
 -> ReaderT
      Env
      (ValidateT (Dual [Warning]) IO)
      (Maybe (Maybe Day, [SpanUpdate])))
-> ((Maybe Text, FetchTree)
    -> ReaderT
         Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate]))
-> (Maybe Text, FetchTree)
-> ReaderT
     Env
     (ValidateT (Dual [Warning]) IO)
     (Maybe (Maybe Day, [SpanUpdate]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FetchTree
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
go (FetchTree
 -> ReaderT
      Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate]))
-> ((Maybe Text, FetchTree) -> FetchTree)
-> (Maybe Text, FetchTree)
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text, FetchTree) -> FetchTree
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 = [Day] -> Maybe Day
forall a. Ord a => [a] -> Maybe a
maximumMay ([Maybe Day] -> [Day]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Day]
ds)
      (Maybe Day, [SpanUpdate])
-> ReaderT
     Env (ValidateT (Dual [Warning]) IO) (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Maybe Day
latestDate
        , [ SrcSpan -> Text -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
v)
                       (Text -> Text
quoteString (Text -> Text) -> (Day -> Text) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"unstable-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Day -> Text) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack (FilePath -> Text) -> (Day -> FilePath) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> FilePath
forall a. Show a => a -> FilePath
show (Day -> Text) -> Day -> Text
forall a b. (a -> b) -> a -> b
$ Day
d)
          | Just Day
d <- Maybe Day -> [Maybe Day]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Day
latestDate
          , Just NExprLoc
v <- Maybe NExprLoc -> [Maybe NExprLoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NExprLoc
versionExpr
          ]
        [SpanUpdate] -> [SpanUpdate] -> [SpanUpdate]
forall a. Semigroup a => a -> a -> a
<> [[SpanUpdate]] -> [SpanUpdate]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SpanUpdate]]
ss
        )

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

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