August 2017 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-glazier for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-glazier for openSUSE:Factory checked in at 2017-08-31 20:51:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-glazier (Old) and /work/SRC/openSUSE:Factory/.ghc-glazier.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-glazier" Thu Aug 31 20:51:13 2017 rev:2 rq:513256 version:0.11.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-glazier/ghc-glazier.changes 2017-04-14 13:35:22.899228755 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-glazier.new/ghc-glazier.changes 2017-08-31 20:51:15.303314673 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:57 UTC 2017 - psimons(a)suse.com + +- Update to version 0.11.0.1. + +------------------------------------------------------------------- Old: ---- glazier-0.7.0.0.tar.gz New: ---- glazier-0.11.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-glazier.spec ++++++ --- /var/tmp/diff_new_pack.byzkDO/_old 2017-08-31 20:51:17.539000846 +0200 +++ /var/tmp/diff_new_pack.byzkDO/_new 2017-08-31 20:51:17.539000846 +0200 @@ -18,9 +18,9 @@ %global pkg_name glazier Name: ghc-%{pkg_name} -Version: 0.7.0.0 +Version: 0.11.0.1 Release: 0 -Summary: Composable widgets framework +Summary: Composable widgets framework with enhanced with transformers and lens License: BSD-3-Clause Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} @@ -29,7 +29,6 @@ BuildRequires: ghc-lens-devel BuildRequires: ghc-mmorph-devel BuildRequires: ghc-mtl-devel -BuildRequires: ghc-profunctors-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-semigroupoids-devel BuildRequires: ghc-transformers-devel ++++++ glazier-0.7.0.0.tar.gz -> glazier-0.11.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/glazier.cabal new/glazier-0.11.0.1/glazier.cabal --- old/glazier-0.7.0.0/glazier.cabal 2017-02-02 11:07:44.000000000 +0100 +++ new/glazier-0.11.0.1/glazier.cabal 2017-03-13 23:10:19.000000000 +0100 @@ -1,36 +1,30 @@ name: glazier -version: 0.7.0.0 -synopsis: Composable widgets framework -description: Please see README.md +version: 0.11.0.1 +synopsis: Composable widgets framework with enhanced with transformers and lens. +description: Elm-like Action/Model/View/Update framework powered by typeclasses, monad transformers, and lens. homepage: https://github.com/louispan/glazier#readme license: BSD3 license-file: LICENSE author: Louis Pan maintainer: louis(a)pan.me copyright: 2016 Louis Pan -category: FRP +category: FRP, GUI build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.0.1 library hs-source-dirs: src - exposed-modules: Glazier - Glazier.Class - Glazier.Example - Glazier.Gadget.Lazy - Glazier.Gadget.Strict - Glazier.Widget.Lazy - Glazier.Widget.Strict - Glazier.Window - build-depends: base >= 4.7 && < 5 - , lens >= 4 && < 5 - , mmorph >= 1 && < 2 - , mtl >= 2 && <3 - , semigroupoids >= 5 && < 6 - , transformers >= 0.4 && < 0.6 - , profunctors >= 5 && < 6 - ghc-options: -Wall + exposed-modules: Glazier + Glazier.Gadget + Glazier.Window + build-depends: base >= 4.7 && < 5 + , lens >= 4 && < 5 + , mmorph >= 1 && < 2 + , mtl >= 2 && <3 + , semigroupoids >= 5 && < 6 + , transformers >= 0.4 && < 0.6 + ghc-options: -Wall default-language: Haskell2010 source-repository head diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Class.hs new/glazier-0.11.0.1/src/Glazier/Class.hs --- old/glazier-0.7.0.0/src/Glazier/Class.hs 2017-02-02 11:02:17.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Class.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,20 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module Glazier.Class where - -import Control.Lens - --- | Modify the state given a lens, prism or traversal. --- NB. This is 'Control.Lens.Zoom' for Notify. -type family Implanted m :: * -> * -class Implant m n s t | m -> s, n -> t, m t -> n, n s -> m where - implant :: LensLike' (Implanted m) t s -> m -> n - -------------------------------------------------------------------------------- -type family Dispatched m :: * -> * - --- | Changes the action type given a lens, prism or traversal -class Dispatch m n b a | m -> b, n -> a, m a -> n, n b -> m where - dispatch :: LensLike' (Dispatched m) a b -> m -> n diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Example.hs new/glazier-0.11.0.1/src/Glazier/Example.hs --- old/glazier-0.7.0.0/src/Glazier/Example.hs 2017-02-02 11:07:21.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Example.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,165 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | This contains examples of general widget transformation functions. -module Glazier.Example where - -import Control.Category -import Control.Lens -import Control.Monad.Reader -import Data.Foldable -import Data.List -import Data.Semigroup -import Glazier -import Prelude hiding (id, (.)) - -newtype Action a = Action { getAction :: a } -class AsAction s a | s -> a where - _Action :: Prism' s (Action a) -instance AsAction (Action a) a where - _Action = id - -newtype ConsAction a = ConsAction { getConsAction :: a } -class AsConsAction s a | s -> a where - _ConsAction :: Prism' s (ConsAction a) -instance AsConsAction (ConsAction a) a where - _ConsAction = id - -data Reset = Reset -class AsReset s where - _Reset :: Prism' s Reset -instance AsReset Reset where - _Reset = id - -data Tail = Tail -class AsTail s where - _Tail :: Prism' s Tail -instance AsTail Tail where - _Tail = id - -newtype Set a = Set { getSet :: a } -class AsSet s a | s -> a where - _Set :: Prism' s (Set a) -instance AsSet (Set a) a where - _Set = id - --- | Transforms a widget into an optional widget. --- This wraps the original model inside a Maybe. --- The new action is now a sum type that contains the additional actions: --- * A Reset action --- * A Set action --- * A mapping action --- * The original action --- The original action is wrapped using the given prism and will only --- modify the state if the preview of the prism is not Nothing. --- The view will be mempty if the model is Nothing. --- Widget was a w s m c v --- Widget s v m a c -optionalExample :: - ( Monoid v - , Monoid c - , Semigroup v - , Semigroup c - , AsSet a s - , AsReset a - , AsAction a (Maybe s -> Maybe s) - , Monad m - ) - => Prism' a a' -> Widget s v m a' c -> Widget (Maybe s) v m a c -optionalExample p w = - ( - implant _Just -- original update will only work if model is Just - >>> dispatch p -- make original action part of a smaller action, in preparation of adding other actions below - ) w - <> statically mempty -- change mempty to specify a rendering function when Nothing - <> dynamically - ( dispatch _Set (review _Gadget $ \a _ -> pure (mempty,Just $ getSet a)) - <> dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s)) - <> dispatch _Reset (review _Gadget $ \_ _ -> pure (mempty, Nothing)) - ) - --- | Transforms a widget into an list widget. --- Given a separator rendering widget, and a widget, --- this wraps the original model inside a list. --- The new action is now a sum type that contains the additional actions: --- * A Tail action --- * A Cons action --- * A mapping action --- * The original action --- The original action is wrapped using the given prism and will only --- modify the state of the head. --- The view will be mempty if Nil. -listExample :: - ( Monoid v - , Monoid c - , Semigroup v - , Semigroup c - , AsTail a - , AsConsAction a s - , AsAction a ([s] -> [s]) - , Monad m - ) - => Prism' b a -> Widget s v m a c -> Widget [s] v m b c -listExample p (Widget (Window d) u) = - -- Create a list rendering function by - -- interspercing the separator with the View from the original widget. - statically (Window . ReaderT $ \ss -> do - ss' <- traverse (runReaderT d) ss - pure (fold $ intersperse separator ss')) - <> dynamically - ( implant (ix 0) u -- original update will only work on the head of list - <> dispatch _Tail (review _Gadget $ \_ s -> pure (mempty, tail s)) - <> dispatch _ConsAction (review _Gadget $ \(ConsAction a) s -> pure (mempty, a : s)) - <> dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s)) - ) - & dispatch p -- make original action part of a smaller action - where separator = mempty -- change mempty to specify a rendering function - --- | Transforms a widget into an dictionary widget. --- Given a ordering function, a key function, and a separator rendering function, --- allows a dictionary of k to Widget. --- The new action is now a sum type that contains the additional actions: --- * A mapping action --- * A tuple of (key, original action) --- The original action is now a tuple with an additional key, which will act on the widget if the key exists in the map. -indexedExample :: - ( Monoid v - , Monoid c - , Field2 b b a a - , Field1 b b (Index (t s)) (Index (t s)) - , Ixed (t s) - , Semigroup v - , Semigroup c - , AsAction b (t s -> t s) - , IxValue (t s) ~ s - , Monad m - , Traversable t - ) - => Widget s v m a c -> Widget (t s) v m b c -indexedExample (Widget (Window d) g) = - -- Create a rendering function by folding the original view function - statically (Window . ReaderT $ \ss -> do - ss' <- traverse (runReaderT d) ss - pure (fold ss')) - <> - dynamically - ( - -- This effectively dispatches the Update - -- ie the action type has changed - -- so a @dispatch prism@ is not required - (do - x <- ask - let k = x ^. _1 - -- a = x ^. _2 - -- run u but for a state implanted by ix k - zoom (ix k) (magnify _2 g) - ) - <> - dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s)) - ) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Gadget/Lazy.hs new/glazier-0.11.0.1/src/Glazier/Gadget/Lazy.hs --- old/glazier-0.7.0.0/src/Glazier/Gadget/Lazy.hs 2017-02-02 11:05:42.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Gadget/Lazy.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,173 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Glazier.Gadget.Lazy where - -import Control.Applicative -import Control.Arrow -import qualified Control.Category as C -import Control.Lens -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix (MonadFix) -import Control.Monad.Morph -import Control.Monad.Reader -import Control.Monad.State.Lazy -import Data.Profunctor -import Data.Semigroup -import Glazier.Class - --- | The Elm update function is @a -> s -> (s, c)@ --- This is isomorphic to @ReaderT a (State s) c@ --- ie, given an action "a", and a current state "s", return the new state "s" --- and any commands "c" that need to be interpreted externally (eg. download file). --- This is named Gadget instead of Update to avoid confusion with update from Data.Map -newtype Gadget s m a c = Gadget - { runGadget :: ReaderT a (StateT s m) c - } deriving ( MonadState s - , MonadReader a - , Monad - , Applicative - , Functor - , Fail.MonadFail - , Alternative - , MonadPlus - , MonadFix - , MonadIO - ) - -class HasGadget s a | s -> a where - gadget :: Lens' s a - -instance HasGadget (Gadget s m a c) (Gadget s m a c) where - gadget = id - -makeWrapped ''Gadget - --- | NB lift can be simulated: --- liftGadget :: (MonadTrans t, Monad m) => Gadget s m a c -> Gadget s (t m) a c --- liftGadget = _Wrapping Gadget %~ hoist (hoist lift) -hoistGadget :: (Monad m) => (forall b. m b -> n b) -> Gadget s m a c -> Gadget s n a c -hoistGadget g = _Wrapping Gadget %~ hoist (hoist g) -{-# INLINABLE hoistGadget #-} - --- | This Iso gives the following functions: --- --- @ --- underGadget :: (ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c') -> Gadget s m a c -> Gadget s' m' a' c' --- underGadget f = _Wrapping Gadget %~ f --- --- overGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c' --- overGadget f = _Unwrapping Gadget %~ f --- --- belowGadget :: (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) -> Gadget s m a c -> Gadget s' m' a' c' --- belowGadget f = _Gadget %~ f --- --- aboveGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) --- aboveGadget f = from _Gadget %~ f --- --- mkGadget' :: (a -> s -> m (c, s)) -> Gadget s m a c --- mkGadget' = review _Gadget --- --- runGadget' :: Gadget s m a c -> (a -> s -> m (c, s)) --- runGadget' = view _Gadget --- @ --- -_Gadget :: Iso (Gadget s m a c) (Gadget s' m' a' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) -_Gadget = _Wrapping Gadget . iso runReaderT ReaderT . iso (runStateT .) (StateT .) -{-# INLINABLE _Gadget #-} - --- | Non polymorphic version of _Gadget -_Gadget' :: Iso' (Gadget s m a c) (a -> s -> m (c, s)) -_Gadget' = _Gadget -{-# INLINABLE _Gadget' #-} - -instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where - (Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g - {-# INLINABLE (<>) #-} - -instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where - mempty = Gadget $ pure mempty - {-# INLINABLE mempty #-} - - (Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g - {-# INLINABLE mappend #-} - -instance Monad m => Profunctor (Gadget s m) where - dimap f g (Gadget (ReaderT m)) = Gadget $ ReaderT $ \a -> StateT $ \s -> undefined - (first g) <$> runStateT (m (f a)) s - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Gadget s m) where - first' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \(b, d) -> StateT $ \s -> - (\(c, s') -> ((c, d), s')) <$> runStateT (bc b) s - {-# INLINABLE first' #-} - -instance Monad m => C.Category (Gadget s m) where - id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s) - {-# INLINABLE id #-} - - Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do - -- This line is the main difference between Strict and Lazy versions - ~(b, s') <- runStateT (ab a) s - runStateT (bc b) s' - {-# INLINABLE (.) #-} - -instance Monad m => Arrow (Gadget s m) where - arr f = dimap f id C.id - {-# INLINABLE arr #-} - - first = first' - {-# INLINABLE first #-} - -instance Monad m => Choice (Gadget s m) where - left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of - Left b -> do - -- This line is the main difference between Strict and Lazy versions - ~(c, s') <- runStateT (bc b) s - pure (Left c, s') - Right d -> pure (Right d, s) - {-# INLINABLE left' #-} - -instance Monad m => ArrowChoice (Gadget s m) where - left = left' - {-# INLINABLE left #-} - -instance Monad m => ArrowApply (Gadget s m) where - app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s - {-# INLINABLE app #-} - -instance MonadPlus m => ArrowZero (Gadget s m) where - zeroArrow = Gadget mzero - {-# INLINABLE zeroArrow #-} - -instance MonadPlus m => ArrowPlus (Gadget s m) where - Gadget a <+> Gadget b = Gadget (a `mplus` b) - {-# INLINABLE (<+>) #-} - --- | zoom can be used to modify the state inside an Gadget -type instance Zoomed (Gadget s m a) = Zoomed (StateT s m) -instance Monad m => Zoom (Gadget s m a) (Gadget t m a) s t where - zoom l = Gadget . zoom l . runGadget - {-# INLINABLE zoom #-} - --- | magnify can be used to modify the action inside an Gadget -type instance Magnified (Gadget s m a) = Magnified (ReaderT a (StateT s m)) -instance Monad m => Magnify (Gadget s m a) (Gadget s m b) a b where - magnify l = Gadget . magnify l . runGadget - {-# INLINABLE magnify #-} - -type instance Implanted (Gadget s m a c) = Zoomed (Gadget s m a) c -instance Monad m => Implant (Gadget s m a c) (Gadget t m a c) s t where - implant = zoom - {-# INLINABLE implant #-} - -type instance Dispatched (Gadget s m a c) = Magnified (Gadget s m a) c -instance Monad m => Dispatch (Gadget s m a c) (Gadget s m b c) a b where - dispatch = magnify - {-# INLINABLE dispatch #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Gadget/Strict.hs new/glazier-0.11.0.1/src/Glazier/Gadget/Strict.hs --- old/glazier-0.7.0.0/src/Glazier/Gadget/Strict.hs 2017-02-02 11:05:50.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Gadget/Strict.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,173 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Glazier.Gadget.Strict where - -import Control.Applicative -import Control.Arrow -import qualified Control.Category as C -import Control.Lens -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix (MonadFix) -import Control.Monad.Morph -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Profunctor -import Data.Semigroup -import Glazier.Class - --- | The Elm update function is @a -> s -> (s, c)@ --- This is isomorphic to @ReaderT a (State s) c@ --- ie, given an action "a", and a current state "s", return the new state "s" --- and any commands "c" that need to be interpreted externally (eg. download file). --- This is named Gadget instead of Update to avoid confusion with update from Data.Map -newtype Gadget s m a c = Gadget - { runGadget :: ReaderT a (StateT s m) c - } deriving ( MonadState s - , MonadReader a - , Monad - , Applicative - , Functor - , Fail.MonadFail - , Alternative - , MonadPlus - , MonadFix - , MonadIO - ) - -class HasGadget s a | s -> a where - gadget :: Lens' s a - -instance HasGadget (Gadget s m a c) (Gadget s m a c) where - gadget = id - -makeWrapped ''Gadget - --- | NB lift can be simulated: --- liftGadget :: (MonadTrans t, Monad m) => Gadget s m a c -> Gadget s (t m) a c --- liftGadget = _Wrapping Gadget %~ hoist (hoist lift) -hoistGadget :: (Monad m) => (forall b. m b -> n b) -> Gadget s m a c -> Gadget s n a c -hoistGadget g = _Wrapping Gadget %~ hoist (hoist g) -{-# INLINABLE hoistGadget #-} - --- | This Iso gives the following functions: --- --- @ --- underGadget :: (ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c') -> Gadget s m a c -> Gadget s' m' a' c' --- underGadget f = _Wrapping Gadget %~ f --- --- overGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c' --- overGadget f = _Unwrapping Gadget %~ f --- --- belowGadget :: (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) -> Gadget s m a c -> Gadget s' m' a' c' --- belowGadget f = _Gadget %~ f --- --- aboveGadget :: (Gadget s m a c -> Gadget s' m' a' c') -> (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) --- aboveGadget f = from _Gadget %~ f --- --- mkGadget' :: (a -> s -> m (c, s)) -> Gadget s m a c --- mkGadget' = review _Gadget --- --- runGadget' :: Gadget s m a c -> (a -> s -> m (c, s)) --- runGadget' = view _Gadget --- @ --- -_Gadget :: Iso (Gadget s m a c) (Gadget s' m' a' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) -_Gadget = _Wrapping Gadget . iso runReaderT ReaderT . iso (runStateT .) (StateT .) -{-# INLINABLE _Gadget #-} - --- | Non polymorphic version of _Gadget -_Gadget' :: Iso' (Gadget s m a c) (a -> s -> m (c, s)) -_Gadget' = _Gadget -{-# INLINABLE _Gadget' #-} - -instance (Monad m, Semigroup c) => Semigroup (Gadget s m a c) where - (Gadget f) <> (Gadget g) = Gadget $ (<>) <$> f <*> g - {-# INLINABLE (<>) #-} - -instance (Monad m, Monoid c) => Monoid (Gadget s m a c) where - mempty = Gadget $ pure mempty - {-# INLINABLE mempty #-} - - (Gadget f) `mappend` (Gadget g) = Gadget $ mappend <$> f <*> g - {-# INLINABLE mappend #-} - -instance Monad m => Profunctor (Gadget s m) where - dimap f g (Gadget (ReaderT m)) = Gadget $ ReaderT $ \a -> StateT $ \s -> undefined - (first g) <$> runStateT (m (f a)) s - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Gadget s m) where - first' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \(b, d) -> StateT $ \s -> - (\(c, s') -> ((c, d), s')) <$> runStateT (bc b) s - {-# INLINABLE first' #-} - -instance Monad m => C.Category (Gadget s m) where - id = Gadget $ ReaderT $ \a -> StateT $ \s -> pure (a, s) - {-# INLINABLE id #-} - - Gadget (ReaderT bc) . Gadget (ReaderT ab) = Gadget $ ReaderT $ \a -> StateT $ \s -> do - -- This line is the main difference between Strict and Lazy versions - (b, s') <- runStateT (ab a) s - runStateT (bc b) s' - {-# INLINABLE (.) #-} - -instance Monad m => Arrow (Gadget s m) where - arr f = dimap f id C.id - {-# INLINABLE arr #-} - - first = first' - {-# INLINABLE first #-} - -instance Monad m => Choice (Gadget s m) where - left' (Gadget (ReaderT bc)) = Gadget $ ReaderT $ \db -> StateT $ \s -> case db of - Left b -> do - -- This line is the main difference between Strict and Lazy versions - (c, s') <- runStateT (bc b) s - pure (Left c, s') - Right d -> pure (Right d, s) - {-# INLINABLE left' #-} - -instance Monad m => ArrowChoice (Gadget s m) where - left = left' - {-# INLINABLE left #-} - -instance Monad m => ArrowApply (Gadget s m) where - app = Gadget $ ReaderT $ \(Gadget (ReaderT bc), b) -> StateT $ \s -> runStateT (bc b) s - {-# INLINABLE app #-} - -instance MonadPlus m => ArrowZero (Gadget s m) where - zeroArrow = Gadget mzero - {-# INLINABLE zeroArrow #-} - -instance MonadPlus m => ArrowPlus (Gadget s m) where - Gadget a <+> Gadget b = Gadget (a `mplus` b) - {-# INLINABLE (<+>) #-} - --- | zoom can be used to modify the state inside an Gadget -type instance Zoomed (Gadget s m a) = Zoomed (StateT s m) -instance Monad m => Zoom (Gadget s m a) (Gadget t m a) s t where - zoom l = Gadget . zoom l . runGadget - {-# INLINABLE zoom #-} - --- | magnify can be used to modify the action inside an Gadget -type instance Magnified (Gadget s m a) = Magnified (ReaderT a (StateT s m)) -instance Monad m => Magnify (Gadget s m a) (Gadget s m b) a b where - magnify l = Gadget . magnify l . runGadget - {-# INLINABLE magnify #-} - -type instance Implanted (Gadget s m a c) = Zoomed (Gadget s m a) c -instance Monad m => Implant (Gadget s m a c) (Gadget t m a c) s t where - implant = zoom - {-# INLINABLE implant #-} - -type instance Dispatched (Gadget s m a c) = Magnified (Gadget s m a) c -instance Monad m => Dispatch (Gadget s m a c) (Gadget s m b c) a b where - dispatch = magnify - {-# INLINABLE dispatch #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Gadget.hs new/glazier-0.11.0.1/src/Glazier/Gadget.hs --- old/glazier-0.7.0.0/src/Glazier/Gadget.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Gadget.hs 2017-02-21 23:12:38.000000000 +0100 @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Glazier.Gadget where + +import Control.Applicative +import Control.Lens +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix (MonadFix) +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Semigroup + +-- | The Elm update function is @a -> s -> (s, c)@ +-- This is isomorphic to @ReaderT a (State s) c@ +-- ie, given an action "a", and a current state "s", return the new state "s" +-- and any commands "c" that need to be interpreted externally (eg. download file). +-- This is named Gadget instead of Update to avoid confusion with update from Data.Map +newtype GadgetT a s m c = GadgetT + { runGadgetT :: ReaderT a (StateT s m) c + } deriving ( MonadState s + , MonadReader a + , Monad + , Applicative + , Functor + , Fail.MonadFail + , Alternative + , MonadPlus + , MonadFix + , MonadIO + ) + +makeWrapped ''GadgetT + +type Gadget a s = GadgetT a s Identity + +_GadgetT :: Iso (GadgetT a s m c) (GadgetT a' s' m' c') (a -> s -> m (c, s)) (a' -> s' -> m' (c', s')) +_GadgetT = _Wrapping GadgetT . iso runReaderT ReaderT . iso (runStateT .) (StateT .) +{-# INLINABLE _GadgetT #-} + +-- | Non polymorphic version of _Gadget +_GadgetT' :: Iso' (GadgetT a s m c) (a -> s -> m (c, s)) +_GadgetT' = _GadgetT +{-# INLINABLE _GadgetT' #-} + +mkGadgetT' :: (a -> s -> m (c, s)) -> GadgetT a s m c +mkGadgetT' = review _GadgetT +{-# INLINABLE mkGadgetT' #-} + +runGadgetT' :: GadgetT a s m c -> (a -> s -> m (c, s)) +runGadgetT' = view _GadgetT +{-# INLINABLE runGadgetT' #-} + +belowGadgetT :: + ((a -> s -> m (c, s)) -> a' -> s' -> m' (c', s')) + -> GadgetT a s m c -> GadgetT a' s' m' c' +belowGadgetT f = _GadgetT %~ f +{-# INLINABLE belowGadgetT #-} + +underGadgetT + :: (ReaderT a (StateT s m) c -> ReaderT a' (StateT s' m') c') + -> GadgetT a s m c + -> GadgetT a' s' m' c' +underGadgetT f = _Wrapping GadgetT %~ f +{-# INLINABLE underGadgetT #-} + +overGadgetT + :: (GadgetT a s m c -> GadgetT a' s' m' c') + -> ReaderT a (StateT s m) c + -> ReaderT a' (StateT s' m') c' +overGadgetT f = _Unwrapping GadgetT %~ f +{-# INLINABLE overGadgetT #-} + +aboveGadgetT :: + (GadgetT a s m c -> GadgetT a' s' m' c') + -> (a -> s -> m (c, s)) -> a' -> s' -> m' (c', s') +aboveGadgetT f = from _GadgetT %~ f +{-# INLINABLE aboveGadgetT #-} + +instance MonadTrans (GadgetT a s) where + lift = GadgetT . lift . lift + +instance MFunctor (GadgetT a s) where + hoist f (GadgetT m) = GadgetT (hoist (hoist f) m) + +instance (Monad m, Semigroup c) => Semigroup (GadgetT a s m c) where + (GadgetT f) <> (GadgetT g) = GadgetT $ (<>) <$> f <*> g + {-# INLINABLE (<>) #-} + +instance (Monad m, Monoid c) => Monoid (GadgetT a s m c) where + mempty = GadgetT $ pure mempty + {-# INLINABLE mempty #-} + + (GadgetT f) `mappend` (GadgetT g) = GadgetT $ mappend <$> f <*> g + {-# INLINABLE mappend #-} + +-- | zoom can be used to modify the state inside an Gadget +type instance Zoomed (GadgetT a s m) = Zoomed (ReaderT a (StateT s m)) +instance Monad m => Zoom (GadgetT a s m) (GadgetT a t m) s t where + zoom l = GadgetT . zoom l . runGadgetT + {-# INLINABLE zoom #-} + +-- | magnify can be used to modify the action inside an Gadget +type instance Magnified (GadgetT a s m) = Magnified (ReaderT a (StateT s m)) +instance Monad m => Magnify (GadgetT a s m) (GadgetT b s m) a b where + magnify l = GadgetT . magnify l . runGadgetT + {-# INLINABLE magnify #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Widget/Lazy.hs new/glazier-0.11.0.1/src/Glazier/Widget/Lazy.hs --- old/glazier-0.7.0.0/src/Glazier/Widget/Lazy.hs 2017-02-02 11:07:12.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Widget/Lazy.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,245 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Glazier.Widget.Lazy - ( Widget(..) - , _Widget - , _Widget' - , _WrappingWidget - , _WrappingWidget' - , hoistWidget - , statically - , dynamically - ) where - -import Control.Applicative -import Control.Arrow -import qualified Control.Category as C -import Control.Lens -import Data.Functor.Apply -import Data.Maybe -import Data.Profunctor -import Data.Semigroup -import Glazier.Class -import Glazier.Gadget.Lazy -import Glazier.Window - --- | A widget is basically a tuple with Gadget and Window. -data Widget s v m a c = Widget - { widgetWindow :: Window m s v - , widgetGadget :: Gadget s m a c - } - -makeFields ''Widget - --- | This Iso gives the following functions: --- --- @ --- belowWidget :: ((s -> m v, a -> s -> m (c, s)) -> (s' -> m' v', a' -> s' -> m' (c', s'))) -> Widget s v m a c -> Widget s' v' m' a' c' --- belowWidget f = _Widget %~ f --- --- aboveWidget :: (Widget s v m a c -> Widget s' v' m' a' c') -> (s -> m v, a -> s -> m (c, s)) -> (s' -> m' v', a' -> s' -> m' (c', s')) --- aboveWidget f = from _Widget %~ f --- --- mkWidget' :: (s -> m v, a -> s -> m (c, s)) -> Widget s v m a c --- mkWidget' = review _Widget --- --- runWidget' :: Widget s v m a c -> (s -> m v, a -> s -> m (c, s)) --- runWidget' = view _Widget --- @ --- -_Widget :: Iso (Widget s v m a c) (Widget s' v' m' a' c') - (s -> m v, a -> s -> m (c, s)) (s' -> m' v', a' -> s' -> m' (c', s')) -_Widget = iso (\(Widget w g) -> (view _Window w, view _Gadget g)) - (\(w, g) -> Widget (review _Window w) (review _Gadget g)) -{-# INLINABLE _Widget #-} - --- | This Iso gives the following functions: --- --- @ --- underWidget :: ((Window m s v, Gadget s m a c) -> (Window m' s' v', Gadget s' m' a' c')) -> Widget s v m a c -> Widget s' v' m' a' c' --- underWidget f = _WrappingWidget %~ f --- --- overWidget :: (Widget s v m a c -> Widget s' v' m' a' c') -> (Window m s v, Gadget s m a c) -> (Window m' s' v', Gadget s' m' a' c') --- overWidget f = from _WrappingWidget %~ f --- --- mkWidget :: (Window m s v, Gadget s m a c) -> Widget s v m a c --- mkWidget = review _WrappingWidget --- --- runWidget :: Widget s v m a c -> (Window m s v, Gadget s m a c) --- runWidget = view _WrappingWidget --- @ --- -_WrappingWidget :: Iso (Widget s v m a c) (Widget s' v' m' a' c') - (Window m s v, Gadget s m a c) (Window m' s' v', Gadget s' m' a' c') -_WrappingWidget = iso (\(Widget w g) -> (w, g)) - (\(w, g) -> Widget w g) -{-# INLINABLE _WrappingWidget #-} - --- | Non polymorphic version of _WrappingWidget -_WrappingWidget' :: Iso' (Widget s v m a c) (Window m s v, Gadget s m a c) -_WrappingWidget' = _WrappingWidget -{-# INLINABLE _WrappingWidget' #-} - --- | Non polymorphic version of _Widget -_Widget' :: Iso' (Widget s v m a c) (s -> m v, a -> s -> m (c, s)) -_Widget' = _Widget -{-# INLINABLE _Widget' #-} - --- | NB lift can be simulated: --- liftWidget :: (MonadTrans t, Monad m) => Widget s v m a c -> Widget s v (t m) a c --- liftWidget = hoistWidget lift -hoistWidget :: (Monad m) => (forall x. m x -> n x) -> Widget s v m a c -> Widget s v n a c --- hoistWidget f (Widget w g) = Widget (hoistWindow f w) (hoistGadget f g) -hoistWidget f = _WrappingWidget %~ \(w, g) -> (hoistWindow f w, hoistGadget f g) -{-# INLINABLE hoistWidget #-} - -instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where - w1 <> w2 = Widget - (widgetWindow w1 <> widgetWindow w2) - (widgetGadget w1 <> widgetGadget w2) - {-# INLINABLE (<>) #-} - -instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where - mempty = Widget mempty mempty - {-# INLINABLE mempty #-} - - mappend w1 w2 = Widget - (widgetWindow w1 `mappend` widgetWindow w2) - (widgetGadget w1 `mappend` widgetGadget w2) - {-# INLINABLE mappend #-} - --- | Widget Functor is lawful --- 1: fmap id = id --- (Widget w g) = Widget w (id <$> g) = Widget w g --- 2: fmap (f . g) = fmap f . fmap g --- (Widget w gad) = Widget w ((f . g) <$> gad) = Widget w ((fmap f . fmap g) gad) -instance Functor m => Functor (Widget s v m a) where - fmap f (Widget w g) = Widget - w - (f <$> g) - {-# INLINABLE fmap #-} - --- | Widget Applicative is lawful --- Identity: pure id <*> v = v --- Widget mempty (pure id) <*> Widget vw vg --- = Widget (mempty <> vw) (pure id <*> vg) --- = Widget vw vg --- Composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w) --- Widget mempty (pure (.)) <*> Widget uw ug <*> Widget vw vg <*> Widget ww wg = --- = Widget (mempty <> uw <> vw <> ww) (pure (.) <*> ug <*> vg <*> wg --- = Widget (uw <> vw <> ww) (ug <*> (vg <*> wg)) --- = Widget (uw <> (vw <> ww)) (ug <*> (vg <*> wg)) --- = Widget uw ug <*> (Widget vw vg <*> Widget ww wg) --- Interchange: u <*> pure y = pure ($ y) <*> u --- Widget uw ug <*> Widget mempty (pure y) --- = Widget (uw <> mempty) (ug <*> pure y) --- = Widget (mempty <> uw) (pure ($ y) <*> ug) --- = Widget mempty (pure $y) <*> Widget uw ug -instance (Semigroup v, Monad m, Monoid v) => Applicative (Widget s v m a) where - pure c = Widget mempty (pure c) - {-# INLINABLE pure #-} - - (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g) - {-# INLINABLE (<*>) #-} - -instance Monad m => Profunctor (Widget s v m) where - dimap f g (Widget w m) = Widget w (dimap f g m) - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Widget s v m) where - first' (Widget w g) = Widget w (first' g) - {-# INLINABLE first' #-} - -instance (Monad m, Monoid v) => C.Category (Widget s v m) where - id = Widget mempty C.id - {-# INLINABLE id #-} - - Widget wbc gbc . Widget wab gab = Widget - (wab `mappend` wbc) - (gbc C.. gab) - {-# INLINABLE (.) #-} - --- | No monad instance for Widget is possible, however an arrow is possible. --- The Arrow instance monoidally appends the Window, and uses the inner Gadget Arrow instance. -instance (Monad m, Monoid v) => Arrow (Widget s v m) where - arr f = dimap f id C.id - {-# INLINABLE arr #-} - - first = first' - {-# INLINABLE first #-} - -instance (Monad m) => Choice (Widget s v m) where - left' (Widget w bc) = Widget w (left' bc) - {-# INLINABLE left' #-} - -instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where - left = left' - {-# INLINABLE left #-} - -statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c -statically w = Widget w mempty -{-# INLINABLE statically #-} - -dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c -dynamically = Widget mempty -{-# INLINABLE dynamically #-} - -type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c) -instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where - dispatch p w = Widget - (widgetWindow w) - (dispatch p $ widgetGadget w) - {-# INLINABLE dispatch #-} - -type instance Implanted (Widget s v m a c) = - PairMaybeFunctor (Implanted (Gadget s m a c)) - (Implanted (Window m s v)) -instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where - implant l w = Widget - (implant (sndLensLike l) $ widgetWindow w) - (implant (fstLensLike l) $ widgetGadget w) - {-# INLINABLE implant #-} - --- ------------------------------------------------------------------------------- - --- | This can be used to hold two LensLike functors. --- The inner LensLike functor can be extracted from a @LensLike (PairMaybeFunctor f g) s t a b@ --- using 'fstLensLike' or 'sndLensLike'. --- NB. The constructor must not be exported to keep 'fstLensLike' and 'sndLensLike' safe. -newtype PairMaybeFunctor f g a = PairMaybeFunctor { getPairMaybeFunctor :: (Maybe (f a), Maybe (g a)) } - -instance (Functor f, Functor g) => Functor (PairMaybeFunctor f g) where - fmap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (fmap f <$> a, fmap f <$> b) - {-# INLINABLE fmap #-} - -instance (Apply f, Apply g) => Apply (PairMaybeFunctor f g) where - (PairMaybeFunctor (a, b)) <.> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (Data.Functor.Apply.<.>) a c, liftA2 (Data.Functor.Apply.<.>) b d) - {-# INLINABLE (<.>) #-} - -instance (Applicative f, Applicative g) => Applicative (PairMaybeFunctor f g) where - pure a = PairMaybeFunctor (Just $ pure a, Just $ pure a) - {-# INLINABLE pure #-} - - (PairMaybeFunctor (a, b)) <*> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (<*>) a c, liftA2 (<*>) b d) - {-# INLINABLE (<*>) #-} - -instance (Contravariant f, Contravariant g) => Contravariant (PairMaybeFunctor f g) where - contramap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (contramap f <$> a, contramap f <$> b) - {-# INLINABLE contramap #-} - -fstLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike f s t a b --- fromJust is safe here as the constructor is hidden and we've definitely filled in the fst item of PairMaybeFunctor -fstLensLike l f b = fromJust . fst . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Just $ f a, Nothing)) b -{-# INLINABLE fstLensLike #-} - -sndLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike g s t a b --- fromJust is safe here as the constructor is hidden and we've definitely filled in the snd item of PairMaybeFunctor -sndLensLike l f b = fromJust . snd . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Nothing, Just $ f a)) b -{-# INLINABLE sndLensLike #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Widget/Strict.hs new/glazier-0.11.0.1/src/Glazier/Widget/Strict.hs --- old/glazier-0.7.0.0/src/Glazier/Widget/Strict.hs 2017-02-02 11:06:46.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Widget/Strict.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,245 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Glazier.Widget.Strict - ( Widget(..) - , _Widget - , _Widget' - , _WrappingWidget - , _WrappingWidget' - , hoistWidget - , statically - , dynamically - ) where - -import Control.Applicative -import Control.Arrow -import qualified Control.Category as C -import Control.Lens -import Data.Functor.Apply -import Data.Maybe -import Data.Profunctor -import Data.Semigroup -import Glazier.Class -import Glazier.Gadget.Strict -import Glazier.Window - --- | A widget is basically a tuple with Gadget and Window. -data Widget s v m a c = Widget - { widgetWindow :: Window m s v - , widgetGadget :: Gadget s m a c - } - -makeFields ''Widget - --- | This Iso gives the following functions: --- --- @ --- belowWidget :: ((s -> m v, a -> s -> m (c, s)) -> (s' -> m' v', a' -> s' -> m' (c', s'))) -> Widget s v m a c -> Widget s' v' m' a' c' --- belowWidget f = _Widget %~ f --- --- aboveWidget :: (Widget s v m a c -> Widget s' v' m' a' c') -> (s -> m v, a -> s -> m (c, s)) -> (s' -> m' v', a' -> s' -> m' (c', s')) --- aboveWidget f = from _Widget %~ f --- --- mkWidget' :: (s -> m v, a -> s -> m (c, s)) -> Widget s v m a c --- mkWidget' = review _Widget --- --- runWidget' :: Widget s v m a c -> (s -> m v, a -> s -> m (c, s)) --- runWidget' = view _Widget --- @ --- -_Widget :: Iso (Widget s v m a c) (Widget s' v' m' a' c') - (s -> m v, a -> s -> m (c, s)) (s' -> m' v', a' -> s' -> m' (c', s')) -_Widget = iso (\(Widget w g) -> (view _Window w, view _Gadget g)) - (\(w, g) -> Widget (review _Window w) (review _Gadget g)) -{-# INLINABLE _Widget #-} - --- | This Iso gives the following functions: --- --- @ --- underWidget :: ((Window m s v, Gadget s m a c) -> (Window m' s' v', Gadget s' m' a' c')) -> Widget s v m a c -> Widget s' v' m' a' c' --- underWidget f = _WrappingWidget %~ f --- --- overWidget :: (Widget s v m a c -> Widget s' v' m' a' c') -> (Window m s v, Gadget s m a c) -> (Window m' s' v', Gadget s' m' a' c') --- overWidget f = from _WrappingWidget %~ f --- --- mkWidget :: (Window m s v, Gadget s m a c) -> Widget s v m a c --- mkWidget = review _WrappingWidget --- --- runWidget :: Widget s v m a c -> (Window m s v, Gadget s m a c) --- runWidget = view _WrappingWidget --- @ --- -_WrappingWidget :: Iso (Widget s v m a c) (Widget s' v' m' a' c') - (Window m s v, Gadget s m a c) (Window m' s' v', Gadget s' m' a' c') -_WrappingWidget = iso (\(Widget w g) -> (w, g)) - (\(w, g) -> Widget w g) -{-# INLINABLE _WrappingWidget #-} - --- | Non polymorphic version of _WrappingWidget -_WrappingWidget' :: Iso' (Widget s v m a c) (Window m s v, Gadget s m a c) -_WrappingWidget' = _WrappingWidget -{-# INLINABLE _WrappingWidget' #-} - --- | Non polymorphic version of _Widget -_Widget' :: Iso' (Widget s v m a c) (s -> m v, a -> s -> m (c, s)) -_Widget' = _Widget -{-# INLINABLE _Widget' #-} - --- | NB lift can be simulated: --- liftWidget :: (MonadTrans t, Monad m) => Widget s v m a c -> Widget s v (t m) a c --- liftWidget = hoistWidget lift -hoistWidget :: (Monad m) => (forall x. m x -> n x) -> Widget s v m a c -> Widget s v n a c --- hoistWidget f (Widget w g) = Widget (hoistWindow f w) (hoistGadget f g) -hoistWidget f = _WrappingWidget %~ \(w, g) -> (hoistWindow f w, hoistGadget f g) -{-# INLINABLE hoistWidget #-} - -instance (Monad m, Semigroup c, Semigroup v) => Semigroup (Widget s v m a c) where - w1 <> w2 = Widget - (widgetWindow w1 <> widgetWindow w2) - (widgetGadget w1 <> widgetGadget w2) - {-# INLINABLE (<>) #-} - -instance (Monad m, Monoid c, Monoid v) => Monoid (Widget s v m a c) where - mempty = Widget mempty mempty - {-# INLINABLE mempty #-} - - mappend w1 w2 = Widget - (widgetWindow w1 `mappend` widgetWindow w2) - (widgetGadget w1 `mappend` widgetGadget w2) - {-# INLINABLE mappend #-} - --- | Widget Functor is lawful --- 1: fmap id = id --- (Widget w g) = Widget w (id <$> g) = Widget w g --- 2: fmap (f . g) = fmap f . fmap g --- (Widget w gad) = Widget w ((f . g) <$> gad) = Widget w ((fmap f . fmap g) gad) -instance Functor m => Functor (Widget s v m a) where - fmap f (Widget w g) = Widget - w - (f <$> g) - {-# INLINABLE fmap #-} - --- | Widget Applicative is lawful --- Identity: pure id <*> v = v --- Widget mempty (pure id) <*> Widget vw vg --- = Widget (mempty <> vw) (pure id <*> vg) --- = Widget vw vg --- Composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w) --- Widget mempty (pure (.)) <*> Widget uw ug <*> Widget vw vg <*> Widget ww wg = --- = Widget (mempty <> uw <> vw <> ww) (pure (.) <*> ug <*> vg <*> wg --- = Widget (uw <> vw <> ww) (ug <*> (vg <*> wg)) --- = Widget (uw <> (vw <> ww)) (ug <*> (vg <*> wg)) --- = Widget uw ug <*> (Widget vw vg <*> Widget ww wg) --- Interchange: u <*> pure y = pure ($ y) <*> u --- Widget uw ug <*> Widget mempty (pure y) --- = Widget (uw <> mempty) (ug <*> pure y) --- = Widget (mempty <> uw) (pure ($ y) <*> ug) --- = Widget mempty (pure $y) <*> Widget uw ug -instance (Semigroup v, Monad m, Monoid v) => Applicative (Widget s v m a) where - pure c = Widget mempty (pure c) - {-# INLINABLE pure #-} - - (Widget w1 fg) <*> (Widget w2 g) = Widget (w1 <> w2) (fg <*> g) - {-# INLINABLE (<*>) #-} - -instance Monad m => Profunctor (Widget s v m) where - dimap f g (Widget w m) = Widget w (dimap f g m) - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Widget s v m) where - first' (Widget w g) = Widget w (first' g) - {-# INLINABLE first' #-} - -instance (Monad m, Monoid v) => C.Category (Widget s v m) where - id = Widget mempty C.id - {-# INLINABLE id #-} - - Widget wbc gbc . Widget wab gab = Widget - (wab `mappend` wbc) - (gbc C.. gab) - {-# INLINABLE (.) #-} - --- | No monad instance for Widget is possible, however an arrow is possible. --- The Arrow instance monoidally appends the Window, and uses the inner Gadget Arrow instance. -instance (Monad m, Monoid v) => Arrow (Widget s v m) where - arr f = dimap f id C.id - {-# INLINABLE arr #-} - - first = first' - {-# INLINABLE first #-} - -instance (Monad m) => Choice (Widget s v m) where - left' (Widget w bc) = Widget w (left' bc) - {-# INLINABLE left' #-} - -instance (Monad m, Monoid v) => ArrowChoice (Widget s v m) where - left = left' - {-# INLINABLE left #-} - -statically :: (Monad m, Monoid c) => Window m s v -> Widget s v m a c -statically w = Widget w mempty -{-# INLINABLE statically #-} - -dynamically :: (Monad m, Monoid v) => Gadget s m a c -> Widget s v m a c -dynamically = Widget mempty -{-# INLINABLE dynamically #-} - -type instance Dispatched (Widget s v m a c) = Dispatched (Gadget s m a c) -instance Monad m => Dispatch (Widget s v m a c) (Widget s v m b c) a b where - dispatch p w = Widget - (widgetWindow w) - (dispatch p $ widgetGadget w) - {-# INLINABLE dispatch #-} - -type instance Implanted (Widget s v m a c) = - PairMaybeFunctor (Implanted (Gadget s m a c)) - (Implanted (Window m s v)) -instance Monad m => Implant (Widget s v m a c) (Widget t v m a c) s t where - implant l w = Widget - (implant (sndLensLike l) $ widgetWindow w) - (implant (fstLensLike l) $ widgetGadget w) - {-# INLINABLE implant #-} - --- ------------------------------------------------------------------------------- - --- | This can be used to hold two LensLike functors. --- The inner LensLike functor can be extracted from a @LensLike (PairMaybeFunctor f g) s t a b@ --- using 'fstLensLike' or 'sndLensLike'. --- NB. The constructor must not be exported to keep 'fstLensLike' and 'sndLensLike' safe. -newtype PairMaybeFunctor f g a = PairMaybeFunctor { getPairMaybeFunctor :: (Maybe (f a), Maybe (g a)) } - -instance (Functor f, Functor g) => Functor (PairMaybeFunctor f g) where - fmap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (fmap f <$> a, fmap f <$> b) - {-# INLINABLE fmap #-} - -instance (Apply f, Apply g) => Apply (PairMaybeFunctor f g) where - (PairMaybeFunctor (a, b)) <.> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (Data.Functor.Apply.<.>) a c, liftA2 (Data.Functor.Apply.<.>) b d) - {-# INLINABLE (<.>) #-} - -instance (Applicative f, Applicative g) => Applicative (PairMaybeFunctor f g) where - pure a = PairMaybeFunctor (Just $ pure a, Just $ pure a) - {-# INLINABLE pure #-} - - (PairMaybeFunctor (a, b)) <*> (PairMaybeFunctor (c, d)) = PairMaybeFunctor (liftA2 (<*>) a c, liftA2 (<*>) b d) - {-# INLINABLE (<*>) #-} - -instance (Contravariant f, Contravariant g) => Contravariant (PairMaybeFunctor f g) where - contramap f (PairMaybeFunctor (a, b)) = PairMaybeFunctor (contramap f <$> a, contramap f <$> b) - {-# INLINABLE contramap #-} - -fstLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike f s t a b --- fromJust is safe here as the constructor is hidden and we've definitely filled in the fst item of PairMaybeFunctor -fstLensLike l f b = fromJust . fst . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Just $ f a, Nothing)) b -{-# INLINABLE fstLensLike #-} - -sndLensLike :: LensLike (PairMaybeFunctor f g) s t a b -> LensLike g s t a b --- fromJust is safe here as the constructor is hidden and we've definitely filled in the snd item of PairMaybeFunctor -sndLensLike l f b = fromJust . snd . getPairMaybeFunctor $ l (\a -> PairMaybeFunctor (Nothing, Just $ f a)) b -{-# INLINABLE sndLensLike #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier/Window.hs new/glazier-0.11.0.1/src/Glazier/Window.hs --- old/glazier-0.7.0.0/src/Glazier/Window.hs 2017-02-02 10:58:11.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier/Window.hs 2017-03-18 14:37:37.000000000 +0100 @@ -9,60 +9,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} --- | Functional version of (Elm View/Update & startApp architecture) enabling composable widgets, and a FRP-like framework. --- --- This framework makes it easier to modularize the Elm architecture idea of View/Update: --- based on the deprecated Elm Architecture version of Jan 2016 --- https://github.com/evancz/elm-architecture-tutorial/tree/de5682a5a8e4459aed… --- --- The Elm View/Update is basically as follows: --- --- @ --- data Model = Blah.... --- data Action = DoThis | DoThat deriving Show --- --- -- | update is fired from an event processing loop --- update :: Action -> Model -> Model --- --- -- | The widget from 'view' knows how to send Action to a mailbox --- view :: Signal Address -> Model -> Html --- @ --- --- This module uses isomorphic Window and Gadget resulting in instances can be be composed together into larger Widgets. --- Original inspiration from https://arianvp.me/lenses-and-prisms-for-modular-clientside-apps/ --- --- This framework provides three main combinators: --- * Semigroup and Monoid instances for concatenating widgets. --- * 'dispatch' is used to re-route the action type. --- * 'implant' is used to modify the model type. module Glazier.Window where import Control.Applicative -import Control.Arrow -import qualified Control.Category as C import Control.Lens -import qualified Control.Lens.Internal.Zoom as Z import qualified Control.Monad.Fail as Fail import Control.Monad.Fix (MonadFix) import Control.Monad.Morph import Control.Monad.Reader -import Control.Monad.Zip (MonadZip) -import Data.Profunctor import Data.Semigroup -import Glazier.Class ------------------------------------------------------------------------------- -- | The Elm view function is basically @view :: model -> html@ --- NB. elm-html is actually @view :: Signal.Address action -> model -> html@ --- where @Signal.Address action@ is the Pipes.Concurrent.Output that is sent --- actions (eg. when html button is clicked). --- This address argument is not required in the general case, and is only required for specific widgets on an as needed basis. --- Therefore, using the fundamental type of @view :: model -> html@ --- This is be ehanced with monadic effects with ReaderT. +-- This can be enhanced with monadic effects with ReaderT. -- This is named Window instead of View to avoid confusion with view from Control.Lens -newtype Window m s v = Window - { runWindow :: ReaderT s m v +newtype WindowT s m v = WindowT + { runWindowT :: ReaderT s m v } deriving ( MonadReader s , Monad , Applicative @@ -72,113 +35,74 @@ , MonadPlus , MonadFix , MonadIO - , MonadZip ) -class HasWindow s a | s -> a where - window :: Lens' s a -instance HasWindow (Window m s v) (Window m s v) where - window = id +makeWrapped ''WindowT -makeWrapped ''Window +type Window s = WindowT s Identity --- | NB lift can be simulated: --- liftWindow :: (MonadTrans t, Monad m) => Window m s v -> Window (t m) s v --- liftWindow = hoistWindow lift -hoistWindow :: (Monad m) => (forall a. m a -> n a) -> Window m s v -> Window n s v -hoistWindow g = _Wrapping Window %~ hoist g -{-# INLINABLE hoistWindow #-} - --- | This Iso gives the following functions: --- --- @ --- liftWindow :: (MonadTrans t, Monad m) => Window m s v -> Window (t m) s v --- liftWindow = hoistWindow lift --- --- underWindow :: (ReaderT s m v -> ReaderT s' m' v') -> Window m s v -> Window m' s' v' --- underWindow f = _Wrapping Window %~ f --- --- overWindow :: (Window m s v -> Window m' s' v') -> ReaderT s m v -> ReaderT s' m' v' --- overWindow f = _Unwrapping Window %~ f --- --- belowWindow :: ((s -> m v) -> (s' -> m' v')) -> Window m s v -> Window m' s' v' --- belowWindow f = _Window %~ f --- --- aboveWindow :: (Window m s v -> Window m' s' v') -> (s -> m v) -> (s' -> m' v') --- aboveWindow f = from _Window %~ f --- --- mkWindow' :: (s -> m v) -> Window m s v --- mkWindow' = review _Window --- --- runWindow' :: Window m s v -> (s -> m v) --- runWindow' = view _Window --- @ --- -_Window :: Iso (Window m s v) (Window m' s' v') (s -> m v) (s' -> m' v') -_Window = _Wrapping Window . iso runReaderT ReaderT -- lens 4.15.1 doesn't have a general enough ReaderT iso -{-# INLINABLE _Window #-} +_WindowT :: Iso (WindowT s m v) (WindowT s' m' v') (s -> m v) (s' -> m' v') +_WindowT = _Wrapping WindowT . iso runReaderT ReaderT +{-# INLINABLE _WindowT #-} -- | Non polymorphic version of _Window -_Window' :: Iso' (Window m s v) (s -> m v) -_Window' = _Window -{-# INLINABLE _Window' #-} - -instance (Applicative m, Semigroup v) => Semigroup (Window m s v) where - (Window f) <> (Window g) = Window $ ReaderT $ \a -> - (<>) <$> runReaderT f a <*> runReaderT g a +_WindowT' :: Iso' (WindowT s m v) (s -> m v) +_WindowT' = _WindowT +{-# INLINABLE _WindowT' #-} + +mkWindowT' :: (s -> m v) -> WindowT s m v +mkWindowT' = review _WindowT +{-# INLINABLE mkWindowT' #-} + +runWindowT' :: WindowT s m v -> (s -> m v) +runWindowT' = view _WindowT +{-# INLINABLE runWindowT' #-} + +belowWindowT :: + ((s -> m v) -> (s' -> m' v')) + -> WindowT s m v -> WindowT s' m' v' +belowWindowT f = _WindowT %~ f +{-# INLINABLE belowWindowT #-} + +underWindowT + :: (ReaderT s m v -> ReaderT s' m' v') + -> WindowT s m v + -> WindowT s' m' v' +underWindowT f = _Wrapping WindowT %~ f +{-# INLINABLE underWindowT #-} + +overWindowT + :: (WindowT s m v -> WindowT s' m' v') + -> ReaderT s m v + -> ReaderT s' m' v' +overWindowT f = _Unwrapping WindowT %~ f +{-# INLINABLE overWindowT #-} + +aboveWindowT :: + (WindowT s m v -> WindowT s' m' v') + -> (s -> m v) -> (s' -> m' v') +aboveWindowT f = from _WindowT %~ f +{-# INLINABLE aboveWindowT #-} + +instance MonadTrans (WindowT s) where + lift = WindowT . lift + +instance MFunctor (WindowT s) where + hoist f (WindowT m) = WindowT (hoist f m) + +instance (Applicative m, Semigroup v) => Semigroup (WindowT s m v) where + (WindowT f) <> (WindowT g) = WindowT $ (<>) <$> f <*> g {-# INLINABLE (<>) #-} -instance (Applicative m, Monoid v) => Monoid (Window m s v) where - mempty = Window $ ReaderT $ const $ pure mempty +instance (Applicative m, Monoid v) => Monoid (WindowT s m v) where + mempty = WindowT $ pure mempty {-# INLINABLE mempty #-} - (Window f) `mappend` (Window g) = Window $ ReaderT $ \a -> - mappend <$> runReaderT f a <*> runReaderT g a + (WindowT f) `mappend` (WindowT g) = WindowT $ mappend <$> f <*> g {-# INLINABLE mappend #-} -instance Monad m => Profunctor (Window m) where - dimap f g = _Window %~ (runKleisli . dimap f g . Kleisli) - {-# INLINABLE dimap #-} - -instance Monad m => Strong (Window m) where - first' = _Window %~ (runKleisli . first' . Kleisli) - {-# INLINABLE first' #-} - -instance Monad m => C.Category (Window m) where - id = Window . ReaderT $ runKleisli C.id - {-# INLINABLE id #-} - - Window (ReaderT k) . Window (ReaderT l) = Window . ReaderT . runKleisli $ Kleisli k C.. Kleisli l - {-# INLINABLE (.) #-} - -instance Monad m => Arrow (Window m) where - arr f = Window $ ReaderT $ runKleisli $ arr f - {-# INLINABLE arr #-} - - first = _Window %~ (runKleisli . first . Kleisli) - {-# INLINABLE first #-} - -instance Monad m => Choice (Window m) where - left' = _Window %~ (runKleisli . left' . Kleisli) - {-# INLINABLE left' #-} - -instance Monad m => ArrowChoice (Window m) where - left = _Window %~ (runKleisli . left . Kleisli) - {-# INLINABLE left #-} - -instance Monad m => ArrowApply (Window m) where - app = Window . ReaderT $ \(Window (ReaderT bc), b) -> bc b - {-# INLINABLE app #-} - -instance MonadPlus m => ArrowZero (Window m) where - zeroArrow = Window mzero - {-# INLINABLE zeroArrow #-} - -instance MonadPlus m => ArrowPlus (Window m) where - Window a <+> Window b = Window (a `mplus` b) - {-# INLINABLE (<+>) #-} - -type instance Implanted (Window m s v) = Z.Effect m v -instance Monad m => Implant (Window m s v) (Window m t v) s t where - implant l (Window m) = Window $ magnify l m - {-# INLINABLE implant #-} +-- | magnify can be used to modify the action inside an Gadget +type instance Magnified (WindowT s m) = Magnified (ReaderT s m) +instance Monad m => Magnify (WindowT s m) (WindowT t m) s t where + magnify l = WindowT . magnify l . runWindowT + {-# INLINABLE magnify #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glazier-0.7.0.0/src/Glazier.hs new/glazier-0.11.0.1/src/Glazier.hs --- old/glazier-0.7.0.0/src/Glazier.hs 2017-02-02 11:03:30.000000000 +0100 +++ new/glazier-0.11.0.1/src/Glazier.hs 2017-03-18 14:46:57.000000000 +0100 @@ -1,11 +1,28 @@ +-- Functional version of Elm Action/Model/View/Update architecture, but additionally powered by Haskell typeclasses, monad transformers, and lens. +-- #Features +-- ## Composable widgets +-- Larger widgets can be made out of smaller widgets without changing any existing code, or "lifting of" states. +-- ## Easily embed widget +-- Use of lens and prisms to embed a smaller widget Action &Model within larger widget Action & Model. +-- ## Typeclasses and Monad Transformers +-- Using Haskell typeclasses and monad transformer enables a disciplined and lawful way of composing widgets and effects together. +-- ## Orthogonal wiring +-- Unlike other GUI frameworks, the signal framework (how the widgets interact with other stateful effects) are not fixed by this library. I recommend using the pipe ecosystem, but you could probably use conduit or manually run the StateT transformer yourself. +-- ## Combine multiple concurrent stateful effects +-- I recommend using the pipe ecosystem the signal framework because [pipes-fluid](https://github.com/louispan/pipes-fluid) allows combining multiple concurrent stateful effects whilst maintaining a single source of truth. This is possible because the stateful effects are running over [STM](http://chimera.labs.oreilly.com/books/1230000000929/ch10.html) which will ensure a consistent ordering of stateful effects. Haskell is +-- ## Isolation of IO +-- The stateful effects are pure and do not involve IO. All IO effects are isolated to an interpreter of the command output of the gadget. This has the benefit of allowing better testing of the intention of gadgets; increasing confidence of the behaviour of the gadget, reducing the surface area of IO misbehaviour. +-- # Examples +-- ## TodoMVC +-- This is a fully featured TodoMVC in in Haskell and ReactJS using the [glazier-react](https://github.com/louispan/glazier-react) library. +-- For a live demo, see https://louispan.github.io/glazier-react-examples/ +-- For more details, see the [todo example README.md](https://github.com/louispan/glazier-react-examples/tree/master/e… +-- # Slides +-- See [slides](https://github.com/louispan/glazier-react-intro) module Glazier - ( module Glazier.Class - , module Glazier.Window - , module Glazier.Gadget.Strict - , module Glazier.Widget.Strict + ( module Glazier.Window + , module Glazier.Gadget ) where -import Glazier.Class import Glazier.Window -import Glazier.Gadget.Strict -import Glazier.Widget.Strict +import Glazier.Gadget

