{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Swarm.Game.Exception (
Exn (..),
IncapableFix (..),
formatExn,
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)
data IncapableFix
=
FixByInstall
|
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)
data Exn
=
Fatal Text
|
InfiniteLoop
|
Incapable IncapableFix Requirements Term
|
CmdFailed Const Text
|
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)
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
formatIncapableFix :: IncapableFix -> Text
formatIncapableFix :: IncapableFix -> Text
formatIncapableFix = \case
IncapableFix
FixByInstall -> Text
"install"
IncapableFix
FixByObtain -> Text
"obtain"
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
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
")"
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