{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A data type to represent system failures (as distinct from robot
-- program failures).
--
-- These failures are often not fatal and serve
-- to create common infrastructure for logging.
module Swarm.Failure (
  SystemFailure (..),
  simpleErrorHandle,
  AssetData (..),
  Asset (..),
  Entry (..),
  LoadingFailure (..),
  OrderFileWarning (..),
) where

import Control.Carrier.Throw.Either (ThrowC (..), runThrow)
import Control.Monad ((<=<))
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void
import Data.Yaml (ParseException, prettyPrintParseException)
import Prettyprinter (Pretty (pretty), nest, squotes, vcat, (<+>))
import Swarm.Pretty (BulletList (..), PrettyPrec (..), ppr, prettyShowLow, prettyString)
import Swarm.Util (showLowT)
import Text.Megaparsec (ParseErrorBundle, errorBundlePretty)
import Witch (into)

------------------------------------------------------------
-- Failure descriptions

-- | Enumeration of various assets we can attempt to load.
data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worlds | Scenarios | Script
  deriving (AssetData -> AssetData -> Bool
(AssetData -> AssetData -> Bool)
-> (AssetData -> AssetData -> Bool) -> Eq AssetData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AssetData -> AssetData -> Bool
== :: AssetData -> AssetData -> Bool
$c/= :: AssetData -> AssetData -> Bool
/= :: AssetData -> AssetData -> Bool
Eq, Int -> AssetData -> ShowS
[AssetData] -> ShowS
AssetData -> String
(Int -> AssetData -> ShowS)
-> (AssetData -> String)
-> ([AssetData] -> ShowS)
-> Show AssetData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AssetData -> ShowS
showsPrec :: Int -> AssetData -> ShowS
$cshow :: AssetData -> String
show :: AssetData -> String
$cshowList :: [AssetData] -> ShowS
showList :: [AssetData] -> ShowS
Show)

-- | Overarching enumeration of various assets we can attempt to load.
data Asset = Achievement | Data AssetData | History | Keybindings | Save
  deriving (Asset -> Asset -> Bool
(Asset -> Asset -> Bool) -> (Asset -> Asset -> Bool) -> Eq Asset
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Asset -> Asset -> Bool
== :: Asset -> Asset -> Bool
$c/= :: Asset -> Asset -> Bool
/= :: Asset -> Asset -> Bool
Eq, Int -> Asset -> ShowS
[Asset] -> ShowS
Asset -> String
(Int -> Asset -> ShowS)
-> (Asset -> String) -> ([Asset] -> ShowS) -> Show Asset
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Asset -> ShowS
showsPrec :: Int -> Asset -> ShowS
$cshow :: Asset -> String
show :: Asset -> String
$cshowList :: [Asset] -> ShowS
showList :: [Asset] -> ShowS
Show)

-- | Enumeration type to distinguish between directories and files.
data Entry = Directory | File
  deriving (Entry -> Entry -> Bool
(Entry -> Entry -> Bool) -> (Entry -> Entry -> Bool) -> Eq Entry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
/= :: Entry -> Entry -> Bool
Eq, Int -> Entry -> ShowS
[Entry] -> ShowS
Entry -> String
(Int -> Entry -> ShowS)
-> (Entry -> String) -> ([Entry] -> ShowS) -> Show Entry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Entry -> ShowS
showsPrec :: Int -> Entry -> ShowS
$cshow :: Entry -> String
show :: Entry -> String
$cshowList :: [Entry] -> ShowS
showList :: [Entry] -> ShowS
Show)

-- | An error that occurred while attempting to load some kind of asset.
data LoadingFailure
  = DoesNotExist Entry
  | EntryNot Entry
  | CanNotParseYaml ParseException
  | Duplicate AssetData Text
  | SystemFailure SystemFailure
  deriving (Int -> LoadingFailure -> ShowS
[LoadingFailure] -> ShowS
LoadingFailure -> String
(Int -> LoadingFailure -> ShowS)
-> (LoadingFailure -> String)
-> ([LoadingFailure] -> ShowS)
-> Show LoadingFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadingFailure -> ShowS
showsPrec :: Int -> LoadingFailure -> ShowS
$cshow :: LoadingFailure -> String
show :: LoadingFailure -> String
$cshowList :: [LoadingFailure] -> ShowS
showList :: [LoadingFailure] -> ShowS
Show)

-- ~~~~ Note [Pretty-printing typechecking errors]
--
-- It would make sense to store a CheckErr in DoesNotTypecheck;
-- however, Swarm.Failure is imported in lots of places, and
-- CheckErr can contain high-level things like TTerms etc., so it
-- would lead to an import cycle.  Instead, we choose to just
-- pretty-print typechecking errors before storing them here.

-- | A warning that arose while processing an @00-ORDER.txt@ file.
data OrderFileWarning
  = NoOrderFile
  | MissingFiles (NonEmpty FilePath)
  | DanglingFiles (NonEmpty FilePath)
  deriving (OrderFileWarning -> OrderFileWarning -> Bool
(OrderFileWarning -> OrderFileWarning -> Bool)
-> (OrderFileWarning -> OrderFileWarning -> Bool)
-> Eq OrderFileWarning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OrderFileWarning -> OrderFileWarning -> Bool
== :: OrderFileWarning -> OrderFileWarning -> Bool
$c/= :: OrderFileWarning -> OrderFileWarning -> Bool
/= :: OrderFileWarning -> OrderFileWarning -> Bool
Eq, Int -> OrderFileWarning -> ShowS
[OrderFileWarning] -> ShowS
OrderFileWarning -> String
(Int -> OrderFileWarning -> ShowS)
-> (OrderFileWarning -> String)
-> ([OrderFileWarning] -> ShowS)
-> Show OrderFileWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OrderFileWarning -> ShowS
showsPrec :: Int -> OrderFileWarning -> ShowS
$cshow :: OrderFileWarning -> String
show :: OrderFileWarning -> String
$cshowList :: [OrderFileWarning] -> ShowS
showList :: [OrderFileWarning] -> ShowS
Show)

-- | An enumeration of various types of failures (errors or warnings)
--   that can occur.
data SystemFailure
  = AssetNotLoaded Asset FilePath LoadingFailure
  | ScenarioNotFound FilePath
  | OrderFileWarning FilePath OrderFileWarning
  | CanNotParseMegaparsec (ParseErrorBundle Text Void)
  | DoesNotTypecheck Text -- See Note [Pretty-printing typechecking errors]
  | CustomFailure Text
  deriving (Int -> SystemFailure -> ShowS
[SystemFailure] -> ShowS
SystemFailure -> String
(Int -> SystemFailure -> ShowS)
-> (SystemFailure -> String)
-> ([SystemFailure] -> ShowS)
-> Show SystemFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SystemFailure -> ShowS
showsPrec :: Int -> SystemFailure -> ShowS
$cshow :: SystemFailure -> String
show :: SystemFailure -> String
$cshowList :: [SystemFailure] -> ShowS
showList :: [SystemFailure] -> ShowS
Show)

------------------------------------------------------------
-- Basic error handling

simpleErrorHandle :: ThrowC SystemFailure IO a -> IO a
simpleErrorHandle :: forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle = (SystemFailure -> IO a)
-> (a -> IO a) -> Either SystemFailure a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a)
-> (SystemFailure -> String) -> SystemFailure -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemFailure -> String
forall a. PrettyPrec a => a -> String
prettyString) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SystemFailure a -> IO a)
-> (ThrowC SystemFailure IO a -> IO (Either SystemFailure a))
-> ThrowC SystemFailure IO a
-> IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ThrowC SystemFailure IO a -> IO (Either SystemFailure a)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow

------------------------------------------------------------
-- Pretty-printing

instance PrettyPrec AssetData where
  prettyPrec :: forall ann. Int -> AssetData -> Doc ann
prettyPrec Int
_ = \case
    AssetData
NameGeneration -> Doc ann
"name generation data"
    AssetData
AppAsset -> Doc ann
"data assets"
    AssetData
d -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (AssetData -> Text
forall a. Show a => a -> Text
showLowT AssetData
d)

instance PrettyPrec Asset where
  prettyPrec :: forall ann. Int -> Asset -> Doc ann
prettyPrec Int
_ = \case
    Data AssetData
ad -> AssetData -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr AssetData
ad
    Asset
a -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Asset -> Text
forall a. Show a => a -> Text
showLowT Asset
a)

instance PrettyPrec Entry where
  prettyPrec :: forall ann. Int -> Entry -> Doc ann
prettyPrec Int
_ = Entry -> Doc ann
forall a ann. Show a => a -> Doc ann
prettyShowLow

instance PrettyPrec LoadingFailure where
  prettyPrec :: forall ann. Int -> LoadingFailure -> Doc ann
prettyPrec Int
prec = \case
    DoesNotExist Entry
e -> Doc ann
"The" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Entry -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Entry
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"is missing!"
    EntryNot Entry
