Adapt to Semigroup changes in base-4.11

This commit is contained in:
Ryan Scott 2018-02-04 19:49:16 -05:00
parent 450573ac35
commit 3408e1e630
10 changed files with 59 additions and 29 deletions

View File

@ -1,3 +1,9 @@
## 1.6.1
* Add a `Semigroup LiteApp` instance, and explicitly define `(<>)` in the
already existing `Semigroup` instances for `WidgetFor`, `Head`, `Body`,
`GWData`, and `UniqueList`.
## 1.6.0
* Upgrade to conduit 1.3.0

View File

@ -4,6 +4,9 @@ module Yesod.Core.Internal.LiteApp where
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif
import Yesod.Routes.Class
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
@ -42,9 +45,14 @@ instance RenderRoute LiteApp where
instance ParseRoute LiteApp where
parseRoute (x, _) = Just $ LiteAppRoute x
instance Semigroup LiteApp where
LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps
instance Monoid LiteApp where
mempty = LiteApp $ \_ _ -> Nothing
mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
type LiteHandler = HandlerFor LiteApp
type LiteWidget = WidgetFor LiteApp

View File

@ -31,6 +31,7 @@ import Data.IORef (IORef, modifyIORef')
import Data.Map (Map, unionWith)
import qualified Data.Map as Map
import Data.Monoid (Endo (..), Last (..))
import Data.Semigroup (Semigroup(..))
import Data.Serialize (Serialize (..),
putByteString)
import Data.String (IsString (fromString))
@ -55,12 +56,10 @@ import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
import Control.Monad.Reader (MonadReader (..))
import Data.Monoid ((<>))
import Control.DeepSeq (NFData (rnf))
import Control.DeepSeq.Generics (genericRnf)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
import Control.Monad.Logger (MonadLoggerIO (..))
import Data.Semigroup (Semigroup)
import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
-- Sessions
@ -255,8 +254,11 @@ data WidgetData site = WidgetData
instance a ~ () => Monoid (WidgetFor site a) where
mempty = return ()
mappend x y = x >> y
instance a ~ () => Semigroup (WidgetFor site a)
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance a ~ () => Semigroup (WidgetFor site a) where
x <> y = x >> y
-- | A 'String' can be trivially promoted to a widget.
--
@ -356,11 +358,9 @@ data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttrib
newtype Title = Title { unTitle :: Html }
newtype Head url = Head (HtmlUrl url)
deriving Monoid
instance Semigroup (Head a)
deriving (Semigroup, Monoid)
newtype Body url = Body (HtmlUrl url)
deriving Monoid
instance Semigroup (Body a)
deriving (Semigroup, Monoid)
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
@ -375,16 +375,19 @@ data GWData a = GWData
}
instance Monoid (GWData a) where
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
(a1 `mappend` b1)
(a2 `mappend` b2)
(a3 `mappend` b3)
(a4 `mappend` b4)
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance Semigroup (GWData a) where
GWData a1 a2 a3 a4 a5 a6 a7 <>
GWData b1 b2 b3 b4 b5 b6 b7 = GWData
(a1 <> b1)
(a2 <> b2)
(a3 <> b3)
(a4 <> b4)
(unionWith mappend a5 b5)
(a6 `mappend` b6)
(a7 `mappend` b7)
instance Semigroup (GWData a)
(a6 <> b6)
(a7 <> b7)
data HandlerContents =
HCContent !H.Status !TypedContent
@ -473,8 +476,11 @@ instance MonadLoggerIO (HandlerFor site) where
instance Monoid (UniqueList x) where
mempty = UniqueList id
UniqueList x `mappend` UniqueList y = UniqueList $ x . y
instance Semigroup (UniqueList x)
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance Semigroup (UniqueList x) where
UniqueList x <> UniqueList y = UniqueList $ x . y
instance IsString Content where
fromString = flip ContentBuilder Nothing . BB.stringUtf8

View File

@ -1,5 +1,5 @@
name: yesod-core
version: 1.6.0
version: 1.6.1
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

View File

@ -1,3 +1,7 @@
## 1.6.1
* Explicitly define `(<>)` in the `Semigroup` instance for `Enctype`
## 1.6.0
* Upgrade to yesod-core 1.6.0

View File

@ -104,9 +104,12 @@ instance ToValue Enctype where
toValue Multipart = "multipart/form-data"
instance Monoid Enctype where
mempty = UrlEncoded
mappend UrlEncoded UrlEncoded = UrlEncoded
mappend _ _ = Multipart
instance Semigroup Enctype
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance Semigroup Enctype where
UrlEncoded <> UrlEncoded = UrlEncoded
_ <> _ = Multipart
data Ints = IntCons Int Ints | IntSingle Int
instance Show Ints where

View File

@ -1,5 +1,5 @@
name: yesod-form
version: 1.6.0
version: 1.6.1
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

View File

@ -1,3 +1,7 @@
## 1.6.1
* Fix the build with `base-4.11` (GHC 8.4).
## 1.6.0
* Upgrade to yesod-core 1.6.0

View File

@ -158,6 +158,7 @@ import Data.Time.Clock (getCurrentTime)
import Control.Applicative ((<$>))
import Text.Show.Pretty (ppShow)
import Data.Monoid (mempty)
import Data.Semigroup (Semigroup(..))
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack)
#elif MIN_VERSION_base(4,8,1)
@ -570,9 +571,6 @@ genericNameFromLabel match label = do
name:_ -> return name
_ -> failure $ "More than one label contained " <> label
(<>) :: T.Text -> T.Text -> T.Text
(<>) = T.append
byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
-> T.Text -- ^ The text contained in the @\<label>@.
-> T.Text -- ^ The value to set the parameter to.

View File

@ -1,5 +1,5 @@
name: yesod-test
version: 1.6.0
version: 1.6.1
license: MIT
license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar>
@ -30,6 +30,7 @@ library
, network >= 2.2
, persistent >= 1.0
, pretty-show >= 1.6
, semigroups
, text
, time
, transformers >= 0.2.2