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