generated from tpl/purs
71 lines
1.9 KiB
Plaintext
71 lines
1.9 KiB
Plaintext
module Test.Mujoco.MJCF.Util where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad.Error.Class (class MonadError, class MonadThrow, try)
|
|
import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, local, runReaderT)
|
|
import Data.Either (isLeft)
|
|
import Data.Identity (Identity)
|
|
import Data.Newtype (class Newtype, unwrap)
|
|
import Effect.Aff (Aff)
|
|
import Effect.Aff.Class (class MonadAff)
|
|
import Effect.Class (class MonadEffect, liftEffect)
|
|
import Effect.Console as Console
|
|
import Effect.Exception (Error)
|
|
import Mujoco.MJCF as X
|
|
import Mujoco.MJCF.XML (Node)
|
|
import Mujoco.MJCF.XML as XML
|
|
import Mujoco.Wasm (Mujoco)
|
|
import Mujoco.Wasm as Mj
|
|
import Test.Assert (assertTrue)
|
|
import Test.Spec (SpecT, Spec, hoistSpec)
|
|
|
|
type T' = { mj :: Mujoco, dbg :: Boolean }
|
|
newtype T a = T (ReaderT T' Aff a)
|
|
|
|
derive instance Newtype (T a) _
|
|
derive newtype instance Functor T
|
|
derive newtype instance Applicative T
|
|
derive newtype instance Apply T
|
|
derive newtype instance Bind T
|
|
derive newtype instance Monad T
|
|
derive newtype instance MonadReader T' T
|
|
derive newtype instance MonadAsk T' T
|
|
derive newtype instance MonadEffect T
|
|
derive newtype instance MonadAff T
|
|
derive newtype instance MonadThrow Error T
|
|
derive newtype instance MonadError Error T
|
|
|
|
type MjcfSpec a = SpecT T Unit Identity a
|
|
|
|
mjcf :: forall a. Mujoco -> MjcfSpec a -> Spec a
|
|
mjcf mj = hoistSpec identity (\_ -> runT mj)
|
|
|
|
runT :: forall a. Mujoco -> T a -> Aff a
|
|
runT mj m = runReaderT (unwrap m) { mj, dbg: false }
|
|
|
|
dbg :: forall a. T a -> T a
|
|
dbg = local (_ { dbg = true })
|
|
|
|
renderSpec :: XML.Node -> T Mj.Spec
|
|
renderSpec node = do
|
|
{ mj, dbg: dbg' } <- ask
|
|
let
|
|
xml = XML.render node
|
|
|
|
when dbg'
|
|
$ liftEffect
|
|
$ Console.log
|
|
$ xml
|
|
|
|
liftEffect $ Mj.parseXMLString mj xml
|
|
|
|
parseOk :: XML.Node -> T Unit
|
|
parseOk = void <<< renderSpec
|
|
|
|
parseFail :: XML.Node -> T Unit
|
|
parseFail = (liftEffect <<< assertTrue <<< isLeft) <=< (try <<< renderSpec)
|
|
|
|
w :: forall a. XML.Children a => a -> Node
|
|
w = X.mujoco {} <<< X.worldbody {}
|