January 2016 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-pipes for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-profunctors for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-optparse-applicative for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-OpenGLRaw for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-MonadRandom for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-mono-traversable for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-memory for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-lifted-async for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-JuicyPixels for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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

commit ghc-HUnit for openSUSE:Factory
by root＠hilbert.suse.de 28 Jan '16

28 Jan '16

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> - - 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>. - - <h2>Introduction</h2> - - 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>.) - - 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 <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. - - <h2 id="GettingStarted">Getting Started</h2> - - In the Haskell module where your tests will reside, import module <tt>Test.HUnit</tt>: - <pre> - import Test.HUnit -</pre> - Define test cases as appropriate: - <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> - Name the test cases and group them together: - <pre> - tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2] -</pre> - 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 - Text orientation with output to the Terminal.) - <pre> - > runTestTT tests - Cases: 2 Tried: 2 Errors: 0 Failures: 0 - > -</pre> - If the tests are proving their worth, you might see: - <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> - Isn't that easy? - - You can specify tests even more succinctly using operators and overloaded functions that - HUnit provides: - <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> - Assuming the same test failures as before, you would see: - <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> - - 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. - - <h3 id="Assertions">Assertions</h3> - - The basic building block of a test is an assertion. - <pre> - type Assertion = IO () -</pre> - 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>. - <pre> - assertFailure :: String -> Assertion - assertFailure msg = ioError (userError ("HUnit:" ++ msg)) -</pre> - <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.) - - <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. - <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> - 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>. - - 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. - - <h3 id="TestCase">Test Case</h3> - - 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 - <tt>IO.bracket</tt> function to achieve the desired effect. - - 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>. - - <h3 id="Tests">Tests</h3> - - 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 [<a href="#DesignPatterns">1</a>], 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. - <pre> - data Test = TestCase Assertion - | TestList [Test] - | TestLabel String Test -</pre> - There are three important features of this definition to note: - <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> - The number of test cases that a test comprises can be computed with - <tt>testCaseCount</tt>. - <pre> - testCaseCount :: Test -> Int -</pre> - As mentioned above, a test is identified by its path in the test hierarchy. - <pre> - data Node = ListItem Int | Label String - deriving (Eq, Show, Read) - - type Path = [Node] -- Node order is from test case to root. -</pre> - 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. - - 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 - <tt>testCasePaths</tt>. The paths are listed in the order in which the corresponding - test cases would be executed. - <pre> - testCasePaths :: Test -> [Path] -</pre> - - 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>. - - 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: - <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> - - 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. - <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> - 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.) - - 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>. - <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> - The overloaded <tt>assert</tt> function in the <tt>Assertable</tt> type class constructs - an assertion. - <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> - The <tt>ListAssertable</tt> class allows <tt>assert</tt> to be applied to <tt>[Char]</tt> - (that is, <tt>String</tt>). - <pre> - class ListAssertable t - where listAssert :: [t] -> Assertion - - instance ListAssertable Char - where listAssert = assertString -</pre> - 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. - - The overloaded <tt>test</tt> function in the <tt>Testable</tt> type class constructs a - test. - <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> - 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). - - The following operators can be used to construct tests. - <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> - <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. - - <h2 id="RunningTests">Running Tests</h2> - - 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. - - <h3 id="TestExecution">Test Execution</h3> - - 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 <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: - <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> - 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. - - 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.) - <ul> - <li>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.</li> - <li>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).</li> - <li>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).</li> - </ul> - 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. - - <h3 id="Text-BasedController">Text-Based Controller</h3> - - A text-based test controller is included with HUnit. - <pre> - runTestText :: PutText st -> Test -> IO (Counts, st) -</pre> - <tt>runTestText</tt> 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. - <ul> - <li>A start 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 error report is of the form - "<tt>Error in:   path\nmessage</tt>", - where path is the path of the test case in error, as shown by - <tt>showPath</tt>, and message is a message describing the error. If the path - is empty, the report has the form "<tt>Error:\nmessage</tt>".</li> - <li>A failure report is of the form - "<tt>Failure in: path\nmessage</tt>", where - path is the path of the test case in error, as shown by - <tt>showPath</tt>, and message is the failure message. If the path is empty, - the report has the form "<tt>Failure:\nmessage</tt>".</li> - </ul> - - The function <tt>showCounts</tt> shows a set of counts. - <pre> - showCounts :: Counts -> String -</pre> - The form of its result is - "<tt>Cases: cases  Tried: tried  Errors: errors  Failures: failures</tt>" - where cases, tried, errors, and failures are the count - values. - - The function <tt>showPath</tt> shows a test case path. - <pre> - showPath :: Path -> String -</pre> - 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 n)</tt> is <tt>(show n)</tt>. The representation - for <tt>(Label label)</tt> is normally label. However, if label - contains a colon or if <tt>(show label)</tt> is different from label - surrounded by quotation marks--that is, if any ambiguity could exist--then <tt>(Label - label)</tt> is represented as <tt>(show label)</tt>. - - HUnit includes two reporting schemes for the text-based test controller. You may define - others if you wish. - <pre> - putTextToHandle :: Handle -> Bool -> PutText Int -</pre> - <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. - <pre> - putTextToShowS :: PutText ShowS -</pre> - <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. - - HUnit provides a shorthand for the most common use of the text-based test controller. - <pre> - runTestTT :: Test -> IO Counts -</pre> - <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. - - - <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/> - - The HUnit software and this guide were written by Dean Herington (<a - href="mailto:heringto@cs.unc.edu">heringto(a)cs.unc.edu</a>). - </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