module ConnectF where
import Fudgets(F,(>+<))

infixl :&:,>&<


--leaf :: (o->h)->F i o->(F i o,o->h,i->i)
tagF :: (o -> h) -> F i o -> TagF i o h ((->) i)
tagF o -> h
handler F i o
fud = F i o -> (o -> h) -> (i -> i) -> TagF i o h ((->) i)
forall i o h (t :: * -> *).
F i o -> (o -> h) -> t i -> TagF i o h t
TagF F i o
fud o -> h
handler i -> i
forall a. a -> a
id

--data TagF a b c = TagF a b c
data TagF i o h t = TagF (F i o) (o->h) (t i)
-- TagF makes the type more readable but also more restrictive...

TagF i o h f1
tf1 >&< :: TagF i o h f1
-> TagF b o h f2 -> TagF (Either i b) (Either o o) h (Tags f1 f2)
>&< TagF b o h f2
tf2 = (F i o -> F b o -> F (Either i b) (Either o o))
-> TagF i o h f1
-> TagF b o h f2
-> TagF (Either i b) (Either o o) h (Tags f1 f2)
forall (f2 :: * -> *) (f1 :: * -> *) i o b o h.
(Tag f2, Tag f1) =>
(F i o -> F b o -> F (Either i b) (Either o o))
-> TagF i o h f1
-> TagF b o h f2
-> TagF (Either i b) (Either o o) h (Tags f1 f2)
compTagF F i o -> F b o -> F (Either i b) (Either o o)
forall a b c d. F a b -> F c d -> F (Either a c) (Either b d)
(>+<) TagF i o h f1
tf1 TagF b o h f2
tf2

compTagF :: (F i o -> F b o -> F (Either i b) (Either o o))
-> TagF i o h f1
-> TagF b o h f2
-> TagF (Either i b) (Either o o) h (Tags f1 f2)
compTagF F i o -> F b o -> F (Either i b) (Either o o)
compF (TagF F i o
fud1 o -> h
get1 f1 i
tag1) (TagF F b o
fud2 o -> h
get2 f2 b
tag2) =
    F (Either i b) (Either o o)
-> (Either o o -> h)
-> Tags f1 f2 (Either i b)
-> TagF (Either i b) (Either o o) h (Tags f1 f2)
forall i o h (t :: * -> *).
F i o -> (o -> h) -> t i -> TagF i o h t
TagF (F i o -> F b o -> F (Either i b) (Either o o)
compF F i o
fud1 F b o
fud2) ((o -> h) -> (o -> h) -> Either o o -> h
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either o -> h
get1 o -> h
get2) (f1 (Either i b)
forall b. f1 (Either i b)
etag1 f1 (Either i b) -> f2 (Either i b) -> Tags f1 f2 (Either i b)
forall (f1 :: * -> *) (f2 :: * -> *) a.
f1 a -> f2 a -> Tags f1 f2 a
:&: f2 (Either i b)
forall a. f2 (Either a b)
etag2)
  where
    etag1 :: f1 (Either i b)
etag1 = (i -> Either i b) -> f1 i -> f1 (Either i b)
forall (f :: * -> *) b c. Tag f => (b -> c) -> f b -> f c
extend i -> Either i b
forall a b. a -> Either a b
Left f1 i
tag1
    etag2 :: f2 (Either a b)
etag2 = (b -> Either a b) -> f2 b -> f2 (Either a b)
forall (f :: * -> *) b c. Tag f => (b -> c) -> f b -> f c
extend b -> Either a b
forall a b. b -> Either a b
Right f2 b
tag2

mapTF :: (F i o -> F i o) -> TagF i o h t -> TagF i o h t
mapTF F i o -> F i o
f (TagF F i o
fud o -> h
get t i
tag) = F i o -> (o -> h) -> t i -> TagF i o h t
forall i o h (t :: * -> *).
F i o -> (o -> h) -> t i -> TagF i o h t
TagF (F i o -> F i o
f F i o
fud) o -> h
get t i
tag

