module HyperGraphicsF where
--import Fudget
--import Defaults(paperColor)
--import InputMsg(inputDone)
import Utils(swap)
--import Xtypes(ColorName)
import Loops(loopThroughRightF)
import SerCompF(mapstateF)
--import Graphic
import Drawing
import DrawingOps
import GraphicsF
import FDefaults
import HbcUtils(assoc)
import Sizing(Sizing(..))
--import GCAttrs() -- instances
import Event(Pressed(..))
--import Maptrace(ctrace) -- debugging
--import SpyF(teeF) -- debugging
--import CompOps((>==<)) -- debugging

hyperGraphicsF :: Drawing d leaf -> F (Either (Drawing d leaf) (d, Drawing d leaf)) d
hyperGraphicsF Drawing d leaf
x = forall {d} {leaf}.
(Eq d, Graphic leaf) =>
(GraphicsF (Drawing d leaf) -> GraphicsF (Drawing d leaf))
-> Drawing d leaf
-> F (Either (Drawing d leaf) (d, Drawing d leaf)) d
hyperGraphicsF' forall a. Customiser a
standard Drawing d leaf
x

{-
hyperGraphicsF' :: (Eq annot,Graphic g) =>
                  Customiser (GraphicsF (Drawing annot g)) ->
                  Drawing annot g ->
		  F (Either (Drawing annot g) (annot,Drawing annot g))
		    annot
-}
hyperGraphicsF' :: (GraphicsF (Drawing d leaf) -> GraphicsF (Drawing d leaf))
-> Drawing d leaf
-> F (Either (Drawing d leaf) (d, Drawing d leaf)) d
hyperGraphicsF' GraphicsF (Drawing d leaf) -> GraphicsF (Drawing d leaf)
custom Drawing d leaf
init =
    forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d
loopThroughRightF
	(forall {t} {a} {b}. (t -> a -> (t, [b])) -> t -> F a b
mapstateF forall {lbl} {leaf}.
Eq lbl =>
([(lbl, DPath)], Drawing lbl leaf)
-> Either
     (GfxEvent DPath)
     (Either (Drawing lbl leaf) (lbl, Drawing lbl leaf))
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) lbl])
ctrl ([(d, DPath)], Drawing d leaf)
state0)
	({-teeF show "\n" >==<-} forall gfx.
Graphic gfx =>
Customiser (GraphicsF gfx) -> F (GfxFCmd gfx) (GfxEvent DPath)
graphicsDispF' (GraphicsF (Drawing d leaf) -> GraphicsF (Drawing d leaf)
custom forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphicsF (Drawing d leaf) -> GraphicsF (Drawing d leaf)
params))
  where
    --tr x = ctrace "hyper" (show x) x -- debugging
    params :: GraphicsF (Drawing d leaf) -> GraphicsF (Drawing d leaf)
params = forall (xxx :: * -> *) a.
HasInitDisp xxx =>
a -> Customiser (xxx a)
setInitDisp Drawing d leaf
init forall b c a. (b -> c) -> (a -> b) -> a -> c
.
	     forall {gfx}. [GfxEventMask] -> Customiser (GraphicsF gfx)
setGfxEventMask [GfxEventMask
GfxButtonMask] forall b c a. (b -> c) -> (a -> b) -> a -> c
.
	     forall xxx. HasSizing xxx => Sizing -> Customiser xxx
setSizing Sizing
Dynamic
    state0 :: ([(d, DPath)], Drawing d leaf)
state0 = (forall {a} {leaf}. Drawing a leaf -> [(a, DPath)]
annotPaths Drawing d leaf
init,Drawing d leaf
init)

    ctrl :: ([(lbl, DPath)], Drawing lbl leaf)
-> Either
     (GfxEvent DPath)
     (Either (Drawing lbl leaf) (lbl, Drawing lbl leaf))
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) lbl])
ctrl state :: ([(lbl, DPath)], Drawing lbl leaf)
state@([(lbl, DPath)]
paths,Drawing lbl leaf
drawing) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}.
GfxEvent DPath
-> (([(lbl, DPath)], Drawing lbl leaf), [Either a lbl])
input forall {b}.
Either (Drawing lbl leaf) (lbl, Drawing lbl leaf)
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) b])
output
      where
        same :: (([(lbl, DPath)], Drawing lbl leaf), [a])
same = (([(lbl, DPath)], Drawing lbl leaf)
state,[])
        output :: Either (Drawing lbl leaf) (lbl, Drawing lbl leaf)
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) b])
output = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} {leaf} {a} {b}.
Drawing a leaf
-> (([(a, DPath)], Drawing a leaf),
    [Either (GfxCommand [a] (Drawing a leaf)) b])
