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

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

  -- * 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, deviceForCap, entityName)
import Swarm.Language.Capability (Capability (CGod), capabilityName)
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Requirement (Requirements (..))
import Swarm.Language.Syntax (Const, Term)
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.Requirement 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
    FixByObtain
  deriving (IncapableFix -> IncapableFix -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IncapableFix -> IncapableFix -> Bool
$c/= :: IncapableFix -> IncapableFix -> Bool
== :: IncapableFix -> IncapableFix -> Bool
$c== :: IncapableFix -> IncapableFix -> Bool
Eq, Int -> IncapableFix -> ShowS
[IncapableFix] -> ShowS
IncapableFix -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IncapableFix] -> ShowS
$cshowList :: [IncapableFix] -> ShowS
show :: IncapableFix -> String
$cshow :: IncapableFix -> String
showsPrec :: Int -> IncapableFix -> ShowS
$cshowsPrec :: Int -> IncapableFix -> ShowS
Show, 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
$cto :: forall x. Rep IncapableFix x -> IncapableFix
$cfrom :: forall x. IncapableFix -> Rep IncapableFix x
Generic, Value -> Parser [IncapableFix]
Value -> Parser IncapableFix
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [IncapableFix]
$cparseJSONList :: Value -> Parser [IncapableFix]
parseJSON :: Value -> Parser IncapableFix
$cparseJSON :: Value -> Parser IncapableFix
FromJSON, [IncapableFix] -> Encoding
[IncapableFix] -> Value
IncapableFix -> Encoding
IncapableFix -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [IncapableFix] -> Encoding
$ctoEncodingList :: [IncapableFix] -> Encoding
toJSONList :: [IncapableFix] -> Value
$ctoJSONList :: [IncapableFix] -> Value
toEncoding :: IncapableFix -> Encoding
$ctoEncoding :: IncapableFix -> Encoding
toJSON :: IncapableFix -> Value
$ctoJSON :: IncapableFix -> Value
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
  | -- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exn -> Exn -> Bool
$c/= :: Exn -> Exn -> Bool
== :: Exn -> Exn -> Bool
$c== :: Exn -> Exn -> Bool
Eq, Int -> Exn -> ShowS
[Exn] -> ShowS
Exn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exn] -> ShowS
$cshowList :: [Exn] -> ShowS
show :: Exn -> String
$cshow :: Exn -> String
showsPrec :: Int -> Exn -> ShowS
$cshowsPrec :: Int -> Exn -> ShowS
Show, 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
$cto :: forall x. Rep Exn x -> Exn
$cfrom :: forall x. Exn -> Rep Exn x
Generic, Value -> Parser [Exn]
Value -> Parser Exn
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Exn]
$cparseJSONList :: Value -> Parser [Exn]
parseJSON :: Value -> Parser Exn
$cparseJSON :: Value -> Parser Exn
FromJSON, [Exn] -> Encoding
[Exn] -> Value
Exn -> Encoding
Exn -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Exn] -> Encoding
$ctoEncodingList :: [Exn] -> Encoding
toJSONList :: [Exn] -> Value
$ctoJSONList :: [Exn] -> Value
toEncoding :: Exn -> Encoding
$ctoEncoding :: Exn -> Encoding
toJSON :: Exn -> Value
$ctoJSON :: Exn -> Value
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: " forall a. Semigroup a => a -> a -> a
<> Text
t
      , Text
"Please report this as a bug at"
      , Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
swarmRepoUrl forall a. Semigroup a => a -> a -> a
<> Text
"issues/new>."
      ]
  Exn
InfiniteLoop -> Text
"Infinite loop detected!"
  (CmdFailed Const
c Text
t Maybe GameplayAchievement
_) -> [Text] -> Text
T.concat [forall a. PrettyPrec a => a -> Text
prettyText Const
c, Text
": ", Text
t]
  (User Text
t) -> Text
"Player exception: " 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

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

-- | Pretty-print an 'IncapableFix': either "equip" or "obtain".
formatIncapableFix :: IncapableFix -> Text
formatIncapableFix :: IncapableFix -> Text
formatIncapableFix = \case
  IncapableFix
FixByEquip -> Text
"equip"
  IncapableFix