1 0

commit ghc-glaze for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-glaze for openSUSE:Factory checked in at 2017-08-31 20:51:10 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-glaze (Old) and /work/SRC/openSUSE:Factory/.ghc-glaze.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-glaze" Thu Aug 31 20:51:10 2017 rev:2 rq:513255 version:0.3.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-glaze/ghc-glaze.changes 2017-04-14 13:35:19.395723891 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-glaze.new/ghc-glaze.changes 2017-08-31 20:51:11.771810395 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:59 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0.1. + +------------------------------------------------------------------- Old: ---- glaze-0.2.0.2.tar.gz New: ---- glaze-0.3.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-glaze.spec ++++++ --- /var/tmp/diff_new_pack.Ec4o7D/_old 2017-08-31 20:51:12.655686324 +0200 +++ /var/tmp/diff_new_pack.Ec4o7D/_new 2017-08-31 20:51:12.659685763 +0200 @@ -18,7 +18,7 @@ %global pkg_name glaze Name: ghc-%{pkg_name} -Version: 0.2.0.2 +Version: 0.3.0.1 Release: 0 Summary: Framework for rendering things with metadata/headers and values License: BSD-3-Clause ++++++ glaze-0.2.0.2.tar.gz -> glaze-0.3.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glaze-0.2.0.2/LICENSE new/glaze-0.3.0.1/LICENSE --- old/glaze-0.2.0.2/LICENSE 2016-12-28 09:42:35.000000000 +0100 +++ new/glaze-0.3.0.1/LICENSE 2017-03-06 21:31:21.000000000 +0100 @@ -1,4 +1,4 @@ -Copyright Author name here (c) 2016 +Copyright Louis Pan (c) 2016 All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Author name here nor the names of other + * Neither the name of Louis Pan nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -27,4 +27,4 @@ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glaze-0.2.0.2/glaze.cabal new/glaze-0.3.0.1/glaze.cabal --- old/glaze-0.2.0.2/glaze.cabal 2017-01-29 13:37:58.000000000 +0100 +++ new/glaze-0.3.0.1/glaze.cabal 2017-03-06 21:37:24.000000000 +0100 @@ -1,5 +1,5 @@ name: glaze -version: 0.2.0.2 +version: 0.3.0.1 synopsis: Framework for rendering things with metadata/headers and values description: Please see README.md homepage: https://github.com/louispan/glaze#readme diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/glaze-0.2.0.2/src/Glaze.hs new/glaze-0.3.0.1/src/Glaze.hs --- old/glaze-0.2.0.2/src/Glaze.hs 2017-01-29 13:39:27.000000000 +0100 +++ new/glaze-0.3.0.1/src/Glaze.hs 2017-02-15 11:51:01.000000000 +0100 @@ -1,9 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -- | Framework for rendering things (or list of things, or things that contain things) that have metadata/header information as well as values. module Glaze where @@ -13,98 +10,85 @@ -- | Glaze is something that knows how to render some header information -- and given a value, how to render the value. --- Ie, the value has been glaze with meta information. +-- Ie, the value has been glazeed with meta information. data Glaze a r = Glaze - { glazeRenderedMeta :: r - , glazeValueRenderer :: a -> r - } deriving Functor - --- makeFields ''Glaze --- Manually pasting the splices to get around haddock bug -class HasRenderedMeta s a | s -> a where - renderedMeta :: Lens' s a - -instance HasRenderedMeta (Glaze a r) r where - {-# INLINE renderedMeta #-} - renderedMeta f (Glaze x1 x2) - = fmap (\y1 -> Glaze y1 x2) (f x1) - -class HasValueRenderer s a | s -> a where - valueRenderer :: Lens' s a - -instance HasValueRenderer (Glaze a r) (a -> r) where - {-# INLINE valueRenderer #-} - valueRenderer f (Glaze x1 x2) - = fmap (\y1 -> Glaze x1 y1) (f x2) + { renderedMeta :: r + , valueRenderer :: a -> r + } deriving (Functor) +-- FIXME: is this lawful? instance Applicative (Glaze a) where pure a = Glaze a (const a) x <*> y = Glaze - ((x ^. renderedMeta) (y ^. renderedMeta)) - (\a -> (x ^. valueRenderer) a ((y ^. valueRenderer) a)) + (renderedMeta x $ renderedMeta y) + (\a -> valueRenderer x a $ valueRenderer y a) -- | Given a wrapping function for the meta and renderer value, -- and Glaze instructions for a, run them all together. -renderWith :: (r -> r -> b) -> Glaze a r -> a -> b -renderWith mainWrapper rdr a = - mainWrapper (rdr ^. renderedMeta) ((rdr ^. valueRenderer) a) +unglazeWith :: (r -> r -> b) -> Glaze a r -> a -> b +unglazeWith mainWrapper rdr a = + mainWrapper (renderedMeta rdr) (valueRenderer rdr a) -- | Lifts glazing function into an Applicative -glazeA :: - (Traversable t, Applicative m) => - (wrapper -> meta -> t rs -> r) -> m wrapper -> m meta -> t (m rs) -> m r -glazeA f wrapper meta rs = f <$> wrapper <*> meta <*> sequenceA rs +-- This is used to transform functions like 'glazeList' into 'glazeListA' +glazedA + :: (Traversable t, Applicative m) + => (wrapper -> meta -> t rs -> r) -> m wrapper -> m meta -> t (m rs) -> m r +glazedA f wrapper meta rs = f <$> wrapper <*> meta <*> sequenceA rs -- | This can be used to make a Glaze for a list of things to render as a table. -- Given (mainWrapper :: rows -> final render, headerRowWrapper:: fields -> header row, valueRowWrapper -> value row) --- the rendered meta, and a list of @Glaze a@, transform it to a Glaze for a list of as. -glazeList :: ([row] -> r, [field] -> row, [field] -> row) - -> r - -> [Glaze a field] - -> Glaze [a] r +-- the rendered meta, and a list of @Glaze a@ columns to use, transform it to a Glaze for a list of as. +glazeList :: ([row] -> r, [field] -> row, [field] -> row) -- how to merge subresults + -> r -- meta for the final glaze + -> [Glaze a field] -- descriptions of columns to use + -> Glaze [a] r -- know how to render list of as. glazeList (mainWrapper, headerRowWrapper, valueRowWrapper) meta rs = Glaze meta glazeList' where - rs' = sequenceA rs - glazeList' as = - mainWrapper $ - headerRowWrapper (rs' ^. renderedMeta) : - (valueRowWrapper . view valueRenderer rs' <$> as) + -- rs' :: Glaze a [field] + rs' = sequenceA rs + glazeList' as = + mainWrapper $ + headerRowWrapper (renderedMeta rs') : + (valueRowWrapper . valueRenderer rs' <$> as) -- | Applicative version of glazeList -glazeListA :: - Applicative f => - f ([row] -> r, [field] -> row, [field] -> row) - -> f r -> [f (Glaze a field)] -> f (Glaze [a] r) -glazeListA = glazeA glazeList +glazeListA + :: Applicative f + => f ([row] -> r, [field] -> row, [field] -> row) + -> f r + -> [f (Glaze a field)] + -> f (Glaze [a] r) +glazeListA = glazedA glazeList -- | This can be used to generate a Glaze for a larger supercomponent. -- Given (wrapper :: list of (meta, rendered value) to final render) --- the rendered meta, and a list of @Glaze a@, transform it to a Glaze for a single a. +-- the rendered meta, and a list of @Glaze a@ field to use, transform it to a Glaze for a single a. -- In this case, use 'reglaze' to generate @Glaze a@ for each subcomponent to use as the list of @Glaze a@ -glazeFields :: ([(b, b)] -> r) -> r -> [Glaze a b] -> Glaze a r +glazeFields :: ([(b, b)] -> r) -- how to merge results + -> r -- meta for this glaze + -> [Glaze a b] -- description of sub components to use + -> Glaze a r -- know how to render the composite a glazeFields wrapper meta rs = - Glaze meta (\a -> wrapper $ (\r -> (r ^. renderedMeta, (r ^. valueRenderer) a)) <$> rs) + Glaze meta (\a -> wrapper $ (\r -> (renderedMeta r, valueRenderer r a)) <$> rs) -- | Applicative versino of glazeFields -glazeFieldsA :: - Applicative f => - f ([(b, b)] -> r) -> f r -> [f (Glaze a b)] -> f (Glaze a r) -glazeFieldsA = glazeA glazeFields +glazeFieldsA + :: Applicative f + => f ([(b, b)] -> r) -> f r -> [f (Glaze a b)] -> f (Glaze a r) +glazeFieldsA = glazedA glazeFields -- | Makes a glaze of the type of a larger component, but only using -- the information of a smaller component. --- Given a factory function that can create glazes from Proxy a --- and a Lens into subcomponent a, create the glaze of the type of the larger component. -reglaze :: (Proxy a -> Glaze a r) -> Getter s a -> Glaze s r -reglaze f lns = Glaze - (rdr ^. renderedMeta) - (\s -> (rdr ^. valueRenderer) (s ^. lns)) - where - rdr = f (Proxy :: Proxy a) +-- Given a Glaze and Lens into subcomponent a, create the glaze of the type of the larger component. +reglaze :: Glaze a r -> Getter s a -> Glaze s r +reglaze rdr lns = Glaze + (renderedMeta rdr) + (\s -> valueRenderer rdr (s ^. lns)) -- | Applicative version of reglaze -reglazeA :: Applicative f => (Proxy a -> f (Glaze a r)) -> Getter s a -> f (Glaze s r) -reglazeA f lns = (\rdr -> Glaze - (rdr ^. renderedMeta) - (\s -> (rdr ^. valueRenderer) (s ^. lns))) <$> f (Proxy :: Proxy a) +reglazeA :: Applicative f => f (Glaze a r) -> Getter s a -> f (Glaze s r) +reglazeA rdr lns = (\rdr' -> Glaze + (renderedMeta rdr') + (\s -> valueRenderer rdr' (s ^. lns))) <$> rdr

