summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorConalElliott <>2018-08-30 19:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-08-30 19:28:00 (GMT)
commitf8fb67364650732d7f01611f7db510f22448a3af (patch)
treeecd676001c048a431bbfbb63ea71887085852d29
parent4efc31d6179e6c79f5f875770e0709a31bf23223 (diff)
version 0.9.130.9.13
-rw-r--r--TypeCompose.cabal2
-rw-r--r--src/Control/Compose.hs13
-rw-r--r--src/Data/CxMonoid.hs8
-rw-r--r--src/Data/Title.hs5
-rw-r--r--src/Data/Zip.hs2
5 files changed, 22 insertions, 8 deletions
diff --git a/TypeCompose.cabal b/TypeCompose.cabal
index 1b8aa89..fb7280e 100644
--- a/TypeCompose.cabal
+++ b/TypeCompose.cabal
@@ -1,5 +1,5 @@
Name: TypeCompose
-Version: 0.9.12
+Version: 0.9.13
Synopsis: Type composition classes & instances
Category: Composition, Control
Cabal-Version: >= 1.6
diff --git a/src/Control/Compose.hs b/src/Control/Compose.hs
index 264e8fc..9b7d3d5 100644
--- a/src/Control/Compose.hs
+++ b/src/Control/Compose.hs
@@ -87,8 +87,8 @@ import Control.Arrow
import Data.Orphans ()
import Data.Monoid
+import qualified Data.Semigroup as Sem
import Data.Foldable
-import Data.Traversable
import Control.Applicative
import Control.Monad (join,liftM)
@@ -592,10 +592,13 @@ inFlip3 f (Flip ar) = inFlip2 (f ar)
instance Arrow arr => ContraFunctor (Flip arr b) where
contraFmap h (Flip f) = Flip (arr h >>> f)
+instance (Applicative (j a), Sem.Semigroup o) => Sem.Semigroup (Flip j o a) where
+ (<>) = inFlip2 (liftA2 (Sem.<>))
+
-- Useful for (~>) = (->). Maybe others.
instance (Applicative (j a), Monoid o) => Monoid (Flip j o a) where
mempty = Flip (pure mempty)
- mappend = inFlip2 (liftA2 mappend)
+ mappend = (<>)
-- TODO: generalize (->) to (~>) with Applicative_f (~>)
instance Monoid o => Monoid_f (Flip (->) o) where
@@ -642,9 +645,12 @@ inApp2 :: (f a -> f' a' -> f'' a'') -> (App f a -> App f' a' -> App f'' a'')
inApp2 h (App fa) = inApp (h fa)
-- Example: App IO ()
+instance (Applicative f, Sem.Semigroup m) => Sem.Semigroup (App f m) where
+ (<>) = inApp2 (liftA2 (Sem.<>))
+
instance (Applicative f, Monoid m) => Monoid (App f m) where
mempty = App (pure mempty )
- mappend = inApp2 (liftA2 mappend)
+ mappend = (<>)
-- App a `mappend` App b = App (liftA2 mappend a b)
@@ -848,6 +854,7 @@ newtype Arrw j f g a = Arrw { unArrw :: f a `j` g a } -- deriving Monoid
-- For ghc-6.6, use the "deriving" above, but for 6.8 use the "deriving" below.
+deriving instance Sem.Semigroup (f a `j` g a) => Sem.Semigroup (Arrw j f g a)
deriving instance Monoid (f a `j` g a) => Monoid (Arrw j f g a)
-- Replace with generalized bijection?
diff --git a/src/Data/CxMonoid.hs b/src/Data/CxMonoid.hs
index 8758449..ef517f1 100644
--- a/src/Data/CxMonoid.hs
+++ b/src/Data/CxMonoid.hs
@@ -16,6 +16,7 @@
module Data.CxMonoid (MonoidDict, CxMonoid(..), biCxMonoid) where
import Data.Monoid (Monoid(..))
+import qualified Data.Semigroup as Sem
import Data.Bijection
import Data.Title
@@ -30,10 +31,13 @@ newtype CxMonoid a = CxMonoid { unCxMonoid :: MonoidDict a -> a }
biCxMonoid :: (MonoidDict a -> a) :<->: CxMonoid a
biCxMonoid = Bi CxMonoid unCxMonoid
+instance Sem.Semigroup (CxMonoid a) where
+ CxMonoid f <> CxMonoid g =
+ CxMonoid (\ md@(_,op) -> f md `op` g md)
+
instance Monoid (CxMonoid a) where
mempty = CxMonoid (\ (e,_) -> e)
- CxMonoid f `mappend` CxMonoid g =
- CxMonoid (\ md@(_,op) -> f md `op` g md)
+ mappend = (Sem.<>)
-- Exploit the function instance of 'Title'
instance Title a => Title (CxMonoid a) where
diff --git a/src/Data/Title.hs b/src/Data/Title.hs
index a4f2fdd..f7fbf99 100644
--- a/src/Data/Title.hs
+++ b/src/Data/Title.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeOperators, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances, TypeOperators, TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
@@ -40,7 +40,8 @@ class Title_f f where
instance Title_f g => Title_f (g :. f) where title_f str = inO (title_f str)
-instance Title_f f => Title (f a) where title = title_f
+instance {-# OVERLAPPABLE #-} Title_f f => Title (f a) where
+ title = title_f
instance Title String where
title ttl str = (ttl ++ suffix ++ str)
diff --git a/src/Data/Zip.hs b/src/Data/Zip.hs
index 3176019..5d142aa 100644
--- a/src/Data/Zip.hs
+++ b/src/Data/Zip.hs
@@ -5,6 +5,8 @@
#else
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
#endif
+{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
+
----------------------------------------------------------------------
-- |