Skip to content

Commit

Permalink
Orphan instances resolved.
Browse files Browse the repository at this point in the history
  • Loading branch information
@alanz
alanz committed Jun 3, 2012
1 parent 657fe7c commit 8e14237
Show file tree
Hide file tree
Showing 4 changed files with 113 additions and 93 deletions.
24 changes: 24 additions & 0 deletions src/Graphics/Blobs/Colors.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,8 @@ module Graphics.Blobs.Colors where
import Graphics.UI.WX
import Text.Parse

import qualified Text.XML.HaXml.XmlContent.Haskell as XML


-- Different spelling of colour/color to distinguish local/wx datatypes.
data Colour = RGB !Int !Int !Int deriving (Eq,Show,Read)
Expand Down Expand Up @@ -84,3 +86,25 @@ turquoise = RGB 64 224 208
orangeRed = RGB 255 69 0
gold = RGB 255 215 0
darkSlateGray = RGB 47 79 79

-- ---------------------------------------------------------------------
-- Migrating orphan instances home

{- derived by DrIFT -}
instance XML.HTypeable Colour where
toHType v = XML.Defined "Colour" []
[XML.Constr "RGB" [] [XML.toHType aa,XML.toHType ab,XML.toHType ac]]
where (RGB aa ab ac) = v
instance XML.XmlContent Colour where
parseContents = do
{ XML.inElement "RGB" $ do
{ aa <- XML.parseContents
; ab <- XML.parseContents
; ac <- XML.parseContents
; return (RGB aa ab ac)
}
}
toContents v@(RGB aa ab ac) =
[XML.mkElemC (XML.showConstr 0 (XML.toHType v))
(concat [XML.toContents aa, XML.toContents ab, XML.toContents ac])]

94 changes: 1 addition & 93 deletions src/Graphics/Blobs/Network.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -69,7 +69,7 @@ import Text.XML.HaXml.Combinators (replaceAttrs)
import Text.XML.HaXml.Types
import Text.XML.HaXml.Verbatim
import qualified Text.XML.HaXml.XmlContent.Haskell as XML
import List(nub,isPrefixOf)
import List(nub)
import Monad(when)

data Network g n e = Network
Expand Down Expand Up @@ -736,98 +736,6 @@ instance InfoKind e g => XML.XmlContent (Edge e) where
}
}

{- derived by DrIFT -}
instance XML.HTypeable Colour where
toHType v = XML.Defined "Colour" []
[XML.Constr "RGB" [] [XML.toHType aa,XML.toHType ab,XML.toHType ac]]
where (RGB aa ab ac) = v
instance XML.XmlContent Colour where
parseContents = do
{ XML.inElement "RGB" $ do
{ aa <- XML.parseContents
; ab <- XML.parseContents
; ac <- XML.parseContents
; return (RGB aa ab ac)
}
}
toContents v@(RGB aa ab ac) =
[XML.mkElemC (XML.showConstr 0 (XML.toHType v))
(concat [XML.toContents aa, XML.toContents ab, XML.toContents ac])]

{- derived by DrIFT -}
instance XML.HTypeable Shape.Shape where
toHType v = XML.Defined "Shape" []
[XML.Constr "Circle" [] [XML.toHType aa,XML.toHType ab]
,XML.Constr "Polygon" [] [XML.toHType ac,XML.toHType ad]
,XML.Constr "Lines" [] [XML.toHType ae,XML.toHType af]
,XML.Constr "Composite" [] [XML.toHType ag]]
where
(Shape.Circle aa ab) = v
(Shape.Polygon ac ad) = v
(Shape.Lines ae af) = v
(Shape.Composite ag) = v
instance XML.XmlContent Shape.Shape where
parseContents = do
{ e@(Elem t _ _) <- XML.element ["Circle","Polygon","Lines","Composite"]
; case t of
_ | "Polygon" `isPrefixOf` t -> XML.interior e $
do { ac <- XML.parseContents
; ad <- XML.parseContents
; return (Shape.Polygon ac ad)
}
| "Lines" `isPrefixOf` t -> XML.interior e $
do { ae <- XML.parseContents
; af <- XML.parseContents
; return (Shape.Lines ae af)
}
| "Composite" `isPrefixOf` t -> XML.interior e $
fmap Shape.Composite XML.parseContents
| "Circle" `isPrefixOf` t -> XML.interior e $
do { aa <- XML.parseContents
; ab <- XML.parseContents
; return (Shape.Circle aa ab)
}
}
toContents v@(Shape.Circle aa ab) =
[XML.mkElemC (XML.showConstr 0 (XML.toHType v)) (concat [XML.toContents aa,
XML.toContents ab])]
toContents v@(Shape.Polygon ac ad) =
[XML.mkElemC (XML.showConstr 1 (XML.toHType v)) (concat [XML.toContents ac,
XML.toContents ad])]
toContents v@(Shape.Lines ae af) =
[XML.mkElemC (XML.showConstr 2 (XML.toHType v)) (concat [XML.toContents ae,
XML.toContents af])]
toContents v@(Shape.Composite ag) =
[XML.mkElemC (XML.showConstr 3 (XML.toHType v)) (XML.toContents ag)]

{- derived by DrIFT -}
instance XML.HTypeable Shape.ShapeStyle where
toHType v = XML.Defined "ShapeStyle" []
[XML.Constr "ShapeStyle" [] [XML.toHType aa,XML.toHType ab,XML.toHType ac]]
where (Shape.ShapeStyle aa ab ac) = v
instance XML.XmlContent Shape.ShapeStyle where
parseContents = do
{ XML.inElement "ShapeStyle" $ do
{ aa <- XML.parseContents
; ab <- XML.parseContents
; ac <- XML.parseContents
; return (Shape.ShapeStyle aa ab ac)
}
}
toContents v@(Shape.ShapeStyle aa ab ac) =
[XML.mkElemC (XML.showConstr 0 (XML.toHType v))
(concat [XML.toContents aa, XML.toContents ab, XML.toContents ac])]