e -> Doc ann
"The entry is not a" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Entry -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Entry
e Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"!"
    CanNotParseYaml ParseException
p ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann
"Parse failure:"
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> [Text]
T.lines (forall target source. From source target => source -> target
into @Text (ParseException -> String
prettyPrintParseException ParseException
p)))
    Duplicate AssetData
thing Text
duped -> Doc ann
"Duplicate" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AssetData -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr AssetData
thing Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
duped)
    SystemFailure SystemFailure
g -> Int -> SystemFailure -> Doc ann
forall ann. Int -> SystemFailure -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
prec SystemFailure
g

instance PrettyPrec OrderFileWarning where
  prettyPrec :: forall ann. Int -> OrderFileWarning -> Doc ann
prettyPrec Int
_ = \case
    OrderFileWarning
NoOrderFile -> Doc ann
"File not found; using alphabetical order"
    MissingFiles NonEmpty String
missing ->
      BulletList Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (BulletList Text -> Doc ann)
-> ([Text] -> BulletList Text) -> [Text] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Doc a) -> [Text] -> BulletList Text
forall i. (forall a. Doc a) -> [i] -> BulletList i
BulletList Doc a
forall a. Doc a
"Files not listed will be ignored:" ([Text] -> Doc ann) -> [Text] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (forall target source. From source target => source -> target
into @Text) (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
missing)
    DanglingFiles NonEmpty String
dangling ->
      BulletList Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (BulletList Text -> Doc ann)
-> ([Text] -> BulletList Text) -> [Text] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Doc a) -> [Text] -> BulletList Text
forall i. (forall a. Doc a) -> [i] -> BulletList i
BulletList Doc a
forall a. Doc a
"Some listed files do not exist:" ([Text] -> Doc ann) -> [Text] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (forall target source. From source target => source -> target
into @Text) (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
dangling)

instance PrettyPrec SystemFailure where
  prettyPrec :: forall ann. Int -> SystemFailure -> Doc ann
prettyPrec Int
_ = \case
    AssetNotLoaded Asset
a String
fp LoadingFailure
l ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [ Doc ann
"Failed to acquire" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Asset -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Asset
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"from path" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
        , LoadingFailure -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr LoadingFailure
l
        ]
    ScenarioNotFound String
s -> Doc ann
"Scenario not found:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
s
    OrderFileWarning String
orderFile OrderFileWarning
w ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [ Doc ann
"Warning: while processing" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
orderFile Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
        , OrderFileWarning -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr OrderFileWarning
w
        ]
    CanNotParseMegaparsec ParseErrorBundle Text Void
p ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann
"Parse failure:"
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> [Text]
T.lines (forall target source. From source target => source -> target
into @Text (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
p)))
    DoesNotTypecheck Text
t ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann
"Parse failure:"
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> [Text]
T.lines Text
t)
    CustomFailure Text
m -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
m