module Data.Type.BitRecords.Builder.Holey where
import Control.Category
import Data.Monoid
import Prelude hiding (id, (.))
import Data.Tagged
newtype Holey m r a = HM {runHM :: (m -> r) -> a }
instance Monoid m => Category (Holey m) where
(.) (HM f) (HM g) = HM (\k -> (f (\m1 -> g (\m2 -> k (m1 <> m2)))))
id = HM ($ mempty)
instance Monoid m => Monoid (Holey m r r) where
mappend = (.)
mempty = id
hoistM :: (m -> n) -> Holey m a b -> Holey n a b
hoistM into (HM f) = HM (\k -> f (k . into))
hoistR :: (s -> r) -> Holey m r a -> Holey m s a
hoistR outof (HM f) = HM (\k -> f (outof . k))
immediate :: m -> Holey m r r
immediate m =
HM { runHM = ($ m) }
indirect :: (a -> m) -> Holey m r (a -> r)
indirect f =
HM { runHM = (. f) }
bind :: Holey m b c
-> (m -> Holey n a b)
-> Holey n a c
bind mbc fm = HM $ \ kna -> runHM mbc (($ kna) . runHM . fm)
applyHoley :: Holey m r (a -> b) -> a -> Holey m r b
applyHoley (HM !f) x = HM $ \k -> f k x
taggedHoley :: forall tag m r a x . Holey m r (a -> x) -> Holey m r (Tagged tag a -> x)
taggedHoley = mapHoley (\f -> f . untag)
mapHoley :: (a -> b) -> Holey m r a -> Holey m r b
mapHoley f (HM !h) = HM $ \k -> f (h k)
runHoley :: Holey m m a -> a
runHoley = ($ id) . runHM