{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Conversions from native Haskell values
-- to values in the swarm language.
module Swarm.Game.Value where

import Control.Lens (view)
import Data.Either.Extra (maybeToEither)
import Data.Int (Int32)
import Data.List (uncons)
import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import Linear (V2 (..))
import Swarm.Game.Entity
import Swarm.Game.Location
import Swarm.Game.Robot
import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
import Swarm.Game.Universe
import Swarm.Language.Syntax.Direction
import Swarm.Language.Value

-- * Patterns

type VRect = Value
pattern VRect :: Integer -> Integer -> Integer -> Integer -> VRect
pattern $mVRect :: forall {r}.
VRect
-> (Integer -> Integer -> Integer -> Integer -> r)
-> ((# #) -> r)
-> r
$bVRect :: Integer -> Integer -> Integer -> Integer -> VRect
VRect x1 y1 x2 y2 = VPair (VPair (VInt x1) (VInt y1)) (VPair (VInt x2) (VInt y2))

-- * Conversions

-- | Conversion from native Haskell types
-- to their swarm-lang equivalents, useful for
-- implementing swarm
-- <https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet commands>
-- in Haskell.
class Valuable a where
  asValue :: a -> Value

instance Valuable Value where
  asValue :: VRect -> VRect
asValue = VRect -> VRect
forall a. a -> a
id

instance Valuable Int32 where
  asValue :: Int32 -> VRect
asValue = Integer -> VRect
VInt (Integer -> VRect) -> (Int32 -> Integer) -> Int32 -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Valuable Int where
  asValue :: Int -> VRect
asValue = Integer -> VRect
VInt (Integer -> VRect) -> (Int -> Integer) -> Int -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Valuable Integer where
  asValue :: Integer -> VRect
asValue = Integer -> VRect
VInt

instance Valuable Bool where
  asValue :: Bool -> VRect
asValue = Bool -> VRect
VBool

instance Valuable Text where
  asValue :: Text -> VRect
asValue = Text -> VRect
VText

instance Valuable SubworldName where
  asValue :: SubworldName -> VRect
asValue = Text -> VRect
forall a. Valuable a => a -> VRect
asValue (Text -> VRect) -> (SubworldName -> Text) -> SubworldName -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubworldName -> Text
renderWorldName

instance Valuable () where
  asValue :: () -> VRect
asValue = VRect -> () -> VRect
forall a b. a -> b -> a
const VRect
VUnit

instance (Valuable a) => Valuable (V2 a) where
  asValue :: V2 a -> VRect
asValue (V2 a
x a
y) = (a, a) -> VRect
forall a. Valuable a => a -> VRect
asValue (a
x, a
y)

instance (Valuable a, Valuable b) => Valuable (a, b) where
  asValue :: (a, b) -> VRect
asValue (a
x, b
y) = VRect -> VRect -> VRect
VPair (a -> VRect
forall a. Valuable a => a -> VRect
asValue a
x) (b -> VRect
forall a. Valuable a => a -> VRect
asValue b
y)

instance Valuable Location where
  asValue :: Location -> VRect
asValue (Location Int32
x Int32
y) = (Int32, Int32) -> VRect
forall a. Valuable a => a -> VRect
asValue (Int32
x, Int32
y)

instance Valuable Entity where
  asValue :: Entity -> VRect
asValue = Text -> VRect
VText (Text -> VRect) -> (Entity -> Text) -> Entity -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Entity Text -> Entity -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Entity Text
Lens' Entity Text
entityName

instance Valuable Robot where
  asValue :: Robot -> VRect
asValue = Int -> VRect
VRobot (Int -> VRect) -> (Robot -> Int) -> Robot -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Int Robot Int -> Robot -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int Robot Int
Getter Robot Int
robotID

instance Valuable Direction where
  asValue :: Direction -> VRect
asValue = Direction -> VRect
VDir

instance (Valuable a) => Valuable (Maybe a) where
  asValue :: Maybe a -> VRect
asValue = Either () a -> VRect
forall a. Valuable a => a -> VRect
asValue (Either () a -> VRect)
-> (Maybe a -> Either () a) -> Maybe a -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Maybe a -> Either () a
forall a b. a -> Maybe b -> Either a b
maybeToEither ()

instance (Valuable a, Valuable b) => Valuable (Either a b) where
  asValue :: Either a b -> VRect
asValue (Left a
x) = Bool -> VRect -> VRect
VInj Bool
False (VRect -> VRect) -> VRect -> VRect
forall a b. (a -> b) -> a -> b
$ a -> VRect
forall a. Valuable a => a -> VRect
asValue a
x
  asValue (Right b
x) = Bool -> VRect -> VRect
VInj Bool
True (VRect -> VRect) -> VRect -> VRect
forall a b. (a -> b) -> a -> b
$ b -> VRect
forall a. Valuable a => a -> VRect
asValue b
x

instance Valuable a => Valuable [a] where
  asValue :: [a] -> VRect
asValue = Maybe (a, [a]) -> VRect
forall a. Valuable a => a -> VRect
asValue (Maybe (a, [a]) -> VRect)
-> ([a] -> Maybe (a, [a])) -> [a] -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
uncons

instance Valuable a => Valuable (NE.NonEmpty a) where
  asValue :: NonEmpty a -> VRect
asValue = [a] -> VRect
forall a. Valuable a => a -> VRect
asValue ([a] -> VRect) -> (NonEmpty a -> [a]) -> NonEmpty a -> VRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList

instance Valuable AreaDimensions where
  asValue :: AreaDimensions -> VRect
asValue (AreaDimensions Int32
w Int32
h) = (Int32, Int32) -> VRect
forall a. Valuable a => a -> VRect
asValue (Int32
w, Int32
h)