hgeometry-ipe 0.12.0.0 → 0.13

raw patch · 46 files changed

+3689/−3184 lines, 46 filesdep +typed-processdep ~directorydep ~filepathdep ~hgeometryPVP ok

version bump matches the API change (PVP)

Dependencies added: typed-process

Dependency ranges changed: directory, filepath, hgeometry, hgeometry-combinatorial

API changes (from Hackage documentation)

Files

• README.md +39/−13
• changelog +54/−0
• changelog.org +22/−0
• hgeometry-ipe.cabal +29/−24
• src/Data/Geometry/Arrangement/Draw.hs +2/−6
• src/Data/Geometry/Ipe.hs +0/−28
• src/Data/Geometry/Ipe/Attributes.hs +0/−374
• src/Data/Geometry/Ipe/Color.hs +0/−120
• src/Data/Geometry/Ipe/Content.hs +0/−346
• src/Data/Geometry/Ipe/FromIpe.hs +0/−264
• src/Data/Geometry/Ipe/IpeOut.hs +0/−282
• src/Data/Geometry/Ipe/Layer.hs +0/−13
• src/Data/Geometry/Ipe/Literal.hs +0/−27
• src/Data/Geometry/Ipe/Matrix.hs +0/−41
• src/Data/Geometry/Ipe/ParserPrimitives.hs +0/−148
• src/Data/Geometry/Ipe/Path.hs +0/−112
• src/Data/Geometry/Ipe/PathParser.hs +0/−167
• src/Data/Geometry/Ipe/Reader.hs +0/−438
• src/Data/Geometry/Ipe/Types.hs +0/−198
• src/Data/Geometry/Ipe/Value.hs +0/−24
• src/Data/Geometry/Ipe/Writer.hs +0/−436
• src/Data/Geometry/PlanarSubdivision/Draw.hs +32/−25
• src/Data/Geometry/QuadTree/Draw.hs +19/−5
• src/Data/Geometry/Triangulation/Draw.hs +1/−1
• src/Data/PlaneGraph/Draw.hs +58/−35
• src/Data/Tree/Draw.hs +1/−1
• src/Ipe.hs +99/−0
• src/Ipe/Attributes.hs +341/−0
• src/Ipe/Color.hs +128/−0
• src/Ipe/Content.hs +348/−0
• src/Ipe/FromIpe.hs +264/−0
• src/Ipe/IpeOut.hs +290/−0
• src/Ipe/IpeRender.hs +81/−0
• src/Ipe/IpeToIpe.hs +107/−0
• src/Ipe/Layer.hs +24/−0
• src/Ipe/Literal.hs +40/−0
• src/Ipe/Matrix.hs +53/−0
• src/Ipe/ParserPrimitives.hs +148/−0
• src/Ipe/Path.hs +124/−0
• src/Ipe/PathParser.hs +194/−0
• src/Ipe/Reader.hs +475/−0
• src/Ipe/Types.hs +199/−0
• src/Ipe/Value.hs +24/−0
• src/Ipe/Writer.hs +436/−0
• test/Data/Geometry/Ipe/ReaderSpec.hs +0/−56
• test/Ipe/ReaderSpec.hs +57/−0

@@ -6,23 +6,49 @@ progress. Hence, the API is experimental and may change at any time!  Here is an example showing reading a set of points from an Ipe file,-computing the DelaunayTriangulation, and writing the result again to-an output file+computing the DelaunayTriangulation and the Euclidean Minimimum+Spanning tree, and writing the result again to an output file. Refer+to+[hgeometry-examples](https://github.com/noinia/hgeometry/tree/master/hgeometry-examples/src/Demo/Delaunay.hs)+for the full code. + ```haskell mainWith                          :: Options -> IO () mainWith (Options inFile outFile) = do-    ePage <- readSinglePageFile inFile-    case ePage of-      Left err                         -> print err-      Right (page :: IpePage Rational) -> case page^..content.traverse._IpeUse of-        []         -> putStrLn "No points found"-        syms@(_:_) -> do-           let pts  = syms&traverse.core %~ (^.symbolPoint)-               pts' = NonEmpty.fromList pts-               dt   = delaunayTriangulation $ pts'-               out  = [iO $ drawTriangulation dt]-           writeIpeFile outFile . singlePageFromContent $ out+  pts <- readAllFrom @(Point 2 R) inFile+  let pts' = NonEmpty.fromList pts+      dt   = toPlanarSubdivision (Proxy @DTWorld) . delaunayTriangulation $ pts'+      emst = euclideanMST pts'+      out  = [ iO $ drawPlanarSubdivisionWith drawVtx drawEdge (drawInternalFace dt) drawOuterFace dt+                  ! attr SLayer "delaunayTriangulation"+             , iO $ drawTree' emst ! attr SLayer "emst"+             ]+      outputFile = singlePageFromContent out+  outputFile' <- addStyleSheetFrom "../hgeometry-ipe/resources/opacities.isy" outputFile+  writeIpeFile outFile outputFile'++-- | The world in which the delaunay triangulation "lives"+data DTWorld++-- | Draw vertices using their default representation; disk marks. For+-- the rest we keep their original attributes.+drawVtx                         :: IpeOut' Maybe (VertexId' s, VertexData r (IpeAttributes IpeSymbol r)) IpeSymbol r+drawVtx (_vi, VertexData p ats) = Just $ defIO p ! ats++-- | Draw edges using normal line segments+drawEdge              :: IpeOut' Maybe (Dart s,      LineSegment 2 v r :+ e)  Path r+drawEdge (_d, s :+ _) = Just $ defIO s++-- | Internal faces are filled polygons.+drawInternalFace                 :: PlanarSubdivision s v e f r+                                 -> IpeOut' Maybe (FaceId' s,   SomePolygon v r :+ f)    Path r+drawInternalFace s (fi, pg :+ _) = Just $ defIO pg ! attr SFill lightcyan++--+drawOuterFace :: (Ord r, Num r) => IpeOut' Maybe (FaceId' s,   MultiPolygon (Maybe v) r :+ f) Path r+drawOuterFace (_, pg :+ _) = Just $ defIO pg ! attr SOpacity "10%"+                                             ! attr SFill lightgray ```  See the [hgeometry-examples](https://github.com/noinia/hgeometry/tree/master/hgeometry-examples) package for more examples.

@@ -0,0 +1,54 @@+#+STARTUP: showeverything++* Changelog++** 0.13++- Newer BezierSpline parsing.+- Renamed the modules from Data.Geometry.Ipe to simply Ipe. The+  following find and sed command should be able to help you migrate+  (but use it at your own risk)++  #+begin_src sh+  find src -name "*.hs" -exec sed -i -e 's/Data.Geometry.Ipe/Ipe/g' {} \;+  #+end_src+- Better Documentation; i.e. specific reexports from the Ipe module.+- Added functionality to load and add a stylesheet to a file.+- Added support for the stroke-opacity attribute.+- IpeRender and IpeToIpe modules that allows to us to easily call+  'iperender' and 'ipetoipe'. The IpeToIpe module now also defines a+  'wirteIpeFileAsPdf' function that allows us to write to an ipe pdf+  file (by calling ipetoipe to create this pdf.)++** 0.12++- Compatibility with HGeometry 0.12++** 0.11+- Split the Types module into smaller sub modules, and restricting+  what is exported.+- Traversable, Foldable, and Functor instances for the ipe types.+- Reading and Writing of Ellipses :)+- Added Coordinate Float and IpeWriteText Float instances.+- readAll now accepts only one IpePage rather than a Foldable f => f+  (IpePage r)+- Renamed attrLens to ixAttr, and added a prism _Attr to access an+  attribute._+- added convenience functions (well, Getter's) for getting all Ipe+  objects on a particular layer, or in a particular view.+- readSinglePageFile now makes sure there is at least one layer / view+  in the file, and if not creates it. This matches the behaviour of+  ipe itself. See the new 'withDefaults' function in the Types module+  for the details.+- fromContent now creates these layers and views as well.++** 0.10++- Added a 'labeled' IpeOut that supports labeling geometric objects+  with some textual label+- IpeWrite instance for NonEmpty Lists, and IpeWriteText and+  Coordinate instances for Data.RealNumber.Rational++** 0.9++- First release in which hgeometry-ipe was split off from hgeometry.

@@ -2,6 +2,28 @@  * Changelog +** 0.13++- Newer BezierSpline parsing.+- Renamed the modules from Data.Geometry.Ipe to simply Ipe. The+  following find and sed command should be able to help you migrate+  (but use it at your own risk)++  #+begin_src sh+  find src -name "*.hs" -exec sed -i -e 's/Data.Geometry.Ipe/Ipe/g' {} \;+  #+end_src+- Better Documentation; i.e. specific reexports from the Ipe module.+- Added functionality to load and add a stylesheet to a file.+- Added support for the stroke-opacity attribute.+- IpeRender and IpeToIpe modules that allows to us to easily call+  'iperender' and 'ipetoipe'. The IpeToIpe module now also defines a+  'wirteIpeFileAsPdf' function that allows us to write to an ipe pdf+  file (by calling ipetoipe to create this pdf.)++** 0.12++- Compatibility with HGeometry 0.12+ ** 0.11 - Split the Types module into smaller sub modules, and restricting   what is exported.

@@ -1,10 +1,11 @@+cabal-version:       2.4 name:                hgeometry-ipe-version:             0.12.0.0+version:             0.13 synopsis:            Reading and Writing ipe7 files. description:    Reading and Writing ipe7 files and converting them to and from HGeometry types. homepage:            https://fstaals.net/software/hgeometry-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Frank Staals maintainer:          frank@fstaals.net@@ -21,12 +22,12 @@                      -- examples/**/*.out  extra-source-files:  README.md+                     changelog                      changelog.org  Extra-doc-files:                      -- docs/**/*.png -cabal-version:       2.0 source-repository head   type:     git   location: https://github.com/noinia/hgeometry@@ -47,21 +48,24 @@                     Data.Geometry.QuadTree.Draw                      -- * Ipe Types-                    Data.Geometry.Ipe-                    Data.Geometry.Ipe.Literal-                    Data.Geometry.Ipe.Value-                    Data.Geometry.Ipe.Color-                    Data.Geometry.Ipe.Attributes-                    Data.Geometry.Ipe.Types-                    Data.Geometry.Ipe.Writer-                    Data.Geometry.Ipe.Reader-                    Data.Geometry.Ipe.PathParser-                    Data.Geometry.Ipe.IpeOut-                    Data.Geometry.Ipe.FromIpe-                    Data.Geometry.Ipe.Path-                    Data.Geometry.Ipe.Matrix-                    Data.Geometry.Ipe.Layer-                    Data.Geometry.Ipe.Content+                    Ipe+                    Ipe.Literal+                    Ipe.Value+                    Ipe.Color+                    Ipe.Attributes+                    Ipe.Types+                    Ipe.Writer+                    Ipe.Reader+                    Ipe.PathParser+                    Ipe.IpeOut+                    Ipe.FromIpe+                    Ipe.Path+                    Ipe.Matrix+                    Ipe.Layer+                    Ipe.Content+                    -- * IpeRender+                    Ipe.IpeRender+                    Ipe.IpeToIpe                      -- * Embedded Planar Graphs                     Data.PlaneGraph.Draw@@ -69,7 +73,7 @@                     -- Data.Geometry.BezierSpline    other-modules:-                    Data.Geometry.Ipe.ParserPrimitives+                    Ipe.ParserPrimitives     -- other-extensions:@@ -93,8 +97,8 @@               , QuickCheck              >= 2.5               , quickcheck-instances    >= 0.3 -              , hgeometry-combinatorial >= 0.12.0.0-              , hgeometry               >= 0.12.0.0+              , hgeometry-combinatorial >= 0.13+              , hgeometry               >= 0.13                -- , validation       >= 0.4 @@ -108,8 +112,9 @@               , hexpat           >= 0.20.9               , aeson            >= 1.0               , yaml             >= 0.8-              -- , zippers          >= 0.2-+              , typed-process    >= 0.2.6+              , directory        >= 1.3+              , filepath         >= 1.4               , mtl               , random               , template-haskell@@ -169,7 +174,7 @@   build-tool-depends: hspec-discover:hspec-discover  -  other-modules: Data.Geometry.Ipe.ReaderSpec+  other-modules: Ipe.ReaderSpec    build-depends:        base                       , hspec                >= 2.1

@@ -12,13 +12,9 @@  import Control.Lens import Data.Geometry.Arrangement-import Data.Geometry.Ipe+import Ipe import Data.Geometry.PlanarSubdivision.Draw  -- | Draws an arrangement-drawArrangement :: IpeOut (Arrangement s l v e f r) Group r+drawArrangement :: (Ord r, Num r) => IpeOut (Arrangement s l v e f r) Group r drawArrangement = drawPlanarSubdivision' . view subdivision---- | Draws an arrangement-drawColoredArrangement :: IpeOut (Arrangement s l v e (Maybe (IpeColor r)) r) Group r-drawColoredArrangement = drawColoredPlanarSubdivision . view subdivision

@@ -1,28 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Reexports the functionality for reading and writing Ipe files.-------------------------------------------------------------------------------------module Data.Geometry.Ipe( module Data.Geometry.Ipe.Types-                        , module Data.Geometry.Ipe.Writer-                        , module Data.Geometry.Ipe.Reader-                        , module Data.Geometry.Ipe.IpeOut-                        , module Data.Geometry.Ipe.FromIpe-                        , module Data.Geometry.Ipe.Attributes-                        , module Data.Geometry.Ipe.Value-                        , module Data.Geometry.Ipe.Color-                        ) where--import Data.Geometry.Ipe.Types-import Data.Geometry.Ipe.Writer-import Data.Geometry.Ipe.Reader-import Data.Geometry.Ipe.IpeOut-import Data.Geometry.Ipe.FromIpe-import Data.Geometry.Ipe.Attributes-import Data.Geometry.Ipe.Value-import Data.Geometry.Ipe.Color(IpeColor(..))

@@ -1,374 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE UndecidableInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.Attributes--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Possible Attributes we can assign to items in an Ipe file-------------------------------------------------------------------------------------module Data.Geometry.Ipe.Attributes where--import Control.Lens hiding (rmap, Const)-import Data.Geometry.Ipe.Value-import Data.Singletons-import Data.Singletons.TH-import Data.Text (Text)-import Data.Vinyl-import Data.Vinyl.TypeLevel-import Data.Vinyl.Functor-import Text.Read (lexP, step, parens, prec, (+++)-                , Lexeme(Ident), readPrec, readListPrec, readListPrecDefault)-------------------------------------------------------------------------------------data AttributeUniverse = -- common-                         Layer | Matrix | Pin | Transformations-                       -- symbol-                       | Stroke | Fill | Pen | Size-                       -- Path-                       | Dash | LineCap | LineJoin-                       | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient-                       -- Group-                       | Clip-                       -- Extra---                       | X Text-                       deriving (Show,Read,Eq)---genSingletons [ ''AttributeUniverse ]---type CommonAttributes = [ Layer, Matrix, Pin, Transformations ]---type TextLabelAttributes = CommonAttributes-type MiniPageAttributes  = CommonAttributes--type ImageAttributes     = CommonAttributes---type SymbolAttributes = CommonAttributes ++-                          [Stroke, Fill, Pen, Size]--type PathAttributes = CommonAttributes ++-                      [ Stroke, Fill, Dash, Pen, LineCap, LineJoin-                      , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient-                      ]--type GroupAttributes = CommonAttributes ++ '[ 'Clip]--------------------------------------------------------------------------------------- * Attr---- | Attr implements the mapping from labels to types as specified by the--- (symbol representing) the type family 'f'-newtype Attr (f :: TyFun u * -> *) -- Symbol repr. the Type family mapping-                                   -- Labels in universe u to concrete types-             (label :: u) = GAttr { _getAttr :: Maybe (Apply f label) }---deriving instance Eq   (Apply f label) => Eq   (Attr f label)-deriving instance Ord  (Apply f label) => Ord  (Attr f label)--makeLenses ''Attr---- | Constructor for constructing an Attr given an actual value.-pattern Attr   :: Apply f label -> Attr f label-pattern Attr x = GAttr (Just x)---- | An Attribute that is not set-pattern NoAttr :: Attr f label-pattern NoAttr = GAttr Nothing-{-# COMPLETE NoAttr, Attr #-}---traverseAttr   :: Applicative h => (Apply f label -> h (Apply g label))-               -> Attr f label -> h (Attr g label)-traverseAttr f = \case-  Attr x -> Attr <$> f x-  NoAttr -> pure NoAttr---- | Traverse for the situation where the type is not actually parameterized.-pureAttr :: (Applicative h, Apply f a ~ Apply g a) => Attr f a -> h (Attr g a)-pureAttr = pure . \case-    Attr a -> Attr a-    NoAttr -> NoAttr---instance Show (Apply f label) => Show (Attr f label) where-  showsPrec d NoAttr   = showParen (d > app_prec) $ showString "NoAttr"-    where app_prec = 10-  showsPrec d (Attr a) = showParen (d > up_prec) $-                           showString "Attr " . showsPrec (up_prec+1) a-    where up_prec  = 5--instance Read (Apply f label) => Read (Attr f label) where-  readPrec = parens $ (prec app_prec $ do-                                         Ident "NoAttr" <- lexP-                                         pure NoAttr)-                  +++ (prec up_prec $ do-                                         Ident "Attr" <- lexP-                                         a <- step readPrec-                                         pure $ Attr a)-    where-      app_prec = 10-      up_prec = 5-  readListPrec = readListPrecDefault------ | Give pref. to the *RIGHT*-instance Semigroup (Attr f l) where-  _ <> b@(Attr _) = b-  a <> _          = a--instance Monoid (Attr f l) where-  mempty  = NoAttr-  mappend = (<>)------------------------------------------------------------------------------------- * Attributes---- | A collection of Attributes.-newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) = Attrs (Rec (Attr f) ats)--unAttrs :: Lens (Attributes f ats) (Attributes f' ats') (Rec (Attr f) ats) (Rec (Attr f') ats')-unAttrs = lens (\(Attrs r) -> r) (const Attrs)--deriving instance ( RMap ats, ReifyConstraint Show (Attr f) ats, RecordToList ats-                  , RecAll (Attr f) ats Show) => Show (Attributes f ats)--- deriving instance (RecAll (Attr f) ats Read) => Read (Attributes f ats)--instance ( ReifyConstraint Eq (Attr f) ats, RecordToList ats-         , RecAll (Attr f) ats Eq)   => Eq   (Attributes f ats) where-  (Attrs a) == (Attrs b) = and . recordToList-                         . zipRecsWith (\x (Compose (Dict y)) -> Const $ x == y) a-                         . (reifyConstraint @Eq) $ b--instance RecApplicative ats => Monoid (Attributes f ats) where-  mempty        = Attrs $ rpure mempty-  a `mappend` b = a <> b--instance Semigroup (Attributes f ats) where-  (Attrs as) <> (Attrs bs) = Attrs $ zipRecsWith mappend as bs--traverseAttrs               :: Applicative h-                            => (forall label. Attr f label -> h (Attr g label))-                            -> Attributes f ats -> h (Attributes g ats)-traverseAttrs f (Attrs ats) = Attrs <$> rtraverse f ats----zipRecsWith                       :: (forall a. f a -> g a -> h a)-                                  -> Rec f as -> Rec g as -> Rec h as-zipRecsWith _ RNil      _         = RNil-zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss----------------------------------------------- | Lens into a specific attribute, if it is set.-ixAttr   :: forall at ats proxy f. (at ∈ ats)-         => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at))-ixAttr _ = unAttrs.(rlens @at).getAttr---- | Prism into a particular attribute.-_Attr   :: forall at ats proxy f. (at ∈ ats, RecApplicative ats)-         => proxy at -> Prism' (Attributes f ats) (Apply f at)-_Attr a = prism' setA getA-  where-    setA x = setAttr a x mempty-    getA = lookupAttr a---- | Looks up a particular attribute.-lookupAttr   :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at)-lookupAttr p = view (ixAttr p)---- | Sets a particular attribute-setAttr               :: forall proxy at ats f. (at ∈ ats)-                      => proxy at -> Apply f at -> Attributes f ats -> Attributes f ats-setAttr _ a (Attrs r) = Attrs $ rput (Attr a :: Attr f at) r----- | gets and removes the attribute from Attributes-takeAttr       :: forall proxy at ats f. (at ∈ ats)-               => proxy at -> Attributes f ats -> ( Maybe (Apply f at)-                                                  , Attributes f ats )-takeAttr p ats = (lookupAttr p ats, ats&ixAttr p .~ Nothing)---- | unsets/Removes an attribute-unSetAttr   :: forall proxy at ats f. (at ∈ ats)-            => proxy at -> Attributes f ats -> Attributes f ats-unSetAttr p = snd . takeAttr p---- | Creates a singleton attribute-attr     :: (at ∈ ats, RecApplicative ats)-         => proxy at -> Apply f at -> Attributes f ats-attr p x = x^.re (_Attr p)------------------------------------------------------------------------------------- | Common Attributes---- IpeObjects may have attributes. Essentially attributes are (key,value)--- pairs. The key is some name. Which attributes an object can have depends on--- the type of the object. However, all ipe objects support the following--- 'common attributes':---- data CommonAttributeUniverse = Layer | Matrix | Pin | Transformations---                              deriving (Show,Read,Eq)---- | Possible values for Pin-data PinType = No | Yes | Horizontal | Vertical-             deriving (Eq,Show,Read)---- | Possible values for Transformation-data TransformationTypes = Affine | Rigid | Translations deriving (Show,Read,Eq)---- type family CommonAttrElf (r :: *) (f :: CommonAttributeUniverse)where---   CommonAttrElf r 'Layer          = Text---   CommonAttrElf r 'Matrix         = Matrix 3 3 r---   CommonAttrElf r Pin             = PinType---   CommonAttrElf r Transformations = TransformationTypes---- genDefunSymbols [''CommonAttrElf]----- type CommonAttributes r =---   Attributes (CommonAttrElfSym1 r) [ 'Layer, 'Matrix, Pin, Transformations ]------------------------------------------------------------------------------------- Text Attributes---- these Attributes are speicifc to IpeObjects representing TextLabels and--- MiniPages. The same structure as for the `CommonAttributes' applies here.---- | TODO------------------------------------------------------------------------------------- | Symbol Attributes---- | The optional Attributes for a symbol--- data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size---                              deriving (Show,Eq)--newtype IpeSize  r = IpeSize  (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable)-newtype IpePen   r = IpePen   (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable)----- -- | And the corresponding types--- type family SymbolAttrElf (r :: *) (s :: SymbolAttributeUniverse) :: * where---   SymbolAttrElf r SymbolStroke = IpeColor---   SymbolAttrElf r SymbolPen    = IpePen r---   SymbolAttrElf r SymbolFill   = IpeColor---   SymbolAttrElf r Size         = IpeSize r---- genDefunSymbols [''SymbolAttrElf]----- type SymbolAttributes r = [SymbolStroke, SymbolFill, SymbolPen, Size]---- type SymbolAttributes r =---   Attributes (SymbolAttrElfSym1 r) [SymbolStroke, SymbolFill, SymbolPen, Size]------------------------------------------------------------------------------------ | Path Attributes---- | Possible attributes for a path--- data PathAttributeUniverse = Stroke | Fill | Dash | Pen | LineCap | LineJoin---                            | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient---                            deriving (Show,Eq)----- | Possible values for Dash-data IpeDash r = DashNamed Text-               | DashPattern [r] r-               deriving (Show,Eq,Functor,Foldable,Traversable)---- | Allowed Fill types-data FillType = Wind | EOFill deriving (Show,Read,Eq)---- | IpeOpacity, IpeTyling, and IpeGradient are all symbolic values-type IpeOpacity  = Text-type IpeTiling   = Text-type IpeGradient = Text---- | Possible values for an ipe arrow-data IpeArrow r = IpeArrow { _arrowName :: Text-                           , _arrowSize :: IpeSize r-                           } deriving (Show,Eq,Functor,Foldable,Traversable)-makeLenses ''IpeArrow--normalArrow :: IpeArrow r-normalArrow = IpeArrow "normal" (IpeSize $ Named "normal/normal")------------------------------------------------------------------------------------- | Group Attributes---- | The only group attribute is a Clip--- data GroupAttributeUniverse = Clip deriving (Show,Read,Eq,Ord)---- A clipping path is a Path. Which is defined in Data.Geometry.Ipe.Types. To--- avoid circular imports, we define GroupAttrElf and GroupAttribute there.------------------------------------------------------------------------------------- * Attribute names in Ipe----- | For the types representing attribute values we can get the name/key to use--- when serializing to ipe.-class IpeAttrName (a :: AttributeUniverse) where-  attrName :: proxy a -> Text---- CommonAttributeUnivers-instance IpeAttrName Layer           where attrName _ = "layer"-instance IpeAttrName Matrix          where attrName _ = "matrix"-instance IpeAttrName Pin             where attrName _ = "pin"-instance IpeAttrName Transformations where attrName _ = "transformations"---- IpeSymbolAttributeUniversre-instance IpeAttrName Stroke       where attrName _ = "stroke"-instance IpeAttrName Fill         where attrName _ = "fill"-instance IpeAttrName Pen          where attrName _ = "pen"-instance IpeAttrName Size         where attrName _ = "size"---- PathAttributeUniverse-instance IpeAttrName Dash       where attrName _ = "dash"-instance IpeAttrName LineCap    where attrName _ = "cap"-instance IpeAttrName LineJoin   where attrName _ = "join"-instance IpeAttrName FillRule   where attrName _ = "fillrule"-instance IpeAttrName Arrow      where attrName _ = "arrow"-instance IpeAttrName RArrow     where attrName _ = "rarrow"-instance IpeAttrName Opacity    where attrName _ = "opacity"-instance IpeAttrName Tiling     where attrName _ = "tiling"-instance IpeAttrName Gradient   where attrName _ = "gradient"---- GroupAttributeUniverse-instance IpeAttrName Clip     where attrName _ = "clip"----- -- | Function that states that all elements in xs satisfy a given constraint c--- type family AllSatisfy (c :: k -> Constraint) (xs :: [k]) :: Constraint where---   AllSatisfy c '[] = ()---   AllSatisfy c (x ': xs) = (c x, AllSatisfy c xs)----- | Writing Attribute names-writeAttrNames           :: AllConstrained IpeAttrName rs => Rec f rs -> Rec (Const Text) rs-writeAttrNames RNil      = RNil-writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs-  where-    write''   :: forall f s. IpeAttrName s => f s -> Text-    write'' _ = attrName (Proxy :: Proxy s)--------------------------------------------------------------------------------------

@@ -1,120 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.Color--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Data type for representing colors in ipe as well as the colors available in--- the standard ipe stylesheet.-------------------------------------------------------------------------------------module Data.Geometry.Ipe.Color where--import Data.Colour.SRGB (RGB(..))-import Data.Geometry.Ipe.Value-import Data.Text-import Data.Traversable-----------------------------------------------------------------------------------newtype IpeColor r = IpeColor (IpeValue (RGB r)) deriving (Show,Read,Eq)--instance Ord r => Ord (IpeColor r) where-  (IpeColor c) `compare` (IpeColor c') = fmap f c `compare` fmap f c'-    where-      f (RGB r g b) = (r,g,b)--instance Functor IpeColor where-  fmap = fmapDefault-instance Foldable IpeColor where-  foldMap = foldMapDefault-instance Traversable IpeColor where-  traverse f (IpeColor v) = IpeColor <$> traverse traverseRGB v-    where-      traverseRGB (RGB r g b) = RGB <$> f r <*> f g <*> f b---- | Creates a named color-named :: Text -> IpeColor r-named = IpeColor . Named------------------------------------------------------------------------------------- * Basic Named colors--red :: IpeColor r-red = named "red"--green :: IpeColor r-green = named "green"--blue :: IpeColor r-blue = named "blue"--yellow :: IpeColor r-yellow = named "yellow"--orange :: IpeColor r-orange = named "orange"--gold :: IpeColor r-gold = named "gold"--purple :: IpeColor r-purple = named "purple"--gray :: IpeColor r-gray = named "gray"--brown :: IpeColor r-brown = named "brown"--navy :: IpeColor r-navy = named "navy"--pink :: IpeColor r-pink = named "pink"--seagreen :: IpeColor r-seagreen = named "seagreen"--turquoise :: IpeColor r-turquoise = named "turquoise"--violet :: IpeColor r-violet = named "violet"--darkblue :: IpeColor r-darkblue = named "darkblue"--darkcyan :: IpeColor r-darkcyan = named "darkcyan"--darkgray :: IpeColor r-darkgray = named "darkgray"--darkgreen :: IpeColor r-darkgreen = named "darkgreen"--darkmagenta :: IpeColor r-darkmagenta = named "darkmagenta"--darkorange :: IpeColor r-darkorange = named "darkorange"--darkred :: IpeColor r-darkred = named "darkred"--lightblue :: IpeColor r-lightblue = named "lightblue"--lightcyan :: IpeColor r-lightcyan = named "lightcyan"--lightgray :: IpeColor r-lightgray = named "lightgray"--lightgreen :: IpeColor r-lightgreen = named "lightgreen"--lightyellow :: IpeColor r-lightyellow = named "lightyellow"

@@ -1,346 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}-module Data.Geometry.Ipe.Content(-    Image(Image), imageData, rect-  , TextLabel(..)-  , MiniPage(..), width--  , IpeSymbol(Symbol), symbolPoint, symbolName--  , Path(Path), pathSegments-  , PathSegment(..)--  , Group(Group), groupItems---  , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath-  , IpeObject'-  , ipeObject', ToObject(..)--  , IpeAttributes-  , Attributes', AttributesOf, AttrMap, AttrMapSym1-  , attributes, traverseIpeAttrs-  , commonAttributes--  , flattenGroups-  ) where--import           Control.Lens hiding (views)-import           Data.Bitraversable-import           Data.Ext-import           Data.Geometry.Box (Rectangle)-import qualified Data.Geometry.Ipe.Attributes as AT-import           Data.Geometry.Ipe.Attributes hiding (Matrix)-import           Data.Geometry.Ipe.Color-import           Data.Geometry.Ipe.Layer-import           Data.Geometry.Ipe.Path-import           Data.Geometry.Matrix-import           Data.Geometry.Point-import           Data.Geometry.Properties-import           Data.Geometry.Transformation-import           Data.Proxy-import           Data.Singletons.TH (genDefunSymbols)-import           Data.Text (Text)-import           Data.Traversable-import           Data.Vinyl hiding (Label)-import           Data.Vinyl.TypeLevel (AllConstrained)------------------------------------------------------------------------------------- | Image Objects--data Image r = Image { _imageData :: ()-                     , _rect      :: Rectangle () r-                     } deriving (Show,Eq,Ord)-makeLenses ''Image--type instance NumType   (Image r) = r-type instance Dimension (Image r) = 2--instance Fractional r => IsTransformable (Image r) where-  transformBy t = over rect (transformBy t)--instance Functor Image where-  fmap = fmapDefault-instance Foldable Image where-  foldMap = foldMapDefault-instance Traversable Image where-  traverse f (Image d r) = Image d <$> bitraverse pure f r------------------------------------------------------------------------------------- | Text Objects--data TextLabel r = Label Text (Point 2 r)-                 deriving (Show,Eq,Ord,Functor,Foldable,Traversable)--data MiniPage r = MiniPage Text (Point 2 r) r-                 deriving (Show,Eq,Ord,Functor,Foldable,Traversable)--type instance NumType   (TextLabel r) = r-type instance Dimension (TextLabel r) = 2--type instance NumType   (MiniPage r) = r-type instance Dimension (MiniPage r) = 2--instance Fractional r => IsTransformable (TextLabel r) where-  transformBy t (Label txt p) = Label txt (transformBy t p)--instance Fractional r => IsTransformable (MiniPage r) where-  transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w--width                  :: MiniPage t -> t-width (MiniPage _ _ w) = w------------------------------------------------------------------------------------- | Ipe Symbols, i.e. Points---- | A symbol (point) in ipe-data IpeSymbol r = Symbol { _symbolPoint :: Point 2 r-                          , _symbolName  :: Text-                          }-                 deriving (Show,Eq,Ord,Functor,Foldable,Traversable)-makeLenses ''IpeSymbol--type instance NumType   (IpeSymbol r) = r-type instance Dimension (IpeSymbol r) = 2--instance Fractional r => IsTransformable (IpeSymbol r) where-  transformBy t = over symbolPoint (transformBy t)------ | Example of an IpeSymbol. I.e. A symbol that expresses that the size is 'large'--- sizeSymbol :: Attributes (AttrMapSym1 r) (SymbolAttributes r)--- sizeSymbol = attr SSize (IpeSize $ Named "large")-------------------------------------------------------------------------------------- * Paths are in a separate module------------------------------------------------------------------------------------- * Attribute Mapping----- | The mapping between the labels of the the attributes and the types of the--- attributes with these labels. For example, the 'Matrix' label/attribute should--- have a value of type 'Matrix 3 3 r'.-type family AttrMap (r :: *) (l :: AttributeUniverse) :: * where-  AttrMap r 'Layer          = LayerName-  AttrMap r AT.Matrix       = Matrix 3 3 r-  AttrMap r Pin             = PinType-  AttrMap r Transformations = TransformationTypes--  AttrMap r Stroke = IpeColor r-  AttrMap r Pen    = IpePen r-  AttrMap r Fill   = IpeColor r-  AttrMap r Size   = IpeSize r--  AttrMap r Dash     = IpeDash r-  AttrMap r LineCap  = Int-  AttrMap r LineJoin = Int-  AttrMap r FillRule = FillType-  AttrMap r Arrow    = IpeArrow r-  AttrMap r RArrow   = IpeArrow r-  AttrMap r Opacity  = IpeOpacity-  AttrMap r Tiling   = IpeTiling-  AttrMap r Gradient = IpeGradient--  AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess--genDefunSymbols [''AttrMap]--------------------------------------------------------------------------------------- | For the types representing attribute values we can get the name/key to use--- when serializing to ipe.-class TraverseIpeAttr (a :: AttributeUniverse) where-  traverseIpeAttr :: Applicative h-                  => (r -> h s) -> Attr (AttrMapSym1 r) a -> h (Attr (AttrMapSym1 s) a)--  -- attrName :: proxy a -> Text---- CommonAttributeUnivers-instance TraverseIpeAttr Layer           where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr AT.Matrix       where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr Pin             where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr Transformations where traverseIpeAttr _ = pureAttr---- -- IpeSymbolAttributeUniversre-instance TraverseIpeAttr Stroke       where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr Fill         where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr Pen          where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr Size         where traverseIpeAttr f = traverseAttr (traverse f)---- -- PathAttributeUniverse-instance TraverseIpeAttr Dash       where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr LineCap    where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr LineJoin   where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr FillRule   where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr Arrow      where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr RArrow     where traverseIpeAttr f = traverseAttr (traverse f)-instance TraverseIpeAttr Opacity    where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr Tiling     where traverseIpeAttr _ = pureAttr-instance TraverseIpeAttr Gradient   where traverseIpeAttr _ = pureAttr----- GroupAttributeUniverse-instance TraverseIpeAttr Clip     where traverseIpeAttr f = traverseAttr (traverse f)------------------------------------------------------------------------------------- | Groups and Objects------------------------------------------------------------------------------------- | Group Attributes---- -- | Now that we know what a Path is we can define the Attributes of a Group.--- type family GroupAttrElf (r :: *) (s :: GroupAttributeUniverse) :: * where---   GroupAttrElf r Clip = Path r -- strictly we event want this to be a closed path I guess---- genDefunSymbols [''GroupAttrElf]---- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip]----- | A group is essentially a list of IpeObjects.-newtype Group r = Group [IpeObject r] deriving (Show,Eq,Functor,Foldable,Traversable)--type instance NumType   (Group r) = r-type instance Dimension (Group r) = 2--instance Fractional r => IsTransformable (Group r) where-  transformBy t (Group s) = Group $ fmap (transformBy t) s---type family AttributesOf (t :: * -> *) :: [AttributeUniverse] where-  AttributesOf Group     = GroupAttributes-  AttributesOf Image     = CommonAttributes-  AttributesOf TextLabel = CommonAttributes-  AttributesOf MiniPage  = CommonAttributes-  AttributesOf IpeSymbol = SymbolAttributes-  AttributesOf Path      = PathAttributes----- | Attributes' :: * -> [AttributeUniverse] -> *-type Attributes' r = Attributes (AttrMapSym1 r)--type IpeAttributes g r = Attributes' r (AttributesOf g)----- | An IpeObject' is essentially the oject ogether with its attributes-type IpeObject' g r = g r :+ IpeAttributes g r--attributes :: Lens' (IpeObject' g r) (IpeAttributes g r)-attributes = extra---- | traverse for ipe attributes-traverseIpeAttrs               :: ( Applicative f-                                  , AllConstrained TraverseIpeAttr (AttributesOf g)-                                  ) => proxy g -> (r -> f s) -> IpeAttributes g r -> f (IpeAttributes g s)-traverseIpeAttrs _ f (Attrs ats) = fmap Attrs . traverseIpeAttrs' f $ ats--traverseIpeAttrs'   :: ( Applicative f-                       , AllConstrained TraverseIpeAttr ats-                       )-                    => (r -> f s)-                    -> Rec (Attr (AttrMapSym1 r)) ats-                    -> f (Rec (Attr (AttrMapSym1 s)) ats)-traverseIpeAttrs' f = \case-  RNil        -> pure RNil-  (a :& ats') -> (:&) <$> traverseIpeAttr f a <*> traverseIpeAttrs' f ats'---data IpeObject r =-    IpeGroup     (IpeObject' Group     r)-  | IpeImage     (IpeObject' Image     r)-  | IpeTextLabel (IpeObject' TextLabel r)-  | IpeMiniPage  (IpeObject' MiniPage  r)-  | IpeUse       (IpeObject' IpeSymbol r)-  | IpePath      (IpeObject' Path      r)---traverseIpeObject'              :: forall g r f s. ( Applicative f-                                                   , Traversable g-                                                   , AllConstrained TraverseIpeAttr (AttributesOf  g)-                                                   )-                                => (r -> f s) -> IpeObject' g r -> f (IpeObject' g s)-traverseIpeObject' f (i :+ ats) = (:+) <$> traverse f i <*> traverseIpeAttrs (Proxy @g) f ats--instance Functor IpeObject where-  fmap = fmapDefault-instance Foldable IpeObject where-  foldMap = foldMapDefault-instance Traversable IpeObject where-  traverse f = \case-    IpeGroup g     -> IpeGroup     <$> traverseIpeObject' f g-    IpeImage i     -> IpeImage     <$> traverseIpeObject' f i-    IpeTextLabel l -> IpeTextLabel <$> traverseIpeObject' f l-    IpeMiniPage p  -> IpeMiniPage  <$> traverseIpeObject' f p-    IpeUse u       -> IpeUse       <$> traverseIpeObject' f u-    IpePath p      -> IpePath      <$> traverseIpeObject' f p---deriving instance (Show r) => Show (IpeObject r)--- deriving instance (Read r) => Read (IpeObject r)-deriving instance (Eq r)   => Eq   (IpeObject r)--type instance NumType   (IpeObject r) = r-type instance Dimension (IpeObject r) = 2--makePrisms ''IpeObject--groupItems :: Lens (Group r) (Group s) [IpeObject r] [IpeObject s]-groupItems = lens (\(Group xs) -> xs) (const Group)--class ToObject i where-  mkIpeObject :: IpeObject' i r -> IpeObject r--instance ToObject Group      where mkIpeObject = IpeGroup-instance ToObject Image      where mkIpeObject = IpeImage-instance ToObject TextLabel  where mkIpeObject = IpeTextLabel-instance ToObject MiniPage   where mkIpeObject = IpeMiniPage-instance ToObject IpeSymbol  where mkIpeObject = IpeUse-instance ToObject Path       where mkIpeObject = IpePath--instance Fractional r => IsTransformable (IpeObject r) where-  transformBy t (IpeGroup i)     = IpeGroup     $ i&core %~ transformBy t-  transformBy t (IpeImage i)     = IpeImage     $ i&core %~ transformBy t-  transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t-  transformBy t (IpeMiniPage i)  = IpeMiniPage  $ i&core %~ transformBy t-  transformBy t (IpeUse i)       = IpeUse       $ i&core %~ transformBy t-  transformBy t (IpePath i)      = IpePath      $ i&core %~ transformBy t---- | Shorthand for constructing ipeObjects-ipeObject'     :: ToObject i => i r -> IpeAttributes i r -> IpeObject r-ipeObject' i a = mkIpeObject $ i :+ a--commonAttributes :: Lens' (IpeObject r) (Attributes (AttrMapSym1 r) CommonAttributes)-commonAttributes = lens (Attrs . g) (\x (Attrs a) -> s x a)-  where-    select :: (CommonAttributes ⊆ AttributesOf g) =>-              Lens' (IpeObject' g r) (Rec (Attr (AttrMapSym1 r)) CommonAttributes)-    select = attributes.unAttrs.rsubset--    g (IpeGroup i)     = i^.select-    g (IpeImage i)     = i^.select-    g (IpeTextLabel i) = i^.select-    g (IpeMiniPage i)  = i^.select-    g (IpeUse i)       = i^.select-    g (IpePath i)      = i^.select--    s (IpeGroup i)     a = IpeGroup     $ i&select .~ a-    s (IpeImage i)     a = IpeImage     $ i&select .~ a-    s (IpeTextLabel i) a = IpeTextLabel $ i&select .~ a-    s (IpeMiniPage i)  a = IpeMiniPage  $ i&select .~ a-    s (IpeUse i)       a = IpeUse       $ i&select .~ a-    s (IpePath i)      a = IpePath      $ i&select .~ a---- | collect all non-group objects-flattenGroups :: [IpeObject r] -> [IpeObject r]-flattenGroups = concatMap flattenGroups'-  where-    flattenGroups'                              :: IpeObject r -> [IpeObject r]-    flattenGroups' (IpeGroup (Group gs :+ ats)) =-      map (applyAts ats) . concatMap flattenGroups' $ gs-        where-          applyAts _ = id-    flattenGroups' o                            = [o]

@@ -1,264 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.FromIpe--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Functions that help reading geometric values from ipe images.-------------------------------------------------------------------------------------module Data.Geometry.Ipe.FromIpe(-  -- * Individual readers-    _asPoint-  , _asLineSegment-  , _asRectangle-  , _asTriangle--  , _asPolyLine-  , _asSomePolygon, _asSimplePolygon, _asMultiPolygon--  -- * Dealing with Attributes-  , _withAttrs--  -- * Default readers-  , HasDefaultFromIpe(..)--  -- * Reading all elements of a particular type-  , readAll, readAllFrom-  ) where--import           Control.Lens hiding (Simple)-import           Data.Ext-import           Data.Geometry.Ball-import           Data.Geometry.Box-import           Data.Geometry.Ellipse (Ellipse, _EllipseCircle)-import           Data.Geometry.Ipe.Path-import           Data.Geometry.Ipe.Reader-import           Data.Geometry.Ipe.Types-import           Data.Geometry.LineSegment-import           Data.Geometry.Point-import qualified Data.Geometry.PolyLine as PolyLine-import           Data.Geometry.Polygon-import           Data.Geometry.Properties-import           Data.Geometry.Triangle-import qualified Data.LSeq as LSeq-import           Data.List.NonEmpty (NonEmpty(..))------------------------------------------------------------------------------------- $setup--- >>> :set -XOverloadedStrings--- >>> import Data.Geometry.Ipe.Attributes--- >>> import Data.Geometry.Ipe.Color(IpeColor(..))--- >>> import Data.Geometry.Point--- >>> :{--- let testPath :: Path Int---     testPath = Path . fromSingleton  . PolyLineSegment---              . PolyLine.fromPoints . map ext---              $ [ origin, Point2 10 10, Point2 200 100 ]---     testPathAttrs :: IpeAttributes Path Int---     testPathAttrs = attr SStroke (IpeColor "red")---     testObject :: IpeObject Int---     testObject = IpePath (testPath :+ testPathAttrs)--- :}------ | Extracts the point from a Symbol. When creating a symbol this--- creates a disk that supports a stroke color.-_asPoint :: Prism' (IpeSymbol r) (Point 2 r)-_asPoint = prism' (flip Symbol "mark/disk(sx)") (Just . view symbolPoint)---- | Try to convert a path into a line segment, fails if the path is not a line--- segment or a polyline with more than two points.-------_asLineSegment :: Prism' (Path r) (LineSegment 2 () r)-_asLineSegment = prism' seg2path path2seg-  where-    seg2path   = review _asPolyLine . PolyLine.fromLineSegment-    path2seg p = PolyLine.asLineSegment' =<< preview _asPolyLine p---- | Convert to a polyline. Ignores all non-polyline parts------ >>> testPath ^? _asPolyLine--- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])})-_asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r)-_asPolyLine = prism' poly2path path2poly-  where-    poly2path = Path . fromSingleton  . PolyLineSegment-    path2poly = preview (pathSegments.traverse._PolyLineSegment)-    -- TODO: Check that the path actually is a polyline, rather-    -- than ignoring everything that does not fit---- | Convert to a simple polygon-_asSimplePolygon :: Prism' (Path r) (Polygon Simple () r)-_asSimplePolygon = _asSomePolygon._Left----- | Tries to convert a path into a rectangle.-_asRectangle :: forall r. (Num r, Ord r) => Prism' (Path r) (Rectangle () r)-_asRectangle = prism' rectToPath pathToRect-  where-    rectToPath (corners -> Corners a b c d) = review _asSimplePolygon . fromPoints $ [a,b,c,d]-    pathToRect p = p^?_asSimplePolygon >>= asRect--    asRect    :: SimplePolygon () r -> Maybe (Rectangle () r)-    asRect pg = case pg^..outerBoundaryVector.traverse of-        [a,b,c,d] | isH a b && isV b c && isH c d && isV d a -> Just (boundingBoxList' [a,c])-        [a,b,c,d] | isV a b && isH b c && isV c d && isH d a -> Just (boundingBoxList' [a,c])-        _                                                    -> Nothing--    isH (p :+ _) (q :+ _) = p^.xCoord == q^.xCoord-    isV (p :+ _) (q :+ _) = p^.yCoord == q^.yCoord----- | Convert to a triangle-_asTriangle :: Prism' (Path r) (Triangle 2 () r)-_asTriangle = prism' triToPath path2tri-  where-    triToPath (Triangle p q r) = polygonToPath . unsafeFromPoints . map (&extra .~ ()) $ [p,q,r]-    path2tri p = case p^..pathSegments.traverse._PolygonPath of-                    []   -> Nothing-                    [pg] -> case polygonVertices pg of-                              (a :| [b,c]) -> Just $ Triangle a b c-                              _            -> Nothing-                    _    -> Nothing---  -- an ellipse is an affine transformation of the unit disk----- (Disk origin 1) (Vector2 1 1)--_asEllipse :: Prism' (Path r) (Ellipse r)-_asEllipse = prism' toPath toEllipse-  where-    toPath      = Path . fromSingleton  . EllipseSegment-    toEllipse p = case p^..pathSegments.traverse._EllipseSegment of-                    [e] -> Just e-                    _   -> Nothing--_asCircle :: (Floating r, Eq r) => Prism' (Path r) (Circle () r)-_asCircle = _asEllipse._EllipseCircle--- FIXME: For reading we should not need the floating constraint!--_asDisk :: (Floating r, Eq r) => Prism' (Path r) (Disk () r)-_asDisk = _asCircle.from _DiskCircle----- | Convert to a multipolygon-_asMultiPolygon :: Prism' (Path r) (MultiPolygon () r)-_asMultiPolygon = _asSomePolygon._Right---- _asPolygon :: Prism' (Path r) (forall t. Polygon t () r)--- _asPolygon = prism' polygonToPath (fmap (either id id) . pathToPolygon)--_asSomePolygon :: Prism' (Path r) (SomePolygon () r)-_asSomePolygon = prism' embed pathToPolygon-  where-    embed     = either polygonToPath polygonToPath---polygonToPath                      :: Polygon t () r -> Path r-polygonToPath pg@SimplePolygon{}   = Path . fromSingleton . PolygonPath $ pg-polygonToPath (MultiPolygon vs hs) = Path . LSeq.fromNonEmpty . fmap PolygonPath-                                   $ vs :| hs---pathToPolygon   :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r))-pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of-                    []    -> Nothing-                    [pg]  -> Just . Left  $ pg-                    vs:hs -> Just . Right $ MultiPolygon vs hs------------------------------------------------------------------------------------------- | Use the first prism to select the ipe object to depicle with, and the second--- how to select the geometry object from there on. Then we can select the geometry--- object, directly with its attributes here.------ >>> testObject ^? _withAttrs _IpePath _asPolyLine--- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})-_withAttrs       :: Prism' (IpeObject r) (i r :+ IpeAttributes i r) -> Prism' (i r) g-                 -> Prism' (IpeObject r) (g :+ IpeAttributes i r)-_withAttrs po pg = prism' g2o o2g-  where-    g2o    = review po . over core (review pg)-    o2g o  = preview po o >>= \(i :+ ats) -> (:+ ats) <$> preview pg i-------- instance HasDefaultIpeObject Path where---   defaultIpeObject' = _IpePath----- class HasDefaultFromIpe g where---   type DefaultFromIpe g :: * -> *---   defaultIpeObject :: proxy g -> Prism' (IpeObject r) (DefaultFromIpe g r :+ IpeAttributes (DefaultFromIpe g) r)---   defaultFromIpe   :: proxy g -> Prism' (DefaultFromIpe g (NumType g)) g---class HasDefaultFromIpe g where-  type DefaultFromIpe g :: * -> *-  defaultFromIpe :: (r ~ NumType g)-                 => Prism' (IpeObject r) (g :+ IpeAttributes (DefaultFromIpe g) r)--instance HasDefaultFromIpe (Point 2 r) where-  type DefaultFromIpe (Point 2 r) = IpeSymbol-  defaultFromIpe = _withAttrs _IpeUse _asPoint-    where---instance HasDefaultFromIpe (LineSegment 2 () r) where-  type DefaultFromIpe (LineSegment 2 () r) = Path-  defaultFromIpe = _withAttrs _IpePath _asLineSegment--instance HasDefaultFromIpe (Ellipse r) where-  type DefaultFromIpe (Ellipse r) = Path-  defaultFromIpe = _withAttrs _IpePath _asEllipse--instance (Floating r, Eq r) => HasDefaultFromIpe (Circle () r) where-  type DefaultFromIpe (Circle () r) = Path-  defaultFromIpe = _withAttrs _IpePath _asCircle--instance (Floating r, Eq r) => HasDefaultFromIpe (Disk () r) where-  type DefaultFromIpe (Disk () r) = Path-  defaultFromIpe = _withAttrs _IpePath _asDisk--instance HasDefaultFromIpe (PolyLine.PolyLine 2 () r) where-  type DefaultFromIpe (PolyLine.PolyLine 2 () r) = Path-  defaultFromIpe = _withAttrs _IpePath _asPolyLine---instance HasDefaultFromIpe (SimplePolygon () r) where-  type DefaultFromIpe (SimplePolygon () r) = Path-  defaultFromIpe = _withAttrs _IpePath _asSimplePolygon--instance HasDefaultFromIpe (MultiPolygon () r) where-  type DefaultFromIpe (MultiPolygon () r) = Path-  defaultFromIpe = _withAttrs _IpePath _asMultiPolygon----- | Read all g's from some ipe page(s).-readAll   :: forall g r. (HasDefaultFromIpe g, r ~ NumType g)-          => IpePage r -> [g :+ IpeAttributes (DefaultFromIpe g) r]-readAll p = p^..content.traverse.defaultFromIpe---- | Convenience function from reading all g's from an ipe file. If there--- is an error reading or parsing the file the error is "thrown away".-readAllFrom    :: (HasDefaultFromIpe g, r ~ NumType g, Coordinate r, Eq r)-               => FilePath -> IO [g :+ IpeAttributes (DefaultFromIpe g) r]-readAllFrom fp = foldMap readAll <$> readSinglePageFile fp--fromSingleton :: a -> LSeq.LSeq 1 a-fromSingleton = LSeq.fromNonEmpty . (:| [])