1 0

commit ghc-gitrev for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gitrev for openSUSE:Factory checked in at 2017-08-31 20:51:08 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gitrev (Old) and /work/SRC/openSUSE:Factory/.ghc-gitrev.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gitrev" Thu Aug 31 20:51:08 2017 rev:3 rq:513254 version:1.3.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gitrev/ghc-gitrev.changes 2016-07-20 09:21:35.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gitrev.new/ghc-gitrev.changes 2017-08-31 20:51:09.940067520 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:02 UTC 2017 - psimons(a)suse.com + +- Update to version 1.3.1. + +------------------------------------------------------------------- Old: ---- gitrev-1.2.0.tar.gz New: ---- gitrev-1.3.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gitrev.spec ++++++ --- /var/tmp/diff_new_pack.nIZOVt/_old 2017-08-31 20:51:11.147897974 +0200 +++ /var/tmp/diff_new_pack.nIZOVt/_new 2017-08-31 20:51:11.151897413 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-gitrev # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,22 +18,21 @@ %global pkg_name gitrev Name: ghc-%{pkg_name} -Version: 1.2.0 +Version: 1.3.1 Release: 0 Summary: Compile git revision info into Haskell projects License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: +BuildRequires: ghc-base-compat-devel BuildRequires: ghc-directory-devel BuildRequires: ghc-filepath-devel BuildRequires: ghc-process-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-template-haskell-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description Some handy Template Haskell splices for including the current git hash and @@ -54,15 +53,12 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %post devel %ghc_pkg_recache ++++++ gitrev-1.2.0.tar.gz -> gitrev-1.3.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gitrev-1.2.0/gitrev.cabal new/gitrev-1.3.1/gitrev.cabal --- old/gitrev-1.2.0/gitrev.cabal 2016-01-11 23:53:59.000000000 +0100 +++ new/gitrev-1.3.1/gitrev.cabal 2017-03-17 03:34:52.000000000 +0100 @@ -1,5 +1,5 @@ name: gitrev -version: 1.2.0 +version: 1.3.1 synopsis: Compile git revision info into Haskell projects homepage: https://github.com/acfoltzer/gitrev license: BSD3 @@ -9,6 +9,7 @@ category: Development build-type: Simple cabal-version: >=1.10 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 description: Some handy Template Haskell splices for including the current git hash and branch in the code of your project. Useful for including in panic messages, @--version@ output, or diagnostic info for more informative bug reports. source-repository head @@ -17,10 +18,12 @@ library build-depends: base >= 4.6 && < 5, + base-compat >= 0.6.0, directory, filepath, template-haskell, process hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 exposed-modules: Development.GitRev \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gitrev-1.2.0/src/Development/GitRev.hs new/gitrev-1.3.1/src/Development/GitRev.hs --- old/gitrev-1.2.0/src/Development/GitRev.hs 2016-01-11 23:53:59.000000000 +0100 +++ new/gitrev-1.3.1/src/Development/GitRev.hs 2017-03-17 03:34:52.000000000 +0100 @@ -1,3 +1,6 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + -- | -- Module : $Header$ -- Copyright : (c) 2015 Adam C. Foltzer @@ -29,9 +32,16 @@ -- > % cabal exec runhaskell Example.hs -- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no! -module Development.GitRev (gitHash, gitBranch, gitDirty, gitCommitCount, gitCommitDate) where +module Development.GitRev + ( gitBranch + , gitCommitCount + , gitCommitDate + , gitDescribe + , gitDirty + , gitDirtyTracked + , gitHash + ) where -import Control.Applicative import Control.Exception import Control.Monad import Data.Maybe @@ -42,6 +52,9 @@ import System.FilePath import System.Process +import Prelude () +import Prelude.Compat + -- | Run git with the given arguments and no stdin, returning the -- stdout output. If git isn't available or something goes wrong, -- return the second argument. @@ -53,7 +66,7 @@ if gitFound then do -- a lot of bookkeeping to record the right dependencies - pwd <- runIO getCurrentDirectory + pwd <- runIO getDotGit let hd = pwd </> ".git" </> "HEAD" index = pwd </> ".git" </> "index" packedRefs = pwd </> ".git" </> "packed-refs" @@ -61,8 +74,7 @@ when hdExists $ do -- the HEAD file either contains the hash of a detached head -- or a pointer to the file that contains the hash of the head - hdRef <- runIO $ readFile hd - case splitAt 5 hdRef of + splitAt 5 `fmap` runIO (readFile hd) >>= \case -- pointer to ref ("ref: ", relRef) -> do let ref = pwd </> ".git" </> relRef @@ -85,6 +97,36 @@ ExitFailure _ -> return def else return def +-- | Determine where our @.git@ directory is, in case we're in a +-- submodule. +getDotGit :: IO FilePath +getDotGit = do + pwd <- getGitRoot + let dotGit = pwd </> ".git" + oops = return dotGit -- it's gonna fail, that's fine + isDir <- doesDirectoryExist dotGit + isFile <- doesFileExist dotGit + if | isDir -> return dotGit + | not isFile -> oops + | isFile -> + splitAt 8 `fmap` readFile dotGit >>= \case + ("gitdir: ", relDir) -> do + isRelDir <- doesDirectoryExist relDir + if isRelDir + then return relDir + else oops + _ -> oops + +-- | Get the root directory of the Git repo. +getGitRoot :: IO FilePath +getGitRoot = do + pwd <- getCurrentDirectory + (code, out, _) <- + readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] "" + case code of + ExitSuccess -> return $ takeWhile (/= '\n') out + ExitFailure _ -> return pwd -- later steps will fail, that's fine + -- | Type to flag if the git index is used or not in a call to runGit data IndexUsed = IdxUsed -- ^ The git index is used | IdxNotUsed -- ^ The git index is /not/ used @@ -103,6 +145,12 @@ gitBranch = stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed +-- | Return the long git description for the current git commit, or +-- @UNKNOWN@ if not in a git repository. +gitDescribe :: ExpQ +gitDescribe = + stringE =<< runGit ["describe", "--long", "--always"] "UNKNOWN" IdxNotUsed + -- | Return @True@ if there are non-committed files present in the -- repository gitDirty :: ExpQ @@ -111,6 +159,15 @@ case output of "" -> conE falseName _ -> conE trueName + +-- | Return @True@ if there are non-commited changes to tracked files +-- present in the repository +gitDirtyTracked :: ExpQ +gitDirtyTracked = do + output <- runGit ["status", "--porcelain","--untracked-files=no"] "" IdxUsed + case output of + "" -> conE falseName + _ -> conE trueName -- | Return the number of commits in the current head gitCommitCount :: ExpQ

