From dccd1f800d6452ecb8498932bb130a27a1a07161 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sun, 15 Apr 2018 12:40:16 -0700 Subject: [PATCH] Support building with GHC 8.4 --- src/Data/Aeson/Extended.hs | 8 +++++-- src/Stack/Build/ConstructPlan.hs | 11 +++++++--- src/Stack/Ls.hs | 3 ++- src/Stack/PackageIndex.hs | 7 +++++- src/Stack/Setup/Installed.hs | 4 +++- src/Stack/Types/BuildPlan.hs | 16 +++++++++----- src/Stack/Types/Config.hs | 29 ++++++++++++++++--------- src/Stack/Types/Config/Build.hs | 20 +++++++++++++---- src/Stack/Types/Docker.hs | 6 ++++- src/Stack/Types/Image.hs | 5 ++++- src/Stack/Types/Nix.hs | 6 ++++- src/Stack/Types/PackageIndex.hs | 5 ++++- src/Stack/Types/Urls.hs | 5 ++++- src/Stack/Types/Version.hs | 7 ++++-- src/Text/PrettyPrint/Leijen/Extended.hs | 4 ++-- 15 files changed, 100 insertions(+), 36 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 282f535afa..a767d03775 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -142,9 +142,11 @@ data WarningParserMonoid = WarningParserMonoid { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning] } deriving Generic +instance Semigroup WarningParserMonoid where + (<>) = mappenddefault instance Monoid WarningParserMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) instance IsString WarningParserMonoid where fromString s = mempty { wpmWarnings = [fromString s] } @@ -153,9 +155,11 @@ data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] deriving (Eq, Generic, Show) instance Functor WithJSONWarnings where fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w +instance Monoid a => Semigroup (WithJSONWarnings a) where + (<>) = mappenddefault instance Monoid a => Monoid (WithJSONWarnings a) where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Warning output from 'WarningParser'. data JSONWarning = JSONUnrecognizedFields String [Text] diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index e0af580c82..9c32ccc8ee 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -114,9 +114,11 @@ data W = W , wParents :: !ParentMap -- ^ Which packages a given package depends on, along with the package's version } deriving Generic +instance Semigroup W where + (<>) = mappenddefault instance Monoid W where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) type M = RWST -- TODO replace with more efficient WS stack on top of StackT Ctx @@ -1148,8 +1150,11 @@ extendDepsPath ident dp = DepsPath newtype MonoidMap k a = MonoidMap (Map k a) deriving (Eq, Ord, Read, Show, Generic, Functor) -instance (Ord k, Monoid a) => Monoid (MonoidMap k a) where - mappend (MonoidMap mp1) (MonoidMap mp2) = MonoidMap (M.unionWith mappend mp1 mp2) +instance (Ord k, Semigroup a) => Semigroup (MonoidMap k a) where + MonoidMap mp1 <> MonoidMap mp2 = MonoidMap (M.unionWith (<>) mp1 mp2) + +instance (Ord k, Monoid a, Semigroup a) => Monoid (MonoidMap k a) where + mappend = (<>) mempty = MonoidMap mempty -- Switch this to 'True' to enable some debugging putStrLn in this module diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index 80e8b6fada..71e7a26f25 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,10 +15,10 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader) import Control.Monad (when) import Data.Aeson +import Stack.Prelude import Stack.Types.Runner import qualified Data.Aeson.Types as A import qualified Data.List as L -import Data.Monoid import Data.Text hiding (pack, intercalate) import qualified Data.Text as T import qualified Data.Text.IO as T diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 14bedada1b..2b147b0b4b 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -400,7 +401,11 @@ getPackageCaches = do result <- liftM mconcat $ forM (clIndices cl) $ \index -> do fp <- configPackageIndexCache (indexName index) PackageCache pis <- +#if MIN_VERSION_template_haskell(2,13,0) + $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "LLL6OCcimOqRm3r0JmsSlLHcaLE=" +#else $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8=" +#endif :: VersionConfig (PackageCache ()))) fp (populateCache index) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index b3e0830017..869a40ca28 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -176,9 +176,11 @@ data ExtraDirs = ExtraDirs , edInclude :: ![Path Abs Dir] , edLib :: ![Path Abs Dir] } deriving (Show, Generic) +instance Semigroup ExtraDirs where + (<>) = mappenddefault instance Monoid ExtraDirs where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) installDir :: (MonadReader env m, MonadThrow m) => Path Abs Dir diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 25fd3cd4b6..bd1cb76897 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -363,12 +363,15 @@ data DepInfo = DepInfo instance Store DepInfo instance NFData DepInfo -instance Monoid DepInfo where - mempty = DepInfo mempty (fromVersionRange C.anyVersion) - DepInfo a x `mappend` DepInfo b y = DepInfo +instance Semigroup DepInfo where + DepInfo a x <> DepInfo b y = DepInfo (mappend a b) (intersectVersionIntervals x y) +instance Monoid DepInfo where + mempty = DepInfo mempty (fromVersionRange C.anyVersion) + mappend = (<>) + data Component = CompLibrary | CompExecutable | CompTestSuite @@ -390,10 +393,13 @@ newtype ModuleInfo = ModuleInfo instance Store ModuleInfo instance NFData ModuleInfo +instance Semigroup ModuleInfo where + ModuleInfo x <> ModuleInfo y = + ModuleInfo (Map.unionWith Set.union x y) + instance Monoid ModuleInfo where mempty = ModuleInfo mempty - mappend (ModuleInfo x) (ModuleInfo y) = - ModuleInfo (Map.unionWith Set.union x y) + mappend = (<>) moduleInfoVC :: VersionConfig ModuleInfo moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s=" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 1c84667cc8..3929df8b6e 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -459,9 +459,12 @@ data GlobalOptsMonoid = GlobalOptsMonoid , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml } deriving (Show, Generic) +instance Semigroup GlobalOptsMonoid where + (<>) = mappenddefault + instance Monoid GlobalOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Default logging level should be something useful but not crazy. defaultLogLevel :: LogLevel @@ -771,9 +774,12 @@ data ConfigMonoid = } deriving (Show, Generic) +instance Semigroup ConfigMonoid where + (<>) = mappenddefault + instance Monoid ConfigMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid) parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject @@ -1676,6 +1682,16 @@ instance FromJSON (WithJSONWarnings SetupInfo) where -- | For @siGHCs@ and @siGHCJSs@ fields maps are deeply merged. -- For all fields the values from the last @SetupInfo@ win. +instance Semigroup SetupInfo where + l <> r = + SetupInfo + { siSevenzExe = siSevenzExe r <|> siSevenzExe l + , siSevenzDll = siSevenzDll r <|> siSevenzDll l + , siMsys2 = siMsys2 r <> siMsys2 l + , siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l) + , siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l) + , siStack = Map.unionWith (<>) (siStack l) (siStack r) } + instance Monoid SetupInfo where mempty = SetupInfo @@ -1686,14 +1702,7 @@ instance Monoid SetupInfo where , siGHCJSs = Map.empty , siStack = Map.empty } - mappend l r = - SetupInfo - { siSevenzExe = siSevenzExe r <|> siSevenzExe l - , siSevenzDll = siSevenzDll r <|> siSevenzDll l - , siMsys2 = siMsys2 r <> siMsys2 l - , siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l) - , siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l) - , siStack = Map.unionWith (<>) (siStack l) (siStack r) } + mappend = (<>) -- | Remote or inline 'SetupInfo' data SetupInfoLocation diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index d98eb6c0fd..2b612a3eba 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -290,9 +290,12 @@ buildMonoidSplitObjsName = "split-objs" buildMonoidSkipComponentsName :: Text buildMonoidSkipComponentsName = "skip-components" +instance Semigroup BuildOptsMonoid where + (<>) = mappenddefault + instance Monoid BuildOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Which subset of packages to build data BuildSubset @@ -347,9 +350,12 @@ toMonoidCoverageArgName = "coverage" toMonoidDisableRunArgName :: Text toMonoidDisableRunArgName = "no-run-tests" +instance Semigroup TestOptsMonoid where + (<>) = mappenddefault + instance Monoid TestOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) @@ -370,9 +376,12 @@ instance FromJSON (WithJSONWarnings HaddockOptsMonoid) where (\o -> do hoMonoidAdditionalArgs <- o ..:? hoMonoidAdditionalArgsName ..!= [] return HaddockOptsMonoid{..}) +instance Semigroup HaddockOptsMonoid where + (<>) = mappenddefault + instance Monoid HaddockOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) hoMonoidAdditionalArgsName :: Text hoMonoidAdditionalArgsName = "haddock-args" @@ -409,9 +418,12 @@ beoMonoidAdditionalArgsArgName = "benchmark-arguments" beoMonoidDisableRunArgName :: Text beoMonoidDisableRunArgName = "no-run-benchmarks" +instance Semigroup BenchmarkOptsMonoid where + (<>) = mappenddefault + instance Monoid BenchmarkOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) data FileWatchOpts = NoFileWatch diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index ae70a9aaac..730b70e0b6 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -131,10 +131,14 @@ instance FromJSON (WithJSONWarnings DockerOptsMonoid) where ..!= VersionRangeJSON anyVersion) return DockerOptsMonoid{..}) +-- | Left-biased combine Docker options +instance Semigroup DockerOptsMonoid where + (<>) = mappenddefault + -- | Left-biased combine Docker options instance Monoid DockerOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Where to get the `stack` executable to run in Docker containers data DockerStackExe diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs index 4688008d08..ef5be2e5ef 100644 --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -51,9 +51,12 @@ instance FromJSON (WithJSONWarnings ImageOptsMonoid) where { .. }) +instance Semigroup ImageOptsMonoid where + (<>) = mappenddefault + instance Monoid ImageOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) instance FromJSON (WithJSONWarnings ImageDockerOpts) where parseJSON = withObjectWarnings diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index e72863d22e..81d2e04fe6 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -60,10 +60,14 @@ instance FromJSON (WithJSONWarnings NixOptsMonoid) where nixMonoidAddGCRoots <- First <$> o ..:? nixAddGCRootsArgName return NixOptsMonoid{..}) +-- | Left-biased combine Nix options +instance Semigroup NixOptsMonoid where + (<>) = mappenddefault + -- | Left-biased combine Nix options instance Monoid NixOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Nix enable argument name. nixEnableArgName :: Text diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 3f87e24111..b103684d20 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -50,9 +50,12 @@ newtype PackageCache index = PackageCache (index, Maybe PackageDownload, NonEmpty ([CabalHash], OffsetSize)))) deriving (Generic, Eq, Show, Data, Typeable, Store, NFData) +instance Semigroup (PackageCache index) where + PackageCache x <> PackageCache y = PackageCache (HashMap.unionWith HashMap.union x y) + instance Monoid (PackageCache index) where mempty = PackageCache HashMap.empty - mappend (PackageCache x) (PackageCache y) = PackageCache (HashMap.unionWith HashMap.union x y) + mappend = (<>) -- | offset in bytes into the 01-index.tar file for the .cabal file -- contents, and size in bytes of the .cabal file diff --git a/src/Stack/Types/Urls.hs b/src/Stack/Types/Urls.hs index eeb58b3a11..2dd5c6f623 100644 --- a/src/Stack/Types/Urls.hs +++ b/src/Stack/Types/Urls.hs @@ -38,6 +38,9 @@ instance FromJSON (WithJSONWarnings UrlsMonoid) where <*> o ..: "lts-build-plans" <*> o ..: "nightly-build-plans" +instance Semigroup UrlsMonoid where + (<>) = mappenddefault + instance Monoid UrlsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index f5ba6ea00e..147a2df299 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -101,10 +101,13 @@ newtype IntersectingVersionRange = IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange } deriving Show +instance Semigroup IntersectingVersionRange where + IntersectingVersionRange l <> IntersectingVersionRange r = + IntersectingVersionRange (l `Cabal.intersectVersionRanges` r) + instance Monoid IntersectingVersionRange where mempty = IntersectingVersionRange Cabal.anyVersion - mappend (IntersectingVersionRange l) (IntersectingVersionRange r) = - IntersectingVersionRange (l `Cabal.intersectVersionRanges` r) + mappend = (<>) -- | Attoparsec parser for a package version. versionParser :: Parser Version diff --git a/src/Text/PrettyPrint/Leijen/Extended.hs b/src/Text/PrettyPrint/Leijen/Extended.hs index 80c22f443e..1248c21458 100644 --- a/src/Text/PrettyPrint/Leijen/Extended.hs +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -140,7 +140,7 @@ import Text.PrettyPrint.Annotated.Leijen hiding ((<>), display) instance Semigroup (Doc a) where (<>) = (P.<>) instance Monoid (Doc a) where - mappend = (P.<>) + mappend = (<>) mempty = empty -------------------------------------------------------------------------------- @@ -164,7 +164,7 @@ instance Display (Doc a) where type AnsiDoc = Doc AnsiAnn newtype AnsiAnn = AnsiAnn [SGR] - deriving (Eq, Show, Monoid) + deriving (Eq, Show, Semigroup, Monoid) class HasAnsiAnn a where getAnsiAnn :: a -> AnsiAnn