{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Runtime exceptions for the Swarm language interpreter.
module Swarm.Game.Exception (
  Exn (..),
  IncapableFix (..),
  formatExn,
  exnSeverity,
  IncapableFixWords (..),

  -- * Helper functions
  formatIncapable,
  formatIncapableFix,
) where

import Control.Lens ((^.))
import Data.Aeson (FromJSON, ToJSON)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Swarm.Constant
import Swarm.Game.Achievement.Definitions
import Swarm.Game.Entity (EntityMap, devicesForCap, entityName)
import Swarm.Language.Capability (Capability (CGod), capabilityName)
import Swarm.Language.JSON ()
import Swarm.Language.Requirements.Type (Requirements (..))
import Swarm.Language.Syntax (Const, Term)
import Swarm.Log (Severity (..))
import Swarm.Pretty (prettyText)
import Swarm.Util
import Witch (from)

-- ------------------------------------------------------------------
-- SETUP FOR DOCTEST

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Control.Lens
-- >>> import Data.Text (unpack)
-- >>> import Swarm.Language.Syntax
-- >>> import Swarm.Language.Capability
-- >>> import Swarm.Game.Entity
-- >>> import Swarm.Game.Display
-- >>> import qualified Swarm.Language.Requirements.Type as R

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

-- | Suggested way to fix things when a robot does not meet the
--   requirements to run a command.
data IncapableFix
  = -- | 'Swarm.Language.Syntax.Equip' the missing device on yourself/target
    FixByEquip
  | -- | Add the missing device to your inventory
    FixByObtainDevice
  | -- | Add the missing consumables to your inventory
    FixByObtainConsumables
  deriving (IncapableFix -> IncapableFix -> Bool
(IncapableFix -> IncapableFix -> Bool)
-> (IncapableFix -> IncapableFix -> Bool) -> Eq IncapableFix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncapableFix -> IncapableFix -> Bool
== :: IncapableFix -> IncapableFix -> Bool
$c/= :: IncapableFix -> IncapableFix -> Bool
/= :: IncapableFix -> IncapableFix -> Bool
Eq, Int -> IncapableFix -> ShowS
[IncapableFix] -> ShowS
IncapableFix -> String
(Int -> IncapableFix -> ShowS)
-> (IncapableFix -> String)
-> ([IncapableFix] -> ShowS)
-> Show IncapableFix
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncapableFix -> ShowS
showsPrec :: Int -> IncapableFix -> ShowS
$cshow :: IncapableFix -> String
show :: IncapableFix -> String
$cshowList :: [IncapableFix] -> ShowS
showList :: [IncapableFix] -> ShowS
Show, (forall x. IncapableFix -> Rep IncapableFix x)
-> (forall x. Rep IncapableFix x -> IncapableFix)
-> Generic IncapableFix
forall x. Rep IncapableFix x -> IncapableFix
forall x. IncapableFix -> Rep IncapableFix x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IncapableFix -> Rep IncapableFix x
from :: forall x. IncapableFix -> Rep IncapableFix x
$cto :: forall x. Rep IncapableFix x -> IncapableFix
to :: forall x. Rep IncapableFix x -> IncapableFix
Generic, Maybe IncapableFix
Value -> Parser [IncapableFix]
Value -> Parser IncapableFix
(Value -> Parser IncapableFix)
-> (Value -> Parser [IncapableFix])
-> Maybe IncapableFix
-> FromJSON IncapableFix
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser IncapableFix
parseJSON :: Value -> Parser IncapableFix
$cparseJSONList :: Value -> Parser [IncapableFix]
parseJSONList :: Value -> Parser [IncapableFix]
$comittedField :: Maybe IncapableFix
omittedField :: Maybe IncapableFix
FromJSON, [IncapableFix] -> Value
[IncapableFix] -> Encoding
IncapableFix -> Bool
IncapableFix -> Value
IncapableFix -> Encoding
(IncapableFix -> Value)
-> (IncapableFix -> Encoding)
-> ([IncapableFix] -> Value)
-> ([IncapableFix] -> Encoding)
-> (IncapableFix -> Bool)
-> ToJSON IncapableFix
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: IncapableFix -> Value
toJSON :: IncapableFix -> Value
$ctoEncoding :: IncapableFix -> Encoding
toEncoding :: IncapableFix -> Encoding
$ctoJSONList :: [IncapableFix] -> Value
toJSONList :: [IncapableFix] -> Value
$ctoEncodingList :: [IncapableFix] -> Encoding
toEncodingList :: [IncapableFix] -> Encoding
$comitField :: IncapableFix -> Bool
omitField :: IncapableFix -> Bool
ToJSON)

-- | The type of exceptions that can be thrown by robot programs.
data Exn
  = -- | Something went very wrong.  This is a bug in Swarm and cannot
    --   be caught by a @try@ block (but at least it will not crash
    --   the entire UI).
    Fatal Text
  | -- | The user manually cancelled the computation (e.g. by hitting
    --   Ctrl-C). This cannot be caught by a @try@ block, and results
    --   in the CESK machine unwinding the stack all the way back to
    --   the top level.
    Cancel
  | -- | An infinite loop was detected via a blackhole.  This cannot
    --   be caught by a @try@ block.
    InfiniteLoop
  | -- | A robot tried to do something for which it does not have some
    --   of the required capabilities.  This cannot be caught by a
    --   @try@ block.  Also contains the missing requirements, the
    --   term that caused the problem, and a suggestion for how to fix
    --   things.
    Incapable IncapableFix Requirements Term
  | -- | A command failed in some "normal" way (/e.g./ a 'Swarm.Language.Syntax.Move'
    --   command could not move, or a 'Swarm.Language.Syntax.Grab' command found nothing to
    --   grab, /etc./).  Can be caught by a @try@ block.
    CmdFailed Const Text (Maybe GameplayAchievement)
  | -- | The user program explicitly called 'Swarm.Language.Syntax.Undefined' or 'Swarm.Language.Syntax.Fail'. Can
    --   be caught by a @try@ block.
    User Text
  deriving (Exn -> Exn -> Bool
(Exn -> Exn -> Bool) -> (Exn -> Exn -> Bool) -> Eq Exn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Exn -> Exn -> Bool
== :: Exn -> Exn -> Bool
$c/= :: Exn -> Exn -> Bool
/= :: Exn -> Exn -> Bool
Eq, Int -> Exn -> ShowS
[Exn] -> ShowS
Exn -> String
(Int -> Exn -> ShowS)
-> (Exn -> String) -> ([Exn] -> ShowS) -> Show Exn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Exn -> ShowS
showsPrec :: Int -> Exn -> ShowS
$cshow :: Exn -> String
show :: Exn -> String
$cshowList :: [Exn] -> ShowS
showList :: [Exn] -> ShowS
Show, (forall x. Exn -> Rep Exn x)
-> (forall x. Rep Exn x -> Exn) -> Generic Exn
forall x. Rep Exn x -> Exn
forall x. Exn -> Rep Exn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Exn -> Rep Exn x
from :: forall x. Exn -> Rep Exn x
$cto :: forall x. Rep Exn x -> Exn
to :: forall x. Rep Exn x -> Exn
Generic, Maybe Exn
Value -> Parser [Exn]
Value -> Parser Exn
(Value -> Parser Exn)
-> (Value -> Parser [Exn]) -> Maybe Exn -> FromJSON Exn
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Exn
parseJSON :: Value -> Parser Exn
$cparseJSONList :: Value -> Parser [Exn]
parseJSONList :: Value -> Parser [Exn]
$comittedField :: Maybe Exn
omittedField :: Maybe Exn
FromJSON, [Exn] -> Value
[Exn] -> Encoding
Exn -> Bool
Exn -> Value
Exn -> Encoding
(Exn -> Value)
-> (Exn -> Encoding)
-> ([Exn] -> Value)
-> ([Exn] -> Encoding)
-> (Exn -> Bool)
-> ToJSON Exn
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Exn -> Value
toJSON :: Exn -> Value
$ctoEncoding :: Exn -> Encoding
toEncoding :: Exn -> Encoding
$ctoJSONList :: [Exn] -> Value
toJSONList :: [Exn] -> Value
$ctoEncodingList :: [Exn] -> Encoding
toEncodingList :: [Exn] -> Encoding
$comitField :: Exn -> Bool
omitField :: Exn -> Bool
ToJSON)

-- | Pretty-print an exception for displaying to the player.
formatExn :: EntityMap -> Exn -> Text
formatExn :: EntityMap -> Exn -> Text
formatExn EntityMap
em = \case
  Fatal Text
t ->
    [Text] -> Text
T.unlines
      [ Text
"Fatal error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
      , Text
"Please report this as a bug at"
      , Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
swarmRepoUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"issues/new>."
      ]
  Exn
Cancel -> Text
"Computation cancelled."
  Exn
InfiniteLoop -> Text
"Infinite loop detected!"
  (CmdFailed Const
c Text
t Maybe GameplayAchievement
_) -> [Text] -> Text
T.concat [Const -> Text
forall a. PrettyPrec a => a -> Text
prettyText Const
c, Text
": ", Text
t]
  (User Text
t) -> Text
"Player exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
  (Incapable IncapableFix
f Requirements
caps Term
tm) -> EntityMap -> IncapableFix -> Requirements -> Term -> Text
formatIncapable EntityMap
em IncapableFix
f Requirements
caps Term
tm

exnSeverity :: Exn -> Severity
exnSeverity :: Exn -> Severity
exnSeverity = \case
  Fatal {} -> Severity
Critical
  Cancel {} -> Severity
Info
  InfiniteLoop {} -> Severity
Error
  Incapable {} -> Severity
Error
  CmdFailed {} -> Severity
Error
  User {} -> Severity
Error

-- ------------------------------------------------------------------
-- INCAPABLE HELPERS
-- ------------------------------------------------------------------

data IncapableFixWords = IncapableFixWords
  { IncapableFixWords -> Text
fixVerb :: Text
  , IncapableFixWords -> Text
fixNoun :: Text
  }

-- | Pretty-print an 'IncapableFix': either "equip device",
-- "obtain device", or "obtain consumables".
formatIncapableFix :: IncapableFix -> IncapableFixWords
formatIncapableFix :: IncapableFix -> IncapableFixWords
formatIncapableFix = \case
  IncapableFix
FixByEquip -> Text -> Text -> IncapableFixWords
IncapableFixWords Text
"equip" Text
"device(s)"
  IncapableFix
FixByObtainDevice -> Text -> Text -> IncapableFixWords
IncapableFixWords Text
"obtain" Text
"device(s)"
  IncapableFix
FixByObtainConsumables -> Text -> Text -> IncapableFixWords
IncapableFixWords Text
"obtain" Text
"consumables"

-- | Pretty print the incapable exception with an actionable suggestion
--   on how to fix it.
--
-- >>> import Data.Either (fromRight)
-- >>> import Control.Carrier.Throw.Either (runThrow)
-- >>> import Control.Algebra (run)
-- >>> import Swarm.Failure (LoadingFailure)
-- >>> import qualified Data.Set as S
-- >>> :set -XTypeApplications
-- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty (S.singleton $ CExecute Appear)
-- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty (S.singleton $ CExecute Appear)
-- >>> m = fromRight mempty . run . runThrow @LoadingFailure $ buildEntityMap [w,r]
-- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByEquip cs t
--
-- >>> incapableError (R.singletonCap CGod) (TConst As)
-- Thou shalt not utter such blasphemy:
--   'as'
--   If God in troth thou wantest to play, try thou a Creative game.
--
-- >>> incapableError (R.singletonCap $ CExecute Appear) (TConst Appear)
-- You do not have the device(s) required for:
--   'appear'
--   Please equip:
--   - magic wand or the one ring
--
-- >>> incapableError (R.singletonCap $ CExecute Random) (TConst Random)
-- Missing the random capability for:
--   'random'
--   but no device yet provides it. See
--   https://github.com/swarm-game/swarm/issues/26
--
-- >>> incapableError (R.singletonInv 3 "tree") (TConst Noop)
-- You are missing required inventory for:
--   'noop'
--   Please obtain:
--   - tree (3)
formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text
formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text
formatIncapable EntityMap
em IncapableFix
f (Requirements Set Capability
caps Set Text
_ Map Text Int
inv) Term
tm
  | Capability
CGod Capability -> Set Capability -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
caps =
      NonEmpty Text -> Text
unlinesExText (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall a b. (a -> b) -> a -> b
$
        Text
"Thou shalt not utter such blasphemy:"
          Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [ Text -> Text
squote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Term -> Text
forall a. PrettyPrec a => a -> Text
prettyText Term
tm
             , Text
"If God in troth thou wantest to play, try thou a Creative game."
             ]
  | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
capsNone) =
      NonEmpty Text -> Text
unlinesExText (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall a b. (a -> b) -> a -> b
$
        Text
"Missing the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
capMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for:"
          Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [ Text -> Text
squote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Term -> Text
forall a. PrettyPrec a => a -> Text
prettyText Term
tm
             , Text
"but no device yet provides it. See"
             , Text
swarmRepoUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"issues/26"
             ]
  | Bool -> Bool
not (Set Capability -> Bool
forall a. Set a -> Bool
S.null Set Capability
caps) =
      let IncapableFixWords Text
fVerb Text
fNoun = IncapableFix -> IncapableFixWords
formatIncapableFix IncapableFix
f
       in NonEmpty Text -> Text
unlinesExText
            ( [Text] -> Text
T.unwords [Text
"You do not have the", Text
fNoun, Text
"required for:"]
                Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| Text -> Text
squote (Term -> Text
forall a. PrettyPrec a => a -> Text
prettyText Term
tm)
                Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"Please " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fVerb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
                Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> ([Entity] -> Text) -> [Entity] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entity] -> Text
formatDevices ([Entity] -> Text) -> [[Entity]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Entity] -> Bool) -> [[Entity]] -> [[Entity]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Entity] -> Bool) -> [Entity] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Entity]]
deviceSets)
            )
  | Bool
