{-# OPTIONS_HADDOCK hide #-}
module Graphics.WorldTurtle.Internal.Commands
( SeqC
, TurtleCommand (..)
, WorldCommand (..)
) where
import Control.Applicative
import Control.Monad
import Graphics.Gloss.Data.Picture (text)
import Graphics.WorldTurtle.Internal.Sequence
type SeqC a = SequenceCommand (AlmostVal ()) a
newtype TurtleCommand a = TurtleCommand
{
TurtleCommand a -> Turtle -> SeqC a
seqT :: Turtle -> SeqC a
}
instance Functor TurtleCommand where
fmap :: (a -> b) -> TurtleCommand a -> TurtleCommand b
fmap a -> b
f (TurtleCommand Turtle -> SeqC a
a) = (Turtle -> SeqC b) -> TurtleCommand b
forall a. (Turtle -> SeqC a) -> TurtleCommand a
TurtleCommand ((Turtle -> SeqC b) -> TurtleCommand b)
-> (Turtle -> SeqC b) -> TurtleCommand b
forall a b. (a -> b) -> a -> b
$ \ Turtle
t -> (a -> b) -> SeqC a -> SeqC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Turtle -> SeqC a
a Turtle
t)
instance Applicative TurtleCommand where
pure :: a -> TurtleCommand a
pure a
a = (Turtle -> SeqC a) -> TurtleCommand a
forall a. (Turtle -> SeqC a) -> TurtleCommand a
TurtleCommand ((Turtle -> SeqC a) -> TurtleCommand a)
-> (Turtle -> SeqC a) -> TurtleCommand a
forall a b. (a -> b) -> a -> b
$ \ Turtle
_ -> a -> SeqC a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
liftA2 :: (a -> b -> c)
-> TurtleCommand a -> TurtleCommand b -> TurtleCommand c
liftA2 a -> b -> c
f (TurtleCommand Turtle -> SeqC a
a) (TurtleCommand Turtle -> SeqC b
b) =
(Turtle -> SeqC c) -> TurtleCommand c
forall a. (Turtle -> SeqC a) -> TurtleCommand a
TurtleCommand ((Turtle -> SeqC c) -> TurtleCommand c)
-> (Turtle -> SeqC c) -> TurtleCommand c
forall a b. (a -> b) -> a -> b
$ \ Turtle
t -> (a -> b -> c) -> SeqC a -> SeqC b -> SeqC c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f (Turtle -> SeqC a
a Turtle
t) (Turtle -> SeqC b
b Turtle
t)
instance Monad TurtleCommand where
(TurtleCommand Turtle -> SeqC a
a) >>= :: TurtleCommand a -> (a -> TurtleCommand b) -> TurtleCommand b
>>= a -> TurtleCommand b
f = (Turtle -> SeqC b) -> TurtleCommand b
forall a. (Turtle -> SeqC a) -> TurtleCommand a
TurtleCommand ((Turtle -> SeqC b) -> TurtleCommand b)
-> (Turtle -> SeqC b) -> TurtleCommand b
forall a b. (a -> b) -> a -> b
$ \ Turtle
t -> Turtle -> SeqC a
a Turtle
t SeqC a -> (a -> SeqC b) -> SeqC b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
s -> TurtleCommand b -> Turtle -> SeqC b
forall a. TurtleCommand a -> Turtle -> SeqC a
seqT (a -> TurtleCommand b
f a
s) Turtle
t
instance MonadFail TurtleCommand where
fail :: String -> TurtleCommand a
fail String
t = (Turtle -> SeqC a) -> TurtleCommand a
forall a. (Turtle -> SeqC a) -> TurtleCommand a
TurtleCommand ((Turtle -> SeqC a) -> TurtleCommand a)
-> (Turtle -> SeqC a) -> TurtleCommand a
forall a b. (a -> b) -> a -> b
$ \ Turtle
_ -> do
Picture -> SequenceCommand (AlmostVal ()) ()
forall b. Picture -> SequenceCommand b ()
addPicture (Picture -> SequenceCommand (AlmostVal ()) ())
-> Picture -> SequenceCommand (AlmostVal ()) ()
forall a b. (a -> b) -> a -> b
$ String -> Picture
text String
t
SeqC a
forall b a. SequenceCommand b a
failSequence
newtype WorldCommand a = WorldCommand
{
WorldCommand a -> SeqC a
seqW :: SeqC a
}
instance Functor WorldCommand where
fmap :: (a -> b) -> WorldCommand a -> WorldCommand b
fmap a -> b
f (WorldCommand SeqC a
a) = SeqC b -> WorldCommand b
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC b -> WorldCommand b) -> SeqC b -> WorldCommand b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> SeqC a -> SeqC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f SeqC a
a
instance Applicative WorldCommand where
pure :: a -> WorldCommand a
pure a
a = SeqC a -> WorldCommand a
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC a -> WorldCommand a) -> SeqC a -> WorldCommand a
forall a b. (a -> b) -> a -> b
$ a -> SeqC a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
liftA2 :: (a -> b -> c) -> WorldCommand a -> WorldCommand b -> WorldCommand c
liftA2 a -> b -> c
f (WorldCommand SeqC a
a) (WorldCommand SeqC b
b) = SeqC c -> WorldCommand c
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC c -> WorldCommand c) -> SeqC c -> WorldCommand c
forall a b. (a -> b) -> a -> b
$ (a -> b -> c) -> SeqC a -> SeqC b -> SeqC c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f SeqC a
a SeqC b
b
instance Monad WorldCommand where
(WorldCommand SeqC a
a) >>= :: WorldCommand a -> (a -> WorldCommand b) -> WorldCommand b
>>= a -> WorldCommand b
f = SeqC b -> WorldCommand b
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC b -> WorldCommand b) -> SeqC b -> WorldCommand b
forall a b. (a -> b) -> a -> b
$ SeqC a
a SeqC a -> (a -> SeqC b) -> SeqC b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
s -> WorldCommand b -> SeqC b
forall a. WorldCommand a -> SeqC a
seqW (a -> WorldCommand b
f a
s)
instance Alternative WorldCommand where
empty :: WorldCommand a
empty = SeqC a -> WorldCommand a
forall a. SeqC a -> WorldCommand a
WorldCommand SeqC a
forall b a. SequenceCommand b a
failSequence
<|> :: WorldCommand a -> WorldCommand a -> WorldCommand a
(<|>) (WorldCommand SeqC a
a) (WorldCommand SeqC a
b) = SeqC a -> WorldCommand a
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC a -> WorldCommand a) -> SeqC a -> WorldCommand a
forall a b. (a -> b) -> a -> b
$ SeqC a -> SeqC a -> SeqC a
forall b a.
SequenceCommand b a -> SequenceCommand b a -> SequenceCommand b a
alternateSequence SeqC a
a SeqC a
b
instance Semigroup a => Semigroup (WorldCommand a) where
(WorldCommand SeqC a
a) <> :: WorldCommand a -> WorldCommand a -> WorldCommand a
<> (WorldCommand SeqC a
b) = SeqC a -> WorldCommand a
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC a -> WorldCommand a) -> SeqC a -> WorldCommand a
forall a b. (a -> b) -> a -> b
$ SeqC a -> SeqC a -> SeqC a
forall a b.
Semigroup a =>
SequenceCommand b a -> SequenceCommand b a -> SequenceCommand b a
combineSequence SeqC a
a SeqC a
b
instance MonadPlus WorldCommand
instance MonadFail WorldCommand where
fail :: String -> WorldCommand a
fail String
t = SeqC a -> WorldCommand a
forall a. SeqC a -> WorldCommand a
WorldCommand (SeqC a -> WorldCommand a) -> SeqC a -> WorldCommand a
forall a b. (a -> b) -> a -> b
$ do
Picture -> SequenceCommand (AlmostVal ()) ()
forall b. Picture -> SequenceCommand b ()
addPicture (Picture -> SequenceCommand (AlmostVal ()) ())
-> Picture -> SequenceCommand (AlmostVal ()) ()
forall a b. (a -> b) -> a -> b
$ String -> Picture
text String
t
SeqC a
forall b a. SequenceCommand b a
failSequence