content: -- | @futhark pkg@
  module Futhark.CLI.Pkg (main) where
  
  import Control.Monad
  import Control.Monad.IO.Class
  import Control.Monad.Reader
  import Control.Monad.State
  import Data.List (intercalate)
  import Data.Map qualified as M
  import Data.Maybe
  import Data.Monoid
  import Data.Text qualified as T
  import Data.Text.IO qualified as T
  import Futhark.Pkg.Info
  import Futhark.Pkg.Solve
  import Futhark.Pkg.Types
  import Futhark.Util (directoryContents, maxinum)
  import Futhark.Util.Log
  import Futhark.Util.Options
  import System.Directory
  import System.Environment
  import System.Exit
  import System.FilePath
  import System.IO
  import System.IO.Temp (withSystemTempDirectory)
  import Prelude
  
  --- Installing packages
  
  installInDir :: CacheDir -> BuildList -> FilePath -> PkgM ()
  installInDir cachedir (BuildList bl) dir =
    forM_ (M.toList bl) $ \(p, v) -> do
      info <- lookupPackageRev cachedir p v
      (filedir, files) <- getFiles $ pkgGetFiles info
  
      -- The directory in the local file system that will contain the
      -- package files.
      let pdir = dir </> T.unpack p
      -- Remove any existing directory for this package.  This is a bit
      -- inefficient, as the likelihood that the old ``lib`` directory
      -- already contains the correct version is rather high.  We should
      -- have a way to recognise this situation, and not download the
      -- zipball in that case.
      liftIO $ removePathForcibly pdir
  
      forM_ files $ \file -> do
        let from = filedir </> file
            to = pdir </> file
        liftIO $ createDirectoryIfMissing True $ takeDirectory to
        logMsg $ "Copying " <> from <> "\n" <> "to      " <> to
        liftIO $ copyFile from to
  
  libDir, libNewDir, libOldDir :: FilePath
  (libDir, libNewDir, libOldDir) = ("lib", "lib~new", "lib~old")
  
  -- | Install the packages listed in the build list in the @lib@
  -- directory of the current working directory.  Since we are touching
  -- the file system, we are going to be very paranoid.  In particular,
  -- we want to avoid corrupting the @lib@ directory if something fails
  -- along the way.
  --
  -- The procedure is as follows:
  --
  -- 1) Create a directory @lib~new@.  Delete an existing @lib~new@ if
  -- necessary.
  --
  -- 2) Populate @lib~new@ based on the build list.
  --
  -- 3) Rename @lib@ to @lib~old@.  Delete an existing @lib~old@ if
  -- necessary.
  --
  -- 4) Rename @lib~new@ to @lib@
  --
  -- 5) If the current package has package path @p@, move @lib~old/p@ to
  -- @lib~new/p@.
  --
  -- 6) Delete @lib~old@.
  --
  -- Since POSIX at least guarantees atomic renames, the only place this
  -- can fail is between steps 3, 4, and 5.  In that case, at least the
  -- @lib~old@ will still exist and can be put back by the user.
  installBuildList :: CacheDir -> Maybe PkgPath -> BuildList -> PkgM ()
  installBuildList cachedir p bl = do
    libdir_exists <- liftIO $ doesDirectoryExist libDir
  
    -- 1
    liftIO $ do
      removePathForcibly libNewDir
      createDirectoryIfMissing False libNewDir
  
    -- 2
    installInDir cachedir bl libNewDir
  
    -- 3
    when libdir_exists $
      liftIO $ do
        removePathForcibly libOldDir
        renameDirectory libDir libOldDir
  
    -- 4
    liftIO $ renameDirectory libNewDir libDir
  
    -- 5
    case pkgPathFilePath <$> p of
      Just pfp | libdir_exists -> liftIO $ do
        pkgdir_exists <- doesDirectoryExist $ libOldDir </> pfp
        when pkgdir_exists $ do
          -- Ensure the parent directories exist so that we can move the
          -- package directory directly.
          createDirectoryIfMissing True $ takeDirectory $ libDir </> pfp
          renameDirectory (libOldDir </> pfp) (libDir </> pfp)
      _ -> pure ()
  
    -- 6
    when libdir_exists $ liftIO $ removePathForcibly libOldDir
  
  getPkgManifest :: PkgM PkgManifest
  getPkgManifest = do
    file_exists <- liftIO $ doesFileExist futharkPkg
    dir_exists <- liftIO $ doesDirectoryExist futharkPkg
  
    case (file_exists, dir_exists) of
      (True, _) -> liftIO $ parsePkgManifestFromFile futharkPkg
      (_, True) ->
        fail $
          futharkPkg
            <> " exists, but it is a directory!  What in Odin's beard..."
      _ -> liftIO $ do
        T.putStrLn $ T.pack futharkPkg <> " not found - pretending it's empty."
        pure $ newPkgManifest Nothing
  
  putPkgManifest :: PkgManifest -> PkgM ()
  putPkgManifest = liftIO . T.writeFile futharkPkg . prettyPkgManifest
  
  --- The CLI
  
  newtype PkgConfig = PkgConfig {pkgVerbose :: Bool}
  
  -- | The monad in which futhark-pkg runs.
  newtype PkgM a = PkgM {unPkgM :: ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a}
    deriving (Functor, Applicative, MonadIO, MonadReader PkgConfig)
  
  instance Monad PkgM where
    PkgM m >>= f = PkgM $ m >>= unPkgM . f
  
  instance MonadFail PkgM where
    fail s = liftIO $ do
      prog <- getProgName
      putStrLn $ prog ++ ": " ++ s
      exitFailure
  
  instance MonadPkgRegistry PkgM where
    putPkgRegistry = PkgM . put
    getPkgRegistry = PkgM get
  
  instance MonadLogger PkgM where
    addLog l = do
      verbose <- asks pkgVerbose
      when verbose $ liftIO $ T.hPutStrLn stderr $ toText l
  
  runPkgM :: PkgConfig -> PkgM a -> IO a
  runPkgM cfg (PkgM m) = evalStateT (runReaderT m cfg) mempty
  
  cmdMain ::
    String ->
    ([String] -> PkgConfig -> Maybe (IO ())) ->
    String ->
    [String] ->
    IO ()
  cmdMain = mainWithOptions (PkgConfig False) options
    where
      options =
        [ Option
            "v"
            ["verbose"]
            (NoArg $ Right $ \cfg -> cfg {pkgVerbose = True})
            "Write running diagnostics to stderr."
        ]
  
  doFmt :: String -> [String] -> IO ()
  doFmt = mainWithOptions () [] "" $ \args () ->
    case args of
      [] -> Just $ do
        m <- parsePkgManifestFromFile futharkPkg
        T.writeFile futharkPkg $ prettyPkgManifest m
      _ -> Nothing
  
  withCacheDir :: (CacheDir -> IO a) -> IO a
  withCacheDir f = withSystemTempDirectory "futhark-pkg" $ f . CacheDir
  
  doCheck :: String -> [String] -> IO ()
  doCheck = cmdMain "check" $ \args cfg ->
    case args of
      [] -> Just . withCacheDir $ \cachedir -> runPkgM cfg $ do
        m <- getPkgManifest
        bl <- solveDeps cachedir $ pkgRevDeps m
  
        liftIO $ T.putStrLn "Dependencies chosen:"
        liftIO $ T.putStr $ prettyBuildList bl
  
        case commented $ manifestPkgPath m of
          Nothing -> pure ()
          Just p -> do
            let pdir = "lib" </> T.unpack p
  
            pdir_exists <- liftIO $ doesDirectoryExist pdir
  
            unless pdir_exists $
              liftIO $ do
                T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not exist."
                exitFailure
  
            anything <-
              liftIO $
                any ((== ".fut") . takeExtension)
                  <$> directoryContents ("lib" </> T.unpack p)
            unless anything $
              liftIO $ do
                T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not contain any .fut files."
                exitFailure
      _ -> Nothing
  
  doSync :: String -> [String] -> IO ()
  doSync = cmdMain "" $ \args cfg ->
    case args of
      [] -> Just . withCacheDir $ \cachedir -> runPkgM cfg $ do
        m <- getPkgManifest
        bl <- solveDeps cachedir $ pkgRevDeps m
        installBuildList cachedir (commented $ manifestPkgPath m) bl
      _ -> Nothing
  
  doAdd :: String -> [String] -> IO ()
  doAdd = cmdMain "PKGPATH" $ \args cfg ->
    case args of
      [p, v]
        | Right v' <- parseVersion $ T.pack v ->
            Just $ withCacheDir $ \cachedir ->
              runPkgM cfg $ doAdd' cachedir (T.pack p) v'
      [p] ->
        Just $ withCacheDir $ \cachedir ->
          runPkgM cfg $
            -- Look up the newest revision of the package.
            doAdd' cachedir (T.pack p) =<< lookupNewestRev cachedir (T.pack p)
      _ -> Nothing
    where
      doAdd' cachedir p v = do
        m <- getPkgManifest
  
        -- See if this package (and its dependencies) even exists.  We
        -- do this by running the solver with the dependencies already
        -- in the manifest, plus this new one.  The Monoid instance for
        -- PkgRevDeps is left-biased, so we are careful to use the new
        -- version for this package.
        _ <- solveDeps cachedir $ PkgRevDeps (M.singleton p (v, Nothing)) <> pkgRevDeps m
  
        -- We either replace any existing occurence of package 'p', or
        -- we add a new one.
        p_info <- lookupPackageRev cachedir p v
        let hash = case (_svMajor v, _svMinor v, _svPatch v) of
              -- We do not perform hash-pinning for
              -- (0,0,0)-versions, because these already embed a
              -- specific revision ID into their version number.
              (0, 0, 0) -> Nothing
              _ -> Just $ pkgRevCommit p_info
            req = Required p v hash
            (m', prev_r) = addRequiredToManifest req m
  
        case prev_r of
          Just prev_r'
            | requiredPkgRev prev_r' == v ->
                liftIO $ T.putStrLn $ "Package already at version " <> prettySemVer v <> "; nothing to do."
            | otherwise ->
                liftIO $
                  T.putStrLn $
                    "Replaced "
                      <> p
                      <> " "
                      <> prettySemVer (requiredPkgRev prev_r')
                      <> " => "
                      <> prettySemVer v
                      <> "."
          Nothing ->
            liftIO $ T.putStrLn $ "Added new required package " <> p <> " " <> prettySemVer v <> "."
        putPkgManifest m'
        liftIO $ T.putStrLn "Remember to run 'futhark pkg sync'."
  
  doRemove :: String -> [String] -> IO ()
  doRemove = cmdMain "PKGPATH" $ \args cfg ->
    case args of
      [p] -> Just $ runPkgM cfg $ doRemove' $ T.pack p
      _ -> Nothing
    where
      doRemove' p = do
        m <- getPkgManifest
        case removeRequiredFromManifest p m of
          Nothing -> liftIO $ do
            T.putStrLn $ "No package " <> p <> " found in " <> T.pack futharkPkg <> "."
            exitFailure
          Just (m', r) -> do
            putPkgManifest m'
            liftIO $ T.putStrLn $ "Removed " <> p <> " " <> prettySemVer (requiredPkgRev r) <> "."
  
  doInit :: String -> [String] -> IO ()
  doInit = cmdMain "PKGPATH" $ \args cfg ->
    case args of
      [p] -> Just $ runPkgM cfg $ doCreate' $ T.pack p
      _ -> Nothing
    where
      validPkgPath p =
        not $ any (`elem` [".", ".."]) $ splitDirectories $ T.unpack p
  
      doCreate' p = do
        unless (validPkgPath p) . liftIO $ do
          T.putStrLn $ "Not a valid package path: " <> p
          T.putStrLn "Note: package paths are usually URIs."
          T.putStrLn "Note: 'futhark init' is only needed when creating a package, not to use packages."
          exitFailure
  
        exists <- liftIO $ (||) <$> doesFileExist futharkPkg <*> doesDirectoryExist futharkPkg
        when exists $
          liftIO $ do
            T.putStrLn $ T.pack futharkPkg <> " already exists."
            exitFailure
  
        liftIO $ createDirectoryIfMissing True $ "lib" </> T.unpack p
        liftIO $ T.putStrLn $ "Created directory " <> T.pack ("lib" </> T.unpack p) <> "."
  
        putPkgManifest $ newPkgManifest $ Just p
        liftIO $ T.putStrLn $ "Wrote " <> T.pack futharkPkg <> "."
  
  doUpgrade :: String -> [String] -> IO ()
  doUpgrade = cmdMain "" $ \args cfg ->
    case args of
      [] -> Just . withCacheDir $ \cachedir -> runPkgM cfg $ do
        m <- getPkgManifest
        rs <- traverse (mapM (traverse (upgrade cachedir))) $ manifestRequire m
        putPkgManifest m {manifestRequire = rs}
        if rs == manifestRequire m
          then liftIO $ T.putStrLn "Nothing to upgrade."
          else liftIO $ T.putStrLn "Remember to run 'futhark pkg sync'."
      _ -> Nothing
    where
      upgrade cachedir req = do
        v <- lookupNewestRev cachedir $ requiredPkg req
        h <- pkgRevCommit <$> lookupPackageRev cachedir (requiredPkg req) v
  
        when (v /= requiredPkgRev req) $
          liftIO $
            T.putStrLn $
              "Upgraded "
                <> requiredPkg req
                <> " "
                <> prettySemVer (requiredPkgRev req)
                <> " => "
                <> prettySemVer v
                <> "."
  
        pure
          req
            { requiredPkgRev = v,
              requiredHash = Just h
            }
  
  doVersions :: String -> [String] -> IO ()
  doVersions = cmdMain "PKGPATH" $ \args cfg ->
    case args of
      [p] -> Just $ withCacheDir $ \cachedir ->
        runPkgM cfg $ doVersions' cachedir $ T.pack p
      _ -> Nothing
    where
      doVersions' cachedir =
        mapM_ (liftIO . T.putStrLn . prettySemVer) . M.keys . pkgVersions
          <=< lookupPackage cachedir
  
  -- | Run @futhark pkg@.
  main :: String -> [String] -> IO ()
  main prog args = do
    -- Avoid Git asking for credentials.  We prefer failure.
    liftIO $ setEnv "GIT_TERMINAL_PROMPT" "0"
  
    let commands =
          [ ( "add",
              (doAdd, "Add another required package to futhark.pkg.")
            ),
            ( "check",
              (doCheck, "Check that futhark.pkg is satisfiable.")
            ),
            ( "init",
              (doInit, "Create a new futhark.pkg and a lib/ skeleton.")
            ),
            ( "fmt",
              (doFmt, "Reformat futhark.pkg.")
            ),
            ( "sync",
              (doSync, "Populate lib/ as specified by futhark.pkg.")
            ),
            ( "remove",
              (doRemove, "Remove a required package from futhark.pkg.")
            ),
            ( "upgrade",
              (doUpgrade, "Upgrade all packages to newest versions.")
            ),
            ( "versions",
              (doVersions, "List available versions for a package.")
            )
          ]
        usage = "options... <" <> intercalate "|" (map fst commands) <> ">"
    case args of
      cmd : args'
        | Just (m, _) <- lookup cmd commands ->
            m (unwords [prog, cmd]) args'
      _ -> do
        let bad _ () = Just $ do
              let k = maxinum (map (length . fst) commands) + 3
              usageMsg . T.unlines $
                ["<command> ...:", "", "Commands:"]
                  ++ [ "   " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc
                       | (cmd, (_, desc)) <- commands
                     ]
  
        mainWithOptions () [] usage bad prog args
    where
      usageMsg s = do
        T.putStrLn $ "Usage: " <> T.pack prog <> " [--version] [--help] " <> s
        exitFailure
  