Linear semigroups and monoids

Author: b-mehta

linear-base.cabal

@@ -23,6 +23,7 @@ library
     Control.Optics.Linear.Internal
     Data.Bifunctor.Linear
     Data.Functor.Linear
+    Data.Semigroup.Linear
     Data.Vector.Linear
     Data.Profunctor.Linear
     Data.Profunctor.Kleisli.Linear

src/Data/Functor/Linear.hs

@@ -15,7 +15,9 @@
 module Data.Functor.Linear where
 
 import Prelude.Linear.Internal.Simple
+import Prelude (Maybe(..), Either(..))
 import Data.Functor.Const
+import Data.Semigroup.Linear
 
 class Functor f where
   fmap :: (a ->. b) -> f a ->. f b
@@ -74,3 +76,23 @@ instance Traversable [] where
 
 instance Functor (Const x) where
   fmap _ (Const x) = Const x
+
+-- Const is only a traversable if the applicative is changed to a control
+-- applicative
+-- maybe that's the right definition?
+
+instance Monoid x => Applicative (Const x) where
+  pure _ = Const mempty
+  Const x <*> Const y = Const (x <> y)
+
+instance Functor Maybe where
+  fmap _ Nothing = Nothing
+  fmap f (Just x) = Just (f x)
+
+instance Traversable Maybe where
+  sequence Nothing = pure Nothing
+  sequence (Just x) = fmap Just x
+
+instance Functor (Either e) where
+  fmap _ (Left x) = Left x
+  fmap f (Right x) = Right (f x)

src/Data/Semigroup/Linear.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+-- | = The linear semigroup hierarchy
+--
+-- TODO: documentation
+
+module Data.Semigroup.Linear
+  ( Semigroup(..)
+  , Monoid(..)
+  , LEndo(..), appLEndo
+  , module Data.Semigroup
+  )
+  where
+
+import Prelude.Linear.Internal.Simple
+import Data.Semigroup hiding (Semigroup(..))
+import qualified Data.Semigroup as Prelude
+import qualified Prelude
+import qualified Unsafe.Linear as Unsafe
+
+class Prelude.Semigroup a => Semigroup a where
+  (<>) :: a ->. a ->. a
+
+class (Semigroup a, Prelude.Monoid a) => Monoid a where
+  {-# MINIMAL #-}
+  mempty :: a
+  mempty = mempty
+  -- convenience redefine
+
+---------------
+-- Instances --
+---------------
+
+instance Semigroup () where
+  () <> () = ()
+
+newtype LEndo a = LEndo (a ->. a)
+
+-- TODO: have this as a newtype deconstructor once the right type can be
+-- correctly inferred
+appLEndo :: LEndo a ->. a ->. a
+appLEndo (LEndo f) = f
+
+instance Prelude.Semigroup (LEndo a) where
+  LEndo f <> LEndo g = LEndo (f . g)
+instance Prelude.Monoid (LEndo a) where
+  mempty = LEndo id
+instance Semigroup (LEndo a) where
+  LEndo f <> LEndo g = LEndo (f . g)
+instance Monoid (LEndo a) where
+
+instance (Semigroup a, Semigroup b) => Semigroup (a,b) where
+  (a,x) <> (b,y) = (a <> b, x <> y)
+instance (Monoid a, Monoid b) => Monoid (a,b)
+
+instance Semigroup a => Semigroup (Dual a) where
+  Dual x <> Dual y = Dual (y <> x)
+instance Monoid a => Monoid (Dual a)
+
+newtype LWrap a = LWrap a
+  deriving (Prelude.Semigroup, Prelude.Monoid)
+
+-- This instance is unsafe: do not export LWrap so it cannot be used.
+instance Prelude.Semigroup a => Semigroup (LWrap a) where
+  LWrap a <> LWrap b = LWrap (Unsafe.toLinear2 (Prelude.<>) a b)
+instance Prelude.Monoid a => Monoid (LWrap a)
+
+-- XXX: I think these are safe but I'm not fully confident
+deriving via (LWrap (Sum a)) instance Prelude.Num a => Semigroup (Sum a)
+deriving via (LWrap (Sum a)) instance Prelude.Num a => Monoid (Sum a)
+deriving via (LWrap (Product a)) instance Prelude.Num a => Semigroup (Product a)
+deriving via (LWrap (Product a)) instance Prelude.Num a => Monoid (Product a)
+
+-- Bools are movable so this is fine
+deriving via LWrap All instance Semigroup All
+deriving via LWrap All instance Monoid All
+deriving via LWrap Any instance Semigroup Any
+deriving via LWrap Any instance Monoid Any

src/Prelude/Linear.hs

@@ -19,6 +19,8 @@ module Prelude.Linear
   , either
   , maybe
   , forget
+  , Semigroup(..)
+  , Monoid(..)
     -- * Unrestricted
     -- $ unrestricted
   , Unrestricted(..)
@@ -37,6 +39,7 @@ module Prelude.Linear
   , module Prelude
   ) where
 
+import Data.Semigroup.Linear
 import qualified Data.Functor.Linear as Data
 import Data.Vector.Linear (V)
 import qualified Data.Vector.Linear as V
@@ -56,6 +59,8 @@ import Prelude hiding
   , Applicative(..)
   , Monad(..)
   , Traversable(..)
+  , Semigroup(..)
+  , Monoid(..)
   )
 import Prelude.Linear.Internal.Simple
 import qualified Unsafe.Linear as Unsafe