diff options
Diffstat (limited to 'tests/examplefiles/StdGeneric.icl')
| -rw-r--r-- | tests/examplefiles/StdGeneric.icl | 134 |
1 files changed, 0 insertions, 134 deletions
diff --git a/tests/examplefiles/StdGeneric.icl b/tests/examplefiles/StdGeneric.icl deleted file mode 100644 index 891b510a..00000000 --- a/tests/examplefiles/StdGeneric.icl +++ /dev/null @@ -1,134 +0,0 @@ -implementation module StdGeneric - -/** - * NOTE: this is a collection of different tricky parts of Clean modules (even - * though the file is simply called StdGeneric.icl). The code is taken from: - * - * - StdGeneric (StdEnv) - * - Graphics.Scalable.Image (Platform) - */ - -import StdInt, StdMisc, StdClass, StdFunc - -generic bimap a b :: Bimap .a .b - -bimapId :: Bimap .a .a -bimapId = { map_to = id, map_from = id } - -bimap{|c|} = { map_to = id, map_from = id } - -bimap{|PAIR|} bx by = { map_to= map_to, map_from=map_from } -where - map_to (PAIR x y) = PAIR (bx.map_to x) (by.map_to y) - map_from (PAIR x y) = PAIR (bx.map_from x) (by.map_from y) -bimap{|EITHER|} bl br = { map_to= map_to, map_from=map_from } -where - map_to (LEFT x) = LEFT (bl.map_to x) - map_to (RIGHT x) = RIGHT (br.map_to x) - map_from (LEFT x) = LEFT (bl.map_from x) - map_from (RIGHT x) = RIGHT (br.map_from x) - -bimap{|(->)|} barg bres = { map_to = map_to, map_from = map_from } -where - map_to f = comp3 bres.map_to f barg.map_from - map_from f = comp3 bres.map_from f barg.map_to - -bimap{|CONS|} barg = { map_to= map_to, map_from=map_from } -where - map_to (CONS x) = CONS (barg.map_to x) - map_from (CONS x) = CONS (barg.map_from x) - -bimap{|FIELD|} barg = { map_to= map_to, map_from=map_from } -where - map_to (FIELD x) = FIELD (barg.map_to x) - map_from (FIELD x) = FIELD (barg.map_from x) - -bimap{|OBJECT|} barg = { map_to= map_to, map_from=map_from } -where - map_to (OBJECT x) = OBJECT (barg.map_to x) - map_from (OBJECT x) = OBJECT (barg.map_from x) - -bimap{|Bimap|} x y = {map_to = map_to, map_from = map_from} -where - map_to {map_to, map_from} = - { map_to = comp3 y.map_to map_to x.map_from - , map_from = comp3 x.map_to map_from y.map_from - } - map_from {map_to, map_from} = - { map_to = comp3 y.map_from map_to x.map_to - , map_from = comp3 x.map_from map_from y.map_to - } - -comp3 :: !(.a -> .b) u:(.c -> .a) !(.d -> .c) -> u:(.d -> .b) -comp3 f g h - | is_id f - | is_id h - = cast g - = cast (\x -> g (h x)) - | is_id h - = cast (\x -> f (g x)) - = \x -> f (g (h x)) -where - is_id :: !.(.a -> .b) -> Bool - is_id f = code inline - { - eq_desc e_StdFunc_did 0 0 - pop_a 1 - } - - cast :: !u:a -> u:b - cast f = code inline - { - pop_a 0 - } - -getConsPath :: !GenericConsDescriptor -> [ConsPos] -getConsPath {gcd_index, gcd_type_def={gtd_num_conses}} - = doit gcd_index gtd_num_conses -where - doit i n - | n == 0 - = abort "getConsPath: zero conses\n" - | i >= n - = abort "getConsPath: cons index >= number of conses" - | n == 1 - = [] - | i < (n/2) - = [ ConsLeft : doit i (n/2) ] - | otherwise - = [ ConsRight : doit (i - (n/2)) (n - (n/2)) ] - -:: NoAttr m = NoAttr -:: DashAttr m = { dash :: ![Int] } -:: FillAttr m = { fill :: !SVGColor } -:: LineEndMarker m = { endmarker :: !Image m } -:: LineMidMarker m = { midmarker :: !Image m } -:: LineStartMarker m = { startmarker :: !Image m } -:: MaskAttr m = { mask :: !Image m } -:: OpacityAttr m = { opacity :: !Real } -:: StrokeAttr m = { stroke :: !SVGColor } -:: StrokeWidthAttr m = { strokewidth :: !Span } -:: XRadiusAttr m = { xradius :: !Span } -:: YRadiusAttr m = { yradius :: !Span } - - -instance tuneImage NoAttr where tuneImage image _ = image -instance tuneImage DashAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgDashAttr attr.DashAttr.dash)) image -instance tuneImage FillAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgFillAttr attr.FillAttr.fill)) image -instance tuneImage LineEndMarker where tuneImage image attr = Attr` (LineMarkerAttr` {LineMarkerAttr | markerImg = attr.LineEndMarker.endmarker, markerPos = LineMarkerEnd}) image -instance tuneImage LineMidMarker where tuneImage image attr = Attr` (LineMarkerAttr` {LineMarkerAttr | markerImg = attr.LineMidMarker.midmarker, markerPos = LineMarkerMid}) image -instance tuneImage LineStartMarker where tuneImage image attr = Attr` (LineMarkerAttr` {LineMarkerAttr | markerImg = attr.LineStartMarker.startmarker, markerPos = LineMarkerStart}) image -instance tuneImage MaskAttr where tuneImage image attr = Attr` (MaskAttr` attr.MaskAttr.mask) image -instance tuneImage OpacityAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgFillOpacityAttr attr.OpacityAttr.opacity)) image -instance tuneImage StrokeAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgStrokeAttr attr.StrokeAttr.stroke)) image -instance tuneImage StrokeWidthAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgStrokeWidthAttr attr.StrokeWidthAttr.strokewidth)) image -instance tuneImage XRadiusAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgXRadiusAttr attr.XRadiusAttr.xradius)) image -instance tuneImage YRadiusAttr where tuneImage image attr = Attr` (BasicImageAttr` (BasicImgYRadiusAttr attr.YRadiusAttr.yradius)) image - -instance tuneImage DraggableAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerDraggableAttr attr)) image -instance tuneImage OnClickAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnClickAttr attr)) image -instance tuneImage OnMouseDownAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseDownAttr attr)) image -instance tuneImage OnMouseMoveAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseMoveAttr attr)) image -instance tuneImage OnMouseOutAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseOutAttr attr)) image -instance tuneImage OnMouseOverAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseOverAttr attr)) image -instance tuneImage OnMouseUpAttr where tuneImage image attr = Attr` (HandlerAttr` (ImgEventhandlerOnMouseUpAttr attr)) image |