diff --git a/semigroupoids.cabal b/semigroupoids.cabal --- a/semigroupoids.cabal +++ b/semigroupoids.cabal @@ -1,8 +1,8 @@ name: semigroupoids category: Control, Comonads -version: 4.2 +version: 4.3 license: BSD3 -cabal-version: >= 1.6 +cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -84,6 +84,12 @@ default: True manual: True +flag doctests + description: + You can disable testing with doctests using `-f-doctests`. + default: True + manual: True + flag comonad description: You can disable the use of the `comonad` package using `-f-comonad`. @@ -98,9 +104,10 @@ library build-depends: - base >= 4 && < 5, - semigroups >= 0.8.3.1 && < 1, - transformers >= 0.2 && < 0.6 + base >= 4 && < 5, + semigroups >= 0.8.3.1 && < 1, + transformers >= 0.2 && < 0.6, + transformers-compat >= 0.3 && < 0.5 if flag(containers) build-depends: containers >= 0.3 && < 0.6 @@ -139,3 +146,18 @@ Data.Traversable.Instances ghc-options: -Wall -fno-warn-warnings-deprecations + + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + ghc-options: -Wall -fno-warn-warnings-deprecations + + if !flag(doctests) + buildable: False + else + build-depends: + base >= 4 && < 5, + doctest >= 0.9.1 && < 0.10, + Glob >= 0.7 && < 0.8 diff --git a/src/Data/Functor/Alt.hs b/src/Data/Functor/Alt.hs --- a/src/Data/Functor/Alt.hs +++ b/src/Data/Functor/Alt.hs @@ -24,6 +24,7 @@ import Control.Monad import Control.Monad.Trans.Identity import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -37,7 +38,7 @@ import Data.Functor.Bind import Data.Semigroup import Data.List.NonEmpty (NonEmpty(..)) -import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++)) +import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either) #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap @@ -155,6 +156,13 @@ case a of Left _ -> n Right r -> return (Right r) + +instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) where + ExceptT m ExceptT n = ExceptT $ do + a <- m + case a of + Left e -> liftM (either (Left . (<>) e) Right) n + Right x -> return (Right x) instance Apply f => Alt (ListT f) where ListT a ListT b = ListT $ () <$> a <.> b diff --git a/src/Data/Functor/Bind.hs b/src/Data/Functor/Bind.hs --- a/src/Data/Functor/Bind.hs +++ b/src/Data/Functor/Bind.hs @@ -58,6 +58,7 @@ #endif import Control.Monad.Trans.Cont import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -220,13 +221,16 @@ #endif -- MaybeT is _not_ the same as Compose f Maybe -instance (Bind m, Monad m) => Apply (MaybeT m) where +instance (Functor m, Monad m) => Apply (MaybeT m) where (<.>) = apDefault -- ErrorT e is _not_ the same as Compose f (Either e) -instance (Bind m, Monad m) => Apply (ErrorT e m) where +instance (Functor m, Monad m) => Apply (ErrorT e m) where (<.>) = apDefault +instance (Functor m, Monad m) => Apply (ExceptT e m) where + (<.>) = apDefault + instance Apply m => Apply (ReaderT e m) where ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e @@ -430,18 +434,25 @@ instance Monad m => Bind (WrappedMonad m) where WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f -instance (Bind m, Monad m) => Bind (MaybeT m) where +instance (Functor m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ -instance (Bind m, Monad m) => Bind (ListT m) where +instance (Apply m, Monad m) => Bind (ListT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ -instance (Bind m, Monad m) => Bind (ErrorT e m) where +instance (Functor m, Monad m) => Bind (ErrorT e m) where m >>- k = ErrorT $ do a <- runErrorT m case a of Left l -> return (Left l) Right r -> runErrorT (k r) + +instance (Functor m, Monad m) => Bind (ExceptT e m) where + m >>- k = ExceptT $ do + a <- runExceptT m + case a of + Left l -> return (Left l) + Right r -> runExceptT (k r) instance Bind m => Bind (ReaderT e m) where ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e diff --git a/src/Data/Semigroup/Foldable.hs b/src/Data/Semigroup/Foldable.hs --- a/src/Data/Semigroup/Foldable.hs +++ b/src/Data/Semigroup/Foldable.hs @@ -12,6 +12,8 @@ ---------------------------------------------------------------------------- module Data.Semigroup.Foldable ( Foldable1(..) + , intercalate1 + , intercalateMap1 , traverse1_ , for1_ , sequenceA1_ @@ -73,6 +75,37 @@ instance Foldable1 ((,) a) where foldMap1 f (_, x) = f x + +newtype JoinWith a = JoinWith {joinee :: (a -> a)} + +instance Semigroup a => Semigroup (JoinWith a) where + JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j + +-- | Insert an 'm' between each pair of 't m'. Equivalent to +-- 'intercalateMap1' with 'id' as the second argument. +-- +-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"] +-- "hello, how, are, you" +-- +-- >>> intercalate1 ", " $ "hello" :| [] +-- "hello" +-- +-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"] +-- "IAmFineYou?" +intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m +intercalate1 = flip intercalateMap1 id +{-# INLINE intercalate1 #-} + +-- | Insert 'm' between each pair of 'm' derived from 'a'. +-- +-- >>> intercalateMap1 " " show $ True :| [False, True] +-- "True False True" +-- +-- >>> intercalateMap1 " " show $ True :| [] +-- "True" +intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m +intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f) +{-# INLINE intercalateMap1 #-} newtype Act f a = Act { getAct :: f a } diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,11 @@ +module Main where + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= + doctest . (["-Wall", + "-fno-warn-warnings-deprecations", + "-optP-include", + "-optPdist/build/autogen/cabal_macros.h"] ++)