module Interface.TV.OFun (OX,OFun, wrapO) where
import Control.Category
import Prelude hiding ((.), id)
import Control.Arrow
import Control.Compose (ContraFunctor(..))
import Data.FunArr
import Control.Arrow.DeepArrow
import Interface.TV.Output
import Interface.TV.Input
type OX dom ran a b = Output dom ran a -> Output dom ran b
newtype OFun dom ran a b = OFun (OX dom ran a b)
instance Category (OFun dom ran) where
id = OFun id
OFun g . OFun f = OFun (g . f)
instance Arrow (OFun dom ran) where
arr = error "Interface.TV.OFun: no 'arr' method"
first (OFun f) = OFun (firstO f)
second (OFun f) = OFun (secondO f)
f &&& g = dupA >>> f *** g
instance DeepArrow (OFun dom ran) where
dupA = postFun "dup" dupO
fstA = postFun "first half" fstO
sndA = postFun "second half" sndO
funF = postFun "funF" funFO
funS = postFun "funS" funSO
funR = postFun "funR" funRO
swapA = postFun "swapped" swapO
curryA = postFun "curried" curryO
uncurryA = postFun "uncurried" uncurryO
result (OFun ox) = OFun (resultO ox)
instance FunArr (OFun dom ran) (Output dom ran) where
toArr ofun = OFun (applyO ofun)
OFun ox $$ o = ox o
retitle :: (String -> String) -> OX dom ran a b -> OX dom ran a b
retitle re ofun (OTitle str o) = OTitle (re str) (retitle re ofun o)
retitle _ ofun o = ofun o
posttitle :: String -> OX dom ran a b -> OX dom ran a b
posttitle post = retitle (++ (" -- " ++ post))
postFun :: String -> OX dom ran a b -> OFun dom ran a b
postFun post = OFun . posttitle post
resultO :: OX dom ran b b' -> OX dom ran (a->b) (a->b')
resultO ox ab = OLambda a (ox b)
where (a,b) = asOLambda ab
applyO :: Output dom ran (a->b) -> OX dom ran a b
applyO o = const b where (_,b) = asOLambda o
firstO :: OX dom ran a c -> OX dom ran (a,b) (c,b)
firstO f ab = OPair (f a) b where (a,b) = asOPair ab
secondO :: OX dom ran b c -> OX dom ran (a,b) (a,c)
secondO f ab = OPair a (f b) where (a,b) = asOPair ab
dupO :: OX dom ran a (a,a)
dupO a = OPair a a
fstO :: OX dom ran (a,b) a
fstO ab = a where (a,_) = asOPair ab
sndO :: OX dom ran (a,b) b
sndO ab = b where (_,b) = asOPair ab
funFO :: OX dom ran (c->a,b) (c->(a,b))
funFO gb = OLambda c (OPair a b)
where
(g,b) = asOPair gb
(c,a) = asOLambda g
funSO :: OX dom ran (a,c->b) (c->(a,b))
funSO ag = OLambda c (OPair a b)
where
(a,g) = asOPair ag
(c,b) = asOLambda g
funRO :: OX dom ran (a->b->c) (b->a->c)
funRO abc = OLambda b (OLambda a c)
where
(a,bc) = asOLambda abc
(b,c) = asOLambda bc
swapO :: OX dom ran (a,b) (b,a)
swapO ab = OPair b a where (a,b) = asOPair ab
curryO :: OX dom ran ((a,b)->c) (a->b->c)
curryO o = OLambda a (OLambda b c)
where (ab,c) = asOLambda o
(a ,b) = asIPair ab
uncurryO :: OX dom ran (a->b->c) ((a,b)->c)
uncurryO o = OLambda (IPair a b) c
where (a,bc) = asOLambda o
(b, c) = asOLambda bc
wrapO :: (Functor dom, ContraFunctor ran) =>
(b'->b) -> (a->a') -> OX dom ran (a->b) (a'->b')
wrapO outer inner ab = OLambda (fmap inner ia) (contraFmap outer ob)
where
(ia,ob) = asOLambda ab