otherwise =
      NonEmpty Text -> Text
unlinesExText
        ( Text
"You are missing required inventory for:"
            Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| Text -> Text
squote (Term -> Text
forall a. PrettyPrec a => a -> Text
prettyText Term
tm)
            Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"Please obtain:"
            Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> ((Text, Int) -> Text) -> (Text, Int) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Int) -> Text
forall {a} {a}.
(Eq a, Num a, Semigroup a, IsString a, From String a, Show a) =>
(a, a) -> a
formatEntity ((Text, Int) -> Text) -> [(Text, Int)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Int -> [(Text, Int)]
forall k a. Map k a -> [(k, a)]
M.assocs Map Text Int
inv)
        )
 where
  capList :: [Capability]
capList = Set Capability -> [Capability]
forall a. Set a -> [a]
S.toList Set Capability
caps
  deviceSets :: [[Entity]]
deviceSets = (Capability -> [Entity]) -> [Capability] -> [[Entity]]
forall a b. (a -> b) -> [a] -> [b]
map (Capability -> EntityMap -> [Entity]
`devicesForCap` EntityMap
em) [Capability]
capList
  devicePerCap :: [(Capability, [Entity])]
devicePerCap = [Capability] -> [[Entity]] -> [(Capability, [Entity])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Capability]
capList [[Entity]]
deviceSets
  -- capabilities not provided by any device
  capsNone :: [Text]
