ScenarioInfo.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Saving and loading info about scenarios (status, path, etc.) as
-- well as loading recursive scenario collections.
module Swarm.Game.ScenarioInfo (
  -- * Scenario info
  ScenarioStatus (..),
  _NotStarted,
  ScenarioInfo,
  scenarioPath,
  scenarioStatus,
  CodeSizeDeterminators (CodeSizeDeterminators),
  ScenarioWith,

  -- * Scenario collection
  ScenarioCollection (..),
  scenarioCollectionToList,
  flatten,
  scenarioItemByPath,
  normalizeScenarioPath,
  ScenarioItem (..),
  scenarioItemName,
  _SISingle,
  pathifyCollection,

  -- ** Tutorials
  tutorialsDirname,
  getTutorials,

  -- * Loading and saving scenarios
  loadScenarios,
  loadScenarioInfo,
  saveScenarioInfo,
) where

import Control.Algebra (Has)
import Control.Carrier.Lift (runM)
import Control.Carrier.Throw.Either (runThrow)
import Control.Effect.Accum (Accum, add)
import Control.Effect.Lift (Lift, sendIO)
import Control.Effect.Throw (Throw, liftEither)
import Control.Lens hiding (from, (<.>))
import Control.Monad (filterM, forM_, void, when, (<=<))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Char (isSpace)
import Data.Either (partitionEithers)
import Data.Either.Extra (fromRight')
import Data.List (intercalate, isPrefixOf, stripPrefix, (\\))
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Map.Ordered (OMap)
import Data.Map.Ordered qualified as OM
import Data.Maybe (isJust)
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Data.Yaml as Y
import Swarm.Failure
import Swarm.Game.Scenario
import Swarm.Game.Scenario.Scoring.CodeSize
import Swarm.Game.Scenario.Status
import Swarm.ResourceLoading (getDataDirSafe, getSwarmSavePath)
import Swarm.Util (lookupEither)
import Swarm.Util.Effect (warn, withThrow)
import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory)
import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), (</>))
import System.IO (readFile')
import System.IO.Error (catchIOError)
import Witch (into)

------------------------------------------------------------

-- * Utilities

-- | Given an ordered list of keys and a map, return a partition consisting of:
-- * Left: the keys that were not present
-- * Right: the retrievable key-value pairs in corresponding order to the provided keys
lookupInOrder :: Ord k => Map k v -> [k] -> ([k], [(k, v)])
lookupInOrder m = partitionEithers . map produceKeyValuePair
 where
  produceKeyValuePair k = sequenceA (k, lookupEither k m)

-- ** Ordered Map utilities

type instance Index (OMap k a) = k
type instance IxValue (OMap k a) = a

-- | Adapted from:
-- https://hackage.haskell.org/package/lens-5.3.4/docs/src/Control.Lens.At.html#line-319
instance Ord k => Ixed (OMap k a) where
  ix k f m = case OM.lookup k m of
    Just v -> f v <&> \v' -> OM.alter (const $ Just v') k m
    Nothing -> pure m

-- | Strangely, an 'elems' function is missing from the 'OMap' API.
orderedElems :: OMap k a -> [a]
orderedElems = map snd . OM.assocs

fromMapOM :: Ord k => Map k a -> OMap k a
fromMapOM = OM.fromList . M.toList

-- ----------------------------------------------------------------------------
-- Scenario Item
-- ----------------------------------------------------------------------------

-- | A scenario item is either a specific scenario, or a collection of
--   scenarios (/e.g./ the scenarios contained in a subdirectory).
data ScenarioItem a = SISingle (ScenarioWith a) | SICollection Text (ScenarioCollection a)
  deriving (Functor)

-- | Retrieve the name of a scenario item.
scenarioItemName :: ScenarioItem a -> Text
scenarioItemName (SISingle (ScenarioWith s _ss)) = s ^. scenarioMetadata . scenarioName
scenarioItemName (SICollection name _) = name

-- | A scenario collection is a tree of scenarios, keyed by name,
--   together with an optional order.
--
--   /Invariant:/ every item in the
--   'scOrder' exists as a key in the 'scMap'.
newtype ScenarioCollection a = SC
  { scMap :: OMap FilePath (ScenarioItem a)
  }
  deriving (Functor)

pathifyCollection :: Functor f => f ScenarioInfo -> f ScenarioPath
pathifyCollection = fmap (ScenarioPath . view scenarioPath)

