Skip to content

GitLab

C
clean-platform
Commit d58cd793 authored by Steffen Michels's avatar Steffen Michels
Browse files
Options

Merge branch 'remove-fragile-dependency-on-ord-for-Set-in-graphics' into 'master' 

Image attributes now uses a Data.SetBy instead of Data.Set;

See merge request !335
parents f742ac48 4ea0ae89
Pipeline #43132 passed with stage
    in 2 minutes and 31 seconds
    Hide whitespace changes
    Inline Side-by-side
    Showing with 24 additions and 21 deletions
    src/libraries/OS-Independent/Data/SetBy.icl
    View file @ d58cd793
    ......@@ -97,10 +97,10 @@ singleton x = BinBy 1 x TipBy TipBy
    *--------------------------------------------------------------------*/
    insertBy :: !(a a -> Bool) !a !.(SetBy a) -> SetBy a
    insertBy comp x t=:(BinBy _ y l r)
    insertBy comp x (BinBy c y l r)
    | comp x y = balanceL y (insertBy comp x l) r
    | comp y x = balanceR y l (insertBy comp x r)
    | otherwise = t
    | otherwise = BinBy c x l r
    insertBy _ x _ = singleton x
    deleteBy :: !(a a -> Bool) !a !.(SetBy a) -> SetBy a
    ......
    src/libraries/OS-Independent/Graphics/Scalable/Internal/Image`.dcl
    View file @ d58cd793
    ......@@ -2,6 +2,7 @@ definition module Graphics.Scalable.Internal.Image`
    from Data.Maybe import :: Maybe
    from Data.Set import :: Set
    from Data.SetBy import :: SetBy
    from Data.Map import :: Map
    from Data.Error import :: MaybeError (..)
    from Math.Geometry import :: Angle
    ......@@ -110,7 +111,7 @@ instance == DefuncImgEventhandler`
    , offsets :: ![ImageOffset] // the offsets matching one-by-one with .overlays
    }
    :: HostImg
    = BasicHostImg !BasicImg !(Set BasicImgAttr)
    = BasicHostImg !BasicImg !(SetBy BasicImgAttr)
    | RawHostImg !String
    | CompositeImg !Img
    :: BasicImg
    ......
    src/libraries/OS-Independent/Graphics/Scalable/Internal/Image`.icl
    View file @ d58cd793
    ......@@ -10,8 +10,10 @@ import Data.Monoid
    import Data.MapCollection
    import qualified Data.Foldable
    import qualified Data.Set
    import qualified Data.SetBy
    import qualified Data.Map
    from Data.Set import :: Set, instance == (Set a), instance < (Set a), instance Foldable Set
    from Data.SetBy import :: SetBy, isEqualBy, instance Foldable SetBy
    from Data.Map import :: Map, findKeyWith, instance Functor (Map k)
    from Control.Applicative import class Applicative (..)
    import Control.Monad
    ......@@ -42,7 +44,7 @@ equivImg {Img | transform = tfs, offsets = offs, host = h, overlays = overs }
    = tfs == tfs` && offs === offs` && equivHostImg h h` && gEq{|*->*|} equivImg overs overs`
    equivHostImg :: !HostImg !HostImg -> Bool
    equivHostImg (BasicHostImg basic attrs) (BasicHostImg basic` attrs`) = basic === basic` && attrs === attrs`
    equivHostImg (BasicHostImg basic attrs) (BasicHostImg basic` attrs`) = basic === basic` && isEqualBy smallerBasicImgAttr attrs attrs`
    equivHostImg (RawHostImg txt) (RawHostImg txt`) = txt == txt`
    equivHostImg (CompositeImg img) (CompositeImg img`) = equivImg img img`
    equivHostImg _ _ = False
    ......@@ -145,17 +147,19 @@ defunc (ImgEventhandlerOnMouseMoveAttr {OnMouseMoveAttr | local}) = {ImgEventhan
    defunc (ImgEventhandlerOnMouseOutAttr {OnMouseOutAttr | local}) = {ImgEventhandler` | handler = ImgEventhandlerOnMouseOutAttr`, local=local}
    defunc (ImgEventhandlerDraggableAttr _) = {ImgEventhandler` | handler = ImgEventhandlerDraggableAttr`, local=False}
    defaultFilledImgAttributes :: Set BasicImgAttr
    defaultFilledImgAttributes :: SetBy BasicImgAttr
    defaultFilledImgAttributes
    = 'Data.Set'.fromList [ BasicImgStrokeAttr (toSVGColor "black")
    = 'Data.SetBy'.fromListBy smallerBasicImgAttr
    [ BasicImgStrokeAttr (toSVGColor "black")
    , BasicImgStrokeWidthAttr (PxSpan 1.0)
    , BasicImgFillAttr (toSVGColor "black")
    , BasicImgFillOpacityAttr 1.0
    ]
    defaultOutlineImgAttributes :: Set BasicImgAttr
    defaultOutlineImgAttributes :: SetBy BasicImgAttr
    defaultOutlineImgAttributes
    = 'Data.Set'.fromList [ BasicImgFillAttr (toSVGColor "none")
    = 'Data.SetBy'.fromListBy smallerBasicImgAttr
    [ BasicImgFillAttr (toSVGColor "none")
    , BasicImgStrokeAttr (toSVGColor "black")
    , BasicImgStrokeWidthAttr (PxSpan 1.0)
    ]
    ......@@ -166,7 +170,7 @@ defaultMargins` = {Margins` | n=zero, e=zero, s=zero, w=zero}
    defaultMarkers` :: Markers` m
    defaultMarkers` = {Markers` | markerStart` = Nothing, markerMid` = Nothing, markerEnd` = Nothing}
    mkBasicHostImg :: !ImgTagNo !BasicImg !(Set BasicImgAttr) -> Img
    mkBasicHostImg :: !ImgTagNo !BasicImg !(SetBy BasicImgAttr) -> Img
    mkBasicHostImg no basicImg atts = {Img | uniqId = no
    , host = BasicHostImg basicImg atts
    , transform = Nothing
    ......@@ -252,7 +256,7 @@ empty` xspan yspan font_spans text_spans imgTables=:{ImgTables | imgNewTexts = t
    #! (yspan`,txts) = spanImgTexts text_spans yspan txts
    #! dx = positive_span xspan`
    #! dy = positive_span yspan`
    = ( mkBasicHostImg no EmptyImg 'Data.Set'.newSet
    = ( mkBasicHostImg no EmptyImg 'Data.SetBy'.newSet
    , {ImgTables | imgTables & imgNewTexts = txts
    , imgSpans = 'Data.Map'.put no (dx,dy) curSpans
    , imgUniqIds = no-1
    ......@@ -263,7 +267,7 @@ text` :: !FontDef !String !FontSpans !TextSpans !ImgTables -> (!Img,!ImgTables)
    text` font str font_spans text_spans imgTables=:{ImgTables | imgNewFonts = curFonts, imgNewTexts = txts, imgSpans = curSpans, imgUniqIds = no}
    #! (w,txts) = spanImgTexts text_spans (LookupSpan (TextXSpan font str)) txts
    #! curFonts = if ('Data.Map'.member font font_spans) curFonts ('Data.Set'.insert font curFonts)
    = ( mkBasicHostImg no (TextImg font str) 'Data.Set'.newSet
    = ( mkBasicHostImg no (TextImg font str) 'Data.SetBy'.newSet
    , {ImgTables | imgTables & imgNewFonts = curFonts
    , imgNewTexts = txts
    , imgSpans = 'Data.Map'.put no (w,PxSpan (getfontysize font)) curSpans
    ......@@ -458,7 +462,7 @@ margin` {Margins` | n,e,s,w} image p font_spans text_spans imgTables=:{ImgTables
    #! (img_w,img_h) = 'Data.Map'.find img.Img.uniqId curSpans
    #! span_host = (w + img_w + e, n + img_h + s)
    = ({Img | uniqId = no
    , host = BasicHostImg EmptyImg 'Data.Set'.newSet
    , host = BasicHostImg EmptyImg 'Data.SetBy'.newSet
    , transform = Nothing
    , overlays = [img]
    , offsets = [(w,n)]
    ......@@ -481,7 +485,7 @@ where
    #! span_imgs = [(uniqId,'Data.Map'.find uniqId curSpans) \\ {Img | uniqId} <- imgs]
    #! span_host = bounding_box_of_spans span_imgs
    = ({Img | uniqId = no
    , host = BasicHostImg EmptyImg 'Data.Set'.newSet
    , host = BasicHostImg EmptyImg 'Data.SetBy'.newSet
    , transform = Nothing
    , overlays = imgs
    , offsets = [ offset_within_host span_img align offset span_host
    ......@@ -607,7 +611,7 @@ attr` (BasicImageAttr` attr) image p font_spans text_spans imgTables
    = (img`,{ImgTables | imgTables & imgNewTexts = txts})
    where
    add_basic_attribute :: !BasicImgAttr !HostImg -> HostImg
    add_basic_attribute attr (BasicHostImg img attrs) = BasicHostImg img ('Data.Set'.insert attr attrs)
    add_basic_attribute attr (BasicHostImg img attrs) = BasicHostImg img ('Data.SetBy'.insertBy smallerBasicImgAttr attr attrs)
    add_basic_attribute _ host = host
    attr` (LineMarkerAttr` {LineMarkerAttr | markerImg,markerPos}) image p font_spans text_spans imgTables
    #! (mark,imgTables) = toImg markerImg [ViaAttr :p] font_spans text_spans imgTables
    ......@@ -676,8 +680,6 @@ ImgEventhandler`ConsName ImgEventhandlerOnMouseMoveAttr` = "ImgEventhandlerOnM
    ImgEventhandler`ConsName ImgEventhandlerOnMouseOutAttr` = "ImgEventhandlerOnMouseOutAttr`"
    ImgEventhandler`ConsName ImgEventhandlerDraggableAttr` = "ImgEventhandlerDraggableAttr`"
    instance < (ImgEventhandler m) where (<) a b = ImgEventhandlerConsName a < ImgEventhandlerConsName b
    instance == (ImgEventhandler m) where (==) a b = ImgEventhandlerConsName a == ImgEventhandlerConsName b
    instance == DefuncImgEventhandler` where (==) a b = ImgEventhandler`ConsName a == ImgEventhandler`ConsName b
    ImgAttrConsName :: !BasicImgAttr -> String
    ......@@ -690,8 +692,8 @@ ImgAttrConsName (BasicImgFillOpacityAttr _) = "BasicImgFillOpacityAttr"
    ImgAttrConsName (BasicImgFillAttr _) = "BasicImgFillAttr"
    ImgAttrConsName (BasicImgDashAttr _) = "BasicImgDashAttr"
    instance < BasicImgAttr where (<) a b = ImgAttrConsName a < ImgAttrConsName b
    instance == BasicImgAttr where (==) a b = ImgAttrConsName a == ImgAttrConsName b
    smallerBasicImgAttr :: !BasicImgAttr !BasicImgAttr -> Bool
    smallerBasicImgAttr a b = ImgAttrConsName a < ImgAttrConsName b
    tag` :: !ImageTag !(Image` m) !ImgNodePath !FontSpans !TextSpans !ImgTables -> (!Img,!ImgTables)
    tag` t=:(ImageTagUser no label) image p font_spans txt_spans imgTables
    ......@@ -907,12 +909,12 @@ where
    resolveHostImg user_tags font_spans text_spans host spans
    = (Ok host,spans)
    resolveImgAttrs :: !ImgTags !FontSpans !TextSpans !(Set BasicImgAttr) !*(!ImgPaths,!ImgSpans,!GridSpans) -> (!MaybeError SpanResolveError (Set BasicImgAttr),!*(!ImgPaths,!ImgSpans,!GridSpans))
    resolveImgAttrs :: !ImgTags !FontSpans !TextSpans !(SetBy BasicImgAttr) !*(!ImgPaths,!ImgSpans,!GridSpans) -> (!MaybeError SpanResolveError (SetBy BasicImgAttr),!*(!ImgPaths,!ImgSpans,!GridSpans))
    resolveImgAttrs user_tags font_spans text_spans attrs spans
    #! (m_attrs`,spans) = strictTRMapSt (resolveImgAttr user_tags font_spans text_spans) ('Data.Set'.toList attrs) spans
    #! (m_attrs`,spans) = strictTRMapSt (resolveImgAttr user_tags font_spans text_spans) ('Data.SetBy'.toList attrs) spans
    = case [e \\ Error e <- m_attrs`] of
    [e : _] = (Error e,spans)
    _ = (Ok ('Data.Set'.fromList (map fromOk m_attrs`)),spans)
    _ = (Ok ('Data.SetBy'.fromListBy smallerBasicImgAttr (map fromOk m_attrs`)),spans)
    resolveImgAttr :: !ImgTags !FontSpans !TextSpans !BasicImgAttr !*(!ImgPaths,!ImgSpans,!GridSpans) -> (!MaybeError SpanResolveError BasicImgAttr,!*(!ImgPaths,!ImgSpans,!GridSpans))
    resolveImgAttr user_tags font_spans text_spans (BasicImgStrokeWidthAttr span) spans
    ......
    Markdown is supported
    0% or .
    You are about to add 0 people to the discussion. Proceed with caution.
    Finish editing this message first!
    Please register or to comment