@@ -1,282 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.IpeOut--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Functions that help drawing geometric values in ipe. An "IpeOut" is--- essenitally a function that converts a geometric type g into an IpeObject.------ We also proivde a "HasDefaultIpeOut" typeclass that defines a default--- conversion function from a geometry type g to an ipe type.-------------------------------------------------------------------------------------module Data.Geometry.Ipe.IpeOut where---import           Control.Lens hiding (Simple)-import           Data.Bifunctor-import           Data.Ext-import           Data.Foldable (toList)-import           Data.Geometry.Ball-import           Data.Geometry.Boundary-import           Data.Geometry.Box-import           Data.Geometry.Ellipse (Ellipse, circleToEllipse)-import           Data.Geometry.HalfLine-import           Data.Geometry.Ipe.Attributes-import           Data.Geometry.Ipe.Color (IpeColor(..))-import           Data.Geometry.Ipe.FromIpe-import           Data.Geometry.Ipe.Types-import           Data.Geometry.Line-import           Data.Geometry.LineSegment-import           Data.Geometry.Point-import           Data.Geometry.PolyLine (PolyLine,fromLineSegment)-import           Data.Geometry.Polygon-import           Data.Geometry.Polygon.Convex-import           Data.Geometry.Properties-import qualified Data.LSeq as LSeq-import           Data.List.NonEmpty (NonEmpty(..))-import           Data.Maybe (fromMaybe)-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Vinyl (Rec(..))-import           Data.Vinyl.CoRec-import           Linear.Affine ((.+^))-------------------------------------------------------------------------------------- $setup--- >>> :set -XOverloadedStrings--- >>> :{--- let myPolygon = fromPoints . map ext $ [origin, Point2 10 10, Point2 100 200]--- :}------------------------------------------------------------------------------------- * The IpeOut type and the default combinator to use it--type IpeOut g i r = g -> IpeObject' i r----- | Add attributes to an IpeObject'-(!)       :: IpeObject' i r -> IpeAttributes i r -> IpeObject' i r-(!) i ats = i&extra %~ (<> ats)---- | Render an ipe object--------- >>> :{---   iO $ defIO myPolygon ! attr SFill (IpeColor "blue")---                        ! attr SLayer "alpha"---                        ! attr SLayer "beta"--- :}--- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "blue"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})------ >>> :{---   iO $ ipeGroup [ iO $ ipePolygon myPolygon ! attr SFill (IpeColor "red")---                 ] ! attr SLayer "alpha"--- :}--- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr})----iO :: ToObject i => IpeObject' i r -> IpeObject r-iO = mkIpeObject---- | Render to an ipe object using the defIO IpeOut--------- >>> :{---   iO'' myPolygon $  attr SFill (IpeColor "red")---                  <> attr SLayer "alpha"---                  <> attr SLayer "beta"--- :}--- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})------ >>> iO'' [ myPolygon , myPolygon ] $ attr SLayer "alpha"--- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}),IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr})-iO''       :: ( HasDefaultIpeOut g, NumType g ~ r-             , DefaultIpeOut g ~ i, ToObject i-             ) => g -> IpeAttributes i r-           -> IpeObject r-iO'' g ats = iO $ defIO g ! ats---- | generate an ipe object without any specific attributes-iO' :: HasDefaultIpeOut g => g -> IpeObject (NumType g)-iO' = iO . defIO------------------------------------------------------------------------------------- * Default Conversions---- | Class that specifies a default conversion from a geometry type g into an--- ipe object.-class ToObject (DefaultIpeOut g) => HasDefaultIpeOut g where-  type DefaultIpeOut g :: * -> *--  defIO :: IpeOut g (DefaultIpeOut g) (NumType g)--instance (HasDefaultIpeOut g, a ~ IpeAttributes (DefaultIpeOut g) (NumType g))-        => HasDefaultIpeOut (g :+ a) where-  type DefaultIpeOut (g :+ a) = DefaultIpeOut g-  defIO (g :+ ats) = defIO g ! ats--instance HasDefaultIpeOut a => HasDefaultIpeOut [a] where-  type DefaultIpeOut [a] = Group-  defIO = ipeGroup . map (iO .  defIO)--instance HasDefaultIpeOut (Point 2 r) where-  type DefaultIpeOut (Point 2 r) = IpeSymbol-  defIO = ipeDiskMark--instance HasDefaultIpeOut (LineSegment 2 p r) where-  type DefaultIpeOut (LineSegment 2 p r) = Path-  defIO = ipeLineSegment--instance HasDefaultIpeOut (PolyLine 2 p r) where-  type DefaultIpeOut (PolyLine 2 p r) = Path-  defIO = ipePolyLine--instance (Fractional r, Ord r) => HasDefaultIpeOut (Line 2 r) where-  type DefaultIpeOut (Line 2 r) = Path-  defIO = ipeLine--instance (Fractional r, Ord r) => HasDefaultIpeOut (HalfLine 2 r) where-  type DefaultIpeOut (HalfLine 2 r) = Path-  defIO = ipeHalfLine--instance HasDefaultIpeOut (Polygon t p r) where-  type DefaultIpeOut (Polygon t p r) = Path-  defIO = ipePolygon--instance HasDefaultIpeOut (SomePolygon p r) where-  type DefaultIpeOut (SomePolygon p r) = Path-  defIO = either defIO defIO--instance HasDefaultIpeOut (ConvexPolygon p r) where-  type DefaultIpeOut (ConvexPolygon p r) = Path-  defIO = defIO . view simplePolygon--instance HasDefaultIpeOut (Ellipse r) where-  type DefaultIpeOut (Ellipse r) = Path-  defIO = ipeEllipse--instance Floating r => HasDefaultIpeOut (Disk p r) where-  type DefaultIpeOut (Disk p r) = Path-  defIO = ipeDisk--instance Floating r => HasDefaultIpeOut (Circle p r) where-  type DefaultIpeOut (Circle p r) = Path-  defIO = ipeCircle--instance Num r => HasDefaultIpeOut (Rectangle p r) where-  type DefaultIpeOut (Rectangle p r) = Path-  defIO = ipeRectangle------------------------------------------------------------------------------------- * Point Converters--ipeMark     :: Text -> IpeOut (Point 2 r) IpeSymbol r-ipeMark n p = Symbol p n :+ mempty--ipeDiskMark :: IpeOut (Point 2 r) IpeSymbol r-ipeDiskMark = ipeMark "mark/disk(sx)"------------------------------------------------------------------------------------- * Path Converters---- | Size of the default bounding box used to clip lines and--- half-lines in the default IpeOuts.-defaultBox :: Num r => Rectangle () r-defaultBox = let z  = 1000-                 z' = negate z-             in box (ext $ Point2 z' z') (ext $ Point2 z z)---- | Renders a line as a Path. The line is clipped to the 'defaultBox'-ipeLine :: (Ord r, Fractional r) => IpeOut (Line 2 r) Path r-ipeLine = ipeLineIn defaultBox---- | Renders the line in the given box.------ pre: the intersection of the box with the line is non-empty-ipeLineIn        :: forall p r. (Ord r, Fractional r)-                 => Rectangle p r -> IpeOut (Line 2 r) Path r-ipeLineIn bBox l = match (l `intersect` bBox) $-     H (\NoIntersection    -> error "ipeLineIn: precondition failed, no intersection")-  :& H (\(_p :: Point 2 r) -> error "ipeLineIn: precondition failed, single point")-  :& H ipeLineSegment-  :& RNil---- | Renders an Halfine.--------- pre: the intersection of the box with the line is non-empty-ipeHalfLine :: (Ord r, Fractional r) => IpeOut (HalfLine 2 r) Path r-ipeHalfLine = ipeHalfLineIn defaultBox---- | Renders the HalfLine in the given box.------ pre: the intersection of the box with the line is non-empty-ipeHalfLineIn        :: forall p r. (Ord r, Fractional r)-                     => Rectangle p r -> IpeOut (HalfLine 2 r) Path r-ipeHalfLineIn bBox l = match (l `intersect` bBox) $-     H (\NoIntersection    -> error "ipeHalfLineIn: precondition failed, no intersection")-  :& H (\(_p :: Point 2 r) -> error "ipeHalfLineIn: precondition failed, single point")-  :& H ipeLineSegment-  :& RNil--ipeLineSegment   :: IpeOut (LineSegment 2 p r) Path r-ipeLineSegment s = (path . pathSegment $ s) :+ mempty--ipePolyLine   :: IpeOut (PolyLine 2 p r) Path r-ipePolyLine p = (path . PolyLineSegment . first (const ()) $ p) :+ mempty--ipeEllipse :: IpeOut (Ellipse r) Path r-ipeEllipse = \e -> path (EllipseSegment e) :+ mempty--ipeCircle :: Floating r => IpeOut (Circle p r) Path r-ipeCircle = ipeEllipse . circleToEllipse--ipeDisk   :: Floating r => IpeOut (Disk p r) Path r-ipeDisk d = ipeCircle (Boundary d) ! attr SFill (IpeColor "0.722 0.145 0.137")---- | Helper to construct a path from a singleton item-path :: PathSegment r -> Path r-path = Path . LSeq.fromNonEmpty . (:| [])--pathSegment :: LineSegment 2 p r -> PathSegment r-pathSegment = PolyLineSegment . fromLineSegment . first (const ())---- | Draw a polygon-ipePolygon                          :: IpeOut (Polygon t p r) Path r-ipePolygon (first (const ()) -> pg) = case pg of-               SimplePolygon{} -> pg^.re _asSimplePolygon :+ mempty-               MultiPolygon{}  -> pg^.re _asMultiPolygon  :+ mempty----- | Draw a Rectangle-ipeRectangle   :: Num r => IpeOut (Rectangle p r) Path r-ipeRectangle r = ipePolygon $ unsafeFromPoints [tl,tr,br,bl]-  where-    Corners tl tr br bl = corners r------------------------------------------------------------------------------------- * Group Converters--ipeGroup    :: Foldable f => IpeOut (f (IpeObject r)) Group r-ipeGroup xs = Group (toList xs) :+ mempty-------------------------------------------------------------------------------------- * Text Converters---- | Creates an text label-ipeLabel            :: IpeOut (Text :+ Point 2 r) TextLabel r-ipeLabel (txt :+ p) = Label txt p :+ mempty----- | Annotate an IpeOut with a label-labelled                 :: (Show lbl, NumType g ~ r, ToObject i)-                         => (g -> Point 2 r) -- ^ where to place the label-                         -> IpeOut g i r     -- ^ how to draw the geometric object-                         -> IpeOut (g :+ lbl) Group r-labelled pos f (g :+ lbl) = ipeGroup [iO $ f g, iO $ ipeLabel ((Text.pack $ show lbl) :+ pos g)]