-- | Access and modify 'ScenarioItem's in collection based on their path.
scenarioItemByPath :: FilePath -> Traversal' (ScenarioCollection a) (ScenarioItem a)
scenarioItemByPath path = ixp ps
 where
  ps = splitDirectories path
  ixp :: (Applicative f) => [String] -> (ScenarioItem a -> f (ScenarioItem a)) -> ScenarioCollection a -> f (ScenarioCollection a)
  ixp [] _ col = pure col
  ixp [s] f (SC m) = SC <$> ix s f m
  ixp (d : xs) f (SC m) = SC <$> ix d inner m
   where
    inner si = case si of
      SISingle {} -> pure si
      SICollection n' col -> SICollection n' <$> ixp xs f col

-- | Subdirectory of the scenarios directory where tutorials are stored.
tutorialsDirname :: FilePath
tutorialsDirname = "Tutorials"

-- | Extract just the collection of tutorial scenarios from the entire
--   scenario collection.
getTutorials :: ScenarioCollection a -> ScenarioCollection a
getTutorials sc = case OM.lookup tutorialsDirname (scMap sc) of
  Just (SICollection _ c) -> c
  _ -> SC OM.empty

-- | Canonicalize a scenario path, making it usable as a unique key.
normalizeScenarioPath ::
  (MonadIO m) =>
  ScenarioCollection a ->
  FilePath ->
  m FilePath
normalizeScenarioPath col p =
  let path = p -<.> "yaml"
   in if isJust $ col ^? scenarioItemByPath path
        then return path
        else liftIO $ do
          canonPath <- canonicalizePath path
          eitherDataDir <- runM . runThrow @SystemFailure $ getDataDirSafe Scenarios "." -- no way we got this far without data directory
          d <- canonicalizePath $ fromRight' eitherDataDir
          let n =
                stripPrefix (d </> "scenarios") canonPath
                  & maybe canonPath (dropWhile (== pathSeparator))
          return n

-- | Convert a scenario collection to a list of scenario items.
scenarioCollectionToList :: ScenarioCollection a -> [ScenarioItem a]
scenarioCollectionToList (SC xs) = orderedElems xs

flatten :: ScenarioItem a -> [ScenarioWith a]
flatten (SISingle p) = [p]
flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c

-- | Load all the scenarios from the scenarios data directory.
loadScenarios ::
  (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
  ScenarioInputs ->
  Bool ->
  m (ScenarioCollection ScenarioInfo)
loadScenarios scenarioInputs loadTestScenarios = do
  res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios"
  case res of
    Left err -> do
      warn err
      return $ SC OM.empty
    Right dataDir -> loadScenarioDir scenarioInputs loadTestScenarios dataDir

-- | The name of the special file which indicates the order of
--   scenarios in a folder.
orderFileName :: FilePath
orderFileName = "00-ORDER.txt"

testingDirectory :: FilePath
testingDirectory = "Testing"

readOrderFile :: FilePath -> IO (Maybe [String])
readOrderFile orderFile = fmap nonEmptyLines <$> readFileMaybe orderFile
 where
  nonEmptyLines :: String -> [String]
  nonEmptyLines = filter (not . null) . lines
  readFileMaybe :: FilePath -> IO (Maybe String)
  readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\_ -> return Nothing)

