Better SemiGroup

nobrakal · Aug 4, 2018 · 91a9535 · 91a9535
1 parent aa2458e
commit 91a9535
Showing 1 changed file with 10 additions and 6 deletions.
diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs
@@ -57,7 +57,7 @@ import Control.Applicative (Alternative)
 import Control.DeepSeq (NFData (..))
 import Control.Monad.Compat
 import Data.Foldable (toList)
-import Data.Semigroup (Semigroup (..), stimesIdempotent)
+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, stimesMonoid)
 import Data.Tree
 
 import Algebra.Graph.Internal
@@ -206,8 +206,8 @@ newtype Overlaying a = Overlaying {getOverlaying :: Graph a}
     deriving (Foldable, Functor, Show, Traversable)
 
 instance Semigroup (Overlaying a) where
-    (Overlaying a) <> (Overlaying b) = Overlaying $ Overlay a b
-    stimes = stimesIdempotent
+    (<>) = coerce (overlay :: Graph a -> Graph a -> Graph a)
+    stimes = stimesIdempotentMonoid
 
 instance Monoid (Overlaying a) where
     mempty = Overlaying empty
@@ -216,7 +216,8 @@ newtype Connecting a = Connecting {getConnecting :: Graph a}
     deriving (Foldable, Functor, Show, Traversable)
 
 instance Semigroup (Connecting a) where
-    (Connecting a) <> (Connecting b) = Connecting $ Connect a b
+    (<>) = coerce (connect :: Graph a -> Graph a -> Graph a)
+    stimes = stimesMonoid
 
 instance Monoid (Connecting a) where
     mempty = Connecting empty
@@ -340,7 +341,7 @@ edges = overlays . map (uncurry edge)
 -- 'isEmpty' . overlays == 'all' 'isEmpty'
 -- @
 overlays :: [Graph a] -> Graph a
-overlays = getOverlaying . maybe mempty (sconcat . coerce) . nonEmpty
+overlays = getOverlaying . sconcatM . coerce
 {-# INLINE [0] overlays #-}
 
 -- | Connect a given list of graphs.
@@ -355,14 +356,17 @@ overlays = getOverlaying . maybe mempty (sconcat . coerce) . nonEmpty
 -- 'isEmpty' . connects == 'all' 'isEmpty'
 -- @
 connects :: [Graph a] -> Graph a
-connects = getConnecting . maybe mempty (sconcat . coerce) . nonEmpty
+connects = getConnecting . sconcatM . coerce
 {-# INLINE [0] connects #-}
 
 {-# RULES
  "overlays/map" forall f xs. overlays (map f xs) = getOverlaying (sconcatMap (coerce . f) xs);
  "connects/map" forall f xs. connects (map f xs) = getConnecting (sconcatMap (coerce . f) xs)
   #-}
 
+sconcatM :: Monoid m => [m] -> m
+sconcatM = maybe mempty sconcat . nonEmpty
+
 -- | Utilitary function for rewrite rules of 'overlays' and 'connects'
 sconcatMap :: Monoid m => (b -> m) -> [b] -> m
 sconcatMap f = maybe mempty (sconcatf f) . nonEmpty