openSUSE Commits
Threads by month
- ----- 2024 -----
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
January 2016
- 1 participants
- 1523 discussions
Hello community,
here is the log from the commit of package ghc-pipes for openSUSE:Factory checked in at 2016-01-28 17:24:05
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-pipes (Old)
and /work/SRC/openSUSE:Factory/.ghc-pipes.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-pipes"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-pipes/ghc-pipes.changes 2015-11-18 22:34:41.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-pipes.new/ghc-pipes.changes 2016-01-28 17:24:59.000000000 +0100
@@ -1,0 +2,5 @@
+Wed Jan 20 10:03:51 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 4.1.8
+
+-------------------------------------------------------------------
Old:
----
pipes-4.1.7.tar.gz
New:
----
pipes-4.1.8.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-pipes.spec ++++++
--- /var/tmp/diff_new_pack.0t2vo8/_old 2016-01-28 17:25:00.000000000 +0100
+++ /var/tmp/diff_new_pack.0t2vo8/_new 2016-01-28 17:25:00.000000000 +0100
@@ -21,7 +21,7 @@
%bcond_with tests
Name: ghc-pipes
-Version: 4.1.7
+Version: 4.1.8
Release: 0
Summary: Compositional pipelines
License: BSD-3-Clause
++++++ pipes-4.1.7.tar.gz -> pipes-4.1.8.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-4.1.7/pipes.cabal new/pipes-4.1.8/pipes.cabal
--- old/pipes-4.1.7/pipes.cabal 2015-11-08 21:06:24.000000000 +0100
+++ new/pipes-4.1.8/pipes.cabal 2016-01-18 19:05:18.000000000 +0100
@@ -1,5 +1,5 @@
Name: pipes
-Version: 4.1.7
+Version: 4.1.8
Cabal-Version: >= 1.10
Build-Type: Simple
License: BSD3
@@ -44,7 +44,7 @@
HS-Source-Dirs: src
Build-Depends:
base >= 4.4 && < 5 ,
- transformers >= 0.2.0.0 && < 0.5,
+ transformers >= 0.2.0.0 && < 0.6,
mmorph >= 1.0.0 && < 1.1,
mtl >= 2.1 && < 2.3
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-4.1.7/src/Pipes/Internal.hs new/pipes-4.1.8/src/Pipes/Internal.hs
--- old/pipes-4.1.7/src/Pipes/Internal.hs 2015-11-08 21:06:24.000000000 +0100
+++ new/pipes-4.1.8/src/Pipes/Internal.hs 2016-01-18 19:05:17.000000000 +0100
@@ -84,10 +84,10 @@
Respond b fb' -> Respond b (\b' -> go (fb' b'))
M m -> M (m >>= \p' -> return (go p'))
Pure f -> fmap f px
- (*>) = (>>)
+ m *> k = m >>= (\_ -> k)
instance Monad m => Monad (Proxy a' a b' b m) where
- return = Pure
+ return = pure
(>>=) = _bind
_bind
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-4.1.7/src/Pipes.hs new/pipes-4.1.8/src/Pipes.hs
--- old/pipes-4.1.7/src/Pipes.hs 2015-11-08 21:06:24.000000000 +0100
+++ new/pipes-4.1.8/src/Pipes.hs 2016-01-18 19:05:17.000000000 +0100
@@ -408,7 +408,7 @@
yield (f x) ) ) )
instance (Monad m) => Monad (ListT m) where
- return a = Select (yield a)
+ return = pure
m >>= f = Select (for (enumerate m) (\a -> enumerate (f a)))
fail _ = mzero
1
0
Hello community,
here is the log from the commit of package ghc-profunctors for openSUSE:Factory checked in at 2016-01-28 17:24:06
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-profunctors (Old)
and /work/SRC/openSUSE:Factory/.ghc-profunctors.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-profunctors"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-profunctors/ghc-profunctors.changes 2015-12-09 22:17:20.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-profunctors.new/ghc-profunctors.changes 2016-01-28 17:25:00.000000000 +0100
@@ -1,0 +2,10 @@
+Wed Jan 20 11:55:47 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 5.2
+* Renamed Cotambara to TambaraChoice and Pastro to PastroChoice.
+* Added a true Cotambara and Copastro construction for (co)freely generating
+ costrength, along with CotambaraSum and CopastroSum variants.
+* Engaged in a fair bit of bikeshedding about the module structure for lesser used
+ modules in this package.
+
+-------------------------------------------------------------------
Old:
----
profunctors-5.1.2.tar.gz
New:
----
profunctors-5.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-profunctors.spec ++++++
--- /var/tmp/diff_new_pack.gkDvTD/_old 2016-01-28 17:25:00.000000000 +0100
+++ /var/tmp/diff_new_pack.gkDvTD/_new 2016-01-28 17:25:00.000000000 +0100
@@ -19,7 +19,7 @@
%global pkg_name profunctors
Name: ghc-profunctors
-Version: 5.1.2
+Version: 5.2
Release: 0
Summary: Profunctors
License: BSD-3-Clause
@@ -32,6 +32,7 @@
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-rpm-macros
# Begin cabal-rpm deps:
+BuildRequires: ghc-base-orphans-devel
BuildRequires: ghc-bifunctors-devel
BuildRequires: ghc-comonad-devel
BuildRequires: ghc-distributive-devel
++++++ profunctors-5.1.2.tar.gz -> profunctors-5.2.tar.gz ++++++
++++ 2590 lines of diff (skipped)
1
0
Hello community,
here is the log from the commit of package ghc-optparse-applicative for openSUSE:Factory checked in at 2016-01-28 17:24:03
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-optparse-applicative (Old)
and /work/SRC/openSUSE:Factory/.ghc-optparse-applicative.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-optparse-applicative"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-optparse-applicative/ghc-optparse-applicative.changes 2016-01-08 15:22:53.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-optparse-applicative.new/ghc-optparse-applicative.changes 2016-01-28 17:24:58.000000000 +0100
@@ -1,0 +2,7 @@
+Wed Jan 20 09:59:00 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 0.12.1.0
+* Improve subparser contexts to improve usage error texts
+* Fixed bugs
+
+-------------------------------------------------------------------
Old:
----
optparse-applicative-0.12.0.0.tar.gz
New:
----
optparse-applicative-0.12.1.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-optparse-applicative.spec ++++++
--- /var/tmp/diff_new_pack.shnxZg/_old 2016-01-28 17:24:59.000000000 +0100
+++ /var/tmp/diff_new_pack.shnxZg/_new 2016-01-28 17:24:59.000000000 +0100
@@ -18,7 +18,7 @@
%global pkg_name optparse-applicative
Name: ghc-optparse-applicative
-Version: 0.12.0.0
+Version: 0.12.1.0
Release: 0
Summary: Utilities and combinators for parsing command line options
Group: System/Libraries
++++++ optparse-applicative-0.12.0.0.tar.gz -> optparse-applicative-0.12.1.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optparse-applicative-0.12.0.0/CHANGELOG.md new/optparse-applicative-0.12.1.0/CHANGELOG.md
--- old/optparse-applicative-0.12.0.0/CHANGELOG.md 2015-09-25 12:00:41.000000000 +0200
+++ new/optparse-applicative-0.12.1.0/CHANGELOG.md 2016-01-19 10:57:20.000000000 +0100
@@ -1,3 +1,17 @@
+## Version 0.12.1.0 (18 Jan 2016)
+
+- Updated dependency bounds.
+
+- Improve subparser contexts to improve usage error texts
+
+- Doc
+
+- Fixed bugs
+ * \# 164 - Invalid options and invalid arguments after parser has succeeded
+ not displaying
+ * \# 146 - multi-word filename completion is broken
+
+
## Version 0.12.0.0 (17 Sep 2015)
- Add "missing" error condition descriptions when required flags and arguments
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optparse-applicative-0.12.0.0/Options/Applicative/BashCompletion.hs new/optparse-applicative-0.12.1.0/Options/Applicative/BashCompletion.hs
--- old/optparse-applicative-0.12.0.0/Options/Applicative/BashCompletion.hs 2015-09-25 12:00:41.000000000 +0200
+++ new/optparse-applicative-0.12.1.0/Options/Applicative/BashCompletion.hs 2016-01-19 10:57:20.000000000 +0100
@@ -78,6 +78,7 @@
[ "_" ++ progn ++ "()"
, "{"
, " local cmdline"
+ , " local IFS=$'\n'"
, " CMDLINE=(--bash-completion-index $COMP_CWORD)"
, ""
, " for arg in ${COMP_WORDS[@]}; do"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optparse-applicative-0.12.0.0/Options/Applicative/Common.hs new/optparse-applicative-0.12.1.0/Options/Applicative/Common.hs
--- old/optparse-applicative-0.12.0.0/Options/Applicative/Common.hs 2015-09-25 12:00:41.000000000 +0200
+++ new/optparse-applicative-0.12.1.0/Options/Applicative/Common.hs 2016-01-19 10:57:20.000000000 +0100
@@ -52,7 +52,7 @@
OptDescStyle (..)
) where
-import Control.Applicative (pure, (<*>), (<$>), (<|>), (<$))
+import Control.Applicative (pure, (<*>), (<*), (*>), (<$>), (<|>), (<$))
import Control.Arrow (left)
import Control.Monad (guard, mzero, msum, when, liftM)
import Control.Monad.Trans.Class (lift)
@@ -102,14 +102,13 @@
return result
CmdReader _ f ->
flip fmap (f arg) $ \subp -> StateT $ \args -> do
- setContext (Just arg) subp
prefs <- getPrefs
let runSubparser
| prefBacktrack prefs = \i a ->
runParser (getPolicy i) (infoParser i) a
| otherwise = \i a
-> (,) <$> runParserInfo i a <*> pure []
- runSubparser subp args
+ enterContext arg subp *> runSubparser subp args <* exitContext
_ -> Nothing
optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
@@ -243,8 +242,9 @@
runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a
runParserFully policy p args = do
(r, args') <- runParser policy p args
- guard $ null args'
- return r
+ case args' of
+ [] -> return r
+ a:_ -> parseError a
-- | The default value of a 'Parser'. This function returns an error if any of
-- the options don't have a default value.
@@ -258,13 +258,11 @@
= Left $ Leaf (f (OptHelpInfo m d) opt)
| otherwise
= Left $ MultNode []
-evalParser m d f (MultP p1 p2) = case evalParser m d f p1 <*> evalParser m d f p2 of
- Right a -> Right a
- Left _ -> case (evalParser m d f p1, evalParser m d f p2) of
- (Left a', Left b') -> Left $ MultNode [a', b']
- (Left a', _) -> Left $ MultNode [a']
- (_, Left b') -> Left $ MultNode [b']
- _ -> Left $ MultNode []
+evalParser m d f (MultP p1 p2) = case (evalParser m d f p1, evalParser m d f p2) of
+ (Right a', Right b') -> Right $ a' b'
+ (Left a', Left b') -> Left $ MultNode [a', b']
+ (Left a', _) -> Left $ MultNode [a']
+ (_, Left b') -> Left $ MultNode [b']
evalParser m d f (AltP p1 p2) = case (evalParser m d f p1, evalParser m d f p2) of
(Right a', _) -> Right a'
(_, Right b') -> Right b'
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optparse-applicative-0.12.0.0/Options/Applicative/Extra.hs new/optparse-applicative-0.12.1.0/Options/Applicative/Extra.hs
--- old/optparse-applicative-0.12.0.0/Options/Applicative/Extra.hs 2015-09-25 12:00:41.000000000 +0200
+++ new/optparse-applicative-0.12.1.0/Options/Applicative/Extra.hs 2016-01-19 10:57:20.000000000 +0100
@@ -44,6 +44,9 @@
, help "Show this help text"
, hidden ]
+-- | Builder for a command parser with a \"helper\" option attached.
+-- Used in the same way as `subparser`, but includes a \"--help|-h\" inside
+-- the subcommand.
hsubparser :: Mod CommandFields a -> Parser a
hsubparser m = mkParser d g rdr
where
@@ -133,7 +136,7 @@
--
-- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@
parserFailure :: ParserPrefs -> ParserInfo a
- -> ParseError -> Context
+ -> ParseError -> [Context]
-> ParserFailure ParserHelp
parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
let h = with_context ctx pinfo $ \names pinfo' -> mconcat
@@ -149,12 +152,12 @@
ShowHelpText -> ExitSuccess
InfoMsg _ -> ExitSuccess
- with_context :: Context
+ with_context :: [Context]
-> ParserInfo a
-> (forall b . [String] -> ParserInfo b -> c)
-> c
- with_context NullContext i f = f [] i
- with_context (Context n i) _ f = f n i
+ with_context [] i f = f [] i
+ with_context c@(Context _ i:_) _ f = f (contextNames c) i
usage_help progn names i = case msg of
InfoMsg _ -> mempty
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optparse-applicative-0.12.0.0/Options/Applicative/Internal.hs new/optparse-applicative-0.12.1.0/Options/Applicative/Internal.hs
--- old/optparse-applicative-0.12.0.0/Options/Applicative/Internal.hs 2015-09-25 12:00:41.000000000 +0200
+++ new/optparse-applicative-0.12.1.0/Options/Applicative/Internal.hs 2016-01-19 10:57:20.000000000 +0100
@@ -17,6 +17,7 @@
, runCompletion
, SomeParser(..)
, ComplError(..)
+ , contextNames
, ListT
, takeListT
@@ -35,15 +36,13 @@
(runExcept, runExceptT, withExcept, ExceptT(..), throwE, catchE)
import Control.Monad.Trans.Reader
(mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
-import Control.Monad.Trans.Writer (runWriterT, WriterT, tell)
-import Control.Monad.Trans.State (StateT, get, put, evalStateT)
-import Data.Maybe (maybeToList)
-import Data.Monoid (Monoid(..))
+import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)
import Options.Applicative.Types
class (Alternative m, MonadPlus m) => MonadP m where
- setContext :: Maybe String -> ParserInfo a -> m ()
+ enterContext :: String -> ParserInfo a -> m ()
+ exitContext :: m ()
getPrefs :: m ParserPrefs
missingArgP :: ParseError -> Completer -> m a
@@ -51,7 +50,7 @@
errorP :: ParseError -> m a
exitP :: Parser b -> Either ParseError a -> m a
-newtype P a = P (ExceptT ParseError (WriterT Context (Reader ParserPrefs)) a)
+newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
instance Functor P where
fmap f (P m) = P $ fmap f m
@@ -74,20 +73,16 @@
data Context
- = forall a . Context [String] (ParserInfo a)
- | NullContext
+ = forall a . Context String (ParserInfo a)
-contextNames :: Context -> [String]
-contextNames (Context ns _) = ns
-contextNames NullContext = []
-
-instance Monoid Context where
- mempty = NullContext
- mappend c (Context ns i) = Context (contextNames c ++ ns) i
- mappend c _ = c
+contextNames :: [Context] -> [String]
+contextNames ns =
+ let go (Context n _) = n
+ in reverse $ go <$> ns
instance MonadP P where
- setContext name = P . lift . tell . Context (maybeToList name)
+ enterContext name pinfo = P $ lift $ modify $ (:) $ Context name pinfo
+ exitContext = P $ lift $ modify $ drop 1
getPrefs = P . lift . lift $ ask
missingArgP e _ = errorP e
@@ -101,8 +96,8 @@
hoistEither :: MonadP m => Either ParseError a -> m a
hoistEither = either errorP return
-runP :: P a -> ParserPrefs -> (Either ParseError a, Context)
-runP (P p) = runReader . runWriterT . runExceptT $ p
+runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])
+runP (P p) = runReader . flip runStateT [] . runExceptT $ p
uncons :: [a] -> Maybe (a, [a])
uncons [] = Nothing
@@ -165,7 +160,8 @@
mplus (Completion x) (Completion y) = Completion $ mplus x y
instance MonadP Completion where
- setContext _ _ = return ()
+ enterContext _ _ = return ()
+ exitContext = return ()
getPrefs = Completion $ lift ask
missingArgP _ = Completion . lift . lift . ComplOption
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optparse-applicative-0.12.0.0/optparse-applicative.cabal new/optparse-applicative-0.12.1.0/optparse-applicative.cabal
--- old/optparse-applicative-0.12.0.0/optparse-applicative.cabal 2015-09-25 12:00:41.000000000 +0200
+++ new/optparse-applicative-0.12.1.0/optparse-applicative.cabal 2016-01-19 10:57:20.000000000 +0100
@@ -1,5 +1,5 @@
name: optparse-applicative
-version: 0.12.0.0
+version: 0.12.1.0
synopsis: Utilities and combinators for parsing command line options
description:
Here is a simple example of an applicative option parser:
@@ -110,7 +110,7 @@
Options.Applicative.Internal
ghc-options: -Wall
build-depends: base == 4.*,
- transformers >= 0.2 && < 0.5,
- transformers-compat >= 0.3 && < 0.5,
- process >= 1.0 && < 1.4,
+ transformers >= 0.2 && < 0.6,
+ transformers-compat >= 0.3 && < 0.6,
+ process >= 1.0 && < 1.5,
ansi-wl-pprint >= 0.6.6 && < 0.7
1
0
Hello community,
here is the log from the commit of package ghc-OpenGLRaw for openSUSE:Factory checked in at 2016-01-28 17:24:02
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-OpenGLRaw (Old)
and /work/SRC/openSUSE:Factory/.ghc-OpenGLRaw.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-OpenGLRaw"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-OpenGLRaw/ghc-OpenGLRaw.changes 2016-01-05 21:55:49.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-OpenGLRaw.new/ghc-OpenGLRaw.changes 2016-01-28 17:24:57.000000000 +0100
@@ -1,0 +2,10 @@
+Mon Jan 11 07:53:35 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 3.1.0.0
+* Changed the type of GL_FALSE and GL_TRUE to GLboolean, leading to fewer
+ fromIntegral calls in user code.
+* Added deprecated functions mkGLDEBUGPROC, mkGLDEBUGPROCAMD, mkGLDEBUGPROCARB,
+ mkGLDEBUGPROCKHR for gl compatibility.
+* Updated OpenGL registry to r32348.
+
+-------------------------------------------------------------------
Old:
----
OpenGLRaw-3.0.0.0.tar.gz
New:
----
OpenGLRaw-3.1.0.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-OpenGLRaw.spec ++++++
--- /var/tmp/diff_new_pack.jcXhkN/_old 2016-01-28 17:24:57.000000000 +0100
+++ /var/tmp/diff_new_pack.jcXhkN/_new 2016-01-28 17:24:58.000000000 +0100
@@ -20,7 +20,7 @@
%global pkg_name OpenGLRaw
Name: ghc-OpenGLRaw
-Version: 3.0.0.0
+Version: 3.1.0.0
Release: 0
Summary: A raw binding for the OpenGL graphics system
License: BSD-3-Clause
++++++ OpenGLRaw-3.0.0.0.tar.gz -> OpenGLRaw-3.1.0.0.tar.gz ++++++
++++ 25983 lines of diff (skipped)
1
0
Hello community,
here is the log from the commit of package ghc-MonadRandom for openSUSE:Factory checked in at 2016-01-28 17:23:59
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-MonadRandom (Old)
and /work/SRC/openSUSE:Factory/.ghc-MonadRandom.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-MonadRandom"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-MonadRandom/ghc-MonadRandom.changes 2016-01-22 01:08:31.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-MonadRandom.new/ghc-MonadRandom.changes 2016-01-28 17:24:54.000000000 +0100
@@ -1,0 +2,6 @@
+Wed Jan 20 09:49:57 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 0.4.2.2
+* Allow transformers-0.5.
+
+-------------------------------------------------------------------
Old:
----
MonadRandom-0.4.2.1.tar.gz
New:
----
MonadRandom-0.4.2.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-MonadRandom.spec ++++++
--- /var/tmp/diff_new_pack.25nlEK/_old 2016-01-28 17:24:55.000000000 +0100
+++ /var/tmp/diff_new_pack.25nlEK/_new 2016-01-28 17:24:55.000000000 +0100
@@ -19,7 +19,7 @@
%global pkg_name MonadRandom
Name: ghc-MonadRandom
-Version: 0.4.2.1
+Version: 0.4.2.2
Release: 0
Summary: Random-number generation monad
License: MIT
++++++ MonadRandom-0.4.2.1.tar.gz -> MonadRandom-0.4.2.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MonadRandom-0.4.2.1/CHANGES.markdown new/MonadRandom-0.4.2.2/CHANGES.markdown
--- old/MonadRandom-0.4.2.1/CHANGES.markdown 2016-01-17 00:40:44.000000000 +0100
+++ new/MonadRandom-0.4.2.2/CHANGES.markdown 2016-01-18 18:09:08.000000000 +0100
@@ -1,3 +1,8 @@
+0.4.2.2 (18 January 2016)
+-------------------------
+
+ - Allow `transformers-0.5`.
+
0.4.2.1 (16 January 2016)
-------------------------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/MonadRandom-0.4.2.1/MonadRandom.cabal new/MonadRandom-0.4.2.2/MonadRandom.cabal
--- old/MonadRandom-0.4.2.1/MonadRandom.cabal 2016-01-17 00:40:44.000000000 +0100
+++ new/MonadRandom-0.4.2.2/MonadRandom.cabal 2016-01-18 18:09:08.000000000 +0100
@@ -1,5 +1,5 @@
name: MonadRandom
-version: 0.4.2.1
+version: 0.4.2.2
synopsis: Random-number generation monad.
description: Support for computations which consume random values.
license: OtherLicense
@@ -11,6 +11,13 @@
build-type: Simple
cabal-version: >=1.10
extra-source-files: CHANGES.markdown
+tested-with:
+ GHC==7.4.2,
+ GHC==7.6.3,
+ GHC==7.8.4,
+ GHC==7.10.3,
+ GHC==8.0.1
+
source-repository head
type: git
location: git://github.com/byorgey/MonadRandom.git
@@ -18,7 +25,7 @@
library
exposed-modules: Control.Monad.Random, Control.Monad.Random.Class
build-depends: base >= 2 && < 5,
- transformers >= 0.3 && < 0.5,
+ transformers >= 0.3 && < 0.6,
transformers-compat >= 0.4 && < 0.6,
mtl >= 2.1 && < 2.3,
random
1
0
Hello community,
here is the log from the commit of package ghc-mono-traversable for openSUSE:Factory checked in at 2016-01-28 17:24:01
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-mono-traversable (Old)
and /work/SRC/openSUSE:Factory/.ghc-mono-traversable.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-mono-traversable"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-mono-traversable/ghc-mono-traversable.changes 2016-01-07 00:25:17.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-mono-traversable.new/ghc-mono-traversable.changes 2016-01-28 17:24:56.000000000 +0100
@@ -1,0 +2,6 @@
+Tue Jan 26 09:50:06 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 0.10.1
+* Allow comonad-5
+
+-------------------------------------------------------------------
Old:
----
mono-traversable-0.10.0.1.tar.gz
New:
----
mono-traversable-0.10.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-mono-traversable.spec ++++++
--- /var/tmp/diff_new_pack.QDsQN7/_old 2016-01-28 17:24:56.000000000 +0100
+++ /var/tmp/diff_new_pack.QDsQN7/_new 2016-01-28 17:24:56.000000000 +0100
@@ -20,7 +20,7 @@
%bcond_with tests
Name: ghc-mono-traversable
-Version: 0.10.0.1
+Version: 0.10.1
Release: 0
Summary: Type classes for mapping, folding, and traversing monomorphic containers
Group: System/Libraries
++++++ mono-traversable-0.10.0.1.tar.gz -> mono-traversable-0.10.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mono-traversable-0.10.0.1/ChangeLog.md new/mono-traversable-0.10.1/ChangeLog.md
--- old/mono-traversable-0.10.0.1/ChangeLog.md 2015-12-13 09:10:48.000000000 +0100
+++ new/mono-traversable-0.10.1/ChangeLog.md 2016-01-18 13:20:42.000000000 +0100
@@ -1,3 +1,7 @@
+## 0.10.1
+
+* Allow comonad-5 [#86](https://github.com/snoyberg/mono-traversable/issues/86)
+
## 0.10.0.1
* Instance for Data.Sequence.Seq is incorrect. [#83](https://github.com/snoyberg/mono-traversable/issues/83)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mono-traversable-0.10.0.1/mono-traversable.cabal new/mono-traversable-0.10.1/mono-traversable.cabal
--- old/mono-traversable-0.10.0.1/mono-traversable.cabal 2015-12-13 09:10:48.000000000 +0100
+++ new/mono-traversable-0.10.1/mono-traversable.cabal 2016-01-18 13:20:42.000000000 +0100
@@ -1,5 +1,5 @@
name: mono-traversable
-version: 0.10.0.1
+version: 0.10.1
synopsis: Type classes for mapping, folding, and traversing monomorphic containers
description: Monomorphic variants of the Functor, Foldable, and Traversable typeclasses. If you understand Haskell's basic typeclasses, you understand mono-traversable. In addition to what you are used to, it adds on an IsSequence typeclass and has code for marking data structures as non-empty.
homepage: https://github.com/snoyberg/mono-traversable
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mono-traversable-0.10.0.1/src/Data/MonoTraversable.hs new/mono-traversable-0.10.1/src/Data/MonoTraversable.hs
--- old/mono-traversable-0.10.0.1/src/Data/MonoTraversable.hs 2015-12-13 09:10:48.000000000 +0100
+++ new/mono-traversable-0.10.1/src/Data/MonoTraversable.hs 2016-01-18 13:20:42.000000000 +0100
@@ -1,4 +1,5 @@
{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -68,7 +69,9 @@
import Control.Comonad.Store (StoreT)
import Control.Comonad.Env (EnvT)
import Control.Comonad.Traced (TracedT)
+#if !MIN_VERSION_comonad(5,0,0)
import Data.Functor.Coproduct (Coproduct)
+#endif
import Control.Monad.Trans.Writer (WriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)
import Control.Monad.Trans.State (StateT(..))
@@ -151,7 +154,9 @@
type instance Element (EnvT e w a) = a
type instance Element (StoreT s w a) = a
type instance Element (TracedT m w a) = a
+#if !MIN_VERSION_comonad(5,0,0)
type instance Element (Coproduct f g a) = a
+#endif
-- | Monomorphic containers that can be mapped over.
class MonoFunctor mono where
@@ -198,7 +203,9 @@
instance Functor w => MonoFunctor (EnvT e w a)
instance Functor w => MonoFunctor (StoreT s w a)
instance Functor w => MonoFunctor (TracedT m w a)
+#if !MIN_VERSION_comonad(5,0,0)
instance (Functor f, Functor g) => MonoFunctor (Coproduct f g a)
+#endif
instance Arrow a => MonoFunctor (WrappedArrow a b c)
instance Functor f => MonoFunctor (MaybeApply f a)
instance Functor f => MonoFunctor (WrappedApplicative f a)
@@ -1274,7 +1281,9 @@
instance Comonad w => MonoComonad (EnvT e w a)
instance Comonad w => MonoComonad (StoreT s w a)
instance (Comonad w, Monoid m) => MonoComonad (TracedT m w a)
+#if !MIN_VERSION_comonad(5,0,0)
instance (Comonad f, Comonad g) => MonoComonad (Coproduct f g a)
+#endif
-- Not Comonad
instance MonoComonad (ViewL a) where
1
0
Hello community,
here is the log from the commit of package ghc-memory for openSUSE:Factory checked in at 2016-01-28 17:23:58
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-memory (Old)
and /work/SRC/openSUSE:Factory/.ghc-memory.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-memory"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-memory/ghc-memory.changes 2016-01-07 00:25:18.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-memory.new/ghc-memory.changes 2016-01-28 17:24:53.000000000 +0100
@@ -1,0 +2,5 @@
+Fri Jan 15 10:04:57 UTC 2016 - mimi.vx(a)gmail.com
+
+- update 0.11
+
+-------------------------------------------------------------------
Old:
----
memory-0.10.tar.gz
New:
----
memory-0.11.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-memory.spec ++++++
--- /var/tmp/diff_new_pack.UOWviT/_old 2016-01-28 17:24:54.000000000 +0100
+++ /var/tmp/diff_new_pack.UOWviT/_new 2016-01-28 17:24:54.000000000 +0100
@@ -21,7 +21,7 @@
%bcond_with tests
Name: ghc-memory
-Version: 0.10
+Version: 0.11
Release: 0
Summary: Memory and related abtraction stuff
License: BSD-3-Clause
++++++ memory-0.10.tar.gz -> memory-0.11.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.10/Data/ByteArray/ScrubbedBytes.hs new/memory-0.11/Data/ByteArray/ScrubbedBytes.hs
--- old/memory-0.10/Data/ByteArray/ScrubbedBytes.hs 2015-09-08 15:28:21.000000000 +0200
+++ new/memory-0.11/Data/ByteArray/ScrubbedBytes.hs 2016-01-12 23:28:28.000000000 +0100
@@ -64,10 +64,29 @@
| otherwise = IO $ \s ->
case newAlignedPinnedByteArray# sz 8# s of
(# s1, mbarr #) ->
- let !scrubber = getScrubber sz
+ let !scrubber = (getScrubber sz) (byteArrayContents# (unsafeCoerce# mbarr))
!mba = ScrubbedBytes mbarr
- in case mkWeak# mbarr () (scrubber (byteArrayContents# (unsafeCoerce# mbarr)) >> touchScrubbedBytes mba) s1 of
+ in case mkWeak# mbarr () (finalize scrubber mba) s1 of
(# s2, _ #) -> (# s2, mba #)
+ where
+#if __GLASGOW_HASKELL__ > 800
+ finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> State# RealWorld -> State# RealWorld
+ finalize scrubber mba@(ScrubbedBytes _) = \s1 ->
+ case scrubber s1 of
+ s2 -> touch# mba s2
+#elif __GLASGOW_HASKELL__ >= 800
+ finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> State# RealWorld -> (# State# RealWorld, () #)
+ finalize scrubber mba@(ScrubbedBytes _) = \s1 ->
+ case scrubber s1 of
+ s2 -> case touch# mba s2 of
+ s3 -> (# s3, () #)
+#else
+ finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> IO ()
+ finalize scrubber mba@(ScrubbedBytes _) = IO $ \s1 -> do
+ case scrubber s1 of
+ s2 -> case touch# mba s2 of
+ s3 -> (# s3, () #)
+#endif
scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes)
scrubbedBytesAllocRet sz f = do
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.10/Data/Memory/Internal/CompatPrim.hs new/memory-0.11/Data/Memory/Internal/CompatPrim.hs
--- old/memory-0.10/Data/Memory/Internal/CompatPrim.hs 2015-09-08 15:28:21.000000000 +0200
+++ new/memory-0.11/Data/Memory/Internal/CompatPrim.hs 2016-01-12 23:28:28.000000000 +0100
@@ -75,10 +75,10 @@
-> (Int# -> a) -- ^ if it divided by 8, the argument is the number of 8 bytes words
-> (Int# -> a) -- ^ if it doesn't, just the number of bytes
-> a
-#if __GLASGOW_HASKELL__ >= 740
+#if __GLASGOW_HASKELL__ > 704
eitherDivideBy8# v f8 f1 =
- let !(# q, r #) = quotRemInt v 8#
- in if booleanPrim (r ==# 0)
+ let !(# q, r #) = quotRemInt# v 8#
+ in if booleanPrim (r ==# 0#)
then f8 q
else f1 v
#else
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.10/Data/Memory/Internal/Scrubber.hs new/memory-0.11/Data/Memory/Internal/Scrubber.hs
--- old/memory-0.10/Data/Memory/Internal/Scrubber.hs 2015-09-08 15:28:21.000000000 +0200
+++ new/memory-0.11/Data/Memory/Internal/Scrubber.hs 2016-01-12 23:28:28.000000000 +0100
@@ -15,10 +15,9 @@
) where
import GHC.Prim
-import GHC.IO
import Data.Memory.Internal.CompatPrim (booleanPrim)
-getScrubber :: Int# -> (Addr# -> IO ())
+getScrubber :: Int# -> (Addr# -> State# RealWorld -> State# RealWorld)
getScrubber sz
| booleanPrim (sz ==# 4#) = scrub4
| booleanPrim (sz ==# 8#) = scrub8
@@ -26,31 +25,31 @@
| booleanPrim (sz ==# 32#) = scrub32
| otherwise = scrubBytes sz
where
- scrub4 a = IO $ \s -> (# writeWord32OffAddr# a 0# 0## s, () #)
+ scrub4 a = \s -> writeWord32OffAddr# a 0# 0## s
#if WORD_SIZE_IN_BITS == 64
- scrub8 a = IO $ \s -> (# writeWord64OffAddr# a 0# 0## s, () #)
- scrub16 a = IO $ \s1 ->
+ scrub8 a = \s -> writeWord64OffAddr# a 0# 0## s
+ scrub16 a = \s1 ->
let !s2 = writeWord64OffAddr# a 0# 0## s1
!s3 = writeWord64OffAddr# a 1# 0## s2
- in (# s3, () #)
- scrub32 a = IO $ \s1 ->
+ in s3
+ scrub32 a = \s1 ->
let !s2 = writeWord64OffAddr# a 0# 0## s1
!s3 = writeWord64OffAddr# a 1# 0## s2
!s4 = writeWord64OffAddr# a 2# 0## s3
!s5 = writeWord64OffAddr# a 3# 0## s4
- in (# s5, () #)
+ in s5
#else
- scrub8 a = IO $ \s1 ->
+ scrub8 a = \s1 ->
let !s2 = writeWord32OffAddr# a 0# 0## s1
!s3 = writeWord32OffAddr# a 1# 0## s2
- in (# s3, () #)
- scrub16 a = IO $ \s1 ->
+ in s3
+ scrub16 a = \s1 ->
let !s2 = writeWord32OffAddr# a 0# 0## s1
!s3 = writeWord32OffAddr# a 1# 0## s2
!s4 = writeWord32OffAddr# a 2# 0## s3
!s5 = writeWord32OffAddr# a 3# 0## s4
- in (# s5, () #)
- scrub32 a = IO $ \s1 ->
+ in s5
+ scrub32 a = \s1 ->
let !s2 = writeWord32OffAddr# a 0# 0## s1
!s3 = writeWord32OffAddr# a 1# 0## s2
!s4 = writeWord32OffAddr# a 2# 0## s3
@@ -59,11 +58,11 @@
!s7 = writeWord32OffAddr# a 5# 0## s6
!s8 = writeWord32OffAddr# a 6# 0## s7
!s9 = writeWord32OffAddr# a 7# 0## s8
- in (# s9, () #)
+ in s9
#endif
-scrubBytes :: Int# -> Addr# -> IO ()
-scrubBytes sz8 addr = IO $ \s -> (# loop sz8 addr s, () #)
+scrubBytes :: Int# -> Addr# -> State# RealWorld -> State# RealWorld
+scrubBytes sz8 addr = \s -> loop sz8 addr s
where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld
loop n a s
| booleanPrim (n ==# 0#) = s
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.10/memory.cabal new/memory-0.11/memory.cabal
--- old/memory-0.10/memory.cabal 2015-09-08 15:28:21.000000000 +0200
+++ new/memory-0.11/memory.cabal 2016-01-12 23:28:28.000000000 +0100
@@ -1,5 +1,5 @@
Name: memory
-Version: 0.10
+Version: 0.11
Synopsis: memory and related abstraction stuff
Description:
Chunk of memory, polymorphic byte array management and manipulation
@@ -13,6 +13,8 @@
* Aliasing with endianness support.
.
* Encoding : Base16, Base32, Base64.
+ .
+ * Hashing : FNV, SipHash
License: BSD3
License-file: LICENSE
Copyright: Vincent Hanquez <vincent(a)snarc.org>
1
0
Hello community,
here is the log from the commit of package ghc-lifted-async for openSUSE:Factory checked in at 2016-01-28 17:23:57
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-lifted-async (Old)
and /work/SRC/openSUSE:Factory/.ghc-lifted-async.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-lifted-async"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-lifted-async/ghc-lifted-async.changes 2015-12-01 09:19:32.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-lifted-async.new/ghc-lifted-async.changes 2016-01-28 17:24:49.000000000 +0100
@@ -1,0 +2,10 @@
+Wed Jan 20 09:54:36 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 0.8.0.1
+* Relax upper bound for constraints
+* Drop Monad instance for Concurrently
+* Expose STM operations
+* Relax upper bound for base
+* Add Monoid and Semigroup instances for Concurrently
+
+-------------------------------------------------------------------
Old:
----
lifted-async-0.7.0.2.tar.gz
New:
----
lifted-async-0.8.0.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-lifted-async.spec ++++++
--- /var/tmp/diff_new_pack.VCDfbf/_old 2016-01-28 17:24:53.000000000 +0100
+++ /var/tmp/diff_new_pack.VCDfbf/_new 2016-01-28 17:24:53.000000000 +0100
@@ -21,7 +21,7 @@
%bcond_with tests
Name: ghc-lifted-async
-Version: 0.7.0.2
+Version: 0.8.0.1
Release: 0
Summary: Run lifted IO operations asynchronously and wait for their results
License: BSD-3-Clause
++++++ lifted-async-0.7.0.2.tar.gz -> lifted-async-0.8.0.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/lifted-async-0.7.0.2/CHANGELOG.md new/lifted-async-0.8.0.1/CHANGELOG.md
--- old/lifted-async-0.7.0.2/CHANGELOG.md 2015-11-27 02:28:01.000000000 +0100
+++ new/lifted-async-0.8.0.1/CHANGELOG.md 2016-01-17 22:16:51.000000000 +0100
@@ -1,3 +1,14 @@
+## v0.8.0.1 - 2015-01-17
+
+* Relax upper bound for constraints
+
+## v0.8.0 - 2016-01-10
+
+* Drop Monad instance for Concurrently
+* Expose STM operations
+* Relax upper bound for base and async
+* Add Monoid and Semigroup instances for Concurrently
+
## v0.7.0.2 - 2015-11-26
* Relax upper bound for the constraints package
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/lifted-async-0.7.0.2/lifted-async.cabal new/lifted-async-0.8.0.1/lifted-async.cabal
--- old/lifted-async-0.7.0.2/lifted-async.cabal 2015-11-27 02:28:01.000000000 +0100
+++ new/lifted-async-0.8.0.1/lifted-async.cabal 2016-01-17 22:16:51.000000000 +0100
@@ -1,5 +1,5 @@
name: lifted-async
-version: 0.7.0.2
+version: 0.8.0.1
synopsis: Run lifted IO operations asynchronously and wait for their results
homepage: https://github.com/maoe/lifted-async
bug-reports: https://github.com/maoe/lifted-async/issues
@@ -7,7 +7,7 @@
license-file: LICENSE
author: Mitsutoshi Aoe
maintainer: Mitsutoshi Aoe <maoe(a)foldr.in>
-copyright: Copyright (C) 2012-2015 Mitsutoshi Aoe
+copyright: Copyright (C) 2012-2016 Mitsutoshi Aoe
category: Concurrency
build-type: Simple
cabal-version: >= 1.8
@@ -34,14 +34,14 @@
Control.Concurrent.Async.Lifted
Control.Concurrent.Async.Lifted.Safe
build-depends:
- base >= 4.5 && < 4.9
- , async >= 2.0.1 && < 2.1
+ base >= 4.5 && < 4.10
+ , async >= 2.0.1 && < 2.2
, lifted-base >= 0.2 && < 0.3
, transformers-base >= 0.4 && < 0.5
if flag(monad-control-1)
build-depends: monad-control == 1.0.*
if impl(ghc >= 7.8)
- build-depends: constraints >= 0.2 && < 0.7
+ build-depends: constraints >= 0.2 && < 0.9
else
build-depends: constraints >= 0.2 && < 0.6
else
@@ -114,5 +114,5 @@
source-repository this
type: git
- tag: v0.7.0.2
+ tag: v0.8.0.1
location: https://github.com/maoe/lifted-async.git
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/lifted-async-0.7.0.2/src/Control/Concurrent/Async/Lifted/Safe.hs new/lifted-async-0.8.0.1/src/Control/Concurrent/Async/Lifted/Safe.hs
--- old/lifted-async-0.7.0.2/src/Control/Concurrent/Async/Lifted/Safe.hs 2015-11-27 02:28:01.000000000 +0100
+++ new/lifted-async-0.8.0.1/src/Control/Concurrent/Async/Lifted/Safe.hs 2016-01-17 22:16:51.000000000 +0100
@@ -53,6 +53,16 @@
, Unsafe.waitEither_
, waitBoth
+#if MIN_VERSION_async(2, 1, 0)
+ -- ** Waiting for multiple 'Async's in STM
+ , A.waitAnySTM
+ , A.waitAnyCatchSTM
+ , A.waitEitherSTM
+ , A.waitEitherCatchSTM
+ , A.waitEitherSTM_
+ , A.waitBothSTM
+#endif
+
-- ** Linking
, Unsafe.link, Unsafe.link2
@@ -89,6 +99,11 @@
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710
import Data.Traversable
#endif
+#if !MIN_VERSION_base(4, 8, 0)
+import Data.Monoid (Monoid(mappend, mempty))
+#elif MIN_VERSION_base(4, 9, 0)
+import Data.Semigroup (Semigroup((<>)))
+#endif
-- | Generalized version of 'A.async'.
async
@@ -366,8 +381,20 @@
\\ (inst :: Forall (Pure m) :- Pure m a)
\\ (inst :: Forall (Pure m) :- Pure m b)
-instance (MonadBaseControl IO m, Forall (Pure m)) =>
- Monad (Concurrently m) where
- return = Concurrently . return
- Concurrently a >>= f = Concurrently $ a >>= runConcurrently . f
+#if MIN_VERSION_base(4, 9, 0)
+instance (MonadBaseControl IO m, Semigroup a, Forall (Pure m)) =>
+ Semigroup (Concurrently m a) where
+ (<>) = liftA2 (<>)
+
+instance (MonadBaseControl IO m, Semigroup a, Monoid a, Forall (Pure m)) =>
+ Monoid (Concurrently m a) where
+ mempty = pure mempty
+ mappend = (<>)
+#else
+instance (MonadBaseControl IO m, Monoid a, Forall (Pure m)) =>
+ Monoid (Concurrently m a) where
+ mempty = pure mempty
+ mappend = liftA2 mappend
+#endif
+
#endif
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/lifted-async-0.7.0.2/src/Control/Concurrent/Async/Lifted.hs new/lifted-async-0.8.0.1/src/Control/Concurrent/Async/Lifted.hs
--- old/lifted-async-0.7.0.2/src/Control/Concurrent/Async/Lifted.hs 2015-11-27 02:28:01.000000000 +0100
+++ new/lifted-async-0.8.0.1/src/Control/Concurrent/Async/Lifted.hs 2016-01-17 22:16:51.000000000 +0100
@@ -49,11 +49,21 @@
, waitEither_
, waitBoth
+#if MIN_VERSION_async(2, 1, 0)
+ -- ** Waiting for multiple 'Async's in STM
+ , A.waitAnySTM
+ , A.waitAnyCatchSTM
+ , A.waitEitherSTM
+ , A.waitEitherCatchSTM
+ , A.waitEitherSTM_
+ , A.waitBothSTM
+#endif
+
-- ** Linking
, link, link2
-- * Convenient utilities
- , race, race_, concurrently, mapConcurrently
+ , race, race_, concurrently, mapConcurrently, forConcurrently
, Concurrently(..)
) where
@@ -73,6 +83,11 @@
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710
import Data.Traversable
#endif
+#if !MIN_VERSION_base(4, 8, 0)
+import Data.Monoid (Monoid(mappend, mempty))
+#elif MIN_VERSION_base(4, 9, 0)
+import Data.Semigroup (Semigroup((<>)))
+#endif
-- | Generalized version of 'A.async'.
async :: MonadBaseControl IO m => m a -> m (Async (StM m a))
@@ -352,6 +367,14 @@
-> m (t b)
mapConcurrently f = runConcurrently . traverse (Concurrently . f)
+-- | Generalized version of 'A.forConcurrently'.
+forConcurrently
+ :: (Traversable t, MonadBaseControl IO m)
+ => t a
+ -> (a -> m b)
+ -> m (t b)
+forConcurrently = flip mapConcurrently
+
-- | Generalized version of 'A.Concurrently'.
--
-- A value of type @'Concurrently' m a@ is an IO-based operation that can be
@@ -385,9 +408,20 @@
Concurrently as <|> Concurrently bs =
Concurrently $ either id id <$> race as bs
-instance MonadBaseControl IO m => Monad (Concurrently m) where
- return = Concurrently . return
- Concurrently a >>= f = Concurrently $ a >>= runConcurrently . f
+#if MIN_VERSION_base(4, 9, 0)
+instance (MonadBaseControl IO m, Semigroup a) =>
+ Semigroup (Concurrently m a) where
+ (<>) = liftA2 (<>)
+
+instance (MonadBaseControl IO m, Semigroup a, Monoid a) =>
+ Monoid (Concurrently m a) where
+ mempty = pure mempty
+ mappend = (<>)
+#else
+instance (MonadBaseControl IO m, Monoid a) => Monoid (Concurrently m a) where
+ mempty = pure mempty
+ mappend = liftA2 mappend
+#endif
sequenceEither :: MonadBaseControl IO m => Either e (StM m a) -> m (Either e a)
sequenceEither = either (return . Left) (liftM Right . restoreM)
1
0
Hello community,
here is the log from the commit of package ghc-JuicyPixels for openSUSE:Factory checked in at 2016-01-28 17:23:56
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-JuicyPixels (Old)
and /work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-JuicyPixels"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-JuicyPixels/ghc-JuicyPixels.changes 2015-12-09 22:16:50.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new/ghc-JuicyPixels.changes 2016-01-28 17:24:47.000000000 +0100
@@ -1,0 +2,11 @@
+Tue Jan 26 09:39:22 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 3.2.7
+* Addition: convertRGB8 and convertRGBA8 helper functions
+* Addition: new output colorspace for JPEG format: Y, RGB & CMYK
+* Addition: RGBA8 bitmap reading (thanks to mtolly)
+* Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck)
+* Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck)
+* Fix: GHC 8.0 compilation (thanks to phadej)
+
+-------------------------------------------------------------------
Old:
----
JuicyPixels-3.2.6.4.tar.gz
New:
----
JuicyPixels-3.2.7.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-JuicyPixels.spec ++++++
--- /var/tmp/diff_new_pack.bDE1ez/_old 2016-01-28 17:24:49.000000000 +0100
+++ /var/tmp/diff_new_pack.bDE1ez/_new 2016-01-28 17:24:49.000000000 +0100
@@ -20,7 +20,7 @@
# no useful debuginfo for Haskell packages without C sources
%global debug_package %{nil}
Name: ghc-JuicyPixels
-Version: 3.2.6.4
+Version: 3.2.7
Release: 0
Summary: Picture loading/serialization
License: BSD-3-Clause
++++++ JuicyPixels-3.2.6.4.tar.gz -> JuicyPixels-3.2.7.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/JuicyPixels.cabal new/JuicyPixels-3.2.7/JuicyPixels.cabal
--- old/JuicyPixels-3.2.6.4/JuicyPixels.cabal 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/JuicyPixels.cabal 2016-01-25 23:33:57.000000000 +0100
@@ -1,5 +1,5 @@
Name: JuicyPixels
-Version: 3.2.6.4
+Version: 3.2.7
Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance)
Description:
<<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>
@@ -28,7 +28,7 @@
Source-Repository this
Type: git
Location: git://github.com/Twinside/Juicy.Pixels.git
- Tag: v3.2.6.4
+ Tag: v3.2.7
Flag Mmap
Description: Enable the file loading via mmap (memory map)
@@ -52,11 +52,10 @@
Codec.Picture.ColorQuant
Ghc-options: -O3 -Wall
- Ghc-prof-options: -rtsopts -Wall -prof -auto-all
Build-depends: base >= 4.5 && < 5,
bytestring >= 0.9 && < 0.11,
mtl >= 1.1 && < 2.3,
- binary >= 0.5 && < 0.8,
+ binary >= 0.5 && < 0.9,
zlib >= 0.5.3.1 && < 0.7,
transformers >= 0.2,
vector >= 0.9 && < 0.12,
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/README.md new/JuicyPixels-3.2.7/README.md
--- old/JuicyPixels-3.2.6.4/README.md 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/README.md 2016-01-25 23:33:57.000000000 +0100
@@ -52,6 +52,7 @@
- Bitmap (.bmp) (mainly used as a debug output format)
* Reading
+ - 32bits (RGBA) images
- 24bits (RGB) images
- 8bits (greyscale & paletted) images
@@ -62,10 +63,12 @@
* Metadata (reading/writing): DPI information
- - Jpeg (.jpg, .jpeg)
+ - Jpeg (.jpg, .jpeg)
* Reading normal and interlaced baseline DCT image
- YCbCr (default) CMYK/YCbCrK/RGB colorspaces
+
* Writing non-interlaced JPG
+ - YCbCr (favored), Y, RGB & CMYK colorspaces
* Metadata:
- Reading and writing DpiX & DpiY from JFIF header.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/changelog new/JuicyPixels-3.2.7/changelog
--- old/JuicyPixels-3.2.6.4/changelog 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/changelog 2016-01-25 23:33:57.000000000 +0100
@@ -1,7 +1,20 @@
Change log
==========
-v3.2.6.3 December 2015
+v3.2.7 January 2016
+-------------------
+ * Addition: convertRGB8 and convertRGBA8 helper functions
+ * Addition: new output colorspace for JPEG format: Y, RGB & CMYK
+ * Addition: RGBA8 bitmap reading (thanks to mtolly)
+ * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck)
+ * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck)
+ * Fix: GHC 8.0 compilation (thanks to phadej)
+
+v3.2.6.5 December 2015
+----------------------
+ * Fix: Compilation on GHC 7.6/7.8
+
+v3.2.6.4 December 2015
----------------------
* Fix: previous broken bugfix.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/BitWriter.hs new/JuicyPixels-3.2.7/src/Codec/Picture/BitWriter.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/BitWriter.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/BitWriter.hs 2016-01-25 23:33:57.000000000 +0100
@@ -1,4 +1,5 @@
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-- | This module implement helper functions to read & write data
-- at bits level.
@@ -9,7 +10,9 @@
, getNextBitsLSBFirst
, getNextBitsMSBFirst
, getNextBitJpg
+ , getNextIntJpg
, setDecodedString
+ , setDecodedStringMSB
, setDecodedStringJpg
, runBoolReader
@@ -33,6 +36,7 @@
import Control.Monad( when )
import Control.Monad.ST( ST )
import qualified Control.Monad.Trans.State.Strict as S
+import Data.Int ( Int32 )
import Data.Word( Word8, Word32 )
import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL )
@@ -42,6 +46,7 @@
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
+
--------------------------------------------------
---- Reader
--------------------------------------------------
@@ -93,8 +98,8 @@
BoolState idx _ chain <- S.get
when (idx /= 7) (setDecodedStringJpg chain)
-{-# INLINE getNextBitJpg #-}
getNextBitJpg :: BoolReader s Bool
+{-# INLINE getNextBitJpg #-}
getNextBitJpg = do
BoolState idx v chain <- S.get
let val = (v .&. (1 `unsafeShiftL` idx)) /= 0
@@ -103,25 +108,51 @@
else S.put $ BoolState (idx - 1) v chain
return val
-{-# INLINE getNextBitMSB #-}
-getNextBitMSB :: BoolReader s Bool
-getNextBitMSB = do
+getNextIntJpg :: Int -> BoolReader s Int32
+{-# INLINE getNextIntJpg #-}
+getNextIntJpg = go 0 where
+ go !acc !0 = return acc
+ go !acc !n = do
BoolState idx v chain <- S.get
- let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0
- if idx == 7
- then setDecodedString chain
- else S.put $ BoolState (idx + 1) v chain
- return val
+ let !leftBits = 1 + fromIntegral idx
+ if n >= leftBits then do
+ setDecodedStringJpg chain
+ let !remaining = n - leftBits
+ !mask = (1 `unsafeShiftL` leftBits) - 1
+ !finalV = fromIntegral v .&. mask
+ !theseBits = finalV `unsafeShiftL` remaining
+ go (acc .|. theseBits) remaining
+ else do
+ let !remaining = leftBits - n
+ !mask = (1 `unsafeShiftL` n) - 1
+ !finalV = fromIntegral v `unsafeShiftR` remaining
+ S.put $ BoolState (fromIntegral remaining - 1) v chain
+ return $ (finalV .&. mask) .|. acc
+
+
+setDecodedStringMSB :: B.ByteString -> BoolReader s ()
+setDecodedStringMSB str = case B.uncons str of
+ Nothing -> S.put $ BoolState 8 0 B.empty
+ Just (v, rest) -> S.put $ BoolState 8 v rest
+
{-# INLINE getNextBitsMSBFirst #-}
getNextBitsMSBFirst :: Int -> BoolReader s Word32
-getNextBitsMSBFirst = aux 0
- where aux acc 0 = return acc
- aux acc n = do
- bit <- getNextBitMSB
- let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1
- | otherwise = acc `unsafeShiftL` 1
- aux nextVal (n - 1)
+getNextBitsMSBFirst requested = go 0 requested where
+ go :: Word32 -> Int -> BoolReader s Word32
+ go !acc !0 = return acc
+ go !acc !n = do
+ BoolState idx v chain <- S.get
+ let !leftBits = fromIntegral idx
+ if n >= leftBits then do
+ setDecodedStringMSB chain
+ let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits)
+ go (acc .|. theseBits) (n - leftBits)
+ else do
+ let !remaining = leftBits - n
+ !mask = (1 `unsafeShiftL` remaining) - 1
+ S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain
+ return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc
{-# INLINE getNextBitsLSBFirst #-}
getNextBitsLSBFirst :: Int -> BoolReader s Word32
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Bitmap.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Bitmap.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Bitmap.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Bitmap.hs 2016-01-25 23:33:56.000000000 +0100
@@ -41,6 +41,7 @@
, getWord8
, getWord16le
, getWord32le
+ , getWord32be
, bytesRead
, skip
)
@@ -253,6 +254,34 @@
inner 0 0 initialIndex
VS.unsafeFreeze buff
+decodeImageRGBA8 :: BmpInfoHeader -> (Int, Int, Int, Int) -> B.ByteString -> Image PixelRGBA8
+decodeImageRGBA8 (BmpInfoHeader { width = w, height = h }) (posR, posG, posB, posA) str = Image wi hi stArray where
+ wi = fromIntegral w
+ hi = abs $ fromIntegral h
+ stArray = runST $ do
+ arr <- M.new (fromIntegral $ w * abs h * 4)
+ if h > 0 then
+ foldM_ (readLine arr) 0 [0 .. hi - 1]
+ else
+ foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
+ VS.unsafeFreeze arr
+
+ stride = linePadding 32 wi -- will be 0
+
+ readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
+ readLine arr readIndex line = inner readIndex writeIndex where
+ lastIndex = wi * (hi - 1 - line + 1) * 4
+ writeIndex = wi * (hi - 1 - line) * 4
+
+ inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride
+ inner readIdx writeIdx = do
+ -- 32-bit BMP pixels are BGRA
+ (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + posR))
+ (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + posG))
+ (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` (readIdx + posB))
+ (arr `M.unsafeWrite` (writeIdx + 3)) (str `B.index` (readIdx + posA))
+ inner (readIdx + 4) (writeIdx + 4)
+
decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8
decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where
wi = fromIntegral w
@@ -322,6 +351,8 @@
-- | Try to decode a bitmap image.
-- Right now this function can output the following pixel types :
--
+-- * PixelRGBA8
+--
-- * PixelRGB8
--
-- * Pixel8
@@ -349,27 +380,49 @@
paletteColorCount
| colorCount bmpHeader == 0 = 2 ^ bpp
| otherwise = fromIntegral $ colorCount bmpHeader
+ getData = do
+ readed' <- bytesRead
+ skip . fromIntegral $ dataOffset hdr - fromIntegral readed'
+ getRemainingBytes
+ addMetadata i = (i, metadataOfHeader bmpHeader)
- table <- if bpp > 8
- then return V.empty
- else V.replicateM paletteColorCount pixelGet
-
- readed' <- bytesRead
-
- skip . fromIntegral $ dataOffset hdr - fromIntegral readed'
- rest <- getRemainingBytes
- let addMetadata i = (i, metadataOfHeader bmpHeader)
case (bitPerPixel bmpHeader, planes bmpHeader,
bitmapCompression bmpHeader) of
- -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh"
- (24, 1, 0) -> return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest
- ( 8, 1, 0) ->
- let indexer v = table V.! fromIntegral v in
- return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest
+ (32, 1, 0) -> do
+ rest <- getData
+ return . addMetadata . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest
+ -- (2, 1, 0, 3) means BGRA pixel order
+ (32, 1, 3) -> do
+ posRed <- getBitfield
+ posGreen <- getBitfield
+ posBlue <- getBitfield
+ posAlpha <- getBitfield
+ rest <- getData
+ return . addMetadata . ImageRGBA8 $
+ decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest
+ (24, 1, 0) -> do
+ rest <- getData
+ return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest
+ ( 8, 1, 0) -> do
+ table <- V.replicateM paletteColorCount pixelGet
+ rest <- getData
+ let indexer v = table V.! fromIntegral v
+ return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest
a -> fail $ "Can't handle BMP file " ++ show a
+getBitfield :: Get Int
+getBitfield = do
+ w32 <- getWord32be
+ case w32 of
+ 0xFF000000 -> return 0
+ 0x00FF0000 -> return 1
+ 0x0000FF00 -> return 2
+ 0x000000FF -> return 3
+ _ -> fail $
+ "Codec.Picture.Bitmap.getBitfield: unsupported bitfield of " ++ show w32
+
-- | Write an image in a file use the bitmap format.
writeBitmap :: (BmpEncodable pixel)
=> FilePath -> Image pixel -> IO ()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Gif/LZW.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Gif/LZW.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Gif/LZW.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Gif/LZW.hs 2016-01-25 23:33:57.000000000 +0100
@@ -1,191 +1,194 @@
-{-# LANGUAGE CPP #-}
-module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<$>) )
-#endif
-
-import Data.Word( Word8 )
-import Control.Monad( when, unless )
-
-import Data.Bits( (.&.) )
-
-import Control.Monad.ST( ST )
-import Control.Monad.Trans.Class( MonadTrans, lift )
-
-import Foreign.Storable ( Storable )
-
-import qualified Data.ByteString as B
-import qualified Data.Vector.Storable.Mutable as M
-
-import Codec.Picture.BitWriter
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a
-(.!!!.) = M.unsafeRead
- {-M.read-}
-
-{-# INLINE (..!!!..) #-}
-(..!!!..) :: (MonadTrans t, Storable a)
- => M.STVector s a -> Int -> t (ST s) a
-(..!!!..) v idx = lift $ v .!!!. idx
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s ()
-(.<-.) = M.unsafeWrite
- {-M.write-}
-
-{-# INLINE (..<-..) #-}
-(..<-..) :: (MonadTrans t, Storable a)
- => M.STVector s a -> Int -> a -> t (ST s) ()
-(..<-..) v idx = lift . (v .<-. idx)
-
-
-duplicateData :: (Show a, MonadTrans t, Storable a)
- => M.STVector s a -> M.STVector s a
- -> Int -> Int -> Int -> t (ST s) ()
-duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex
- where endIndex = sourceIndex + size
- aux i _ | i == endIndex = return ()
- aux i j = do
- src .!!!. i >>= (dest .<-. j)
- aux (i + 1) (j + 1)
-
-rangeSetter :: (Storable a, Num a)
- => Int -> M.STVector s a
- -> ST s (M.STVector s a)
-rangeSetter count vec = aux 0
- where aux n | n == count = return vec
- aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)
-
-decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8
- -> BoolReader s ()
-decodeLzw str maxBitKey initialKey outVec = do
- setDecodedString str
- lzw GifVariant maxBitKey initialKey 0 outVec
-
-isOldTiffLZW :: B.ByteString -> Bool
-isOldTiffLZW str = firstByte == 0 && secondByte == 1
- where firstByte = str `B.index` 0
- secondByte = (str `B.index` 1) .&. 1
-
-decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int
- -> BoolReader s()
-decodeLzwTiff str outVec initialWriteIdx = do
- setDecodedString str
- let variant | isOldTiffLZW str = OldTiffVariant
- | otherwise = TiffVariant
- lzw variant 12 9 initialWriteIdx outVec
-
-data TiffVariant =
- GifVariant
- | TiffVariant
- | OldTiffVariant
- deriving Eq
-
--- | Gif image constraint from spec-gif89a, code size max : 12 bits.
-lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8
- -> BoolReader s ()
-lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do
- -- Allocate buffer of maximum size.
- lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray
- lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray
- lzwSizeTable <- lift $ M.replicate tableEntryCount 0
- lift $ lzwSizeTable `M.set` 1
-
- let firstVal code = do
- dataOffset <- lzwOffsetTable ..!!!.. code
- lzwData ..!!!.. dataOffset
-
- writeString at code = do
- dataOffset <- lzwOffsetTable ..!!!.. code
- dataSize <- lzwSizeTable ..!!!.. code
-
- when (at + dataSize <= maxWrite) $
- duplicateData lzwData outVec dataOffset dataSize at
-
- return dataSize
-
- addString pos at code val = do
- dataOffset <- lzwOffsetTable ..!!!.. code
- dataSize <- lzwSizeTable ..!!!.. code
-
- when (pos < tableEntryCount) $ do
- (lzwOffsetTable ..<-.. pos) at
- (lzwSizeTable ..<-.. pos) $ dataSize + 1
-
- when (at + dataSize + 1 <= maxDataSize) $ do
- duplicateData lzwData lzwData dataOffset dataSize at
- (lzwData ..<-.. (at + dataSize)) val
-
- return $ dataSize + 1
-
- maxWrite = M.length outVec
- loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code
- | outWriteIdx >= maxWrite = return ()
- | code == endOfInfo = return ()
- | code == clearCode = do
- toOutput <- getNextCode startCodeSize
- unless (toOutput == endOfInfo) $ do
- dataSize <- writeString outWriteIdx toOutput
- getNextCode startCodeSize >>=
- loop (outWriteIdx + dataSize)
- firstFreeIndex firstFreeIndex startCodeSize toOutput
-
- | otherwise = do
- (written, dicAdd) <-
- if code >= writeIdx then do
- c <- firstVal oldCode
- wroteSize <- writeString outWriteIdx oldCode
- (outVec ..<-.. (outWriteIdx + wroteSize)) c
- addedSize <- addString writeIdx dicWriteIdx oldCode c
- return (wroteSize + 1, addedSize)
- else do
- wroteSize <- writeString outWriteIdx code
- c <- firstVal code
- addedSize <- addString writeIdx dicWriteIdx oldCode c
- return (wroteSize, addedSize)
-
- let new_code_size = updateCodeSize codeSize $ writeIdx + 1
- getNextCode new_code_size >>=
- loop (outWriteIdx + written)
- (writeIdx + 1)
- (dicWriteIdx + dicAdd)
- new_code_size
- code
-
- getNextCode startCodeSize >>=
- loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0
-
- where tableEntryCount = 2 ^ min 12 nMaxBitKeySize
- maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1
-
- isNewTiff = variant == TiffVariant
- (switchOffset, isTiffVariant) = case variant of
- GifVariant -> (0, False)
- TiffVariant -> (1, True)
- OldTiffVariant -> (0, True)
-
- initialElementCount = 2 ^ initialKeySize :: Int
- clearCode | isTiffVariant = 256
- | otherwise = initialElementCount
-
- endOfInfo | isTiffVariant = 257
- | otherwise = clearCode + 1
-
- startCodeSize
- | isTiffVariant = initialKeySize
- | otherwise = initialKeySize + 1
-
- firstFreeIndex = endOfInfo + 1
-
- resetArray a = lift $ rangeSetter initialElementCount a
-
- updateCodeSize codeSize writeIdx
- | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1
- | otherwise = codeSize
-
- getNextCode s
- | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s
- | otherwise = fromIntegral <$> getNextBitsLSBFirst s
-
+{-# LANGUAGE CPP #-}
+module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+#endif
+
+import Data.Word( Word8 )
+import Control.Monad( when, unless )
+
+import Data.Bits( (.&.) )
+
+import Control.Monad.ST( ST )
+import Control.Monad.Trans.Class( MonadTrans, lift )
+
+import Foreign.Storable ( Storable )
+
+import qualified Data.ByteString as B
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.BitWriter
+
+{-# INLINE (.!!!.) #-}
+(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a
+(.!!!.) = M.unsafeRead
+ {-M.read-}
+
+{-# INLINE (..!!!..) #-}
+(..!!!..) :: (MonadTrans t, Storable a)
+ => M.STVector s a -> Int -> t (ST s) a
+(..!!!..) v idx = lift $ v .!!!. idx
+
+{-# INLINE (.<-.) #-}
+(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s ()
+(.<-.) = M.unsafeWrite
+ {-M.write-}
+
+{-# INLINE (..<-..) #-}
+(..<-..) :: (MonadTrans t, Storable a)
+ => M.STVector s a -> Int -> a -> t (ST s) ()
+(..<-..) v idx = lift . (v .<-. idx)
+
+
+duplicateData :: (Show a, MonadTrans t, Storable a)
+ => M.STVector s a -> M.STVector s a
+ -> Int -> Int -> Int -> t (ST s) ()
+duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex
+ where endIndex = sourceIndex + size
+ aux i _ | i == endIndex = return ()
+ aux i j = do
+ src .!!!. i >>= (dest .<-. j)
+ aux (i + 1) (j + 1)
+
+rangeSetter :: (Storable a, Num a)
+ => Int -> M.STVector s a
+ -> ST s (M.STVector s a)
+rangeSetter count vec = aux 0
+ where aux n | n == count = return vec
+ aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)
+
+decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8
+ -> BoolReader s ()
+decodeLzw str maxBitKey initialKey outVec = do
+ setDecodedString str
+ lzw GifVariant maxBitKey initialKey 0 outVec
+
+isOldTiffLZW :: B.ByteString -> Bool
+isOldTiffLZW str = firstByte == 0 && secondByte == 1
+ where firstByte = str `B.index` 0
+ secondByte = (str `B.index` 1) .&. 1
+
+decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int
+ -> BoolReader s()
+decodeLzwTiff str outVec initialWriteIdx = do
+ if isOldTiffLZW str then
+ setDecodedString str
+ else
+ setDecodedStringMSB str
+ let variant | isOldTiffLZW str = OldTiffVariant
+ | otherwise = TiffVariant
+ lzw variant 12 9 initialWriteIdx outVec
+
+data TiffVariant =
+ GifVariant
+ | TiffVariant
+ | OldTiffVariant
+ deriving Eq
+
+-- | Gif image constraint from spec-gif89a, code size max : 12 bits.
+lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8
+ -> BoolReader s ()
+lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do
+ -- Allocate buffer of maximum size.
+ lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray
+ lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray
+ lzwSizeTable <- lift $ M.replicate tableEntryCount 0
+ lift $ lzwSizeTable `M.set` 1
+
+ let firstVal code = do
+ dataOffset <- lzwOffsetTable ..!!!.. code
+ lzwData ..!!!.. dataOffset
+
+ writeString at code = do
+ dataOffset <- lzwOffsetTable ..!!!.. code
+ dataSize <- lzwSizeTable ..!!!.. code
+
+ when (at + dataSize <= maxWrite) $
+ duplicateData lzwData outVec dataOffset dataSize at
+
+ return dataSize
+
+ addString pos at code val = do
+ dataOffset <- lzwOffsetTable ..!!!.. code
+ dataSize <- lzwSizeTable ..!!!.. code
+
+ when (pos < tableEntryCount) $ do
+ (lzwOffsetTable ..<-.. pos) at
+ (lzwSizeTable ..<-.. pos) $ dataSize + 1
+
+ when (at + dataSize + 1 <= maxDataSize) $ do
+ duplicateData lzwData lzwData dataOffset dataSize at
+ (lzwData ..<-.. (at + dataSize)) val
+
+ return $ dataSize + 1
+
+ maxWrite = M.length outVec
+ loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code
+ | outWriteIdx >= maxWrite = return ()
+ | code == endOfInfo = return ()
+ | code == clearCode = do
+ toOutput <- getNextCode startCodeSize
+ unless (toOutput == endOfInfo) $ do
+ dataSize <- writeString outWriteIdx toOutput
+ getNextCode startCodeSize >>=
+ loop (outWriteIdx + dataSize)
+ firstFreeIndex firstFreeIndex startCodeSize toOutput
+
+ | otherwise = do
+ (written, dicAdd) <-
+ if code >= writeIdx then do
+ c <- firstVal oldCode
+ wroteSize <- writeString outWriteIdx oldCode
+ (outVec ..<-.. (outWriteIdx + wroteSize)) c
+ addedSize <- addString writeIdx dicWriteIdx oldCode c
+ return (wroteSize + 1, addedSize)
+ else do
+ wroteSize <- writeString outWriteIdx code
+ c <- firstVal code
+ addedSize <- addString writeIdx dicWriteIdx oldCode c
+ return (wroteSize, addedSize)
+
+ let new_code_size = updateCodeSize codeSize $ writeIdx + 1
+ getNextCode new_code_size >>=
+ loop (outWriteIdx + written)
+ (writeIdx + 1)
+ (dicWriteIdx + dicAdd)
+ new_code_size
+ code
+
+ getNextCode startCodeSize >>=
+ loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0
+
+ where tableEntryCount = 2 ^ min 12 nMaxBitKeySize
+ maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1
+
+ isNewTiff = variant == TiffVariant
+ (switchOffset, isTiffVariant) = case variant of
+ GifVariant -> (0, False)
+ TiffVariant -> (1, True)
+ OldTiffVariant -> (0, True)
+
+ initialElementCount = 2 ^ initialKeySize :: Int
+ clearCode | isTiffVariant = 256
+ | otherwise = initialElementCount
+
+ endOfInfo | isTiffVariant = 257
+ | otherwise = clearCode + 1
+
+ startCodeSize
+ | isTiffVariant = initialKeySize
+ | otherwise = initialKeySize + 1
+
+ firstFreeIndex = endOfInfo + 1
+
+ resetArray a = lift $ rangeSetter initialElementCount a
+
+ updateCodeSize codeSize writeIdx
+ | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1
+ | otherwise = codeSize
+
+ getNextCode s
+ | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s
+ | otherwise = fromIntegral <$> getNextBitsLSBFirst s
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Common.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Common.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Common.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Common.hs 2016-01-25 23:33:57.000000000 +0100
@@ -23,11 +23,10 @@
import Control.Applicative( pure, (<$>) )
#endif
-import Control.Monad( replicateM, when )
+import Control.Monad( when )
import Control.Monad.ST( ST, runST )
import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) )
import Data.Int( Int16, Int32 )
-import Data.List( foldl' )
import Data.Maybe( fromMaybe )
import Data.Word( Word8 )
import qualified Data.Vector.Storable as VS
@@ -174,8 +173,7 @@
-- | Unpack an int of the given size encoded from MSB to LSB.
unpackInt :: Int -> BoolReader s Int32
-unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg
-
+unpackInt = getNextIntJpg
{-# INLINE rasterMap #-}
rasterMap :: (Monad m)
@@ -187,11 +185,6 @@
where columner x | x >= width = liner (y + 1)
columner x = f x y >> columner (x + 1)
-packInt :: [Bool] -> Int32
-packInt = foldl' bitStep 0
- where bitStep acc True = (acc `unsafeShiftL` 1) + 1
- bitStep acc False = acc `unsafeShiftL` 1
-
pixelClamp :: Int16 -> Word8
pixelClamp n = fromIntegral . min 255 $ max 0 n
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Types.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Types.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Types.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Types.hs 2016-01-25 23:33:57.000000000 +0100
@@ -427,7 +427,8 @@
getByteString (fromIntegral size - 2)
putFrame :: JpgFrame -> Put
-putFrame (JpgAdobeAPP14 _adobe) = return ()
+putFrame (JpgAdobeAPP14 adobe) =
+ put (JpgAppSegment 14) >> putWord16be 14 >> put adobe
putFrame (JpgJFIF jfif) =
put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif
putFrame (JpgExif _exif) =
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg.hs 2016-01-25 23:33:56.000000000 +0100
@@ -11,7 +11,9 @@
, decodeJpegWithMetadata
, encodeJpegAtQuality
, encodeJpegAtQualityWithMetadata
+ , encodeDirectJpegAtQualityWithMetadata
, encodeJpeg
+ , JpgEncodable
) where
#if !MIN_VERSION_base(4,8,0)
@@ -546,6 +548,8 @@
--
-- * PixelRGB8
--
+-- * PixelCMYK8
+--
-- * PixelYCbCr8
--
decodeJpeg :: B.ByteString -> Either String DynamicImage
@@ -623,7 +627,8 @@
frozen <- unsafeFreezeImage fImg
return (st, imageData frozen)
-extractBlock :: Image PixelYCbCr8 -- ^ Source image
+extractBlock :: forall s px. (PixelBaseComponent px ~ Word8)
+ => Image px -- ^ Source image
-> MutableMacroBlock s Int16 -- ^ Mutable block where to put extracted block
-> Int -- ^ Plane
-> Int -- ^ X sampling factor
@@ -741,6 +746,22 @@
, prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
]
+lumaQuantTableAtQuality :: Int -> QuantificationTable
+lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable
+
+chromaQuantTableAtQuality :: Int -> QuantificationTable
+chromaQuantTableAtQuality qual =
+ scaleQuantisationMatrix qual defaultChromaQuantizationTable
+
+zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
+zigzaggedQuantificationSpec qual =
+ [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma }
+ , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma }
+ ]
+ where
+ luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+ chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
+
-- | Function to call to encode an image to jpeg.
-- The quality factor should be between 0 and 100 (100 being
-- the best quality).
@@ -749,6 +770,203 @@
-> L.ByteString -- ^ Encoded JPEG
encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty
+-- | Record gathering all information to encode a component
+-- from the source image. Previously was a huge tuple
+-- burried in the code
+data EncoderState = EncoderState
+ { _encComponentIndex :: !Int
+ , _encBlockWidth :: !Int
+ , _encBlockHeight :: !Int
+ , _encQuantTable :: !QuantificationTable
+ , _encDcHuffman :: !HuffmanWriterCode
+ , _encAcHuffman :: !HuffmanWriterCode
+ }
+
+
+-- | Helper type class describing all JPG-encodable pixel types
+class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where
+ additionalBlocks :: Image px -> [JpgFrame]
+ additionalBlocks _ = []
+
+ componentsOfColorSpace :: Image px -> [JpgComponent]
+
+ encodingState :: Int -> Image px -> V.Vector EncoderState
+
+ imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
+ imageHuffmanTables _ = defaultHuffmanTables
+
+ scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification]
+
+ quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec]
+ quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual
+
+ maximumSubSamplingOf :: Image px -> Int
+ maximumSubSamplingOf _ = 1
+
+instance JpgEncodable Pixel8 where
+ scanSpecificationOfColorSpace _ =
+ [ JpgScanSpecification { componentSelector = 1
+ , dcEntropyCodingTable = 0
+ , acEntropyCodingTable = 0
+ }
+ ]
+
+ componentsOfColorSpace _ =
+ [ JpgComponent { componentIdentifier = 1
+ , horizontalSamplingFactor = 1
+ , verticalSamplingFactor = 1
+ , quantizationTableDest = 0
+ }
+ ]
+
+ imageHuffmanTables _ =
+ [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+ , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+ ]
+
+ encodingState qual _ = V.singleton EncoderState
+ { _encComponentIndex = 0
+ , _encBlockWidth = 1
+ , _encBlockHeight = 1
+ , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+ , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree
+ , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree
+ }
+
+
+instance JpgEncodable PixelYCbCr8 where
+ maximumSubSamplingOf _ = 2
+ quantTableSpec _ qual = zigzaggedQuantificationSpec qual
+ scanSpecificationOfColorSpace _ =
+ [ JpgScanSpecification { componentSelector = 1
+ , dcEntropyCodingTable = 0
+ , acEntropyCodingTable = 0
+ }
+ , JpgScanSpecification { componentSelector = 2
+ , dcEntropyCodingTable = 1
+ , acEntropyCodingTable = 1
+ }
+ , JpgScanSpecification { componentSelector = 3
+ , dcEntropyCodingTable = 1
+ , acEntropyCodingTable = 1
+ }
+ ]
+
+ componentsOfColorSpace _ =
+ [ JpgComponent { componentIdentifier = 1
+ , horizontalSamplingFactor = 2
+ , verticalSamplingFactor = 2
+ , quantizationTableDest = 0
+ }
+ , JpgComponent { componentIdentifier = 2
+ , horizontalSamplingFactor = 1
+ , verticalSamplingFactor = 1
+ , quantizationTableDest = 1
+ }
+ , JpgComponent { componentIdentifier = 3
+ , horizontalSamplingFactor = 1
+ , verticalSamplingFactor = 1
+ , quantizationTableDest = 1
+ }
+ ]
+
+ encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }]
+ where
+ lumaState = EncoderState
+ { _encComponentIndex = 0
+ , _encBlockWidth = 2
+ , _encBlockHeight = 2
+ , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+ , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree
+ , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree
+ }
+ chromaState = EncoderState
+ { _encComponentIndex = 1
+ , _encBlockWidth = 1
+ , _encBlockHeight = 1
+ , _encQuantTable = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
+ , _encDcHuffman = makeInverseTable defaultDcChromaHuffmanTree
+ , _encAcHuffman = makeInverseTable defaultAcChromaHuffmanTree
+ }
+
+instance JpgEncodable PixelRGB8 where
+ additionalBlocks _ = [] where
+ _adobe14 = JpgAdobeApp14
+ { _adobeDctVersion = 100
+ , _adobeFlag0 = 0
+ , _adobeFlag1 = 0
+ , _adobeTransform = AdobeUnknown
+ }
+
+ imageHuffmanTables _ =
+ [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+ , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+ ]
+
+ scanSpecificationOfColorSpace _ = fmap build "RGB" where
+ build c = JpgScanSpecification
+ { componentSelector = fromIntegral $ fromEnum c
+ , dcEntropyCodingTable = 0
+ , acEntropyCodingTable = 0
+ }
+
+ componentsOfColorSpace _ = fmap build "RGB" where
+ build c = JpgComponent
+ { componentIdentifier = fromIntegral $ fromEnum c
+ , horizontalSamplingFactor = 1
+ , verticalSamplingFactor = 1
+ , quantizationTableDest = 0
+ }
+
+ encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where
+ build ix = EncoderState
+ { _encComponentIndex = ix
+ , _encBlockWidth = 1
+ , _encBlockHeight = 1
+ , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+ , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree
+ , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree
+ }
+
+instance JpgEncodable PixelCMYK8 where
+ additionalBlocks _ = [] where
+ _adobe14 = JpgAdobeApp14
+ { _adobeDctVersion = 100
+ , _adobeFlag0 = 32768
+ , _adobeFlag1 = 0
+ , _adobeTransform = AdobeYCck
+ }
+
+ imageHuffmanTables _ =
+ [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+ , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+ ]
+
+ scanSpecificationOfColorSpace _ = fmap build "CMYK" where
+ build c = JpgScanSpecification
+ { componentSelector = fromIntegral $ fromEnum c
+ , dcEntropyCodingTable = 0
+ , acEntropyCodingTable = 0
+ }
+
+ componentsOfColorSpace _ = fmap build "CMYK" where
+ build c = JpgComponent
+ { componentIdentifier = fromIntegral $ fromEnum c
+ , horizontalSamplingFactor = 1
+ , verticalSamplingFactor = 1
+ , quantizationTableDest = 0
+ }
+
+ encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where
+ build ix = EncoderState
+ { _encComponentIndex = ix
+ , _encBlockWidth = 1
+ , _encBlockHeight = 1
+ , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+ , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree
+ , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree
+ }
+
-- | Equivalent to 'encodeJpegAtQuality', but will store the following
-- metadatas in the file using a JFIF block:
--
@@ -759,121 +977,86 @@
-> Metadatas
-> Image PixelYCbCr8 -- ^ Image to encode
-> L.ByteString -- ^ Encoded JPEG
-encodeJpegAtQualityWithMetadata quality metas img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage
- where finalImage = JpgImage $
- encodeMetadatas metas ++
- [ JpgQuantTable quantTables
- , JpgScans JpgBaselineDCTHuffman hdr
- , JpgHuffmanTable defaultHuffmanTables
- , JpgScanBlob scanHeader encodedImage
- ]
-
- outputComponentCount = 3
-
- scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
- scanHeader' = JpgScanHeader
- { scanLength = 0
- , scanComponentCount = outputComponentCount
- , scans = [ JpgScanSpecification { componentSelector = 1
- , dcEntropyCodingTable = 0
- , acEntropyCodingTable = 0
- }
- , JpgScanSpecification { componentSelector = 2
- , dcEntropyCodingTable = 1
- , acEntropyCodingTable = 1
- }
- , JpgScanSpecification { componentSelector = 3
- , dcEntropyCodingTable = 1
- , acEntropyCodingTable = 1
- }
- ]
-
- , spectralSelection = (0, 63)
- , successiveApproxHigh = 0
- , successiveApproxLow = 0
- }
-
- hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' }
- hdr' = JpgFrameHeader { jpgFrameHeaderLength = 0
- , jpgSamplePrecision = 8
- , jpgHeight = fromIntegral h
- , jpgWidth = fromIntegral w
- , jpgImageComponentCount = outputComponentCount
- , jpgComponents = [
- JpgComponent { componentIdentifier = 1
- , horizontalSamplingFactor = 2
- , verticalSamplingFactor = 2
- , quantizationTableDest = 0
- }
- , JpgComponent { componentIdentifier = 2
- , horizontalSamplingFactor = 1
- , verticalSamplingFactor = 1
- , quantizationTableDest = 1
- }
- , JpgComponent { componentIdentifier = 3
- , horizontalSamplingFactor = 1
- , verticalSamplingFactor = 1
- , quantizationTableDest = 1
- }
- ]
- }
-
- lumaQuant = scaleQuantisationMatrix (fromIntegral quality)
- defaultLumaQuantizationTable
- chromaQuant = scaleQuantisationMatrix (fromIntegral quality)
- defaultChromaQuantizationTable
-
- zigzagedLumaQuant = zigZagReorderForwardv lumaQuant
- zigzagedChromaQuant = zigZagReorderForwardv chromaQuant
- quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0
- , quantTable = zigzagedLumaQuant }
- , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1
- , quantTable = zigzagedChromaQuant }
- ]
-
- encodedImage = runST $ do
- let horizontalMetaBlockCount =
- w `divUpward` (dctBlockSize * maxSampling)
- verticalMetaBlockCount =
- h `divUpward` (dctBlockSize * maxSampling)
- maxSampling = 2
- lumaSamplingSize = ( maxSampling, maxSampling, zigzagedLumaQuant
- , makeInverseTable defaultDcLumaHuffmanTree
- , makeInverseTable defaultAcLumaHuffmanTree)
- chromaSamplingSize = ( maxSampling - 1, maxSampling - 1, zigzagedChromaQuant
- , makeInverseTable defaultDcChromaHuffmanTree
- , makeInverseTable defaultAcChromaHuffmanTree)
- componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize]
-
- imageComponentCount = length componentDef
-
- dc_table <- M.replicate 3 0
- block <- createEmptyMutableMacroBlock
- workData <- createEmptyMutableMacroBlock
- zigzaged <- createEmptyMutableMacroBlock
- writeState <- newWriteStateRef
-
- -- It's ugly, I know, be avoid allocation
- let blockDecoder mx my = component $ zip [0..] componentDef
- where component [] = return ()
- component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) =
- rasterMap sizeX sizeY decoder >> component comp_rest
- where xSamplingFactor = maxSampling - sizeX + 1
- ySamplingFactor = maxSampling - sizeY + 1
- extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount
-
- decoder subX subY = do
- let blockY = my * sizeY + subY
- blockX = mx * sizeX + subX
- prev_dc <- dc_table `M.unsafeRead` comp
- (dc_coeff, neo_block) <- extractor comp blockX blockY >>=
- encodeMacroBlock table workData zigzaged prev_dc
- (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
- serializeMacroBlock writeState dc ac neo_block
-
- rasterMap
- horizontalMetaBlockCount verticalMetaBlockCount
- blockDecoder
+encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata
+
+-- | Equivalent to 'encodeJpegAtQuality', but will store the following
+-- metadatas in the file using a JFIF block:
+--
+-- * 'Codec.Picture.Metadata.DpiX'
+-- * 'Codec.Picture.Metadata.DpiY'
+--
+-- This function also allow to create JPEG files with the following color
+-- space:
+--
+-- * Y (Pixel8) for greyscale.
+-- * RGB (PixelRGB8) with no color downsampling on any plane
+-- * CMYK (PixelCMYK8) with no color downsampling on any plane
+--
+encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px)
+ => Word8 -- ^ Quality factor
+ -> Metadatas
+ -> Image px -- ^ Image to encode
+ -> L.ByteString -- ^ Encoded JPEG
+encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where
+ !w = imageWidth img
+ !h = imageHeight img
+ finalImage = JpgImage $
+ encodeMetadatas metas ++
+ additionalBlocks img ++
+ [ JpgQuantTable $ quantTableSpec img (fromIntegral quality)
+ , JpgScans JpgBaselineDCTHuffman hdr
+ , JpgHuffmanTable $ imageHuffmanTables img
+ , JpgScanBlob scanHeader encodedImage
+ ]
+
+ !outputComponentCount = componentCount (undefined :: px)
+
+ scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
+ scanHeader' = JpgScanHeader
+ { scanLength = 0
+ , scanComponentCount = fromIntegral outputComponentCount
+ , scans = scanSpecificationOfColorSpace img
+ , spectralSelection = (0, 63)
+ , successiveApproxHigh = 0
+ , successiveApproxLow = 0
+ }
+
+ hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' }
+ hdr' = JpgFrameHeader
+ { jpgFrameHeaderLength = 0
+ , jpgSamplePrecision = 8
+ , jpgHeight = fromIntegral h
+ , jpgWidth = fromIntegral w
+ , jpgImageComponentCount = fromIntegral outputComponentCount
+ , jpgComponents = componentsOfColorSpace img
+ }
+
+ !maxSampling = maximumSubSamplingOf img
+ !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling)
+ !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling)
+ !componentDef = encodingState (fromIntegral quality) img
+
+ encodedImage = runST $ do
+ dc_table <- M.replicate outputComponentCount 0
+ block <- createEmptyMutableMacroBlock
+ workData <- createEmptyMutableMacroBlock
+ zigzaged <- createEmptyMutableMacroBlock
+ writeState <- newWriteStateRef
+
+ rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my ->
+ V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) ->
+ let !xSamplingFactor = maxSampling - sizeX + 1
+ !ySamplingFactor = maxSampling - sizeY + 1
+ !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount
+ in
+ rasterMap sizeX sizeY $ \subX subY -> do
+ let !blockY = my * sizeY + subY
+ !blockX = mx * sizeX + subX
+ prev_dc <- dc_table `M.unsafeRead` comp
+ extracted <- extractor comp blockX blockY
+ (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted
+ (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
+ serializeMacroBlock writeState dc ac neo_block
- finalizeBoolWriter writeState
+ finalizeBoolWriter writeState
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Saving.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Saving.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Saving.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Saving.hs 2016-01-25 23:33:57.000000000 +0100
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
-- | Helper functions to save dynamic images to other file format
-- with automatic color space/sample format conversion done automatically.
module Codec.Picture.Saving( imageToJpg
@@ -10,6 +11,10 @@
, imageToTga
) where
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+#endif
+
import Data.Bits( unsafeShiftR )
import Data.Word( Word8, Word16 )
import qualified Data.ByteString.Lazy as L
@@ -94,9 +99,13 @@
-- | This function will try to do anything to encode an image
-- as JPEG, make all color conversion and such. Equivalent
-- of 'decodeImage' for jpeg encoding
+-- Save Y or YCbCr Jpeg only, all other colorspaces are converted.
+-- To save a RGB or CMYK JPEG file, use the
+-- 'Codec.Picture.Jpg.encodeDirectJpegAtQualityWithMetadata' function
imageToJpg :: Int -> DynamicImage -> L.ByteString
imageToJpg quality dynImage =
let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)
+ encodeWithMeta = encodeDirectJpegAtQualityWithMetadata (fromIntegral quality) mempty
in case dynImage of
ImageYCbCr8 img -> encodeAtQuality img
ImageCMYK8 img -> imageToJpg quality . ImageRGB8 $ convertImage img
@@ -105,10 +114,8 @@
ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img
ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img)
ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img
- ImageY8 img -> encodeAtQuality . convertImage
- $ (promoteImage img :: Image PixelRGB8)
- ImageYA8 img -> encodeAtQuality $
- convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)
+ ImageY8 img -> encodeWithMeta img
+ ImageYA8 img -> encodeWithMeta $ dropAlphaLayer img
ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img
ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img
ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Types.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Types.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Types.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture/Types.hs 2016-01-25 23:33:57.000000000 +0100
@@ -739,7 +739,7 @@
-> Int -- ^ Height in pixels
-> m (MutableImage (PrimState m) px)
{-# INLINE generateMutableImage #-}
-generateMutableImage f w h = MutableImage w h <$> generated where
+generateMutableImage f w h = MutableImage w h `liftM` generated where
compCount = componentCount (undefined :: px)
generated = do
@@ -897,6 +897,7 @@
{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-}
{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-}
{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-}
pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } =
Image w h pixels
where sourceComponentCount = componentCount (undefined :: a)
@@ -1105,9 +1106,10 @@
instance LumaPlaneExtractable PixelRGBA8 where
{-# INLINE computeLuma #-}
- computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r +
- 0.59 * toRational g +
- 0.11 * toRational b
+ computeLuma (PixelRGBA8 r g b _) =
+ floor $ (0.3 :: Double) * fromIntegral r
+ + 0.59 * fromIntegral g
+ + 0.11 * fromIntegral b
instance LumaPlaneExtractable PixelYCbCr8 where
{-# INLINE computeLuma #-}
@@ -1570,9 +1572,11 @@
instance LumaPlaneExtractable PixelRGB16 where
{-# INLINE computeLuma #-}
- computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r +
- 0.59 * toRational g +
- 0.11 * toRational b
+ computeLuma (PixelRGB16 r g b) =
+ floor $ (0.3 :: Double) * fromIntegral r
+ + 0.59 * fromIntegral g
+ + 0.11 * fromIntegral b
+
--------------------------------------------------
---- PixelRGB8 instances
--------------------------------------------------
@@ -1654,9 +1658,10 @@
instance LumaPlaneExtractable PixelRGB8 where
{-# INLINE computeLuma #-}
- computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r +
- 0.59 * toRational g +
- 0.11 * toRational b
+ computeLuma (PixelRGB8 r g b) =
+ floor $ (0.3 :: Double) * fromIntegral r
+ + 0.59 * fromIntegral g
+ + 0.11 * fromIntegral b
--------------------------------------------------
---- PixelRGBA8 instances
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture.hs new/JuicyPixels-3.2.7/src/Codec/Picture.hs
--- old/JuicyPixels-3.2.6.4/src/Codec/Picture.hs 2015-12-02 22:38:14.000000000 +0100
+++ new/JuicyPixels-3.2.7/src/Codec/Picture.hs 2016-01-25 23:33:56.000000000 +0100
@@ -1,7 +1,10 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | Main module for image import/export into various image formats.
--
-- To use the library without thinking about it, look after 'decodeImage' and
@@ -23,6 +26,10 @@
, generateFoldImage
, withImage
+ -- * RGB helper functions
+ , convertRGB8
+ , convertRGBA8
+
-- * Lens compatibility
, Traversal
, imagePixels
@@ -138,6 +145,7 @@
import Control.Applicative( (<$>) )
#endif
+import Data.Bits( unsafeShiftR )
import Control.DeepSeq( NFData, deepseq )
import qualified Control.Exception as Exc ( catch, IOException )
import Codec.Picture.Metadata( Metadatas )
@@ -200,6 +208,7 @@
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
+import qualified Data.Vector.Storable as VS
-- | Return the first Right thing, accumulating error
eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b
@@ -263,6 +272,7 @@
readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas))
readImageWithMetadata = withImageDecoder decodeImageWithMetadata
+
-- | If you want to decode an image in a bytestring without even thinking
-- in term of format or whatever, this is the function to use. It will try
-- to decode in each known format and if one decoding succeeds, it will return
@@ -270,6 +280,85 @@
decodeImage :: B.ByteString -> Either String DynamicImage
decodeImage = fmap fst . decodeImageWithMetadata
+class Decimable px1 px2 where
+ decimateBitDepth :: Image px1 -> Image px2
+
+decimateWord16 :: ( Pixel px1, Pixel px2
+ , PixelBaseComponent px1 ~ Pixel16
+ , PixelBaseComponent px2 ~ Pixel8
+ ) => Image px1 -> Image px2
+decimateWord16 (Image w h da) =
+ Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da
+
+decimateFloat :: ( Pixel px1, Pixel px2
+ , PixelBaseComponent px1 ~ PixelF
+ , PixelBaseComponent px2 ~ Pixel8
+ ) => Image px1 -> Image px2
+decimateFloat (Image w h da) =
+ Image w h $ VS.map (floor . (255*) . max 0 . min 1) da
+
+instance Decimable Pixel16 Pixel8 where
+ decimateBitDepth = decimateWord16
+
+instance Decimable PixelYA16 PixelYA8 where
+ decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGB16 PixelRGB8 where
+ decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGBA16 PixelRGBA8 where
+ decimateBitDepth = decimateWord16
+
+instance Decimable PixelCMYK16 PixelCMYK8 where
+ decimateBitDepth = decimateWord16
+
+instance Decimable PixelF Pixel8 where
+ decimateBitDepth = decimateFloat
+
+instance Decimable PixelRGBF PixelRGB8 where
+ decimateBitDepth = decimateFloat
+
+-- | Convert by any mean possible a dynamic image to an image
+-- in RGBA. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels.
+convertRGBA8 :: DynamicImage -> Image PixelRGBA8
+convertRGBA8 dynImage = case dynImage of
+ ImageY8 img -> promoteImage img
+ ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+ ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+ ImageYA8 img -> promoteImage img
+ ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+ ImageRGB8 img -> promoteImage img
+ ImageRGB16 img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+ ImageRGBF img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+ ImageRGBA8 img -> promoteImage img
+ ImageRGBA16 img -> decimateBitDepth img
+ ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8)
+ ImageCMYK8 img -> promoteImage (convertImage img :: Image PixelRGB8)
+ ImageCMYK16 img ->
+ promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8)
+
+-- | Convert by any mean possible a dynamic image to an image
+-- in RGB. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels. Any alpha layer will
+-- be dropped
+convertRGB8 :: DynamicImage -> Image PixelRGB8
+convertRGB8 dynImage = case dynImage of
+ ImageY8 img -> promoteImage img
+ ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+ ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+ ImageYA8 img -> promoteImage img
+ ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+ ImageRGB8 img -> img
+ ImageRGB16 img -> decimateBitDepth img
+ ImageRGBF img -> decimateBitDepth img :: Image PixelRGB8
+ ImageRGBA8 img -> dropAlphaLayer img
+ ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8)
+ ImageYCbCr8 img -> convertImage img
+ ImageCMYK8 img -> convertImage img
+ ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8)
+
+
-- | Equivalent to 'decodeImage', but also provide potential metadatas
-- present in the given file.
decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
@@ -306,7 +395,7 @@
readJpeg :: FilePath -> IO (Either String DynamicImage)
readJpeg = withImageDecoder decodeJpeg
--- | Try to load a .bmp file. The colorspace would be RGB or Y.
+-- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y.
readBitmap :: FilePath -> IO (Either String DynamicImage)
readBitmap = withImageDecoder decodeBitmap
1
0
Hello community,
here is the log from the commit of package ghc-HUnit for openSUSE:Factory checked in at 2016-01-28 17:23:54
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-HUnit (Old)
and /work/SRC/openSUSE:Factory/.ghc-HUnit.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-HUnit"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-HUnit/ghc-HUnit.changes 2016-01-22 01:08:35.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-HUnit.new/ghc-HUnit.changes 2016-01-28 17:24:47.000000000 +0100
@@ -1,0 +2,5 @@
+Fri Jan 22 10:12:18 UTC 2016 - mimi.vx(a)gmail.com
+
+- update to 1.3.1.1
+
+-------------------------------------------------------------------
Old:
----
HUnit-1.3.1.0.tar.gz
New:
----
HUnit-1.3.1.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-HUnit.spec ++++++
--- /var/tmp/diff_new_pack.1TwUXh/_old 2016-01-28 17:24:47.000000000 +0100
+++ /var/tmp/diff_new_pack.1TwUXh/_new 2016-01-28 17:24:47.000000000 +0100
@@ -19,7 +19,7 @@
%global pkg_name HUnit
Name: ghc-HUnit
-Version: 1.3.1.0
+Version: 1.3.1.1
Release: 0
Summary: A unit testing framework for Haskell
License: BSD-3-Clause
@@ -75,6 +75,6 @@
%files devel -f %{name}-devel.files
%defattr(-,root,root,-)
-%doc examples README.md doc
+%doc examples README.md
%changelog
++++++ HUnit-1.3.1.0.tar.gz -> HUnit-1.3.1.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/CHANGELOG.md new/HUnit-1.3.1.1/CHANGELOG.md
--- old/HUnit-1.3.1.0/CHANGELOG.md 1970-01-01 01:00:00.000000000 +0100
+++ new/HUnit-1.3.1.1/CHANGELOG.md 2016-01-19 17:16:50.000000000 +0100
@@ -0,0 +1,19 @@
+## Changes
+
+#### 1.3.1.1
+
+- Various updates to metadata and documentation removing outdated information and making other things more visible
+
+### 1.3.1.0
+
+- add minimal support for GHC 8.0
+
+### 1.3.0.0
+
+- removed support for old compilers
+
+- add source locations for failing assertions (GHC >= 7.10.2 only)
+
+#### 1.2.5.2
+
+- Added support for GHC 7.7
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/HUnit.cabal new/HUnit-1.3.1.1/HUnit.cabal
--- old/HUnit-1.3.1.0/HUnit.cabal 2016-01-11 10:04:20.000000000 +0100
+++ new/HUnit-1.3.1.1/HUnit.cabal 2016-01-19 17:16:50.000000000 +0100
@@ -1,23 +1,22 @@
Name: HUnit
-Version: 1.3.1.0
+Version: 1.3.1.1
Cabal-Version: >= 1.8
License: BSD3
License-File: LICENSE
Author: Dean Herington
Maintainer: Simon Hengel <sol(a)typeful.net>
Stability: stable
-Homepage: http://hunit.sourceforge.net/
+Homepage: https://github.com/hspec/HUnit#readme
Category: Testing
Synopsis: A unit testing framework for Haskell
Description:
HUnit is a unit testing framework for Haskell, inspired by the
JUnit tool for Java, see: <http://www.junit.org>.
Build-Type: Simple
-Data-Files:
- doc/Guide.html
- examples/Example.hs
- prologue.txt
+Extra-Source-Files:
+ CHANGELOG.md
README.md
+ examples/Example.hs
source-repository head
type: git
@@ -38,7 +37,7 @@
Test-Suite tests
Type: exitcode-stdio-1.0
Main-Is: HUnitTests.hs
- HS-Source-Dirs: tests
+ HS-Source-Dirs: tests, examples
Build-Depends:
base == 4.*,
deepseq,
@@ -49,4 +48,5 @@
HUnitTestBase
HUnitTestExtended
TerminalTest
+ Example
GHC-Options: -Wall
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/README.md new/HUnit-1.3.1.1/README.md
--- old/HUnit-1.3.1.0/README.md 2016-01-11 10:04:20.000000000 +0100
+++ new/HUnit-1.3.1.1/README.md 2016-01-19 17:16:50.000000000 +0100
@@ -1,28 +1,545 @@
-# HUnit
+# HUnit User's Guide
-HUnit is a unit testing framework for Haskell, inspired by the JUnit
-tool for Java. HUnit is free software; see its "License" file for
-details. HUnit is available at <http://hunit.sourceforge.net>.
+HUnit is a unit testing framework for Haskell, inspired by the JUnit tool for Java. This
+guide describes how to use HUnit, assuming you are familiar with Haskell, though not
+necessarily with JUnit. You can obtain HUnit, including this guide, at
+[https://github.com/hspec/HUnit](https://github.com/hspec/HUnit)
-HUnit 1.1.1 consists of a number of files. Besides Haskell source files
-in Test/HUnit (whose names end in ".hs" or ".lhs"), these files include:
+## Introduction
+A test-centered methodology for software development is most effective when tests are
+easy to create, change, and execute. The [JUnit](www.junit.org) tool
+pioneered support for test-first development in [Java](http://java.sun.com).
+HUnit is an adaptation of JUnit to Haskell, a general-purpose, purely functional
+programming language. (To learn more about Haskell, see www.haskell.org](http://www.haskell.org).
+With HUnit, as with JUnit, you can easily create tests, name them, group them into
+suites, and execute them, with the framework checking the results automatically. Test
+specification in HUnit is even more concise and flexible than in JUnit, thanks to the
+nature of the Haskell language. HUnit currently includes only a text-based test
+controller, but the framework is designed for easy extension. (Would anyone care to
+write a graphical test controller for HUnit?)
+
+The next section helps you get started using HUnit in simple ways. Subsequent sections
+give details on [writing tests](#writing-tests) and [running tests](#running-tests).
+The document concludes with a section describing HUnit's [constituent files](#constituent-files)
+and a section giving [references](#references) to further information.
+
+## Getting Started
+
+In the Haskell module where your tests will reside, import module `Test.HUnit`:
+
+```haskell
+import Test.HUnit
+```
+
+Define test cases as appropriate:
+
+```haskell
+test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))
+test2 = TestCase (do (x,y) <- partA 3
+ assertEqual "for the first result of partA," 5 x
+ b <- partB y
+ assertBool ("(partB " ++ show y ++ ") failed") b)
+```
+
+Name the test cases and group them together:
+
+```haskell
+tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]
+```
+
+Run the tests as a group. At a Haskell interpreter prompt, apply the
+function `runTestTT` to the collected tests. (The `TT` suggests
+**T**ext orientation with output to the **T**erminal.)
+
+```haskell
+> runTestTT tests
+Cases: 2 Tried: 2 Errors: 0 Failures: 0
+>
+```
+
+If the tests are proving their worth, you might see:
+
+```haskell
+> runTestTT tests
+### Failure in: 0:test1
+for (foo 3),
+expected: (1,2)
+ but got: (1,3)
+Cases: 2 Tried: 2 Errors: 0 Failures: 1
+>
+```
+
+Isn't that easy?
+
+You can specify tests even more succinctly using operators and
+overloaded functions that HUnit provides:
+
+```haskell
+tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),
+ "test2" ~: do (x, y) <- partA 3
+ assertEqual "for the first result of partA," 5 x
+ partB y @? "(partB " ++ show y ++ ") failed" ]
+```
+
+Assuming the same test failures as before, you would see:
+
+```haskell
+> runTestTT tests
+### Failure in: 0:test1:(foo 3)
+expected: (1,2)
+ but got: (1,3)
+Cases: 2 Tried: 2 Errors: 0 Failures: 1
+>
+```
+
+## Writing Tests
+
+Tests are specified compositionally. [Assertions](#assertions) are
+combined to make a [test case](#test-case), and test cases are combined
+into [tests](#tests). HUnit also provides [advanced
+features](#advanced-features) for more convenient test specification.
+
+### Assertions
+
+ The basic building block of a test is an **assertion**.
+
+```haskell
+type Assertion = IO ()
+```
+
+An assertion is an `IO` computation that always produces a void result. Why is an assertion an `IO` computation? So that programs with real-world side effects can be tested. How does an assertion assert anything if it produces no useful result? The answer is that an assertion can signal failure by calling `assertFailure`.
+
+```haskell
+assertFailure :: String -> Assertion
+assertFailure msg = ioError (userError ("HUnit:" ++ msg))
+```
+
+`(assertFailure msg)` raises an exception. The string argument identifies the
+ failure. The failure message is prefixed by "`HUnit:`" to mark it as an HUnit
+ assertion failure message. The HUnit test framework interprets such an exception as
+ indicating failure of the test whose execution raised the exception. (Note: The details
+ concerning the implementation of `assertFailure` are subject to change and should
+ not be relied upon.)
+
+`assertFailure` can be used directly, but it is much more common to use it
+ indirectly through other assertion functions that conditionally assert failure.
+
+```haskell
+assertBool :: String -> Bool -> Assertion
+assertBool msg b = unless b (assertFailure msg)
+
+assertString :: String -> Assertion
+assertString s = unless (null s) (assertFailure s)
+
+assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion
+assertEqual preface expected actual =
+ unless (actual == expected) (assertFailure msg)
+ where msg = (if null preface then "" else preface ++ "\n") ++
+ "expected: " ++ show expected ++ "\n but got: " ++ show actual
+```
+
+With `assertBool` you give the assertion condition and failure message separately.
+ With `assertString` the two are combined. With `assertEqual` you provide a
+ "preface", an expected value, and an actual value; the failure message shows the two
+ unequal values and is prefixed by the preface. Additional ways to create assertions are
+ described later under [Avanced Features](#advanced-features)
+
+Since assertions are `IO` computations, they may be combined--along with other
+ `IO` computations--using `(>>=)`, `(>>)`, and the `do`
+ notation. As long as its result is of type `(IO ())`, such a combination
+ constitutes a single, collective assertion, incorporating any number of constituent
+ assertions. The important features of such a collective assertion are that it fails if
+ any of its constituent assertions is executed and fails, and that the first constituent
+ assertion to fail terminates execution of the collective assertion. Such behavior is
+ essential to specifying a test case.
+
+### Test Case
+
+A **test case** is the unit of test execution. That is, distinct test cases are
+ executed independently. The failure of one is independent of the failure of any other.
+
+A test case consists of a single, possibly collective, assertion. The possibly multiple
+ constituent assertions in a test case's collective assertion are **not** independent.
+ Their interdependence may be crucial to specifying correct operation for a test. A test
+ case may involve a series of steps, each concluding in an assertion, where each step
+ must succeed in order for the test case to continue. As another example, a test may
+ require some "set up" to be performed that must be undone ("torn down" in JUnit
+ parlance) once the test is complete. In this case, you could use Haskell's
+ `IO.bracket` function to achieve the desired effect.
+
+You can make a test case from an assertion by applying the `TestCase` constructor.
+ For example, `(TestCase (return ()))` is a test case that never
+ fails, and `(TestCase (assertEqual "for x," 3 x))`
+ is a test case that checks that the value of `x` is 3. Additional ways
+ to create test cases are described later under [Advanced Features](#advanced-eatures).
+
+### Tests
+
+As soon as you have more than one test, you'll want to name them to tell them apart. As
+ soon as you have more than several tests, you'll want to group them to process them more
+ easily. So, naming and grouping are the two keys to managing collections of tests.
+
+In tune with the "composite" design pattern [1], a
+ **test** is defined as a package of test cases. Concretely, a test is either a single
+ test case, a group of tests, or either of the first two identified by a label.
+
+```haskell
+data Test = TestCase Assertion
+ | TestList [Test]
+ | TestLabel String Test
+```
+
+There are three important features of this definition to note:
+
+
+* A `TestList` consists of a list of tests rather than a list of test cases.
+ This means that the structure of a `Test` is actually a tree. Using a
+ hierarchy helps organize tests just as it helps organize files in a file system.
+* A `TestLabel` is attached to a test rather than to a test case. This means
+ that all nodes in the test tree, not just test case (leaf) nodes, can be labeled.
+ Hierarchical naming helps organize tests just as it helps organize files in a file
+ system.
+* A `TestLabel` is separate from both `TestCase` and `TestList`.
+ This means that labeling is optional everywhere in the tree. Why is this a good
+ thing? Because of the hierarchical structure of a test, each constituent test case
+ is uniquely identified by its path in the tree, ignoring all labels. Sometimes a
+ test case's path (or perhaps its subpath below a certain node) is a perfectly
+ adequate "name" for the test case (perhaps relative to a certain node). In this
+ case, creating a label for the test case is both unnecessary and inconvenient.
+
+
+The number of test cases that a test comprises can be computed with `testCaseCount`.
+
+```haskell
+testCaseCount :: Test -> Int
+```
+
+As mentioned above, a test is identified by its **path** in the test hierarchy.
+
+```haskell
+data Node = ListItem Int | Label String
+ deriving (Eq, Show, Read)
+
+type Path = [Node] -- Node order is from test case to root.
+```
+
+Each occurrence of `TestList` gives rise to a `ListItem` and each
+ occurrence of `TestLabel` gives rise to a `Label`. The `ListItem`s
+ by themselves ensure uniqueness among test case paths, while the `Label`s allow
+ you to add mnemonic names for individual test cases and collections of them.
+
+Note that the order of nodes in a path is reversed from what you might expect: The first
+ node in the list is the one deepest in the tree. This order is a concession to
+ efficiency: It allows common path prefixes to be shared.
+
+The paths of the test cases that a test comprises can be computed with
+ `testCasePaths`. The paths are listed in the order in which the corresponding
+ test cases would be executed.
+
+```haskell
+testCasePaths :: Test -> [Path]
+```
+
+The three variants of `Test` can be constructed simply by applying
+ `TestCase`, `TestList`, and `TestLabel` to appropriate arguments.
+ Additional ways to create tests are described later under [Advanced Features](#advanced-features).
+
+The design of the type `Test` provides great conciseness, flexibility, and
+ convenience in specifying tests. Moreover, the nature of Haskell significantly augments
+ these qualities:
+
+* Combining assertions and other code to construct test cases is easy with the
+ `IO` monad.
+* Using overloaded functions and special operators (see below), specification of
+ assertions and tests is extremely compact.
+* Structuring a test tree by value, rather than by name as in JUnit, provides for more
+ convenient, flexible, and robust test suite specification. In particular, a test
+ suite can more easily be computed "on the fly" than in other test frameworks.
+* Haskell's powerful abstraction facilities provide unmatched support for test
+ refactoring.
+
+### Advanced Features
+
+HUnit provides additional features for specifying assertions and tests more conveniently
+ and concisely. These facilities make use of Haskell type classes.
+
+The following operators can be used to construct assertions.
+
+```haskell
+infix 1 @?, @=?, @?=
+
+(@?) :: (AssertionPredicable t) => t -> String -> Assertion
+pred @? msg = assertionPredicate pred >>= assertBool msg
+
+(@=?) :: (Eq a, Show a) => a -> a -> Assertion
+expected @=? actual = assertEqual "" expected actual
+
+(@?=) :: (Eq a, Show a) => a -> a -> Assertion
+actual @?= expected = assertEqual "" expected actual
+```
+
+You provide a boolean condition and failure message separately to `(@?)`, as for
+ `assertBool`, but in a different order. The `(@=?)` and `(@?=)`
+ operators provide shorthands for `assertEqual` when no preface is required. They
+ differ only in the order in which the expected and actual values are provided. (The
+ actual value--the uncertain one--goes on the "?" side of the operator.)
+
+The `(@?)` operator's first argument is something from which an assertion
+ predicate can be made, that is, its type must be `AssertionPredicable`.
+
+```haskell
+type AssertionPredicate = IO Bool
+
+class AssertionPredicable t
+ where assertionPredicate :: t -> AssertionPredicate
+
+instance AssertionPredicable Bool
+ where assertionPredicate = return
+
+instance (AssertionPredicable t) => AssertionPredicable (IO t)
+ where assertionPredicate = (>>= assertionPredicate)
+```
+
+The overloaded `assert` function in the `Assertable` type class constructs
+ an assertion.
+
+```haskell
+class Assertable t
+ where assert :: t -> Assertion
+
+instance Assertable ()
+ where assert = return
+
+instance Assertable Bool
+ where assert = assertBool ""
+
+instance (ListAssertable t) => Assertable [t]
+ where assert = listAssert
+
+instance (Assertable t) => Assertable (IO t)
+ where assert = (>>= assert)
+```
+
+The `ListAssertable` class allows `assert` to be applied to `[Char]`
+ (that is, `String`).
+
+```haskell
+class ListAssertable t
+ where listAssert :: [t] -> Assertion
+
+instance ListAssertable Char
+ where listAssert = assertString
+```
+
+With the above declarations, `(assert ())`,
+ `(assert True)`, and `(assert "")` (as well as
+ `IO` forms of these values, such as `(return ())`) are all
+ assertions that never fail, while `(assert False)` and
+ `(assert "some failure message")` (and their
+ `IO` forms) are assertions that always fail. You may define additional
+ instances for the type classes `Assertable`, `ListAssertable`, and
+ `AssertionPredicable` if that should be useful in your application.
+
+The overloaded `test` function in the `Testable` type class constructs a
+ test.
+
+```haskell
+class Testable t
+ where test :: t -> Test
+
+instance Testable Test
+ where test = id
+
+instance (Assertable t) => Testable (IO t)
+ where test = TestCase . assert
+
+instance (Testable t) => Testable [t]
+ where test = TestList . map test
+```
+
+The `test` function makes a test from either an `Assertion` (using
+ `TestCase`), a list of `Testable` items (using `TestList`), or
+ a `Test` (making no change).
+
+The following operators can be used to construct tests.
+
+```haskell
+infix 1 ~?, ~=?, ~?=
+infixr 0 ~:
+
+(~?) :: (AssertionPredicable t) => t -> String -> Test
+pred ~? msg = TestCase (pred @? msg)
+
+(~=?) :: (Eq a, Show a) => a -> a -> Test
+expected ~=? actual = TestCase (expected @=? actual)
+
+(~?=) :: (Eq a, Show a) => a -> a -> Test
+actual ~?= expected = TestCase (actual @?= expected)
+
+(~:) :: (Testable t) => String -> t -> Test
+label ~: t = TestLabel label (test t)
+```
+
+`(~?)`, `(~=?)`, and `(~?=)` each make an assertion, as for
+ `(@?)`, `(@=?)`, and `(@?=)`, respectively, and then a test case
+ from that assertion. `(~:)` attaches a label to something that is
+ `Testable`. You may define additional instances for the type class
+ `Testable` should that be useful.
+
+## Running Tests
+
+HUnit is structured to support multiple test controllers. The first
+ subsection below describes the [test execution](#test-execution)
+ characteristics common to all test controllers. The second subsection
+ describes the text-based controller that is included with HUnit.
+
+## Test Execution
+
+All test controllers share a common test execution model. They differ only in how the
+ results of test execution are shown.
+
+The execution of a test (a value of type `Test`) involves the serial execution (in
+ the `IO` monad) of its constituent test cases. The test cases are executed in a
+ depth-first, left-to-right order. During test execution, four counts of test cases are
+ maintained:
+
+```haskell
+data Counts = Counts { cases, tried, errors, failures :: Int }
+ deriving (Eq, Show, Read)
```
- * README.md -- this file
- * doc/Guide.html -- user's guide, in HTML format
- * LICENSE -- license for use of HUnit
+
+
+* `cases` is the number of test cases included in the test. This number is a
+ static property of a test and remains unchanged during test execution.
+* `tried` is the number of test cases that have been executed so far during the
+ test execution.
+* `errors` is the number of test cases whose execution ended with an unexpected
+ exception being raised. Errors indicate problems with test cases, as opposed to the
+ code under test.
+* `failures` is the number of test cases whose execution asserted failure.
+ Failures indicate problems with the code under test.
+
+
+Why is there no count for test case successes? The technical reason is that the counts
+ are maintained such that the number of test case successes is always equal to
+ `(tried - (errors + failures))`. The
+ psychosocial reason is that, with test-centered development and the expectation that
+ test failures will be few and short-lived, attention should be focused on the failures
+ rather than the successes.
+
+As test execution proceeds, three kinds of reporting event are communicated to the test
+ controller. (What the controller does in response to the reporting events depends on the
+ controller.)
+
+* *start* -- Just prior to initiation of a test case, the path of the test case
+ and the current counts (excluding the current test case) are reported.
+* *error* -- When a test case terminates with an error, the error message is
+ reported, along with the test case path and current counts (including the current
+ test case).
+* *failure* -- When a test case terminates with a failure, the failure message is
+ reported, along with the test case path and current counts (including the current
+ test case).
+
+Typically, a test controller shows *error* and *failure* reports immediately
+ but uses the *start* report merely to update an indication of overall test
+ execution progress.
+
+### Text-Based Controller
+
+A text-based test controller is included with HUnit.
+
+```haskell
+runTestText :: PutText st -> Test -> IO (Counts, st)
+```
+
+`runTestText` is generalized on a *reporting scheme* given as its first
+ argument. During execution of the test given as its second argument, the controller
+ creates a string for each reporting event and processes it according to the reporting
+ scheme. When test execution is complete, the controller returns the final counts along
+ with the final state for the reporting scheme.
+
+The strings for the three kinds of reporting event are as follows.
+
+* A *start* report is the result of the function `showCounts` applied to
+ the counts current immediately prior to initiation of the test case being started.
+* An *error* report is of the form
+ "`Error in: *path*\n*message*`",
+ where *path* is the path of the test case in error, as shown by
+ `showPath`, and *message* is a message describing the error. If the path
+ is empty, the report has the form "`Error:\n*message*`".
+* A *failure* report is of the form
+ "`Failure in: *path*\n*message*`", where
+ *path* is the path of the test case in error, as shown by
+ `showPath`, and *message* is the failure message. If the path is empty,
+ the report has the form "`Failure:\n*message*`".
+
+The function `showCounts` shows a set of counts.
+
+```haskell
+showCounts :: Counts -> String
+```
+
+The form of its result is
+`Cases: *cases* Tried: *tried* Errors: *errors* Failures: *failures*`
+where *cases*, *tried*, *errors*, and *failures* are the count values.
+
+The function `showPath` shows a test case path.
+
+```haskell
+ showPath :: Path -> String
+```
+
+The nodes in the path are reversed (so that the path reads from the root down to the test
+ case), and the representations for the nodes are joined by '`:`' separators. The
+ representation for `(ListItem *n*)` is `(show n)`. The representation
+ for `(Label *label*)` is normally *label*. However, if *label*
+ contains a colon or if `(show *label*)` is different from *label*
+ surrounded by quotation marks--that is, if any ambiguity could exist--then `(Label
+ *label*)` is represented as `(show *label*)`.
+
+HUnit includes two reporting schemes for the text-based test controller. You may define
+ others if you wish.
+
+```haskell
+putTextToHandle :: Handle -> Bool -> PutText Int
+```
+
+`putTextToHandle` writes error and failure reports, plus a report of the final
+ counts, to the given handle. Each of these reports is terminated by a newline. In
+ addition, if the given flag is `True`, it writes start reports to the handle as
+ well. A start report, however, is not terminated by a newline. Before the next report is
+ written, the start report is "erased" with an appropriate sequence of carriage return
+ and space characters. Such overwriting realizes its intended effect on terminal devices.
+
+```haskell
+putTextToShowS :: PutText ShowS
+```
+
+`putTextToShowS` ignores start reports and simply accumulates error and failure
+ reports, terminating them with newlines. The accumulated reports are returned (as the
+ second element of the pair returned by `runTestText`) as a `ShowS`
+ function (that is, one with type `(String -> String)`) whose
+ first argument is a string to be appended to the accumulated report lines.
+
+HUnit provides a shorthand for the most common use of the text-based test controller.
+
+```haskell
+runTestTT :: Test -> IO Counts
```
-See the user's guide for more information.
+`runTestTT` invokes `runTestText`, specifying `(putTextToHandle stderr
+True)` for the reporting scheme, and returns the final counts from the
+test execution.
-## Changes
+## References
-### 1.3.1.0
+* [1] Gamma, E., et al. Design Patterns: Elements of Reusable Object-Oriented Software, Addison-Wesley, Reading, MA, 1995: The classic book describing design patterns in an object-oriented context.
-- add minimal support for GHC 8.0
+* [junit.org](http://www.junit.org): Web page for JUnit, the tool after which HUnit is modeled.
-### 1.3.0.0
+* [http://junit.sourceforge.net/doc/testinfected/testing.htm](http://junit.sou…: A good introduction to test-first development and the use of JUnit.
-- removed support for old compilers
+* [http://junit.sourceforge.net/doc/cookstour/cookstour.htm](http://junit.sour…: A description of the internal structure of JUnit. Makes for an interesting comparison between JUnit and HUnit.
-- add source locations for failing assertions (GHC >= 7.10.2 only)
+The HUnit software and this guide were written by Dean Herington [heringto@cs.unc.edu](mailto:heringto@cs.unc.edu)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/doc/Guide.html new/HUnit-1.3.1.1/doc/Guide.html
--- old/HUnit-1.3.1.0/doc/Guide.html 2016-01-11 10:04:20.000000000 +0100
+++ new/HUnit-1.3.1.1/doc/Guide.html 1970-01-01 01:00:00.000000000 +0100
@@ -1,539 +0,0 @@
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
- "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
- xsi:schemaLocation="http://www.w3.org/MarkUp/SCHEMA/xhtml11.xsd" xml:lang="en">
- <head>
- <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>
- <meta name="Author" content="Dean Herington"/>
- <meta name="KeyWords" content="HUnit, unit testing, test-first development, Haskell, JUnit"/>
- <title>HUnit 1.0 User's Guide</title>
- </head>
- <body>
-
- <h1>HUnit 1.2 User's Guide</h1>
-
- <p>HUnit is a unit testing framework for Haskell, inspired by the JUnit tool for Java. This
- guide describes how to use HUnit, assuming you are familiar with Haskell, though not
- necessarily with JUnit. You can obtain HUnit, including this guide, at <a
- href="http://code.haskell.org/HUnit">http://code.haskell.org/HUnit</a>.</p>
-
- <h2>Introduction</h2>
-
- <p>A test-centered methodology for software development is most effective when tests are
- easy to create, change, and execute. The <a href="http://www.junit.org">JUnit</a> tool
- pioneered support for test-first development in <a href="http://java.sun.com">Java</a>.
- HUnit is an adaptation of JUnit to Haskell, a general-purpose, purely functional
- programming language. (To learn more about Haskell, see <a href="http://www.haskell.org"
- >http://www.haskell.org</a>.)</p>
-
- <p>With HUnit, as with JUnit, you can easily create tests, name them, group them into
- suites, and execute them, with the framework checking the results automatically. Test
- specification in HUnit is even more concise and flexible than in JUnit, thanks to the
- nature of the Haskell language. HUnit currently includes only a text-based test
- controller, but the framework is designed for easy extension. (Would anyone care to
- write a graphical test controller for HUnit?)</p>
-
- <p>The next section helps you get started using HUnit in simple ways. Subsequent sections
- give details on <a href="#WritingTests">writing tests</a> and <a href="#RunningTests"
- >running tests</a>. The document concludes with a section describing HUnit's <a
- href="#ConstituentFiles">constituent files</a> and a section giving <a
- href="#References">references</a> to further information.</p>
-
- <h2 id="GettingStarted">Getting Started</h2>
-
- <p>In the Haskell module where your tests will reside, import module <tt>Test.HUnit</tt>:</p>
- <pre>
- import Test.HUnit
-</pre>
- <p>Define test cases as appropriate:</p>
- <pre>
- test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))
- test2 = TestCase (do (x,y) <- partA 3
- assertEqual "for the first result of partA," 5 x
- b <- partB y
- assertBool ("(partB " ++ show y ++ ") failed") b)
-</pre>
- <p>Name the test cases and group them together:</p>
- <pre>
- tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]
-</pre>
- <p>Run the tests as a group. At a Haskell interpreter prompt, apply the function
- <tt>runTestTT</tt> to the collected tests. (The "<tt>TT</tt>" suggests
- <strong>T</strong>ext orientation with output to the <strong>T</strong>erminal.)</p>
- <pre>
- > runTestTT tests
- Cases: 2 Tried: 2 Errors: 0 Failures: 0
- >
-</pre>
- <p>If the tests are proving their worth, you might see:</p>
- <pre>
- > runTestTT tests
- ### Failure in: 0:test1
- for (foo 3),
- expected: (1,2)
- but got: (1,3)
- Cases: 2 Tried: 2 Errors: 0 Failures: 1
- >
-</pre>
- <p>Isn't that easy?</p>
-
- <p>You can specify tests even more succinctly using operators and overloaded functions that
- HUnit provides:</p>
- <pre>
- tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),
- "test2" ~: do (x, y) <- partA 3
- assertEqual "for the first result of partA," 5 x
- partB y @? "(partB " ++ show y ++ ") failed" ]
-</pre>
- <p>Assuming the same test failures as before, you would see:</p>
- <pre>
- > runTestTT tests
- ### Failure in: 0:test1:(foo 3)
- expected: (1,2)
- but got: (1,3)
- Cases: 2 Tried: 2 Errors: 0 Failures: 1
- >
-</pre>
-
- <h2 id="WritingTests">Writing Tests</h2>
-
- <p>Tests are specified compositionally. <a href="#Assertions">Assertions</a> are combined to
- make a <a href="#TestCase">test case</a>, and test cases are combined into <a
- href="#Tests">tests</a>. HUnit also provides <a href="#AdvancedFeatures">advanced
- features</a> for more convenient test specification.</p>
-
- <h3 id="Assertions">Assertions</h3>
-
- <p>The basic building block of a test is an <b>assertion</b>.</p>
- <pre>
- type Assertion = IO ()
-</pre>
- <p>An assertion is an <tt>IO</tt> computation that always produces a void result. Why is an
- assertion an <tt>IO</tt> computation? So that programs with real-world side effects can
- be tested. How does an assertion assert anything if it produces no useful result? The
- answer is that an assertion can signal failure by calling <tt>assertFailure</tt>.</p>
- <pre>
- assertFailure :: String -> Assertion
- assertFailure msg = ioError (userError ("HUnit:" ++ msg))
-</pre>
- <p><tt>(assertFailure msg)</tt> raises an exception. The string argument identifies the
- failure. The failure message is prefixed by "<tt>HUnit:</tt>" to mark it as an HUnit
- assertion failure message. The HUnit test framework interprets such an exception as
- indicating failure of the test whose execution raised the exception. (Note: The details
- concerning the implementation of <tt>assertFailure</tt> are subject to change and should
- not be relied upon.)</p>
-
- <p><tt>assertFailure</tt> can be used directly, but it is much more common to use it
- indirectly through other assertion functions that conditionally assert failure.</p>
- <pre>
- assertBool :: String -> Bool -> Assertion
- assertBool msg b = unless b (assertFailure msg)
-
- assertString :: String -> Assertion
- assertString s = unless (null s) (assertFailure s)
-
- assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion
- assertEqual preface expected actual =
- unless (actual == expected) (assertFailure msg)
- where msg = (if null preface then "" else preface ++ "\n") ++
- "expected: " ++ show expected ++ "\n but got: " ++ show actual
-</pre>
- <p>With <tt>assertBool</tt> you give the assertion condition and failure message separately.
- With <tt>assertString</tt> the two are combined. With <tt>assertEqual</tt> you provide a
- "preface", an expected value, and an actual value; the failure message shows the two
- unequal values and is prefixed by the preface. Additional ways to create assertions are
- described later under <a href="#AdvancedFeatures">Advanced Features</a>.</p>
-
- <p>Since assertions are <tt>IO</tt> computations, they may be combined--along with other
- <tt>IO</tt> computations--using <tt>(>>=)</tt>, <tt>(>>)</tt>, and the <tt>do</tt>
- notation. As long as its result is of type <tt>(IO ())</tt>, such a combination
- constitutes a single, collective assertion, incorporating any number of constituent
- assertions. The important features of such a collective assertion are that it fails if
- any of its constituent assertions is executed and fails, and that the first constituent
- assertion to fail terminates execution of the collective assertion. Such behavior is
- essential to specifying a test case.</p>
-
- <h3 id="TestCase">Test Case</h3>
-
- <p>A <b>test case</b> is the unit of test execution. That is, distinct test cases are
- executed independently. The failure of one is independent of the failure of any other.</p>
-
- <p>A test case consists of a single, possibly collective, assertion. The possibly multiple
- constituent assertions in a test case's collective assertion are <b>not</b> independent.
- Their interdependence may be crucial to specifying correct operation for a test. A test
- case may involve a series of steps, each concluding in an assertion, where each step
- must succeed in order for the test case to continue. As another example, a test may
- require some "set up" to be performed that must be undone ("torn down" in JUnit
- parlance) once the test is complete. In this case, you could use Haskell's
- <tt>IO.bracket</tt> function to achieve the desired effect.</p>
-
- <p>You can make a test case from an assertion by applying the <tt>TestCase</tt> constructor.
- For example, <tt>(TestCase (return ()))</tt> is a test case that never
- fails, and
- <tt>(TestCase (assertEqual "for x," 3 x))</tt>
- is a test case that checks that the value of <tt>x</tt> is 3. Additional ways
- to create test cases are described later under <a href="#AdvancedFeatures">Advanced
- Features</a>.</p>
-
- <h3 id="Tests">Tests</h3>
-
- <p>As soon as you have more than one test, you'll want to name them to tell them apart. As
- soon as you have more than several tests, you'll want to group them to process them more
- easily. So, naming and grouping are the two keys to managing collections of tests.</p>
-
- <p>In tune with the "composite" design pattern [<a href="#DesignPatterns">1</a>], a
- <b>test</b> is defined as a package of test cases. Concretely, a test is either a single
- test case, a group of tests, or either of the first two identified by a label.</p>
- <pre>
- data Test = TestCase Assertion
- | TestList [Test]
- | TestLabel String Test
-</pre>
- <p>There are three important features of this definition to note:</p>
- <ul>
- <li>A <tt>TestList</tt> consists of a list of tests rather than a list of test cases.
- This means that the structure of a <tt>Test</tt> is actually a tree. Using a
- hierarchy helps organize tests just as it helps organize files in a file system.</li>
- <li>A <tt>TestLabel</tt> is attached to a test rather than to a test case. This means
- that all nodes in the test tree, not just test case (leaf) nodes, can be labeled.
- Hierarchical naming helps organize tests just as it helps organize files in a file
- system.</li>
- <li>A <tt>TestLabel</tt> is separate from both <tt>TestCase</tt> and <tt>TestList</tt>.
- This means that labeling is optional everywhere in the tree. Why is this a good
- thing? Because of the hierarchical structure of a test, each constituent test case
- is uniquely identified by its path in the tree, ignoring all labels. Sometimes a
- test case's path (or perhaps its subpath below a certain node) is a perfectly
- adequate "name" for the test case (perhaps relative to a certain node). In this
- case, creating a label for the test case is both unnecessary and inconvenient.</li>
- </ul>
- <p>The number of test cases that a test comprises can be computed with
- <tt>testCaseCount</tt>.</p>
- <pre>
- testCaseCount :: Test -> Int
-</pre>
- <p>As mentioned above, a test is identified by its <b>path</b> in the test hierarchy.</p>
- <pre>
- data Node = ListItem Int | Label String
- deriving (Eq, Show, Read)
-
- type Path = [Node] -- Node order is from test case to root.
-</pre>
- <p>Each occurrence of <tt>TestList</tt> gives rise to a <tt>ListItem</tt> and each
- occurrence of <tt>TestLabel</tt> gives rise to a <tt>Label</tt>. The <tt>ListItem</tt>s
- by themselves ensure uniqueness among test case paths, while the <tt>Label</tt>s allow
- you to add mnemonic names for individual test cases and collections of them.</p>
-
- <p>Note that the order of nodes in a path is reversed from what you might expect: The first
- node in the list is the one deepest in the tree. This order is a concession to
- efficiency: It allows common path prefixes to be shared.</p>
-
- <p>The paths of the test cases that a test comprises can be computed with
- <tt>testCasePaths</tt>. The paths are listed in the order in which the corresponding
- test cases would be executed.</p>
- <pre>
- testCasePaths :: Test -> [Path]
-</pre>
-
- <p>The three variants of <tt>Test</tt> can be constructed simply by applying
- <tt>TestCase</tt>, <tt>TestList</tt>, and <tt>TestLabel</tt> to appropriate arguments.
- Additional ways to create tests are described later under <a href="#AdvancedFeatures"
- >Advanced Features</a>.</p>
-
- <p>The design of the type <tt>Test</tt> provides great conciseness, flexibility, and
- convenience in specifying tests. Moreover, the nature of Haskell significantly augments
- these qualities:</p>
- <ul>
- <li>Combining assertions and other code to construct test cases is easy with the
- <tt>IO</tt> monad.</li>
- <li>Using overloaded functions and special operators (see below), specification of
- assertions and tests is extremely compact.</li>
- <li>Structuring a test tree by value, rather than by name as in JUnit, provides for more
- convenient, flexible, and robust test suite specification. In particular, a test
- suite can more easily be computed "on the fly" than in other test frameworks.</li>
- <li>Haskell's powerful abstraction facilities provide unmatched support for test
- refactoring.</li>
- </ul>
-
- <h3 id="AdvancedFeatures">Advanced Features</h3>
-
- <p>HUnit provides additional features for specifying assertions and tests more conveniently
- and concisely. These facilities make use of Haskell type classes.</p>
-
- <p>The following operators can be used to construct assertions.</p>
- <pre>
- infix 1 @?, @=?, @?=
-
- (@?) :: (AssertionPredicable t) => t -> String -> Assertion
- pred @? msg = assertionPredicate pred >>= assertBool msg
-
- (@=?) :: (Eq a, Show a) => a -> a -> Assertion
- expected @=? actual = assertEqual "" expected actual
-
- (@?=) :: (Eq a, Show a) => a -> a -> Assertion
- actual @?= expected = assertEqual "" expected actual
-</pre>
- <p>You provide a boolean condition and failure message separately to <tt>(@?)</tt>, as for
- <tt>assertBool</tt>, but in a different order. The <tt>(@=?)</tt> and <tt>(@?=)</tt>
- operators provide shorthands for <tt>assertEqual</tt> when no preface is required. They
- differ only in the order in which the expected and actual values are provided. (The
- actual value--the uncertain one--goes on the "?" side of the operator.)</p>
-
- <p>The <tt>(@?)</tt> operator's first argument is something from which an assertion
- predicate can be made, that is, its type must be <tt>AssertionPredicable</tt>.</p>
- <pre>
- type AssertionPredicate = IO Bool
-
- class AssertionPredicable t
- where assertionPredicate :: t -> AssertionPredicate
-
- instance AssertionPredicable Bool
- where assertionPredicate = return
-
- instance (AssertionPredicable t) => AssertionPredicable (IO t)
- where assertionPredicate = (>>= assertionPredicate)
-</pre>
- <p>The overloaded <tt>assert</tt> function in the <tt>Assertable</tt> type class constructs
- an assertion.</p>
- <pre>
- class Assertable t
- where assert :: t -> Assertion
-
- instance Assertable ()
- where assert = return
-
- instance Assertable Bool
- where assert = assertBool ""
-
- instance (ListAssertable t) => Assertable [t]
- where assert = listAssert
-
- instance (Assertable t) => Assertable (IO t)
- where assert = (>>= assert)
-</pre>
- <p>The <tt>ListAssertable</tt> class allows <tt>assert</tt> to be applied to <tt>[Char]</tt>
- (that is, <tt>String</tt>).</p>
- <pre>
- class ListAssertable t
- where listAssert :: [t] -> Assertion
-
- instance ListAssertable Char
- where listAssert = assertString
-</pre>
- <p>With the above declarations, <tt>(assert ())</tt>,
- <tt>(assert True)</tt>, and <tt>(assert "")</tt> (as well as
- <tt>IO</tt> forms of these values, such as <tt>(return ())</tt>) are all
- assertions that never fail, while <tt>(assert False)</tt> and
- <tt>(assert "some failure message")</tt> (and their
- <tt>IO</tt> forms) are assertions that always fail. You may define additional
- instances for the type classes <tt>Assertable</tt>, <tt>ListAssertable</tt>, and
- <tt>AssertionPredicable</tt> if that should be useful in your application.</p>
-
- <p>The overloaded <tt>test</tt> function in the <tt>Testable</tt> type class constructs a
- test.</p>
- <pre>
- class Testable t
- where test :: t -> Test
-
- instance Testable Test
- where test = id
-
- instance (Assertable t) => Testable (IO t)
- where test = TestCase . assert
-
- instance (Testable t) => Testable [t]
- where test = TestList . map test
-</pre>
- <p>The <tt>test</tt> function makes a test from either an <tt>Assertion</tt> (using
- <tt>TestCase</tt>), a list of <tt>Testable</tt> items (using <tt>TestList</tt>), or
- a <tt>Test</tt> (making no change).</p>
-
- <p>The following operators can be used to construct tests.</p>
- <pre>
- infix 1 ~?, ~=?, ~?=
- infixr 0 ~:
-
- (~?) :: (AssertionPredicable t) => t -> String -> Test
- pred ~? msg = TestCase (pred @? msg)
-
- (~=?) :: (Eq a, Show a) => a -> a -> Test
- expected ~=? actual = TestCase (expected @=? actual)
-
- (~?=) :: (Eq a, Show a) => a -> a -> Test
- actual ~?= expected = TestCase (actual @?= expected)
-
- (~:) :: (Testable t) => String -> t -> Test
- label ~: t = TestLabel label (test t)
-</pre>
- <p><tt>(~?)</tt>, <tt>(~=?)</tt>, and <tt>(~?=)</tt> each make an assertion, as for
- <tt>(@?)</tt>, <tt>(@=?)</tt>, and <tt>(@?=)</tt>, respectively, and then a test case
- from that assertion. <tt>(~:)</tt> attaches a label to something that is
- <tt>Testable</tt>. You may define additional instances for the type class
- <tt>Testable</tt> should that be useful.</p>
-
- <h2 id="RunningTests">Running Tests</h2>
-
- <p>HUnit is structured to support multiple test controllers. The first subsection below
- describes the <a href="#TestExecution">test execution</a> characteristics common to all
- test controllers. The second subsection describes the <a href="#Text-BasedController"
- >text-based controller</a> that is included with HUnit.</p>
-
- <h3 id="TestExecution">Test Execution</h3>
-
- <p>All test controllers share a common test execution model. They differ only in how the
- results of test execution are shown.</p>
-
- <p>The execution of a test (a value of type <tt>Test</tt>) involves the serial execution (in
- the <tt>IO</tt> monad) of its constituent test cases. The test cases are executed in a
- depth-first, left-to-right order. During test execution, four counts of test cases are
- maintained:</p>
- <pre>
- data Counts = Counts { cases, tried, errors, failures :: Int }
- deriving (Eq, Show, Read)
-</pre>
- <ul>
- <li><tt>cases</tt> is the number of test cases included in the test. This number is a
- static property of a test and remains unchanged during test execution.</li>
- <li><tt>tried</tt> is the number of test cases that have been executed so far during the
- test execution.</li>
- <li><tt>errors</tt> is the number of test cases whose execution ended with an unexpected
- exception being raised. Errors indicate problems with test cases, as opposed to the
- code under test.</li>
- <li><tt>failures</tt> is the number of test cases whose execution asserted failure.
- Failures indicate problems with the code under test.</li>
- </ul>
- <p>Why is there no count for test case successes? The technical reason is that the counts
- are maintained such that the number of test case successes is always equal to
- <tt>(tried - (errors + failures))</tt>. The
- psychosocial reason is that, with test-centered development and the expectation that
- test failures will be few and short-lived, attention should be focused on the failures
- rather than the successes.</p>
-
- <p>As test execution proceeds, three kinds of reporting event are communicated to the test
- controller. (What the controller does in response to the reporting events depends on the
- controller.)</p>
- <ul>
- <li><i>start</i> -- Just prior to initiation of a test case, the path of the test case
- and the current counts (excluding the current test case) are reported.</li>
- <li><i>error</i> -- When a test case terminates with an error, the error message is
- reported, along with the test case path and current counts (including the current
- test case).</li>
- <li><i>failure</i> -- When a test case terminates with a failure, the failure message is
- reported, along with the test case path and current counts (including the current
- test case).</li>
- </ul>
- <p>Typically, a test controller shows <i>error</i> and <i>failure</i> reports immediately
- but uses the <i>start</i> report merely to update an indication of overall test
- execution progress.</p>
-
- <h3 id="Text-BasedController">Text-Based Controller</h3>
-
- <p>A text-based test controller is included with HUnit.</p>
- <pre>
- runTestText :: PutText st -> Test -> IO (Counts, st)
-</pre>
- <p><tt>runTestText</tt> is generalized on a <i>reporting scheme</i> given as its first
- argument. During execution of the test given as its second argument, the controller
- creates a string for each reporting event and processes it according to the reporting
- scheme. When test execution is complete, the controller returns the final counts along
- with the final state for the reporting scheme.</p>
-
- <p>The strings for the three kinds of reporting event are as follows.</p>
- <ul>
- <li>A <i>start</i> report is the result of the function <tt>showCounts</tt> applied to
- the counts current immediately prior to initiation of the test case being started.</li>
- <li>An <i>error</i> report is of the form
- "<tt>Error in: <i>path</i>\n<i>message</i></tt>",
- where <i>path</i> is the path of the test case in error, as shown by
- <tt>showPath</tt>, and <i>message</i> is a message describing the error. If the path
- is empty, the report has the form "<tt>Error:\n<i>message</i></tt>".</li>
- <li>A <i>failure</i> report is of the form
- "<tt>Failure in: <i>path</i>\n<i>message</i></tt>", where
- <i>path</i> is the path of the test case in error, as shown by
- <tt>showPath</tt>, and <i>message</i> is the failure message. If the path is empty,
- the report has the form "<tt>Failure:\n<i>message</i></tt>".</li>
- </ul>
-
- <p>The function <tt>showCounts</tt> shows a set of counts.</p>
- <pre>
- showCounts :: Counts -> String
-</pre>
- <p>The form of its result is
- "<tt>Cases: <i>cases</i> Tried: <i>tried</i> Errors: <i>errors</i> Failures: <i>failures</i></tt>"
- where <i>cases</i>, <i>tried</i>, <i>errors</i>, and <i>failures</i> are the count
- values.</p>
-
- <p>The function <tt>showPath</tt> shows a test case path.</p>
- <pre>
- showPath :: Path -> String
-</pre>
- <p>The nodes in the path are reversed (so that the path reads from the root down to the test
- case), and the representations for the nodes are joined by '<tt>:</tt>' separators. The
- representation for <tt>(ListItem <i>n</i>)</tt> is <tt>(show n)</tt>. The representation
- for <tt>(Label <i>label</i>)</tt> is normally <i>label</i>. However, if <i>label</i>
- contains a colon or if <tt>(show <i>label</i>)</tt> is different from <i>label</i>
- surrounded by quotation marks--that is, if any ambiguity could exist--then <tt>(Label
- <i>label</i>)</tt> is represented as <tt>(show <i>label</i>)</tt>.</p>
-
- <p>HUnit includes two reporting schemes for the text-based test controller. You may define
- others if you wish.</p>
- <pre>
- putTextToHandle :: Handle -> Bool -> PutText Int
-</pre>
- <p><tt>putTextToHandle</tt> writes error and failure reports, plus a report of the final
- counts, to the given handle. Each of these reports is terminated by a newline. In
- addition, if the given flag is <tt>True</tt>, it writes start reports to the handle as
- well. A start report, however, is not terminated by a newline. Before the next report is
- written, the start report is "erased" with an appropriate sequence of carriage return
- and space characters. Such overwriting realizes its intended effect on terminal devices.</p>
- <pre>
- putTextToShowS :: PutText ShowS
-</pre>
- <p><tt>putTextToShowS</tt> ignores start reports and simply accumulates error and failure
- reports, terminating them with newlines. The accumulated reports are returned (as the
- second element of the pair returned by <tt>runTestText</tt>) as a <tt>ShowS</tt>
- function (that is, one with type <tt>(String -> String)</tt>) whose
- first argument is a string to be appended to the accumulated report lines.</p>
-
- <p>HUnit provides a shorthand for the most common use of the text-based test controller.</p>
- <pre>
- runTestTT :: Test -> IO Counts
-</pre>
- <p><tt>runTestTT</tt> invokes <tt>runTestText</tt>, specifying <tt>(putTextToHandle stderr
- True)</tt> for the reporting scheme, and returns the final counts from the test
- execution.</p>
-
-
- <h2 id="References">References</h2>
-
- <dl>
-
- <dt id="DesignPatterns">[1] Gamma, E., et al. Design Patterns: Elements of Reusable
- Object-Oriented Software, Addison-Wesley, Reading, MA, 1995.</dt>
- <dd>The classic book describing design patterns in an object-oriented context.</dd>
-
- <dt>
- <a href="http://www.junit.org">http://www.junit.org</a>
- </dt>
- <dd>Web page for JUnit, the tool after which HUnit is modeled.</dd>
-
- <dt>
- <a href="http://junit.sourceforge.net/doc/testinfected/testing.htm">
- http://junit.sourceforge.net/doc/testinfected/testing.htm</a>
- </dt>
- <dd>A good introduction to test-first development and the use of JUnit.</dd>
-
- <dt>
- <a href="http://junit.sourceforge.net/doc/cookstour/cookstour.htm">
- http://junit.sourceforge.net/doc/cookstour/cookstour.htm</a>
- </dt>
- <dd>A description of the internal structure of JUnit. Makes for an interesting
- comparison between JUnit and HUnit.</dd>
-
- </dl>
-
- <hr/>
-
- <p>The HUnit software and this guide were written by Dean Herington (<a
- href="mailto:heringto@cs.unc.edu">heringto(a)cs.unc.edu</a>).</p>
- </body>
-</html>
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/examples/Example.hs new/HUnit-1.3.1.1/examples/Example.hs
--- old/HUnit-1.3.1.0/examples/Example.hs 2016-01-11 10:04:20.000000000 +0100
+++ new/HUnit-1.3.1.1/examples/Example.hs 2016-01-19 17:16:50.000000000 +0100
@@ -1,9 +1,9 @@
-- Example.hs -- Examples from HUnit user's guide
--
-- For more examples, check out the tests directory. It contains unit tests
--- for HUnit.
+-- for HUnit.
-module Main where
+module Example where
import Test.HUnit
@@ -36,5 +36,5 @@
partB y @? "(partB " ++ show y ++ ") failed" ]
main :: IO Counts
-main = do runTestTT tests
+main = do _ <- runTestTT tests
runTestTT tests'
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/prologue.txt new/HUnit-1.3.1.1/prologue.txt
--- old/HUnit-1.3.1.0/prologue.txt 2016-01-11 10:04:20.000000000 +0100
+++ new/HUnit-1.3.1.1/prologue.txt 1970-01-01 01:00:00.000000000 +0100
@@ -1,2 +0,0 @@
-HUnit is a unit testing framework for Haskell, inspired by the JUnit
-tool for Java, see: <http://www.junit.org>.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HUnit-1.3.1.0/tests/HUnitTests.hs new/HUnit-1.3.1.1/tests/HUnitTests.hs
--- old/HUnit-1.3.1.0/tests/HUnitTests.hs 2016-01-11 10:04:20.000000000 +0100
+++ new/HUnit-1.3.1.1/tests/HUnitTests.hs 2016-01-19 17:16:50.000000000 +0100
@@ -10,6 +10,7 @@
import HUnitTestBase
import HUnitTestExtended
import TerminalTest
+import Example ()
main :: IO ()
main = do
1
0