From bedff06725c09b6c4ec8dd84132b70410c889ab2 Mon Sep 17 00:00:00 2001 From: Frank Staals <991345+noinia@users.noreply.github.com> Date: Mon, 16 Sep 2024 22:37:37 +0200 Subject: [PATCH] Getting rid of most of my TemplateHaskell usage (#249) * removing TemplateHaskell from HGeometry itself * getting rid of more template haskell --- hgeometry/ipe/src/Ipe/Content.hs | 39 +++++++-- hgeometry/ipe/src/Ipe/Path.hs | 8 +- hgeometry/ipe/src/Ipe/Types.hs | 87 +++++++++++++++---- .../LineSegment/Intersection/Types.hs | 55 ++++++++++-- .../VerticalRayShooting/PersistentSweep.hs | 18 +++- 5 files changed, 168 insertions(+), 39 deletions(-) diff --git a/hgeometry/ipe/src/Ipe/Content.hs b/hgeometry/ipe/src/Ipe/Content.hs index 473b64a9c..9d165bb7b 100644 --- a/hgeometry/ipe/src/Ipe/Content.hs +++ b/hgeometry/ipe/src/Ipe/Content.hs @@ -33,6 +33,7 @@ import Data.Text (Text) import Data.Traversable import Data.Vinyl hiding (Label) import Data.Vinyl.TypeLevel (AllConstrained) +import GHC.Generics (Generic) import HGeometry.Box (Rectangle) import HGeometry.Ext import HGeometry.Matrix @@ -45,13 +46,24 @@ import Ipe.Color import Ipe.Layer import Ipe.Path + -------------------------------------------------------------------------------- -- | Image Objects +-- | bitmap image objects in Ipe data Image r = Image { _imageData :: () , _rect :: Rectangle (Point 2 r) - } deriving (Show,Eq,Ord) -makeLenses ''Image + } deriving (Show,Eq,Ord,Generic) + +-- | Lens to access the image data +imageData :: Lens' (Image r) () +imageData f (Image i r) = fmap (\i' -> Image i' r) (f i) +{-# INLINE imageData #-} + +-- | Lens to access the rectangle of the image +rect :: Lens (Image r) (Image r') (Rectangle (Point 2 r)) (Rectangle (Point 2 r')) +rect f (Image i r) = fmap (\r' -> Image i r') (f r) +{-# INLINE rect #-} type instance NumType (Image r) = r type instance Dimension (Image r) = 2 @@ -71,7 +83,7 @@ instance Traversable Image where -- | A text label data TextLabel r = Label Text (Point 2 r) - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) type instance NumType (TextLabel r) = r type instance Dimension (TextLabel r) = 2 @@ -88,7 +100,7 @@ instance Fractional r => IsTransformable (TextLabel r) where -- | A Minipage data MiniPage r = MiniPage Text (Point 2 r) r - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) type instance NumType (MiniPage r) = r type instance Dimension (MiniPage r) = 2 @@ -112,8 +124,18 @@ width (MiniPage _ _ w) = w data IpeSymbol r = Symbol { _symbolPoint :: Point 2 r , _symbolName :: Text } - deriving (Show,Eq,Ord) -makeLenses ''IpeSymbol + deriving (Show,Eq,Ord,Generic) + +-- | Lens to access the position of the symbol +symbolPoint :: Lens (IpeSymbol r) (IpeSymbol r') (Point 2 r) (Point 2 r') +symbolPoint f (Symbol p n) = fmap (\p' -> Symbol p' n) (f p) +{-# INLINE symbolPoint #-} + +-- | Lens to access the name of the symbol +symbolName :: Lens' (IpeSymbol r) Text +symbolName f (Symbol p n) = fmap (\n' -> Symbol p n') (f n) +{-# INLINE symbolName #-} + type instance NumType (IpeSymbol r) = r type instance Dimension (IpeSymbol r) = 2 @@ -241,7 +263,8 @@ instance TraverseIpeAttr Clip where traverseIpeAttr f = traverseAttr (traver -- | A group is essentially a list of IpeObjects. -newtype Group r = Group [IpeObject r] deriving (Show,Eq,Functor,Foldable,Traversable) +newtype Group r = Group [IpeObject r] + deriving (Show,Eq,Functor,Foldable,Traversable,Generic) type instance NumType (Group r) = r type instance Dimension (Group r) = 2 @@ -304,7 +327,7 @@ data IpeObject r = | IpeMiniPage (IpeObject' MiniPage r) | IpeUse (IpeObject' IpeSymbol r) | IpePath (IpeObject' Path r) - + deriving (Generic) traverseIpeObject' :: forall g r f s. ( Applicative f , Traversable g diff --git a/hgeometry/ipe/src/Ipe/Path.hs b/hgeometry/ipe/src/Ipe/Path.hs index 625aaffdf..0b1d8a2ca 100644 --- a/hgeometry/ipe/src/Ipe/Path.hs +++ b/hgeometry/ipe/src/Ipe/Path.hs @@ -37,6 +37,7 @@ module Ipe.Path( import Control.Lens hiding (rmap, elements) import qualified Data.Sequence as Seq import Data.Traversable +import GHC.Generics (Generic) import HGeometry.BezierSpline import HGeometry.Ellipse (Ellipse) import HGeometry.Matrix @@ -100,10 +101,12 @@ instance Fractional r => IsTransformable (PathSegment r) where -- | A path is a non-empty sequence of PathSegments. newtype Path r = Path { _pathSegments :: Seq.Seq (PathSegment r) } - deriving (Show,Eq,Functor,Foldable,Traversable) + deriving (Show,Eq,Functor,Foldable,Traversable,Generic) deriving newtype (Semigroup) -makeLenses ''Path +-- | Lens/Iso to access the sequcne of segments of the path +pathSegments :: Iso (Path r) (Path r') (Seq.Seq (PathSegment r)) (Seq.Seq (PathSegment r')) +pathSegments = coerced type instance NumType (Path r) = r type instance Dimension (Path r) = 2 @@ -111,7 +114,6 @@ 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. diff --git a/hgeometry/ipe/src/Ipe/Types.hs b/hgeometry/ipe/src/Ipe/Types.hs index ed443263f..ca7d2b5d7 100644 --- a/hgeometry/ipe/src/Ipe/Types.hs +++ b/hgeometry/ipe/src/Ipe/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -53,15 +52,16 @@ module Ipe.Types( import Control.Lens hiding (views) -import Ipe.Attributes hiding (Matrix) -import Ipe.Content -import Ipe.Layer -import 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 GHC.Generics (Generic) +import Ipe.Attributes hiding (Matrix) +import Ipe.Content +import Ipe.Layer +import Ipe.Literal import Text.XML.Expat.Tree (Node) @@ -73,8 +73,17 @@ import Text.XML.Expat.Tree (Node) data View = View { _layerNames :: [LayerName] , _activeLayer :: LayerName } - deriving (Eq, Ord, Show) -makeLenses ''View + deriving (Eq, Ord, Show, Generic) + +-- | Lens to access the layers in this view +layerNames :: Lens' View [LayerName] +layerNames f (View ns a) = fmap (\ns' -> View ns' a) (f ns) +{-# INLINE layerNames #-} + +-- | Lens to access the active layer +activeLayer :: Lens' View LayerName +activeLayer f (View ns a) = fmap (\a' -> View ns a') (f a) +{-# INLINE activeLayer #-} -- instance Default @@ -83,8 +92,17 @@ makeLenses ''View data IpeStyle = IpeStyle { _styleName :: Maybe Text , _styleData :: Node Text Text } - deriving (Eq,Show) -makeLenses ''IpeStyle + deriving (Eq,Show,Generic) + +-- | Lens to access the style name +styleName :: Lens' IpeStyle (Maybe Text) +styleName f (IpeStyle n sd) = fmap (\n' -> IpeStyle n' sd) (f n) +{-# INLINE styleName #-} + +-- | Lens to access the style data +styleData :: Lens' IpeStyle (Node Text Text) +styleData f (IpeStyle n sd) = fmap (\sd' -> IpeStyle n sd') (f sd) +{-# INLINE styleData #-} -- | The "basic" ipe stylesheet basicIpeStyle :: IpeStyle @@ -99,12 +117,20 @@ opacitiesStyle = IpeStyle (Just "opacities") (xmlLiteral [litFile|data/ipe/opaci data IpePreamble = IpePreamble { _encoding :: Maybe Text , _preambleData :: Text } - deriving (Eq,Read,Show,Ord) -makeLenses ''IpePreamble + deriving (Eq,Read,Show,Ord,Generic) -type IpeBitmap = Text +-- | Lens to access the encoding +encoding :: Lens' IpePreamble (Maybe Text) +encoding f (IpePreamble e pd) = fmap (\e' -> IpePreamble e' pd) (f e) +{-# INLINE encoding #-} +-- | Lens to access the preambleData +preambleData :: Lens' IpePreamble Text +preambleData f (IpePreamble e pd) = fmap (\pd' -> IpePreamble e pd') (f pd) +{-# INLINE preambleData #-} +-- | Ipe Bitmap data +type IpeBitmap = Text -------------------------------------------------------------------------------- -- Ipe Pages @@ -115,8 +141,22 @@ data IpePage r = IpePage { _layers :: [LayerName] , _views :: [View] , _content :: [IpeObject r] } - deriving (Eq,Show) -makeLenses ''IpePage + deriving (Eq,Show,Generic) + +-- | Lens to access the layers of an ipe page +layers :: Lens' (IpePage r) [LayerName] +layers f (IpePage lrs vs cnts) = fmap (\lrs' -> IpePage lrs' vs cnts) (f lrs) +{-# INLINE layers #-} + +-- | Lens to access the views of an ipe page +views :: Lens' (IpePage r) [View] +views f (IpePage lrs vs cnts) = fmap (\vs' -> IpePage lrs vs' cnts) (f vs) +{-# INLINE views #-} + +-- | Lens to access the content of an ipe page +content :: Lens (IpePage r) (IpePage r') [IpeObject r] [IpeObject r'] +content f (IpePage lrs vs cnts) = fmap (\cnts' -> IpePage lrs vs cnts') (f cnts) +{-# INLINE content #-} -- | Creates an empty page with one layer and view. emptyPage :: IpePage r @@ -177,9 +217,22 @@ data IpeFile r = IpeFile { _preamble :: Maybe IpePreamble , _styles :: [IpeStyle] , _pages :: NE.NonEmpty (IpePage r) } - deriving (Eq,Show) -makeLenses ''IpeFile - + deriving (Eq,Show,Generic) + +-- | Lens to access the preamble of an ipe file +preamble :: Lens' (IpeFile r) (Maybe IpePreamble) +preamble f (IpeFile p ss pgs) = fmap (\p' -> IpeFile p' ss pgs) (f p) +{-# INLINE preamble #-} + +-- | Lens to access the styles of an ipe file +styles :: Lens' (IpeFile r) [IpeStyle] +styles f (IpeFile p ss pgs) = fmap (\ss' -> IpeFile p ss' pgs) (f ss) +{-# INLINE styles #-} + +-- | Lens to access the pages of an ipe file +pages :: Lens (IpeFile r) (IpeFile r') (NE.NonEmpty (IpePage r)) (NE.NonEmpty (IpePage r')) +pages f (IpeFile p ss pgs) = fmap (\pgs' -> IpeFile p ss pgs') (f pgs) +{-# INLINE pages #-} -- | Convenience constructor for creating an ipe file without preamble -- and with the default stylesheet. diff --git a/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs b/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs index 62d858c8e..f2ca176e1 100644 --- a/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs +++ b/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : HGeometry.LineSegment.Intersection.Types @@ -58,9 +57,13 @@ import HGeometry.Point -- | Assumes that two segments have the same start point -newtype AroundStart a = AroundStart a deriving (Show,Read,NFData,Functor) +newtype AroundStart a = AroundStart a + deriving (Show,Read,NFData,Functor,Generic) -makeWrapped ''AroundStart +instance Wrapped (AroundStart a) where + type Unwrapped (AroundStart a) = a + +instance (AroundStart a ~ t) => Rewrapped (AroundStart a) t instance ( Point_ point 2 r, Eq r , HasEnd lineSegment point) => Eq (AroundStart lineSegment) where @@ -77,9 +80,12 @@ instance ( LineSegment_ lineSegment point ---------------------------------------- -- | Assumes that two segments have the same end point -newtype AroundEnd a = AroundEnd a deriving (Show,Read,NFData,Functor) +newtype AroundEnd a = AroundEnd a deriving (Show,Read,NFData,Functor,Generic) + +instance Wrapped (AroundEnd a) where + type Unwrapped (AroundEnd a) = a -makeWrapped ''AroundEnd +instance (AroundEnd a ~ t) => Rewrapped (AroundEnd a) t instance (Point_ point 2 r, Eq r, HasStart lineSegment point) => Eq (AroundEnd lineSegment) where -- | equality on endpoint @@ -96,9 +102,13 @@ instance ( LineSegment_ lineSegment point -------------------------------------------------------------------------------- -- | Assumes that two segments intersect in a single point. -newtype AroundIntersection a = AroundIntersection a deriving (Eq,Show,Read,NFData,Functor) +newtype AroundIntersection a = AroundIntersection a + deriving (Eq,Show,Read,NFData,Functor,Generic) -makeWrapped ''AroundIntersection +instance Wrapped (AroundIntersection a) where + type Unwrapped (AroundIntersection a) = a + +instance (AroundIntersection a ~ t) => Rewrapped (AroundIntersection a) t instance ( LineSegment_ lineSegment point , Point_ point 2 r @@ -168,7 +178,20 @@ type OrdArounds lineSegment = ( Ord (AroundStart lineSegment) , Ord (AroundEnd lineSegment) ) -makeLenses ''Associated +-- | Lens to access the segments for which this is a startPoint +startPointOf :: Lens' (Associated lineSegment) (Set.Set (AroundStart lineSegment)) +startPointOf f (Associated ss es is) = fmap (\ss' -> Associated ss' es is) (f ss) +{-# INLINE startPointOf #-} + +-- | Lens to access the segments for which this is an endPoint +endPointOf :: Lens' (Associated lineSegment) (Set.Set (AroundEnd lineSegment)) +endPointOf f (Associated ss es is) = fmap (\es' -> Associated ss es' is) (f es) +{-# INLINE endPointOf #-} + +-- | Lens to access the segments for which this point lies in the interior of the segment +interiorTo :: Lens' (Associated lineSegment) (Set.Set (AroundIntersection lineSegment)) +interiorTo f (Associated ss es is) = fmap (\is' -> Associated ss es is') (f is) +{-# INLINE interiorTo #-} -- | Fold over the segments associated with the intersection. @@ -247,7 +270,21 @@ data IntersectionPoint point lineSegment = IntersectionPoint { _intersectionPoint :: !point , _associatedSegs :: !(Associated lineSegment) } deriving stock (Show,Generic) -makeLenses ''IntersectionPoint + +-- | Lens to access the intersectionp oint +intersectionPoint :: Lens (IntersectionPoint point lineSegment) + (IntersectionPoint point' lineSegment) + point point' +intersectionPoint f (IntersectionPoint p ss) = fmap (\p' -> IntersectionPoint p' ss) (f p) +{-# INLINE intersectionPoint #-} + +-- | Lens to access the associated segments +associatedSegs :: Lens (IntersectionPoint point lineSegment) + (IntersectionPoint point lineSegment') + (Associated lineSegment) (Associated lineSegment') +associatedSegs f (IntersectionPoint p ss) = fmap (\ss' -> IntersectionPoint p ss') (f ss) +{-# INLINE associatedSegs #-} + deriving stock instance ( Eq (AroundStart lineSegment) , Eq (AroundIntersection lineSegment) diff --git a/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs b/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs index 9c217ec83..ca6c2617a 100644 --- a/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs +++ b/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs @@ -1,4 +1,3 @@ -{-# Language TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : HGeometry.VerticalRayShooting.PersistentSweep @@ -21,6 +20,7 @@ module HGeometry.VerticalRayShooting.PersistentSweep import Control.Lens hiding (contains, below) import Data.Foldable (toList) +import Data.Functor.Contravariant (phantom) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -50,10 +50,24 @@ data VerticalRayShootingStructure' r lineSegment = -- status structure is 's', i.e up to 'r' } deriving (Show,Eq) +-- TODO this is very similar to the 'Alternating' sequence structure; so see if we can reuse code + + -- | The status structure type StatusStructure lineSegment = SS.Set lineSegment -makeLensesWith (lensRules&generateUpdateableOptics .~ False) ''VerticalRayShootingStructure' +-- | Getter to access the leftmost coordinate. +leftMost :: Getter (VerticalRayShootingStructure' r lineSegment) r +leftMost f (VerticalRayShootingStructure x _) = phantom (f x) +{-# INLINE leftMost #-} + +-- | Getter to access the sweep structure +sweepStruct :: Getter (VerticalRayShootingStructure' r lineSegment) + (V.Vector (r :+ StatusStructure lineSegment)) +sweepStruct f (VerticalRayShootingStructure _ ss) = phantom (f ss) +{-# INLINE sweepStruct #-} + +-- more or less copied the above two implementations from the TH generated ones -------------------------------------------------------------------------------- -- * Building the DS