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

-- |
-- Module      :  Swarm.Game.Exception
-- Copyright   :  Brent Yorgey
-- Maintainer  :  byorgey@gmail.com
--
-- 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.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.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 incapable error.
data IncapableFix
  = -- | Install the missing device on yourself/target
    FixByInstall
  | -- | 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.
    Incapable IncapableFix Requirements Term
  | -- | A command failed in some "normal" way (/e.g./ a 'Move'
    --   command could not move, or a 'Grab' command found nothing to
    --   grab, /etc./).
    CmdFailed Const Text
  | -- | The user program explicitly called 'Undefined' or 'Fail'.
    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
"<https://github.com/swarm-game/swarm/issues/new>."
      ]
  Exn
InfiniteLoop -> Text
"Infinite loop detected!"
  (CmdFailed Const
c Text
t) -> [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
-- ------------------------------------------------------------------

formatIncapableFix :: IncapableFix -> Text
formatIncapableFix :: IncapableFix -> Text
formatIncapableFix = \case
  IncapableFix
FixByInstall -> Text
"install"
  IncapableFix
FixByObtain -> Text
"obtain"

-- | Pretty print the incapable exception with an actionable suggestion
--   on how to fix it.
--
-- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" [] [] [CAppear]
-- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" [] [] [CAppear]
-- >>> m = buildEntityMap [w,r]
-- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByInstall 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 install:
--   - 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 =
    [Text] -> Text
unlinesExText
      [ Text
"Thou shalt not utter such blasphemy:"
      , 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) =
    [Text] -> Text
unlinesExText
      [ Text
"Missing the " forall a. Semigroup a => a -> a -> a
<> Text
capMsg forall a. Semigroup a => a -> a -> a
<> Text
" for:"
      , 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
"https://github.com/swarm-game/swarm/issues/26"
      ]
  | Bool -> Bool
not (forall a. Set a -> Bool
S.null Set Capability
caps) =
    [Text] -> Text
unlinesExText
      ( Text
"You do not have the devices required for:" forall a. a -> [a] -> [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 =
    [Text] -> Text
unlinesExText
      ( Text
"You are missing required inventory for:" forall a. a -> [a] -> [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 :: [Text] -> Text
unlinesExText :: [Text] -> Text
unlinesExText [Text]
ts = [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> a
head [Text]
ts forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Text]
ts