new forall {b}.
(lbl, Drawing lbl leaf)
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) b])
newpart
	  where
	    --new d = newpart' d []
	    -- avoid space leak for this common case:
	    new :: Drawing a leaf
-> (([(a, DPath)], Drawing a leaf),
    [Either (GfxCommand [a] (Drawing a leaf)) b])
new Drawing a leaf
d = ((forall {a} {leaf}. Drawing a leaf -> [(a, DPath)]
annotPaths Drawing a leaf
d,Drawing a leaf
d),[forall a b. a -> Either a b
Left (forall {gfx} {a}. gfx -> GfxCommand [a] gfx
replaceAllGfx Drawing a leaf
d)])
	    newpart :: (lbl, Drawing lbl leaf)
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) b])
newpart (lbl
a,Drawing lbl leaf
d) = forall k v r. Eq k => (v -> r) -> r -> [(k, v)] -> k -> r
assoc (forall {b}.
Drawing lbl leaf
-> DPath
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) b])
newpart' Drawing lbl leaf
d) forall {a}. (([(lbl, DPath)], Drawing lbl leaf), [a])
same [(lbl, DPath)]
paths lbl
a
	    newpart' :: Drawing lbl leaf
-> DPath
-> (([(lbl, DPath)], Drawing lbl leaf),
    [Either (GfxCommand DPath (Drawing lbl leaf)) b])
newpart' Drawing lbl leaf
d DPath
path = (([(lbl, DPath)]
paths',Drawing lbl leaf
drawing'),[forall a b. a -> Either a b
Left (forall {path} {gfx}. path -> gfx -> GfxCommand path gfx
replaceGfx DPath
path Drawing lbl leaf
d)])
	      where drawing' :: Drawing lbl leaf
drawing' = forall {lbl} {leaf}.
Drawing lbl leaf -> DPath -> Drawing lbl leaf -> Drawing lbl leaf
replacePart Drawing lbl leaf
drawing DPath
path Drawing lbl leaf
d
	            paths' :: [(lbl, DPath)]
paths' = forall {a} {leaf}. Drawing a leaf -> [(a, DPath)]
annotPaths Drawing lbl leaf
drawing'
			-- Space leak: drawing' isn't used until user clicks
			-- in the window, so the old drawing is retained in
			-- the closure for drawing'

        input :: GfxEvent DPath
-> (([(lbl, DPath)], Drawing lbl leaf), [Either a lbl])
input GfxEvent DPath
msg =
	    case GfxEvent DPath
msg of
	      GfxButtonEvent { gfxType :: forall path. GfxEvent path -> Pressed
gfxType=Pressed
Pressed, gfxPaths :: forall path. GfxEvent path -> [(path, (Point, Rect))]
gfxPaths=[(DPath, (Point, Rect))]
gfxPaths } ->  forall {b} {a}.
[(DPath, b)]
-> (([(lbl, DPath)], Drawing lbl leaf), [Either a lbl])
mouse [(DPath, (Point, Rect))]
gfxPaths
	      GfxEvent DPath
_ -> forall {a}. (([(lbl, DPath)], Drawing lbl leaf), [a])
same
	  where
	    lblPart :: (DPath, b) -> Maybe (Drawing lbl leaf)
lblPart = forall {lbl} {leaf}.
Drawing lbl leaf -> DPath -> Maybe (Drawing lbl leaf)
maybeDrawingPart Drawing lbl leaf
drawing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {leaf}. Drawing t leaf -> DPath -> DPath
drawingAnnotPart Drawing lbl leaf
drawing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
	    mouse :: [(DPath, b)]
-> (([(lbl, DPath)], Drawing lbl leaf), [Either a lbl])
mouse [(DPath, b)]
paths =
	      --ctrace "hyper" (show paths) $
	      case [lbl
lbl|Just (LabelD lbl
lbl Drawing lbl leaf
_)<-forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (DPath, b) -> Maybe (Drawing lbl leaf)
lblPart (forall a. [a] -> [a]
reverse [(DPath, b)]
paths)] of
		lbl
lbl:[lbl]
_ -> (([(lbl, DPath)], Drawing lbl leaf)
state,[forall a b. b -> Either a b
Right lbl
lbl])
{- -- All nodes have unique paths now, so this should not be necessary:
		    Just d ->
		      case annotChildren d of
		        ([],LabelD a _):_ -> (state,[Right a])
			_ -> same
-}
		[lbl]
_ -> forall {a}. (([(lbl, DPath)], Drawing lbl leaf), [a])
same

    annotPaths :: Drawing a leaf -> [(a, DPath)]
annotPaths = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. (b, a) -> (a, b)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {leaf}. Drawing a leaf -> [(DPath, a)]
drawingAnnots