capsNone = ((Capability, [Entity]) -> Text)
-> [(Capability, [Entity])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Capability -> Text
capabilityName (Capability -> Text)
-> ((Capability, [Entity]) -> Capability)
-> (Capability, [Entity])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Capability, [Entity]) -> Capability
forall a b. (a, b) -> a
fst) ([(Capability, [Entity])] -> [Text])
-> [(Capability, [Entity])] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Capability, [Entity]) -> Bool)
-> [(Capability, [Entity])] -> [(Capability, [Entity])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Entity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Entity] -> Bool)
-> ((Capability, [Entity]) -> [Entity])
-> (Capability, [Entity])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Capability, [Entity]) -> [Entity]
forall a b. (a, b) -> b
snd) [(Capability, [Entity])]
devicePerCap
  capMsg :: Text
capMsg = case [Text]
capsNone of
    [Text
ca] -> Text
ca Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" capability"
    [Text]
cas -> Text
"capabilities " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
cas
  formatDevices :: [Entity] -> Text
formatDevices = Text -> [Text] -> Text
T.intercalate Text
" or " ([Text] -> Text) -> ([Entity] -> [Text]) -> [Entity] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Text) -> [Entity] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName)
  formatEntity :: (a, a) -> a
formatEntity (a
e, a
1) = a
e
  formatEntity (a
e, a
n) = a
e a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" (" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall source target. From source target => source -> target
from (a -> String
forall a. Show a => a -> String
show a
n) a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"

-- | Exceptions that span multiple lines should be indented.
unlinesExText :: NonEmpty Text -> Text
unlinesExText :: NonEmpty Text -> Text
unlinesExText (Text
t :| [Text]
ts) = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
ts