-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Auto-generation of command attributes matrix.
module Swarm.Doc.Command where

import Data.Aeson (ToJSON)
import Data.List.Extra (enumerate)
import Data.List.NonEmpty qualified as NE
import Data.Set (Set)
import Data.Set qualified as Set
import GHC.Generics (Generic)
import Servant.Docs qualified as SD
import Swarm.Doc.Util
import Swarm.Language.Syntax
import Swarm.Language.Syntax.CommandMetadata
import Swarm.Language.Typecheck (inferConst)
import Swarm.Language.Types

data DerivedAttrs = DerivedAttrs
  { DerivedAttrs -> Bool
hasActorTarget :: Bool
  , DerivedAttrs -> Bool
pureComputation :: Bool
  , DerivedAttrs -> Bool
modifiesEnvironment :: Bool
  , DerivedAttrs -> Bool
modifiesRobot :: Bool
  , DerivedAttrs -> Bool
movesRobot :: Bool
  , DerivedAttrs -> Bool
returnsValue :: Bool
  , DerivedAttrs -> String
outputType :: String
  }
  deriving ((forall x. DerivedAttrs -> Rep DerivedAttrs x)
-> (forall x. Rep DerivedAttrs x -> DerivedAttrs)
-> Generic DerivedAttrs
forall x. Rep DerivedAttrs x -> DerivedAttrs
forall x. DerivedAttrs -> Rep DerivedAttrs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DerivedAttrs -> Rep DerivedAttrs x
from :: forall x. DerivedAttrs -> Rep DerivedAttrs x
$cto :: forall x. Rep DerivedAttrs x -> DerivedAttrs
to :: forall x. Rep DerivedAttrs x -> DerivedAttrs
Generic, [DerivedAttrs] -> Value
[DerivedAttrs] -> Encoding
DerivedAttrs -> Bool
DerivedAttrs -> Value
DerivedAttrs -> Encoding
(DerivedAttrs -> Value)
-> (DerivedAttrs -> Encoding)
-> ([DerivedAttrs] -> Value)
-> ([DerivedAttrs] -> Encoding)
-> (DerivedAttrs -> Bool)
-> ToJSON DerivedAttrs
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DerivedAttrs -> Value
toJSON :: DerivedAttrs -> Value
$ctoEncoding :: DerivedAttrs -> Encoding
toEncoding :: DerivedAttrs -> Encoding
$ctoJSONList :: [DerivedAttrs] -> Value
toJSONList :: [DerivedAttrs] -> Value
$ctoEncodingList :: [DerivedAttrs] -> Encoding
toEncodingList :: [DerivedAttrs] -> Encoding
$comitField :: DerivedAttrs -> Bool
omitField :: DerivedAttrs -> Bool
ToJSON)

data CommandEntry = CommandEntry
  { CommandEntry -> Const
cmd :: Const
  , CommandEntry -> Set CommandEffect
effects :: Set CommandEffect
  , CommandEntry -> NonEmpty Type
argTypes :: NE.NonEmpty Type
  , CommandEntry -> DerivedAttrs
derivedAttrs :: DerivedAttrs
  }
  deriving ((forall x. CommandEntry -> Rep CommandEntry x)
-> (forall x. Rep CommandEntry x -> CommandEntry)
-> Generic CommandEntry
forall x. Rep CommandEntry x -> CommandEntry
forall x. CommandEntry -> Rep CommandEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommandEntry -> Rep CommandEntry x
from :: forall x. CommandEntry -> Rep CommandEntry x
$cto :: forall x. Rep CommandEntry x -> CommandEntry
to :: forall x. Rep CommandEntry x -> CommandEntry
Generic, [CommandEntry] -> Value
[CommandEntry] -> Encoding
CommandEntry -> Bool
CommandEntry -> Value
CommandEntry -> Encoding
(CommandEntry -> Value)
-> (CommandEntry -> Encoding)
-> ([CommandEntry] -> Value)
-> ([CommandEntry] -> Encoding)
-> (CommandEntry -> Bool)
-> ToJSON CommandEntry
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CommandEntry -> Value
toJSON :: CommandEntry -> Value
$ctoEncoding :: CommandEntry -> Encoding
toEncoding :: CommandEntry -> Encoding
$ctoJSONList :: [CommandEntry] -> Value
toJSONList :: [CommandEntry] -> Value
$ctoEncodingList :: [CommandEntry] -> Encoding
toEncodingList :: [CommandEntry] -> Encoding
$comitField :: CommandEntry -> Bool
omitField :: CommandEntry -> Bool
ToJSON)

newtype CommandCatalog = CommandCatalog
  { CommandCatalog -> [CommandEntry]
entries :: [CommandEntry]
  }
  deriving ((forall x. CommandCatalog -> Rep CommandCatalog x)
-> (forall x. Rep CommandCatalog x -> CommandCatalog)
-> Generic CommandCatalog
forall x. Rep CommandCatalog x -> CommandCatalog
forall x. CommandCatalog -> Rep CommandCatalog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommandCatalog -> Rep CommandCatalog x
from :: forall x. CommandCatalog -> Rep CommandCatalog x
$cto :: forall x. Rep CommandCatalog x -> CommandCatalog
to :: forall x. Rep CommandCatalog x -> CommandCatalog
Generic, [CommandCatalog] -> Value
[CommandCatalog] -> Encoding
CommandCatalog -> Bool
CommandCatalog -> Value
CommandCatalog -> Encoding
(CommandCatalog -> Value)
-> (CommandCatalog -> Encoding)
-> ([CommandCatalog] -> Value)
-> ([CommandCatalog] -> Encoding)
-> (CommandCatalog -> Bool)
-> ToJSON CommandCatalog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CommandCatalog -> Value
toJSON :: CommandCatalog -> Value
$ctoEncoding :: CommandCatalog -> Encoding
toEncoding :: CommandCatalog -> Encoding
$ctoJSONList :: [CommandCatalog] -> Value
toJSONList :: [CommandCatalog] -> Value
$ctoEncodingList :: [CommandCatalog] -> Encoding
toEncodingList :: [CommandCatalog] -> Encoding
$comitField :: CommandCatalog -> Bool
omitField :: CommandCatalog -> Bool
ToJSON)