@@ -1,13 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Geometry.Ipe.Layer(-  LayerName(LayerName), layerName-  ) where--import           Control.Lens-import           Data.Text (Text)-import           GHC.Exts------------------------------------------------------------------------------------newtype LayerName = LayerName {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString)-makeLenses ''LayerName

@@ -1,27 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Geometry.Ipe.Literal where---import Language.Haskell.TH-import Language.Haskell.TH.Quote-import qualified Data.Text as T-import qualified Data.ByteString.Char8 as C-import Text.XML.Expat.Tree--literally :: String -> Q Exp-literally = return . LitE . StringL--lit :: QuasiQuoter-lit = QuasiQuoter { quoteExp = literally-                  , quotePat = undefined-                  , quoteType = undefined-                  , quoteDec  = undefined-                  }--litFile :: QuasiQuoter-litFile = quoteFile lit---xmlLiteral :: String -> Node T.Text T.Text-xmlLiteral = either (error "xmlLiteral. error parsing xml: " . show) id-           .  parse' defaultParseOptions . C.pack

@@ -1,41 +0,0 @@-module Data.Geometry.Ipe.Matrix where--import           Control.Lens hiding (rmap)-import           Data.Ext-import qualified Data.Geometry.Ipe.Attributes as AT-import           Data.Geometry.Ipe.Attributes hiding (Matrix)-import           Data.Geometry.Ipe.Types-import           Data.Geometry.Properties-import           Data.Geometry.Transformation-import           Data.Proxy-import           Data.Vinyl hiding (Label)-------------------------------------------------------------------------------------- | Takes and applies the ipe Matrix attribute of this item.-applyMatrix'              :: ( IsTransformable (i r)-                             , AT.Matrix ∈ AttributesOf i-                             , Dimension (i r) ~ 2, r ~ NumType (i r))-                          => IpeObject' i r -> IpeObject' i r-applyMatrix' o@(i :+ ats) = maybe o (\m -> transformBy (Transformation m) i :+ ats') mm-  where-    (mm,ats') = takeAttr (Proxy :: Proxy AT.Matrix) ats---- | Applies the matrix to an ipe object if it has one.-applyMatrix                  :: Fractional r => IpeObject r -> IpeObject r-applyMatrix (IpeGroup i)     = IpeGroup . applyMatrix'-                             $ i&core.groupItems.traverse %~ applyMatrix-                             -- note that for a group we first (recursively)-                             -- apply the matrices, and then apply-                             -- the matrix of the group to its members.-applyMatrix (IpeImage i)     = IpeImage     $ applyMatrix' i-applyMatrix (IpeTextLabel i) = IpeTextLabel $ applyMatrix' i-applyMatrix (IpeMiniPage i)  = IpeMiniPage  $ applyMatrix' i-applyMatrix (IpeUse i)       = IpeUse       $ applyMatrix' i-applyMatrix (IpePath i)      = IpePath      $ applyMatrix' i--applyMatrices   :: Fractional r => IpeFile r -> IpeFile r-applyMatrices f = f&pages.traverse %~ applyMatricesPage--applyMatricesPage   :: Fractional r => IpePage r -> IpePage r-applyMatricesPage p = p&content.traverse %~ applyMatrix

@@ -1,148 +0,0 @@-{-# Language FlexibleContexts  #-}-{-# Language OverloadedStrings  #-}-module Data.Geometry.Ipe.ParserPrimitives( runP, runP'-                                         , pMany, pMany1, pChoice-                                         , pChar, pSpace, pWhiteSpace, pInteger-                                         , pNatural, pPaddedNatural-                                         , (<*><>) , (<*><)-                                         , (<***>) , (<***) , (***>)-                                         , pMaybe , pCount , pSepBy-                                         , Parser, ParseError-                                         , pNotFollowedBy-                                         ) where---import           Text.Parsec(try)-import           Text.Parsec(ParsecT, Stream)-import           Text.Parsec.Text-import           Text.ParserCombinators.Parsec hiding (Parser,try)-import qualified Data.Text as T---runP'     :: Parser a -> T.Text -> (a, T.Text)-runP' p s = case runP p s of-             Left  e -> error $ show e-             Right x -> x--runP   :: Parser a -> T.Text -> Either ParseError (a,T.Text)-runP p = parse ((,) <$> p <*> getInput) ""---------------------------------------------------------------------------------- | reexporting some standard combinators--pMany :: Parser a -> Parser [a]-pMany = many--pMany1 :: Parser a -> Parser [a]-pMany1 = many1---pChoice :: [Parser a] -> Parser a-pChoice = choice . map try---pNatural :: Parser Integer-pNatural = read <$> pMany1 digit---- | parses an integer with a prefix of zeros. Returns the total length of the--- string parced (i.e. number of digits) and the resulting antural number.-pPaddedNatural :: Parser (Int, Integer)-pPaddedNatural = (\s -> (length s, read s)) <$> pMany1 digit--pInteger :: Parser Integer-pInteger = pNatural-           <|>-           negate <$> (pChar '-' *> pNatural)--pChar :: Char -> Parser Char-pChar = char--pSpace :: Parser Char-pSpace = pChar ' '--pWhiteSpace :: Parser [Char]-pWhiteSpace = pMany1 (space <|> newline)--pMaybe :: Parser a -> Parser (Maybe a)-pMaybe = optionMaybe--pCount :: Int -> Parser a -> Parser [a]-pCount = count--pSepBy :: Parser a -> Parser b -> Parser [a]-pSepBy = sepBy----- | infix variant of notfollowed by-pNotFollowedBy :: Parser a -> Parser b -> Parser a-p `pNotFollowedBy` q = do { x <- p ; notFollowedBy' q ; return x }-    where-      -- | copy of the original notFollowedBy but replaced the error message-      -- to get rid of the Show dependency-      notFollowedBy' z     = try (do{ _ <- try z; unexpected "not followed by" }-                                    <|> return ()-                                 )--------------------------------------------------------------------------------- | Running parsers in reverse--infix 1 <*><>, <*><---- | Runs parser q ``in reverse'' on the end of the input stream-(<*><>) ::  (Reversable s, Stream s m t)-        => ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b-p <*><> q = do-  rev-  x <- q-  rev-  f <- p-  return $ f x---(<*><)   :: (Stream s m t, Reversable s)-          => ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b-p <*>< q = const <$> p <*><> q---rev :: (Reversable s, Stream s m t) => ParsecT s u m ()-rev = getInput >>= (setInput . reverseS)---- as :: Parser String--- as = many (char 'a')---- foo :: Parser String--- foo = reverse <$> (string . reverse $ "foo")---- prs :: Parser (String,String)--- prs = (,) <$> as <*>< foo'---- foo' :: Parser String--- foo' = spaces ***> foo---- (<***>) :: Parser (a -> b)--infixr 2 <***>, ***>, <***---- | run the parsers in reverse order, first q, then p-(<***>) :: Monad m => m (t -> b) -> m t -> m b-p <***> q = do-  x <- q-  f <- p-  return $ f x---- | the variants with missing brackets-(***>) :: Monad m => m a -> m b -> m b-p ***> q = (\_ s -> s) <$> p <***> q--(<***) :: Monad m => m b -> m t -> m b-p <*** q = (\s _ -> s) <$> p <***> q--class Reversable s where-  reverseS :: s -> s--instance Reversable [c] where-  reverseS = reverse--instance Reversable T.Text where-  reverseS = T.reverse

@@ -1,112 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Geometry.Ipe.Path(-    Path(Path), pathSegments-  , PathSegment(..)--  , _PolyLineSegment-  , _PolygonPath-  , _CubicBezierSegment-  , _QuadraticBezierSegment-  , _EllipseSegment-  , _ArcSegment-  , _SplineSegment-  , _ClosedSplineSegment--  , Operation(..)-  , _MoveTo-  , _LineTo-  , _CurveTo-  , _QCurveTo-  , _Ellipse-  , _ArcTo-  , _Spline-  , _ClosedSpline-  , _ClosePath-  ) where--import           Control.Lens hiding (rmap)-import           Data.Bitraversable-import           Data.Geometry.BezierSpline-import           Data.Geometry.Point-import           Data.Geometry.Ellipse(Ellipse)-import           Data.Geometry.PolyLine-import           Data.Geometry.Polygon (SimplePolygon)-import           Data.Geometry.Properties-import           Data.Geometry.Transformation-import           Data.Geometry.Matrix-import qualified Data.LSeq as LSeq-import           Data.Traversable------------------------------------------------------------------------------------- | Paths---- | Paths consist of Path Segments. PathSegments come in the following forms:-data PathSegment r = PolyLineSegment        (PolyLine 2 () r)-                   | PolygonPath            (SimplePolygon () r)-                   | CubicBezierSegment     (BezierSpline 3 2 r)-                   | QuadraticBezierSegment (BezierSpline 2 2 r)-                   | EllipseSegment         (Ellipse r)-                     -- TODO-                   | ArcSegment-                   | SplineSegment          -- (Spline 2 r)-                   | ClosedSplineSegment    -- (ClosedSpline 2 r)-                   deriving (Show,Eq)-makePrisms ''PathSegment--type instance NumType   (PathSegment r) = r-type instance Dimension (PathSegment r) = 2--instance Functor PathSegment where-  fmap = fmapDefault-instance Foldable PathSegment where-  foldMap = foldMapDefault-instance Traversable PathSegment where-  traverse f = \case-    PolyLineSegment p        -> PolyLineSegment <$> bitraverse pure f p-    PolygonPath p            -> PolygonPath <$> bitraverse pure f p-    CubicBezierSegment b     -> CubicBezierSegment <$> traverse f b-    QuadraticBezierSegment b -> QuadraticBezierSegment <$> traverse f b-    EllipseSegment e         -> EllipseSegment <$> traverse f e-    ArcSegment               -> pure ArcSegment-    SplineSegment            -> pure SplineSegment-    ClosedSplineSegment      -> pure ClosedSplineSegment--instance Fractional r => IsTransformable (PathSegment r) where-  transformBy t = \case-    PolyLineSegment p        -> PolyLineSegment $ transformBy t p-    PolygonPath p            -> PolygonPath $ transformBy t p-    CubicBezierSegment b     -> CubicBezierSegment $ transformBy t b-    QuadraticBezierSegment b -> QuadraticBezierSegment $ transformBy t b-    EllipseSegment e         -> EllipseSegment $ transformBy t e-    -- TODO:-    ArcSegment               -> ArcSegment-    SplineSegment            -> SplineSegment-    ClosedSplineSegment      -> ClosedSplineSegment----- | A path is a non-empty sequence of PathSegments.-newtype Path r = Path { _pathSegments :: LSeq.LSeq 1 (PathSegment r) }-                 deriving (Show,Eq,Functor,Foldable,Traversable)-makeLenses ''Path--type instance NumType   (Path r) = r-type instance Dimension (Path r) = 2--instance Fractional r => IsTransformable (Path r) where-  transformBy t (Path s) = Path $ fmap (transformBy t) s--------------------------------------------------------------------------------------- | type that represents a path in ipe.-data Operation r = MoveTo (Point 2 r)-                 | LineTo (Point 2 r)-                 | CurveTo (Point 2 r) (Point 2 r) (Point 2 r)-                 | QCurveTo (Point 2 r) (Point 2 r)-                 | Ellipse (Matrix 3 3 r)-                 | ArcTo (Matrix 3 3 r) (Point 2 r)-                 | Spline [Point 2 r]-                 | ClosedSpline [Point 2 r]-                 | ClosePath-                 deriving (Eq, Show,Functor,Foldable,Traversable)-makePrisms ''Operation

@@ -1,167 +0,0 @@-{-# Language OverloadedStrings #-}-{-# Language DefaultSignatures #-}-module Data.Geometry.Ipe.PathParser where--import           Data.Bifunctor-import           Data.Char (isSpace)-import           Data.Ext (ext)-import           Data.Geometry.Box-import           Data.Geometry.Ipe.ParserPrimitives-import           Data.Geometry.Ipe.Path (Operation(..))-import           Data.Geometry.Matrix-import           Data.Geometry.Point-import           Data.Geometry.Vector-import           Data.Ratio-import           Data.RealNumber.Rational-import           Data.Text (Text)-import qualified Data.Text as T-import           Text.Parsec.Error (messageString, errorMessages)----------------------------------------------------------------------------- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read)--class Fractional r => Coordinate r where-    -- reads a coordinate. The input is an integer representing the-    -- part before the decimal point, and a length and an integer-    -- representing the part after the decimal point-    fromSeq :: Integer -> Maybe (Int, Integer) -> r-    default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r-    fromSeq = defaultFromSeq--defaultFromSeq                :: (Ord r, Fractional r)-                              => Integer -> Maybe (Int, Integer) -> r-defaultFromSeq x Nothing      = fromInteger x-defaultFromSeq x (Just (l,y)) = let x'          = fromInteger x-                                    y'          = fromInteger y-                                    asDecimal a =  a * (0.1 ^ l)-                                    z           = if x' < 0 then (-1) else 1-                                in z * (abs x' + asDecimal y')--instance Coordinate Double-instance Coordinate Float-instance Coordinate (Ratio Integer)-instance Coordinate (RealNumber p)---------------------------------------------------------------------------- | Running the parsers--readCoordinate :: Coordinate r => Text -> Either Text r-readCoordinate = runParser pCoordinate--readPoint :: Coordinate r => Text -> Either Text (Point 2 r)-readPoint = runParser pPoint--runParser   :: Parser a -> Text -> Either Text a-runParser p = bimap errorText fst . runP p---- Collect errors-data Either' l r = Left' l | Right' r deriving (Show,Eq)--instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where-  (Left' l)  <> (Left' l')  = Left' $ l <> l'-  (Left' l)  <> _           = Left' l-  _          <> (Left' l')  = Left' l'-  (Right' r) <> (Right' r') = Right' $ r <> r'--instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where-  mempty = Right' mempty-  mappend = (<>)-either' :: (l -> a) -> (r -> a) -> Either' l r -> a-either' lf _  (Left' l)  = lf l-either' _  rf (Right' r) = rf r--- TODO: Use Validation instead of this home-brew one--readPathOperations :: Coordinate r => Text -> Either Text [Operation r]-readPathOperations = unWrap . mconcat . map (wrap . runP pOperation)-                   . clean . splitKeepDelims "mlcqeasuh"-    where-      -- Unwrap the Either'. If it is a Left containing all our errors,-      -- combine them into one error. Otherwise just ReWrap it in an proper Either-      unWrap = either' (Left . combineErrors) Right-      -- for the lefts: wrap the error in a list, for the rights: we only care-      -- about the result, so wrap that in a list as well. Collecting the-      -- results is done using the Semigroup instance of Either'-      wrap   = either (Left' . (:[])) (Right' . (:[]) . fst)-      -- Split the input string in pieces, each piece represents one operation-      trim   = T.dropWhile isSpace-      clean  = filter (not . T.null) . map trim-      -- TODO: Do the splitting on the Text rather than unpacking and packing-      -- the thing--errorText :: ParseError -> Text-errorText = T.pack . unlines . map messageString . errorMessages--combineErrors :: [ParseError] -> Text-combineErrors = T.unlines . map errorText---splitKeepDelims          :: [Char] -> Text -> [Text]-splitKeepDelims delims t = maybe mPref continue $ T.uncons rest-  where-    mPref           = if T.null pref then [] else [pref]-    (pref,rest)     = T.break (`elem` delims) t-    continue (c,t') = pref `T.snoc` c : splitKeepDelims delims t'---readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r)-readMatrix = runParser pMatrix---readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r)-readRectangle = runParser pRectangle---------------------------------------------------------------------------- | The parsers themselves---pOperation :: forall r. Coordinate r => Parser (Operation r)-pOperation = pChoice [ MoveTo       <$> pPoint                         *>> 'm'-                     , LineTo       <$> pPoint                         *>> 'l'-                     , CurveTo      <$> pPoint <*> pPoint' <*> pPoint' *>> 'c'-                     , QCurveTo     <$> pPoint <*> pPoint'             *>> 'q'-                     , Ellipse      <$> pMatrix                        *>> 'e'-                     , ArcTo        <$> pMatrix <*> pPoint'            *>> 'a'-                     , Spline       <$> pPoint `pSepBy` pWhiteSpace    *>> 's'-                     , ClosedSpline <$> pPoint `pSepBy` pWhiteSpace    *>> 'u'-                     , pChar 'h'  *> pure ClosePath-                     ]-             where-               pPoint' = pWhiteSpace *> pPoint-               p *>> c = p <*>< pWhiteSpace ***> pChar c----pPoint :: Coordinate r => Parser (Point 2 r)-pPoint = Point2 <$> pCoordinate <* pWhiteSpace <*> pCoordinate---pCoordinate :: Coordinate r => Parser r-pCoordinate = fromSeq <$> pInteger <*> pDecimal-              where-                pDecimal  = pMaybe (pChar '.' *> pPaddedNatural)---pRectangle :: Coordinate r => Parser (Rectangle () r)-pRectangle = (\p q -> box (ext p) (ext q)) <$> pPoint-                                           <*  pWhiteSpace-                                           <*> pPoint--pMatrix :: Coordinate r => Parser (Matrix 3 3 r)-pMatrix = (\a b -> mkMatrix (a:b)) <$> pCoordinate-                                   <*> pCount 5 (pWhiteSpace *> pCoordinate)----- | Generate a matrix from a list of 6 coordinates.-mkMatrix               :: Coordinate r => [r] -> Matrix 3 3 r-mkMatrix [a,b,c,d,e,f] = Matrix $ Vector3 (Vector3 a c e)-                                          (Vector3 b d f)-                                          (Vector3 0 0 1)-                           -- We need the matrix in the following order:-                         -- 012-                         -- 345-                         ---                         -- But ipe uses the following order:-                         -- 024-                         -- 135-mkMatrix _             = error "mkMatrix: need exactly 6 arguments"

@@ -1,438 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Data.Geometry.Ipe.Reader( -- * Reading ipe Files-                                 readRawIpeFile-                               , readIpeFile-                               , readSinglePageFile-                               , readSinglePageFileThrow-                               , ConversionError--                               -- * Reading XML directly-                               , fromIpeXML-                               , readXML--                               -- * Read classes-                               , IpeReadText(..)-                               , IpeRead(..)-                               , IpeReadAttr(..)---                               -- * Some low level implementation functions-                               , ipeReadTextWith-                               , ipeReadObject-                               , ipeReadAttrs-                               , ipeReadRec--                               , Coordinate(..)-                               ) where--import           Control.Applicative ((<|>))-import           Control.Lens hiding (Const, rmap)-import           Data.Bifunctor-import qualified Data.ByteString as B-import           Data.Colour.SRGB (RGB(..))-import           Data.Either (rights)-import           Data.Ext-import           Data.Geometry.BezierSpline-import           Data.Geometry.Box-import           Data.Geometry.Ellipse (ellipseMatrix)-import           Data.Geometry.Ipe.Attributes-import           Data.Geometry.Ipe.Color (IpeColor(..))-import           Data.Geometry.Ipe.Matrix-import           Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace)-import           Data.Geometry.Ipe.Path-import           Data.Geometry.Ipe.PathParser-import           Data.Geometry.Ipe.Types-import           Data.Geometry.Ipe.Value-import qualified Data.Geometry.Matrix as Matrix-import           Data.Geometry.Point-import           Data.Geometry.PolyLine-import qualified Data.Geometry.Polygon as Polygon-import qualified Data.LSeq as LSeq-import qualified Data.List as L-import qualified Data.List.NonEmpty as NonEmpty-import           Data.Maybe (fromMaybe, mapMaybe)-import           Data.Proxy-import           Data.Singletons-import           Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Traversable as Tr-import           Data.Vinyl hiding (Label)-import           Data.Vinyl.Functor-import           Data.Vinyl.TypeLevel-import           Text.XML.Expat.Tree-------------------------------------------------------------------------------------type ConversionError = Text----- | Given a file path, tries to read an ipe file-readRawIpeFile :: (Coordinate r, Eq r)-               => FilePath -> IO (Either ConversionError (IpeFile r))-readRawIpeFile = fmap fromIpeXML . B.readFile----- | Given a file path, tries to read an ipe file.------ This function applies all matrices to objects.-readIpeFile :: (Coordinate r, Eq r)-            => FilePath -> IO (Either ConversionError (IpeFile r))-readIpeFile = fmap (second applyMatrices) . readRawIpeFile----- | Since most Ipe file contain only one page, we provide a shortcut for that--- as well.------ This function applies all matrices, and it makes sure there is at--- least one layer and view in the page.----readSinglePageFile :: (Coordinate r, Eq r)-                   => FilePath -> IO (Either ConversionError (IpePage r))-readSinglePageFile = fmap (fmap f) . readIpeFile-  where-    f   :: IpeFile r -> IpePage r-    f i = withDefaults . NonEmpty.head $ i^.pages---- | Tries to read a single page file, throws an error when this--- fails. See 'readSinglePageFile' for further details.-readSinglePageFileThrow    :: (Coordinate r, Eq r) => FilePath -> IO (IpePage r)-readSinglePageFileThrow fp = readSinglePageFile fp >>= \case-  Left err -> fail (show err)-  Right p  -> pure p---- | Given a Bytestring, try to parse the bytestring into anything that is--- IpeReadable, i.e. any of the Ipe elements.-fromIpeXML   :: IpeRead (t r) => B.ByteString -> Either ConversionError (t r)-fromIpeXML b = readXML b >>= ipeRead---- | Reads the data from a Bytestring into a proper Node-readXML :: B.ByteString -> Either ConversionError (Node Text Text)-readXML = first (T.pack . show) . parse' defaultParseOptions-------------------------------------------------------------------------------------- | Reading an ipe elemtn from a Text value-class IpeReadText t where-  ipeReadText :: Text -> Either ConversionError t---- | Reading an ipe lement from Xml-class IpeRead t where-  ipeRead  :: Node Text Text -> Either ConversionError t-------------------------------------------------------------------------------------  ReadText instances--instance IpeReadText Text where-  ipeReadText = Right--instance IpeReadText Int where-  ipeReadText = fmap fromInteger . runParser pInteger--instance Coordinate r => IpeReadText (Point 2 r) where-  ipeReadText = readPoint--instance Coordinate r => IpeReadText (Matrix.Matrix 3 3 r) where-  ipeReadText = readMatrix--instance IpeReadText LayerName where-  ipeReadText = Right . LayerName--instance IpeReadText PinType where-  ipeReadText "yes" = Right Yes-  ipeReadText "h"   = Right Horizontal-  ipeReadText "v"   = Right Vertical-  ipeReadText ""    = Right No-  ipeReadText _     = Left "invalid PinType"--instance IpeReadText TransformationTypes where-  ipeReadText "affine"       = Right Affine-  ipeReadText "rigid"        = Right Rigid-  ipeReadText "translations" = Right Translations-  ipeReadText _              = Left "invalid TransformationType"--instance IpeReadText FillType where-  ipeReadText "wind"   = Right Wind-  ipeReadText "eofill" = Right EOFill-  ipeReadText _        = Left "invalid FillType"--instance Coordinate r => IpeReadText (IpeArrow r) where-  ipeReadText t = case T.split (== '/') t of-                    [n,s] -> IpeArrow <$> pure n <*> ipeReadText s-                    _     -> Left "ipeArrow: name contains not exactly 1 / "--instance Coordinate r => IpeReadText (IpeDash r) where-  ipeReadText t = Right . DashNamed $ t-                  -- TODO: Implement proper parsing here---ipeReadTextWith     :: (Text -> Either t v) -> Text -> Either ConversionError (IpeValue v)-ipeReadTextWith f t = case f t of-                        Right v -> Right (Valued v)-                        Left _  -> Right (Named t)---instance Coordinate r => IpeReadText (Rectangle () r) where-  ipeReadText = readRectangle--instance Coordinate r => IpeReadText (RGB r) where-  ipeReadText = runParser (pRGB <|> pGrey)-    where-      pGrey = (\c -> RGB c c c) <$> pCoordinate-      pRGB  = RGB <$> pCoordinate <* pWhiteSpace-                  <*> pCoordinate <* pWhiteSpace-                  <*> pCoordinate--instance Coordinate r => IpeReadText (IpeColor r) where-  ipeReadText = fmap IpeColor . ipeReadTextWith ipeReadText--instance Coordinate r => IpeReadText (IpePen r) where-  ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate--instance Coordinate r => IpeReadText (IpeSize r) where-  ipeReadText = fmap IpeSize . ipeReadTextWith readCoordinate---instance Coordinate r => IpeReadText [Operation r] where-  ipeReadText = readPathOperations--instance (Coordinate r, Eq r) => IpeReadText (NonEmpty.NonEmpty (PathSegment r)) where-  ipeReadText t = ipeReadText t >>= fromOpsN-    where-      fromOpsN xs = case fromOps xs of-                      Left l       -> Left l-                      Right []     -> Left "No path segments produced"-                      Right (p:ps) -> Right $ p NonEmpty.:| ps--      fromOps []            = Right []-      fromOps [Ellipse m]   = Right [EllipseSegment . view (from ellipseMatrix) $ m]-      fromOps (MoveTo p:xs) = fromOps' p xs-      fromOps _             = Left "Path should start with a move to"--      fromOps' _ []             = Left "Found only a MoveTo operation"-      fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops-                                      pts  = map ext $ s:q:mapMaybe (^?_LineTo) ls-                                      poly = Polygon.unsafeFromPoints . dropRepeats $ pts-                                      pl   = fromPointsUnsafe pts-                                  in case xs of-                                       (ClosePath : xs') -> PolygonPath poly   <<| xs'-                                       _                 -> PolyLineSegment pl <<| xs--      fromOps' s [CurveTo a b c] = Right [CubicBezierSegment $ Bezier3 s a b c]-      fromOps' _ _ = Left "fromOpts': rest not implemented yet."--      span' pr = L.span (not . isn't pr)--      x <<| xs = (x:) <$> fromOps xs---dropRepeats :: Eq a => [a] -> [a]-dropRepeats = map head . L.group--instance (Coordinate r, Eq r) => IpeReadText (Path r) where-  ipeReadText = fmap (Path . LSeq.fromNonEmpty) . ipeReadText------------------------------------------------------------------------------------- Reading attributes---- | Basically IpeReadText for attributes. This class is not really meant to be--- implemented directly. Just define an IpeReadText instance for the type--- (Apply f at), then the generic instance below takes care of looking up the--- name of the attribute, and calling the right ipeReadText value. This class--- is just so that reifyConstraint in `ipeReadRec` can select the right--- typeclass when building the rec.-class IpeReadAttr t where-  ipeReadAttr  :: Text -> Node Text Text -> Either ConversionError t--instance IpeReadText (Apply f at) => IpeReadAttr (Attr f at) where-  ipeReadAttr n (Element _ ats _) = GAttr <$> Tr.mapM ipeReadText (lookup n ats)-  ipeReadAttr _ _                 = Left "IpeReadAttr: Element expected, Text found"---- | Combination of zipRecWith and traverse-zipTraverseWith                       :: forall f g h i (rs :: [AttributeUniverse]). Applicative h-                                      => (forall (x :: AttributeUniverse). f x -> g x -> h (i x))-                                      -> Rec f rs -> Rec g rs -> h (Rec i rs)-zipTraverseWith _ RNil      RNil      = pure RNil-zipTraverseWith f (x :& xs) (y :& ys) = (:&) <$> f x y <*> zipTraverseWith f xs ys---- | Reading the Attributes into a Rec (Attr f), all based on the types of f--- (the type family mapping labels to types), and a list of labels (ats).-ipeReadRec       :: forall f ats.-                 ( RecApplicative ats-                 , ReifyConstraint IpeReadAttr (Attr f) ats-                 , RecAll (Attr f) ats IpeReadAttr-                 , AllConstrained IpeAttrName ats-                 )-                 => Proxy f -> Proxy ats-                 -> Node Text Text-                 -> Either ConversionError (Rec (Attr  f) ats)-ipeReadRec _ _ x = zipTraverseWith f (writeAttrNames r) r'-  where-    r  = rpure (GAttr Nothing)-    r' = reifyConstraint @IpeReadAttr r---    f                              :: forall at.-                                      Const Text at-                                   -> (Dict IpeReadAttr :. Attr f) at-                                   -> Either ConversionError (Attr f at)-    f (Const n) (Compose (Dict _)) = ipeReadAttr n x----- | Reader for records. Given a proxy of some ipe type i, and a proxy of an--- coordinate type r, read the IpeAttributes for i from the xml node.-ipeReadAttrs     :: forall proxy proxy' i r f ats.-                 ( f ~ AttrMapSym1 r, ats ~ AttributesOf i-                 , ReifyConstraint IpeReadAttr (Attr f) ats-                 , RecApplicative ats-                 , RecAll (Attr f) ats IpeReadAttr-                 , AllConstrained IpeAttrName ats-                 )-                 => proxy i -> proxy' r-                 -> Node Text Text-                 -> Either ConversionError (IpeAttributes i r)-ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats)----- testSym :: B.ByteString--- testSym = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"------- readAttrsFromXML :: B.ByteString -> Either---- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double)--- readSymAttrs = readXML testSym---                >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)-------- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes--- we can properly read an ipe object using ipeReadObject-ipeReadObject           :: ( IpeRead (i r)-                           , f ~ AttrMapSym1 r, ats ~ AttributesOf i-                           , RecApplicative ats-                           , ReifyConstraint IpeReadAttr (Attr f) ats-                           , RecAll (Attr f) ats IpeReadAttr-                           , AllConstrained IpeAttrName ats-                           )-                        => Proxy i -> proxy r -> Node Text Text-                        -> Either ConversionError (i r :+ IpeAttributes i r)-ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml-------------------------------------------------------------------------------------- | Ipe read instances--instance Coordinate r => IpeRead (IpeSymbol r) where-  ipeRead (Element "use" ats _) = case lookup "pos" ats of-      Nothing -> Left "symbol without position"-      Just ps -> flip Symbol name <$> ipeReadText ps-    where-      name = fromMaybe "mark/disk(sx)" $ lookup "name" ats-  ipeRead _ = Left "symbol element expected, text found"---- | Given a list of Nodes, try to parse all of them as a big text. If we--- encounter anything else then text, the parsing fails.-allText :: [Node Text Text] -> Either ConversionError Text-allText = fmap T.unlines . mapM unT-  where-    unT (Text t) = Right t-    unT _        = Left "allText: Expected Text, found an Element"--instance (Coordinate r, Eq r) => IpeRead (Path r) where-  ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText-  ipeRead _                      = Left "path: expected element, found text"---lookup'   :: Text -> [(Text,a)] -> Either ConversionError a-lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k--instance Coordinate r => IpeRead (TextLabel r) where-  ipeRead (Element "text" ats chs)-    | lookup "type" ats == Just "label" = Label-                                       <$> allText chs-                                       <*> (lookup' "pos" ats >>= ipeReadText)-    | otherwise                         = Left "Not a Text label"-  ipeRead _                             = Left "textlabel: Expected element, found text"----instance Coordinate r => IpeRead (MiniPage r) where-  ipeRead (Element "text" ats chs)-    | lookup "type" ats == Just "minipage" = MiniPage-                                          <$> allText chs-                                          <*> (lookup' "pos"   ats >>= ipeReadText)-                                          <*> (lookup' "width" ats >>= readCoordinate)-    | otherwise                            = Left "Not a MiniPage"-  ipeRead _                                = Left "MiniPage: Expected element, found text"---instance Coordinate r => IpeRead (Image r) where-  ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText)-  ipeRead _                       = Left "Image: Element expected, text found"--instance (Coordinate r, Eq r) => IpeRead (IpeObject r) where-  ipeRead x = firstRight [ IpeUse       <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x-                         , IpePath      <$> ipeReadObject (Proxy :: Proxy Path)      r x-                         , IpeGroup     <$> ipeReadObject (Proxy :: Proxy Group)     r x-                         , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x-                         , IpeMiniPage  <$> ipeReadObject (Proxy :: Proxy MiniPage)  r x-                         , IpeImage     <$> ipeReadObject (Proxy :: Proxy Image)     r x-                         ]-    where-      r = Proxy :: Proxy r--firstRight :: [Either ConversionError a] -> Either ConversionError a-firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right)---instance (Coordinate r, Eq r) => IpeRead (Group r) where-  ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs-  ipeRead _                       = Left "ipeRead Group: expected Element, found Text"---instance IpeRead LayerName where-  ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats-  ipeRead _                       = Left "layer: Expected element, found text"--instance IpeRead View where-  ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a)-                                <$> lookup' "layers" ats-                                <*> (lookup' "active" ats >>= ipeReadText)-  ipeRead _                      = Left "View Expected element, found text"----- TODO: this instance throws away all of our error collecting (and is pretty--- slow/stupid since it tries parsing all children with all parsers)-instance (Coordinate r, Eq r) => IpeRead (IpePage r) where-  ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs)-  ipeRead _                      = Left "page: Element expected, text found"-      -- withDef   :: b -> Either a b -> Either c b-      -- withDef d = either (const $ Right d) Right--      -- readLayers  = withDef ["alpha"] . readAll-      -- readViews   = withDef []        . readAll-      -- readObjects = withDef []        . readAll---- | try reading everything as an a. Throw away whatever fails.-readAll   :: IpeRead a => [Node Text Text] -> [a]-readAll   = rights . map ipeRead---instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where-  ipeRead (Element "ipe" _ chs) = case readAll chs of-                                    []  -> Left "Ipe: no pages found"-                                    pgs -> Right $ IpeFile Nothing [] (NonEmpty.fromList pgs)-  ipeRead _                     = Left "Ipe: Element expected, text found"--------------------------------------------------------------------------------------