1 0

commit ghc-ginger for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-ginger for openSUSE:Factory checked in at 2017-08-31 20:51:04 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-ginger (Old) and /work/SRC/openSUSE:Factory/.ghc-ginger.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-ginger" Thu Aug 31 20:51:04 2017 rev:2 rq:513252 version:0.5.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-ginger/ghc-ginger.changes 2017-04-12 18:06:33.507894120 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-ginger.new/ghc-ginger.changes 2017-08-31 20:51:04.828784997 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:56 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.3.0. + +------------------------------------------------------------------- Old: ---- ginger-0.3.9.1.tar.gz New: ---- ginger-0.5.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-ginger.spec ++++++ --- /var/tmp/diff_new_pack.WiS93N/_old 2017-08-31 20:51:05.664667663 +0200 +++ /var/tmp/diff_new_pack.WiS93N/_new 2017-08-31 20:51:05.664667663 +0200 @@ -19,7 +19,7 @@ %global pkg_name ginger %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3.9.1 +Version: 0.5.3.0 Release: 0 Summary: An implementation of the Jinja2 template language in Haskell License: MIT @@ -96,5 +96,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) +%doc CHANGELOG.md README.md %changelog ++++++ ginger-0.3.9.1.tar.gz -> ginger-0.5.3.0.tar.gz ++++++ ++++ 2101 lines of diff (skipped)

1 0

commit ghc-ghc-typelits-knownnat for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-ghc-typelits-knownnat for openSUSE:Factory checked in at 2017-08-31 20:51:01 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-ghc-typelits-knownnat (Old) and /work/SRC/openSUSE:Factory/.ghc-ghc-typelits-knownnat.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-ghc-typelits-knownnat" Thu Aug 31 20:51:01 2017 rev:3 rq:513251 version:0.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-ghc-typelits-knownnat/ghc-ghc-typelits-knownnat.changes 2017-05-17 10:55:28.849317587 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-ghc-typelits-knownnat.new/ghc-ghc-typelits-knownnat.changes 2017-08-31 20:51:03.604956788 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:03:45 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3. + +------------------------------------------------------------------- Old: ---- ghc-typelits-knownnat-0.2.4.tar.gz New: ---- ghc-typelits-knownnat-0.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-ghc-typelits-knownnat.spec ++++++ --- /var/tmp/diff_new_pack.pSs4N2/_old 2017-08-31 20:51:04.600816997 +0200 +++ /var/tmp/diff_new_pack.pSs4N2/_new 2017-08-31 20:51:04.608815875 +0200 @@ -19,7 +19,7 @@ %global pkg_name ghc-typelits-knownnat %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.4 +Version: 0.3 Release: 0 Summary: Derive KnownNat constraints from other KnownNat constraints License: BSD-2-Clause ++++++ ghc-typelits-knownnat-0.2.4.tar.gz -> ghc-typelits-knownnat-0.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-typelits-knownnat-0.2.4/CHANGELOG.md new/ghc-typelits-knownnat-0.3/CHANGELOG.md --- old/ghc-typelits-knownnat-0.2.4/CHANGELOG.md 2017-04-10 17:31:37.000000000 +0200 +++ new/ghc-typelits-knownnat-0.3/CHANGELOG.md 2017-05-15 10:14:32.000000000 +0200 @@ -1,5 +1,8 @@ # Changelog for the [`ghc-typelits-knownnat`](http://hackage.haskell.org/package/ghc-typelits-knownnat) package +## 0.3 *May 15th 2017* +* GHC 8.2.1 support: Underlying representation for `KnownNat` in GHC 8.2 is `Natural`, meaning users of this plugin will need to update their code to use `Natural` for GHC 8.2 as well. + ## 0.2.4 *April 10th 2017* * New features: * Derive constraints for unary functions via a `KnownNat1` instance; thanks to @nshepperd [#11](https://github.com/clash-lang/ghc-typelits-knownnat/pull/11) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-typelits-knownnat-0.2.4/ghc-typelits-knownnat.cabal new/ghc-typelits-knownnat-0.3/ghc-typelits-knownnat.cabal --- old/ghc-typelits-knownnat-0.2.4/ghc-typelits-knownnat.cabal 2017-04-10 17:27:52.000000000 +0200 +++ new/ghc-typelits-knownnat-0.3/ghc-typelits-knownnat.cabal 2017-05-02 10:09:20.000000000 +0200 @@ -1,5 +1,5 @@ name: ghc-typelits-knownnat -version: 0.2.4 +version: 0.3 synopsis: Derive KnownNat constraints from other KnownNat constraints description: A type checker plugin for GHC that can derive \"complex\" @KnownNat@ @@ -81,8 +81,8 @@ TypeInType UndecidableInstances ViewPatterns - build-depends: base >= 4.9 && <4.10, - ghc >= 8.0.1 && <8.2, + build-depends: base >= 4.9 && <5, + ghc >= 8.0.1 && <8.4, ghc-tcplugins-extra >= 0.2, ghc-typelits-natnormalise >= 0.5.2 && <0.6, singletons >= 2.2 && <3.0, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-typelits-knownnat-0.2.4/src/GHC/TypeLits/KnownNat.hs new/ghc-typelits-knownnat-0.3/src/GHC/TypeLits/KnownNat.hs --- old/ghc-typelits-knownnat-0.2.4/src/GHC/TypeLits/KnownNat.hs 2017-04-10 17:27:52.000000000 +0200 +++ new/ghc-typelits-knownnat-0.3/src/GHC/TypeLits/KnownNat.hs 2017-05-02 10:03:24.000000000 +0200 @@ -85,6 +85,7 @@ -} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} @@ -116,15 +117,29 @@ import Data.Bits (shiftL) import Data.Proxy (Proxy (..)) +#if MIN_VERSION_ghc(8,2,0) +import GHC.TypeNats + (KnownNat, Nat, type (+), type (*), type (^), type (-), type (<=), natVal) +import GHC.TypeLits (Symbol) +#else import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), type (*), type (^), type (-), type (<=), natVal) +#endif import Data.Singletons (type (~>), type (@@)) import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) +#if MIN_VERSION_ghc(8,2,0) +import Numeric.Natural (Natural) +#endif import GHC.TypeLits.KnownNat.TH --- | Singleton natural number (represented by an integer) -newtype SNatKn (n :: Nat) = SNatKn Integer +-- | Singleton natural number +newtype SNatKn (n :: Nat) = +#if MIN_VERSION_ghc(8,2,0) + SNatKn Natural +#else + SNatKn Integer +#endif -- | Class for arithmetic functions with /one/ argument. -- @@ -171,7 +186,7 @@ natSing2 = let x = natVal (Proxy @ a) y = natVal (Proxy @ b) z = case x of - 2 -> shiftL 1 (fromInteger y) + 2 -> shiftL 1 (fromIntegral y) _ -> x ^ y in SNatKn z {-# INLINE natSing2 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-typelits-knownnat-0.2.4/tests/Main.hs new/ghc-typelits-knownnat-0.3/tests/Main.hs --- old/ghc-typelits-knownnat-0.2.4/tests/Main.hs 2017-04-10 17:27:52.000000000 +0200 +++ new/ghc-typelits-knownnat-0.3/tests/Main.hs 2017-05-02 10:23:58.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, +{-# LANGUAGE CPP, DataKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, TypeApplications, TypeFamilies, TypeFamilyDependencies, FlexibleContexts #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} @@ -8,7 +8,12 @@ import Data.Proxy import Data.Type.Equality ((:~:)(..)) +#if __GLASGOW_HASKELL__ >= 802 +import GHC.TypeNats +import Numeric.Natural +#else import GHC.TypeLits +#endif import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -16,14 +21,20 @@ import TestFunctions -addT :: Integer -> Integer -> Integer +#if __GLASGOW_HASKELL__ >= 802 +type Number = Natural +#else +type Number = Integer +#endif + +addT :: Number -> Number -> Number addT a b = withNat a $ \(Proxy :: Proxy a) -> withNat b $ \(Proxy :: Proxy b) -> natVal (Proxy :: Proxy (a + b)) -subT :: Integer -> Integer -> Integer +subT :: Number -> Number -> Number subT a b | a >= b = withNat a $ \(Proxy :: Proxy a) -> @@ -34,77 +45,77 @@ natVal (Proxy :: Proxy (a - b)) | otherwise = error "a - b < 0" -mulT :: Integer -> Integer -> Integer +mulT :: Number -> Number -> Number mulT a b = withNat a $ \(Proxy :: Proxy a) -> withNat b $ \(Proxy :: Proxy b) -> natVal (Proxy :: Proxy (a * b)) -maxT :: Integer -> Integer -> Integer +maxT :: Number -> Number -> Number maxT a b = withNat a $ \(Proxy :: Proxy a) -> withNat b $ \(Proxy :: Proxy b) -> natVal (Proxy :: Proxy (Max a b)) -logT :: Integer -> Integer +logT :: Number -> Number logT n = withNat n $ \(Proxy :: Proxy n) -> natVal (Proxy :: Proxy (Log n)) -test1 :: forall n . KnownNat n => Proxy n -> Integer +test1 :: forall n . KnownNat n => Proxy n -> Number test1 _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2)) -test2 :: forall n . KnownNat n => Proxy n -> Integer +test2 :: forall n . KnownNat n => Proxy n -> Number test2 _ = natVal (Proxy :: Proxy (n*3)) -test3 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Integer +test3 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Number test3 _ _ = natVal (Proxy :: Proxy (n+m)) -test4 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Integer +test4 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Number test4 _ _ = natVal (Proxy :: Proxy (n*m)) -test5 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Integer +test5 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Number test5 _ _ = natVal (Proxy :: Proxy (n^m)) -test6 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Integer +test6 :: forall n m . (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Number test6 _ _ = natVal (Proxy :: Proxy ((n^m)+(n*m))) -test7 :: forall n m . (KnownNat m, KnownNat n) => Proxy n -> Proxy m -> Integer +test7 :: forall n m . (KnownNat m, KnownNat n) => Proxy n -> Proxy m -> Number test7 _ _ = natVal (Proxy :: Proxy (Max n m + 1)) -test8 :: forall n m . (KnownNat (Min n m)) => Proxy n -> Proxy m -> Integer +test8 :: forall n m . (KnownNat (Min n m)) => Proxy n -> Proxy m -> Number test8 _ _ = natVal (Proxy :: Proxy (Min n m + 1)) -test9 :: forall n m . (KnownNat m, KnownNat n, n <= m) => Proxy m -> Proxy n -> Integer +test9 :: forall n m . (KnownNat m, KnownNat n, n <= m) => Proxy m -> Proxy n -> Number test9 _ _ = natVal (Proxy :: Proxy (m-n)) -test10 :: forall (n :: Nat) m . (KnownNat m) => Proxy m -> Proxy n -> Integer +test10 :: forall (n :: Nat) m . (KnownNat m) => Proxy m -> Proxy n -> Number test10 _ _ = natVal (Proxy :: Proxy (m-n+n)) -test11 :: forall m . (KnownNat m) => Proxy m -> Integer +test11 :: forall m . (KnownNat m) => Proxy m -> Number test11 _ = natVal (Proxy @ (m*m)) -test12 :: forall m . (KnownNat (m+1)) => Proxy m -> Integer +test12 :: forall m . (KnownNat (m+1)) => Proxy m -> Number test12 = natVal -test13 :: forall m . (KnownNat (m+3)) => Proxy m -> Integer +test13 :: forall m . (KnownNat (m+3)) => Proxy m -> Number test13 = natVal -test14 :: forall m . (KnownNat (4+m)) => Proxy (7+m) -> Integer +test14 :: forall m . (KnownNat (4+m)) => Proxy (7+m) -> Number test14 = natVal type family Foo (m :: Nat) = (result :: Nat) | result -> m fakeFooEvidence :: 1 :~: Foo 1 fakeFooEvidence = unsafeCoerce Refl -test15 :: KnownNat (4 + Foo 1) => Proxy (Foo 1) -> Proxy (4 + Foo 1) -> Integer +test15 :: KnownNat (4 + Foo 1) => Proxy (Foo 1) -> Proxy (4 + Foo 1) -> Number test15 _ _ = natVal (Proxy @ (Foo 1 + 7)) -test16 :: KnownNat (4 + Foo 1 + Foo 1) => Proxy (Foo 1) -> Proxy (4 + Foo 1 + Foo 1) -> Integer +test16 :: KnownNat (4 + Foo 1 + Foo 1) => Proxy (Foo 1) -> Proxy (4 + Foo 1 + Foo 1) -> Number test16 _ _ = natVal (Proxy @ (Foo 1 + 7 + Foo 1)) -test17 :: KnownNat (4 + 2 * Foo 1 + Foo 1) => Proxy (Foo 1) -> Proxy (4 + 2 * Foo 1 + Foo 1) -> Integer +test17 :: KnownNat (4 + 2 * Foo 1 + Foo 1) => Proxy (Foo 1) -> Proxy (4 + 2 * Foo 1 + Foo 1) -> Number test17 _ _ = natVal (Proxy @ (2 * Foo 1 + 7 + Foo 1)) data SNat :: Nat -> * where @@ -131,19 +142,19 @@ test19 :: SNat (a+b) -> SNat b -> SNat a test19 = subSNat -test20 :: forall a . (KnownNat (3 * a - a)) => Proxy a -> Integer +test20 :: forall a . (KnownNat (3 * a - a)) => Proxy a -> Number test20 _ = natVal (Proxy @ (2 * a)) -test21 :: forall m n . (KnownNat (m+n), KnownNat m) => Proxy (m+n) -> Proxy m -> Integer +test21 :: forall m n . (KnownNat (m+n), KnownNat m) => Proxy (m+n) -> Proxy m -> Number test21 _ _ = natVal (Proxy :: Proxy n) -test22 :: forall x y . (KnownNat x, KnownNat y) => Proxy x -> Proxy y -> Integer +test22 :: forall x y . (KnownNat x, KnownNat y) => Proxy x -> Proxy y -> Number test22 _ _ = natVal (Proxy :: Proxy (y*x*y)) test23 :: SNat addrSize -> SNat ((addrSize + 1) - (addrSize - 1)) test23 SNat = SNat -test24 :: (KnownNat n, n ~ (m+1)) => proxy m -> Integer +test24 :: (KnownNat n, n ~ (m+1)) => proxy m -> Number test24 = natVal tests :: TestTree diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-typelits-knownnat-0.2.4/tests/TestFunctions.hs new/ghc-typelits-knownnat-0.3/tests/TestFunctions.hs --- old/ghc-typelits-knownnat-0.2.4/tests/TestFunctions.hs 2017-04-10 17:27:52.000000000 +0200 +++ new/ghc-typelits-knownnat-0.3/tests/TestFunctions.hs 2017-05-02 10:50:43.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, GADTs, KindSignatures, +{-# LANGUAGE CPP, DataKinds, FlexibleInstances, GADTs, KindSignatures, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TemplateHaskell, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} @@ -9,7 +9,12 @@ import Data.Singletons.TH (genDefunSymbols) import Data.Type.Bool (If) import GHC.TypeLits.KnownNat +#if __GLASGOW_HASKELL__ >= 802 +import GHC.TypeNats +import Numeric.Natural +#else import GHC.TypeLits +#endif type family Max (a :: Nat) (b :: Nat) :: Nat where Max 0 b = b -- See [Note: single equation TFs are treated like synonyms] @@ -38,17 +43,26 @@ Min a b = If (a <=? b) a b -- Unary functions. - +#if __GLASGOW_HASKELL__ >= 802 +withNat :: Natural -> (forall n. (KnownNat n) => Proxy n -> r) -> r +withNat n f = case someNatVal n of + SomeNat proxy -> f proxy +#else withNat :: Integer -> (forall n. (KnownNat n) => Proxy n -> r) -> r withNat n f = case someNatVal n of Just (SomeNat proxy) -> f proxy Nothing -> error ("withNat: negative value (" ++ show n ++ ")") +#endif type family Log (n :: Nat) :: Nat where genDefunSymbols [''Log] +#if __GLASGOW_HASKELL__ >= 802 +logInt :: Natural -> Natural +#else logInt :: Integer -> Integer +#endif logInt 0 = error "log 0" logInt n = go 0 where

