packages feed

semigroupoids 5.2 → 5.2.1

raw patch · 10 files changed

+154/−169 lines, 10 filesdep +hashabledep +semigroupoidsdep +unordered-containersdep ~doctestdep ~generic-derivingsetup-changed

Dependencies added: hashable, semigroupoids, unordered-containers

Dependency ranges changed: doctest, generic-deriving

Files

.travis.yml view
@@ -34,17 +34,17 @@     - env: CABALVER=1.24 GHCVER=8.0.2       compiler: ": #GHC 8.0.2"       addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}}-    - env: CABALVER=1.24 GHCVER=8.2.1+    - env: CABALVER=2.0 GHCVER=8.2.1       compiler: ": #GHC 8.2.1"-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1], sources: [hvr-ghc]}}-    - env: CABALVER=1.24 GHCVER=head+      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}}+    - env: CABALVER=head GHCVER=head       compiler: ": #GHC head"-      addons: {apt: {packages: [cabal-install-1.24,ghc-head], sources: [hvr-ghc]}}+      addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}    allow_failures:     - env: CABALVER=1.24 GHCVER=7.0.4     - env: CABALVER=1.24 GHCVER=7.2.2-    - env: CABALVER=1.24 GHCVER=head+    - env: CABALVER=head GHCVER=head  before_install:  - unset CC
CHANGELOG.markdown view
@@ -1,3 +1,12 @@+5.2.1+-----+* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1`+  functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`.+* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex`+* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package+  (on which `semigroupoids` now depends)+* Add `Semigroupoid` instances for `Tagged` and `Const`+ 5.2 --- * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build
Setup.lhs view
@@ -1,182 +1,34 @@ \begin{code} {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-} module Main (main) where  #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif - #if MIN_VERSION_cabal_doctest(1,0,0)-import Distribution.Extra.Doctest ( defaultMainWithDoctests )-#else --- Otherwise we provide a shim--#ifndef MIN_VERSION_Cabal-#define MIN_VERSION_Cabal(x,y,z) 0-#endif-#ifndef MIN_VERSION_directory-#define MIN_VERSION_directory(x,y,z) 0-#endif-#if MIN_VERSION_Cabal(1,24,0)-#define InstalledPackageId UnitId-#endif--import Control.Monad ( when )-import Data.List ( nub )-import Data.String ( fromString )-import Distribution.Package ( InstalledPackageId )-import Distribution.Package ( PackageId, Package (..), packageVersion )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)-import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )-import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))-import Distribution.Text ( display , simpleParse )-import System.FilePath ( (</>) )--#if MIN_VERSION_Cabal(1,25,0)-import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )-#endif+import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests" -#if MIN_VERSION_directory(1,2,2)-import System.Directory (makeAbsolute) #else-import System.Directory (getCurrentDirectory)-import System.FilePath (isAbsolute) -makeAbsolute :: FilePath -> IO FilePath-makeAbsolute p | isAbsolute p = return p-               | otherwise    = do-    cwd <- getCurrentDirectory-    return $ cwd </> p-#endif--generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule testsuiteName flags pkg lbi = do-  let verbosity = fromFlag (buildVerbosity flags)-  let distPref = fromFlag (buildDistPref flags)--  -- Package DBs-  let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]-  let dbFlags = "-hide-all-packages" : packageDbArgs dbStack--  withLibLBI pkg lbi $ \lib libcfg -> do-    let libBI = libBuildInfo lib--    -- modules-    let modules = exposedModules lib ++ otherModules libBI-    -- it seems that doctest is happy to take in module names, not actual files!-    let module_sources = modules--    -- We need the directory with library's cabal_macros.h!-#if MIN_VERSION_Cabal(1,25,0)-    let libAutogenDir = autogenComponentModulesDir lbi libcfg-#else-    let libAutogenDir = autogenModulesDir lbi+#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+import Warning () #endif -    -- Lib sources and includes-    iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI-    includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI--    -- CPP includes, i.e. include cabal_macros.h-    let cppFlags = map ("-optP"++) $-            [ "-include", libAutogenDir ++ "/cabal_macros.h" ]-            ++ cppOptions libBI--    withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do--      -- get and create autogen dir-#if MIN_VERSION_Cabal(1,25,0)-      let testAutogenDir = autogenComponentModulesDir lbi suitecfg-#else-      let testAutogenDir = autogenModulesDir lbi-#endif-      createDirectoryIfMissingVerbose verbosity True testAutogenDir--      -- write autogen'd file-      rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines-        [ "module Build_doctests where"-        , ""-        -- -package-id etc. flags-        , "pkgs :: [String]"-        , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)-        , ""-        , "flags :: [String]"-        , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)-        , ""-        , "module_sources :: [String]"-        , "module_sources = " ++ show (map display module_sources)-        ]-  where-    -- we do this check in Setup, as then doctests don't need to depend on Cabal-    isOldCompiler = maybe False id $ do-      a <- simpleParse $ showCompilerId $ compiler lbi-      b <- simpleParse "7.5"-      return $ packageVersion (a :: PackageId) < b--    formatDeps = map formatOne-    formatOne (installedPkgId, pkgId)-      -- The problem is how different cabal executables handle package databases-      -- when doctests depend on the library-      | packageId pkg == pkgId = "-package=" ++ display pkgId-      | otherwise              = "-package-id=" ++ display installedPkgId--    -- From Distribution.Simple.Program.GHC-    packageDbArgs :: [PackageDB] -> [String]-    packageDbArgs | isOldCompiler = packageDbArgsConf-                  | otherwise     = packageDbArgsDb--    -- GHC <7.6 uses '-package-conf' instead of '-package-db'.-    packageDbArgsConf :: [PackageDB] -> [String]-    packageDbArgsConf dbstack = case dbstack of-      (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-      (GlobalPackageDB:dbs)               -> ("-no-user-package-conf")-                                           : concatMap specific dbs-      _ -> ierror-      where-        specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]-        specific _                      = ierror-        ierror = error $ "internal error: unexpected package db stack: "-                      ++ show dbstack--    -- GHC >= 7.6 uses the '-package-db' flag. See-    -- https://ghc.haskell.org/trac/ghc/ticket/5977.-    packageDbArgsDb :: [PackageDB] -> [String]-    -- special cases to make arguments prettier in common scenarios-    packageDbArgsDb dbstack = case dbstack of-      (GlobalPackageDB:UserPackageDB:dbs)-        | all isSpecific dbs              -> concatMap single dbs-      (GlobalPackageDB:dbs)-        | all isSpecific dbs              -> "-no-user-package-db"-                                           : concatMap single dbs-      dbs                                 -> "-clear-package-db"-                                           : concatMap single dbs-     where-       single (SpecificPackageDB db) = [ "-package-db=" ++ db ]-       single GlobalPackageDB        = [ "-global-package-db" ]-       single UserPackageDB          = [ "-user-package-db" ]-       isSpecific (SpecificPackageDB _) = True-       isSpecific _                     = False--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+import Distribution.Simple -defaultMainWithDoctests :: String -> IO ()-defaultMainWithDoctests testSuiteName = defaultMainWithHooks simpleUserHooks-  { buildHook = \pkg lbi hooks flags -> do-     generateBuildModule testSuiteName flags pkg lbi-     buildHook simpleUserHooks pkg lbi hooks flags-  }+main :: IO ()+main = defaultMain  #endif--main :: IO ()-main = defaultMainWithDoctests "doctests"  \end{code}
+ Warning.hs view
@@ -0,0 +1,5 @@+module Warning+  {-# WARNING ["You are configuring this package without cabal-doctest installed.",+               "The doctests test-suite will not work as a result.",+               "To fix this, install cabal-doctest before configuring."] #-}+  () where
semigroupoids.cabal view
@@ -1,6 +1,6 @@ name:          semigroupoids category:      Control, Comonads-version:       5.2+version:       5.2.1 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -19,6 +19,7 @@   .vim.custom   README.markdown   CHANGELOG.markdown+  Warning.hs description:   Provides a wide array of (semi)groupoids and operations for working with them.   .@@ -117,6 +118,14 @@   default: True   manual: True +flag unordered-containers+  description:+    You can disable the use of the `unordered-containers` package (and also its dependency `hashable`) using `-f-unordered-containers`.+    .+    Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True+ library   build-depends:     base                >= 4.3     && < 5,@@ -147,6 +156,10 @@   if flag(tagged)     build-depends: tagged >= 0.7.3 && < 1 +  if flag(unordered-containers)+    build-depends: hashable >= 1.1  && < 1.3,+                   unordered-containers >= 0.2  && < 0.3+   hs-source-dirs: src    exposed-modules:@@ -185,4 +198,5 @@   else     build-depends:       base      >= 4      && < 5,-      doctest   >= 0.11.1 && < 0.12+      doctest   >= 0.11.1 && < 0.13,+      semigroupoids
src/Data/Functor/Bind/Class.hs view
@@ -82,6 +82,10 @@ import Data.Orphans () import Prelude hiding (id, (.)) +#if MIN_VERSION_base(4,4,0)+import Data.Complex+#endif+ #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap)@@ -99,6 +103,11 @@ import Data.Proxy #endif +#ifdef MIN_VERSION_unordered_containers+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+#endif  #ifdef MIN_VERSION_comonad import Control.Comonad@@ -255,6 +264,11 @@   (<. ) = (<* )   ( .>) = ( *>) +#if MIN_VERSION_base(4,4,0)+instance Apply Complex where+  (a :+ b) <.> (c :+ d) = a c :+ b d+#endif+ #ifdef MIN_VERSION_containers -- | A Map is not 'Applicative', but it is an instance of 'Apply' instance Ord k => Apply (Map k) where@@ -277,6 +291,12 @@   ( .>) = ( *>) #endif +#ifdef MIN_VERSION_unordered_containers+-- | A 'HashMap' is not 'Applicative', but it is an instance of 'Apply'+instance (Hashable k, Eq k) => Apply (HashMap k) where+  (<.>) = HashMap.intersectionWith id+#endif+ -- MaybeT is _not_ the same as Compose f Maybe instance (Functor m, Monad m) => Apply (MaybeT m) where   (<.>) = apDefault@@ -548,6 +568,14 @@   (>>-) = (>>=) -} +#if MIN_VERSION_base(4,4,0)+instance Bind Complex where+  (a :+ b) >>- f = a' :+ b' where+    a' :+ _  = f a+    _  :+ b' = f b+  {-# INLINE (>>-) #-}+#endif+ #ifdef MIN_VERSION_containers -- | A 'Map' is not a 'Monad', but it is an instance of 'Bind' instance Ord k => Bind (Map k) where@@ -562,6 +590,17 @@  instance Bind Tree where   (>>-) = (>>=)+#endif++#ifdef MIN_VERSION_unordered_containers+-- | A 'HashMap' is not a 'Monad', but it is an instance of 'Bind'+instance (Hashable k, Eq k) => Bind (HashMap k) where+  -- this is needlessly painful+  m >>- f = HashMap.fromList $ do+    (k, a) <- HashMap.toList m+    case HashMap.lookup k (f a) of+      Just b -> [(k,b)]+      Nothing -> [] #endif  infixl 4 <<.>>, <<., .>>
src/Data/Semigroup/Foldable.hs view
@@ -17,11 +17,14 @@   , sequenceA1_   , foldMapDefault1   , asum1+  , foldrM1+  , foldlM1   ) where  import Data.Foldable import Data.Functor.Alt (Alt(..)) import Data.Functor.Apply+import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () import Data.Semigroup hiding (Product, Sum) import Data.Semigroup.Foldable.Class@@ -99,3 +102,30 @@ asum1 :: (Foldable1 t, Alt m) => t (m a) -> m a asum1 = getAlt_ . foldMap1 Alt_ {-# INLINE asum1 #-}++-- | Monadic fold over the elements of a non-empty structure,+-- associating to the right, i.e. from right to left.+--+-- > let g = (=<<) . f+-- > in foldrM1 f (x1 :| [x2, ..., xn]) == x1 `g` (x2 `g` ... (xn-1 `f` xn)...)+--+foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a+foldrM1 f = go . toNonEmpty+  where+    g = (=<<) . f+    +    go (e:|es) =+      case es of+        []   -> return e+        x:xs -> e `g` (go (x:|xs))++-- | Monadic fold over the elements of a non-empty structure,+-- associating to the left, i.e. from left to right.+--+-- > let g = flip $ (=<<) . f+-- > in foldlM1 f (x1 :| [x2, ..., xn]) == (...((x1 `f` x2) `g` x2) `g`...) `g` xn+--+foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a+foldlM1 f t = foldlM f x xs+  where+    x:|xs = toNonEmpty t
src/Data/Semigroup/Foldable/Class.hs view
@@ -41,6 +41,10 @@ import Data.Functor.Sum import Data.List.NonEmpty (NonEmpty(..)) +#if MIN_VERSION_base(4,4,0)+import Data.Complex+#endif+ #ifdef MIN_VERSION_tagged import Data.Tagged #endif@@ -64,9 +68,11 @@ class Foldable t => Foldable1 t where   fold1 :: Semigroup m => t m -> m   foldMap1 :: Semigroup m => (a -> m) -> t a -> m+  toNonEmpty :: t a -> NonEmpty a    foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f)   fold1 = foldMap1 id+  toNonEmpty = foldMap1 (:|[])  instance Foldable1 f => Foldable1 (Rec1 f) where   foldMap1 f (Rec1 as) = foldMap1 f as@@ -167,6 +173,12 @@   bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor   {-# INLINE bifoldMap1 #-} +#if MIN_VERSION_base(4,4,0)+instance Foldable1 Complex where+  foldMap1 f (a :+ b) = f a <> f b+  {-# INLINE foldMap1 #-}+#endif+ #ifdef MIN_VERSION_containers instance Foldable1 Tree where   foldMap1 f (Node a []) = f a@@ -207,6 +219,7 @@ instance Foldable1 NonEmpty where   foldMap1 f (a :| []) = f a   foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs)+  toNonEmpty = id  instance Foldable1 ((,) a) where   foldMap1 f (_, x) = f x
src/Data/Semigroup/Traversable/Class.hs view
@@ -47,6 +47,10 @@ #endif import Data.Traversable.Instances () +#if MIN_VERSION_base(4,4,0)+import Data.Complex+#endif+ #ifdef MIN_VERSION_containers import Data.Tree #endif@@ -199,6 +203,12 @@ instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where   traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x   traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y++#if MIN_VERSION_base(4,4,0)+instance Traversable1 Complex where+  traverse1 f (a :+ b) = (:+) <$> f a <.> f b+  {-# INLINE traverse1 #-}+#endif  #ifdef MIN_VERSION_tagged instance Traversable1 (Tagged a) where
src/Data/Semigroupoid.hs view
@@ -27,6 +27,7 @@   , Semi(..)   ) where +import Control.Applicative import Control.Arrow import Data.Functor.Bind import Data.Semigroup@@ -42,6 +43,10 @@ import Control.Comonad #endif +#ifdef MIN_VERSION_tagged+import Data.Tagged (Tagged (..))+#endif+ -- | 'Control.Category.Category' sans 'Control.Category.id' class Semigroupoid c where   o :: c j k -> c i j -> c i k@@ -83,3 +88,11 @@ instance Monoid m => Category (Semi m) where   id = Semi mempty   Semi m . Semi n = Semi (m `mappend` n)++instance Semigroupoid Const where+  _ `o` Const a = Const a++#ifdef MIN_VERSION_tagged+instance Semigroupoid Tagged where+  Tagged b `o` _ = Tagged b+#endif