1implementation module StdGeneric
2
3/**
4 * NOTE: this is a collection of different tricky parts of Clean modules (even
5 * though the file is simply called StdGeneric.icl). The code is taken from:
6 *
7 * - StdGeneric (StdEnv)
8 * - Graphics.Scalable.Image (Platform)
9 */
10
11import StdInt, StdMisc, StdClass, StdFunc
12
13generic bimap a b :: Bimap .a .b
14
15bimapId :: Bimap .a .a
16bimapId = { map_to = id, map_from = id }
17
18bimap{|c|} = { map_to = id, map_from = id }
19
20bimap{|PAIR|} bx by = { map_to= map_to, map_from=map_from }
21where
22	map_to (PAIR x y) 	= PAIR (bx.map_to x) (by.map_to y)
23	map_from (PAIR x y) 	= PAIR (bx.map_from x) (by.map_from y)
24bimap{|EITHER|} bl br = { map_to= map_to, map_from=map_from }
25where
26	map_to (LEFT x) 	= LEFT (bl.map_to x)
27	map_to (RIGHT x)	= RIGHT (br.map_to x)
28	map_from (LEFT x) 	= LEFT (bl.map_from x)
29	map_from (RIGHT x) 	= RIGHT (br.map_from x)
30
31bimap{|(->)|} barg bres = { map_to = map_to, map_from = map_from }
32where
33	map_to f = comp3 bres.map_to f barg.map_from
34	map_from f = comp3 bres.map_from f barg.map_to
35
36bimap{|CONS|} barg = { map_to= map_to, map_from=map_from }
37where
38	map_to   (CONS x) = CONS (barg.map_to x)
39	map_from (CONS x) = CONS (barg.map_from x)
40
41bimap{|FIELD|} barg = { map_to= map_to, map_from=map_from }
42where
43	map_to   (FIELD x) = FIELD (barg.map_to x)
44	map_from (FIELD x) = FIELD (barg.map_from x)
45
46bimap{|OBJECT|} barg = { map_to= map_to, map_from=map_from }
47where
48	map_to   (OBJECT x) = OBJECT (barg.map_to x)
49	map_from (OBJECT x) = OBJECT (barg.map_from x)
50
51bimap{|Bimap|} x y = {map_to = map_to, map_from = map_from}
52where
53	map_to 	{map_to, map_from} =
54		{ map_to 	= comp3 y.map_to map_to x.map_from
55		, map_from 	= comp3 x.map_to map_from y.map_from
56		}
57	map_from {map_to, map_from} =
58		{ map_to 	= comp3 y.map_from map_to x.map_to
59		, map_from 	= comp3 x.map_from map_from y.map_to
60		}
61
62comp3 :: !(.a -> .b) u:(.c -> .a) !(.d -> .c) -> u:(.d -> .b)
63comp3 f g h
64	| is_id f
65		| is_id h
66			= cast g
67			= cast (\x -> g (h x))
68		| is_id h
69			= cast (\x -> f (g x))
70			= \x -> f (g (h x))
71where
72	is_id :: !.(.a -> .b) -> Bool
73	is_id f = code inline
74	{
75		eq_desc e_StdFunc_did 0 0
76		pop_a 1
77	}
78
79	cast :: !u:a -> u:b
80	cast f = code inline
81	{
82		pop_a 0
83	}
84
85getConsPath :: !GenericConsDescriptor -> [ConsPos]
86getConsPath {gcd_index, gcd_type_def={gtd_num_conses}}
87	= doit gcd_index gtd_num_conses
88where
89	doit i n
90		| n == 0
91			= abort "getConsPath: zero conses\n"
92		| i >= n
93			= abort "getConsPath: cons index >= number of conses"
94		| n == 1
95			= []
96		| i < (n/2)
97			= [ ConsLeft : doit i (n/2) ]
98		| otherwise
99			= [ ConsRight : doit (i - (n/2)) (n - (n/2)) ]
100
101:: NoAttr          m = NoAttr
102:: DashAttr        m = { dash        :: ![Int]    }
103:: FillAttr        m = { fill        :: !SVGColor }
104:: LineEndMarker   m = { endmarker   :: !Image m  }
105:: LineMidMarker   m = { midmarker   :: !Image m  }
106:: LineStartMarker m = { startmarker :: !Image m  }
107:: MaskAttr        m = { mask        :: !Image m  }
108:: OpacityAttr     m = { opacity     :: !Real     }
109:: StrokeAttr      m = { stroke      :: !SVGColor }
110:: StrokeWidthAttr m = { strokewidth :: !Span     }
111:: XRadiusAttr     m = { xradius     :: !Span     }
112:: YRadiusAttr     m = { yradius     :: !Span     }
113
114
115instance tuneImage NoAttr          where tuneImage image _    = image
116instance tuneImage DashAttr        where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgDashAttr attr.DashAttr.dash)) image
117instance tuneImage FillAttr        where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgFillAttr attr.FillAttr.fill)) image
118instance tuneImage LineEndMarker   where tuneImage image attr = Attr` (LineMarkerAttr` {LineMarkerAttr | markerImg = attr.LineEndMarker.endmarker, markerPos = LineMarkerEnd}) image
119instance tuneImage LineMidMarker   where tuneImage image attr = Attr` (LineMarkerAttr` {LineMarkerAttr | markerImg = attr.LineMidMarker.midmarker, markerPos = LineMarkerMid}) image
120instance tuneImage LineStartMarker where tuneImage image attr = Attr` (LineMarkerAttr` {LineMarkerAttr | markerImg = attr.LineStartMarker.startmarker, markerPos = LineMarkerStart}) image
121instance tuneImage MaskAttr        where tuneImage image attr = Attr` (MaskAttr` attr.MaskAttr.mask) image
122instance tuneImage OpacityAttr     where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgFillOpacityAttr attr.OpacityAttr.opacity)) image
123instance tuneImage StrokeAttr      where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgStrokeAttr      attr.StrokeAttr.stroke)) image
124instance tuneImage StrokeWidthAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgStrokeWidthAttr attr.StrokeWidthAttr.strokewidth)) image
125instance tuneImage XRadiusAttr     where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgXRadiusAttr     attr.XRadiusAttr.xradius)) image
126instance tuneImage YRadiusAttr     where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgYRadiusAttr     attr.YRadiusAttr.yradius)) image
127
128instance tuneImage DraggableAttr   where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerDraggableAttr   attr)) image
129instance tuneImage OnClickAttr     where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnClickAttr     attr)) image
130instance tuneImage OnMouseDownAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseDownAttr attr)) image
131instance tuneImage OnMouseMoveAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseMoveAttr attr)) image
132instance tuneImage OnMouseOutAttr  where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseOutAttr  attr)) image
133instance tuneImage OnMouseOverAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseOverAttr attr)) image
134instance tuneImage OnMouseUpAttr   where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseUpAttr   attr)) image
135