instance SD.ToSample CommandCatalog where
  toSamples :: Proxy CommandCatalog -> [(Text, CommandCatalog)]
toSamples Proxy CommandCatalog
_ = [(Text, CommandCatalog)]
forall a. [(Text, a)]
SD.noSamples

-- | Uses explicit effects documentation as well as
-- type signature information to compute various flags
mkEntry :: Const -> CommandEntry
mkEntry :: Const -> CommandEntry
mkEntry Const
c =
  Const
-> Set CommandEffect
-> NonEmpty Type
-> DerivedAttrs
-> CommandEntry
CommandEntry Const
c Set CommandEffect
cmdEffects NonEmpty Type
rawArgs (DerivedAttrs -> CommandEntry) -> DerivedAttrs -> CommandEntry
forall a b. (a -> b) -> a -> b
$
    DerivedAttrs
      { hasActorTarget :: Bool
hasActorTarget = [Type] -> Bool
operatesOnActor [Type]
inputArgs
      , pureComputation :: Bool
pureComputation = Set CommandEffect -> Bool
forall a. Set a -> Bool
Set.null Set CommandEffect
cmdEffects
      , modifiesEnvironment :: Bool
modifiesEnvironment = MutationType -> CommandEffect
Mutation MutationType
EntityChange CommandEffect -> Set CommandEffect -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CommandEffect
cmdEffects
      , modifiesRobot :: Bool
modifiesRobot = Bool -> Bool
not (Bool -> Bool)
-> ([CommandEffect] -> Bool) -> [CommandEffect] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set CommandEffect -> Set CommandEffect -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set CommandEffect
cmdEffects (Set CommandEffect -> Bool)
-> ([CommandEffect] -> Set CommandEffect)
-> [CommandEffect]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandEffect] -> Set CommandEffect
forall a. Ord a => [a] -> Set a
Set.fromList ([CommandEffect] -> Bool) -> [CommandEffect] -> Bool
forall a b. (a -> b) -> a -> b
$ (RobotChangeType -> CommandEffect)
-> [RobotChangeType] -> [CommandEffect]
forall a b. (a -> b) -> [a] -> [b]
map (MutationType -> CommandEffect
Mutation (MutationType -> CommandEffect)
-> (RobotChangeType -> MutationType)
-> RobotChangeType
-> CommandEffect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RobotChangeType -> MutationType
RobotChange) [RobotChangeType]
forall a. (Enum a, Bounded a) => [a]
enumerate
      , movesRobot :: Bool
movesRobot = MutationType -> CommandEffect
Mutation (RobotChangeType -> MutationType
RobotChange RobotChangeType
PositionChange) CommandEffect -> Set CommandEffect -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CommandEffect
cmdEffects
      , returnsValue :: Bool
returnsValue = Type
theOutputType Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type -> Type
TyCmd Type
TyUnit
      , outputType :: String
outputType = Type -> String
forall a. Show a => a -> String
show Type
theOutputType
      }
 where
  cmdInfo :: ConstInfo
cmdInfo = Const -> ConstInfo
constInfo Const
c
  cmdEffects :: Set CommandEffect
cmdEffects = ConstDoc -> Set CommandEffect
effectInfo (ConstDoc -> Set CommandEffect) -> ConstDoc -> Set CommandEffect
forall a b. (a -> b) -> a -> b
$ ConstInfo -> ConstDoc
constDoc ConstInfo
cmdInfo

  getArgs :: Poly q Type -> NonEmpty Type
getArgs = Type -> NonEmpty Type
forall t. UnchainableFun t => t -> NonEmpty t
unchainFun (Type -> NonEmpty Type)
-> (Poly q Type -> Type) -> Poly q Type -> NonEmpty Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poly q Type -> Type
forall (q :: ImplicitQuantification) t. Poly q t -> t
ptBody

  rawArgs :: NonEmpty Type
rawArgs = Poly 'Quantified Type -> NonEmpty Type
forall {q :: ImplicitQuantification}. Poly q Type -> NonEmpty Type
getArgs (Poly 'Quantified Type -> NonEmpty Type)
-> Poly 'Quantified Type -> NonEmpty Type
forall a b. (a -> b) -> a -> b
$ Const -> Poly 'Quantified Type
inferConst Const
c

  inputArgs :: [Type]
inputArgs = NonEmpty Type -> [Type]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Type
rawArgs
  theOutputType :: Type
theOutputType = NonEmpty Type -> Type
forall a. NonEmpty a -> a
NE.last NonEmpty Type
rawArgs

  operatesOnActor :: [Type] -> Bool
operatesOnActor = Type -> [Type] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
TyActor

getCatalog :: CommandCatalog
getCatalog :: CommandCatalog
getCatalog = [CommandEntry] -> CommandCatalog
CommandCatalog ([CommandEntry] -> CommandCatalog)
-> [CommandEntry] -> CommandCatalog
forall a b. (a -> b) -> a -> b
$ (Const -> CommandEntry) -> [Const] -> [CommandEntry]
forall a b. (a -> b) -> [a] -> [b]
map Const -> CommandEntry
mkEntry [Const]
commands