loadScenarioDir ::
  forall m sig.
  (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
  ScenarioInputs ->
  Bool ->
  FilePath ->
  m (ScenarioCollection ScenarioInfo)
loadScenarioDir scenarioInputs loadTestScenarios dir = do
  itemPaths <- sendIO $ filterM (isYamlOrPublicDirectory dir) =<< listDirectory dir
  scenarioMap <- loadItems itemPaths
  sendIO (readOrderFile orderFile) >>= \case
    Nothing -> loadUnorderedScenarioDir scenarioMap
    Just order -> loadOrderedScenarioDir order scenarioMap
 where
  dirName, orderFile, orderFileShortPath :: FilePath
  dirName = takeBaseName dir
  orderFile = dir </> orderFileName
  orderFileShortPath = dirName </> orderFileName

  -- The function for individual directory items either warns about SystemFailure,
  -- or has thrown SystemFailure. The following code just adds that thrown failure to others.
  loadItems :: [FilePath] -> m (Map FilePath (ScenarioItem ScenarioInfo))
  loadItems items = do
    let loadItem f = runThrow @SystemFailure $ (f,) <$> loadScenarioItem scenarioInputs loadTestScenarios (dir </> f)
    (scenarioFailures, okScenarios) <- partitionEithers <$> mapM loadItem items
    add (Seq.fromList scenarioFailures)
    return $ M.fromList okScenarios

  isHiddenDir :: String -> Bool
  isHiddenDir f = not loadTestScenarios && f == testingDirectory

  -- Keep only files which are .yaml files or directories not starting with an underscore.
  -- Marked directories contain scenarios that can't be parsed (failure tests) or only script solutions.
  isYamlOrPublicDirectory :: FilePath -> String -> IO Bool
  isYamlOrPublicDirectory d f = do
    isDir <- doesDirectoryExist $ d </> f
    return $
      if isDir
        then not ("_" `isPrefixOf` f || isHiddenDir f)
        else takeExtensions f == ".yaml"

  -- warn that the ORDER file is missing
  loadUnorderedScenarioDir :: Map FilePath (ScenarioItem a) -> m (ScenarioCollection a)
  loadUnorderedScenarioDir scenarioMap = do
    when (dirName /= testingDirectory) (warn $ OrderFileWarning orderFileShortPath NoOrderFile)
    pure . SC $ fromMapOM scenarioMap

  -- warn if the ORDER file does not match directory contents
  loadOrderedScenarioDir :: [String] -> Map FilePath (ScenarioItem a) -> m (ScenarioCollection a)
  loadOrderedScenarioDir order scenarioMap = do
    let missing = M.keys scenarioMap \\ order
        (notPresent, loaded) = lookupInOrder scenarioMap order
        dangling = filter (not . isHiddenDir) notPresent

    forM_ (NE.nonEmpty missing) (warn . OrderFileWarning orderFileShortPath . MissingFiles)
    forM_ (NE.nonEmpty dangling) (warn . OrderFileWarning orderFileShortPath . DanglingFiles)

    pure $ SC $ OM.fromList loaded

-- | How to transform scenario path to save path.
scenarioPathToSavePath :: FilePath -> FilePath -> FilePath
scenarioPathToSavePath path swarmData = swarmData </> Data.List.intercalate "_" (splitDirectories path)

-- | Load saved info about played scenario from XDG data directory.
loadScenarioInfo ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  FilePath ->
  m ScenarioInfo
loadScenarioInfo p = do
  path <- sendIO $ normalizeScenarioPath (SC OM.empty) p
  infoPath <- sendIO $ scenarioPathToSavePath path <$> getSwarmSavePath False
  hasInfo <- sendIO $ doesFileExist infoPath
  if not hasInfo
    then do
      return $
        ScenarioInfo path NotStarted
    else do
      si <-
        withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParseYaml)
          . (liftEither <=< sendIO)
          $ decodeFileEither infoPath
      -- We overwrite the (void) path that was saved inside the yaml file, so that there
      -- is only a single authoritative path "key": the original scenario path.
      return $ path <$ (si :: ScenarioInfoT ())

-- | Save info about played scenario to XDG data directory.
saveScenarioInfo ::
  FilePath ->
  ScenarioInfo ->
  IO ()
saveScenarioInfo path si = do
  infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True
  -- We do not store the path in the save file (see #2390).
  encodeFile infoPath $ void si

-- | Load a scenario item (either a scenario, or a subdirectory
--   containing a collection of scenarios) from a particular path.
loadScenarioItem ::
  ( Has (Throw SystemFailure) sig m
  , Has (Accum (Seq SystemFailure)) sig m
  , Has (Lift IO) sig m
  ) =>
  ScenarioInputs ->
  Bool ->
  FilePath ->
  m (ScenarioItem ScenarioInfo)
loadScenarioItem scenarioInputs loadTestScenarios path = do
  isDir <- sendIO $ doesDirectoryExist path
  let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path
  case isDir of
    True -> SICollection collectionName <$> loadScenarioDir scenarioInputs loadTestScenarios path
    False -> do
      s <- loadScenarioFile scenarioInputs path
      eitherSi <- runThrow @SystemFailure (loadScenarioInfo path)
      case eitherSi of
        Right si -> return $ SISingle $ ScenarioWith s si
        Left warning -> do
          warn warning
          return . SISingle . ScenarioWith s $ ScenarioInfo path NotStarted

------------------------------------------------------------
-- Some lenses + prisms
------------------------------------------------------------

makePrisms ''ScenarioItem
makePrisms ''ScenarioStatus