FixByObtain -> Text
"obtain"

-- | 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.Game.Failure (LoadingFailure)
-- >>> :set -XTypeApplications
-- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty [CAppear]
-- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty [CAppear]
-- >>> 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 CAppear) (TConst Appear)
-- You do not have the devices required for:
--   'appear'
--   Please equip:
--   - the one ring or magic wand
--
-- >>> incapableError (R.singletonCap CRandom) (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 forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
caps =
      NonEmpty Text -> Text
unlinesExText forall a b. (a -> b) -> a -> b
$
        Text
"Thou shalt not utter such blasphemy:"
          forall a. a -> [a] -> NonEmpty a
:| [ Text -> Text
squote forall a b. (a -> b) -> a -> b
$ 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
capsNone) =
      NonEmpty Text -> Text
unlinesExText forall a b. (a -> b) -> a -> b
$
        Text
"Missing the " forall a. Semigroup a => a -> a -> a
<> Text
capMsg forall a. Semigroup a => a -> a -> a
<> Text
" for:"
          forall a. a -> [a] -> NonEmpty a
:| [ Text -> Text
squote forall a b. (a -> b) -> a -> b
$ forall a. PrettyPrec a => a -> Text
prettyText Term
tm
             , Text
"but no device yet provides it. See"
             , Text
swarmRepoUrl forall a. Semigroup a => a -> a -> a
<> Text
"issues/26"
             ]
  | Bool -> Bool
not (forall a. Set a -> Bool
S.null Set Capability
caps) =
      NonEmpty Text -> Text
unlinesExText
        ( Text
"You do not have the devices required for:"
            forall a. a -> [a] -> NonEmpty a
:| Text -> Text
squote (forall a. PrettyPrec a => a -> Text
prettyText Term
tm)
            forall a. a -> [a] -> [a]
: Text
"Please " forall a. Semigroup a => a -> a -> a
<> IncapableFix -> Text
formatIncapableFix IncapableFix
f forall a. Semigroup a => a -> a -> a
<> Text
":"
            forall a. a -> [a] -> [a]
: ((Text
"- " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entity] -> Text
formatDevices forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Entity]]
deviceSets)
        )
  | Bool
otherwise =
      NonEmpty Text -> Text
unlinesExText
        ( Text
"You are missing required inventory for:"
            forall a. a -> [a] -> NonEmpty a
:| Text -> Text
squote (forall a. PrettyPrec a => a -> Text
prettyText Term
tm)
            forall a. a -> [a] -> [a]
: Text
"Please obtain:"
            forall a. a -> [a] -> [a]
: ((Text
"- " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}.
(Eq a, Num a, Semigroup a, IsString a, From String a, Show a) =>
(a, a) -> a
formatEntity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.assocs Map Text Int
inv)
        )
 where
  capList :: [Capability]
capList = forall a. Set a -> [a]
S.toList Set Capability
caps
  deviceSets :: [[Entity]]
deviceSets = forall a b. (a -> b) -> [a] -> [b]
map (Capability -> EntityMap -> [Entity]
`deviceForCap` EntityMap
em) [Capability]
capList
  devicePerCap :: [(Capability, [Entity])]
devicePerCap = forall a b. [a] -> [b] -> [(a, b)]
zip [Capability]
capList [[Entity]]
deviceSets
  -- capabilities not provided by any device
  capsNone :: [Text]
capsNone = forall a b. (a -> b) -> [a] -> [b]
map (Capability -> Text
capabilityName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Capability, [Entity])]
devicePerCap
  capMsg :: Text
capMsg = case [Text]
capsNone of
    [Text
ca] -> Text
ca forall a. Semigroup a => a -> a -> a
<> Text
" capability"
    [Text]
cas -> Text
"capabilities " 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 " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)
  formatEntity :: (a, a) -> a
formatEntity (a
e, a
1) = a
e
  formatEntity (a
e, a
n) = a
e forall a. Semigroup a => a -> a -> a
<> a
" (" forall a. Semigroup a => a -> a -> a
<> forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show a
n) 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 forall a b. (a -> b) -> a -> b
$ (Text
t forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " forall a. Semigroup a => a -> a -> a
<>) [Text]
ts