ltr :: (b -> c)
-> TagF a o c f2
-> (F a o, Either o b -> c, Tags ((->) b) f2 (Either a b))
ltr b -> c
ih (TagF F a o
fud o -> c
get f2 a
tag) =
  (F a o
fud,(o -> c) -> (b -> c) -> Either o b -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either o -> c
get b -> c
ih,b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b)
-> f2 (Either a b) -> Tags ((->) b) f2 (Either a b)
forall (f1 :: * -> *) (f2 :: * -> *) a.
f1 a -> f2 a -> Tags f1 f2 a
:&: (a -> Either a b) -> f2 a -> f2 (Either a b)
forall (f :: * -> *) b c. Tag f => (b -> c) -> f b -> f c
extend a -> Either a b
forall a b. a -> Either a b
Left f2 a
tag)

class Tag f where
  extend :: (b->c) -> f b -> f c

data Tags f1 f2 a = (f1 a) :&: (f2 a)

instance Tag ((->) a) where
  extend :: (b -> c) -> (a -> b) -> a -> c
extend = (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

instance (Tag f1,Tag f2) => Tag (Tags f1 f2) where
  extend :: (b -> c) -> Tags f1 f2 b -> Tags f1 f2 c
extend b -> c
f (f1 b
g1:&:f2 b
g2) = (b -> c) -> f1 b -> f1 c
forall (f :: * -> *) b c. Tag f => (b -> c) -> f b -> f c
extend b -> c
f f1 b
g1f1 c -> f2 c -> Tags f1 f2 c
forall (f1 :: * -> *) (f2 :: * -> *) a.
f1 a -> f2 a -> Tags f1 f2 a
:&:(b -> c) -> f2 b -> f2 c
forall (f :: * -> *) b c. Tag f => (b -> c) -> f b -> f c
extend b -> c
f f2 b
g2

{-
newtype Selector d a = S (d a->Maybe a)

instance Tag (Selector d) where
  extend f 


f d1 d2 = (either d1 no,either no d2)
 :: (d1 a -> Maybe a) ->
    (d2 b -> Maybe b) ->
    (Either (d1 a) (d2 b)->Maybe a,Either (d1 a) (d2 b)->Maybe b)

a->Maybe b -> Either a c -> Maybe b
-}

no :: p -> Maybe a
no p
_ = Maybe a
forall a. Maybe a
Nothing
yes :: a -> Maybe a
yes a
s = a -> Maybe a
forall a. a -> Maybe a
Just a
s
left :: (a -> Maybe a) -> Either a p -> Maybe a
left a -> Maybe a
f = (a -> Maybe a) -> (p -> Maybe a) -> Either a p -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Maybe a
f p -> Maybe a
forall p a. p -> Maybe a
no
right :: (b -> Maybe a) -> Either p b -> Maybe a
right = (p -> Maybe a) -> (b -> Maybe a) -> Either p b -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either p -> Maybe a
forall p a. p -> Maybe a
no
leftleft :: (a -> Maybe a) -> Either (Either a p) p -> Maybe a
leftleft = (Either a p -> Maybe a) -> Either (Either a p) p -> Maybe a
forall a a p. (a -> Maybe a) -> Either a p -> Maybe a
left ((Either a p -> Maybe a) -> Either (Either a p) p -> Maybe a)
-> ((a -> Maybe a) -> Either a p -> Maybe a)
-> (a -> Maybe a)
-> Either (Either a p) p
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> Either a p -> Maybe a
forall a a p. (a -> Maybe a) -> Either a p -> Maybe a
left
leftyes :: Either a p -> Maybe a
leftyes = (a -> Maybe a) -> Either a p -> Maybe a
forall a a p. (a -> Maybe a) -> Either a p -> Maybe a
left a -> Maybe a
forall a. a -> Maybe a
yes