1 0

commit ghc-ghc-prof for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-ghc-prof for openSUSE:Factory checked in at 2017-08-31 20:50:55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-ghc-prof (Old) and /work/SRC/openSUSE:Factory/.ghc-ghc-prof.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-ghc-prof" Thu Aug 31 20:50:55 2017 rev:2 rq:513250 version:1.4.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-ghc-prof/ghc-ghc-prof.changes 2017-04-12 18:06:32.320062074 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-ghc-prof.new/ghc-ghc-prof.changes 2017-08-31 20:50:55.926034687 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:14 UTC 2017 - psimons(a)suse.com + +- Update to version 1.4.0.1. + +------------------------------------------------------------------- Old: ---- ghc-prof-1.3.0.2.tar.gz New: ---- ghc-prof-1.4.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-ghc-prof.spec ++++++ --- /var/tmp/diff_new_pack.oDj6a9/_old 2017-08-31 20:50:56.521951037 +0200 +++ /var/tmp/diff_new_pack.oDj6a9/_new 2017-08-31 20:50:56.525950476 +0200 @@ -19,7 +19,7 @@ %global pkg_name ghc-prof %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.3.0.2 +Version: 1.4.0.1 Release: 0 Summary: Library for parsing GHC time and allocation profiling reports License: BSD-3-Clause @@ -81,5 +81,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) +%doc CHANGELOG.md README.md %changelog ++++++ ghc-prof-1.3.0.2.tar.gz -> ghc-prof-1.4.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/CHANGELOG.md new/ghc-prof-1.4.0.1/CHANGELOG.md --- old/ghc-prof-1.3.0.2/CHANGELOG.md 1970-01-01 01:00:00.000000000 +0100 +++ new/ghc-prof-1.4.0.1/CHANGELOG.md 2017-04-02 05:47:08.000000000 +0200 @@ -0,0 +1,9 @@ +# Revision history for ghc-prof + +## 1.4.0.1 (2017-04-02) + +* Implement a workaround for a bug in the GHC profiler ([#6](https://github.com/maoe/ghc-prof/issues/6)) + +## 1.4.0 (2017-02-14) + +* Rename AggregateCostCentre to AggregatedCostCentre diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/README.md new/ghc-prof-1.4.0.1/README.md --- old/ghc-prof-1.3.0.2/README.md 1970-01-01 01:00:00.000000000 +0100 +++ new/ghc-prof-1.4.0.1/README.md 2017-02-13 21:41:07.000000000 +0100 @@ -0,0 +1,13 @@ +# ghc-prof: Library for parsing GHC time and allocation profiling reports + +[![Hackage](https://img.shields.io/hackage/v/ghc-prof.svg?maxAge=2592000)](https://hackage.haskell.org/package/ghc-prof) +[![Hackage-Deps](https://img.shields.io/hackage-deps/v/ghc-prof.svg?maxAge=2592000)](https://hackage.haskell.org/package/ghc-prof) +[![Stackage LTS](http://stackage.org/package/ghc-prof/badge/lts)](http://stackage.org/l… +[![Stackage Nightly](http://stackage.org/package/ghc-prof/badge/nightly)](http://stacka… +[![Build Status](https://travis-ci.org/maoe/ghc-prof.svg?branch=master)](https://tra… +[![Gitter](https://img.shields.io/gitter/room/maoe/ghc-prof.svg?maxAge=2592000)](https://gitter.im/maoe/ghc-prof) + +## Applications + +* [profiteur](https://hackage.haskell.org/package/profiteur) +* [viewprof](https://hackage.haskell.org/package/viewprof) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/bin/dump.hs new/ghc-prof-1.4.0.1/bin/dump.hs --- old/ghc-prof-1.3.0.2/bin/dump.hs 2016-12-26 06:52:53.000000000 +0100 +++ new/ghc-prof-1.4.0.1/bin/dump.hs 2017-02-13 21:41:07.000000000 +0100 @@ -22,7 +22,7 @@ Left reason -> fail reason Right prof -> case optMode opts of AggregateMode -> - traverse_ (putStrLn . makeAggregateCCName) $ aggregateCostCentres prof + traverse_ (putStrLn . makeAggregateCCName) $ aggregatedCostCentres prof TreeMode -> case restArgs of [] -> traverse_ putStrLn $ drawTree . fmap makeCCName <$> costCentres prof @@ -44,13 +44,13 @@ (showScientific $ costCentreInhAlloc cc) (showScientific $ costCentreIndAlloc cc) -makeAggregateCCName :: AggregateCostCentre -> String +makeAggregateCCName :: AggregatedCostCentre -> String makeAggregateCCName aggregate = printf "%s%%\t%s%%\t%s.%s" - (showScientific $ aggregateCostCentreTime aggregate) - (showScientific $ aggregateCostCentreAlloc aggregate) - (T.unpack $ aggregateCostCentreModule aggregate) - (T.unpack $ aggregateCostCentreName aggregate) + (showScientific $ aggregatedCostCentreTime aggregate) + (showScientific $ aggregatedCostCentreAlloc aggregate) + (T.unpack $ aggregatedCostCentreModule aggregate) + (T.unpack $ aggregatedCostCentreName aggregate) showScientific :: Scientific -> String showScientific = formatScientific Fixed Nothing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/ghc-prof.cabal new/ghc-prof-1.4.0.1/ghc-prof.cabal --- old/ghc-prof-1.3.0.2/ghc-prof.cabal 2017-01-30 05:40:26.000000000 +0100 +++ new/ghc-prof-1.4.0.1/ghc-prof.cabal 2017-04-02 05:48:26.000000000 +0200 @@ -1,5 +1,5 @@ name: ghc-prof -version: 1.3.0.2 +version: 1.4.0.1 synopsis: Library for parsing GHC time and allocation profiling reports description: Library for parsing GHC time and allocation profiling reports homepage: https://github.com/maoe/ghc-prof @@ -7,9 +7,12 @@ license-file: LICENSE author: Mitsutoshi Aoe maintainer: Mitsutoshi Aoe <maoe(a)foldr.in> -copyright: Copyright (C) 2013-2016 Mitsutoshi Aoe +copyright: Copyright (C) 2013-2017 Mitsutoshi Aoe category: Development build-type: Simple +extra-source-files: + CHANGELOG.md + README.md cabal-version: >=1.10 tested-with: GHC >= 7.6 && <= 8.0.2 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/src/GHC/Prof/CostCentreTree.hs new/ghc-prof-1.4.0.1/src/GHC/Prof/CostCentreTree.hs --- old/ghc-prof-1.3.0.2/src/GHC/Prof/CostCentreTree.hs 2017-01-30 00:24:13.000000000 +0100 +++ new/ghc-prof-1.4.0.1/src/GHC/Prof/CostCentreTree.hs 2017-04-01 00:05:08.000000000 +0200 @@ -5,8 +5,8 @@ module GHC.Prof.CostCentreTree ( -- * Cost center breakdown -- ** Aggregate cost centres - aggregateCostCentres - , aggregateCostCentresOrderBy + aggregatedCostCentres + , aggregatedCostCentresOrderBy -- ** Cost centre trees , costCentres @@ -26,7 +26,7 @@ , aggregateModulesOrderBy -- * Low level functions - , buildAggregateCostCentresOrderBy + , buildAggregatedCostCentresOrderBy , buildCostCentresOrderBy , buildCallSitesOrderBy , buildAggregateCallSitesOrderBy @@ -58,21 +58,21 @@ -- | Build a list of cost-centres from a profiling report ordered by the time -- spent and the amount of allocation. -aggregateCostCentres :: Profile -> [AggregateCostCentre] -aggregateCostCentres = aggregateCostCentresOrderBy sortKey +aggregatedCostCentres :: Profile -> [AggregatedCostCentre] +aggregatedCostCentres = aggregatedCostCentresOrderBy sortKey where - sortKey = aggregateCostCentreTime &&& aggregateCostCentreAlloc + sortKey = aggregatedCostCentreTime &&& aggregatedCostCentreAlloc -- | Build a list of cost-centres from a profling report ordered by the given -- key. -aggregateCostCentresOrderBy +aggregatedCostCentresOrderBy :: Ord a - => (AggregateCostCentre -> a) + => (AggregatedCostCentre -> a) -- ^ Sorting key function -> Profile - -> [AggregateCostCentre] -aggregateCostCentresOrderBy sortKey = - buildAggregateCostCentresOrderBy sortKey . profileCostCentreTree + -> [AggregatedCostCentre] +aggregatedCostCentresOrderBy sortKey = + buildAggregatedCostCentresOrderBy sortKey . profileCostCentreTree -- | Build a tree of cost-centres from a profiling report. costCentres :: Profile -> Maybe (Tree CostCentre) @@ -102,26 +102,26 @@ -> Text -- ^ Module name -> Profile - -> Maybe (AggregateCostCentre, [CallSite AggregateCostCentre]) + -> Maybe (AggregatedCostCentre, [CallSite AggregatedCostCentre]) aggregateCallSites = aggregateCallSitesOrderBy sortKey where sortKey = callSiteContribTime &&& callSiteContribAlloc - &&& aggregateCostCentreTime . callSiteCostCentre - &&& aggregateCostCentreAlloc . callSiteCostCentre + &&& aggregatedCostCentreTime . callSiteCostCentre + &&& aggregatedCostCentreAlloc . callSiteCostCentre -- | Build a list of call sites (caller functions of a cost centre) aggregated -- by their cost centre names and module names. Call sites are sorted by the -- given key function. aggregateCallSitesOrderBy :: Ord a - => (CallSite AggregateCostCentre -> a) + => (CallSite AggregatedCostCentre -> a) -- ^ Sorting key function -> Text -- ^ Cost centre name -> Text -- ^ Module name -> Profile - -> Maybe (AggregateCostCentre, [CallSite AggregateCostCentre]) + -> Maybe (AggregatedCostCentre, [CallSite AggregatedCostCentre]) aggregateCallSitesOrderBy sortKey name modName = buildAggregateCallSitesOrderBy sortKey name modName . profileCostCentreTree @@ -133,7 +133,7 @@ -> Text -- ^ Module name -> Profile - -> Maybe (AggregateCostCentre, [CallSite CostCentre]) + -> Maybe (AggregatedCostCentre, [CallSite CostCentre]) callSites = callSitesOrderBy sortKey where sortKey = callSiteContribTime &&& callSiteContribAlloc @@ -152,7 +152,7 @@ -> Text -- ^ Module name -> Profile - -> Maybe (AggregateCostCentre, [CallSite CostCentre]) + -> Maybe (AggregatedCostCentre, [CallSite CostCentre]) callSitesOrderBy sortKey name modName = buildCallSitesOrderBy sortKey name modName . profileCostCentreTree @@ -176,12 +176,12 @@ ----------------------------------------------------------- -buildAggregateCostCentresOrderBy +buildAggregatedCostCentresOrderBy :: Ord a - => (AggregateCostCentre -> a) + => (AggregatedCostCentre -> a) -> CostCentreTree - -> [AggregateCostCentre] -buildAggregateCostCentresOrderBy sortKey CostCentreTree {..} = + -> [AggregatedCostCentre] +buildAggregatedCostCentresOrderBy sortKey CostCentreTree {..} = sortBy (flip compare `on` sortKey) $ concatMap Map.elems $ Map.elems $ costCentreAggregate @@ -208,14 +208,14 @@ buildAggregateCallSitesOrderBy :: Ord a - => (CallSite AggregateCostCentre -> a) + => (CallSite AggregatedCostCentre -> a) -- ^ Sorting key function -> Text -- ^ Cost centre name -> Text -- ^ Module name -> CostCentreTree - -> Maybe (AggregateCostCentre, [CallSite AggregateCostCentre]) + -> Maybe (AggregatedCostCentre, [CallSite AggregatedCostCentre]) buildAggregateCallSitesOrderBy sortKey name modName tree@CostCentreTree {..} = (,) <$> callee <*> callers where @@ -227,9 +227,9 @@ buildAggregateCallSite :: CostCentreTree - -> Map.Map (Text, Text) (CallSite AggregateCostCentre) + -> Map.Map (Text, Text) (CallSite AggregatedCostCentre) -> CostCentre - -> Maybe (Map.Map (Text, Text) (CallSite AggregateCostCentre)) + -> Maybe (Map.Map (Text, Text) (CallSite AggregatedCostCentre)) buildAggregateCallSite CostCentreTree {..} parents CostCentre {..} = do parentNo <- IntMap.lookup costCentreNo costCentreParents parent <- IntMap.lookup parentNo costCentreNodes @@ -271,7 +271,7 @@ -> Text -- ^ Module name -> CostCentreTree - -> Maybe (AggregateCostCentre, [CallSite CostCentre]) + -> Maybe (AggregatedCostCentre, [CallSite CostCentre]) buildCallSitesOrderBy sortKey name modName tree@CostCentreTree {..} = (,) <$> callee <*> callers where @@ -311,25 +311,25 @@ costCentreAggregate where aggregateModule modName = Map.foldl' add (emptyAggregateModule modName) - add aggMod AggregateCostCentre {..} = aggMod + add aggMod AggregatedCostCentre {..} = aggMod { aggregateModuleEntries = seqM $ (+) <$> aggregateModuleEntries aggMod - <*> aggregateCostCentreEntries + <*> aggregatedCostCentreEntries , aggregateModuleTime = - aggregateModuleTime aggMod + aggregateCostCentreTime + aggregateModuleTime aggMod + aggregatedCostCentreTime , aggregateModuleAlloc = - aggregateModuleAlloc aggMod + aggregateCostCentreAlloc + aggregateModuleAlloc aggMod + aggregatedCostCentreAlloc , aggregateModuleTicks = seqM $ (+) <$> aggregateModuleTicks aggMod - <*> aggregateCostCentreTicks + <*> aggregatedCostCentreTicks , aggregateModuleBytes = seqM $ (+) <$> aggregateModuleBytes aggMod - <*> aggregateCostCentreBytes + <*> aggregatedCostCentreBytes } lookupAggregate :: Text -- ^ Cost centre name -> Text -- ^ Module name - -> Map.Map Text (Map.Map Text AggregateCostCentre) - -> Maybe AggregateCostCentre + -> Map.Map Text (Map.Map Text AggregatedCostCentre) + -> Maybe AggregatedCostCentre lookupAggregate name modName m = Map.lookup modName m >>= Map.lookup name diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/src/GHC/Prof/Parser.hs new/ghc-prof-1.4.0.1/src/GHC/Prof/Parser.hs --- old/ghc-prof-1.3.0.2/src/GHC/Prof/Parser.hs 2017-01-30 05:39:48.000000000 +0100 +++ new/ghc-prof-1.4.0.1/src/GHC/Prof/Parser.hs 2017-04-02 05:46:52.000000000 +0200 @@ -13,13 +13,13 @@ , totalTime , totalAlloc , topCostCentres - , aggregateCostCentre + , aggregatedCostCentre , costCentres , costCentre ) where import Control.Applicative import Control.Monad -import Data.Char (isSpace) +import Data.Char (isDigit, isSpace) import Data.Foldable (asum, foldl') import Data.Maybe import Data.Time @@ -28,6 +28,7 @@ import Data.Attoparsec.Text as A import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.Read as TR import Control.Monad.Extras (seqM) import GHC.Prof.Types @@ -151,13 +152,13 @@ return HeaderParams {..} -topCostCentres :: Parser [AggregateCostCentre] +topCostCentres :: Parser [AggregatedCostCentre] topCostCentres = do params <- header; skipSpace - aggregateCostCentre params `sepBy1` endOfLine + aggregatedCostCentre params `sepBy1` endOfLine -aggregateCostCentre :: HeaderParams -> Parser AggregateCostCentre -aggregateCostCentre HeaderParams {..} = AggregateCostCentre +aggregatedCostCentre :: HeaderParams -> Parser AggregatedCostCentre +aggregatedCostCentre HeaderParams {..} = AggregatedCostCentre <$> symbol <* skipHorizontalSpace -- name <*> symbol <* skipHorizontalSpace -- module <*> source <* skipHorizontalSpace -- src @@ -177,22 +178,10 @@ costCentreTree params costCentre :: HeaderParams -> Parser CostCentre -costCentre HeaderParams {..} = do +costCentre params = do name <- symbol; skipHorizontalSpace - modName <- symbol; skipHorizontalSpace - src <- if headerHasSrc - then do - !sym <- sourceSpan - return $ Just sym - else pure Nothing - skipHorizontalSpace - no <- decimal; skipHorizontalSpace - entries <- decimal; skipHorizontalSpace - indTime <- scientific; skipHorizontalSpace - indAlloc <- scientific; skipHorizontalSpace - inhTime <- scientific; skipHorizontalSpace - inhAlloc <- scientific; skipHorizontalSpace - optInfo <- optional optionalInfo + (modName, src, no, (entries, indTime, indAlloc, inhTime, inhAlloc, optInfo)) + <- validCostCentre params <|> jammedCostCentre return $! CostCentre { costCentreName = name , costCentreModule = modName @@ -207,11 +196,40 @@ , costCentreBytes = snd <$> optInfo } where - optionalInfo = do - !ticks <- decimal + validCostCentre HeaderParams {..} = do + modName <- symbol; skipHorizontalSpace + src <- if headerHasSrc + then do + !sym <- sourceSpan + return $ Just sym + else pure Nothing skipHorizontalSpace - !bytes <- decimal - return (ticks, bytes) + no <- decimal; skipHorizontalSpace + vals <- metrics + return (modName, src, no, vals) + -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/8811. + -- This bug had been fixed before the SRC column was implemented so + -- @sourceSpan@ isn't parsed here. + -- Caveat: This parser can be confused if module name contains digits and + -- the digits are jammed with the cost centre number. In such cases, all + -- the digits are parsed as a number of entries. + jammedCostCentre = do + jammed <- symbol; skipHorizontalSpace + let modName = T.dropWhileEnd isDigit jammed + no <- either fail (return . fst) $ TR.decimal $ T.takeWhileEnd isDigit jammed + vals <- metrics + return (modName, Nothing, no, vals) + metrics = do + entries <- decimal; skipHorizontalSpace + indTime <- scientific; skipHorizontalSpace + indAlloc <- scientific; skipHorizontalSpace + inhTime <- scientific; skipHorizontalSpace + inhAlloc <- scientific; skipHorizontalSpace + optInfo <- optional $ do + !ticks <- decimal; skipHorizontalSpace + !bytes <- decimal + return (ticks, bytes) + return (entries, indTime, indAlloc, inhTime, inhAlloc, optInfo) costCentreTree :: HeaderParams -> Parser CostCentreTree costCentreTree params = buildTree <$> costCentreList @@ -282,19 +300,19 @@ (costCentreModule node) costCentreAggregate } - aggregate = AggregateCostCentre - { aggregateCostCentreName = costCentreName node - , aggregateCostCentreModule = costCentreModule node - , aggregateCostCentreSrc = costCentreSrc node - , aggregateCostCentreEntries = Just $! costCentreEntries node - , aggregateCostCentreTime = costCentreIndTime node - , aggregateCostCentreAlloc = costCentreIndAlloc node - , aggregateCostCentreTicks = costCentreTicks node - , aggregateCostCentreBytes = costCentreBytes node + aggregate = AggregatedCostCentre + { aggregatedCostCentreName = costCentreName node + , aggregatedCostCentreModule = costCentreModule node + , aggregatedCostCentreSrc = costCentreSrc node + , aggregatedCostCentreEntries = Just $! costCentreEntries node + , aggregatedCostCentreTime = costCentreIndTime node + , aggregatedCostCentreAlloc = costCentreIndAlloc node + , aggregatedCostCentreTicks = costCentreTicks node + , aggregatedCostCentreBytes = costCentreBytes node } updateCostCentre - :: Maybe (Map.Map Text AggregateCostCentre) - -> Map.Map Text AggregateCostCentre + :: Maybe (Map.Map Text AggregatedCostCentre) + -> Map.Map Text AggregatedCostCentre updateCostCentre = \case Nothing -> Map.singleton (costCentreName node) aggregate Just costCentreByName -> @@ -304,19 +322,19 @@ aggregate costCentreByName addCostCentre x y = x - { aggregateCostCentreEntries = seqM $ (+) - <$> aggregateCostCentreEntries x - <*> aggregateCostCentreEntries y - , aggregateCostCentreTime = - aggregateCostCentreTime x + aggregateCostCentreTime y - , aggregateCostCentreAlloc = - aggregateCostCentreAlloc x + aggregateCostCentreAlloc y - , aggregateCostCentreTicks = seqM $ (+) - <$> aggregateCostCentreTicks x - <*> aggregateCostCentreTicks y - , aggregateCostCentreBytes = seqM $ (+) - <$> aggregateCostCentreBytes x - <*> aggregateCostCentreBytes y + { aggregatedCostCentreEntries = seqM $ (+) + <$> aggregatedCostCentreEntries x + <*> aggregatedCostCentreEntries y + , aggregatedCostCentreTime = + aggregatedCostCentreTime x + aggregatedCostCentreTime y + , aggregatedCostCentreAlloc = + aggregatedCostCentreAlloc x + aggregatedCostCentreAlloc y + , aggregatedCostCentreTicks = seqM $ (+) + <$> aggregatedCostCentreTicks x + <*> aggregatedCostCentreTicks y + , aggregatedCostCentreBytes = seqM $ (+) + <$> aggregatedCostCentreBytes x + <*> aggregatedCostCentreBytes y } howMany :: Parser a -> Parser Int diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/src/GHC/Prof/Types.hs new/ghc-prof-1.4.0.1/src/GHC/Prof/Types.hs --- old/ghc-prof-1.3.0.2/src/GHC/Prof/Types.hs 2017-01-30 00:24:13.000000000 +0100 +++ new/ghc-prof-1.4.0.1/src/GHC/Prof/Types.hs 2017-02-13 21:41:07.000000000 +0100 @@ -16,7 +16,7 @@ , profileCommandLine :: !Text , profileTotalTime :: !TotalTime , profileTotalAlloc :: !TotalAlloc - , profileTopCostCentres :: [AggregateCostCentre] + , profileTopCostCentres :: [AggregatedCostCentre] , profileCostCentreTree :: !CostCentreTree } deriving Show @@ -38,23 +38,23 @@ -- ^ Total memory allocation in bytes } deriving Show -data AggregateCostCentre = AggregateCostCentre - { aggregateCostCentreName :: !Text +data AggregatedCostCentre = AggregatedCostCentre + { aggregatedCostCentreName :: !Text -- ^ Name of the cost-centre - , aggregateCostCentreModule :: !Text + , aggregatedCostCentreModule :: !Text -- ^ Module name of the cost-centre - , aggregateCostCentreSrc :: !(Maybe Text) + , aggregatedCostCentreSrc :: !(Maybe Text) -- ^ Source location of the cost-centre - , aggregateCostCentreEntries :: !(Maybe Integer) + , aggregatedCostCentreEntries :: !(Maybe Integer) -- ^ Number of entries to the cost-centre - , aggregateCostCentreTime :: !Scientific + , aggregatedCostCentreTime :: !Scientific -- ^ Total time spent in the cost-centre - , aggregateCostCentreAlloc :: !Scientific + , aggregatedCostCentreAlloc :: !Scientific -- ^ Total allocation in the cost-centre - , aggregateCostCentreTicks :: !(Maybe Integer) + , aggregatedCostCentreTicks :: !(Maybe Integer) -- ^ Total ticks in the cost-centre. This number exists only if -- @-P@ or @-Pa@ option is given at run-time. - , aggregateCostCentreBytes :: !(Maybe Integer) + , aggregatedCostCentreBytes :: !(Maybe Integer) -- ^ Total memory allocation in the cost-centre. This number -- exists only if @-P@ or @-Pa@ option is given at run-time. } deriving (Show, Eq, Ord) @@ -92,7 +92,7 @@ , costCentreParents :: !(IntMap CostCentreNo) , costCentreChildren :: !(IntMap (Set CostCentre)) , costCentreCallSites :: !(Map (Text, Text) (Set CostCentre)) - , costCentreAggregate :: !(Map Text (Map Text AggregateCostCentre)) + , costCentreAggregate :: !(Map Text (Map Text AggregatedCostCentre)) } deriving Show emptyCostCentreTree :: CostCentreTree diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/src/GHC/Prof.hs new/ghc-prof-1.4.0.1/src/GHC/Prof.hs --- old/ghc-prof-1.3.0.2/src/GHC/Prof.hs 2017-01-30 00:24:13.000000000 +0100 +++ new/ghc-prof-1.4.0.1/src/GHC/Prof.hs 2017-04-01 00:05:08.000000000 +0200 @@ -6,8 +6,8 @@ -- * Cost-centre tree , CostCentreTree - , aggregateCostCentres - , aggregateCostCentresOrderBy + , aggregatedCostCentres + , aggregatedCostCentresOrderBy , costCentres , costCentresOrderBy , aggregateCallSites @@ -21,7 +21,7 @@ , Profile(..) , TotalTime(..) , TotalAlloc(..) - , AggregateCostCentre(..) + , AggregatedCostCentre(..) , CostCentre(..) , CostCentreNo , CallSite(..) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/ghc-prof-1.3.0.2/tests/Regression.hs new/ghc-prof-1.4.0.1/tests/Regression.hs --- old/ghc-prof-1.3.0.2/tests/Regression.hs 2016-12-26 06:52:53.000000000 +0100 +++ new/ghc-prof-1.4.0.1/tests/Regression.hs 2017-04-02 05:48:26.000000000 +0200 @@ -62,36 +62,36 @@ text <- TL.readFile path case ATL.parse profile text of ATL.Done _ prof -> do - let actual = Set.fromList $ map Similar $ aggregateCostCentres prof + let actual = Set.fromList $ map Similar $ aggregatedCostCentres prof expected = Set.fromList $ map Similar $ profileTopCostCentres prof assertBool ("Missing cost centre(s): " ++ show (Set.difference expected actual)) $ Set.isSubsetOf expected actual ATL.Fail _ _ reason -> assertFailure reason -newtype Similar = Similar AggregateCostCentre +newtype Similar = Similar AggregatedCostCentre instance Show Similar where show (Similar a) = show a instance Eq Similar where Similar a == Similar b = - aggregateCostCentreName a == aggregateCostCentreName b - && aggregateCostCentreModule a == aggregateCostCentreModule b - && aggregateCostCentreTime a == aggregateCostCentreTime b - && aggregateCostCentreAlloc a == aggregateCostCentreAlloc b - && aggregateCostCentreTicks a == aggregateCostCentreTicks b - && aggregateCostCentreBytes a == aggregateCostCentreBytes b + aggregatedCostCentreName a == aggregatedCostCentreName b + && aggregatedCostCentreModule a == aggregatedCostCentreModule b + && aggregatedCostCentreTime a == aggregatedCostCentreTime b + && aggregatedCostCentreAlloc a == aggregatedCostCentreAlloc b + && aggregatedCostCentreTicks a == aggregatedCostCentreTicks b + && aggregatedCostCentreBytes a == aggregatedCostCentreBytes b instance Ord Similar where compare (Similar a) (Similar b) = - compare (aggregateCostCentreName a) (aggregateCostCentreName b) - <> compare (aggregateCostCentreModule a) (aggregateCostCentreModule b) - <> compare (aggregateCostCentreTime a) (aggregateCostCentreTime b) - <> compare (aggregateCostCentreAlloc a) (aggregateCostCentreAlloc b) - <> compare (aggregateCostCentreTicks a) (aggregateCostCentreTicks b) - <> compare (aggregateCostCentreBytes a) (aggregateCostCentreBytes b) + compare (aggregatedCostCentreName a) (aggregatedCostCentreName b) + <> compare (aggregatedCostCentreModule a) (aggregatedCostCentreModule b) + <> compare (aggregatedCostCentreTime a) (aggregatedCostCentreTime b) + <> compare (aggregatedCostCentreAlloc a) (aggregatedCostCentreAlloc b) + <> compare (aggregatedCostCentreTicks a) (aggregatedCostCentreTicks b) + <> compare (aggregatedCostCentreBytes a) (aggregatedCostCentreBytes b) #if !MIN_VERSION_directory(1, 2, 3) withCurrentDirectory :: FilePath -> IO a -> IO a