{- handwritten -}
instance XML.HTypeable a => XML.HTypeable (P.Palette a) where
toHType p = XML.Defined "Palette" [XML.toHType a] [XML.Constr "Palette" [] []]
where (P.Palette ((_,(_,Just a)):_)) = p
instance XML.XmlContent a => XML.XmlContent (P.Palette a) where
toContents (P.Palette xs) =
[ XML.mkElemC "Palette" (concatMap XML.toContents xs) ]
parseContents = do
{ XML.inElement "Palette" $ fmap P.Palette (XML.many1 XML.parseContents) }

---------------------------------------------------------
-- Internal type isomorphic to (index,value) pairs
-- (but permits instances of classes)
Expand Down
16 changes: 16 additions & 0 deletions src/Graphics/Blobs/Palette.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,8 @@ import List (nub, (\\))
import qualified Graphics.Blobs.Shape as Shape
import Text.Parse

import qualified Text.XML.HaXml.XmlContent.Haskell as XML

data Palette a = Palette [ (String, (Shape.Shape, Maybe a)) ]
deriving (Eq, Show, Read)

Expand All @@ -28,3 +30,17 @@ instance Functor Palette where
instance Parse a => Parse (Palette a) where
parse = do{ isWord "Palette"; fmap Palette $ parse }


-- ---------------------------------------------------------------------
-- orphan instances coming home

{- handwritten -}
instance XML.HTypeable a => XML.HTypeable (Palette a) where
toHType p = XML.Defined "Palette" [XML.toHType a] [XML.Constr "Palette" [] []]
where (Palette ((_,(_,Just a)):_)) = p
instance XML.XmlContent a => XML.XmlContent (Palette a) where
toContents (Palette xs) =
[ XML.mkElemC "Palette" (concatMap XML.toContents xs) ]
parseContents = do
{ XML.inElement "Palette" $ fmap Palette (XML.many1 XML.parseContents) }

72 changes: 72 additions & 0 deletions src/Graphics/Blobs/Shape.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,10 @@ import Text.Parse
import Graphics.Blobs.Colors
import Graphics.Blobs.Constants

import Text.XML.HaXml.Types
import qualified Text.XML.HaXml.XmlContent.Haskell as XML
import List(isPrefixOf)

data Shape =
Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double }
| Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }
Expand Down Expand Up @@ -176,3 +180,71 @@ defaultShapeStyle =
ShapeStyle { styleStrokeWidth = 1
, styleStrokeColour = licorice
, styleFill = nodeColor }

-- ---------------------------------------------------------------------
-- Orphan instances coming home

{- derived by DrIFT -}
instance XML.HTypeable Shape where
toHType v = XML.Defined "Shape" []
[XML.Constr "Circle" [] [XML.toHType aa,XML.toHType ab]
,XML.Constr "Polygon" [] [XML.toHType ac,XML.toHType ad]
,XML.Constr "Lines" [] [XML.toHType ae,XML.toHType af]
,XML.Constr "Composite" [] [XML.toHType ag]]
where
(Circle aa ab) = v
(Polygon ac ad) = v
(Lines ae af) = v
(Composite ag) = v
instance XML.XmlContent Shape where
parseContents = do
{ e@(Elem t _ _) <- XML.element ["Circle","Polygon","Lines","Composite"]
; case t of
_ | "Polygon" `isPrefixOf` t -> XML.interior e $
do { ac <- XML.parseContents
; ad <- XML.parseContents
; return (Polygon ac ad)
}
| "Lines" `isPrefixOf` t -> XML.interior e $
do { ae <- XML.parseContents
; af <- XML.parseContents
; return (Lines ae af)
}
| "Composite" `isPrefixOf` t -> XML.interior e $
fmap Composite XML.parseContents
| "Circle" `isPrefixOf` t -> XML.interior e $
do { aa <- XML.parseContents
; ab <- XML.parseContents
; return (Circle aa ab)
}
}
toContents v@(Circle aa ab) =
[XML.mkElemC (XML.showConstr 0 (XML.toHType v)) (concat [XML.toContents aa,
XML.toContents ab])]
toContents v@(Polygon ac ad) =
[XML.mkElemC (XML.showConstr 1 (XML.toHType v)) (concat [XML.toContents ac,
XML.toContents ad])]
toContents v@(Lines ae af) =
[XML.mkElemC (XML.showConstr 2 (XML.toHType v)) (concat [XML.toContents ae,
XML.toContents af])]
toContents v@(Composite ag) =
[XML.mkElemC (XML.showConstr 3 (XML.toHType v)) (XML.toContents ag)]

{- derived by DrIFT -}
instance XML.HTypeable ShapeStyle where
toHType v = XML.Defined "ShapeStyle" []
[XML.Constr "ShapeStyle" [] [XML.toHType aa,XML.toHType ab,XML.toHType ac]]
where (ShapeStyle aa ab ac) = v
instance XML.XmlContent ShapeStyle where
parseContents = do
{ XML.inElement "ShapeStyle" $ do
{ aa <- XML.parseContents
; ab <- XML.parseContents
; ac <- XML.parseContents
; return (ShapeStyle aa ab ac)
}
}
toContents v@(ShapeStyle aa ab ac) =
[XML.mkElemC (XML.showConstr 0 (XML.toHType v))
(concat [XML.toContents aa, XML.toContents ab, XML.toContents ac])]

0 comments on commit 8e14237

Please sign in to comment.