@@ -1,198 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.Types--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Data type modeling the various elements in Ipe files.-------------------------------------------------------------------------------------module Data.Geometry.Ipe.Types(-    LayerName(LayerName), layerName-  , Image(Image), imageData, rect-  , TextLabel(..)-  , MiniPage(..), width--  , IpeSymbol(Symbol), symbolPoint, symbolName--  , Path(Path), pathSegments-  , PathSegment(..)--  , Group(Group), groupItems---  , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath-  , IpeObject'-  , ipeObject'-  , ToObject(..)--  , IpeAttributes-  , Attributes', AttributesOf, AttrMap, AttrMapSym1-  , attributes, traverseIpeAttrs-  , commonAttributes--  , flattenGroups---  , View(View), layerNames, activeLayer--  , IpeStyle(IpeStyle), styleName, styleData-  , basicIpeStyle---  , IpePreamble(IpePreamble), encoding, preambleData--  , IpeBitmap---  , IpePage(IpePage), layers, views, content-  , emptyPage, fromContent-  , onLayer, contentInView-  , withDefaults--  , IpeFile(IpeFile), preamble, styles, pages-  , ipeFile, singlePageFile, singlePageFromContent-  ) where---import           Control.Lens hiding (views)-import           Data.Geometry.Ipe.Attributes hiding (Matrix)-import           Data.Geometry.Ipe.Content-import           Data.Geometry.Ipe.Layer-import           Data.Geometry.Ipe.Literal-import qualified Data.List.NonEmpty as NE-import           Data.Maybe (mapMaybe)-import           Data.Semigroup (Endo)-import qualified Data.Set as Set-import           Data.Text (Text)-import           Text.XML.Expat.Tree (Node)--------------------------------------------------------------------------------------- | The definition of a view--- make active layer into an index ?-data View = View { _layerNames      :: [LayerName]-                 , _activeLayer     :: LayerName-                 }-          deriving (Eq, Ord, Show)-makeLenses ''View---- instance Default----- | for now we pretty much ignore these-data IpeStyle = IpeStyle { _styleName :: Maybe Text-                         , _styleData :: Node Text Text-                         }-              deriving (Eq,Show)-makeLenses ''IpeStyle---basicIpeStyle :: IpeStyle-basicIpeStyle = IpeStyle (Just "basic") (xmlLiteral [litFile|resources/basic.isy|])----- | The maybe string is the encoding-data IpePreamble  = IpePreamble { _encoding     :: Maybe Text-                                , _preambleData :: Text-                                }-                  deriving (Eq,Read,Show,Ord)-makeLenses ''IpePreamble--type IpeBitmap = Text--------------------------------------------------------------------------------------- Ipe Pages---- | An IpePage is essentially a Group, together with a list of layers and a--- list of views.-data IpePage r = IpePage { _layers  :: [LayerName]-                         , _views   :: [View]-                         , _content :: [IpeObject r]-                         }-              deriving (Eq,Show)-makeLenses ''IpePage---- | Creates an empty page with one layer and view.-emptyPage :: IpePage r-emptyPage = fromContent []---- | Creates a simple page with a single view.-fromContent     :: [IpeObject r] -> IpePage r-fromContent obs = IpePage layers' [View layers' a] obs-  where-    layers' = Set.toList . Set.fromList $ a : mapMaybe (^.commonAttributes.ixAttr SLayer) obs-    a       = "alpha"---- | Makes sure that the page has at least one layer and at least one--- view, essentially matching the behaviour of ipe. In particular,------ - if the page does not have any layers, it creates a layer named "alpha", and--- - if the page does not have any views, it creates a view in which all layers are visible.----withDefaults :: IpePage r -> IpePage r-withDefaults = addView . addLayer-  where-    whenNull ys = \case-                    [] -> ys-                    xs -> xs-    addLayer p = p&layers %~ whenNull ["alpha"]-    addView  p = p&views  %~ whenNull [View (p^.layers) (head $ p^.layers)]-                 -- note that the head is save, since we just made sure-                 -- with 'addLayer' that there is at least one layer---- | This allows you to filter the objects on some layer.------ >>> let page = IpePage [] [] []--- >>> page^..content.onLayer "myLayer"--- []-onLayer   :: LayerName -> Getting (Endo [IpeObject r]) [IpeObject r] (IpeObject r)-onLayer n = folded.filtered (\o -> o^?commonAttributes._Attr SLayer == Just n)---- | Gets all objects that are visible in the given view.------ Note that views are indexed starting from 0. If the page does not--- have any explicit view definitions, this function returns an empty--- list.------ >>> let page = IpePage [] [] []--- >>> page^.contentInView 0--- []-contentInView                     :: Word -> Getter (IpePage r) [IpeObject r]-contentInView (fromIntegral -> i) = to inView'-  where-    inView' p = let lrs = Set.fromList . concatMap (^.layerNames) $ p^..views.ix i-                in p^..content.folded.filtered (inVisibleLayer lrs)--    inVisibleLayer lrs o = maybe False (`Set.member` lrs) $ o^?commonAttributes._Attr SLayer-------------------------------------------------------------------------------------- | A complete ipe file-data IpeFile r = IpeFile { _preamble :: Maybe IpePreamble-                         , _styles   :: [IpeStyle]-                         , _pages    :: NE.NonEmpty (IpePage r)-                         }-               deriving (Eq,Show)-makeLenses ''IpeFile----- | Convenience constructor for creating an ipe file without preamble--- and with the default stylesheet.-ipeFile :: NE.NonEmpty (IpePage r) -> IpeFile r-ipeFile = IpeFile Nothing [basicIpeStyle]---- | Convenience function to construct an ipe file consisting of a single page.-singlePageFile :: IpePage r -> IpeFile r-singlePageFile = ipeFile . (NE.:| [])---- | Create a single page ipe file from a list of IpeObjects-singlePageFromContent :: [IpeObject r] -> IpeFile r-singlePageFromContent = singlePageFile . fromContent

@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.Value--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ Data type for representing values in ipe.-------------------------------------------------------------------------------------module Data.Geometry.Ipe.Value where--import GHC.Exts-import Data.Text-------------------------------------------------------------------------------------- | Many types either consist of a symbolc value, or a value of type v-data IpeValue v = Named Text | Valued v-  deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable)--instance IsString (IpeValue v) where-  fromString = Named . fromString

@@ -1,436 +0,0 @@-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE UndecidableInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Geometry.Ipe.Writer--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals--- Description :  Converting data types into IpeTypes-------------------------------------------------------------------------------------module Data.Geometry.Ipe.Writer( writeIpeFile, writeIpeFile', writeIpePage-                               , toIpeXML--                               , printAsIpeSelection, toIpeSelectionXML---                               , IpeWrite(..)-                               , IpeWriteText(..)--                               , ipeWriteAttrs, writeAttrValues-                               ) where--import           Control.Lens                 (view, (&), (.~), (^.), (^..))-import qualified Data.ByteString              as B-import qualified Data.ByteString.Char8        as C-import           Data.Colour.SRGB             (RGB (..))-import           Data.Ext-import           Data.Fixed-import qualified Data.Foldable                as F-import           Data.Geometry.BezierSpline-import           Data.Geometry.Box-import           Data.Geometry.Ellipse        (ellipseMatrix)-import           Data.Geometry.Ipe.Attributes-import qualified Data.Geometry.Ipe.Attributes as IA-import           Data.Geometry.Ipe.Color      (IpeColor (..))-import           Data.Geometry.Ipe.Path-import           Data.Geometry.Ipe.Types-import           Data.Geometry.Ipe.Value-import           Data.Geometry.LineSegment-import qualified Data.Geometry.Matrix         as Matrix-import           Data.Geometry.Point-import           Data.Geometry.PolyLine-import           Data.Geometry.Polygon        (Polygon, holeList, outerBoundary,-                                               outerBoundaryVector)-import           Data.Geometry.Vector-import qualified Data.LSeq                    as LSeq-import           Data.List.NonEmpty           (NonEmpty (..))-import           Data.Maybe                   (catMaybes, fromMaybe, mapMaybe)-import           Data.Ratio-import           Data.RealNumber.Rational-import           Data.Singletons-import           Data.Text                    (Text)-import qualified Data.Text                    as Text-import           Data.Vinyl                   hiding (Label)-import           Data.Vinyl.Functor-import           Data.Vinyl.TypeLevel-import           System.IO                    (hPutStrLn, stderr)-import           Text.XML.Expat.Format        (format')-import           Text.XML.Expat.Tree-------------------------------------------------------------------------------------- | Given a prism to convert something of type g into an ipe file, a file path,--- and a g. Convert the geometry and write it to file.---- writeIpe        :: ( RecAll (Page r) gs IpeWrite---                    , IpeWriteText r---                    ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO ()--- writeIpe p fp g = writeIpeFile (p # g) fp---- | Write an IpeFiele to file.-writeIpeFile :: IpeWriteText r => FilePath -> IpeFile r -> IO ()-writeIpeFile = flip writeIpeFile'---- | Creates a single page ipe file with the given page-writeIpePage    :: IpeWriteText r => FilePath -> IpePage r -> IO ()-writeIpePage fp = writeIpeFile fp . singlePageFile----- | Convert the input to ipeXml, and prints it to standard out in such a way--- that the copied text can be pasted into ipe as a geometry object.-printAsIpeSelection :: IpeWrite t => t -> IO ()-printAsIpeSelection = C.putStrLn . fromMaybe "" . toIpeSelectionXML---- | Convert input into an ipe selection.-toIpeSelectionXML :: IpeWrite t => t -> Maybe B.ByteString-toIpeSelectionXML = fmap (format' . ipeSelection) . ipeWrite-  where-    ipeSelection x = Element "ipeselection" [] [x]----- | Convert to Ipe xml-toIpeXML :: IpeWrite t => t -> Maybe B.ByteString-toIpeXML = fmap format' . ipeWrite----- | Convert to ipe XML and write the output to a file.-writeIpeFile'      :: IpeWrite t => t -> FilePath -> IO ()-writeIpeFile' i fp = maybe err (B.writeFile fp) . toIpeXML $ i-  where-    err = hPutStrLn stderr $-          "writeIpeFile: error converting to xml. File '" <> fp <> "'not written"-------------------------------------------------------------------------------------- | For types that can produce a text value-class IpeWriteText t where-  ipeWriteText :: t -> Maybe Text---- | Types that correspond to an XML Element. All instances should produce an--- Element. If the type should produce a Node with the Text constructor, use--- the `IpeWriteText` typeclass instead.-class IpeWrite t where-  ipeWrite :: t -> Maybe (Node Text Text)--instance IpeWrite t => IpeWrite [t] where-  ipeWrite gs = case mapMaybe ipeWrite gs of-                  [] -> Nothing-                  ns -> (Just $ Element "group" [] ns)--instance IpeWrite t => IpeWrite (NonEmpty t) where-  ipeWrite = ipeWrite . F.toList--instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where-  ipeWrite = either ipeWrite ipeWrite--instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where-  ipeWriteText att = _getAttr att >>= ipeWriteText--instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where-  ipeWriteText = either ipeWriteText ipeWriteText----- | Functon to write all attributes in a Rec-ipeWriteAttrs           :: ( RecordToList rs, RMap rs-                           , ReifyConstraint IpeWriteText (Attr f) rs-                           , AllConstrained IpeAttrName rs-                           , RecAll (Attr f) rs IpeWriteText-                           ) => IA.Attributes f rs -> [(Text,Text)]-ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames  r)-                                                                   (writeAttrValues r)-  where-    f (Const n) (Const mv) = Const $ (n,) <$> mv---- | Writing the attribute values-writeAttrValues :: ( RMap rs, ReifyConstraint IpeWriteText f rs-                   , RecAll f rs IpeWriteText)-                => Rec f rs -> Rec (Const (Maybe Text)) rs-writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)-                . reifyConstraint @IpeWriteText---instance IpeWriteText Text where-  ipeWriteText = Just--instance IpeWriteText String where-  ipeWriteText = ipeWriteText . Text.pack----- | Add attributes to a node-addAtts :: Node Text Text -> [(Text,Text)] -> Node Text Text-n `addAtts` ats = n { eAttributes = ats ++ eAttributes n }---- | Same as `addAtts` but then for a Maybe node-mAddAtts  :: Maybe (Node Text Text) -> [(Text, Text)] -> Maybe (Node Text Text)-mn `mAddAtts` ats = fmap (`addAtts` ats) mn-------------------------------------------------------------------------------------instance IpeWriteText Double where-  ipeWriteText = writeByShow--instance IpeWriteText Float where-  ipeWriteText = writeByShow--instance IpeWriteText Int where-  ipeWriteText = writeByShow--instance IpeWriteText Integer where-  ipeWriteText = writeByShow--instance IpeWriteText (RealNumber p) where-  ipeWriteText = ipeWriteText . realToFrac @(RealNumber p) @Rational--instance HasResolution p => IpeWriteText (Fixed p) where-  ipeWriteText = writeByShow---- | This instance converts the ratio to a Pico, and then displays that.-instance Integral a => IpeWriteText (Ratio a) where-  ipeWriteText = ipeWriteText . f . fromRational . toRational-    where-      f :: Pico -> Pico-      f = id--writeByShow :: Show t => t -> Maybe Text-writeByShow = ipeWriteText . Text.pack . show--unwords' :: [Maybe Text] -> Maybe Text-unwords' = fmap Text.unwords . sequence--unlines' :: [Maybe Text] -> Maybe Text-unlines' = fmap Text.unlines . sequence---instance IpeWriteText r => IpeWriteText (Point 2 r) where-  ipeWriteText (Point2 x y) = unwords' [ipeWriteText x, ipeWriteText y]-------------------------------------------------------------------------------------instance IpeWriteText v => IpeWriteText (IpeValue v) where-  ipeWriteText (Named t)  = ipeWriteText t-  ipeWriteText (Valued v) = ipeWriteText v--instance IpeWriteText TransformationTypes where-  ipeWriteText Affine       = Just "affine"-  ipeWriteText Rigid        = Just "rigid"-  ipeWriteText Translations = Just "translations"--instance IpeWriteText PinType where-  ipeWriteText No         = Nothing-  ipeWriteText Yes        = Just "yes"-  ipeWriteText Horizontal = Just "h"-  ipeWriteText Vertical   = Just "v"--instance IpeWriteText r => IpeWriteText (RGB r) where-  ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b]--deriving instance IpeWriteText r => IpeWriteText (IpeSize  r)-deriving instance IpeWriteText r => IpeWriteText (IpePen   r)-deriving instance IpeWriteText r => IpeWriteText (IpeColor r)--instance IpeWriteText r => IpeWriteText (IpeDash r) where-  ipeWriteText (DashNamed t) = Just t-  ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "["-                                                      , Text.intercalate " " ts-                                                      , "] ", t ])-                                    <$> mapM ipeWriteText xs-                                    <*> ipeWriteText x--instance IpeWriteText FillType where-  ipeWriteText Wind   = Just "wind"-  ipeWriteText EOFill = Just "eofill"--instance IpeWriteText r => IpeWriteText (IpeArrow r) where-  ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n-                                                            <*> ipeWriteText s--instance IpeWriteText r => IpeWriteText (Path r) where-  ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . view pathSegments-    where-      concat' = F.foldr1 (\t t' -> t <> "\n" <> t')------------------------------------------------------------------------------------instance IpeWriteText r => IpeWrite (IpeSymbol r) where-  ipeWrite (Symbol p n) = f <$> ipeWriteText p-    where-      f ps = Element "use" [ ("pos", ps)-                           , ("name", n)-                           ] []------------------------------------------------------------------------------------instance IpeWriteText r => IpeWriteText (Matrix.Matrix 3 3 r) where-  ipeWriteText (Matrix.Matrix m) = unwords' [a,b,c,d,e,f]-    where-      (Vector3 r1 r2 _) = m--      (Vector3 a c e) = ipeWriteText <$> r1-      (Vector3 b d f) = ipeWriteText <$> r2-      -- TODO: The third row should be (0,0,1) I guess.---instance IpeWriteText r => IpeWriteText (Operation r) where-  ipeWriteText (MoveTo p)         = unwords' [ ipeWriteText p, Just "m"]-  ipeWriteText (LineTo p)         = unwords' [ ipeWriteText p, Just "l"]-  ipeWriteText (CurveTo p q r)    = unwords' [ ipeWriteText p-                                             , ipeWriteText q-                                             , ipeWriteText r, Just "c"]-  ipeWriteText (QCurveTo p q)     = unwords' [ ipeWriteText p-                                             , ipeWriteText q, Just "q"]-  ipeWriteText (Ellipse m)        = unwords' [ ipeWriteText m, Just "e"]-  ipeWriteText (ArcTo m p)        = unwords' [ ipeWriteText m-                                             , ipeWriteText p, Just "a"]-  ipeWriteText (Spline pts)       = unlines' $ map ipeWriteText pts <> [Just "s"]-  ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"]-  ipeWriteText ClosePath          = Just "h"---instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where-  ipeWriteText pl = case pl^..points.traverse.core of-    (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest-    _          -> error "ipeWriteText. absurd. no vertices polyline"-    -- the polyline type guarantees that there is at least one point--instance IpeWriteText r => IpeWriteText (Polygon t () r) where-  ipeWriteText pg = fmap mconcat . traverse f $ pg^.outerBoundary : holeList pg-    where-      f pg' = case pg'^..outerBoundaryVector.traverse.core of-        (p : rest) -> unlines' . map ipeWriteText-                    $ MoveTo p : map LineTo rest ++ [ClosePath]-        _          -> Nothing-    -- TODO: We are not really guaranteed that there is at least one point, it would-    -- be nice if the type could guarantee that.--instance IpeWriteText r => IpeWriteText (BezierSpline 3 2 r) where-  ipeWriteText (Bezier3 p q r s) = unlines' . map ipeWriteText $ [MoveTo p, CurveTo q r s]--instance IpeWriteText r => IpeWriteText (PathSegment r) where-  ipeWriteText (PolyLineSegment p) = ipeWriteText p-  ipeWriteText (PolygonPath     p) = ipeWriteText p-  ipeWriteText (EllipseSegment  e) = ipeWriteText $ Ellipse (e^.ellipseMatrix)-  ipeWriteText _                   = error "ipeWriteText: PathSegment, not implemented yet."--instance IpeWriteText r => IpeWrite (Path r) where-  ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p-------------------------------------------------------------------------------------instance (IpeWriteText r) => IpeWrite (Group r) where-  ipeWrite (Group gs) = ipeWrite gs---instance ( AllConstrained IpeAttrName rs-         , RecordToList rs, RMap rs-         , ReifyConstraint IpeWriteText (Attr f) rs-         , RecAll (Attr f) rs IpeWriteText-         , IpeWrite g-         ) => IpeWrite (g :+ IA.Attributes f rs) where-  ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats---instance IpeWriteText r => IpeWrite (MiniPage r) where-  ipeWrite (MiniPage t p w) = (\pt wt ->-                              Element "text" [ ("pos", pt)-                                             , ("type", "minipage")-                                             , ("width", wt)-                                             ] [Text t]-                              ) <$> ipeWriteText p-                                <*> ipeWriteText w--instance IpeWriteText r => IpeWrite (Image r) where-  ipeWrite (Image d (Box a b)) = (\dt p q ->-                                   Element "image" [("rect", p <> " " <> q)] [Text dt]-                                 )-                               <$> ipeWriteText d-                               <*> ipeWriteText (a^.core.cwMin)-                               <*> ipeWriteText (b^.core.cwMax)---- TODO: Replace this one with s.t. that writes the actual image payload-instance IpeWriteText () where-  ipeWriteText () = Nothing--instance IpeWriteText r => IpeWrite (TextLabel r) where-  ipeWrite (Label t p) = (\pt ->-                         Element "text" [("pos", pt)-                                        ,("type", "label")-                                        ] [Text t]-                         ) <$> ipeWriteText p---instance (IpeWriteText r) => IpeWrite (IpeObject r) where-    ipeWrite (IpeGroup     g) = ipeWrite g-    ipeWrite (IpeImage     i) = ipeWrite i-    ipeWrite (IpeTextLabel l) = ipeWrite l-    ipeWrite (IpeMiniPage  m) = ipeWrite m-    ipeWrite (IpeUse       s) = ipeWrite s-    ipeWrite (IpePath      p) = ipeWrite p------------------------------------------------------------------------------------deriving instance IpeWriteText LayerName--instance IpeWrite LayerName where-  ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] []--instance IpeWrite View where-  ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)-                                                  , ("active", act^.layerName)-                                                  ] []-    where-      ls = Text.unwords .  map (^.layerName) $ lrs--instance (IpeWriteText r)  => IpeWrite (IpePage r) where-  ipeWrite (IpePage lrs vs objs) = Just .-                                  Element "page" [] . catMaybes . concat $-                                  [ map ipeWrite lrs-                                  , map ipeWrite vs-                                  , map ipeWrite objs-                                  ]---instance IpeWrite IpeStyle where-  ipeWrite (IpeStyle _ xml) = Just xml---instance IpeWrite IpePreamble where-  ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex]-  -- TODO: I probably want to do something with the encoding ....--instance (IpeWriteText r) => IpeWrite (IpeFile r) where-  ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs-    where-      ipeAtts = [("version","70005"),("creator", "HGeometry")]-      chs = mconcat [ catMaybes [mp >>= ipeWrite]-                    , mapMaybe ipeWrite ss-                    , mapMaybe ipeWrite . F.toList $ pgs-                    ]---------------------------------------------------------------------------------------instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where-  ipeWrite p = ipeWrite path-    where-      path = fromPolyLine $ p & points.traverse.extra .~ ()-      -- TODO: Do something with the p's--fromPolyLine :: PolyLine 2 () r -> Path r-fromPolyLine = Path . LSeq.fromNonEmpty . (:| []) . PolyLineSegment---instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where-  ipeWrite (LineSegment' p q) =-    ipeWrite . fromPolyLine . fromPointsUnsafe . map (extra .~ ()) $ [p,q]---instance IpeWrite () where-  ipeWrite = const Nothing

@@ -1,30 +1,33 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Geometry.PlanarSubdivision.Draw+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Helper functions to draw a PlanarSubdivision in ipe+--+-------------------------------------------------------------------------------- module Data.Geometry.PlanarSubdivision.Draw where  import           Control.Lens import           Data.Ext-import           Data.Geometry.Ipe+import           Ipe import           Data.Geometry.LineSegment import           Data.Geometry.PlanarSubdivision import           Data.Geometry.Polygon import           Data.Maybe (mapMaybe) import qualified Data.Vector as V --drawColoredPlanarSubdivision  ::  IpeOut (PlanarSubdivision s v e (Maybe (IpeColor r)) r)-                                          Group r-drawColoredPlanarSubdivision ps = drawPlanarSubdivision-    (ps&vertexData.traverse  .~ Just mempty-       &dartData.traverse._2 .~ Just mempty-       &faceData.traverse    %~ fmap (attr SFill)-    )+--------------------------------------------------------------------------------  -- | Draws only the values for which we have a Just attribute-drawPlanarSubdivision :: forall s r.+drawPlanarSubdivision :: forall s r. (Num r, Ord r) =>                          IpeOut (PlanarSubdivision s (Maybe (IpeAttributes IpeSymbol r))                                                      (Maybe (IpeAttributes Path      r))                                                      (Maybe (IpeAttributes Path      r))                                 r) Group r-drawPlanarSubdivision = drawPlanarSubdivisionWith fv fe ff+drawPlanarSubdivision = drawPlanarSubdivisionWith fv fe ff ff   where     fv                     :: (VertexId' s, VertexData r (Maybe (IpeAttributes IpeSymbol r)))                            -> Maybe (IpeObject' IpeSymbol r)@@ -34,21 +37,25 @@   -- | Draw everything using the defaults-drawPlanarSubdivision'    :: forall s v e f r. IpeOut (PlanarSubdivision s v e f r) Group r+drawPlanarSubdivision'    :: forall s v e f r. (Num r, Ord r)+                          => IpeOut (PlanarSubdivision s v e f r) Group r drawPlanarSubdivision' ps = drawPlanarSubdivision-  (ps&vertexData.traverse   .~ Just (mempty :: IpeAttributes IpeSymbol r)-     &dartData.traverse._2  .~ Just (mempty :: IpeAttributes Path      r)-     &faceData.traverse     .~ Just (mempty :: IpeAttributes Path      r))+  (ps&vertexData.traverse   ?~ (mempty :: IpeAttributes IpeSymbol r)+     &dartData.traverse._2  ?~ (mempty :: IpeAttributes Path      r)+     &faceData.traverse     ?~ (mempty :: IpeAttributes Path      r)) -type MIO g i r = g -> Maybe (IpeObject' i r) -drawPlanarSubdivisionWith            :: (ToObject vi, ToObject ei, ToObject fi)-                                     => MIO (VertexId' s, VertexData r v)          vi r-                                     -> MIO (Dart s,      LineSegment 2 v r :+ e)  ei r-                                     -> MIO (FaceId' s,   SomePolygon v r :+ f)    fi r-                                     -> IpeOut (PlanarSubdivision s v e f r) Group r-drawPlanarSubdivisionWith fv fe ff g = ipeGroup . concat $ [vs, es, fs]+-- | Function to draw a planar subdivision by giving functions that+-- specify how to render vertices, edges, the internal faces, and the outer face.+drawPlanarSubdivisionWith                 :: (ToObject vi, ToObject ei, ToObject fi, Num r, Ord r)+                                          => IpeOut' Maybe (VertexId' s, VertexData r v)          vi r+                                          -> IpeOut' Maybe (Dart s,      LineSegment 2 v r :+ e)  ei r+                                          -> IpeOut' Maybe (FaceId' s,   SomePolygon v r :+ f)    fi r+                                          -> IpeOut' Maybe (FaceId' s,   MultiPolygon (Maybe v) r :+ f)    fi r+                                          -> IpeOut (PlanarSubdivision s v e f r) Group r+drawPlanarSubdivisionWith fv fe fi fo g = ipeGroup . concat $ [o <> fs, es, vs]   where-    vs = mapMaybe (fmap iO . fv) . V.toList . vertices        $ g-    es = mapMaybe (fmap iO . fe) . V.toList . edgeSegments    $ g-    fs = mapMaybe (fmap iO . ff) . V.toList . rawFacePolygons $ g+    vs = mapMaybe (fmap iO . fv)  . V.toList . vertices     $ g+    es = mapMaybe (fmap iO . fe)  . V.toList . edgeSegments $ g+    fs = mapMaybe (fmap iO . fi) . V.toList . internalFacePolygons $ g+    o  = mapMaybe (fmap iO . fo) [(outerFaceId g, outerFacePolygon g)]

@@ -1,28 +1,42 @@ {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Geometry.QuadTree.Draw+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Machinery for drawing cells.+--+-------------------------------------------------------------------------------- module Data.Geometry.QuadTree.Draw where  import           Data.Ext import qualified Data.Foldable as F-import           Data.Geometry.Ipe.Attributes-import           Data.Geometry.Ipe.IpeOut-import           Data.Geometry.Ipe.Types+import           Ipe.Attributes+import           Ipe.IpeOut+import           Ipe.Types import           Data.Geometry.QuadTree import           Data.Geometry.QuadTree.Cell import qualified Data.Text as T import           Data.Tree.Util (TreeNode(..)) -------------------------------------------------------------------------------- +-- | Draw a quadTree cell as a Path drawCell :: Fractional r => IpeOut (Cell r) Path r-drawCell = \c -> ipeRectangle (toBox c)+drawCell = ipeRectangle . toBox +-- | Draws an entire quadtree. drawQuadTree :: (Fractional r, Ord r) => IpeOut (QuadTree v p r) Group r drawQuadTree = drawQuadTreeWith (\(_ :+ c) -> drawCell c) +-- | Draw a quadtree with a given method for drawing the cells. drawQuadTreeWith           :: (ToObject i, Fractional r, Ord r)                            => IpeOut (p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r drawQuadTreeWith drawCell' = ipeGroup . fmap (iO . drawCell') . leaves . withCells +-- | Draw every cell of a level of the quadtree. quadTreeLevels           :: forall i r v p. (ToObject i, Fractional r, Ord r                                             )                          => IpeOut (TreeNode v p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r@@ -37,4 +51,4 @@     drawLevel i = ipeGroup . fmap (\n -> iO $ ipeGroup [iO $ drawCell' n] ! attr SLayer (layer i))      layer   :: Int -> LayerName-    layer i = LayerName $ "level_" <> (T.pack $ show i)+    layer i = LayerName $ "level_" <> T.pack (show i)

@@ -2,7 +2,7 @@  import           Algorithms.Geometry.DelaunayTriangulation.Types import           Data.Geometry.LineSegment-import           Data.Geometry.Ipe+import           Ipe  -------------------------------------------------------------------------------- 

@@ -1,50 +1,73 @@ {-# LANGUAGE ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.PlaneGraph.Draw+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Helper functions to draw a PlaneGraph in ipe+--+-------------------------------------------------------------------------------- module Data.PlaneGraph.Draw where +import           Control.Lens import           Data.Ext-import           Data.Geometry.Ipe-import           Data.Geometry.Properties+import qualified Data.Foldable as F import           Data.Geometry.LineSegment-import           Data.Geometry.Point import           Data.Geometry.Polygon-import           Data.Maybe (catMaybes)+import           Data.Maybe (mapMaybe) import           Data.PlaneGraph-import qualified Data.Vector as V+import           Ipe  -------------------------------------------------------------------------------- --- | Draws a planegraph using Marks, LineSegments, and simple polygons for--- vertices, edges, and faces, respectively. Uses the default IpeOuts to draw--- these elements.-drawPlaneGraph :: forall s v e f r. IpeOut (PlaneGraph s v e f r) Group r-drawPlaneGraph = drawPlaneGraphWith defIO' defIO' defIO'+-- | Draws only the values for which we have a Just attribute+drawPlaneGraph :: forall s r. (Fractional r, Ord r)+               => IpeOut (PlaneGraph s (Maybe (IpeAttributes IpeSymbol r))+                                       (Maybe (IpeAttributes Path  r))+                                       (Maybe (IpeAttributes Path  r))+                           r) Group r+drawPlaneGraph = drawPlaneGraphWith fv fe ff ff   where-    defIO'     :: (HasDefaultIpeOut g, NumType g ~ r) => g -> _x -> Maybe (IpeObject r)-    defIO' p _ = Just . iO $ defIO p+    fv                     :: (VertexId' s, VertexData r (Maybe (IpeAttributes IpeSymbol r)))+                           -> Maybe (IpeObject' IpeSymbol r)+    fv (_,VertexData p ma) = (\a -> defIO p ! a) <$> ma -- draws a point+    fe (_,s :+ ma)         = (\a -> defIO s ! a) <$> ma -- draw segment+    ff (_,f :+ ma)         = (\a -> defIO f ! a) <$> ma -- draw a face --- | Draws a planegraph using Marks, LineSegments, and simple polygons for--- vertices, edges, and faces, respectively.-drawPlaneGraphWith            :: (Point 2 r         -> v -> Maybe (IpeObject r))-                              -> (LineSegment 2 v r -> e -> Maybe (IpeObject r))-                              -> (SimplePolygon v r -> f -> Maybe (IpeObject r))-                              -> IpeOut (PlaneGraph s v e f r) Group r-drawPlaneGraphWith vF eF fF g = ipeGroup $ concatMap (catMaybes . V.toList) [vs, es, fs]-  where-    vs = (\(_,VertexData p v) -> vF p v) <$> vertices g-    es = (\(_,s :+ e)         -> eF s e) <$> edgeSegments g-    fs = (\(_,p :+ f)         -> fF p f) <$> rawFacePolygons g+-- | Draw everything using the defaults+drawPlaneGraph'    :: forall s v e f r. (Ord r, Fractional r)+                   => IpeOut (PlaneGraph s v e f r) Group r+drawPlaneGraph' pg = drawPlaneGraph+  (pg&vertexData.traverse   ?~ (mempty :: IpeAttributes IpeSymbol r)+     &dartData.traverse._2  ?~ (mempty :: IpeAttributes Path      r)+     &faceData.traverse     ?~ (mempty :: IpeAttributes Path      r))  --- | Draw a planegraph using the given functions. Fully generic in how we draw--- the objects.-genericDrawPlaneGraphWith            :: (VertexId' s :+ v -> IpeObject r)-                                     -> (Dart s :+ e      -> IpeObject r)-                                     -> (FaceId' s :+ f   -> IpeObject r)-                                     -> IpeOut (PlaneGraph s v e f r) Group r-genericDrawPlaneGraphWith vF eF fF g = ipeGroup $ concatMap V.toList [vs, es, fs]-  where-    vs = (\(v,VertexData _ x) -> vF $ v :+ x) <$> vertices g-    es = wrap eF <$> edges g-    fs = wrap fF <$> faces g+-- | Function to draw a graph by giving functions that specify how to+-- render vertices, edges, and faces.+drawPlaneGraphWith                 :: (ToObject vi, ToObject ei, ToObject fi, Fractional r, Ord r)+                                   => IpeOut' Maybe (VertexId' s, VertexData r v)          vi r+                                   -> IpeOut' Maybe (Dart s,      LineSegment 2 v r :+ e)  ei r+                                   -> IpeOut' Maybe (FaceId' s,   SimplePolygon v r :+ f)  fi r+                                   -> IpeOut' Maybe (FaceId' s,   MultiPolygon (Maybe v) r :+ f)   fi r+                                   -> IpeOut (PlaneGraph s v e f r) Group r+drawPlaneGraphWith fs fe fif fof g = drawPlaneGraphWith' (outerFaceId g) fs fe fif fof g -    wrap f (a,b) = f $ a :+ b+-- | Function to draw a graph by giving the outer faceId and the+-- functions that specify how to render vertices, edges, and faces.+drawPlaneGraphWith'                    :: (ToObject vi, ToObject ei, ToObject fi, Num r, Ord r)+                                      => FaceId' s -- ^ outerface Id+                                      -> IpeOut' Maybe (VertexId' s, VertexData r v)          vi r+                                      -> IpeOut' Maybe (Dart s,      LineSegment 2 v r :+ e)  ei r+                                      -> IpeOut' Maybe (FaceId' s,   SimplePolygon v r :+ f)  fi r+                                      -> IpeOut' Maybe (FaceId' s,   MultiPolygon (Maybe v) r :+ f)   fi r+                                      -> IpeOut (PlaneGraph s v e f r) Group r+drawPlaneGraphWith' i fv fe fif fof g = ipeGroup . concat $ [vs, es, ifs, of']+  where+    (outerF,innerFs) = facePolygons i g+    vs  = mapMaybe (fmap iO . fv)  . F.toList . vertices        $ g+    es  = mapMaybe (fmap iO . fe)  . F.toList . edgeSegments    $ g+    ifs = mapMaybe (fmap iO . fif) . F.toList $ innerFs+    of' = mapMaybe (fmap iO . fof) [outerF]

@@ -3,7 +3,7 @@ import           Data.Ext import           Data.Geometry.LineSegment import           Data.Geometry.Point-import           Data.Geometry.Ipe+import           Ipe import           Data.Tree  --------------------------------------------------------------------------------

@@ -0,0 +1,99 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Reexports the functionality for reading and writing Ipe files.+--+--------------------------------------------------------------------------------+module Ipe(+  -- * Ipe Files+    IpeFile(IpeFile), preamble, styles, pages+  , ipeFile, singlePageFile, singlePageFromContent+  -- ** Reading Ipe files+  , readIpeFile+  , readSinglePageFile+  , readSinglePageFileThrow+  , readRawIpeFile+  , ConversionError+  -- *** Reading all Geometries from a single page ipe file+  , readAll, readAllFrom+  -- ** Writing ipe files+  , writeIpeFile, writeIpeFile', writeIpePage+  , toIpeXML+  , printAsIpeSelection, toIpeSelectionXML+++  -- * Ipe Pages+  , IpePage(IpePage), layers, views, content+  , emptyPage, fromContent+  , onLayer, contentInView+  , withDefaults++  -- * Content: Ipe Objects+  , IpeObject(..), _IpePath, _IpeUse, _IpeGroup, _IpeTextLabel, _IpeMiniPage, _IpeImage+  , IpeObject'+  , ipeObject'+  , ToObject(..)+  -- ** Specific Ipe-Objects+  , Path(Path), pathSegments+  , PathSegment(..)+  , IpeSymbol(Symbol), symbolPoint, symbolName+  , Group(Group), groupItems+  , TextLabel(..)+  , MiniPage(..), width+  , Image(Image), imageData, rect+  , IpeBitmap+  -- ** Attributes+  , IpeAttributes+  , Attributes', AttributesOf, AttrMap, AttrMapSym1+  , attributes, traverseIpeAttrs+  , commonAttributes+  -- * Layers and Views+  , LayerName(LayerName), layerName+  , View(View), layerNames, activeLayer+  -- * Ipe Syles and Preamble+  , IpeStyle(IpeStyle), styleName, styleData+  , basicIpeStyle+  , readIpeStylesheet+  , addStyleSheetFrom+  , IpePreamble(IpePreamble), encoding, preambleData+  -- * Reading Geometries *From* Ipe+  , IpeRead(..)+  -- ** Converting *from* IpeObjects+  , _asPoint+  , _asLineSegment+  , _asRectangle+  , _asTriangle+  , _asPolyLine+  , _asSomePolygon, _asSimplePolygon, _asMultiPolygon+  -- *** Dealing with Attributes+  , _withAttrs+  -- ** Default readers+  , HasDefaultFromIpe(..)++  -- * Converting *to* IpeObjects+  -- ** IpeWrite+  , IpeWrite(..)+  , IpeWriteText(..)+  -- ** IpeOut+  , module Ipe.IpeOut+  -- ** Batch reexports++  , module Ipe.Types+  , module Ipe.FromIpe+  , module Ipe.Attributes+  , module Ipe.Value+  , IpeColor(..), named+  ) where++import Ipe.Types+import Ipe.Writer+import Ipe.Reader+import Ipe.IpeOut+import Ipe.FromIpe+import Ipe.Attributes+import Ipe.Value+import Ipe.Color

@@ -0,0 +1,341 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.Attributes+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Possible Attributes we can assign to items in an Ipe file+--+--------------------------------------------------------------------------------+module Ipe.Attributes+  -- ( AttributeUniverse(..)+  -- ,++  -- )+  where++import Control.Lens hiding (rmap, Const)+import Ipe.Value+import Data.Singletons+import Data.Singletons.TH+import Data.Text (Text)+import Data.Vinyl+import Data.Vinyl.TypeLevel+import Data.Vinyl.Functor+import Text.Read (lexP, step, parens, prec, (+++)+                , Lexeme(Ident), readPrec, readListPrec, readListPrecDefault)++--------------------------------------------------------------------------------++-- | The possible Attributes supported in Ipe. To use these+-- attributes, you'll likely need their Singletons's version which is+-- Prefixed by an 'S'. E.g. the 'Fill' attribute is represented by a+-- singleton 'SFill :: Sing Fill'.+data AttributeUniverse = -- common+                         Layer | Matrix | Pin | Transformations+                       -- symbol+                       | Stroke | Fill | Pen | Size+                       -- Path+                       | Dash | LineCap | LineJoin+                       | FillRule | Arrow | RArrow | StrokeOpacity | Opacity | Tiling | Gradient+                       -- Group+                       | Clip+                       -- Extra+--                       | X Text+                       deriving (Show,Read,Eq)+++genSingletons [ ''AttributeUniverse ]++-- | IpeObjects may have attributes. Essentially attributes are+-- (key,value) pairs. The key is some name. Which attributes an object+-- can have depends on the type of the object. However, all ipe+-- objects support the Common Attributes+type CommonAttributes = [ Layer, Matrix, Pin, Transformations ]++-- | All attributes applicable to TextLabels+type TextLabelAttributes = CommonAttributes+-- | All attributes applicable to Minipages+type MiniPageAttributes  = CommonAttributes+-- | All attributes applicable to Images+type ImageAttributes     = CommonAttributes++-- | All attributes applicable to Symbols/Marks+type SymbolAttributes = CommonAttributes ++ [Stroke, Fill, Pen, Size]++-- | All attributes applicable to Paths+type PathAttributes = CommonAttributes +++                      [ Stroke, Fill, Dash, Pen, LineCap, LineJoin+                      , FillRule, Arrow, RArrow, StrokeOpacity, Opacity, Tiling, Gradient+                      ]++-- | All attributes applicable to Groups+type GroupAttributes = CommonAttributes ++ '[ 'Clip]++--------------------------------------------------------------------------------+-- * A single attribute Attr++-- | Attr implements the mapping from labels to types as specified by the+-- (symbol representing) the type family 'f'+newtype Attr (f :: TyFun u * -> *) -- Symbol repr. the Type family mapping+                                   -- Labels in universe u to concrete types+             (label :: u) = GAttr { _getAttr :: Maybe (Apply f label) }+++deriving instance Eq   (Apply f label) => Eq   (Attr f label)+deriving instance Ord  (Apply f label) => Ord  (Attr f label)++makeLenses ''Attr++-- | Constructor for constructing an Attr given an actual value.+pattern Attr   :: Apply f label -> Attr f label+pattern Attr x = GAttr (Just x)++-- | An Attribute that is not set+pattern NoAttr :: Attr f label+pattern NoAttr = GAttr Nothing+{-# COMPLETE NoAttr, Attr #-}++-- | Traverse an attribute.+traverseAttr   :: Applicative h => (Apply f label -> h (Apply g label))+               -> Attr f label -> h (Attr g label)+traverseAttr f = \case+  Attr x -> Attr <$> f x+  NoAttr -> pure NoAttr++-- | Traverse for the situation where the type is not actually parameterized.+pureAttr :: (Applicative h, Apply f a ~ Apply g a) => Attr f a -> h (Attr g a)+pureAttr = pure . \case+    Attr a -> Attr a+    NoAttr -> NoAttr+++instance Show (Apply f label) => Show (Attr f label) where+  showsPrec d NoAttr   = showParen (d > app_prec) $ showString "NoAttr"+    where app_prec = 10+  showsPrec d (Attr a) = showParen (d > up_prec) $+                           showString "Attr " . showsPrec (up_prec+1) a+    where up_prec  = 5++instance Read (Apply f label) => Read (Attr f label) where+  readPrec = parens $ (prec app_prec $ do+                                         Ident "NoAttr" <- lexP+                                         pure NoAttr)+                  +++ (prec up_prec $ do+                                         Ident "Attr" <- lexP+                                         a <- step readPrec+                                         pure $ Attr a)+    where+      app_prec = 10+      up_prec = 5+  readListPrec = readListPrecDefault++++-- | Give pref. to the *RIGHT*+instance Semigroup (Attr f l) where+  _ <> b@(Attr _) = b+  a <> _          = a++instance Monoid (Attr f l) where+  mempty  = NoAttr+  mappend = (<>)++--------------------------------------------------------------------------------+-- * Attributes++-- | A collection of Attributes.+newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) = Attrs (Rec (Attr f) ats)++-- | Get a vinyl Record with Attrs+unAttrs :: Lens (Attributes f ats) (Attributes f' ats') (Rec (Attr f) ats) (Rec (Attr f') ats')+unAttrs = lens (\(Attrs r) -> r) (const Attrs)++deriving instance ( RMap ats, ReifyConstraint Show (Attr f) ats, RecordToList ats+                  , RecAll (Attr f) ats Show) => Show (Attributes f ats)+-- deriving instance (RecAll (Attr f) ats Read) => Read (Attributes f ats)++instance ( ReifyConstraint Eq (Attr f) ats, RecordToList ats+         , RecAll (Attr f) ats Eq)   => Eq   (Attributes f ats) where+  (Attrs a) == (Attrs b) = and . recordToList+                         . zipRecsWith (\x (Compose (Dict y)) -> Const $ x == y) a+                         . (reifyConstraint @Eq) $ b++instance RecApplicative ats => Monoid (Attributes f ats) where+  mempty        = Attrs $ rpure mempty+  a `mappend` b = a <> b++instance Semigroup (Attributes f ats) where+  (Attrs as) <> (Attrs bs) = Attrs $ zipRecsWith mappend as bs++-- | Traverse implementation for Attrs+traverseAttrs               :: Applicative h+                            => (forall label. Attr f label -> h (Attr g label))+                            -> Attributes f ats -> h (Attributes g ats)+traverseAttrs f (Attrs ats) = Attrs <$> rtraverse f ats++-- | Zip two Recs with the given function.+zipRecsWith                       :: (forall a. f a -> g a -> h a)+                                  -> Rec f as -> Rec g as -> Rec h as+zipRecsWith _ RNil      _         = RNil+zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss+++----------------------------------------++-- | Lens into a specific attribute, if it is set.+ixAttr   :: forall at ats proxy f. (at ∈ ats)+         => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at))+ixAttr _ = unAttrs.(rlens @at).getAttr++-- | Prism into a particular attribute.+_Attr   :: forall at ats proxy f. (at ∈ ats, RecApplicative ats)+         => proxy at -> Prism' (Attributes f ats) (Apply f at)+_Attr a = prism' setA getA+  where+    setA x = setAttr a x mempty+    getA = lookupAttr a++-- | Looks up a particular attribute.+lookupAttr   :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at)+lookupAttr p = view (ixAttr p)++-- | Sets a particular attribute+setAttr               :: forall proxy at ats f. (at ∈ ats)+                      => proxy at -> Apply f at -> Attributes f ats -> Attributes f ats+setAttr _ a (Attrs r) = Attrs $ rput (Attr a :: Attr f at) r+++-- | gets and removes the attribute from Attributes+takeAttr       :: forall proxy at ats f. (at ∈ ats)+               => proxy at -> Attributes f ats -> ( Maybe (Apply f at)+                                                  , Attributes f ats )+takeAttr p ats = (lookupAttr p ats, ats&ixAttr p .~ Nothing)++-- | unsets/Removes an attribute+unSetAttr   :: forall proxy at ats f. (at ∈ ats)+            => proxy at -> Attributes f ats -> Attributes f ats+unSetAttr p = snd . takeAttr p++-- | Creates a singleton attribute+attr     :: (at ∈ ats, RecApplicative ats)+         => proxy at -> Apply f at -> Attributes f ats+attr p x = x^.re (_Attr p)++--------------------------------------------------------------------------------+-- * Implementations for Common Attributes++-- | Possible values for Pin+data PinType = No | Yes | Horizontal | Vertical+             deriving (Eq,Show,Read)++-- | Possible values for Transformation+data TransformationTypes = Affine | Rigid | Translations deriving (Show,Read,Eq)++--------------------------------------------------------------------------------+-- * Text Attributes++-- these Attributes are speicifc to IpeObjects representing TextLabels+-- and MiniPages. The same structure as for the `CommonAttributes'+-- applies here.++-- | TODO++--------------------------------------------------------------------------------+-- * Symbol Attributes++-- | The optional Attributes for a symbol+-- data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size+--                              deriving (Show,Eq)++-- | Size+newtype IpeSize  r = IpeSize  (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable)+-- | Pen/Thickness+newtype IpePen   r = IpePen   (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable)++-------------------------------------------------------------------------------+-- * Path Attributes++-- | Possible values for Dash+data IpeDash r = DashNamed Text+               | DashPattern [r] r+               deriving (Show,Eq,Functor,Foldable,Traversable)++-- | Allowed Fill types+data FillType = Wind | EOFill deriving (Show,Read,Eq)++-- | IpeOpacity, IpeTyling, and IpeGradient are all symbolic values+type IpeOpacity  = Text+type IpeTiling   = Text+type IpeGradient = Text++-- | Possible values for an ipe arrow+data IpeArrow r = IpeArrow { _arrowName :: Text+                           , _arrowSize :: IpeSize r+                           } deriving (Show,Eq,Functor,Foldable,Traversable)+makeLenses ''IpeArrow++-- | A normal arrow+normalArrow :: IpeArrow r+normalArrow = IpeArrow "normal" (IpeSize $ Named "normal/normal")++--------------------------------------------------------------------------------+-- * Group Attributes++-- | The only group attribute is a Clip++-- A clipping path is a Path. Which is defined in Ipe.Types. To+-- avoid circular imports, we define GroupAttrElf and GroupAttribute there.++--------------------------------------------------------------------------------+-- * Attribute names in Ipe+++-- | For the types representing attribute values we can get the name/key to use+-- when serializing to ipe.+class IpeAttrName (a :: AttributeUniverse) where+  attrName :: proxy a -> Text++-- CommonAttributeUnivers+instance IpeAttrName Layer           where attrName _ = "layer"+instance IpeAttrName Matrix          where attrName _ = "matrix"+instance IpeAttrName Pin             where attrName _ = "pin"+instance IpeAttrName Transformations where attrName _ = "transformations"++-- IpeSymbolAttributeUniversre+instance IpeAttrName Stroke       where attrName _ = "stroke"+instance IpeAttrName Fill         where attrName _ = "fill"+instance IpeAttrName Pen          where attrName _ = "pen"+instance IpeAttrName Size         where attrName _ = "size"++-- PathAttributeUniverse+instance IpeAttrName Dash       where attrName _ = "dash"+instance IpeAttrName LineCap    where attrName _ = "cap"+instance IpeAttrName LineJoin   where attrName _ = "join"+instance IpeAttrName FillRule   where attrName _ = "fillrule"+instance IpeAttrName Arrow      where attrName _ = "arrow"+instance IpeAttrName RArrow     where attrName _ = "rarrow"+instance IpeAttrName StrokeOpacity where attrName _ = "stroke-opacity"+instance IpeAttrName Opacity    where attrName _ = "opacity"+instance IpeAttrName Tiling     where attrName _ = "tiling"+instance IpeAttrName Gradient   where attrName _ = "gradient"++-- GroupAttributeUniverse+instance IpeAttrName Clip     where attrName _ = "clip"++-- | Writing Attribute names+writeAttrNames           :: AllConstrained IpeAttrName rs => Rec f rs -> Rec (Const Text) rs+writeAttrNames RNil      = RNil+writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs+  where+    write''   :: forall f s. IpeAttrName s => f s -> Text+    write'' _ = attrName (Proxy :: Proxy s)++--++--------------------------------------------------------------------------------

@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.Color+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Data type for representing colors in ipe as well as the colors available in+-- the standard ipe stylesheet.+--+--------------------------------------------------------------------------------+module Ipe.Color where++import Data.Colour.SRGB (RGB(..))+import Ipe.Value+import Data.Text+import Data.Traversable+--------------------------------------------------------------------------------++-- | Defines a color in Ipe. Colors are either RGB Values or Named+-- values.+newtype IpeColor r = IpeColor (IpeValue (RGB r)) deriving (Show,Read,Eq)++instance Ord r => Ord (IpeColor r) where+  (IpeColor c) `compare` (IpeColor c') = fmap f c `compare` fmap f c'+    where+      f (RGB r g b) = (r,g,b)++instance Functor IpeColor where+  fmap = fmapDefault+instance Foldable IpeColor where+  foldMap = foldMapDefault+instance Traversable IpeColor where+  traverse f (IpeColor v) = IpeColor <$> traverse traverseRGB v+    where+      traverseRGB (RGB r g b) = RGB <$> f r <*> f g <*> f b++-- | Creates a named color+named :: Text -> IpeColor r+named = IpeColor . Named++--------------------------------------------------------------------------------+-- * Basic Named colors++black :: IpeColor r+black = named "black"++white :: IpeColor r+white = named "white"++red :: IpeColor r+red = named "red"++green :: IpeColor r+green = named "green"++blue :: IpeColor r+blue = named "blue"++yellow :: IpeColor r+yellow = named "yellow"++orange :: IpeColor r+orange = named "orange"++gold :: IpeColor r+gold = named "gold"++purple :: IpeColor r+purple = named "purple"++gray :: IpeColor r+gray = named "gray"++brown :: IpeColor r+brown = named "brown"++navy :: IpeColor r+navy = named "navy"++pink :: IpeColor r+pink = named "pink"++seagreen :: IpeColor r+seagreen = named "seagreen"++turquoise :: IpeColor r+turquoise = named "turquoise"++violet :: IpeColor r+violet = named "violet"++darkblue :: IpeColor r+darkblue = named "darkblue"++darkcyan :: IpeColor r+darkcyan = named "darkcyan"++darkgray :: IpeColor r+darkgray = named "darkgray"++darkgreen :: IpeColor r+darkgreen = named "darkgreen"++darkmagenta :: IpeColor r+darkmagenta = named "darkmagenta"++darkorange :: IpeColor r+darkorange = named "darkorange"++darkred :: IpeColor r+darkred = named "darkred"++lightblue :: IpeColor r+lightblue = named "lightblue"++lightcyan :: IpeColor r+lightcyan = named "lightcyan"++lightgray :: IpeColor r+lightgray = named "lightgray"++lightgreen :: IpeColor r+lightgreen = named "lightgreen"++lightyellow :: IpeColor r+lightyellow = named "lightyellow"

@@ -0,0 +1,348 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+module Ipe.Content(+    Image(Image), imageData, rect+  , TextLabel(..)+  , MiniPage(..), width++  , IpeSymbol(Symbol), symbolPoint, symbolName++  , Path(Path), pathSegments+  , PathSegment(..)++  , Group(Group), groupItems+++  , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath+  , IpeObject'+  , ipeObject', ToObject(..)++  , IpeAttributes+  , Attributes', AttributesOf, AttrMap, AttrMapSym1+  , attributes, traverseIpeAttrs+  , commonAttributes++  , flattenGroups+  ) where++import           Control.Lens hiding (views)+import           Data.Bitraversable+import           Data.Ext+import           Data.Geometry.Box (Rectangle)+import qualified Ipe.Attributes as AT+import           Ipe.Attributes hiding (Matrix)+import           Ipe.Color+import           Ipe.Layer+import           Ipe.Path+import           Data.Geometry.Matrix+import           Data.Geometry.Point+import           Data.Geometry.Properties+import           Data.Geometry.Transformation+import           Data.Proxy+import           Data.Singletons.TH (genDefunSymbols)+import           Data.Text (Text)+import           Data.Traversable+import           Data.Vinyl hiding (Label)+import           Data.Vinyl.TypeLevel (AllConstrained)++--------------------------------------------------------------------------------+-- | Image Objects++data Image r = Image { _imageData :: ()+                     , _rect      :: Rectangle () r+                     } deriving (Show,Eq,Ord)+makeLenses ''Image++type instance NumType   (Image r) = r+type instance Dimension (Image r) = 2++instance Fractional r => IsTransformable (Image r) where+  transformBy t = over rect (transformBy t)++instance Functor Image where+  fmap = fmapDefault+instance Foldable Image where+  foldMap = foldMapDefault+instance Traversable Image where+  traverse f (Image d r) = Image d <$> bitraverse pure f r++--------------------------------------------------------------------------------+-- | Text Objects++data TextLabel r = Label Text (Point 2 r)+                 deriving (Show,Eq,Ord,Functor,Foldable,Traversable)++data MiniPage r = MiniPage Text (Point 2 r) r+                 deriving (Show,Eq,Ord,Functor,Foldable,Traversable)++type instance NumType   (TextLabel r) = r+type instance Dimension (TextLabel r) = 2++type instance NumType   (MiniPage r) = r+type instance Dimension (MiniPage r) = 2++instance Fractional r => IsTransformable (TextLabel r) where+  transformBy t (Label txt p) = Label txt (transformBy t p)++instance Fractional r => IsTransformable (MiniPage r) where+  transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w++width                  :: MiniPage t -> t+width (MiniPage _ _ w) = w++--------------------------------------------------------------------------------+-- | Ipe Symbols, i.e. Points++-- | A symbol (point) in ipe+data IpeSymbol r = Symbol { _symbolPoint :: Point 2 r+                          , _symbolName  :: Text+                          }+                 deriving (Show,Eq,Ord,Functor,Foldable,Traversable)+makeLenses ''IpeSymbol++type instance NumType   (IpeSymbol r) = r+type instance Dimension (IpeSymbol r) = 2++instance Fractional r => IsTransformable (IpeSymbol r) where+  transformBy t = over symbolPoint (transformBy t)++++-- | Example of an IpeSymbol. I.e. A symbol that expresses that the size is 'large'+-- sizeSymbol :: Attributes (AttrMapSym1 r) (SymbolAttributes r)+-- sizeSymbol = attr SSize (IpeSize $ Named "large")+++--------------------------------------------------------------------------------+-- * Paths are in a separate module++--------------------------------------------------------------------------------+-- * Attribute Mapping+++-- | The mapping between the labels of the the attributes and the types of the+-- attributes with these labels. For example, the 'Matrix' label/attribute should+-- have a value of type 'Matrix 3 3 r'.+type family AttrMap (r :: *) (l :: AttributeUniverse) :: * where+  AttrMap r 'Layer          = LayerName+  AttrMap r AT.Matrix       = Matrix 3 3 r+  AttrMap r Pin             = PinType+  AttrMap r Transformations = TransformationTypes++  AttrMap r Stroke = IpeColor r+  AttrMap r Pen    = IpePen r+  AttrMap r Fill   = IpeColor r+  AttrMap r Size   = IpeSize r++  AttrMap r Dash     = IpeDash r+  AttrMap r LineCap  = Int+  AttrMap r LineJoin = Int+  AttrMap r FillRule = FillType+  AttrMap r Arrow    = IpeArrow r+  AttrMap r RArrow   = IpeArrow r+  AttrMap r StrokeOpacity = IpeOpacity+  AttrMap r Opacity       = IpeOpacity+  AttrMap r Tiling        = IpeTiling+  AttrMap r Gradient      = IpeGradient++  AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess++genDefunSymbols [''AttrMap]++--------------------------------------------------------------------------------+++-- | For the types representing attribute values we can get the name/key to use+-- when serializing to ipe.+class TraverseIpeAttr (a :: AttributeUniverse) where+  traverseIpeAttr :: Applicative h+                  => (r -> h s) -> Attr (AttrMapSym1 r) a -> h (Attr (AttrMapSym1 s) a)++  -- attrName :: proxy a -> Text++-- CommonAttributeUnivers+instance TraverseIpeAttr Layer           where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr AT.Matrix       where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr Pin             where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr Transformations where traverseIpeAttr _ = pureAttr++-- -- IpeSymbolAttributeUniversre+instance TraverseIpeAttr Stroke       where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr Fill         where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr Pen          where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr Size         where traverseIpeAttr f = traverseAttr (traverse f)++-- -- PathAttributeUniverse+instance TraverseIpeAttr Dash       where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr LineCap    where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr LineJoin   where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr FillRule   where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr Arrow      where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr RArrow     where traverseIpeAttr f = traverseAttr (traverse f)+instance TraverseIpeAttr StrokeOpacity  where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr Opacity    where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr Tiling     where traverseIpeAttr _ = pureAttr+instance TraverseIpeAttr Gradient   where traverseIpeAttr _ = pureAttr+++-- GroupAttributeUniverse+instance TraverseIpeAttr Clip     where traverseIpeAttr f = traverseAttr (traverse f)++--------------------------------------------------------------------------------+-- | Groups and Objects++--------------------------------------------------------------------------------+-- | Group Attributes++-- -- | Now that we know what a Path is we can define the Attributes of a Group.+-- type family GroupAttrElf (r :: *) (s :: GroupAttributeUniverse) :: * where+--   GroupAttrElf r Clip = Path r -- strictly we event want this to be a closed path I guess++-- genDefunSymbols [''GroupAttrElf]++-- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip]+++-- | A group is essentially a list of IpeObjects.+newtype Group r = Group [IpeObject r] deriving (Show,Eq,Functor,Foldable,Traversable)++type instance NumType   (Group r) = r+type instance Dimension (Group r) = 2++instance Fractional r => IsTransformable (Group r) where+  transformBy t (Group s) = Group $ fmap (transformBy t) s+++type family AttributesOf (t :: * -> *) :: [AttributeUniverse] where+  AttributesOf Group     = GroupAttributes+  AttributesOf Image     = CommonAttributes+  AttributesOf TextLabel = CommonAttributes+  AttributesOf MiniPage  = CommonAttributes+  AttributesOf IpeSymbol = SymbolAttributes+  AttributesOf Path      = PathAttributes+++-- | Attributes' :: * -> [AttributeUniverse] -> *+type Attributes' r = Attributes (AttrMapSym1 r)++type IpeAttributes g r = Attributes' r (AttributesOf g)+++-- | An IpeObject' is essentially the oject ogether with its attributes+type IpeObject' g r = g r :+ IpeAttributes g r++attributes :: Lens' (IpeObject' g r) (IpeAttributes g r)+attributes = extra++-- | traverse for ipe attributes+traverseIpeAttrs               :: ( Applicative f+                                  , AllConstrained TraverseIpeAttr (AttributesOf g)+                                  ) => proxy g -> (r -> f s) -> IpeAttributes g r -> f (IpeAttributes g s)+traverseIpeAttrs _ f (Attrs ats) = fmap Attrs . traverseIpeAttrs' f $ ats++traverseIpeAttrs'   :: ( Applicative f+                       , AllConstrained TraverseIpeAttr ats+                       )+                    => (r -> f s)+                    -> Rec (Attr (AttrMapSym1 r)) ats+                    -> f (Rec (Attr (AttrMapSym1 s)) ats)+traverseIpeAttrs' f = \case+  RNil        -> pure RNil+  (a :& ats') -> (:&) <$> traverseIpeAttr f a <*> traverseIpeAttrs' f ats'+++data IpeObject r =+    IpeGroup     (IpeObject' Group     r)+  | IpeImage     (IpeObject' Image     r)+  | IpeTextLabel (IpeObject' TextLabel r)+  | IpeMiniPage  (IpeObject' MiniPage  r)+  | IpeUse       (IpeObject' IpeSymbol r)+  | IpePath      (IpeObject' Path      r)+++traverseIpeObject'              :: forall g r f s. ( Applicative f+                                                   , Traversable g+                                                   , AllConstrained TraverseIpeAttr (AttributesOf  g)+                                                   )+                                => (r -> f s) -> IpeObject' g r -> f (IpeObject' g s)+traverseIpeObject' f (i :+ ats) = (:+) <$> traverse f i <*> traverseIpeAttrs (Proxy @g) f ats++instance Functor IpeObject where+  fmap = fmapDefault+instance Foldable IpeObject where+  foldMap = foldMapDefault+instance Traversable IpeObject where+  traverse f = \case+    IpeGroup g     -> IpeGroup     <$> traverseIpeObject' f g+    IpeImage i     -> IpeImage     <$> traverseIpeObject' f i+    IpeTextLabel l -> IpeTextLabel <$> traverseIpeObject' f l+    IpeMiniPage p  -> IpeMiniPage  <$> traverseIpeObject' f p+    IpeUse u       -> IpeUse       <$> traverseIpeObject' f u+    IpePath p      -> IpePath      <$> traverseIpeObject' f p+++deriving instance (Show r) => Show (IpeObject r)+-- deriving instance (Read r) => Read (IpeObject r)+deriving instance (Eq r)   => Eq   (IpeObject r)++type instance NumType   (IpeObject r) = r+type instance Dimension (IpeObject r) = 2++makePrisms ''IpeObject++groupItems :: Lens (Group r) (Group s) [IpeObject r] [IpeObject s]+groupItems = lens (\(Group xs) -> xs) (const Group)++class ToObject i where+  mkIpeObject :: IpeObject' i r -> IpeObject r++instance ToObject Group      where mkIpeObject = IpeGroup+instance ToObject Image      where mkIpeObject = IpeImage+instance ToObject TextLabel  where mkIpeObject = IpeTextLabel+instance ToObject MiniPage   where mkIpeObject = IpeMiniPage+instance ToObject IpeSymbol  where mkIpeObject = IpeUse+instance ToObject Path       where mkIpeObject = IpePath++instance Fractional r => IsTransformable (IpeObject r) where+  transformBy t (IpeGroup i)     = IpeGroup     $ i&core %~ transformBy t+  transformBy t (IpeImage i)     = IpeImage     $ i&core %~ transformBy t+  transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t+  transformBy t (IpeMiniPage i)  = IpeMiniPage  $ i&core %~ transformBy t+  transformBy t (IpeUse i)       = IpeUse       $ i&core %~ transformBy t+  transformBy t (IpePath i)      = IpePath      $ i&core %~ transformBy t++-- | Shorthand for constructing ipeObjects+ipeObject'     :: ToObject i => i r -> IpeAttributes i r -> IpeObject r+ipeObject' i a = mkIpeObject $ i :+ a++commonAttributes :: Lens' (IpeObject r) (Attributes (AttrMapSym1 r) CommonAttributes)+commonAttributes = lens (Attrs . g) (\x (Attrs a) -> s x a)+  where+    select :: (CommonAttributes ⊆ AttributesOf g) =>+              Lens' (IpeObject' g r) (Rec (Attr (AttrMapSym1 r)) CommonAttributes)+    select = attributes.unAttrs.rsubset++    g (IpeGroup i)     = i^.select+    g (IpeImage i)     = i^.select+    g (IpeTextLabel i) = i^.select+    g (IpeMiniPage i)  = i^.select+    g (IpeUse i)       = i^.select+    g (IpePath i)      = i^.select++    s (IpeGroup i)     a = IpeGroup     $ i&select .~ a+    s (IpeImage i)     a = IpeImage     $ i&select .~ a+    s (IpeTextLabel i) a = IpeTextLabel $ i&select .~ a+    s (IpeMiniPage i)  a = IpeMiniPage  $ i&select .~ a+    s (IpeUse i)       a = IpeUse       $ i&select .~ a+    s (IpePath i)      a = IpePath      $ i&select .~ a++-- | collect all non-group objects+flattenGroups :: [IpeObject r] -> [IpeObject r]+flattenGroups = concatMap flattenGroups'+  where+    flattenGroups'                              :: IpeObject r -> [IpeObject r]+    flattenGroups' (IpeGroup (Group gs :+ ats)) =+      map (applyAts ats) . concatMap flattenGroups' $ gs+        where+          applyAts _ = id+    flattenGroups' o                            = [o]

@@ -0,0 +1,264 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.FromIpe+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Functions that help reading geometric values from ipe images.+--+--------------------------------------------------------------------------------+module Ipe.FromIpe(+  -- * Individual readers+    _asPoint+  , _asLineSegment+  , _asRectangle+  , _asTriangle++  , _asPolyLine+  , _asSomePolygon, _asSimplePolygon, _asMultiPolygon++  -- * Dealing with Attributes+  , _withAttrs++  -- * Default readers+  , HasDefaultFromIpe(..)++  -- * Reading all elements of a particular type+  , readAll, readAllFrom+  ) where++import           Control.Lens hiding (Simple)+import           Data.Ext+import           Data.Geometry.Ball+import           Data.Geometry.Box+import           Data.Geometry.Ellipse (Ellipse, _EllipseCircle)+import           Ipe.Path+import           Ipe.Reader+import           Ipe.Types+import           Data.Geometry.LineSegment+import           Data.Geometry.Point+import qualified Data.Geometry.PolyLine as PolyLine+import           Data.Geometry.Polygon+import           Data.Geometry.Properties+import           Data.Geometry.Triangle+import qualified Data.LSeq as LSeq+import           Data.List.NonEmpty (NonEmpty(..))++--------------------------------------------------------------------------------+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Ipe.Attributes+-- >>> import Ipe.Color(IpeColor(..))+-- >>> import Data.Geometry.Point+-- >>> :{+-- let testPath :: Path Int+--     testPath = Path . fromSingleton  . PolyLineSegment+--              . PolyLine.fromPoints . map ext+--              $ [ origin, Point2 10 10, Point2 200 100 ]+--     testPathAttrs :: IpeAttributes Path Int+--     testPathAttrs = attr SStroke (IpeColor "red")+--     testObject :: IpeObject Int+--     testObject = IpePath (testPath :+ testPathAttrs)+-- :}++++-- | Extracts the point from a Symbol. When creating a symbol this+-- creates a disk that supports a stroke color.+_asPoint :: Prism' (IpeSymbol r) (Point 2 r)+_asPoint = prism' (flip Symbol "mark/disk(sx)") (Just . view symbolPoint)++-- | Try to convert a path into a line segment, fails if the path is not a line+-- segment or a polyline with more than two points.+--+--+_asLineSegment :: Prism' (Path r) (LineSegment 2 () r)+_asLineSegment = prism' seg2path path2seg+  where+    seg2path   = review _asPolyLine . PolyLine.fromLineSegment+    path2seg p = PolyLine.asLineSegment' =<< preview _asPolyLine p++-- | Convert to a polyline. Ignores all non-polyline parts+--+-- >>> testPath ^? _asPolyLine+-- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])})+_asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r)+_asPolyLine = prism' poly2path path2poly+  where+    poly2path = Path . fromSingleton  . PolyLineSegment+    path2poly = preview (pathSegments.traverse._PolyLineSegment)+    -- TODO: Check that the path actually is a polyline, rather+    -- than ignoring everything that does not fit++-- | Convert to a simple polygon+_asSimplePolygon :: Prism' (Path r) (Polygon Simple () r)+_asSimplePolygon = _asSomePolygon._Left+++-- | Tries to convert a path into a rectangle.+_asRectangle :: forall r. (Num r, Ord r) => Prism' (Path r) (Rectangle () r)+_asRectangle = prism' rectToPath pathToRect+  where+    rectToPath (corners -> Corners a b c d) = review _asSimplePolygon . fromPoints $ [a,b,c,d]+    pathToRect p = p^?_asSimplePolygon >>= asRect++    asRect    :: SimplePolygon () r -> Maybe (Rectangle () r)+    asRect pg = case pg^..outerBoundaryVector.traverse of+        [a,b,c,d] | isH a b && isV b c && isH c d && isV d a -> Just (boundingBoxList' [a,c])+        [a,b,c,d] | isV a b && isH b c && isV c d && isH d a -> Just (boundingBoxList' [a,c])+        _                                                    -> Nothing++    isH (p :+ _) (q :+ _) = p^.xCoord == q^.xCoord+    isV (p :+ _) (q :+ _) = p^.yCoord == q^.yCoord+++-- | Convert to a triangle+_asTriangle :: Prism' (Path r) (Triangle 2 () r)+_asTriangle = prism' triToPath path2tri+  where+    triToPath (Triangle p q r) = polygonToPath . unsafeFromPoints . map (&extra .~ ()) $ [p,q,r]+    path2tri p = case p^..pathSegments.traverse._PolygonPath of+                    []   -> Nothing+                    [pg] -> case polygonVertices pg of+                              (a :| [b,c]) -> Just $ Triangle a b c+                              _            -> Nothing+                    _    -> Nothing+++  -- an ellipse is an affine transformation of the unit disk+++-- (Disk origin 1) (Vector2 1 1)++_asEllipse :: Prism' (Path r) (Ellipse r)+_asEllipse = prism' toPath toEllipse+  where+    toPath      = Path . fromSingleton  . EllipseSegment+    toEllipse p = case p^..pathSegments.traverse._EllipseSegment of+                    [e] -> Just e+                    _   -> Nothing++_asCircle :: (Floating r, Eq r) => Prism' (Path r) (Circle () r)+_asCircle = _asEllipse._EllipseCircle+-- FIXME: For reading we should not need the floating constraint!++_asDisk :: (Floating r, Eq r) => Prism' (Path r) (Disk () r)+_asDisk = _asCircle.from _DiskCircle+++-- | Convert to a multipolygon+_asMultiPolygon :: Prism' (Path r) (MultiPolygon () r)+_asMultiPolygon = _asSomePolygon._Right++-- _asPolygon :: Prism' (Path r) (forall t. Polygon t () r)+-- _asPolygon = prism' polygonToPath (fmap (either id id) . pathToPolygon)++_asSomePolygon :: Prism' (Path r) (SomePolygon () r)+_asSomePolygon = prism' embed pathToPolygon+  where+    embed     = either polygonToPath polygonToPath+++polygonToPath                      :: Polygon t () r -> Path r+polygonToPath pg@SimplePolygon{}   = Path . fromSingleton . PolygonPath $ pg+polygonToPath (MultiPolygon vs hs) = Path . LSeq.fromNonEmpty . fmap PolygonPath+                                   $ vs :| hs+++pathToPolygon   :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r))+pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of+                    []    -> Nothing+                    [pg]  -> Just . Left  $ pg+                    vs:hs -> Just . Right $ MultiPolygon vs hs++++++--------------------------------------------------------------------------------+++-- | Use the first prism to select the ipe object to depicle with, and the second+-- how to select the geometry object from there on. Then we can select the geometry+-- object, directly with its attributes here.+--+-- >>> testObject ^? _withAttrs _IpePath _asPolyLine+-- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})+_withAttrs       :: Prism' (IpeObject r) (i r :+ IpeAttributes i r) -> Prism' (i r) g+                 -> Prism' (IpeObject r) (g :+ IpeAttributes i r)+_withAttrs po pg = prism' g2o o2g+  where+    g2o    = review po . over core (review pg)+    o2g o  = preview po o >>= \(i :+ ats) -> (:+ ats) <$> preview pg i++++++-- instance HasDefaultIpeObject Path where+--   defaultIpeObject' = _IpePath+++-- class HasDefaultFromIpe g where+--   type DefaultFromIpe g :: * -> *+--   defaultIpeObject :: proxy g -> Prism' (IpeObject r) (DefaultFromIpe g r :+ IpeAttributes (DefaultFromIpe g) r)+--   defaultFromIpe   :: proxy g -> Prism' (DefaultFromIpe g (NumType g)) g+++class HasDefaultFromIpe g where+  type DefaultFromIpe g :: * -> *+  defaultFromIpe :: (r ~ NumType g)+                 => Prism' (IpeObject r) (g :+ IpeAttributes (DefaultFromIpe g) r)++instance HasDefaultFromIpe (Point 2 r) where+  type DefaultFromIpe (Point 2 r) = IpeSymbol+  defaultFromIpe = _withAttrs _IpeUse _asPoint+    where+++instance HasDefaultFromIpe (LineSegment 2 () r) where+  type DefaultFromIpe (LineSegment 2 () r) = Path+  defaultFromIpe = _withAttrs _IpePath _asLineSegment++instance HasDefaultFromIpe (Ellipse r) where+  type DefaultFromIpe (Ellipse r) = Path+  defaultFromIpe = _withAttrs _IpePath _asEllipse++instance (Floating r, Eq r) => HasDefaultFromIpe (Circle () r) where+  type DefaultFromIpe (Circle () r) = Path+  defaultFromIpe = _withAttrs _IpePath _asCircle++instance (Floating r, Eq r) => HasDefaultFromIpe (Disk () r) where+  type DefaultFromIpe (Disk () r) = Path+  defaultFromIpe = _withAttrs _IpePath _asDisk++instance HasDefaultFromIpe (PolyLine.PolyLine 2 () r) where+  type DefaultFromIpe (PolyLine.PolyLine 2 () r) = Path+  defaultFromIpe = _withAttrs _IpePath _asPolyLine+++instance HasDefaultFromIpe (SimplePolygon () r) where+  type DefaultFromIpe (SimplePolygon () r) = Path+  defaultFromIpe = _withAttrs _IpePath _asSimplePolygon++instance HasDefaultFromIpe (MultiPolygon () r) where+  type DefaultFromIpe (MultiPolygon () r) = Path+  defaultFromIpe = _withAttrs _IpePath _asMultiPolygon+++-- | Read all g's from some ipe page(s).+readAll   :: forall g r. (HasDefaultFromIpe g, r ~ NumType g)+          => IpePage r -> [g :+ IpeAttributes (DefaultFromIpe g) r]+readAll p = p^..content.traverse.defaultFromIpe++-- | Convenience function from reading all g's from an ipe file. If there+-- is an error reading or parsing the file the error is "thrown away".+readAllFrom    :: forall g r. (HasDefaultFromIpe g, r ~ NumType g, Coordinate r, Eq r)+               => FilePath -> IO [g :+ IpeAttributes (DefaultFromIpe g) r]+readAllFrom fp = foldMap readAll <$> readSinglePageFile fp++fromSingleton :: a -> LSeq.LSeq 1 a+fromSingleton = LSeq.fromNonEmpty . (:| [])

@@ -0,0 +1,290 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.IpeOut+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Functions that help drawing geometric values in ipe. An "IpeOut" is+-- essenitally a function that converts a geometric type g into an IpeObject.+--+-- We also proivde a "HasDefaultIpeOut" typeclass that defines a default+-- conversion function from a geometry type g to an ipe type.+--+--------------------------------------------------------------------------------+module Ipe.IpeOut where+++import           Control.Lens hiding (Simple)+import           Data.Bifunctor+import           Data.Ext+import           Data.Foldable (toList)+import           Data.Geometry.Ball+import           Data.Geometry.BezierSpline+import           Data.Geometry.Boundary+import           Data.Geometry.Box+import           Data.Geometry.Ellipse (Ellipse, circleToEllipse)+import           Data.Geometry.HalfLine+import           Ipe.Attributes+import           Ipe.Color (IpeColor(..))+import           Ipe.FromIpe+import           Ipe.Types+import           Data.Geometry.Line+import           Data.Geometry.LineSegment+import           Data.Geometry.Point+import           Data.Geometry.PolyLine (PolyLine,fromLineSegment)+import           Data.Geometry.Polygon+import           Data.Geometry.Polygon.Convex+import           Data.Geometry.Properties+import qualified Data.LSeq as LSeq+import           Data.List.NonEmpty (NonEmpty(..))++import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.Vinyl (Rec(..))+import           Data.Vinyl.CoRec+++--------------------------------------------------------------------------------++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :{+-- let myPolygon = fromPoints . map ext $ [origin, Point2 10 10, Point2 100 200]+-- :}++--------------------------------------------------------------------------------+-- * The IpeOut type and the default combinator to use it++type IpeOut g i r = g -> IpeObject' i r++-- | Give the option to draw zero, one or more things, i.e. by+-- choosing f ~ Maybe or f ~ []+type IpeOut' f g i r = g -> f (IpeObject' i r)+++-- | Add attributes to an IpeObject'+(!)       :: IpeObject' i r -> IpeAttributes i r -> IpeObject' i r+(!) i ats = i&extra %~ (<> ats)++-- | Render an ipe object+--+--+-- >>> :{+--   iO $ defIO myPolygon ! attr SFill (IpeColor "blue")+--                        ! attr SLayer "alpha"+--                        ! attr SLayer "beta"+-- :}+-- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "blue"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})+--+-- >>> :{+--   iO $ ipeGroup [ iO $ ipePolygon myPolygon ! attr SFill (IpeColor "red")+--                 ] ! attr SLayer "alpha"+-- :}+-- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr})+--+iO :: ToObject i => IpeObject' i r -> IpeObject r+iO = mkIpeObject++-- | Render to an ipe object using the defIO IpeOut+--+--+-- >>> :{+--   iO'' myPolygon $  attr SFill (IpeColor "red")+--                  <> attr SLayer "alpha"+--                  <> attr SLayer "beta"+-- :}+-- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})+--+-- >>> iO'' [ myPolygon , myPolygon ] $ attr SLayer "alpha"+-- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}),IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr})+iO''       :: ( HasDefaultIpeOut g, NumType g ~ r+             , DefaultIpeOut g ~ i, ToObject i+             ) => g -> IpeAttributes i r+           -> IpeObject r+iO'' g ats = iO $ defIO g ! ats++-- | generate an ipe object without any specific attributes+iO' :: HasDefaultIpeOut g => g -> IpeObject (NumType g)+iO' = iO . defIO++--------------------------------------------------------------------------------+-- * Default Conversions++-- | Class that specifies a default conversion from a geometry type g into an+-- ipe object.+class ToObject (DefaultIpeOut g) => HasDefaultIpeOut g where+  type DefaultIpeOut g :: * -> *++  defIO :: IpeOut g (DefaultIpeOut g) (NumType g)++instance (HasDefaultIpeOut g, a ~ IpeAttributes (DefaultIpeOut g) (NumType g))+        => HasDefaultIpeOut (g :+ a) where+  type DefaultIpeOut (g :+ a) = DefaultIpeOut g+  defIO (g :+ ats) = defIO g ! ats++instance HasDefaultIpeOut a => HasDefaultIpeOut [a] where+  type DefaultIpeOut [a] = Group+  defIO = ipeGroup . map (iO .  defIO)++instance HasDefaultIpeOut (Point 2 r) where+  type DefaultIpeOut (Point 2 r) = IpeSymbol+  defIO = ipeDiskMark++instance HasDefaultIpeOut (LineSegment 2 p r) where+  type DefaultIpeOut (LineSegment 2 p r) = Path+  defIO = ipeLineSegment++instance HasDefaultIpeOut (PolyLine 2 p r) where+  type DefaultIpeOut (PolyLine 2 p r) = Path+  defIO = ipePolyLine++instance (Fractional r, Ord r) => HasDefaultIpeOut (Line 2 r) where+  type DefaultIpeOut (Line 2 r) = Path+  defIO = ipeLine++instance (Fractional r, Ord r) => HasDefaultIpeOut (HalfLine 2 r) where+  type DefaultIpeOut (HalfLine 2 r) = Path+  defIO = ipeHalfLine++instance HasDefaultIpeOut (Polygon t p r) where+  type DefaultIpeOut (Polygon t p r) = Path+  defIO = ipePolygon++instance HasDefaultIpeOut (SomePolygon p r) where+  type DefaultIpeOut (SomePolygon p r) = Path+  defIO = either defIO defIO++instance HasDefaultIpeOut (ConvexPolygon p r) where+  type DefaultIpeOut (ConvexPolygon p r) = Path+  defIO = defIO . view simplePolygon++instance HasDefaultIpeOut (Ellipse r) where+  type DefaultIpeOut (Ellipse r) = Path+  defIO = ipeEllipse++instance Floating r => HasDefaultIpeOut (Disk p r) where+  type DefaultIpeOut (Disk p r) = Path+  defIO = ipeDisk++instance Floating r => HasDefaultIpeOut (Circle p r) where+  type DefaultIpeOut (Circle p r) = Path+  defIO = ipeCircle++instance Num r => HasDefaultIpeOut (Rectangle p r) where+  type DefaultIpeOut (Rectangle p r) = Path+  defIO = ipeRectangle++--------------------------------------------------------------------------------+-- * Point Converters++ipeMark     :: Text -> IpeOut (Point 2 r) IpeSymbol r+ipeMark n p = Symbol p n :+ mempty++ipeDiskMark :: IpeOut (Point 2 r) IpeSymbol r+ipeDiskMark = ipeMark "mark/disk(sx)"++--------------------------------------------------------------------------------+-- * Path Converters++-- | Size of the default bounding box used to clip lines and+-- half-lines in the default IpeOuts.+defaultBox :: Num r => Rectangle () r+defaultBox = let z  = 1000+                 z' = negate z+             in box (ext $ Point2 z' z') (ext $ Point2 z z)++-- | Renders a line as a Path. The line is clipped to the 'defaultBox'+ipeLine :: (Ord r, Fractional r) => IpeOut (Line 2 r) Path r+ipeLine = ipeLineIn defaultBox++-- | Renders the line in the given box.+--+-- pre: the intersection of the box with the line is non-empty+ipeLineIn        :: forall p r. (Ord r, Fractional r)+                 => Rectangle p r -> IpeOut (Line 2 r) Path r+ipeLineIn bBox l = match (l `intersect` bBox) $+     H (\NoIntersection    -> error "ipeLineIn: precondition failed, no intersection")+  :& H (\(_p :: Point 2 r) -> error "ipeLineIn: precondition failed, single point")+  :& H ipeLineSegment+  :& RNil++-- | Renders an Halfine.+--+--+-- pre: the intersection of the box with the line is non-empty+ipeHalfLine :: (Ord r, Fractional r) => IpeOut (HalfLine 2 r) Path r+ipeHalfLine = ipeHalfLineIn defaultBox++-- | Renders the HalfLine in the given box.+--+-- pre: the intersection of the box with the line is non-empty+ipeHalfLineIn        :: forall p r. (Ord r, Fractional r)+                     => Rectangle p r -> IpeOut (HalfLine 2 r) Path r+ipeHalfLineIn bBox l = match (l `intersect` bBox) $+     H (\NoIntersection    -> error "ipeHalfLineIn: precondition failed, no intersection")+  :& H (\(_p :: Point 2 r) -> error "ipeHalfLineIn: precondition failed, single point")+  :& H ipeLineSegment+  :& RNil++ipeLineSegment   :: IpeOut (LineSegment 2 p r) Path r+ipeLineSegment s = (path . pathSegment $ s) :+ mempty++ipePolyLine   :: IpeOut (PolyLine 2 p r) Path r+ipePolyLine p = (path . PolyLineSegment . first (const ()) $ p) :+ mempty++ipeEllipse :: IpeOut (Ellipse r) Path r+ipeEllipse = \e -> path (EllipseSegment e) :+ mempty++ipeCircle :: Floating r => IpeOut (Circle p r) Path r+ipeCircle = ipeEllipse . circleToEllipse++ipeDisk   :: Floating r => IpeOut (Disk p r) Path r+ipeDisk d = ipeCircle (Boundary d) ! attr SFill (IpeColor "0.722 0.145 0.137")++ipeBezier :: IpeOut (BezierSpline 3 2 r) Path r+ipeBezier b = (path $ CubicBezierSegment b) :+ mempty++-- | Helper to construct a path from a singleton item+path :: PathSegment r -> Path r+path = Path . LSeq.fromNonEmpty . (:| [])++pathSegment :: LineSegment 2 p r -> PathSegment r+pathSegment = PolyLineSegment . fromLineSegment . first (const ())++-- | Draw a polygon+ipePolygon                          :: IpeOut (Polygon t p r) Path r+ipePolygon (first (const ()) -> pg) = case pg of+               SimplePolygon{} -> pg^.re _asSimplePolygon :+ mempty+               MultiPolygon{}  -> pg^.re _asMultiPolygon  :+ mempty+++-- | Draw a Rectangle+ipeRectangle   :: Num r => IpeOut (Rectangle p r) Path r+ipeRectangle r = ipePolygon $ unsafeFromPoints [tl,tr,br,bl]+  where+    Corners tl tr br bl = corners r++--------------------------------------------------------------------------------+-- * Group Converters++ipeGroup    :: Foldable f => IpeOut (f (IpeObject r)) Group r+ipeGroup xs = Group (toList xs) :+ mempty+++--------------------------------------------------------------------------------+-- * Text Converters++-- | Creates an text label+ipeLabel            :: IpeOut (Text :+ Point 2 r) TextLabel r+ipeLabel (txt :+ p) = Label txt p :+ mempty+++-- | Annotate an IpeOut with a label+labelled                 :: (Show lbl, NumType g ~ r, ToObject i)+                         => (g -> Point 2 r) -- ^ where to place the label+                         -> IpeOut g i r     -- ^ how to draw the geometric object+                         -> IpeOut (g :+ lbl) Group r+labelled pos f (g :+ lbl) = ipeGroup [iO $ f g, iO $ ipeLabel ((Text.pack $ show lbl) :+ pos g)]

@@ -0,0 +1,81 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.IpeRender+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Use 'iperender' to generate png, pdf, or svg files.+--+-- Note that all functions in this module require that 'iperender' is+-- installed (it is bundled with ipe) and available on the path.++--------------------------------------------------------------------------------+module Ipe.IpeRender where++import qualified System.Process.Typed as Process++--------------------------------------------------------------------------------++-- | Call 'iperender' to produce an image of the specified type.+--+-- note that pdf files produces with iperender cannot be opened with ipe.+ipeRenderWith                          :: Options -- ^ the options to use+                                       -> FileType -- ^ output file type+                                       -> FilePath -- ^ input file path+                                       -> FilePath -- ^ output file path+                                       -> IO ()+ipeRenderWith options fType inFp outFp =+    Process.withProcessWait processCfg $ \_iperenderProc -> pure ()+  where+    processCfg = Process.proc "iperender" args+    args = [ "-" <> show fType+           , "-page", show (pageNumber options)+           , "-view", show (viewNumber options)+           , "-resolution", show (resolution options)+           ] <>+           [ "-transparent" | TransparentBackground == transparent options ] <>+           [ "-nocrop"      | NoCrop == crop options ] <>+           [ inFp+           , outFp+           ]++-- | Call 'iperender' with the default options.+--+-- note that pdf files produces with iperender cannot be opened with ipe.+ipeRender :: FileType -> FilePath -> FilePath -> IO ()+ipeRender = ipeRenderWith defaultOptions++--------------------------------------------------------------------------------++-- | Output filetypes supported by iperender+data FileType = PNG | EPS | PDF | SVG+  deriving (Eq,Ord,Enum)++instance Show FileType where+  show = \case+    PNG -> "png"+    EPS -> "eps"+    PDF -> "pdf"+    SVG -> "svg"++-- | Options for iperender+data Options = Options { pageNumber  :: Int+                       , viewNumber  :: Int+                       , resolution  :: Int+                       , transparent :: Background+                       , crop        :: Crop+                       } deriving (Show,Eq,Ord)++-- | The default options in Ipe+defaultOptions :: Options+defaultOptions = Options 1 1 72 TransparentBackground Crop++-- | Whether or not to render a transparent background in output png+-- images.+data Background = OpaqueBackground | TransparentBackground+  deriving (Show,Read,Eq,Ord,Enum)++-- | Whether or not to crop the output image.+data Crop = NoCrop | Crop+  deriving (Show,Read,Eq,Ord,Enum)

@@ -0,0 +1,107 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.IpeToIpe+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Use 'ipetoipe' to generate pdf files.+--+-- Note that all functions in this module require that 'ipetoipe' is+-- installed (it is bundled with ipe) and available on the path.++--------------------------------------------------------------------------------+module Ipe.IpeToIpe where++import           Data.Range+import           Ipe.Types (IpeFile)+import           Ipe.Writer (writeIpeFile, IpeWriteText)+import           System.Directory (getTemporaryDirectory, removeFile)+import           System.FilePath+import qualified System.Process.Typed as Process+import           System.Random++--------------------------------------------------------------------------------++-- | Call 'ipetoipe' to produce an image of the specified type.+ipeToIpeWith                          :: Options -- ^ the options to use+                                      -> FileType -- ^ output file type+                                      -> FilePath -- ^ input file path+                                      -> FilePath -- ^ output file path+                                      -> IO ()+ipeToIpeWith options fType inFp outFp =+    Process.withProcessWait processCfg $ \_iperenderProc -> pure ()+  where+    processCfg = Process.proc "ipetoipe" args+    args = [ "-" <> show fType ] <>+           concat [ [ "-pages", pageRange r ] | PageRange r <- [pages options] ] <>+           concat [ [ "-view", pageView p v ] | Just (p,v) <- [singleView options] ] <>+           [ "-export" | Export == export options ] <>+           [ "-runlatex" | runLatex options] <>+           [ "-nozip"      | NoZip == nozip options ] <>+           [ inFp+           , outFp+           ]+    pageRange (Range' l u) = show l <> "-" <> show u+    pageView p v = show p <> "-" <> show v+++-- | Call 'ipetoipe' with the default options.+ipeToIpe :: FileType -> FilePath -> FilePath -> IO ()+ipeToIpe = ipeToIpeWith defaultOptions++-- | Write an ipe file to disk as an ipe readable pdf file.+--+-- Note that like all other functions in this module, this requires+-- 'ipetoipe' to be installed (it is bundled with ipe) and available+-- on the path.+--+-- Note this will write soem intermediate file to your system temp dir.+writeIpeFileAsPdf      :: IpeWriteText r => FilePath -> IpeFile r -> IO ()+writeIpeFileAsPdf fp f = do num    <- randomIO @Int+                            tempDir <- getTemporaryDirectory+                            let xmlFp = tempDir </> "writeipepdf" <> show num <.> "ipe"+                            writeIpeFile xmlFp f+                            ipeToIpe PDF xmlFp fp+                            removeFile xmlFp+++data FileType = PDF | XML+  deriving (Eq,Enum)++instance Show FileType where+  show = \case+    PDF -> "pdf"+    XML -> "xml"++data Export = RetainIpeInfo | Export+  deriving (Show,Eq,Enum)++type PageNumber = Int+type ViewNumber = Int++data MarkedView = All | OnlyMarkedViews+  deriving (Show,Eq,Enum)++data NoZip = NoZip | Zip+  deriving (Show,Eq,Enum)++data PageRange = EntireFile+               | PageRange (Range PageNumber) -- ^ only closed ranges are supported.+               deriving (Show,Eq)++data Options = Options { export     :: Export+                       , pages      :: PageRange+                       , singleView :: Maybe (PageNumber,ViewNumber)+                       , markedView :: MarkedView+                       , runLatex   :: Bool+                       , nozip      :: NoZip+                       } deriving (Show,Eq)++defaultOptions :: Options+defaultOptions = Options RetainIpeInfo+                         EntireFile+                         Nothing -- default : entire file+                         All+                         False+                         Zip

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.Layer+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Layers in Ipe documents.+--+--------------------------------------------------------------------------------+module Ipe.Layer(+  LayerName(LayerName), layerName+  ) where++import           Control.Lens+import           Data.Text (Text)+import           GHC.Exts++--------------------------------------------------------------------------------++-- | Defines an Layer in Ipe.+newtype LayerName = LayerName {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString)+makeLenses ''LayerName

@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.Literal+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Including xml literals+--+--------------------------------------------------------------------------------+module Ipe.Literal where+++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as C+import Text.XML.Expat.Tree++-- | Include a literal expression+literally :: String -> Q Exp+literally = return . LitE . StringL++-- | Literal quoter.+lit :: QuasiQuoter+lit = QuasiQuoter { quoteExp = literally+                  , quotePat = undefined+                  , quoteType = undefined+                  , quoteDec  = undefined+                  }++-- | Include a file as a literal.+litFile :: QuasiQuoter+litFile = quoteFile lit++-- | Parse a string into a Node.+xmlLiteral :: String -> Node T.Text T.Text+xmlLiteral = either (error "xmlLiteral. error parsing xml: " . show) id+           .  parse' defaultParseOptions . C.pack

@@ -0,0 +1,53 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.Matrix+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Matrix Attributes as defined in Ipe+--+--------------------------------------------------------------------------------+module Ipe.Matrix where++import           Control.Lens hiding (rmap)+import           Data.Ext+import qualified Ipe.Attributes as AT+import           Ipe.Attributes hiding (Matrix)+import           Ipe.Types+import           Data.Geometry.Properties+import           Data.Geometry.Transformation+import           Data.Proxy+import           Data.Vinyl hiding (Label)++--------------------------------------------------------------------------------++-- | Takes and applies the ipe Matrix attribute of this item.+applyMatrix'              :: ( IsTransformable (i r)+                             , AT.Matrix ∈ AttributesOf i+                             , Dimension (i r) ~ 2, r ~ NumType (i r))+                          => IpeObject' i r -> IpeObject' i r+applyMatrix' o@(i :+ ats) = maybe o (\m -> transformBy (Transformation m) i :+ ats') mm+  where+    (mm,ats') = takeAttr (Proxy :: Proxy AT.Matrix) ats++-- | Applies the matrix to an ipe object if it has one.+applyMatrix                  :: Fractional r => IpeObject r -> IpeObject r+applyMatrix (IpeGroup i)     = IpeGroup . applyMatrix'+                             $ i&core.groupItems.traverse %~ applyMatrix+                             -- note that for a group we first (recursively)+                             -- apply the matrices, and then apply+                             -- the matrix of the group to its members.+applyMatrix (IpeImage i)     = IpeImage     $ applyMatrix' i+applyMatrix (IpeTextLabel i) = IpeTextLabel $ applyMatrix' i+applyMatrix (IpeMiniPage i)  = IpeMiniPage  $ applyMatrix' i+applyMatrix (IpeUse i)       = IpeUse       $ applyMatrix' i+applyMatrix (IpePath i)      = IpePath      $ applyMatrix' i++-- | Applies all matrices in the file.+applyMatrices   :: Fractional r => IpeFile r -> IpeFile r+applyMatrices f = f&pages.traverse %~ applyMatricesPage++-- | Applies all Matrices on a given page.+applyMatricesPage   :: Fractional r => IpePage r -> IpePage r+applyMatricesPage p = p&content.traverse %~ applyMatrix

@@ -0,0 +1,148 @@+{-# Language FlexibleContexts  #-}+{-# Language OverloadedStrings  #-}+module Ipe.ParserPrimitives( runP, runP'+                                         , pMany, pMany1, pChoice+                                         , pChar, pSpace, pWhiteSpace, pInteger+                                         , pNatural, pPaddedNatural+                                         , (<*><>) , (<*><)+                                         , (<***>) , (<***) , (***>)+                                         , pMaybe , pCount , pSepBy+                                         , Parser, ParseError+                                         , pNotFollowedBy+                                         ) where+++import           Text.Parsec(try)+import           Text.Parsec(ParsecT, Stream)+import           Text.Parsec.Text+import           Text.ParserCombinators.Parsec hiding (Parser,try)+import qualified Data.Text as T+++runP'     :: Parser a -> T.Text -> (a, T.Text)+runP' p s = case runP p s of+             Left  e -> error $ show e+             Right x -> x++runP   :: Parser a -> T.Text -> Either ParseError (a,T.Text)+runP p = parse ((,) <$> p <*> getInput) ""+++----------------------------------------------------------------------------+-- | reexporting some standard combinators++pMany :: Parser a -> Parser [a]+pMany = many++pMany1 :: Parser a -> Parser [a]+pMany1 = many1+++pChoice :: [Parser a] -> Parser a+pChoice = choice . map try+++pNatural :: Parser Integer+pNatural = read <$> pMany1 digit++-- | parses an integer with a prefix of zeros. Returns the total length of the+-- string parced (i.e. number of digits) and the resulting antural number.+pPaddedNatural :: Parser (Int, Integer)+pPaddedNatural = (\s -> (length s, read s)) <$> pMany1 digit++pInteger :: Parser Integer+pInteger = pNatural+           <|>+           negate <$> (pChar '-' *> pNatural)++pChar :: Char -> Parser Char+pChar = char++pSpace :: Parser Char+pSpace = pChar ' '++pWhiteSpace :: Parser [Char]+pWhiteSpace = pMany1 (space <|> newline)++pMaybe :: Parser a -> Parser (Maybe a)+pMaybe = optionMaybe++pCount :: Int -> Parser a -> Parser [a]+pCount = count++pSepBy :: Parser a -> Parser b -> Parser [a]+pSepBy = sepBy+++-- | infix variant of notfollowed by+pNotFollowedBy :: Parser a -> Parser b -> Parser a+p `pNotFollowedBy` q = do { x <- p ; notFollowedBy' q ; return x }+    where+      -- | copy of the original notFollowedBy but replaced the error message+      -- to get rid of the Show dependency+      notFollowedBy' z     = try (do{ _ <- try z; unexpected "not followed by" }+                                    <|> return ()+                                 )++----------------------------------------------------------------------------+-- | Running parsers in reverse++infix 1 <*><>, <*><++-- | Runs parser q ``in reverse'' on the end of the input stream+(<*><>) ::  (Reversable s, Stream s m t)+        => ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b+p <*><> q = do+  rev+  x <- q+  rev+  f <- p+  return $ f x+++(<*><)   :: (Stream s m t, Reversable s)+          => ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b+p <*>< q = const <$> p <*><> q+++rev :: (Reversable s, Stream s m t) => ParsecT s u m ()+rev = getInput >>= (setInput . reverseS)++-- as :: Parser String+-- as = many (char 'a')++-- foo :: Parser String+-- foo = reverse <$> (string . reverse $ "foo")++-- prs :: Parser (String,String)+-- prs = (,) <$> as <*>< foo'++-- foo' :: Parser String+-- foo' = spaces ***> foo++-- (<***>) :: Parser (a -> b)++infixr 2 <***>, ***>, <***++-- | run the parsers in reverse order, first q, then p+(<***>) :: Monad m => m (t -> b) -> m t -> m b+p <***> q = do+  x <- q+  f <- p+  return $ f x++-- | the variants with missing brackets+(***>) :: Monad m => m a -> m b -> m b+p ***> q = (\_ s -> s) <$> p <***> q++(<***) :: Monad m => m b -> m t -> m b+p <*** q = (\s _ -> s) <$> p <***> q++class Reversable s where+  reverseS :: s -> s++instance Reversable [c] where+  reverseS = reverse++instance Reversable T.Text where+  reverseS = T.reverse

@@ -0,0 +1,124 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.Path+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Defines an Ipe Path.+--+--------------------------------------------------------------------------------+module Ipe.Path(+    Path(Path), pathSegments+  , PathSegment(..)++  , _PolyLineSegment+  , _PolygonPath+  , _CubicBezierSegment+  , _QuadraticBezierSegment+  , _EllipseSegment+  , _ArcSegment+  , _SplineSegment+  , _ClosedSplineSegment++  , Operation(..)+  , _MoveTo+  , _LineTo+  , _CurveTo+  , _QCurveTo+  , _Ellipse+  , _ArcTo+  , _Spline+  , _ClosedSpline+  , _ClosePath+  ) where++import           Control.Lens hiding (rmap)+import           Data.Bitraversable+import           Data.Geometry.BezierSpline+import           Data.Geometry.Point+import           Data.Geometry.Ellipse(Ellipse)+import           Data.Geometry.PolyLine+import           Data.Geometry.Polygon (SimplePolygon)+import           Data.Geometry.Properties+import           Data.Geometry.Transformation+import           Data.Geometry.Matrix+import qualified Data.LSeq as LSeq+import           Data.Traversable++--------------------------------------------------------------------------------+-- | Paths++-- | Paths consist of Path Segments. PathSegments come in the following forms:+data PathSegment r = PolyLineSegment        (PolyLine 2 () r)+                   | PolygonPath            (SimplePolygon () r)+                   | CubicBezierSegment     (BezierSpline 3 2 r)+                   | QuadraticBezierSegment (BezierSpline 2 2 r)+                   | EllipseSegment         (Ellipse r)+                     -- TODO+                   | ArcSegment+                   | SplineSegment          -- (Spline 2 r)+                   | ClosedSplineSegment    -- (ClosedSpline 2 r)+                   deriving (Show,Eq)+makePrisms ''PathSegment++type instance NumType   (PathSegment r) = r+type instance Dimension (PathSegment r) = 2++instance Functor PathSegment where+  fmap = fmapDefault+instance Foldable PathSegment where+  foldMap = foldMapDefault+instance Traversable PathSegment where+  traverse f = \case+    PolyLineSegment p        -> PolyLineSegment <$> bitraverse pure f p+    PolygonPath p            -> PolygonPath <$> bitraverse pure f p+    CubicBezierSegment b     -> CubicBezierSegment <$> traverse f b+    QuadraticBezierSegment b -> QuadraticBezierSegment <$> traverse f b+    EllipseSegment e         -> EllipseSegment <$> traverse f e+    ArcSegment               -> pure ArcSegment+    SplineSegment            -> pure SplineSegment+    ClosedSplineSegment      -> pure ClosedSplineSegment++instance Fractional r => IsTransformable (PathSegment r) where+  transformBy t = \case+    PolyLineSegment p        -> PolyLineSegment $ transformBy t p+    PolygonPath p            -> PolygonPath $ transformBy t p+    CubicBezierSegment b     -> CubicBezierSegment $ transformBy t b+    QuadraticBezierSegment b -> QuadraticBezierSegment $ transformBy t b+    EllipseSegment e         -> EllipseSegment $ transformBy t e+    -- TODO:+    ArcSegment               -> ArcSegment+    SplineSegment            -> SplineSegment+    ClosedSplineSegment      -> ClosedSplineSegment+++-- | A path is a non-empty sequence of PathSegments.+newtype Path r = Path { _pathSegments :: LSeq.LSeq 1 (PathSegment r) }+                 deriving (Show,Eq,Functor,Foldable,Traversable)+makeLenses ''Path++type instance NumType   (Path r) = r+type instance Dimension (Path r) = 2++instance Fractional r => IsTransformable (Path r) where+  transformBy t (Path s) = Path $ fmap (transformBy t) s+++--------------------------------------------------------------------------------++-- | type that represents a path in ipe.+data Operation r = MoveTo (Point 2 r)+                 | LineTo (Point 2 r)+                 | Ellipse (Matrix 3 3 r)+                 | ArcTo (Matrix 3 3 r) (Point 2 r)+                 | Spline [Point 2 r]+                 | ClosedSpline [Point 2 r]+                 | ClosePath+                 -- these should be deprecated+                 | CurveTo (Point 2 r) (Point 2 r) (Point 2 r)+                 | QCurveTo (Point 2 r) (Point 2 r)+                 deriving (Eq, Show,Functor,Foldable,Traversable)+makePrisms ''Operation+

@@ -0,0 +1,194 @@+{-# Language OverloadedStrings #-}+{-# Language DefaultSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Ipe.PathParser+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Parser for a 'Path' in Ipe.+--+--------------------------------------------------------------------------------+module Ipe.PathParser+  ( Coordinate(..)+  , readCoordinate, readPoint+  , readMatrix, readRectangle+  , runParser+  , readPathOperations++  , pOperation, pPoint, pCoordinate+  ) where++import           Data.Bifunctor+import           Data.Char (isSpace)+import           Data.Ext (ext)+import           Data.Functor (($>))+import           Data.Geometry.Box+import           Data.Geometry.Matrix+import           Data.Geometry.Point+import           Data.Geometry.Vector+import           Data.Ratio+import           Data.RealNumber.Rational+import           Data.Text (Text)+import qualified Data.Text as T+import           Ipe.ParserPrimitives+import           Ipe.Path (Operation(..))+import           Text.Parsec.Error (messageString, errorMessages)+++-----------------------------------------------------------------------+-- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read)++class Fractional r => Coordinate r where+    -- reads a coordinate. The input is an integer representing the+    -- part before the decimal point, and a length and an integer+    -- representing the part after the decimal point+    fromSeq :: Integer -> Maybe (Int, Integer) -> r+    default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r+    fromSeq = defaultFromSeq++defaultFromSeq                :: (Ord r, Fractional r)+                              => Integer -> Maybe (Int, Integer) -> r+defaultFromSeq x Nothing      = fromInteger x+defaultFromSeq x (Just (l,y)) = let x'          = fromInteger x+                                    y'          = fromInteger y+                                    asDecimal a =  a * (0.1 ^ l)+                                    z           = if x' < 0 then (-1) else 1+                                in z * (abs x' + asDecimal y')++instance Coordinate Double+instance Coordinate Float+instance Coordinate (Ratio Integer)+instance Coordinate (RealNumber p)++-----------------------------------------------------------------------+-- | Running the parsers++-- | Read/parse a single coordinate value.+readCoordinate :: Coordinate r => Text -> Either Text r+readCoordinate = runParser pCoordinate++-- | Read/parse a single point+readPoint :: Coordinate r => Text -> Either Text (Point 2 r)+readPoint = runParser pPoint++-- | Run a parser+runParser   :: Parser a -> Text -> Either Text a+runParser p = bimap errorText fst . runP p++-- Collect errors+data Either' l r = Left' l | Right' r deriving (Show,Eq)++instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where+  (Left' l)  <> (Left' l')  = Left' $ l <> l'+  (Left' l)  <> _           = Left' l+  _          <> (Left' l')  = Left' l'+  (Right' r) <> (Right' r') = Right' $ r <> r'++instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where+  mempty = Right' mempty+  mappend = (<>)++either' :: (l -> a) -> (r -> a) -> Either' l r -> a+either' lf _  (Left' l)  = lf l+either' _  rf (Right' r) = rf r+-- TODO: Use Validation instead of this home-brew one++-- | Parse a sequence of path operations.+readPathOperations :: Coordinate r => Text -> Either Text [Operation r]+readPathOperations = unWrap . mconcat . map (wrap . runP pOperation)+                   . clean . splitKeepDelims "mlcqeasuh"+    where+      -- Unwrap the Either'. If it is a Left containing all our errors,+      -- combine them into one error. Otherwise just ReWrap it in an proper Either+      unWrap = either' (Left . combineErrors) Right+      -- for the lefts: wrap the error in a list, for the rights: we only care+      -- about the result, so wrap that in a list as well. Collecting the+      -- results is done using the Semigroup instance of Either'+      wrap   = either (Left' . (:[])) (Right' . (:[]) . fst)+      -- Split the input string in pieces, each piece represents one operation+      trim   = T.dropWhile isSpace+      clean  = filter (not . T.null) . map trim+      -- TODO: Do the splitting on the Text rather than unpacking and packing+      -- the thing++errorText :: ParseError -> Text+errorText = T.pack . unlines . map messageString . errorMessages++combineErrors :: [ParseError] -> Text+combineErrors = T.unlines . map errorText+++splitKeepDelims          :: [Char] -> Text -> [Text]+splitKeepDelims delims t = maybe mPref continue $ T.uncons rest+  where+    mPref           = if T.null pref then [] else [pref]+    (pref,rest)     = T.break (`elem` delims) t+    continue (c,t') = pref `T.snoc` c : splitKeepDelims delims t'+++-- | Try to read/parse a matrix.+readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r)+readMatrix = runParser pMatrix++-- | Try to read/parse a Rectangle+readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r)+readRectangle = runParser pRectangle++-----------------------------------------------------------------------+-- * The parsers themselves++-- |  Parse an operation+pOperation :: forall r. Coordinate r => Parser (Operation r)+pOperation = pChoice [ MoveTo       <$> pPoint                         *>> 'm'+                     , LineTo       <$> pPoint                         *>> 'l'+                     , Ellipse      <$> pMatrix                        *>> 'e'+                     , ArcTo        <$> pMatrix <*> pPoint'            *>> 'a'+                     , Spline       <$> pPoint `pSepBy` pWhiteSpace    *>> 'c'+                     , ClosedSpline <$> pPoint `pSepBy` pWhiteSpace    *>> 'u'+                     , pChar 'h'     $> ClosePath+                     , QCurveTo     <$> pPoint <*> pPoint'             *>> 'q'+                     , CurveTo      <$> pPoint <*> pPoint' <*> pPoint' *>> 'c'+                     , Spline       <$> pPoint `pSepBy` pWhiteSpace    *>> 's'+                     ]+             where+               pPoint' = pWhiteSpace *> pPoint+               p *>> c = p <*>< pWhiteSpace ***> pChar c++-- * Parse a Point+pPoint :: Coordinate r => Parser (Point 2 r)+pPoint = Point2 <$> pCoordinate <* pWhiteSpace <*> pCoordinate++-- * Parse a single coordinate.+pCoordinate :: Coordinate r => Parser r+pCoordinate = fromSeq <$> pInteger <*> pDecimal+              where+                pDecimal  = pMaybe (pChar '.' *> pPaddedNatural)+++-- | Parser for a rectangle+pRectangle :: Coordinate r => Parser (Rectangle () r)+pRectangle = (\p q -> box (ext p) (ext q)) <$> pPoint+                                           <*  pWhiteSpace+                                           <*> pPoint++-- | Parser for a matrix.+pMatrix :: Coordinate r => Parser (Matrix 3 3 r)+pMatrix = (\a b -> mkMatrix (a:b)) <$> pCoordinate+                                   <*> pCount 5 (pWhiteSpace *> pCoordinate)+++-- | Generate a matrix from a list of 6 coordinates.+mkMatrix               :: Coordinate r => [r] -> Matrix 3 3 r+mkMatrix [a,b,c,d,e,f] = Matrix $ Vector3 (Vector3 a c e)+                                          (Vector3 b d f)+                                          (Vector3 0 0 1)+                           -- We need the matrix in the following order:+                         -- 012+                         -- 345+                         --+                         -- But ipe uses the following order:+                         -- 024+                         -- 135+mkMatrix _             = error "mkMatrix: need exactly 6 arguments"

@@ -0,0 +1,475 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Ipe.Reader+  ( -- * Reading ipe Files+    readRawIpeFile+  , readIpeFile+  , readSinglePageFile+  , readSinglePageFileThrow+  , ConversionError+  -- * Readiing ipe style files+  , readIpeStylesheet+  , addStyleSheetFrom++    -- * Reading XML directly+  , fromIpeXML+  , readXML++    -- * Read classes+  , IpeReadText(..)+  , IpeRead(..)+  , IpeReadAttr(..)+++    -- * Some low level implementation functions+  , ipeReadTextWith+  , ipeReadObject+  , ipeReadAttrs+  , ipeReadRec++  , Coordinate(..)+  ) where++import           Control.Applicative ((<|>))+import           Control.Lens hiding (Const, rmap)+import           Control.Monad ((<=<))+import           Data.Bifunctor+import qualified Data.ByteString as B+import           Data.Colour.SRGB (RGB(..))+import           Data.Either (rights)+import           Data.Ext+import           Data.Geometry hiding (head)+import           Data.Geometry.BezierSpline+import           Data.Geometry.Box+import           Data.Geometry.Ellipse (ellipseMatrix)+import qualified Data.Geometry.Matrix as Matrix+import           Ipe.Attributes+import           Ipe.Color (IpeColor(..))+import           Ipe.Matrix+import           Ipe.ParserPrimitives (pInteger, pWhiteSpace)+import           Ipe.Path+import           Ipe.PathParser+import           Ipe.Types+import           Ipe.Value+++import qualified Data.Geometry.Polygon as Polygon+import qualified Data.LSeq as LSeq+import qualified Data.List as L+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Maybe (fromMaybe, mapMaybe)+import           Data.Proxy+import           Data.Singletons+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Traversable as Tr+import           Data.Vinyl hiding (Label)+import           Data.Vinyl.Functor+import           Data.Vinyl.TypeLevel+import           Text.XML.Expat.Tree+++--------------------------------------------------------------------------------++type ConversionError = Text+++-- | Given a file path, tries to read an ipe file+readRawIpeFile :: (Coordinate r, Eq r)+               => FilePath -> IO (Either ConversionError (IpeFile r))+readRawIpeFile = fmap fromIpeXML . B.readFile+++-- | Given a file path, tries to read an ipe file.+--+-- This function applies all matrices to objects.+readIpeFile :: (Coordinate r, Eq r)+            => FilePath -> IO (Either ConversionError (IpeFile r))+readIpeFile = fmap (second applyMatrices) . readRawIpeFile+++-- | Since most Ipe file contain only one page, we provide a shortcut for that+-- as well.+--+-- This function applies all matrices, and it makes sure there is at+-- least one layer and view in the page.+--+readSinglePageFile :: (Coordinate r, Eq r)+                   => FilePath -> IO (Either ConversionError (IpePage r))+readSinglePageFile = fmap (fmap f) . readIpeFile+  where+    f   :: IpeFile r -> IpePage r+    f i = withDefaults . NonEmpty.head $ i^.pages++-- | Tries to read a single page file, throws an error when this+-- fails. See 'readSinglePageFile' for further details.+readSinglePageFileThrow    :: (Coordinate r, Eq r) => FilePath -> IO (IpePage r)+readSinglePageFileThrow fp = readSinglePageFile fp >>= \case+  Left err -> fail (show err)+  Right p  -> pure p++-- | Given a Bytestring, try to parse the bytestring into anything that is+-- IpeReadable, i.e. any of the Ipe elements.+fromIpeXML   :: IpeRead (t r) => B.ByteString -> Either ConversionError (t r)+fromIpeXML b = readXML b >>= ipeRead++-- | Reads the data from a Bytestring into a proper Node+readXML :: B.ByteString -> Either ConversionError (Node Text Text)+readXML = first (T.pack . show) . parse' defaultParseOptions++--------------------------------------------------------------------------------++-- | Reading an ipe elemtn from a Text value+class IpeReadText t where+  ipeReadText :: Text -> Either ConversionError t++-- | Reading an ipe lement from Xml+class IpeRead t where+  ipeRead  :: Node Text Text -> Either ConversionError t++--------------------------------------------------------------------------------+--  ReadText instances++instance IpeReadText Text where+  ipeReadText = Right++instance IpeReadText Int where+  ipeReadText = fmap fromInteger . runParser pInteger++instance Coordinate r => IpeReadText (Point 2 r) where+  ipeReadText = readPoint++instance Coordinate r => IpeReadText (Matrix.Matrix 3 3 r) where+  ipeReadText = readMatrix++instance IpeReadText LayerName where+  ipeReadText = Right . LayerName++instance IpeReadText PinType where+  ipeReadText "yes" = Right Yes+  ipeReadText "h"   = Right Horizontal+  ipeReadText "v"   = Right Vertical+  ipeReadText ""    = Right No+  ipeReadText _     = Left "invalid PinType"++instance IpeReadText TransformationTypes where+  ipeReadText "affine"       = Right Affine+  ipeReadText "rigid"        = Right Rigid+  ipeReadText "translations" = Right Translations+  ipeReadText _              = Left "invalid TransformationType"++instance IpeReadText FillType where+  ipeReadText "wind"   = Right Wind+  ipeReadText "eofill" = Right EOFill+  ipeReadText _        = Left "invalid FillType"++instance Coordinate r => IpeReadText (IpeArrow r) where+  ipeReadText t = case T.split (== '/') t of+                    [n,s] -> IpeArrow <$> pure n <*> ipeReadText s+                    _     -> Left "ipeArrow: name contains not exactly 1 / "++instance Coordinate r => IpeReadText (IpeDash r) where+  ipeReadText t = Right . DashNamed $ t+                  -- TODO: Implement proper parsing here+++ipeReadTextWith     :: (Text -> Either t v) -> Text -> Either ConversionError (IpeValue v)+ipeReadTextWith f t = case f t of+                        Right v -> Right (Valued v)+                        Left _  -> Right (Named t)+++instance Coordinate r => IpeReadText (Rectangle () r) where+  ipeReadText = readRectangle++instance Coordinate r => IpeReadText (RGB r) where+  ipeReadText = runParser (pRGB <|> pGrey)+    where+      pGrey = (\c -> RGB c c c) <$> pCoordinate+      pRGB  = RGB <$> pCoordinate <* pWhiteSpace+                  <*> pCoordinate <* pWhiteSpace+                  <*> pCoordinate++instance Coordinate r => IpeReadText (IpeColor r) where+  ipeReadText = fmap IpeColor . ipeReadTextWith ipeReadText++instance Coordinate r => IpeReadText (IpePen r) where+  ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate++instance Coordinate r => IpeReadText (IpeSize r) where+  ipeReadText = fmap IpeSize . ipeReadTextWith readCoordinate+++instance Coordinate r => IpeReadText [Operation r] where+  ipeReadText = readPathOperations++instance (Coordinate r, Fractional r, Eq r) => IpeReadText (NonEmpty.NonEmpty (PathSegment r)) where+  ipeReadText t = ipeReadText t >>= fromOpsN+    where+      fromOpsN xs = case fromOps xs of+                      Left l       -> Left l+                      Right []     -> Left "No path segments produced"+                      Right (p:ps) -> Right $ p NonEmpty.:| ps++      fromOps []            = Right []+      fromOps [Ellipse m]   = Right [EllipseSegment . view (from ellipseMatrix) $ m]+      fromOps (MoveTo p:xs) = fromOps' p xs+      fromOps _             = Left "Path should start with a move to"++      fromOps' _ []             = Left "Found only a MoveTo operation"+      fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops+                                      pts  = map ext $ s:q:mapMaybe (^?_LineTo) ls+                                      poly = Polygon.unsafeFromPoints . dropRepeats $ pts+                                      pl   = fromPointsUnsafe pts+                                  in case xs of+                                       (ClosePath : xs') -> PolygonPath poly   <<| xs'+                                       _                 -> PolyLineSegment pl <<| xs++      fromOps' s [Spline [a, b]]  = Right [QuadraticBezierSegment $ Bezier2 s a b]+      fromOps' s [Spline [a, b, c]]  = Right [CubicBezierSegment $ Bezier3 s a b c]+      fromOps' s [Spline ps] = Right $ map CubicBezierSegment $ splineToCubicBeziers $ s : ps+      -- these will not occur anymore with recent ipe files+      fromOps' s [QCurveTo a b]  = Right [QuadraticBezierSegment $ Bezier2 s a b]+      fromOps' s [CurveTo a b c] = Right [CubicBezierSegment $ Bezier3 s a b c]+      fromOps' _ _ = Left "fromOpts': rest not implemented yet."++      span' pr = L.span (not . isn't pr)++      x <<| xs = (x:) <$> fromOps xs+++-- | Read a list of control points of a uniform cubic B-spline and conver it+--   to cubic Bezier pieces+splineToCubicBeziers :: Fractional r => [Point 2 r] -> [BezierSpline 3 2 r]+splineToCubicBeziers [a, b, c, d] = [Bezier3 a b c d]+splineToCubicBeziers (a : b : c : d : rest) =+  let p = b .+^ (c .-. b) ^/ 2+      q = c .+^ (d .-. c) ^/ 3+      r = p .+^ (q .-. p) ^/ 2+  in (Bezier3 a b p r) : splineToCubicBeziers (r : q : d : rest)+splineToCubicBeziers _ = error "splineToCubicBeziers needs at least four points"+++dropRepeats :: Eq a => [a] -> [a]+dropRepeats = map head . L.group++instance (Coordinate r, Fractional r, Eq r) => IpeReadText (Path r) where+  ipeReadText = fmap (Path . LSeq.fromNonEmpty) . ipeReadText++--------------------------------------------------------------------------------+-- Reading attributes++-- | Basically IpeReadText for attributes. This class is not really meant to be+-- implemented directly. Just define an IpeReadText instance for the type+-- (Apply f at), then the generic instance below takes care of looking up the+-- name of the attribute, and calling the right ipeReadText value. This class+-- is just so that reifyConstraint in `ipeReadRec` can select the right+-- typeclass when building the rec.+class IpeReadAttr t where+  ipeReadAttr  :: Text -> Node Text Text -> Either ConversionError t++instance IpeReadText (Apply f at) => IpeReadAttr (Attr f at) where+  ipeReadAttr n (Element _ ats _) = GAttr <$> Tr.mapM ipeReadText (lookup n ats)+  ipeReadAttr _ _                 = Left "IpeReadAttr: Element expected, Text found"++-- | Combination of zipRecWith and traverse+zipTraverseWith                       :: forall f g h i (rs :: [AttributeUniverse]). Applicative h+                                      => (forall (x :: AttributeUniverse). f x -> g x -> h (i x))+                                      -> Rec f rs -> Rec g rs -> h (Rec i rs)+zipTraverseWith _ RNil      RNil      = pure RNil+zipTraverseWith f (x :& xs) (y :& ys) = (:&) <$> f x y <*> zipTraverseWith f xs ys++-- | Reading the Attributes into a Rec (Attr f), all based on the types of f+-- (the type family mapping labels to types), and a list of labels (ats).+ipeReadRec       :: forall f ats.+                 ( RecApplicative ats+                 , ReifyConstraint IpeReadAttr (Attr f) ats+                 , RecAll (Attr f) ats IpeReadAttr+                 , AllConstrained IpeAttrName ats+                 )+                 => Proxy f -> Proxy ats+                 -> Node Text Text+                 -> Either ConversionError (Rec (Attr  f) ats)+ipeReadRec _ _ x = zipTraverseWith f (writeAttrNames r) r'+  where+    r  = rpure (GAttr Nothing)+    r' = reifyConstraint @IpeReadAttr r+++    f                              :: forall at.+                                      Const Text at+                                   -> (Dict IpeReadAttr :. Attr f) at+                                   -> Either ConversionError (Attr f at)+    f (Const n) (Compose (Dict _)) = ipeReadAttr n x+++-- | Reader for records. Given a proxy of some ipe type i, and a proxy of an+-- coordinate type r, read the IpeAttributes for i from the xml node.+ipeReadAttrs     :: forall proxy proxy' i r f ats.+                 ( f ~ AttrMapSym1 r, ats ~ AttributesOf i+                 , ReifyConstraint IpeReadAttr (Attr f) ats+                 , RecApplicative ats+                 , RecAll (Attr f) ats IpeReadAttr+                 , AllConstrained IpeAttrName ats+                 )+                 => proxy i -> proxy' r+                 -> Node Text Text+                 -> Either ConversionError (IpeAttributes i r)+ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats)+++-- testSym :: B.ByteString+-- testSym = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+++++-- readAttrsFromXML :: B.ByteString -> Either++-- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double)+-- readSymAttrs = readXML testSym+--                >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)++++++-- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes+-- we can properly read an ipe object using ipeReadObject+ipeReadObject           :: ( IpeRead (i r)+                           , f ~ AttrMapSym1 r, ats ~ AttributesOf i+                           , RecApplicative ats+                           , ReifyConstraint IpeReadAttr (Attr f) ats+                           , RecAll (Attr f) ats IpeReadAttr+                           , AllConstrained IpeAttrName ats+                           )+                        => Proxy i -> proxy r -> Node Text Text+                        -> Either ConversionError (i r :+ IpeAttributes i r)+ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml+++--------------------------------------------------------------------------------+-- | Ipe read instances++instance Coordinate r => IpeRead (IpeSymbol r) where+  ipeRead (Element "use" ats _) = case lookup "pos" ats of+      Nothing -> Left "symbol without position"+      Just ps -> flip Symbol name <$> ipeReadText ps+    where+      name = fromMaybe "mark/disk(sx)" $ lookup "name" ats+  ipeRead _ = Left "symbol element expected, text found"++-- | Given a list of Nodes, try to parse all of them as a big text. If we+-- encounter anything else then text, the parsing fails.+allText :: [Node Text Text] -> Either ConversionError Text+allText = fmap T.unlines . mapM unT+  where+    unT (Text t) = Right t+    unT _        = Left "allText: Expected Text, found an Element"++instance (Coordinate r, Fractional r, Eq r) => IpeRead (Path r) where+  ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText+  ipeRead _                      = Left "path: expected element, found text"+++lookup'   :: Text -> [(Text,a)] -> Either ConversionError a+lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k++instance Coordinate r => IpeRead (TextLabel r) where+  ipeRead (Element "text" ats chs)+    | lookup "type" ats == Just "label" = Label+                                       <$> allText chs+                                       <*> (lookup' "pos" ats >>= ipeReadText)+    | otherwise                         = Left "Not a Text label"+  ipeRead _                             = Left "textlabel: Expected element, found text"++++instance Coordinate r => IpeRead (MiniPage r) where+  ipeRead (Element "text" ats chs)+    | lookup "type" ats == Just "minipage" = MiniPage+                                          <$> allText chs+                                          <*> (lookup' "pos"   ats >>= ipeReadText)+                                          <*> (lookup' "width" ats >>= readCoordinate)+    | otherwise                            = Left "Not a MiniPage"+  ipeRead _                                = Left "MiniPage: Expected element, found text"+++instance Coordinate r => IpeRead (Image r) where+  ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText)+  ipeRead _                       = Left "Image: Element expected, text found"++instance (Coordinate r, Fractional r, Eq r) => IpeRead (IpeObject r) where+  ipeRead x = firstRight [ IpeUse       <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x+                         , IpePath      <$> ipeReadObject (Proxy :: Proxy Path)      r x+                         , IpeGroup     <$> ipeReadObject (Proxy :: Proxy Group)     r x+                         , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x+                         , IpeMiniPage  <$> ipeReadObject (Proxy :: Proxy MiniPage)  r x+                         , IpeImage     <$> ipeReadObject (Proxy :: Proxy Image)     r x+                         ]+    where+      r = Proxy :: Proxy r++firstRight :: [Either ConversionError a] -> Either ConversionError a+firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right)+++instance (Coordinate r, Eq r) => IpeRead (Group r) where+  ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs+  ipeRead _                       = Left "ipeRead Group: expected Element, found Text"+++instance IpeRead LayerName where+  ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats+  ipeRead _                       = Left "layer: Expected element, found text"++instance IpeRead View where+  ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a)+                                <$> lookup' "layers" ats+                                <*> (lookup' "active" ats >>= ipeReadText)+  ipeRead _                      = Left "View Expected element, found text"+++-- TODO: this instance throws away all of our error collecting (and is pretty+-- slow/stupid since it tries parsing all children with all parsers)+instance (Coordinate r, Eq r) => IpeRead (IpePage r) where+  ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs)+  ipeRead _                      = Left "page: Element expected, text found"+      -- withDef   :: b -> Either a b -> Either c b+      -- withDef d = either (const $ Right d) Right++      -- readLayers  = withDef ["alpha"] . readAll+      -- readViews   = withDef []        . readAll+      -- readObjects = withDef []        . readAll++-- | try reading everything as an a. Throw away whatever fails.+readAll   :: IpeRead a => [Node Text Text] -> [a]+readAll   = rights . map ipeRead+++instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where+  ipeRead (Element "ipe" _ chs) = case readAll chs of+                                    []  -> Left "Ipe: no pages found"+                                    pgs -> Right $ IpeFile Nothing [] (NonEmpty.fromList pgs)+  ipeRead _                     = Left "Ipe: Element expected, text found"+++instance IpeRead IpeStyle where+  ipeRead = \case+    xml@(Element "ipestyle" ats _) -> Right $ IpeStyle (lookup "name" ats) xml+    _                              -> Left "ipeStyle exptected. Something else found"+++-- | Reads an Ipe stylesheet from Disk.+readIpeStylesheet :: FilePath -> IO (Either ConversionError IpeStyle)+readIpeStylesheet = fmap (ipeRead <=< readXML) . B.readFile++-- | Given a path to a stylesheet, add it to the ipe file with the+-- highest priority. Throws an error when this fails.+addStyleSheetFrom      :: FilePath -> IpeFile r -> IO (IpeFile r)+addStyleSheetFrom fp f = readIpeStylesheet fp >>= \case+  Left err -> fail (show err)+  Right s  -> pure $ addStyleSheet s f++--------------------------------------------------------------------------------