1 0

commit ghc-ghc-exactprint for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-ghc-exactprint for openSUSE:Factory checked in at 2017-08-31 20:50:53 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-ghc-exactprint (Old) and /work/SRC/openSUSE:Factory/.ghc-ghc-exactprint.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-ghc-exactprint" Thu Aug 31 20:50:53 2017 rev:5 rq:513249 version:0.5.5.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-ghc-exactprint/ghc-ghc-exactprint.changes 2017-06-04 01:57:26.640417009 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-ghc-exactprint.new/ghc-ghc-exactprint.changes 2017-08-31 20:50:54.686208723 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:04 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.5.0. + +------------------------------------------------------------------- Old: ---- ghc-exactprint-0.5.3.1.tar.gz New: ---- ghc-exactprint-0.5.5.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-ghc-exactprint.spec ++++++ --- /var/tmp/diff_new_pack.1S7Q64/_old 2017-08-31 20:50:55.494095319 +0200 +++ /var/tmp/diff_new_pack.1S7Q64/_new 2017-08-31 20:50:55.494095319 +0200 @@ -19,7 +19,7 @@ %global pkg_name ghc-exactprint %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.3.1 +Version: 0.5.5.0 Release: 0 Summary: ExactPrint for GHC License: BSD-3-Clause @@ -62,6 +62,9 @@ * Print - converts an AST and its annotations to properly formatted source text. +* Pretty - adds annotations to an AST (fragment) so that the output can be +parsed back to the same AST. + Note: requires GHC 7.10.2 or later. %package devel ++++++ ghc-exactprint-0.5.3.1.tar.gz -> ghc-exactprint-0.5.5.0.tar.gz ++++++ ++++ 13401 lines of diff (skipped)

1 0

