module Wumpus.Basic.Kernel.Base.ContextFun
(
CF
, Query
, runCF
, consCF
, domMap1
, domMap2
, promoteR1
, promoteR2
, pushR0
, pushR1
, pushR2
, apply1R1
, apply1R2
, apply2R2
, lift0R1
, lift0R2
, lift1R2
, uconvR0
, uconvR1
, uconvR2a
, uconvR2ab
, drawingCtx
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Core
import Control.Applicative
import Data.Monoid
newtype CF a = CF { getCF :: DrawingContext -> a }
type instance DUnit (CF a) = DUnit a
type Query a = CF a
instance OPlus a => OPlus (CF a) where
fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx
instance Monoid a => Monoid (CF a) where
mempty = CF $ \_ -> mempty
fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx
instance Functor CF where
fmap f ma = CF $ \ctx -> f $ getCF ma ctx
instance Applicative CF where
pure a = CF $ \_ -> a
mf <*> ma = CF $ \ctx -> let f = getCF mf ctx
a = getCF ma ctx
in f a
instance Monad CF where
return a = CF $ \_ -> a
ma >>= k = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx
instance DrawingCtxM CF where
askDC = CF $ \ctx -> ctx
localize upd df = CF $ \ctx -> getCF df (upd ctx)
instance Rotate a => Rotate (CF a) where
rotate ang = fmap (rotate ang)
instance RotateAbout a => RotateAbout (CF a) where
rotateAbout ang pt = fmap (rotateAbout ang pt)
instance Scale a => Scale (CF a) where
scale sx sy = fmap (scale sx sy)
instance Translate a => Translate (CF a) where
translate dx dy = fmap (translate dx dy)
runCF :: DrawingContext -> CF a -> a
runCF ctx cf = getCF cf ctx
consCF :: (DrawingContext -> a) -> CF a
consCF fn = CF $ \ctx -> fn ctx
domMap1 :: (r1 -> r1) -> CF (r1 -> a) -> CF (r1 -> a)
domMap1 f ma = CF $ \ctx ->
(\r1 -> let f1 = getCF ma ctx in f1 (f r1))
domMap2 :: (r1 -> r1) -> (r2 -> r2) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a)
domMap2 f g ma = CF $ \ctx ->
(\r1 r2 -> let f1 = getCF ma ctx in f1 (f r1) (g r2))
promoteR1 :: (r1 -> CF a) -> CF (r1 -> a)
promoteR1 mf = CF $ \ctx r1 -> getCF (mf r1) ctx
promoteR2 :: (r1 -> r2 -> CF a) -> CF (r1 -> r2 -> a)
promoteR2 mf = CF $ \ctx r1 r2 -> getCF (mf r1 r2) ctx
pushR0 :: (a -> a1) -> CF a -> CF a1
pushR0 = fmap
pushR1 :: (a -> a1) -> CF (r1 -> a) -> CF (r1 -> a1)
pushR1 = fmap . fmap
pushR2 :: (a -> a1) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a1)
pushR2 = fmap . fmap . fmap
apply1R1 :: CF (r1 -> a) -> r1 -> CF a
apply1R1 mf r1 = CF $ \ctx -> getCF mf ctx r1
apply1R2 :: CF (r1 -> r2 -> a) -> r2 -> CF (r1 -> a)
apply1R2 mf r2 = CF $ \ctx r1 -> getCF mf ctx r1 r2
apply2R2 :: CF (r1 -> r2 -> a) -> r1 -> r2 -> CF a
apply2R2 mf r1 r2 = CF $ \ctx -> getCF mf ctx r1 r2
lift0R1 :: CF a -> CF (r1 -> a)
lift0R1 mf = CF $ \ctx _ -> getCF mf ctx
lift0R2 :: CF a -> CF (r1 -> r2 -> a)
lift0R2 mf = CF $ \ctx _ _ -> getCF mf ctx
lift1R2 :: CF (r1 -> a) -> CF (r1 -> r2 -> a)
lift1R2 mf = CF $ \ctx r1 _ -> getCF mf ctx r1
uconvR0 :: (FontSize -> ans -> ans1) -> CF ans -> CF ans1
uconvR0 post df = CF $ \ctx ->
let sz = dc_font_size ctx
in post sz $ getCF df ctx
uconvR1 :: (Functor t, InterpretUnit u, InterpretUnit u1)
=> (FontSize -> ans -> ans1)
-> CF (t u -> ans) -> CF (t u1 -> ans1)
uconvR1 post df = CF $ \ctx r1 ->
let sz = dc_font_size ctx
in post sz $ getCF df ctx (uconvertF sz r1)
uconvR2a :: (Functor t, InterpretUnit u, InterpretUnit u1)
=> (FontSize -> ans -> ans1)
-> CF (t u -> r2 -> ans) -> CF (t u1 -> r2 -> ans1)
uconvR2a post df = CF $ \ctx r1 r2 ->
let sz = dc_font_size ctx
in post sz $ getCF df ctx (uconvertF sz r1) r2
uconvR2ab :: (Functor t1, Functor t2, InterpretUnit u, InterpretUnit u1)
=> (FontSize -> ans -> ans1)
-> CF (t1 u -> t2 u -> ans) -> CF (t1 u1 -> t2 u1 -> ans1)
uconvR2ab post df = CF $ \ctx r1 r2 ->
let sz = dc_font_size ctx
in post sz $ getCF df ctx (uconvertF sz r1) (uconvertF sz r2)
drawingCtx :: Query DrawingContext
drawingCtx = CF $ \ctx -> ctx