module Wumpus.Basic.Monads.DrawingCtxMonad
(
DrawingCtx
, DrawingCtxT
, runDrawingCtx
, runDrawingCtxT
) where
import Wumpus.Basic.Monads.DrawingCtxClass
import Wumpus.Basic.Monads.TraceClass
import Wumpus.Basic.Monads.TurtleClass
import MonadLib ( MonadT(..) )
import Control.Applicative
import Control.Monad
newtype DrawingCtx a = DrawingCtx { getDrawingCtx :: DrawingAttr -> a }
newtype DrawingCtxT m a = DrawingCtxT { getDrawingCtxT :: DrawingAttr -> m a }
instance Functor DrawingCtx where
fmap f m = DrawingCtx $ \r -> let a = getDrawingCtx m r in f a
instance Monad m => Functor (DrawingCtxT m) where
fmap f m = DrawingCtxT $ \r -> getDrawingCtxT m r >>= \a ->
return (f a)
instance Applicative DrawingCtx where
pure a = DrawingCtx $ \_ -> a
mf <*> ma = DrawingCtx $ \r -> let f = getDrawingCtx mf r
a = getDrawingCtx ma r
in f a
instance Monad m => Applicative (DrawingCtxT m) where
pure a = DrawingCtxT $ \_ -> return a
mf <*> ma = DrawingCtxT $ \r -> getDrawingCtxT mf r >>= \f ->
getDrawingCtxT ma r >>= \a ->
return (f a)
instance Monad DrawingCtx where
return a = DrawingCtx $ \_ -> a
m >>= k = DrawingCtx $ \r -> let a = getDrawingCtx m r
in (getDrawingCtx . k) a r
instance Monad m => Monad (DrawingCtxT m) where
return a = DrawingCtxT $ \_ -> return a
m >>= k = DrawingCtxT $ \r -> getDrawingCtxT m r >>= \a ->
(getDrawingCtxT . k) a r
instance MonadT DrawingCtxT where
lift m = DrawingCtxT $ \_ -> m >>= \a -> return a
instance DrawingCtxM DrawingCtx where
askDrawingCtx = DrawingCtx id
localCtx ctx ma = DrawingCtx $ \_ -> getDrawingCtx ma ctx
instance Monad m => DrawingCtxM (DrawingCtxT m) where
askDrawingCtx = DrawingCtxT return
localCtx ctx ma = DrawingCtxT $ \_ -> getDrawingCtxT ma ctx
runDrawingCtx :: DrawingAttr -> DrawingCtx a -> a
runDrawingCtx cfg mf = getDrawingCtx mf cfg
runDrawingCtxT :: Monad m => DrawingAttr -> DrawingCtxT m a -> m a
runDrawingCtxT cfg mf = getDrawingCtxT mf cfg
instance (Monad m, TraceM m i) => TraceM (DrawingCtxT m) i where
trace a = DrawingCtxT $ \_ -> trace a
trace1 a = DrawingCtxT $ \_ -> trace1 a
instance TurtleM m => TurtleM (DrawingCtxT m) where
getLoc = DrawingCtxT $ \_ -> getLoc
setLoc c = DrawingCtxT $ \_ -> setLoc c
getOrigin = DrawingCtxT $ \_ -> getOrigin
setOrigin o = DrawingCtxT $ \_ -> setOrigin o
instance TurtleScaleM m u => TurtleScaleM (DrawingCtxT m) u where
xStep = DrawingCtxT $ \_ -> xStep
yStep = DrawingCtxT $ \_ -> yStep