commit ghc-generics-sop for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-generics-sop for openSUSE:Factory checked in at 2017-08-31 20:50:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-generics-sop (Old) and /work/SRC/openSUSE:Factory/.ghc-generics-sop.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-generics-sop" Thu Aug 31 20:50:51 2017 rev:9 rq:513247 version:0.3.1.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-generics-sop/ghc-generics-sop.changes 2017-06-04 01:53:23.878714201 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-generics-sop.new/ghc-generics-sop.changes 2017-08-31 20:50:51.890601144 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.1.0. + +------------------------------------------------------------------- Old: ---- generics-sop-0.2.5.0.tar.gz New: ---- generics-sop-0.3.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-generics-sop.spec ++++++ --- /var/tmp/diff_new_pack.aplvdM/_old 2017-08-31 20:50:53.082433845 +0200 +++ /var/tmp/diff_new_pack.aplvdM/_new 2017-08-31 20:50:53.090432723 +0200 @@ -18,7 +18,7 @@ %global pkg_name generics-sop Name: ghc-%{pkg_name} -Version: 0.2.5.0 +Version: 0.3.1.0 Release: 0 Summary: Generic Programming using True Sums of Products License: BSD-3-Clause ++++++ generics-sop-0.2.5.0.tar.gz -> generics-sop-0.3.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/CHANGELOG.md new/generics-sop-0.3.1.0/CHANGELOG.md --- old/generics-sop-0.2.5.0/CHANGELOG.md 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/CHANGELOG.md 2017-06-11 15:25:51.000000000 +0200 @@ -1,3 +1,54 @@ +# 0.3.1.0 (2017-06-11) + +* Add AllZip, htrans, hcoerce, hfromI, htoI. + These functions are for converting between related + structures that do not have common signatures. + + The most common application of these functions seems + to be the scenario where a datatype has components + that are all wrapped in a common type constructor + application, e.g. a datatype where every component + is a `Maybe`. Then we can use `hfromI` after `from` + to turn the generically derived `SOP` of `I`s into + an `SOP` of `Maybe`s (and back). + +* Add `IsProductType`, `IsEnumType`, `IsWrappedType` + and `IsNewtype` constraint synonyms capturing + specific classes of datypes. + +# 0.3.0.0 (2017-04-29) + +* No longer compatible with GHC 7.6, due to the lack of + support for type-level literals. + +* Support type-level metadata. This is provided by the + `Generics.SOP.Type.Metadata` module. The two modules + `Generics.SOP.Metadata` and `Generics.SOP.Type.Metadata` + export nearly the same names, so for backwards compatibility, + we keep exporting `Generics.SOP.Metadata` directly from + `Generics.SOP`, whereas `Generics.SOP.Type.Metadata` is + supposed to be imported explicitly (and qualified). + + Term-level metadata is still available, but is now usually + computed automatically from the type-level metadata which + contains the same information, using the function + `demoteDatatypeInfo`. Term-level metadata is unchanged + from generics-sop-0.2, so in most cases, even if your + code makes use of metadata, you should not need to change + anything. + + If you use TH deriving, then both type-level metadata and + term-level metadata is generated for you automatically, + for all supported GHC versions. + + If you use GGP deriving, then type-level metadata is + available if you use GHC 8.0 or newer. If you use GHC 7.x, + then GHC.Generics supports only term-level metadata, so + we cannot translate that into type-level metadata. In + this combination, you cannot use code that relies on + type-level metadata, so you should either upgrade GHC or + switch to TH-based deriving. + # 0.2.5.0 (2017-04-21) * GHC 8.2 compatibility. @@ -79,8 +130,8 @@ hcliftA' p = hcliftA (allP p) where - allP :: proxy c -> Proxy (All c) - allP _ = Proxy + allP :: proxy c -> Proxy (All c) + allP _ = Proxy * Because `All` and `All2` are now type classes, they now have superclass constraints implying that the type-level lists they @@ -99,7 +150,7 @@ For one-dimensional type-level lists, replace - SingI xs => ... + SingI xs => ... by diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/generics-sop.cabal new/generics-sop-0.3.1.0/generics-sop.cabal --- old/generics-sop-0.2.5.0/generics-sop.cabal 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/generics-sop.cabal 2017-06-11 15:25:51.000000000 +0200 @@ -1,5 +1,5 @@ name: generics-sop -version: 0.2.5.0 +version: 0.3.1.0 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions. @@ -37,7 +37,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.1.* +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.1.* source-repository head type: git @@ -48,6 +48,7 @@ Generics.SOP.GGP Generics.SOP.TH Generics.SOP.Dict + Generics.SOP.Type.Metadata -- exposed via Generics.SOP: Generics.SOP.BasicFunctors Generics.SOP.Classes @@ -58,7 +59,7 @@ Generics.SOP.NS Generics.SOP.Universe Generics.SOP.Sing - build-depends: base >= 4.6 && < 5, + build-depends: base >= 4.7 && < 5, template-haskell >= 2.8 && < 2.13, ghc-prim >= 0.3 && < 0.6, deepseq >= 1.3 && < 1.5 @@ -100,9 +101,10 @@ if impl (ghc < 7.10) other-extensions: OverlappingInstances -test-suite generic-sop-examples +test-suite generics-sop-examples type: exitcode-stdio-1.0 main-is: Example.hs + other-modules: HTransExample hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Classes.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Classes.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Classes.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Classes.hs 2017-06-11 15:25:51.000000000 +0200 @@ -39,6 +39,7 @@ , fn_2 , fn_3 , fn_4 + , Same , Prod , HAp(..) -- ** Derived functions @@ -69,6 +70,10 @@ , HApInjs(..) -- * Expanding sums to products , HExpand(..) + -- * Transformation of index lists and coercions + , HTrans(..) + , hfromI + , htoI ) where #if !(MIN_VERSION_base(4,8,0)) @@ -147,6 +152,9 @@ fn_3 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> f x x' x'' fn_4 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> Fn $ \x''' -> f x x' x'' x''' +-- | Maps a structure to the same structure. +type family Same (h :: (k1 -> *) -> (l1 -> *)) :: (k2 -> *) -> (l2 -> *) + -- | Maps a structure containing sums to the corresponding -- product structure. type family Prod (h :: (k -> *) -> (l -> *)) :: (k -> *) -> (l -> *) @@ -519,5 +527,56 @@ -- hcexpand :: (AllN (Prod h) c xs) => proxy c -> (forall x . c x => f x) -> h f xs -> Prod h f xs +-- | A class for transforming structures into related structures with +-- a different index list, as long as the index lists have the same shape +-- and the elements and interpretation functions are suitably related. +-- +-- @since 0.3.1.0 +-- +class (Same h1 ~ h2, Same h2 ~ h1) => HTrans (h1 :: (k1 -> *) -> (l1 -> *)) (h2 :: (k2 -> *) -> (l2 -> *)) where + + -- | Transform a structure into a related structure given a conversion + -- function for the elements. + -- + -- @since 0.3.1.0 + -- + htrans :: + AllZipN (Prod h1) c xs ys + => proxy c + -> (forall x y . c x y => f x -> g y) + -> h1 f xs -> h2 g ys + + -- | Coerce a structure into a representationally equal structure. + -- + -- /Examples:/ + -- + -- >>> hcoerce (I (Just LT) :* I (Just 'x') :* I (Just True) :* Nil) :: NP Maybe '[Ordering, Char, Bool] + -- Just LT :* (Just 'x' :* (Just True :* Nil)) + -- >>> hcoerce (SOP (Z (K True :* K False :* Nil))) :: SOP I '[ '[Bool, Bool], '[Bool] ] + -- SOP (Z (I True :* (I False :* Nil))) + -- + -- @since 0.3.1.0 + hcoerce :: + (AllZipN (Prod h1) (LiftedCoercible f g) xs ys, HTrans h1 h2) + => h1 f xs -> h2 g ys + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +hfromI :: + (AllZipN (Prod h1) (LiftedCoercible I f) xs ys, HTrans h1 h2) + => h1 I xs -> h2 f ys +hfromI = hcoerce + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +htoI :: + (AllZipN (Prod h1) (LiftedCoercible f I) xs ys, HTrans h1 h2) + => h1 f xs -> h2 I ys +htoI = hcoerce + -- $setup -- >>> import Generics.SOP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Constraint.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Constraint.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Constraint.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Constraint.hs 2017-06-11 15:25:51.000000000 +0200 @@ -17,7 +17,9 @@ , Constraint ) where +import Data.Coerce import GHC.Exts (Constraint) + import Generics.SOP.Sing -- | Require a constraint for every element of a list. @@ -46,9 +48,10 @@ -- | Type family used to implement 'All'. -- -type family AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint -type instance AllF _c '[] = () -type instance AllF c (x ': xs) = (c x, All c xs) +type family + AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint where + AllF _c '[] = () + AllF c (x ': xs) = (c x, All c xs) -- | Require a singleton for every inner list in a list of lists. type SListI2 = All SListI @@ -87,6 +90,83 @@ -- it triggers GHC's superclass cycle check when used in a -- class context. +-- | Require a constraint for pointwise for every pair of +-- elements from two lists. +-- +-- /Example:/ The constraint +-- +-- > All (~) '[ Int, Bool, Char ] '[ a, b, c ] +-- +-- is equivalent to the constraint +-- +-- > (Int ~ a, Bool ~ b, Char ~ c) +-- +-- @since 0.3.1.0 +-- +class + ( SListI xs, SListI ys + , SameShapeAs xs ys, SameShapeAs ys xs + , AllZipF c xs ys + ) => AllZip (c :: a -> b -> Constraint) (xs :: [a]) (ys :: [b]) +instance + ( SListI xs, SListI ys + , SameShapeAs xs ys, SameShapeAs ys xs + , AllZipF c xs ys + ) => AllZip c xs ys + +-- | Type family used to implement 'AllZip'. +-- +-- @since 0.3.1.0 +-- +type family + AllZipF (c :: a -> b -> Constraint) (xs :: [a]) (ys :: [b]) + :: Constraint where + AllZipF _c '[] '[] = () + AllZipF c (x ': xs) (y ': ys) = (c x y, AllZip c xs ys) + +-- | Type family that forces a type-level list to be of the same +-- shape as the given type-level list. +-- +-- The main use of this constraint is to help type inference to +-- learn something about otherwise unknown type-level lists. +-- +-- @since 0.3.1.0 +-- +type family + SameShapeAs (xs :: [a]) (ys :: [b]) :: Constraint where + SameShapeAs '[] ys = (ys ~ '[]) + SameShapeAs (x ': xs) ys = + (ys ~ (Head ys ': Tail ys), SameShapeAs xs (Tail ys)) + +-- | Utility function to compute the head of a type-level list. +-- +-- @since 0.3.1.0 +-- +type family Head (xs :: [a]) :: a where + Head (x ': xs) = x + +-- | Utility function to compute the tail of a type-level list. +-- +-- @since 0.3.1.0 +-- +type family Tail (xs :: [a]) :: [a] where + Tail (x ': xs) = xs + +-- | The constraint @LiftedCoercible f g x y@ is equivalent +-- to @Coercible (f x) (g y)@. +-- +-- @since 0.3.1.0 +-- +class Coercible (f x) (g y) => LiftedCoercible f g x y +instance Coercible (f x) (g y) => LiftedCoercible f g x y + +-- | Require a constraint for pointwise for every pair of +-- elements from two lists of lists. +-- +-- +class (AllZipF (AllZip f) xss yss, SListI xss, SListI yss, SameShapeAs xss yss, SameShapeAs yss xss) => AllZip2 f xss yss +instance (AllZipF (AllZip f) xss yss, SListI xss, SListI yss, SameShapeAs xss yss, SameShapeAs yss xss) => AllZip2 f xss yss + -- | Composition of constraints. -- -- Note that the result of the composition must be a constraint, @@ -126,6 +206,13 @@ -- type family AllN (h :: (k -> *) -> (l -> *)) (c :: k -> Constraint) :: l -> Constraint +-- | A generalization of 'AllZip' and 'AllZip2'. +-- +-- The family 'AllZipN' expands to 'AllZip' or 'AllZip2' depending on +-- whther the argument is indexed by a list or a list of lists. +-- +type family AllZipN (h :: (k -> *) -> (l -> *)) (c :: k1 -> k2 -> Constraint) :: l1 -> l2 -> Constraint + -- | A generalization of 'SListI'. -- -- The family 'SListIN' expands to 'SListI' or 'SListI2' depending diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/GGP.hs new/generics-sop-0.3.1.0/src/Generics/SOP/GGP.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/GGP.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/GGP.hs 2017-06-11 15:25:51.000000000 +0200 @@ -1,4 +1,7 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds, UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 780 +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +#endif -- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'. -- -- The technique being used here is described in the following paper: @@ -12,6 +15,9 @@ , GFrom , GTo , GDatatypeInfo +#if MIN_VERSION_base(4,9,0) + , GDatatypeInfoOf +#endif , gfrom , gto , gdatatypeInfo @@ -22,9 +28,16 @@ import Generics.SOP.NP as SOP import Generics.SOP.NS as SOP import Generics.SOP.BasicFunctors as SOP +#if !(MIN_VERSION_base(4,9,0)) import Generics.SOP.Constraint as SOP +#endif +#if MIN_VERSION_base(4,9,0) +import qualified Generics.SOP.Type.Metadata as SOP.T +#endif import Generics.SOP.Metadata as SOP +#if !(MIN_VERSION_base(4,9,0)) import Generics.SOP.Sing +#endif type family ToSingleCode (a :: * -> *) :: * type instance ToSingleCode (K1 _i a) = a @@ -46,6 +59,7 @@ data InfoProxy (c :: *) (f :: * -> *) (x :: *) = InfoProxy #endif +#if !(MIN_VERSION_base(4,9,0)) class GDatatypeInfo' (a :: * -> *) where gDatatypeInfo' :: proxy a -> DatatypeInfo (ToSumCode a '[]) @@ -105,6 +119,36 @@ where p :: InfoProxy c a x p = InfoProxy +#endif + +#if MIN_VERSION_base(4,9,0) +type family ToInfo (a :: * -> *) :: SOP.T.DatatypeInfo +type instance ToInfo (M1 D (MetaData n m p False) a) = + SOP.T.ADT m n (ToSumInfo a '[]) +type instance ToInfo (M1 D (MetaData n m p True) a) = + SOP.T.Newtype m n (ToSingleConstructorInfo a) + +type family ToSumInfo (a :: * -> *) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo] +type instance ToSumInfo (a :+: b) xs = ToSumInfo a (ToSumInfo b xs) +type instance ToSumInfo V1 xs = xs +type instance ToSumInfo (M1 C c a) xs = ToSingleConstructorInfo (M1 C c a) ': xs + +type family ToSingleConstructorInfo (a :: * -> *) :: SOP.T.ConstructorInfo +type instance ToSingleConstructorInfo (M1 C (MetaCons n PrefixI False) a) = + SOP.T.Constructor n +type instance ToSingleConstructorInfo (M1 C (MetaCons n (InfixI assoc fix) False) a) = + SOP.T.Infix n assoc fix +type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) = + SOP.T.Record n (ToProductInfo a '[]) + +type family ToProductInfo (a :: * -> *) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo] +type instance ToProductInfo (a :*: b) xs = ToProductInfo a (ToProductInfo b xs) +type instance ToProductInfo U1 xs = xs +type instance ToProductInfo (M1 S c a) xs = ToSingleInfo (M1 S c a) ': xs + +type family ToSingleInfo (a :: * -> *) :: SOP.T.FieldInfo +type instance ToSingleInfo (M1 S (MetaSel (Just n) _su _ss _ds) a) = 'SOP.T.FieldInfo n +#endif class GFieldInfos (a :: * -> *) where gFieldInfos :: proxy a -> NP FieldInfo xs -> NP FieldInfo (ToProductCode a xs) @@ -209,7 +253,19 @@ type GTo a = GSumTo (GHC.Rep a) -- | Constraint for the class that computes 'gdatatypeInfo'. +#if MIN_VERSION_base(4,9,0) +type GDatatypeInfo a = SOP.T.DemoteDatatypeInfo (GDatatypeInfoOf a) (GCode a) +#else type GDatatypeInfo a = GDatatypeInfo' (GHC.Rep a) +#endif + +#if MIN_VERSION_base(4,9,0) +-- | Compute the datatype info of a datatype. +-- +-- @since 0.3.0.0 +-- +type GDatatypeInfoOf (a :: *) = ToInfo (GHC.Rep a) +#endif -- | An automatically computed version of 'Generics.SOP.from'. -- @@ -242,5 +298,9 @@ -- For more info, see 'Generics.SOP.HasDatatypeInfo'. -- gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a) +#if MIN_VERSION_base(4,9,0) +gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a)) +#else gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a)) +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/NP.hs new/generics-sop-0.3.1.0/src/Generics/SOP/NP.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/NP.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/NP.hs 2017-06-11 15:25:51.000000000 +0200 @@ -64,12 +64,23 @@ , ccata_NP , ana_NP , cana_NP + -- * Transformation of index lists and coercions + , trans_NP + , trans_POP + , coerce_NP + , coerce_POP + , fromI_NP + , fromI_POP + , toI_NP + , toI_POP ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif +import Data.Coerce import Data.Proxy (Proxy(..)) +import Unsafe.Coerce import Control.DeepSeq (NFData(..)) @@ -152,6 +163,9 @@ type instance AllN NP c = All c type instance AllN POP c = All2 c +type instance AllZipN NP c = AllZip c +type instance AllZipN POP c = AllZip2 c + type instance SListIN NP = SListI type instance SListIN POP = SListI2 @@ -266,6 +280,9 @@ _ap_POP_spec :: SListI xss => POP (f -.-> g) xss -> POP f xss -> POP g xss _ap_POP_spec (POP fs) (POP xs) = POP (liftA2_NP ap_NP fs xs) +type instance Same NP = NP +type instance Same POP = POP + type instance Prod NP = NP type instance Prod POP = POP @@ -602,3 +619,124 @@ go SNil _ = Nil go SCons s = case uncons s of (x, s') -> x :* go sList s' + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_NP :: + AllZip c xs ys + => proxy c + -> (forall x y . c x y => f x -> g y) + -> NP f xs -> NP g ys +trans_NP _ _t Nil = Nil +trans_NP p t (x :* xs) = t x :* trans_NP p t xs + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_POP :: + AllZip2 c xss yss + => proxy c + -> (forall x y . c x y => f x -> g y) + -> POP f xss -> POP g yss +trans_POP p t = + POP . trans_NP (allZipP p) (trans_NP p t) . unPOP + +allZipP :: proxy c -> Proxy (AllZip c) +allZipP _ = Proxy + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_NP :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NP f xs -> NP g ys +coerce_NP = + unsafeCoerce + +-- There is a bug in the way coerce works for higher-kinded +-- type variables that seems to occur only in GHC 7.10. +-- +-- Therefore, the safe versions of the coercion functions +-- are excluded below. This is harmless because they're only +-- present for documentation purposes and not exported. + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_NP :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NP f xs -> NP g ys +_safe_coerce_NP = + trans_NP (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_POP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => POP f xss -> POP g yss +coerce_POP = + unsafeCoerce + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_POP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => POP f xss -> POP g yss +_safe_coerce_POP = + trans_POP (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_NP :: + forall f xs ys . + AllZip (LiftedCoercible I f) xs ys + => NP I xs -> NP f ys +fromI_NP = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_NP :: + forall f xs ys . + AllZip (LiftedCoercible f I) xs ys + => NP f xs -> NP I ys +toI_NP = htoI + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_POP :: + forall f xss yss . + AllZip2 (LiftedCoercible I f) xss yss + => POP I xss -> POP f yss +fromI_POP = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_POP :: + forall f xss yss . + AllZip2 (LiftedCoercible f I) xss yss + => POP f xss -> POP I yss +toI_POP = htoI + +instance HTrans NP NP where + htrans = trans_NP + hcoerce = coerce_NP +instance HTrans POP POP where + htrans = trans_POP + hcoerce = coerce_POP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/NS.hs new/generics-sop-0.3.1.0/src/Generics/SOP/NS.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/NS.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/NS.hs 2017-06-11 15:25:51.000000000 +0200 @@ -59,12 +59,23 @@ , cexpand_NS , expand_SOP , cexpand_SOP + -- * Transformation of index lists and coercions + , trans_NS + , trans_SOP + , coerce_NS + , coerce_SOP + , fromI_NS + , fromI_SOP + , toI_NS + , toI_SOP ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif +import Data.Coerce import Data.Proxy +import Unsafe.Coerce import Control.DeepSeq (NFData(..)) @@ -342,6 +353,9 @@ _ap_SOP_spec :: SListI xss => POP (t -.-> f) xss -> SOP t xss -> SOP f xss _ap_SOP_spec (POP fs) (SOP xs) = SOP (liftA2_NS ap_NP fs xs) +type instance Same NS = NS +type instance Same SOP = SOP + type instance Prod NS = NP type instance Prod SOP = POP @@ -591,3 +605,125 @@ instance HExpand SOP where hexpand = expand_SOP hcexpand = cexpand_SOP + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_NS :: + AllZip c xs ys + => proxy c + -> (forall x y . c x y => f x -> g y) + -> NS f xs -> NS g ys +trans_NS _ t (Z x) = Z (t x) +trans_NS p t (S x) = S (trans_NS p t x) + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_SOP :: + AllZip2 c xss yss + => proxy c + -> (forall x y . c x y => f x -> g y) + -> SOP f xss -> SOP g yss +trans_SOP p t = + SOP . trans_NS (allZipP p) (trans_NP p t) . unSOP + +allZipP :: proxy c -> Proxy (AllZip c) +allZipP _ = Proxy + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_NS :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NS f xs -> NS g ys +coerce_NS = + unsafeCoerce + +-- There is a bug in the way coerce works for higher-kinded +-- type variables that seems to occur only in GHC 7.10. +-- +-- Therefore, the safe versions of the coercion functions +-- are excluded below. This is harmless because they're only +-- present for documentation purposes and not exported. + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_NS :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NS f xs -> NS g ys +_safe_coerce_NS = + trans_NS (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_SOP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => SOP f xss -> SOP g yss +coerce_SOP = + unsafeCoerce + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_SOP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => SOP f xss -> SOP g yss +_safe_coerce_SOP = + trans_SOP (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_NS :: + forall f xs ys . + AllZip (LiftedCoercible I f) xs ys + => NS I xs -> NS f ys +fromI_NS = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_NS :: + forall f xs ys . + AllZip (LiftedCoercible f I) xs ys + => NS f xs -> NS I ys +toI_NS = htoI + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_SOP :: + forall f xss yss . + AllZip2 (LiftedCoercible I f) xss yss + => SOP I xss -> SOP f yss +fromI_SOP = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_SOP :: + forall f xss yss . + AllZip2 (LiftedCoercible f I) xss yss + => SOP f xss -> SOP I yss +toI_SOP = htoI + +instance HTrans NS NS where + htrans = trans_NS + hcoerce = coerce_NS + +instance HTrans SOP SOP where + htrans = trans_SOP + hcoerce = coerce_SOP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/TH.hs new/generics-sop-0.3.1.0/src/Generics/SOP/TH.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/TH.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/TH.hs 2017-06-11 15:25:51.000000000 +0200 @@ -5,15 +5,18 @@ , deriveGenericOnly , deriveGenericFunctions , deriveMetadataValue + , deriveMetadataType ) where import Control.Monad (replicateM) import Data.Maybe (fromMaybe) +import Data.Proxy import Language.Haskell.TH import Language.Haskell.TH.Syntax import Generics.SOP.BasicFunctors import qualified Generics.SOP.Metadata as SOP +import qualified Generics.SOP.Type.Metadata as SOP.T import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe @@ -51,8 +54,12 @@ -- > to _ = error "unreachable" -- to avoid GHC warnings -- > -- > instance HasDatatypeInfo Tree where --- > datatypeInfo _ = ADT "Main" "Tree" --- > (Constructor "Leaf" :* Constructor "Node" :* Nil) +-- > type DatatypeInfoOf Tree = +-- > T.ADT "Main" "Tree" +-- > '[ T.Constructor "Leaf", T.Constructor "Node" ] +-- > +-- > datatypeInfo _ = +-- > T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf Tree)) -- -- /Limitations:/ Generation does not work for GADTs, for -- datatypes that involve existential quantification, for @@ -134,6 +141,29 @@ sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |] -- treeDatatypeInfo :: DatatypeInfo TreeCode , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ... ] +{-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-} + +-- | Derive @DatatypeInfo@ type for the type. +-- +-- /Example:/ If you say +-- +-- > deriveMetadataType ''Tree "TreeDatatypeInfo" +-- +-- then you get code that is equivalent to: +-- +-- > type TreeDatatypeInfo = +-- > T.ADT "Main" "Tree" +-- > [ T.Constructor "Leaf", T.Constructor "Node" ] +-- +-- @since 0.3.0.0 +-- +deriveMetadataType :: Name -> String -> Q [Dec] +deriveMetadataType n datatypeInfoName = do + let datatypeInfoName' = mkName datatypeInfoName + dec <- reifyDec n + withDataDec dec $ \ isNewtype _ctx name _bndrs cons _derivs -> + sequence + [ tySynD datatypeInfoName' [] (metadataType' isNewtype name cons) ] deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec] deriveGenericForDataDec _isNewtype _cxt name bndrs cons _derivs = do @@ -154,7 +184,14 @@ let typ = appTyVars name bndrs md <- instanceD (cxt []) [t| HasDatatypeInfo $typ |] - [metadata isNewtype name cons] + [ metadataType typ isNewtype name cons + , funD 'datatypeInfo + [ clause [wildP] + (normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |]) + [] + ] + ] + -- [metadata isNewtype name cons] return [md] @@ -212,10 +249,11 @@ Compute metadata -------------------------------------------------------------------------------} -metadata :: Bool -> Name -> [Con] -> Q Dec -metadata isNewtype typeName cs = - funD 'datatypeInfo [clause [wildP] (normalB $ metadata' isNewtype typeName cs) []] +metadataType :: Q Type -> Bool -> Name -> [Con] -> Q Dec +metadataType typ isNewtype typeName cs = + tySynInstD ''DatatypeInfoOf (tySynEqn [typ] (metadataType' isNewtype typeName cs)) +-- | Derive term-level metadata. metadata' :: Bool -> Name -> [Con] -> Q Exp metadata' isNewtype typeName cs = md where @@ -263,6 +301,54 @@ mdAssociativity InfixR = [| SOP.RightAssociative |] mdAssociativity InfixN = [| SOP.NotAssociative |] +-- | Derive type-level metadata. +metadataType' :: Bool -> Name -> [Con] -> Q Type +metadataType' isNewtype typeName cs = md + where + md :: Q Type + md | isNewtype = [t| 'SOP.T.Newtype $(stringT (nameModule' typeName)) + $(stringT (nameBase typeName)) + $(mdCon (head cs)) + |] + | otherwise = [t| 'SOP.T.ADT $(stringT (nameModule' typeName)) + $(stringT (nameBase typeName)) + $(promotedTypeList $ map mdCon cs) + |] + + + mdCon :: Con -> Q Type + mdCon (NormalC n _) = [t| 'SOP.T.Constructor $(stringT (nameBase n)) |] + mdCon (RecC n ts) = [t| 'SOP.T.Record $(stringT (nameBase n)) + $(promotedTypeList (map mdField ts)) + |] + mdCon (InfixC _ n _) = do +#if MIN_VERSION_template_haskell(2,11,0) + fixity <- reifyFixity n + case fromMaybe defaultFixity fixity of + Fixity f a -> +#else + i <- reify n + case i of + DataConI _ _ _ (Fixity f a) -> +#endif + [t| 'SOP.T.Infix $(stringT (nameBase n)) $(mdAssociativity a) $(natT f) |] +#if !MIN_VERSION_template_haskell(2,11,0) + _ -> fail "Strange infix operator" +#endif + mdCon (ForallC _ _ _) = fail "Existentials not supported" +#if MIN_VERSION_template_haskell(2,11,0) + mdCon (GadtC _ _ _) = fail "GADTs not supported" + mdCon (RecGadtC _ _ _) = fail "GADTs not supported" +#endif + + mdField :: VarStrictType -> Q Type + mdField (n, _, _) = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |] + + mdAssociativity :: FixityDirection -> Q Type + mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative |] + mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |] + mdAssociativity InfixN = [t| 'SOP.T.NotAssociative |] + nameModule' :: Name -> String nameModule' = fromMaybe "" . nameModule @@ -300,6 +386,12 @@ conInfo (RecGadtC _ _ _) = fail "GADTs not supported" #endif +stringT :: String -> Q Type +stringT = litT . strTyLit + +natT :: Int -> Q Type +natT = litT . numTyLit . fromIntegral + promotedTypeList :: [Q Type] -> Q Type promotedTypeList [] = promotedNilT promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Type/Metadata.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Type/Metadata.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Type/Metadata.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Type/Metadata.hs 2017-06-11 15:25:51.000000000 +0200 @@ -0,0 +1,270 @@ +{-# LANGUAGE PolyKinds, UndecidableInstances #-} +-- | Type-level metadata +-- +-- This module provides datatypes (to be used promoted) that can represent the +-- metadata of Haskell datatypes on the type level. +-- +-- We do not reuse the term-level metadata types, because these are GADTs that +-- incorporate additional invariants. We could (at least in GHC 8) impose the +-- same invariants on the type level as well, but some tests have revealed that +-- the resulting type are rather inconvenient to work with. +-- +-- So we use simple datatypes to represent the type-level metadata, even if +-- this means that some invariants are not explicitly captured. +-- +-- We establish a relation between the term- and type-level versions of the +-- metadata by automatically computing the term-level version from the type-level +-- version. +-- +-- As we now have two versions of metadata (term-level and type-level) +-- with very similar, yet slightly different datatype definitions, the names +-- between the modules clash, and this module is recommended to be imported +-- qualified when needed. +-- +-- The interface exported by this module is still somewhat experimental. +-- +-- @since 0.3.0.0 +-- +module Generics.SOP.Type.Metadata + ( module Generics.SOP.Type.Metadata + -- * re-exports + , Associativity(..) + ) where + +import Data.Proxy +import GHC.Generics (Associativity(..)) +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Types +#endif +import GHC.TypeLits + +import qualified Generics.SOP.Metadata as M +import Generics.SOP.NP +import Generics.SOP.Sing + +-- Regarding the CPP in the datatype definitions below: +-- +-- We cannot promote type synonyms in GHC 7, so we +-- use equivalent yet less descriptive definitions +-- for the older GHCs. + +-- | Metadata for a datatype (to be used promoted). +-- +-- A type of kind @'DatatypeInfo'@ contains meta-information about a datatype +-- that is not contained in its code. This information consists +-- primarily of the names of the datatype, its constructors, and possibly its +-- record selectors. +-- +-- The constructor indicates whether the datatype has been declared using @newtype@ +-- or not. +-- +-- @since 0.3.0.0 +-- +data DatatypeInfo = +#if __GLASGOW_HASKELL__ >= 800 + ADT ModuleName DatatypeName [ConstructorInfo] + -- ^ Standard algebraic datatype + | Newtype ModuleName DatatypeName ConstructorInfo + -- ^ Newtype +#else + ADT Symbol Symbol [ConstructorInfo] + -- ^ Standard algebraic datatype + | Newtype Symbol Symbol ConstructorInfo + -- ^ Newtype +#endif + +-- | Metadata for a single constructors (to be used promoted). +-- +-- @since 0.3.0.0 +-- +data ConstructorInfo = +#if __GLASGOW_HASKELL__ >= 800 + Constructor ConstructorName + -- ^ Normal constructor + | Infix ConstructorName Associativity Fixity + -- ^ Infix constructor + | Record ConstructorName [FieldInfo] + -- ^ Record constructor +#else + Constructor Symbol + -- ^ Normal constructor + | Infix Symbol Associativity Nat + -- ^ Infix constructor + | Record Symbol [FieldInfo] + -- ^ Record constructor +#endif + +-- | Metadata for a single record field (to be used promoted). +-- +-- @since 0.3.0.0 +-- +data FieldInfo = +#if __GLASGOW_HASKELL__ >= 800 + FieldInfo FieldName +#else + FieldInfo Symbol +#endif + +#if __GLASGOW_HASKELL__ >= 800 +-- | The name of a datatype. +type DatatypeName = Symbol + +-- | The name of a module. +type ModuleName = Symbol + +-- | The name of a data constructor. +type ConstructorName = Symbol + +-- | The name of a field / record selector. +type FieldName = Symbol + +-- | The fixity of an infix constructor. +type Fixity = Nat +#endif + +-- Demotion +-- +-- The following classes are concerned with computing the +-- term-level metadata from the type-level metadata. + +-- | Class for computing term-level datatype information from +-- type-level datatype information. +-- +-- @since 0.3.0.0 +-- +class DemoteDatatypeInfo (x :: DatatypeInfo) (xss :: [[*]]) where + -- | Given a proxy of some type-level datatype information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteDatatypeInfo :: proxy x -> M.DatatypeInfo xss + +instance + (KnownSymbol m, KnownSymbol d, DemoteConstructorInfos cs xss) + => DemoteDatatypeInfo ('ADT m d cs) xss where + demoteDatatypeInfo _ = + M.ADT + (symbolVal (Proxy :: Proxy m)) + (symbolVal (Proxy :: Proxy d)) + (demoteConstructorInfos (Proxy :: Proxy cs)) + +instance + (KnownSymbol m, KnownSymbol d, DemoteConstructorInfo c '[ x ]) + => DemoteDatatypeInfo ('Newtype m d c) '[ '[ x ] ] where + demoteDatatypeInfo _ = + M.Newtype + (symbolVal (Proxy :: Proxy m)) + (symbolVal (Proxy :: Proxy d)) + (demoteConstructorInfo (Proxy :: Proxy c)) + +-- | Class for computing term-level constructor information from +-- type-level constructor information. +-- +-- @since 0.3.0.0 +-- +class DemoteConstructorInfos (cs :: [ConstructorInfo]) (xss :: [[*]]) where + -- | Given a proxy of some type-level constructor information, + -- return the corresponding term-level information as a product. + -- + -- @since 0.3.0.0 + -- + demoteConstructorInfos :: proxy cs -> NP M.ConstructorInfo xss + +instance DemoteConstructorInfos '[] '[] where + demoteConstructorInfos _ = Nil + +instance + (DemoteConstructorInfo c xs, DemoteConstructorInfos cs xss) + => DemoteConstructorInfos (c ': cs) (xs ': xss) where + demoteConstructorInfos _ = + demoteConstructorInfo (Proxy :: Proxy c) :* demoteConstructorInfos (Proxy :: Proxy cs) + +-- | Class for computing term-level constructor information from +-- type-level constructor information. +-- +-- @since 0.3.0.0 +-- +class DemoteConstructorInfo (x :: ConstructorInfo) (xs :: [*]) where + -- | Given a proxy of some type-level constructor information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteConstructorInfo :: proxy x -> M.ConstructorInfo xs + +instance (KnownSymbol s, SListI xs) => DemoteConstructorInfo ('Constructor s) xs where + demoteConstructorInfo _ = M.Constructor (symbolVal (Proxy :: Proxy s)) + +instance + (KnownSymbol s, DemoteAssociativity a, KnownNat f) + => DemoteConstructorInfo ('Infix s a f) [y, z] where + demoteConstructorInfo _ = + M.Infix + (symbolVal (Proxy :: Proxy s)) + (demoteAssociativity (Proxy :: Proxy a)) + (fromInteger (natVal (Proxy :: Proxy f))) + +instance (KnownSymbol s, DemoteFieldInfos fs xs) => DemoteConstructorInfo ('Record s fs) xs where + demoteConstructorInfo _ = + M.Record (symbolVal (Proxy :: Proxy s)) (demoteFieldInfos (Proxy :: Proxy fs)) + +-- | Class for computing term-level field information from +-- type-level field information. +-- +-- @since 0.3.0.0 +-- +class SListI xs => DemoteFieldInfos (fs :: [FieldInfo]) (xs :: [*]) where + -- | Given a proxy of some type-level field information, + -- return the corresponding term-level information as a product. + -- + -- @since 0.3.0.0 + -- + demoteFieldInfos :: proxy fs -> NP M.FieldInfo xs + +instance DemoteFieldInfos '[] '[] where + demoteFieldInfos _ = Nil + +instance + (DemoteFieldInfo f x, DemoteFieldInfos fs xs) + => DemoteFieldInfos (f ': fs) (x ': xs) where + demoteFieldInfos _ = demoteFieldInfo (Proxy :: Proxy f) :* demoteFieldInfos (Proxy :: Proxy fs) + +-- | Class for computing term-level field information from +-- type-level field information. +-- +-- @since 0.3.0.0 +-- +class DemoteFieldInfo (x :: FieldInfo) (a :: *) where + -- | Given a proxy of some type-level field information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteFieldInfo :: proxy x -> M.FieldInfo a + +instance KnownSymbol s => DemoteFieldInfo ('FieldInfo s) a where + demoteFieldInfo _ = M.FieldInfo (symbolVal (Proxy :: Proxy s)) + +-- | Class for computing term-level associativity information +-- from type-level associativity information. +-- +-- @since 0.3.0.0 +-- +class DemoteAssociativity (a :: Associativity) where + -- | Given a proxy of some type-level associativity information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteAssociativity :: proxy a -> M.Associativity + +instance DemoteAssociativity 'LeftAssociative where + demoteAssociativity _ = M.LeftAssociative + +instance DemoteAssociativity 'RightAssociative where + demoteAssociativity _ = M.RightAssociative + +instance DemoteAssociativity 'NotAssociative where + demoteAssociativity _ = M.NotAssociative + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Universe.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Universe.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Universe.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Universe.hs 2017-06-11 15:25:51.000000000 +0200 @@ -5,6 +5,7 @@ -- | Codes and interpretations module Generics.SOP.Universe where +import Data.Coerce (Coercible) import qualified GHC.Generics as GHC import Generics.SOP.BasicFunctors @@ -13,6 +14,7 @@ import Generics.SOP.Sing import Generics.SOP.GGP import Generics.SOP.Metadata +import qualified Generics.SOP.Type.Metadata as T -- | The (generic) representation of a datatype. -- @@ -137,7 +139,56 @@ -- of 'Generic' for the options. -- class HasDatatypeInfo a where + -- | Type-level datatype info + type DatatypeInfoOf a :: T.DatatypeInfo +#if MIN_VERSION_base(4,9,0) + type DatatypeInfoOf a = GDatatypeInfoOf a +#else + type DatatypeInfoOf a = DatatypeInfoOf a +#endif + + -- | Term-level datatype info; by default, the term-level datatype info is produced + -- from the type-level info. + -- datatypeInfo :: proxy a -> DatatypeInfo (Code a) - default datatypeInfo :: (GDatatypeInfo a, Code a ~ GCode a) - => proxy a -> DatatypeInfo (Code a) + default datatypeInfo :: (GDatatypeInfo a, GCode a ~ Code a) => proxy a -> DatatypeInfo (Code a) datatypeInfo = gdatatypeInfo + +-- | Constraint that captures that a datatype is a product type, +-- i.e., a type with a single constructor. +-- +-- It also gives access to the code for the arguments of that +-- constructor. +-- +-- @since 0.3.1.0 +-- +type IsProductType (a :: *) (xs :: [*]) = + (Generic a, Code a ~ '[ xs ]) + +-- | Constraint that captures that a datatype is an enumeration type, +-- i.e., none of the constructors have any arguments. +-- +-- @since 0.3.1.0 +-- +type IsEnumType (a :: *) = + (Generic a, All ((~) '[]) (Code a)) + +-- | Constraint that captures that a datatype is a single-constructor, +-- single-field datatype. This always holds for newtype-defined types, +-- but it can also be true for data-defined types. +-- +-- The constraint also gives access to the type that is wrapped. +-- +-- @since 0.3.1.0 +-- +type IsWrappedType (a :: *) (x :: *) = + (Generic a, Code a ~ '[ '[ x ] ]) + +-- | Constraint that captures that a datatype is a newtype. +-- This makes use of the fact that newtypes are always coercible +-- to the type they wrap, whereas datatypes are not. +-- +-- @since 0.3.1.0 +-- +type IsNewtype (a :: *) (x :: *) = + (IsWrappedType a x, Coercible a x) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP.hs new/generics-sop-0.3.1.0/src/Generics/SOP.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP.hs 2017-06-11 15:25:51.000000000 +0200 @@ -218,6 +218,10 @@ -- * Codes and interpretations Generic(..) , Rep + , IsProductType + , IsEnumType + , IsWrappedType + , IsNewtype -- * n-ary datatypes , NP(..) , NS(..) @@ -296,6 +300,10 @@ , hsequenceK -- ** Expanding sums to products , HExpand(..) + -- ** Transformation of index lists and coercions + , HTrans(..) + , hfromI + , htoI -- ** Partial operations , fromList -- * Utilities @@ -322,10 +330,16 @@ -- ** Mapping constraints , All , All2 + , AllZip + , AllZip2 + , AllN + , AllZipN + -- ** Other constraints , Compose , And , Top - , AllN + , LiftedCoercible + , SameShapeAs -- ** Singletons , SList(..) , SListI(..) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/test/Example.hs new/generics-sop-0.3.1.0/test/Example.hs --- old/generics-sop-0.2.5.0/test/Example.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/test/Example.hs 2017-06-11 15:25:51.000000000 +0200 @@ -10,6 +10,9 @@ import qualified GHC.Generics as GHC import Generics.SOP import Generics.SOP.TH +import qualified Generics.SOP.Type.Metadata as T + +import HTransExample -- Generic show, kind of gshow :: (Generic a, All2 Show (Code a)) => a -> String @@ -43,7 +46,7 @@ treeB :: TreeB treeB = NodeB (LeafB 1) (LeafB 2) -deriveGenericOnly ''TreeB +deriveGeneric ''TreeB instance Show TreeB where show = gshow @@ -56,6 +59,10 @@ deriveGenericFunctions ''TreeC "TreeCCode" "fromTreeC" "toTreeC" deriveMetadataValue ''TreeC "TreeCCode" "treeDatatypeInfo" +deriveMetadataType ''TreeC "TreeDatatypeInfo" + +demotedTreeDatatypeInfo :: DatatypeInfo TreeCCode +demotedTreeDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy TreeDatatypeInfo) instance Show TreeC where show x = gshowS (fromTreeC x) @@ -66,5 +73,9 @@ print tree print $ datatypeInfo (Proxy :: Proxy Tree) print treeB + print $ datatypeInfo (Proxy :: Proxy TreeB) print treeC print treeDatatypeInfo + print demotedTreeDatatypeInfo + print (treeDatatypeInfo == demotedTreeDatatypeInfo) + print $ convertFull tree diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/test/HTransExample.hs new/generics-sop-0.3.1.0/test/HTransExample.hs --- old/generics-sop-0.2.5.0/test/HTransExample.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/generics-sop-0.3.1.0/test/HTransExample.hs 2017-06-11 15:25:51.000000000 +0200 @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module HTransExample where + +import Generics.SOP + +class IsTupleTypeOf xs y | xs -> y where + toTuple :: NP I xs -> y + default toTuple :: (Generic y, Code y ~ '[ xs ]) => NP I xs -> y + toTuple = to . SOP . Z + +instance IsTupleTypeOf '[] () +instance IsTupleTypeOf '[x1] x1 where toTuple = unI . hd +instance IsTupleTypeOf '[x1, x2] (x1, x2) +instance IsTupleTypeOf '[x1, x2, x3] (x1, x2, x3) +instance IsTupleTypeOf '[x1, x2, x3, x4] (x1, x2, x3, x4) + +convert :: (AllZip IsTupleTypeOf xss ys) => NS (NP I) xss -> NS I ys +convert = htrans (Proxy :: Proxy IsTupleTypeOf) (I . toTuple) + +convertFull :: (Generic a, AllZip IsTupleTypeOf (Code a) ys) => a -> NS I ys +convertFull = convert . unSOP . from

1 0

commit ghc-fold-debounce for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-fold-debounce for openSUSE:Factory checked in at 2017-08-31 20:50:49 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-fold-debounce (Old) and /work/SRC/openSUSE:Factory/.ghc-fold-debounce.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-fold-debounce" Thu Aug 31 20:50:49 2017 rev:5 rq:513242 version:0.2.0.6 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-fold-debounce/ghc-fold-debounce.changes 2017-02-11 01:40:45.648586037 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-fold-debounce.new/ghc-fold-debounce.changes 2017-08-31 20:50:49.230974478 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:56 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.0.6. + +------------------------------------------------------------------- Old: ---- fold-debounce-0.2.0.5.tar.gz New: ---- fold-debounce-0.2.0.6.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-fold-debounce.spec ++++++ --- /var/tmp/diff_new_pack.G27Gwp/_old 2017-08-31 20:50:50.206837496 +0200 +++ /var/tmp/diff_new_pack.G27Gwp/_new 2017-08-31 20:50:50.210836934 +0200 @@ -19,7 +19,7 @@ %global pkg_name fold-debounce %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.0.5 +Version: 0.2.0.6 Release: 0 Summary: Fold multiple events that happen in a given period of time License: BSD-3-Clause ++++++ fold-debounce-0.2.0.5.tar.gz -> fold-debounce-0.2.0.6.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fold-debounce-0.2.0.5/ChangeLog.md new/fold-debounce-0.2.0.6/ChangeLog.md --- old/fold-debounce-0.2.0.5/ChangeLog.md 2017-01-24 13:13:28.000000000 +0100 +++ new/fold-debounce-0.2.0.6/ChangeLog.md 2017-07-21 08:03:46.000000000 +0200 @@ -1,5 +1,11 @@ # Revision history for fold-debounce +## 0.2.0.6 -- 2017-07-21 + +* Confirmed test with `time-1.8`. +* Drop version bounds for `hspec`. It's stable. + + ## 0.2.0.5 -- 2017-01-24 * Confirmed test with `hspec-2.4.0`. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fold-debounce-0.2.0.5/fold-debounce.cabal new/fold-debounce-0.2.0.6/fold-debounce.cabal --- old/fold-debounce-0.2.0.5/fold-debounce.cabal 2017-01-24 13:13:38.000000000 +0100 +++ new/fold-debounce-0.2.0.6/fold-debounce.cabal 2017-07-21 08:02:35.000000000 +0200 @@ -1,5 +1,5 @@ name: fold-debounce -version: 0.2.0.5 +version: 0.2.0.6 author: Toshio Ito <debug.ito(a)gmail.com> maintainer: Toshio Ito <debug.ito(a)gmail.com> license: BSD3 @@ -23,7 +23,7 @@ build-depends: base >= 4.6.0 && <5.0, data-default-class >=0.0.1 && <0.2, stm >=2.4.2 && <2.5, - time >=1.4.0 && <1.8, + time >=1.4.0 && <1.9, stm-delay >=0.1.1 && <0.2 test-suite spec @@ -46,7 +46,7 @@ main-is: Spec.hs other-modules: Control.FoldDebounceSpec build-depends: base, fold-debounce, - hspec >=2.1.7 && <2.5, + hspec, stm, time

1 0

commit ghc-exhaustive for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-exhaustive for openSUSE:Factory checked in at 2017-08-31 20:50:45 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-exhaustive (Old) and /work/SRC/openSUSE:Factory/.ghc-exhaustive.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-exhaustive" Thu Aug 31 20:50:45 2017 rev:3 rq:513239 version:1.1.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-exhaustive/ghc-exhaustive.changes 2017-06-04 01:57:15.477993991 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-exhaustive.new/ghc-exhaustive.changes 2017-08-31 20:50:48.155125496 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:47 UTC 2017 - psimons(a)suse.com + +- Update to version 1.1.5. + +------------------------------------------------------------------- Old: ---- exhaustive-1.1.4.tar.gz New: ---- exhaustive-1.1.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-exhaustive.spec ++++++ --- /var/tmp/diff_new_pack.jQIbo0/_old 2017-08-31 20:50:49.007005918 +0200 +++ /var/tmp/diff_new_pack.jQIbo0/_new 2017-08-31 20:50:49.011005356 +0200 @@ -18,7 +18,7 @@ %global pkg_name exhaustive Name: ghc-%{pkg_name} -Version: 1.1.4 +Version: 1.1.5 Release: 0 Summary: Compile time checks that a computation considers producing data through all possible constructors License: BSD-3-Clause ++++++ exhaustive-1.1.4.tar.gz -> exhaustive-1.1.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/exhaustive-1.1.4/Changelog.md new/exhaustive-1.1.5/Changelog.md --- old/exhaustive-1.1.4/Changelog.md 2017-05-01 19:56:46.000000000 +0200 +++ new/exhaustive-1.1.5/Changelog.md 2017-07-24 14:32:08.000000000 +0200 @@ -1,3 +1,9 @@ +## 1.1.5 + +### Other Changes + +* Increased upper-bound of `base`. + ## 1.1.4 ### Other Changes diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/exhaustive-1.1.4/exhaustive.cabal new/exhaustive-1.1.5/exhaustive.cabal --- old/exhaustive-1.1.4/exhaustive.cabal 2017-05-01 19:56:46.000000000 +0200 +++ new/exhaustive-1.1.5/exhaustive.cabal 2017-07-24 14:32:08.000000000 +0200 @@ -1,5 +1,5 @@ name: exhaustive -version: 1.1.4 +version: 1.1.5 synopsis: Compile time checks that a computation considers producing data through all possible constructors description: For a brief tutorial to @exhaustive@, check out the documentation for "Control.Exhaustive", which contains a small example. homepage: http://github.com/ocharles/exhaustive @@ -21,7 +21,10 @@ exposed-modules: Control.Exhaustive -- other-modules: other-extensions: ConstraintKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances - build-depends: base >=4.7 && <4.10, generics-sop >=0.1 && <0.4, transformers >=0.3 && <0.6, template-haskell + build-depends: base >=4.7 && <4.11 + , generics-sop >=0.1 && <0.4 + , transformers >=0.3 && <0.6 + , template-haskell hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall

1 0