diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: Cabal -version: 3.0.2.0 -copyright: 2003-2019, Cabal Development Team (see AUTHORS file) +version: 3.2.0.0 +copyright: 2003-2020, Cabal Development Team (see AUTHORS file) license: BSD3 license-file: LICENSE author: Cabal Development Team @@ -110,6 +110,8 @@ tests/ParserTests/regressions/Octree-0.5.cabal tests/ParserTests/regressions/Octree-0.5.expr tests/ParserTests/regressions/Octree-0.5.format + tests/ParserTests/regressions/assoc-cpp-options.cabal + tests/ParserTests/regressions/assoc-cpp-options.check tests/ParserTests/regressions/bad-glob-syntax.cabal tests/ParserTests/regressions/bad-glob-syntax.check tests/ParserTests/regressions/big-version.cabal @@ -289,9 +291,10 @@ else build-depends: unix >= 2.6.0.0 && < 2.8 - ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances + if impl(ghc <8.8) ghc-options: -Wnoncanonical-monadfail-instances @@ -300,6 +303,10 @@ -- already depends on `fail` and `semigroups` transitively build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20 + if !impl(ghc >= 7.8) + -- semigroups depends on tagged. + build-depends: tagged >=0.8.6 && <0.9 + exposed-modules: Distribution.Backpack Distribution.Backpack.Configure @@ -315,6 +322,8 @@ Distribution.Utils.IOData Distribution.Utils.LogProgress Distribution.Utils.MapAccum + Distribution.Utils.MD5 + Distribution.Utils.Structured Distribution.Compat.CreatePipe Distribution.Compat.Directory Distribution.Compat.Environment @@ -328,6 +337,7 @@ Distribution.Compat.Semigroup Distribution.Compat.Stack Distribution.Compat.Time + Distribution.Compat.Typeable Distribution.Compat.DList Distribution.Compiler Distribution.InstalledPackageInfo @@ -417,6 +427,7 @@ Distribution.Types.BuildInfo Distribution.Types.BuildType Distribution.Types.ComponentInclude + Distribution.Types.ConfVar Distribution.Types.Dependency Distribution.Types.ExeDependency Distribution.Types.LegacyExeDependency @@ -430,6 +441,7 @@ Distribution.Types.ExecutableScope Distribution.Types.Library Distribution.Types.LibraryVisibility + Distribution.Types.Flag Distribution.Types.ForeignLib Distribution.Types.ForeignLibType Distribution.Types.ForeignLibOption @@ -538,6 +550,7 @@ Distribution.Backpack.Id Distribution.Utils.UnionFind Distribution.Utils.Base62 + Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName Distribution.Compat.MonadFail @@ -608,8 +621,10 @@ UnitTests.Distribution.Utils.Generic UnitTests.Distribution.Utils.NubList UnitTests.Distribution.Utils.ShortText + UnitTests.Distribution.Utils.Structured UnitTests.Distribution.Version UnitTests.Distribution.PkgconfigVersion + UnitTests.Orphans main-is: UnitTests.hs build-depends: array, @@ -652,6 +667,9 @@ ghc-options: -Wall default-language: Haskell2010 + if !impl(ghc >= 8.0) + build-depends: semigroups + if impl(ghc >= 7.8) build-depends: tree-diff >= 0.1 && <0.2 @@ -676,6 +694,8 @@ Cabal ghc-options: -Wall default-language: Haskell2010 + if !impl(ghc >= 8.0) + build-depends: semigroups test-suite custom-setup-tests type: exitcode-stdio-1.0 diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,20 @@ +# 3.2.0.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020 + * Change free text `String` fields to use `ShortText` in package description + and installed packge info. + * Split `Distribution.Types.Flag` and `Distribution.Types.ConfVar` + `Distribution.Types.GenericPackageDescription`. + * Add GHC-8.10 support, including new extensions to + `Language.Haskell.Extension`. + * Use more `NonEmpty` instead of ordinary lists. + * Add `Distribution.Utils.Structured` for fingeprinting `Binary` blobs. + * Add `null`, `length` and `unsafeFromUTF8BS` to `Distribution.Utils.ShortText`. + * Refactor `Distribution.Utils.IOData` module. + * Rename `Distribution.Compat.MD5` to `Distribution.Utils.MD5`. + * Add `safeHead`, `safeTail`, `safeLast` to `Distribution.Utils.Generic`. + * Add `unsnoc` and `unsnocNE` to `Distribution.Utils.Generic`. + * Add `Set'` modifier to `Distribution.Parsec.Newtypes`. + * Add `Distribution.Compat.Async`. + # 3.0.2.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020 * Disallow spaces around colon `:` in Dependency `build-depends` syntax ([#6538](https://github.com/haskell/cabal/pull/6538)). diff --git a/Distribution/Backpack.hs b/Distribution/Backpack.hs --- a/Distribution/Backpack.hs +++ b/Distribution/Backpack.hs @@ -54,7 +54,6 @@ import Distribution.Utils.Base62 import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------- @@ -99,7 +98,7 @@ -- TODO: cache holes? instance Binary OpenUnitId - +instance Structured OpenUnitId instance NFData OpenUnitId where rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst rnf (DefiniteUnitId uid) = rnf uid @@ -166,6 +165,7 @@ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary OpenModule +instance Structured OpenModule instance NFData OpenModule where rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/Distribution/Backpack/ComponentsGraph.hs b/Distribution/Backpack/ComponentsGraph.hs --- a/Distribution/Backpack/ComponentsGraph.hs +++ b/Distribution/Backpack/ComponentsGraph.hs @@ -19,6 +19,7 @@ import Distribution.Types.UnqualComponentName import Distribution.Compat.Graph (Graph, Node(..)) import qualified Distribution.Compat.Graph as Graph +import Distribution.Utils.Generic import Distribution.Pretty (pretty) import Text.PrettyPrint @@ -94,4 +95,4 @@ text $ "Components in the package depend on each other in a cyclic way:\n " ++ intercalate " depends on " [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ [head cnames] ] + | cname <- cnames ++ maybeToList (safeHead cnames) ] diff --git a/Distribution/Backpack/Configure.hs b/Distribution/Backpack/Configure.hs --- a/Distribution/Backpack/Configure.hs +++ b/Distribution/Backpack/Configure.hs @@ -162,7 +162,8 @@ . map Right $ graph combined_graph = Graph.unionRight external_graph internal_graph - Just local_graph = Graph.closure combined_graph (map nodeKey graph) + local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") + $ Graph.closure combined_graph (map nodeKey graph) -- The database of transitively reachable installed packages that the -- external components the package (as a whole) depends on. This will be -- used in several ways: diff --git a/Distribution/Backpack/ModSubst.hs b/Distribution/Backpack/ModSubst.hs --- a/Distribution/Backpack/ModSubst.hs +++ b/Distribution/Backpack/ModSubst.hs @@ -13,12 +13,10 @@ import Prelude () import Distribution.Compat.Prelude hiding (mod) -import Distribution.ModuleName - import Distribution.Backpack +import Distribution.ModuleName import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set -- | Applying module substitutions to semantic objects. diff --git a/Distribution/Backpack/ModuleShape.hs b/Distribution/Backpack/ModuleShape.hs --- a/Distribution/Backpack/ModuleShape.hs +++ b/Distribution/Backpack/ModuleShape.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -- | See module Distribution.Backpack.ModuleShape ( @@ -17,7 +18,6 @@ import Distribution.Backpack import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------- @@ -30,9 +30,10 @@ modShapeProvides :: OpenModuleSubst, modShapeRequires :: Set ModuleName } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Typeable) instance Binary ModuleShape +instance Structured ModuleShape instance ModSubst ModuleShape where modSubst subst (ModuleShape provs reqs) diff --git a/Distribution/Backpack/PreModuleShape.hs b/Distribution/Backpack/PreModuleShape.hs --- a/Distribution/Backpack/PreModuleShape.hs +++ b/Distribution/Backpack/PreModuleShape.hs @@ -11,7 +11,6 @@ import Prelude () import Distribution.Compat.Prelude -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/Distribution/Compat/Async.hs b/Distribution/Compat/Async.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Async.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | 'Async', yet using 'MVar's. +-- +-- Adopted from @async@ library +-- Copyright (c) 2012, Simon Marlow +-- Licensed under BSD-3-Clause +-- +-- @since 3.2.0.0 +-- +module Distribution.Compat.Async ( + AsyncM, + withAsync, waitCatch, + wait, asyncThreadId, + cancel, uninterruptibleCancel, AsyncCancelled (..), + -- * Cabal extras + withAsyncNF, + ) where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.DeepSeq (NFData, force) +import Control.Exception + (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) +import Control.Monad (void) +import Data.Typeable (Typeable) +import GHC.Exts (inline) + +#if MIN_VERSION_base(4,7,0) +import Control.Exception (asyncExceptionFromException, asyncExceptionToException) +#endif + +-- | Async, but based on 'MVar', as we don't depend on @stm@. +data AsyncM a = Async + { asyncThreadId :: {-# UNPACK #-} !ThreadId + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) + } + +-- | Spawn an asynchronous action in a separate thread, and pass its +-- @Async@ handle to the supplied function. When the function returns +-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. +-- +-- > withAsync action inner = mask $ \restore -> do +-- > a <- async (restore action) +-- > restore (inner a) `finally` uninterruptibleCancel a +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Note: a reference to the child thread is kept alive until the call +-- to `withAsync` returns, so nesting many `withAsync` calls requires +-- linear memory. +-- +withAsync :: IO a -> (AsyncM a -> IO b) -> IO b +withAsync = inline withAsyncUsing forkIO + +withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where + evaluateNF = evaluate . force + +withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsyncUsing doFork = \action inner -> do + var <- newEmptyMVar + mask $ \restore -> do + t <- doFork $ try (restore action) >>= putMVar var + let a = Async t var + r <- restore (inner a) `catchAll` \e -> do + uninterruptibleCancel a + throwIO e + uninterruptibleCancel a + return r + +-- | Wait for an asynchronous action to complete, and return its +-- value. If the asynchronous action threw an exception, then the +-- exception is re-thrown by 'wait'. +-- +-- > wait = atomically . waitSTM +-- +{-# INLINE wait #-} +wait :: AsyncM a -> IO a +wait a = do + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x + +-- | Wait for an asynchronous action to complete, and return either +-- @Left e@ if the action raised an exception @e@, or @Right a@ if it +-- returned a value @a@. +-- +-- > waitCatch = atomically . waitCatchSTM +-- +{-# INLINE waitCatch #-} +waitCatch :: AsyncM a -> IO (Either SomeException a) +waitCatch (Async _ var) = tryAgain (readMVar var) + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f + +catchAll :: IO a -> (SomeException -> IO a) -> IO a +catchAll = catch + +-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ +-- exception to it, and waiting for the `Async` thread to quit. +-- Has no effect if the 'Async' has already completed. +-- +-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a +-- +-- Note that 'cancel' will not terminate until the thread the 'Async' +-- refers to has terminated. This means that 'cancel' will block for +-- as long said thread blocks when receiving an asynchronous exception. +-- +-- For example, it could block if: +-- +-- * It's executing a foreign call, and thus cannot receive the asynchronous +-- exception; +-- * It's executing some cleanup handler after having received the exception, +-- and the handler is blocking. +{-# INLINE cancel #-} +cancel :: AsyncM a -> IO () +cancel a@(Async t _) = do + throwTo t AsyncCancelled + void (waitCatch a) + +-- | The exception thrown by `cancel` to terminate a thread. +data AsyncCancelled = AsyncCancelled + deriving (Show, Eq + , Typeable + ) + +instance Exception AsyncCancelled where +#if MIN_VERSION_base(4,7,0) + -- wraps in SomeAsyncException + -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 + fromException = asyncExceptionFromException + toException = asyncExceptionToException +#endif + +-- | Cancel an asynchronous action +-- +-- This is a variant of `cancel`, but it is not interruptible. +{-# INLINE uninterruptibleCancel #-} +uninterruptibleCancel :: AsyncM a -> IO () +uninterruptibleCancel = uninterruptibleMask_ . cancel diff --git a/Distribution/Compat/Binary.hs b/Distribution/Compat/Binary.hs --- a/Distribution/Compat/Binary.hs +++ b/Distribution/Compat/Binary.hs @@ -18,12 +18,7 @@ #endif ) where -import Control.Exception (catch, evaluate) -#if __GLASGOW_HASKELL__ >= 711 -import Control.Exception (pattern ErrorCall) -#else -import Control.Exception (ErrorCall(..)) -#endif +import Control.Exception (ErrorCall (..), catch, evaluate) import Data.ByteString.Lazy (ByteString) #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) @@ -67,5 +62,10 @@ decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) decodeOrFailIO bs = - catch (evaluate (decode bs) >>= return . Right) - $ \(ErrorCall str) -> return $ Left str + catch (evaluate (decode bs) >>= return . Right) handler + where +#if MIN_VERSION_base(4,9,0) + handler (ErrorCallWithLocation str _) = return $ Left str +#else + handler (ErrorCall str) = return $ Left str +#endif diff --git a/Distribution/Compat/DList.hs b/Distribution/Compat/DList.hs --- a/Distribution/Compat/DList.hs +++ b/Distribution/Compat/DList.hs @@ -19,7 +19,7 @@ ) where import Prelude () -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude hiding (toList) -- | Difference list. newtype DList a = DList ([a] -> [a]) diff --git a/Distribution/Compat/Graph.hs b/Distribution/Compat/Graph.hs --- a/Distribution/Compat/Graph.hs +++ b/Distribution/Compat/Graph.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.Graph @@ -83,20 +84,21 @@ nodeValue, ) where +import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) import Prelude () -import qualified Distribution.Compat.Prelude as Prelude -import Distribution.Compat.Prelude hiding (lookup, null, empty) -import Data.Graph (SCC(..)) -import qualified Data.Graph as G +import Data.Array ((!)) +import Data.Either (partitionEithers) +import Data.Graph (SCC (..)) +import Distribution.Utils.Structured (Structure (..), Structured (..)) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Array as Array -import Data.Array ((!)) -import qualified Data.Tree as Tree -import Data.Either (partitionEithers) -import qualified Data.Foldable as Foldable +import qualified Data.Array as Array +import qualified Data.Foldable as Foldable +import qualified Data.Graph as G +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tree as Tree +import qualified Distribution.Compat.Prelude as Prelude -- | A graph of nodes @a@. The nodes are expected to have instance -- of class 'IsNode'. @@ -128,6 +130,9 @@ instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where put x = put (toList x) get = fmap fromDistinctList get + +instance Structured a => Structured (Graph a) where + structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] instance (Eq (Key a), Eq a) => Eq (Graph a) where g1 == g2 = graphMap g1 == graphMap g2 diff --git a/Distribution/Compat/Lens.hs b/Distribution/Compat/Lens.hs --- a/Distribution/Compat/Lens.hs +++ b/Distribution/Compat/Lens.hs @@ -51,7 +51,6 @@ import Distribution.Compat.Prelude import Control.Applicative (Const (..)) -import Data.Functor.Identity (Identity (..)) import Control.Monad.State.Class (MonadState (..), gets, modify) import qualified Distribution.Compat.DList as DList diff --git a/Distribution/Compat/Parsing.hs b/Distribution/Compat/Parsing.hs --- a/Distribution/Compat/Parsing.hs +++ b/Distribution/Compat/Parsing.hs @@ -25,13 +25,10 @@ , some -- from Control.Applicative, parsec many1 , many -- from Control.Applicative , sepBy - , sepBy1 , sepByNonEmpty - , sepEndBy1 - -- , sepEndByNonEmpty + , sepEndByNonEmpty , sepEndBy - , endBy1 - -- , endByNonEmpty + , endByNonEmpty , endBy , count , chainl @@ -58,6 +55,7 @@ import Control.Monad.Trans.Identity (IdentityT (..)) import Data.Foldable (asum) +import qualified Data.List.NonEmpty as NE import qualified Text.Parsec as Parsec -- | @choice ps@ tries to apply the parsers in the list @ps@ in order, @@ -96,36 +94,20 @@ -- -- > commaSep p = p `sepBy` (symbol ",") sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = sepBy1 p sep <|> pure [] +sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] {-# INLINE sepBy #-} --- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. -sepBy1 :: Alternative m => m a -> m sep -> m [a] -sepBy1 p sep = (:) <$> p <*> many (sep *> p) --- toList <$> sepByNonEmpty p sep -{-# INLINE sepBy1 #-} - -- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated -- by @sep@. Returns a non-empty list of values returned by @p@. sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) {-# INLINE sepByNonEmpty #-} --- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a list of values --- returned by @p@. -sepEndBy1 :: Alternative m => m a -> m sep -> m [a] -sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) --- toList <$> sepEndByNonEmpty p sep - -{- -- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a non-empty list of values -- returned by @p@. sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) --} -- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, -- separated and optionally ended by @sep@, ie. haskell style @@ -133,22 +115,14 @@ -- -- > haskellStatements = haskellStatement `sepEndBy` semi sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = sepEndBy1 p sep <|> pure [] +sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] {-# INLINE sepEndBy #-} --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a list of values returned by @p@. -endBy1 :: Alternative m => m a -> m sep -> m [a] -endBy1 p sep = some (p <* sep) -{-# INLINE endBy1 #-} - -{- -- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a non-empty list of values returned by @p@. endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -endByNonEmpty p sep = some1 (p <* sep) +endByNonEmpty p sep = NE.some1 (p <* sep) {-# INLINE endByNonEmpty #-} --} -- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a list of values returned by @p@. diff --git a/Distribution/Compat/Prelude.hs b/Distribution/Compat/Prelude.hs --- a/Distribution/Compat/Prelude.hs +++ b/Distribution/Compat/Prelude.hs @@ -33,11 +33,12 @@ -- * Common type-classes Semigroup (..), gmappend, gmempty, - Typeable, + Typeable, TypeRep, typeRep, Data, Generic, NFData (..), genericRnf, Binary (..), + Structured, Alternative (..), MonadPlus (..), IsString (..), @@ -45,6 +46,9 @@ -- * Some types IO, NoCallStackIO, Map, + Set, + Identity (..), + Proxy (..), -- * Data.Maybe catMaybes, mapMaybe, @@ -61,6 +65,7 @@ -- * Data.List.NonEmpty NonEmpty((:|)), foldl1, foldr1, + head, tail, last, init, -- * Data.Foldable Foldable, foldMap, foldr, @@ -68,6 +73,7 @@ find, foldl', traverse_, for_, any, all, + toList, -- * Data.Traversable Traversable, traverse, sequenceA, @@ -100,7 +106,7 @@ ) where -- We also could hide few partial function import Prelude as BasePrelude hiding - ( IO, mapM, mapM_, sequence, null, length, foldr, any, all + ( IO, mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init -- partial functions , read , foldr1, foldl1 @@ -120,8 +126,9 @@ #if !MINVER_base_48 import Control.Applicative (Applicative (..), (<$), (<$>)) import Distribution.Compat.Semigroup (Monoid (..)) +import Data.Foldable (toList) #else -import Data.Foldable (length, null) +import Data.Foldable (length, null, Foldable(toList)) #endif import Data.Foldable (Foldable (foldMap, foldr), find, foldl', for_, traverse_, any, all) @@ -131,14 +138,17 @@ import Control.Applicative (Alternative (..)) import Control.DeepSeq (NFData (..)) import Data.Data (Data) -import Data.Typeable (Typeable) +import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) import Distribution.Compat.Binary (Binary (..)) import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) import GHC.Generics (Generic, Rep(..), V1, U1(U1), K1(unK1), M1(unM1), (:*:)((:*:)), (:+:)(L1,R1)) +import Data.Functor.Identity (Identity (..)) import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) import Control.Arrow (first) import Control.Monad hiding (mapM) @@ -146,7 +156,7 @@ import Data.List (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, sort, sortBy, unfoldr) -import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List.NonEmpty (NonEmpty((:|)), head, tail, init, last) import Data.Maybe import Data.String (IsString (..)) import Data.Int @@ -157,6 +167,8 @@ import qualified Prelude as OrigPrelude import Distribution.Compat.Stack + +import Distribution.Utils.Structured (Structured) type IO a = WithCallStack (OrigPrelude.IO a) type NoCallStackIO a = OrigPrelude.IO a diff --git a/Distribution/Compat/Semigroup.hs b/Distribution/Compat/Semigroup.hs --- a/Distribution/Compat/Semigroup.hs +++ b/Distribution/Compat/Semigroup.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -21,6 +22,8 @@ ) where import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) +import Data.Typeable (Typeable) import GHC.Generics -- Data.Semigroup is available since GHC 8.0/base-4.9 in `base` @@ -38,8 +41,10 @@ -- | A copy of 'Data.Semigroup.Last'. newtype Last' a = Last' { getLast' :: a } - deriving (Eq, Ord, Read, Show, Binary) + deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) +instance Structured a => Structured (Last' a) + instance Semigroup (Last' a) where _ <> b = b @@ -49,7 +54,9 @@ -- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances -- implemented for 'Maybe' since @base-4.11@. newtype Option' a = Option' { getOption' :: Maybe a } - deriving (Eq, Ord, Read, Show, Binary, Functor) + deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable) + +instance Structured a => Structured (Option' a) instance Semigroup a => Semigroup (Option' a) where Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b)) diff --git a/Distribution/Compat/Time.hs b/Distribution/Compat/Time.hs --- a/Distribution/Compat/Time.hs +++ b/Distribution/Compat/Time.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} @@ -55,7 +57,9 @@ -- | An opaque type representing a file's modification time, represented -- internally as a 64-bit unsigned integer in the Windows UTC format. newtype ModTime = ModTime Word64 - deriving (Binary, Bounded, Eq, Ord) + deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) + +instance Structured ModTime instance Show ModTime where show (ModTime x) = show x diff --git a/Distribution/Compat/Typeable.hs b/Distribution/Compat/Typeable.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Typeable.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Compat.Typeable ( + Typeable, + TypeRep, + typeRep, + ) where + +#if MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable, TypeRep, typeRep) +#else +import Data.Typeable (Typeable, TypeRep, typeOf) +#endif + +#if !MIN_VERSION_base(4,7,0) +typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep +typeRep _ = typeOf (undefined :: a) +#endif diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -66,7 +66,7 @@ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary CompilerFlavor - +instance Structured CompilerFlavor instance NFData CompilerFlavor where rnf = genericRnf knownCompilerFlavors :: [CompilerFlavor] @@ -125,6 +125,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary a => Binary (PerCompilerFlavor a) +instance Structured a => Structured (PerCompilerFlavor a) instance NFData a => NFData (PerCompilerFlavor a) perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] @@ -143,10 +144,10 @@ -- ------------------------------------------------------------ data CompilerId = CompilerId CompilerFlavor Version - deriving (Eq, Generic, Ord, Read, Show) + deriving (Eq, Generic, Ord, Read, Show, Typeable) instance Binary CompilerId - +instance Structured CompilerId instance NFData CompilerId where rnf = genericRnf instance Pretty CompilerId where @@ -192,9 +193,10 @@ data AbiTag = NoAbiTag | AbiTag String - deriving (Eq, Generic, Show, Read) + deriving (Eq, Generic, Show, Read, Typeable) instance Binary AbiTag +instance Structured AbiTag instance Pretty AbiTag where pretty NoAbiTag = Disp.empty diff --git a/Distribution/FieldGrammar.hs b/Distribution/FieldGrammar.hs --- a/Distribution/FieldGrammar.hs +++ b/Distribution/FieldGrammar.hs @@ -25,6 +25,7 @@ takeFields, runFieldParser, runFieldParser', + defaultFreeTextFieldDefST, ) where import Distribution.Compat.Prelude diff --git a/Distribution/FieldGrammar/Class.hs b/Distribution/FieldGrammar/Class.hs --- a/Distribution/FieldGrammar/Class.hs +++ b/Distribution/FieldGrammar/Class.hs @@ -4,19 +4,19 @@ optionalField, optionalFieldDef, monoidalField, + defaultFreeTextFieldDefST, ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Data.Functor.Identity (Identity (..)) - import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Compat.Newtype (Newtype) import Distribution.Fields.Field import Distribution.Parsec (Parsec) import Distribution.Pretty (Pretty) +import Distribution.Utils.ShortText -- | 'FieldGrammar' is parametrised by -- @@ -81,6 +81,12 @@ -> ALens' s String -- ^ lens into the field -> g s String + -- | @since 3.2.0.0 + freeTextFieldDefST + :: FieldName + -> ALens' s ShortText -- ^ lens into the field + -> g s ShortText + -- | Monoidal field. -- -- Values are combined with 'mappend'. @@ -159,3 +165,15 @@ -> ALens' s a -- ^ lens into the field -> g s a monoidalField fn = monoidalFieldAla fn Identity + +-- | Default implementation for 'freeTextFieldDefST'. +defaultFreeTextFieldDefST + :: (Functor (g s), FieldGrammar g) + => FieldName + -> ALens' s ShortText -- ^ lens into the field + -> g s ShortText +defaultFreeTextFieldDefST fn l = + toShortText <$> freeTextFieldDef fn (cloneLens l . st) + where + st :: Lens' ShortText String + st f s = toShortText <$> f (fromShortText s) diff --git a/Distribution/FieldGrammar/FieldDescrs.hs b/Distribution/FieldGrammar/FieldDescrs.hs --- a/Distribution/FieldGrammar/FieldDescrs.hs +++ b/Distribution/FieldGrammar/FieldDescrs.hs @@ -84,6 +84,8 @@ f s = showFreeText (aview l s) g s = cloneLens l (const parsecFreeText) s + freeTextFieldDefST = defaultFreeTextFieldDefST + monoidalFieldAla fn _pack l = singletonF fn f g where f s = pretty (pack' _pack (aview l s)) g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s diff --git a/Distribution/FieldGrammar/Parsec.hs b/Distribution/FieldGrammar/Parsec.hs --- a/Distribution/FieldGrammar/Parsec.hs +++ b/Distribution/FieldGrammar/Parsec.hs @@ -66,17 +66,18 @@ import Data.List (dropWhileEnd) import Data.Ord (comparing) -import Data.Set (Set) import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Simple.Utils (fromUTF8BS) import Prelude () -import qualified Data.ByteString as BS -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Distribution.Utils.ShortText as ShortText +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as P import Distribution.CabalSpecVersion import Distribution.FieldGrammar.Class @@ -84,7 +85,7 @@ import Distribution.Fields.ParseResult import Distribution.Parsec import Distribution.Parsec.FieldLineStream -import Distribution.Parsec.Position (positionRow, positionCol) +import Distribution.Parsec.Position (positionCol, positionRow) ------------------------------------------------------------------------------- -- Auxiliary types @@ -156,12 +157,12 @@ uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [x] -> parseOne v x - Just xs -> do + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) = unpack' _pack <$> runFieldParser pos parsec v fls @@ -169,24 +170,24 @@ booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure Nothing @@ -195,12 +196,12 @@ optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure def @@ -208,12 +209,12 @@ freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure Nothing @@ -222,17 +223,33 @@ freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure "" - Just [] -> pure "" - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure "" + Just [] -> pure "" + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure "" | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) | otherwise = pure (fieldlinesToFreeText fls) + + -- freeTextFieldDefST = defaultFreeTextFieldDefST + freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just [] -> pure mempty + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) = case fls of + [] -> pure mempty + [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) + _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) + | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where diff --git a/Distribution/FieldGrammar/Pretty.hs b/Distribution/FieldGrammar/Pretty.hs --- a/Distribution/FieldGrammar/Pretty.hs +++ b/Distribution/FieldGrammar/Pretty.hs @@ -72,6 +72,8 @@ showFT | v >= CabalSpecV3_0 = showFreeTextV3 | otherwise = showFreeText + freeTextFieldDefST = defaultFreeTextFieldDefST + monoidalFieldAla fn _pack l = PrettyFG pp where pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) diff --git a/Distribution/Fields/ConfVar.hs b/Distribution/Fields/ConfVar.hs --- a/Distribution/Fields/ConfVar.hs +++ b/Distribution/Fields/ConfVar.hs @@ -8,7 +8,7 @@ import Distribution.Fields.Field (SectionArg (..)) import Distribution.Fields.ParseResult import Distribution.Types.Condition -import Distribution.Types.GenericPackageDescription (ConfVar (..)) +import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Version (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, diff --git a/Distribution/Fields/Field.hs b/Distribution/Fields/Field.hs --- a/Distribution/Fields/Field.hs +++ b/Distribution/Fields/Field.hs @@ -73,7 +73,7 @@ -- | Section arguments, e.g. name of the library data SectionArg ann = SecArgName !ann !ByteString - -- ^ identifier, or omething which loos like number. Also many dot numbers, i.e. "7.6.3" + -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" | SecArgStr !ann !ByteString -- ^ quoted string | SecArgOther !ann !ByteString diff --git a/Distribution/Fields/LexerMonad.hs b/Distribution/Fields/LexerMonad.hs --- a/Distribution/Fields/LexerMonad.hs +++ b/Distribution/Fields/LexerMonad.hs @@ -32,6 +32,7 @@ ) where import qualified Data.ByteString as B +import qualified Data.List.NonEmpty as NE import Distribution.Compat.Prelude import Distribution.Parsec.Position (Position (..), showPos) import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) @@ -76,15 +77,15 @@ toPWarnings = map (uncurry toWarning) . Map.toList - . Map.fromListWith (++) - . map (\(LexWarning t p) -> (t, [p])) + . Map.fromListWith (<>) + . map (\(LexWarning t p) -> (t, pure p)) where toWarning LexWarningBOM poss = - PWarning PWTLexBOM (head poss) "Byte-order mark found at the beginning of the file" + PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" toWarning LexWarningNBSP poss = - PWarning PWTLexNBSP (head poss) $ "Non breaking spaces at " ++ intercalate ", " (map showPos poss) + PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) toWarning LexWarningTab poss = - PWarning PWTLexTab (head poss) $ "Tabs used as indentation at " ++ intercalate ", " (map showPos poss) + PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) data LexState = LexState { curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location diff --git a/Distribution/Fields/ParseResult.hs b/Distribution/Fields/ParseResult.hs --- a/Distribution/Fields/ParseResult.hs +++ b/Distribution/Fields/ParseResult.hs @@ -50,13 +50,14 @@ -- | Destruct a 'ParseResult' into the emitted warnings and either -- a successful value or -- list of errors and possibly recovered a spec-version declaration. -runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, [PError]) a) +runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) runParseResult pr = unPR pr emptyPRState failure success where - failure (PRState warns errs v) = (warns, Left (v, errs)) - success (PRState warns [] _) x = (warns, Right x) + failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) + failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where + success (PRState warns [] _) x = (warns, Right x) -- If there are any errors, don't return the result - success (PRState warns errs v) _ = (warns, Left (v, errs)) + success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) instance Functor ParseResult where fmap f (PR pr) = PR $ \ !s failure success -> diff --git a/Distribution/Fields/Pretty.hs b/Distribution/Fields/Pretty.hs --- a/Distribution/Fields/Pretty.hs +++ b/Distribution/Fields/Pretty.hs @@ -20,7 +20,6 @@ prettySectionArgs, ) where -import Data.Functor.Identity (Identity (..)) import Distribution.Compat.Prelude import Distribution.Pretty (showToken) import Prelude () diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -43,7 +43,6 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Set (Set) import Distribution.Backpack import Distribution.CabalSpecVersion (cabalSpecLatest) import Distribution.FieldGrammar @@ -53,6 +52,9 @@ import Distribution.Types.ComponentName import Distribution.Utils.Generic (toUTF8BS) +import Control.DeepSeq (deepseq) +import Data.ByteString (ByteString) + import qualified Data.Map as Map import qualified Distribution.Fields as P import qualified Text.PrettyPrint as Disp @@ -60,7 +62,8 @@ import Distribution.Types.InstalledPackageInfo import Distribution.Types.InstalledPackageInfo.FieldGrammar - +-- $setup +-- >>> :set -XOverloadedStrings installedComponentId :: InstalledPackageInfo -> ComponentId installedComponentId ipi = @@ -92,19 +95,17 @@ -- Parsing -- | Return either errors, or IPI with list of warnings --- --- /Note:/ errors array /may/ be empty, but the parse is still failed (it's a bug though) parseInstalledPackageInfo - :: String - -> Either [String] ([String], InstalledPackageInfo) -parseInstalledPackageInfo s = case P.readFields (toUTF8BS s) of - Left err -> Left [show err] + :: ByteString + -> Either (NonEmpty String) ([String], InstalledPackageInfo) +parseInstalledPackageInfo s = case P.readFields s of + Left err -> Left (show err :| []) Right fs -> case partitionFields fs of (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of - (ws, Right x) -> Right (ws', x) where + (ws, Right x) -> x `deepseq` Right (ws', x) where ws' = map (P.showPWarning "") ws (_, Left (_, errs)) -> Left errs' where - errs' = map (P.showPError "") errs + errs' = fmap (P.showPError "") errs -- ----------------------------------------------------------------------------- -- Pretty-printing diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -128,7 +128,7 @@ deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary License - +instance Structured License instance NFData License where rnf = genericRnf -- | The list of all currently recognised licenses. diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs --- a/Distribution/ModuleName.hs +++ b/Distribution/ModuleName.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | @@ -23,17 +23,16 @@ validModuleComponent, ) where -import Prelude () import Distribution.Compat.Prelude - -import Distribution.Utils.ShortText -import System.FilePath ( pathSeparator ) +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) +import System.FilePath (pathSeparator) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- | A valid Haskell module name. -- @@ -41,6 +40,7 @@ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary ModuleName +instance Structured ModuleName instance NFData ModuleName where rnf (ModuleName ms) = rnf ms @@ -50,7 +50,7 @@ Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms)) instance Parsec ModuleName where - parsec = fromComponents <$> P.sepBy1 component (P.char '.') + parsec = fromComponents <$> toList <$> P.sepByNonEmpty component (P.char '.') where component = do c <- P.satisfy isUpper @@ -130,6 +130,8 @@ instance Binary ShortTextLst where put = put . stlToList get = stlFromList <$> get + +instance Structured ShortTextLst stlToList :: ShortTextLst -> [ShortText] stlToList STLNil = [] diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -137,3 +137,5 @@ import Distribution.Types.LibraryName import Distribution.Types.HookedBuildInfo import Distribution.Types.SourceRepo +import Distribution.Types.Flag +import Distribution.Types.ConfVar diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -73,6 +73,7 @@ import qualified System.FilePath.Windows as FilePath.Windows (isValid) import qualified Data.Set as Set +import qualified Distribution.Utils.ShortText as ShortText import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L @@ -497,32 +498,32 @@ ++ "' use '" ++ prettyShow replacement ++ "'." | (ext, Just replacement) <- ourDeprecatedExtensions ] - , check (null (category pkg)) $ + , check (ShortText.null (category pkg)) $ PackageDistSuspicious "No 'category' field." - , check (null (maintainer pkg)) $ + , check (ShortText.null (maintainer pkg)) $ PackageDistSuspicious "No 'maintainer' field." - , check (null (synopsis pkg) && null (description pkg)) $ + , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ PackageDistInexcusable "No 'synopsis' or 'description' field." - , check (null (description pkg) && not (null (synopsis pkg))) $ + , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ PackageDistSuspicious "No 'description' field." - , check (null (synopsis pkg) && not (null (description pkg))) $ + , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ PackageDistSuspicious "No 'synopsis' field." --TODO: recommend the bug reports URL, author and homepage fields --TODO: recommend not using the stability field --TODO: recommend specifying a source repo - , check (length (synopsis pkg) >= 80) $ + , check (ShortText.length (synopsis pkg) >= 80) $ PackageDistSuspicious "The 'synopsis' field is rather long (max 80 chars is recommended)." -- See also https://github.com/haskell/cabal/pull/3479 - , check (not (null (description pkg)) - && length (description pkg) <= length (synopsis pkg)) $ + , check (not (ShortText.null (description pkg)) + && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ PackageDistSuspicious $ "The 'description' field should be longer than the 'synopsis' " ++ "field. " @@ -546,10 +547,7 @@ ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." - -- Disabled due to #5119: we generate loads of spurious instances of - -- this warning. Re-enabling this check should be part of the fix to - -- #5119. - , check (False && not (null depInternalLibraryWithExtraVersion)) $ + , check (not (null depInternalLibraryWithExtraVersion)) $ PackageBuildWarning $ "The package has an extraneous version range for a dependency on an " ++ "internal library: " @@ -1028,13 +1026,18 @@ checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = - catMaybes [ - checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions] +checkCPPOptions pkg = catMaybes + [ checkAlternatives "cpp-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] ] - where all_cppOptions = [ opts | bi <- allBuildInfo pkg - , opts <- cppOptions bi ] + ++ + [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag" + | opt <- all_cppOptions + -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF + , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] + ] + where + all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck @@ -1589,8 +1592,8 @@ boundedAbove :: VersionRange -> Bool boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - intervals -> case last intervals of + [] -> True -- this is the inconsistent version range. + (x:xs) -> case last (x:|xs) of (_, UpperBound _ _) -> True (_, NoUpperBound ) -> False @@ -2143,7 +2146,7 @@ Right (_:_) -> Just noSplit where -- drop the '/' between the name and prefix: - remainder = init h : rest + remainder = safeInit h : rest where nameMax, prefixMax :: Int diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -65,7 +65,6 @@ import qualified Data.Map.Strict as Map.Strict import qualified Data.Map.Lazy as Map -import Data.Set ( Set ) import qualified Data.Set as Set import Data.Tree ( Tree(Node) ) diff --git a/Distribution/PackageDescription/FieldGrammar.hs b/Distribution/PackageDescription/FieldGrammar.hs --- a/Distribution/PackageDescription/FieldGrammar.hs +++ b/Distribution/PackageDescription/FieldGrammar.hs @@ -76,18 +76,18 @@ <*> blurFieldGrammar L.package packageIdentifierGrammar <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) <*> licenseFilesGrammar - <*> freeTextFieldDef "copyright" L.copyright - <*> freeTextFieldDef "maintainer" L.maintainer - <*> freeTextFieldDef "author" L.author - <*> freeTextFieldDef "stability" L.stability + <*> freeTextFieldDefST "copyright" L.copyright + <*> freeTextFieldDefST "maintainer" L.maintainer + <*> freeTextFieldDefST "author" L.author + <*> freeTextFieldDefST "stability" L.stability <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith - <*> freeTextFieldDef "homepage" L.homepage - <*> freeTextFieldDef "package-url" L.pkgUrl - <*> freeTextFieldDef "bug-reports" L.bugReports + <*> freeTextFieldDefST "homepage" L.homepage + <*> freeTextFieldDefST "package-url" L.pkgUrl + <*> freeTextFieldDefST "bug-reports" L.bugReports <*> pure [] -- source-repos are stanza - <*> freeTextFieldDef "synopsis" L.synopsis - <*> freeTextFieldDef "description" L.description - <*> freeTextFieldDef "category" L.category + <*> freeTextFieldDefST "synopsis" L.synopsis + <*> freeTextFieldDefST "description" L.description + <*> freeTextFieldDefST "category" L.category <*> prefixedFields "x-" L.customFieldsPD <*> optionalField "build-type" L.buildTypeRaw <*> pure Nothing -- custom-setup diff --git a/Distribution/PackageDescription/Parsec.hs b/Distribution/PackageDescription/Parsec.hs --- a/Distribution/PackageDescription/Parsec.hs +++ b/Distribution/PackageDescription/Parsec.hs @@ -36,6 +36,7 @@ import Prelude () import Control.Applicative (Const (..)) +import Control.DeepSeq (deepseq) import Control.Monad (guard) import Control.Monad.State.Strict (StateT, execStateT) import Control.Monad.Trans.Class (lift) @@ -70,9 +71,7 @@ import Distribution.Types.UnqualComponentName (UnqualComponentName, mkUnqualComponentName) import Distribution.Utils.Generic (breakMaybe, unfoldrM, validateUTF8) import Distribution.Verbosity (Verbosity) -import Distribution.Version - (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion, version0, - versionNumbers) +import Distribution.Version (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion, version0, versionNumbers) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -200,7 +199,7 @@ gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) checkForUndefinedFlags gpd1 - return gpd1 + gpd1 `deepseq` return gpd1 where safeLast :: [a] -> Maybe a safeLast = listToMaybe . reverse diff --git a/Distribution/PackageDescription/PrettyPrint.hs b/Distribution/PackageDescription/PrettyPrint.hs --- a/Distribution/PackageDescription/PrettyPrint.hs +++ b/Distribution/PackageDescription/PrettyPrint.hs @@ -126,17 +126,10 @@ thenDoc = go thenTree ppIf (CondBranch c thenTree (Just elseTree)) = - case (False, False) of - -- case (isEmpty thenDoc, isEmpty elseDoc) of - (True, True) -> mempty - (False, True) -> [ ppIfCondition c thenDoc ] - (True, False) -> [ ppIfCondition (cNot c) elseDoc ] - (False, False) -> [ ppIfCondition c thenDoc - , PrettySection () "else" [] elseDoc - ] - where - thenDoc = go thenTree - elseDoc = go elseTree + -- See #6193 + [ ppIfCondition c (go thenTree) + , PrettySection () "else" [] (go elseTree) + ] ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] ppCondLibrary _ Nothing = mempty diff --git a/Distribution/PackageDescription/Quirks.hs b/Distribution/PackageDescription/Quirks.hs --- a/Distribution/PackageDescription/Quirks.hs +++ b/Distribution/PackageDescription/Quirks.hs @@ -1,19 +1,17 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -- | -- -- @since 2.2.0.0 module Distribution.PackageDescription.Quirks (patchQuirks) where -import Prelude () -import Distribution.Compat.Prelude -import GHC.Fingerprint (Fingerprint (..), fingerprintData) -import Foreign.Ptr (castPtr) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Distribution.Compat.Prelude +import Distribution.Utils.MD5 +import GHC.Fingerprint (Fingerprint (..)) +import Prelude () import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS -import qualified Data.Map as Map +import qualified Data.Map as Map -- | Patch legacy @.cabal@ file contents to allow parsec parser to accept -- all of Hackage. @@ -30,13 +28,7 @@ where output = f bs -md5 :: BS.ByteString -> Fingerprint -md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fingerprintData (castPtr ptr) len - -- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. --- --- patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) patches = Map.fromList -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 diff --git a/Distribution/Parsec.hs b/Distribution/Parsec.hs --- a/Distribution/Parsec.hs +++ b/Distribution/Parsec.hs @@ -42,7 +42,6 @@ ) where import Data.Char (digitToInt, intToDigit) -import Data.Functor.Identity (Identity (..)) import Data.List (transpose) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude @@ -260,8 +259,8 @@ parsecLeadingCommaList p = do c <- P.optional comma case c of - Nothing -> P.sepEndBy1 lp comma <|> pure [] - Just _ -> P.sepBy1 lp comma + Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] + Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" @@ -269,7 +268,7 @@ parsecOptCommaList :: CabalParsing m => m a -> m [a] parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) where - comma = P.char ',' *> P.spaces + comma = P.char ',' *> P.spaces -- | Like 'parsecOptCommaList' but -- @@ -290,7 +289,7 @@ c <- P.optional comma case c of Nothing -> sepEndBy1Start <|> pure [] - Just _ -> P.sepBy1 lp comma + Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" @@ -311,7 +310,7 @@ parsecMaybeQuoted p = parsecQuoted p <|> p parsecUnqualComponentName :: CabalParsing m => m String -parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') +parsecUnqualComponentName = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') where component :: CabalParsing m => m String component = do @@ -380,7 +379,9 @@ nomore :: m () nomore = P.notFollowedBy anyd <|> toomuch - (low, ex : high) = splitAt bd dps + (low, ex, high) = case splitAt bd dps of + (low', ex' : high') -> (low', ex', high') + (_, _) -> error "escapeCode: Logic error" in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) <|> if not (null bds) diff --git a/Distribution/Parsec/Newtypes.hs b/Distribution/Parsec/Newtypes.hs --- a/Distribution/Parsec/Newtypes.hs +++ b/Distribution/Parsec/Newtypes.hs @@ -18,6 +18,10 @@ Sep (..), -- ** Type List, + -- * Set + alaSet, + alaSet', + Set', -- * Version & License SpecVersion (..), TestedWith (..), @@ -33,16 +37,15 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Functor.Identity (Identity (..)) import Distribution.CabalSpecVersion import Distribution.Compiler (CompilerFlavor) import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty -import Distribution.Version - (LowerBound (..), Version, VersionRange, anyVersion, asVersionIntervals, mkVersion) +import Distribution.Version (LowerBound (..), Version, VersionRange, anyVersion, asVersionIntervals, mkVersion) import Text.PrettyPrint (Doc, comma, fsep, punctuate, vcat, (<+>)) +import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P import qualified Distribution.SPDX as SPDX @@ -61,13 +64,10 @@ -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep --- | Proxy, internal to this module. -data P sep = P - class Sep sep where - prettySep :: P sep -> [Doc] -> Doc + prettySep :: Proxy sep -> [Doc] -> Doc - parseSep :: CabalParsing m => P sep -> m a -> m [a] + parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] instance Sep CommaVCat where prettySep _ = vcat . punctuate comma @@ -116,10 +116,45 @@ instance Newtype [a] (List sep wrapper a) instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (P :: P sep) parsec + parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (P :: P sep) . map (pretty . (pack :: a -> b)) . unpack + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack + +-- | Like 'List', but for 'Set'. +-- +-- @since 3.2.0.0 +newtype Set' sep b a = Set' { _getSet :: Set a } + +-- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom +-- arguments to constraint the resulting type +-- +-- >>> :t alaSet VCat +-- alaSet VCat :: Set a -> Set' VCat (Identity a) a +-- +-- >>> :t alaSet' FSep Token +-- alaSet' FSep Token :: Set String -> Set' FSep Token String +-- +-- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo" +-- Right (fromList ["bar","foo"]) +-- +-- @since 3.2.0.0 +alaSet :: sep -> Set a -> Set' sep (Identity a) a +alaSet _ = Set' + +-- | More general version of 'alaSet'. +-- +-- @since 3.2.0.0 +alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a +alaSet' _ _ = Set' + +instance Newtype (Set a) (Set' sep wrapper a) + +instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where + parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack -- | Haskell string or @[^ ,]+@ newtype Token = Token { getToken :: String } diff --git a/Distribution/Pretty.hs b/Distribution/Pretty.hs --- a/Distribution/Pretty.hs +++ b/Distribution/Pretty.hs @@ -12,7 +12,6 @@ Separator, ) where -import Data.Functor.Identity (Identity (..)) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude import Prelude () diff --git a/Distribution/SPDX/License.hs b/Distribution/SPDX/License.hs --- a/Distribution/SPDX/License.hs +++ b/Distribution/SPDX/License.hs @@ -44,6 +44,7 @@ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary License +instance Structured License instance NFData License where rnf NONE = () diff --git a/Distribution/SPDX/LicenseExceptionId.hs b/Distribution/SPDX/LicenseExceptionId.hs --- a/Distribution/SPDX/LicenseExceptionId.hs +++ b/Distribution/SPDX/LicenseExceptionId.hs @@ -12,9 +12,11 @@ import Distribution.Compat.Prelude import Prelude () +import Distribution.Compat.Lens (set) import Distribution.Pretty import Distribution.Parsec import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) import Distribution.SPDX.LicenseListVersion import qualified Data.Binary.Get as Binary @@ -74,6 +76,10 @@ if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) then fail "Too large LicenseExceptionId tag" else return (toEnum (fromIntegral i)) + +-- note: remember to bump version each time the definition changes +instance Structured LicenseExceptionId where + structure p = set typeVersion 306 $ nominalStructure p instance Pretty LicenseExceptionId where pretty = Disp.text . licenseExceptionId diff --git a/Distribution/SPDX/LicenseExpression.hs b/Distribution/SPDX/LicenseExpression.hs --- a/Distribution/SPDX/LicenseExpression.hs +++ b/Distribution/SPDX/LicenseExpression.hs @@ -60,6 +60,8 @@ instance Binary LicenseExpression instance Binary SimpleLicenseExpression +instance Structured SimpleLicenseExpression +instance Structured LicenseExpression instance Pretty LicenseExpression where pretty = go 0 diff --git a/Distribution/SPDX/LicenseId.hs b/Distribution/SPDX/LicenseId.hs --- a/Distribution/SPDX/LicenseId.hs +++ b/Distribution/SPDX/LicenseId.hs @@ -15,9 +15,11 @@ import Distribution.Compat.Prelude import Prelude () +import Distribution.Compat.Lens (set) import Distribution.Pretty import Distribution.Parsec import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) import Distribution.SPDX.LicenseListVersion import qualified Data.Binary.Get as Binary @@ -412,6 +414,10 @@ if i > fromIntegral (fromEnum (maxBound :: LicenseId)) then fail "Too large LicenseId tag" else return (toEnum (fromIntegral i)) + +-- note: remember to bump version each time the definition changes +instance Structured LicenseId where + structure p = set typeVersion 306 $ nominalStructure p instance Pretty LicenseId where pretty = Disp.text . licenseId diff --git a/Distribution/SPDX/LicenseReference.hs b/Distribution/SPDX/LicenseReference.hs --- a/Distribution/SPDX/LicenseReference.hs +++ b/Distribution/SPDX/LicenseReference.hs @@ -34,6 +34,7 @@ licenseDocumentRef = _lrDocument instance Binary LicenseRef +instance Structured LicenseRef instance NFData LicenseRef where rnf (LicenseRef d l) = rnf d `seq` rnf l diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -524,9 +524,9 @@ ++ "but the package does not have a library." sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | not (null nonExistant) + | exe1 : _ <- nonExistant = die' verbosity $ "The buildinfo contains info for an executable called '" - ++ prettyShow (head nonExistant) ++ "' but the package does not have a " + ++ prettyShow exe1 ++ "' but the package does not have a " ++ "executable with that name." where pkgExeNames = nub (map exeName (executables pkg_descr)) diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -30,6 +30,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec @@ -154,7 +155,9 @@ target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of -- This seems DEEPLY questionable. - [] -> return (head (allTargetsInBuildOrder' pkg_descr lbi)) + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target:_) -> return target + [] -> die' verbosity $ "Failed to determine target." [target] -> return target _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] @@ -180,7 +183,7 @@ componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity buildComponent verbosity NoFlag pkg_descr lbi' suffixes comp clbi distPref - | subtarget <- init componentsToBuild ] + | subtarget <- safeInit componentsToBuild ] -- REPL for target components let clbi = targetCLBI target diff --git a/Distribution/Simple/Build/Macros.hs b/Distribution/Simple/Build/Macros.hs --- a/Distribution/Simple/Build/Macros.hs +++ b/Distribution/Simple/Build/Macros.hs @@ -109,9 +109,9 @@ ++ generateMacros "TOOL_" progname version | prog <- progs , isJust . programVersion $ prog - , let progid = programId prog ++ "-" ++ prettyShow version - progname = map fixchar (programId prog) - Just version = programVersion prog + , let progid = programId prog ++ "-" ++ prettyShow version + progname = map fixchar (programId prog) + version = fromMaybe version0 (programVersion prog) ] -- | Common implementation of 'generatePackageVersionMacros' and @@ -131,7 +131,11 @@ ] ,"\n"] where - (major1:major2:minor:_) = map show (versionNumbers version ++ repeat 0) + (major1,major2,minor) = case map show (versionNumbers version) of + [] -> ("0", "0", "0") + [x] -> (x, "0", "0") + [x,y] -> (x, y, "0") + (x:y:z:_) -> (x, y, z) -- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID -- of the current package. diff --git a/Distribution/Simple/BuildTarget.hs b/Distribution/Simple/BuildTarget.hs --- a/Distribution/Simple/BuildTarget.hs +++ b/Distribution/Simple/BuildTarget.hs @@ -58,6 +58,7 @@ import Control.Monad ( msum ) import Data.List ( stripPrefix, groupBy, partition ) +import qualified Data.List.NonEmpty as NE import Data.Either ( partitionEithers ) import System.FilePath as FilePath ( dropExtension, normalise, splitDirectories, joinPath, splitPath @@ -318,8 +319,9 @@ where classifyMatchErrors errs - | not (null expected) = let (things, got:_) = unzip expected in - BuildTargetExpected userTarget things got + | Just expected' <- NE.nonEmpty expected + = let (things, got:|_) = NE.unzip expected' in + BuildTargetExpected userTarget (NE.toList things) got | not (null nosuch) = BuildTargetNoSuch userTarget nosuch | otherwise = error $ "resolveBuildTarget: internal error in matching" where diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -103,6 +103,7 @@ deriving (Eq, Generic, Typeable, Show, Read) instance Binary Compiler +instance Structured Compiler showCompilerId :: Compiler -> String showCompilerId = prettyShow . compilerId @@ -171,9 +172,10 @@ data PackageDB = GlobalPackageDB | UserPackageDB | SpecificPackageDB FilePath - deriving (Eq, Generic, Ord, Show, Read) + deriving (Eq, Generic, Ord, Show, Read, Typeable) instance Binary PackageDB +instance Structured PackageDB -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example @@ -197,8 +199,9 @@ -- the top of the stack. -- registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB [] = error "internal error: empty package db set" -registrationPackageDB dbs = last dbs +registrationPackageDB dbs = case safeLast dbs of + Nothing -> error "internal error: empty package db set" + Just p -> p -- | Make package paths absolute @@ -223,9 +226,10 @@ data OptimisationLevel = NoOptimisation | NormalOptimisation | MaximumOptimisation - deriving (Bounded, Enum, Eq, Generic, Read, Show) + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) instance Binary OptimisationLevel +instance Structured OptimisationLevel flagToOptimisationLevel :: Maybe String -> OptimisationLevel flagToOptimisationLevel Nothing = NormalOptimisation @@ -250,9 +254,10 @@ | MinimalDebugInfo | NormalDebugInfo | MaximalDebugInfo - deriving (Bounded, Enum, Eq, Generic, Read, Show) + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) instance Binary DebugInfoLevel +instance Structured DebugInfoLevel flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo @@ -405,9 +410,10 @@ | ProfDetailToplevelFunctions | ProfDetailAllFunctions | ProfDetailOther String - deriving (Eq, Generic, Read, Show) + deriving (Eq, Generic, Read, Show, Typeable) instance Binary ProfDetailLevel +instance Structured ProfDetailLevel flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -54,7 +54,7 @@ , platformDefines, ) where -import Prelude () +import qualified Prelude (tail) import Distribution.Compat.Prelude import Distribution.Compiler @@ -113,7 +113,8 @@ import Control.Exception ( ErrorCall, Exception, evaluate, throw, throwIO, try ) import Control.Monad ( forM, forM_ ) -import Distribution.Compat.Binary ( decodeOrFailIO, encode ) +import Data.List.NonEmpty ( nonEmpty ) +import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) import Distribution.Compat.Directory ( listDirectory ) import Data.ByteString.Lazy ( ByteString ) import qualified Data.ByteString as BS @@ -211,7 +212,7 @@ Right x -> x let getStoredValue = do - result <- decodeOrFailIO (BLC8.tail body) + result <- structuredDecodeOrFailIO (BLC8.tail body) case result of Left _ -> throw ConfigStateFileNoParse Right x -> return x @@ -256,7 +257,7 @@ writePersistBuildConfig distPref lbi = do createDirectoryIfMissing False distPref writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, encode lbi] + BLC8.unlines [showHeader pkgId, structuredEncode lbi] where pkgId = localPackage lbi @@ -971,7 +972,7 @@ -- Reinterpret the "package name" as an unqualified component -- name = LSubLibName $ packageNameToUnqualComponentName depName - -- Check whether a libray exists and is visible. + -- Check whether a library exists and is visible. -- We don't disambiguate between dependency on non-existent or private -- library yet, so we just return a bool and later report a generic error. visible lib = maybe @@ -1314,19 +1315,22 @@ -- It's an external package, normal situation do_external_external = - case PackageIndex.lookupDependency installedIndex dep_pkgname vr of - [] -> Left (DependencyNotExists dep_pkgname) - pkgs -> Right $ head $ snd $ last pkgs + case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg -- It's an internal library, being looked up externally do_external_internal :: LibraryName -> Either FailedDependency InstalledPackageInfo do_external_internal ln = - case PackageIndex.lookupInternalDependency installedIndex + case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex (packageName pkgid) vr ln of - [] -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid)) - pkgs -> Right $ head $ snd $ last pkgs + Nothing -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid)) + Just pkg -> Right pkg + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + reportSelectedDependencies :: Verbosity -> [ResolvedDependency] -> IO () reportSelectedDependencies verbosity deps = @@ -1772,7 +1776,7 @@ findOffendingHdr = ifBuildsWith allHeaders ccArgs (return Nothing) - (go . tail . inits $ allHeaders) + (go . Prelude.tail . inits $ allHeaders) -- inits always contains at least [] where go [] = return Nothing -- cannot happen go (hdrs:hdrsInits) = @@ -1781,9 +1785,10 @@ -- If that works, try compiling too (ifBuildsWith hdrs ccArgs (go hdrsInits) - (return . Just . Right . last $ hdrs)) - (return . Just . Left . last $ hdrs) + (return . fmap Right . safeLast $ hdrs)) + (return . fmap Left . safeLast $ hdrs) + cppArgs = "-E":commonCppArgs -- preprocess only ccArgs = "-c":commonCcArgs -- don't try to link @@ -2003,7 +2008,7 @@ -- database to which the package is installed are relative to the -- prefix of the package depsPrefixRelative = do - pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi)) + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) traverse_ (doCheck pkgr) ipkgs where doCheck pkgr ipkg diff --git a/Distribution/Simple/Flag.hs b/Distribution/Simple/Flag.hs --- a/Distribution/Simple/Flag.hs +++ b/Distribution/Simple/Flag.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- @@ -51,9 +52,10 @@ -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. -- -data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read) +data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable) instance Binary a => Binary (Flag a) +instance Structured a => Structured (Flag a) instance Functor Flag where fmap f (Flag x) = Flag (f x) diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -138,11 +138,11 @@ (userMaybeSpecifyPath "ghc" hcPath conf0) let implInfo = ghcVersionImplInfo ghcVersion - -- Cabal currently supports ghc >= 7.0.1 && < 8.10 - unless (ghcVersion < mkVersion [8,10]) $ + -- Cabal currently supports ghc >= 7.0.1 && < 8.12 + unless (ghcVersion < mkVersion [8,12]) $ warn verbosity $ "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.10): " + ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.12): " ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion -- This is slightly tricky, we have to configure ghc first, then we use the @@ -317,7 +317,7 @@ getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg where - Just version = programVersion ghcProg + version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg implInfo = ghcVersionImplInfo version -- | Given a single package DB, return all installed packages. @@ -363,7 +363,7 @@ return $! mconcat indices where - Just ghcProg = lookupProgram ghcProgram progdb + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = @@ -396,7 +396,7 @@ platformAndVersion = Internal.ghcPlatformAndVersionString platform ghcVersion packageConfFileName = "package.conf.d" - Just ghcVersion = programVersion ghcProg + ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg checkPackageDbEnvVar :: Verbosity -> IO () checkPackageDbEnvVar verbosity = @@ -475,7 +475,7 @@ if isFileStyle then return path else return (path "package.cache") - Just ghcProg = lookupProgram ghcProgram progdb + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb -- ----------------------------------------------------------------------------- @@ -1139,24 +1139,26 @@ -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg - | not (null main_fn) && isLower (head main_fn) + | headOf main_fn isLower -- The arg looked like "Foo.Bar.baz" = Just (ModuleName.fromString main_mod) - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" = Just (ModuleName.fromString arg) | otherwise -- The arg looked like "baz" = Nothing where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + (main_mod, main_fn) = splitLongestPrefix arg (== '.') splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix str pred' | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + -- 'safeTail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred' (reverse str) - -- | A collection of: -- * C input files -- * C++ input files @@ -2030,9 +2032,9 @@ , HcPkg.suppressFilesCheck = v >= [6,6] } where - v = versionNumbers ver - Just ghcPkgProg = lookupProgram ghcPkgProgram progdb - Just ver = programVersion ghcPkgProg + v = versionNumbers ver + ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb + ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg registerPackage :: Verbosity @@ -2049,7 +2051,7 @@ pkgRoot verbosity lbi = pkgRoot' where pkgRoot' GlobalPackageDB = - let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) + let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) pkgRoot' UserPackageDB = do appDir <- getAppUserDataDirectory "ghc" diff --git a/Distribution/Simple/GHCJS.hs b/Distribution/Simple/GHCJS.hs --- a/Distribution/Simple/GHCJS.hs +++ b/Distribution/Simple/GHCJS.hs @@ -241,7 +241,7 @@ getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg where - Just version = programVersion ghcjsProg + version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg implInfo = ghcVersionImplInfo version -- | Given a single package DB, return all installed packages. @@ -275,7 +275,7 @@ return $! (mconcat indices) where - Just ghcjsProg = lookupProgram ghcjsProgram progdb + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = @@ -307,7 +307,7 @@ platformAndVersion = Internal.ghcPlatformAndVersionString platform ghcjsVersion packageConfFileName = "package.conf.d" - Just ghcjsVersion = programVersion ghcjsProg + ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg checkPackageDbEnvVar :: Verbosity -> IO () checkPackageDbEnvVar verbosity = @@ -360,7 +360,7 @@ if isFileStyle then return path else return (path "package.cache") - Just ghcjsProg = lookupProgram ghcjsProgram progdb + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb toJSLibName :: String -> String @@ -926,21 +926,24 @@ -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg - | not (null main_fn) && isLower (head main_fn) + | headOf main_fn isLower -- The arg looked like "Foo.Bar.baz" = Just (ModuleName.fromString main_mod) - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" = Just (ModuleName.fromString arg) | otherwise -- The arg looked like "baz" = Nothing where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + (main_mod, main_fn) = splitLongestPrefix arg (== '.') splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix str pred' | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + -- 'safeTail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred' (reverse str) @@ -1779,8 +1782,8 @@ } where v7_10 = mkVersion [7,10] - Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb - Just ver = programVersion ghcjsPkgProg + ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb + ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg registerPackage :: Verbosity @@ -1797,7 +1800,7 @@ pkgRoot verbosity lbi = pkgRoot' where pkgRoot' GlobalPackageDB = - let Just ghcjsProg = lookupProgram ghcjsProgram (withPrograms lbi) + let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) pkgRoot' UserPackageDB = do appDir <- getAppUserDataDirectory "ghcjs" @@ -1827,4 +1830,4 @@ ) where script = exe <.> "jsexe" "all" <.> "js" - Just ghcjsProg = lookupProgram ghcjsProgram progdb + ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb diff --git a/Distribution/Simple/Glob.hs b/Distribution/Simple/Glob.hs --- a/Distribution/Simple/Glob.hs +++ b/Distribution/Simple/Glob.hs @@ -37,6 +37,8 @@ import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) +import qualified Data.List.NonEmpty as NE + -- Note throughout that we use splitDirectories, not splitPath. On -- Posix, this makes no difference, but, because Windows accepts both -- slash and backslash as its path separators, if we left in the @@ -151,7 +153,7 @@ fileGlobMatchesSegments pat' segs GlobFinal final -> case final of FinalMatch Recursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions (last $ seg:segs) + let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) guard (not (null candidateBase)) checkExt multidot ext candidateExts FinalMatch NonRecursive multidot ext -> do diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -66,6 +66,7 @@ import Distribution.Parsec (simpleParsec) import Distribution.Utils.NubList import Distribution.Version +import qualified Distribution.Utils.ShortText as ShortText import Distribution.Verbosity import Language.Haskell.Extension @@ -352,20 +353,23 @@ ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs -fromPackageDescription haddockTarget pkg_descr = - mempty { argInterfaceFile = Flag $ haddockName pkg_descr, - argPackageName = Flag $ packageId $ pkg_descr, - argOutputDir = Dir $ - "doc" "html" haddockDirName haddockTarget pkg_descr, - argPrologue = Flag $ if null desc then synopsis pkg_descr - else desc, - argTitle = Flag $ showPkg ++ subtitle - } - where - desc = PD.description pkg_descr - showPkg = prettyShow (packageId pkg_descr) - subtitle | null (synopsis pkg_descr) = "" - | otherwise = ": " ++ synopsis pkg_descr +fromPackageDescription haddockTarget pkg_descr = mempty + { argInterfaceFile = Flag $ haddockName pkg_descr + , argPackageName = Flag $ packageId $ pkg_descr + , argOutputDir = Dir $ + "doc" "html" haddockDirName haddockTarget pkg_descr + , argPrologue = Flag $ ShortText.fromShortText $ + if ShortText.null desc + then synopsis pkg_descr + else desc + , argTitle = Flag $ showPkg ++ subtitle + } + where + desc = PD.description pkg_descr + showPkg = prettyShow (packageId pkg_descr) + subtitle + | ShortText.null (synopsis pkg_descr) = "" + | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath @@ -521,7 +525,11 @@ haddockVersionMacro = "-D__HADDOCK_VERSION__=" ++ show (v1 * 1000 + v2 * 10 + v3) where - [v1, v2, v3] = take 3 $ versionNumbers haddockVersion ++ [0,0] + (v1, v2, v3) = case versionNumbers haddockVersion of + [] -> (0,0,0) + [x] -> (x,0,0) + [x,y] -> (x,y,0) + (x:y:z:_) -> (x,y,z) getGhcLibDir :: Verbosity -> LocalBuildInfo -> IO HaddockArgs diff --git a/Distribution/Simple/HaskellSuite.hs b/Distribution/Simple/HaskellSuite.hs --- a/Distribution/Simple/HaskellSuite.hs +++ b/Distribution/Simple/HaskellSuite.hs @@ -9,6 +9,7 @@ import Data.Either (partitionEithers) import qualified Data.Map as Map (empty) +import qualified Data.List.NonEmpty as NE import Distribution.Simple.Program import Distribution.Simple.Compiler as Compiler @@ -91,15 +92,15 @@ hstoolVersion = findProgramVersion "--hspkg-version" id numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) -numericVersion = findProgramVersion "--compiler-version" (last . words) +numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) getCompilerVersion verbosity prog = do output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] let parts = words output - name = concat $ init parts -- there shouldn't be any spaces in the name anyway - versionStr = last parts + name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway + versionStr = fromMaybe "" $ safeLast parts version <- maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ simpleParsec versionStr @@ -137,9 +138,9 @@ where parsePackages str = - case partitionEithers $ map parseInstalledPackageInfo (splitPkgs str) of + case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of ([], ok) -> Right [ pkg | (_, pkg) <- ok ] - (msgss, _) -> Left (concat msgss) + (msgss, _) -> Left (foldMap NE.toList msgss) splitPkgs :: String -> [String] splitPkgs = map unlines . splitWith ("---" ==) . lines @@ -216,8 +217,8 @@ runProgramInvocation verbosity $ (programInvocation hspkg - ["update", packageDbOpt $ last packageDbs]) - { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo } + ["update", packageDbOpt $ registrationPackageDB packageDbs]) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo } initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () initPackageDB verbosity progdb dbPath = diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -98,9 +99,10 @@ htmldir :: dir, haddockdir :: dir, sysconfdir :: dir - } deriving (Eq, Read, Show, Functor, Generic) + } deriving (Eq, Read, Show, Functor, Generic, Typeable) instance Binary dir => Binary (InstallDirs dir) +instance Structured dir => Structured (InstallDirs dir) instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where mempty = gmempty @@ -352,9 +354,10 @@ -- substituted for to get a real 'FilePath'. -- newtype PathTemplate = PathTemplate [PathComponent] - deriving (Eq, Ord, Generic) + deriving (Eq, Ord, Generic, Typeable) instance Binary PathTemplate +instance Structured PathTemplate type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] diff --git a/Distribution/Simple/InstallDirs/Internal.hs b/Distribution/Simple/InstallDirs/Internal.hs --- a/Distribution/Simple/InstallDirs/Internal.hs +++ b/Distribution/Simple/InstallDirs/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.InstallDirs.Internal ( PathComponent(..) @@ -10,9 +11,10 @@ data PathComponent = Ordinary FilePath | Variable PathTemplateVariable - deriving (Eq, Ord, Generic) + deriving (Eq, Ord, Generic, Typeable) instance Binary PathComponent +instance Structured PathComponent data PathTemplateVariable = PrefixVar -- ^ The @$prefix@ path variable @@ -39,9 +41,10 @@ | TestSuiteResultVar -- ^ The result of the test suite being run, eg -- @pass@, @fail@, or @error@. | BenchmarkNameVar -- ^ The name of the benchmark being run - deriving (Eq, Ord, Generic) + deriving (Eq, Ord, Generic, Typeable) instance Binary PathTemplateVariable +instance Structured PathTemplateVariable instance Show PathTemplateVariable where show PrefixVar = "prefix" diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs --- a/Distribution/Simple/PackageIndex.hs +++ b/Distribution/Simple/PackageIndex.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -112,6 +113,7 @@ import qualified Data.Array as Array import qualified Data.Graph as Graph import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) +import qualified Data.List.NonEmpty as NE import qualified Data.Tree as Tree import Control.Monad import Distribution.Compat.Stack @@ -143,9 +145,10 @@ -- preserved. See #1463 for discussion. packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) - } deriving (Eq, Generic, Show, Read) + } deriving (Eq, Generic, Show, Read, Typeable) instance Binary a => Binary (PackageIndex a) +instance Structured a => Structured (PackageIndex a) -- | The default package index which contains 'InstalledPackageInfo'. Normally -- use this. @@ -210,20 +213,20 @@ -- ones. -- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex -fromList pkgs = mkPackageIndex pids pnames +fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) where pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] pnames = Map.fromList - [ (liftM2 (,) packageName IPI.sourceLibName (head pkgsN), pvers) - | pkgsN <- groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) + | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) $ pkgs , let pvers = Map.fromList - [ (packageVersion (head pkgsNV), - nubBy (equating installedUnitId) (reverse pkgsNV)) - | pkgsNV <- groupBy (equating packageVersion) pkgsN + [ (packageVersion (NE.head pkgsNV), + NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN ] ] diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -269,7 +269,7 @@ let (srcStem, ext) = splitExtension psrcRelFile psrcFile = psrcLoc psrcRelFile pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") - (lookup (tailNotNull ext) handlers) + (lookup (safeTail ext) handlers) -- Preprocessing files for 'sdist' is different from preprocessing -- for 'build'. When preprocessing for sdist we preprocess to -- avoid that the user has to have the preprocessors available. @@ -296,8 +296,6 @@ where dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files -- be in the same place as the hs files, so if we put the hs file in dist/ @@ -727,8 +725,9 @@ pp $ buildDir lbi nm' nm' ++ "-tmp" TestSuiteLibV09 _ _ -> pp $ buildDir lbi stubName test stubName test ++ "-tmp" - TestSuiteUnsupported tt -> die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test suite type " ++ + prettyShow tt CBench bm -> do let nm' = unUnqualComponentName $ benchmarkName bm case benchmarkInterface bm of diff --git a/Distribution/Simple/PreProcess/Unlit.hs b/Distribution/Simple/PreProcess/Unlit.hs --- a/Distribution/Simple/PreProcess/Unlit.hs +++ b/Distribution/Simple/PreProcess/Unlit.hs @@ -17,6 +17,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic (safeTail, safeLast, safeInit) import Data.List (mapAccumL) @@ -33,12 +34,10 @@ classify :: String -> Classified classify ('>':s) = BirdTrack s classify ('#':s) = case tokens s of - (line:file:_) | all isDigit line - && length file >= 2 - && head file == '"' - && last file == '"' + (line:file@('"':_:_):_) | all isDigit line + && safeLast file == Just '"' -- this shouldn't fail as we tested for 'all isDigit' - -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (tail (init file)) -- TODO:eradicateNoParse + -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse _ -> CPP s where tokens = unfoldr $ \str -> case lex str of (t@(_:_), str'):_ -> Just (t, str') diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -61,6 +61,7 @@ , programInvocation , runProgramInvocation , getProgramInvocationOutput + , getProgramInvocationLBS -- * The collection of unconfigured and configured programs , builtinPrograms diff --git a/Distribution/Simple/Program/Db.hs b/Distribution/Simple/Program/Db.hs --- a/Distribution/Simple/Program/Db.hs +++ b/Distribution/Simple/Program/Db.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | @@ -61,19 +61,21 @@ ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Find +import Distribution.Pretty import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Types import Distribution.Simple.Utils -import Distribution.Version -import Distribution.Pretty +import Distribution.Utils.Structured (Structure (..), Structured (..)) import Distribution.Verbosity +import Distribution.Version import Control.Monad (join) -import Data.Tuple (swap) +import Data.Tuple (swap) + import qualified Data.Map as Map -- ------------------------------------------------------------ @@ -150,6 +152,12 @@ progSearchPath = searchpath, configuredProgs = progs } + +instance Structured ProgramDb where + structure p = Nominal (typeRep p) 0 "ProgramDb" + [ structure (Proxy :: Proxy ProgramSearchPath) + , structure (Proxy :: Proxy ConfiguredProgs) + ] -- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the diff --git a/Distribution/Simple/Program/Find.hs b/Distribution/Simple/Program/Find.hs --- a/Distribution/Simple/Program/Find.hs +++ b/Distribution/Simple/Program/Find.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -67,9 +68,10 @@ data ProgramSearchPathEntry = ProgramSearchPathDir FilePath -- ^ A specific dir | ProgramSearchPathDefault -- ^ The system default - deriving (Eq, Generic) + deriving (Eq, Generic, Typeable) instance Binary ProgramSearchPathEntry +instance Structured ProgramSearchPathEntry defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] diff --git a/Distribution/Simple/Program/GHC.hs b/Distribution/Simple/Program/GHC.hs --- a/Distribution/Simple/Program/GHC.hs +++ b/Distribution/Simple/Program/GHC.hs @@ -45,7 +45,6 @@ import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (All(..), Any(..), Endo(..)) -import Data.Set (Set) import qualified Data.Set as Set normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] @@ -56,7 +55,7 @@ supportedGHCVersions :: VersionRange supportedGHCVersions = intersectVersionRanges (orLaterVersion (mkVersion [8,0])) - (earlierVersion (mkVersion [8,9])) + (earlierVersion (mkVersion [8,11])) from :: Monoid m => [Int] -> m -> m from version flags @@ -193,6 +192,11 @@ ] , from [8,4] ["show-loaded-modules"] , from [8,6] [ "ghci-leak-check", "no-it" ] + , from [8,10] + [ "defer-diagnostics" -- affects printing of diagnostics + , "keep-going" -- try harder, the build will still fail if it's erroneous + , "print-axiom-incomps" -- print more debug info for closed type families + ] ] , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] , isOptIntFlag @@ -764,8 +768,10 @@ --------------- -- Inputs - , [ prettyShow modu | modu <- flags ghcOptInputModules ] + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. , flags ghcOptInputFiles + , [ prettyShow modu | modu <- flags ghcOptInputModules ] , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs --- a/Distribution/Simple/Program/HcPkg.hs +++ b/Distribution/Simple/Program/HcPkg.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -42,29 +44,28 @@ listInvocation, ) where -import Prelude () import Distribution.Compat.Prelude hiding (init) - -import Data.Either (partitionEithers) +import Prelude () +import Distribution.Compat.Exception import Distribution.InstalledPackageInfo +import Distribution.Parsec +import Distribution.Pretty import Distribution.Simple.Compiler -import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types import Distribution.Simple.Utils -import Distribution.Parsec -import Distribution.Pretty import Distribution.Types.ComponentId import Distribution.Types.PackageId import Distribution.Types.UnitId import Distribution.Verbosity -import Distribution.Compat.Exception -import Data.List - ( stripPrefix ) -import System.FilePath as FilePath - ( (), (<.>) - , splitPath, splitDirectories, joinPath, isPathSeparator ) +import Data.List (stripPrefix) +import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), ()) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE import qualified System.FilePath.Posix as FilePath.Posix -- | Information about the features and capabilities of an @hc-pkg@ @@ -161,7 +162,7 @@ -- | registerMultiInstance registerOptions , recacheMultiInstance hpi - = do let pkgdb = last packagedbs + = do let pkgdb = registrationPackageDB packagedbs writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo recache hpi verbosity pkgdb @@ -224,9 +225,9 @@ describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] describe hpi verbosity packagedb pid = do - output <- getProgramInvocationOutput verbosity + output <- getProgramInvocationLBS verbosity (describeInvocation hpi verbosity packagedb pid) - `catchIO` \_ -> return "" + `catchIO` \_ -> return mempty case parsePackages output of Left ok -> return ok @@ -249,7 +250,7 @@ dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] dump hpi verbosity packagedb = do - output <- getProgramInvocationOutput verbosity + output <- getProgramInvocationLBS verbosity (dumpInvocation hpi verbosity packagedb) `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " ++ displayException e @@ -259,27 +260,51 @@ _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " dump'" -parsePackages :: String -> Either [InstalledPackageInfo] [String] -parsePackages str = - case partitionEithers $ map parseInstalledPackageInfo (splitPkgs str) of - ([], ok) -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] - (msgss, _) -> Right (concat msgss) ---TODO: this could be a lot faster. We're doing normaliseLineEndings twice --- and converting back and forth with lines/unlines. -splitPkgs :: String -> [String] -splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines +parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] +parsePackages lbs0 = + case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of + Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] + Left msgs -> Right (NE.toList msgs) where - -- Handle the case of there being no packages at all. - checkEmpty [s] | all isSpace s = [] - checkEmpty ss = ss + splitPkgs :: LBS.ByteString -> [BS.ByteString] + splitPkgs = checkEmpty . doSplit + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | BS.all isSpace8 s = [] + checkEmpty ss = ss - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs + isSpace8 :: Word8 -> Bool + isSpace8 9 = True -- '\t' + isSpace8 10 = True -- '\n' + isSpace8 13 = True -- '\r' + isSpace8 32 = True -- ' ' + isSpace8 _ = False + doSplit :: LBS.ByteString -> [BS.ByteString] + doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) + where + go :: [Int64] -> [BS.ByteString] + go [] = [ LBS.toStrict lbs ] + go (idx:idxs) = + let (pfx, sfx) = LBS.splitAt idx lbs + in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + Just sfx' -> LBS.toStrict pfx : doSplit sfx' + Nothing -> go idxs + + separators :: [LBS.ByteString] + separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] + +lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString +#if MIN_VERSION_bytestring(0,10,8) +lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs +#else +lbsStripPrefix pfx lbs + | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs) + | otherwise = Nothing +#endif + + mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) @@ -375,7 +400,7 @@ -> ProgramInvocation registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = (programInvocation (hcPkgProgram hpi) (args "-")) { - progInvokeInput = Just (showInstalledPackageInfo pkgInfo), + progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, progInvokeInputEncoding = IOEncodingUTF8 } where @@ -385,9 +410,7 @@ | otherwise = "register" args file = [cmdname, file] - ++ (if noPkgDbStack hpi - then [packageDbOpts hpi (last packagedbs)] - else packageDbStackOpts hpi packagedbs) + ++ packageDbStackOpts hpi packagedbs ++ [ "--enable-multi-instance" | registerMultiInstance registerOptions ] ++ [ "--force-files" @@ -422,9 +445,7 @@ describeInvocation hpi verbosity packagedbs pkgid = programInvocation (hcPkgProgram hpi) $ ["describe", prettyShow pkgid] - ++ (if noPkgDbStack hpi - then [packageDbOpts hpi (last packagedbs)] - else packageDbStackOpts hpi packagedbs) + ++ packageDbStackOpts hpi packagedbs ++ verbosityOpts hpi verbosity hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId @@ -459,19 +480,21 @@ packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] -packageDbStackOpts hpi dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : ("--no-user-" ++ packageDbFlag hpi) - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) +packageDbStackOpts hpi dbstack + | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] + | otherwise = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi diff --git a/Distribution/Simple/Program/Internal.hs b/Distribution/Simple/Program/Internal.hs --- a/Distribution/Simple/Program/Internal.hs +++ b/Distribution/Simple/Program/Internal.hs @@ -13,6 +13,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic(safeTail) -- | Extract the version number from the output of 'strip --version'. -- @@ -29,7 +30,7 @@ filterPar' :: Int -> [String] -> [String] filterPar' _ [] = [] filterPar' n (x:xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((tail x):xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs) | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs | n > 0 = filterPar' n xs | otherwise = x:filterPar' n xs diff --git a/Distribution/Simple/Program/Run.hs b/Distribution/Simple/Program/Run.hs --- a/Distribution/Simple/Program/Run.hs +++ b/Distribution/Simple/Program/Run.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | @@ -22,24 +23,27 @@ runProgramInvocation, getProgramInvocationOutput, + getProgramInvocationLBS, getProgramInvocationOutputAndErrors, getEffectiveEnvironment, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.Compat.Environment import Distribution.Simple.Program.Types import Distribution.Simple.Utils +import Distribution.Utils.Generic import Distribution.Verbosity -import Distribution.Compat.Environment -import qualified Data.Map as Map +import System.Exit (ExitCode (..), exitWith) import System.FilePath -import System.Exit - ( ExitCode(..), exitWith ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map + -- | Represents a specific invocation of a specific program. -- -- This is used as an intermediate type between deciding how to call a program @@ -54,17 +58,18 @@ -- Extra paths to add to PATH progInvokePathEnv :: [FilePath], progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe String, - progInvokeInputEncoding :: IOEncoding, + progInvokeInput :: Maybe IOData, + progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. progInvokeOutputEncoding :: IOEncoding } data IOEncoding = IOEncodingText -- locale mode text | IOEncodingUTF8 -- always utf8 -encodeToIOData :: IOEncoding -> String -> IOData -encodeToIOData IOEncodingText = IODataText -encodeToIOData IOEncodingUTF8 = IODataBinary . toUTF8LBS +encodeToIOData :: IOEncoding -> IOData -> IOData +encodeToIOData _ iod@(IODataBinary _) = iod +encodeToIOData IOEncodingText iod@(IODataText _) = iod +encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation = @@ -155,32 +160,41 @@ die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors return output +getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString +getProgramInvocationLBS verbosity inv = do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + when (exitCode /= ExitSuccess) $ + die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation -> IO (String, String, ExitCode) -getProgramInvocationOutputAndErrors verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = minputStr, - progInvokeOutputEncoding = encoding - } = do - let mode = case encoding of IOEncodingUTF8 -> IODataModeBinary - IOEncodingText -> IODataModeText - - decode (IODataBinary b) = normaliseLineEndings (fromUTF8LBS b) - decode (IODataText s) = s +getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of + IOEncodingText -> do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText + return (output, errors, exitCode) + IOEncodingUTF8 -> do + (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) +getProgramInvocationIODataAndErrors + :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode + -> IO (mode, String, ExitCode) +getProgramInvocationIODataAndErrors + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokePathEnv = extraPath + , progInvokeCwd = mcwd + , progInvokeInput = minputStr + , progInvokeInputEncoding = encoding + } + mode = do pathOverride <- getExtraPathEnv envOverrides extraPath menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - (output, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - input mode - return (decode output, errors, exitCode) + rawSystemStdInOut verbosity path args mcwd menv input mode where input = encodeToIOData encoding <$> minputStr @@ -243,13 +257,14 @@ chunkSize = maxCommandLineSize - fixedArgSize in case splitChunks chunkSize args of - [] -> [ simple ] + [] -> [ simple ] - [c] -> [ simple `appendArgs` c ] + [c] -> [ simple `appendArgs` c ] - (c:cs) -> [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- init cs ] - ++ [ final `appendArgs` c'| let c' = last cs ] + (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> + [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- xs ] + ++ [ final `appendArgs` x ] where appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation diff --git a/Distribution/Simple/Program/Script.hs b/Distribution/Simple/Program/Script.hs --- a/Distribution/Simple/Program/Script.hs +++ b/Distribution/Simple/Program/Script.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Script @@ -20,6 +21,7 @@ import Distribution.Compat.Prelude import Distribution.Simple.Program.Run +import Distribution.Simple.Utils import Distribution.System -- | Generate a system script, either POSIX shell script or Windows batch file @@ -45,8 +47,8 @@ ++ concatMap setEnv envExtra ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] ++ [ (case minput of - Nothing -> "" - Just input -> "echo " ++ quote input ++ " | ") + Nothing -> "" + Just input -> "echo " ++ quote (iodataToText input) ++ " | ") ++ unwords (map quote $ path : args) ++ " \"$@\""] where @@ -60,7 +62,11 @@ escape ('\'':cs) = "'\\''" ++ escape cs escape (c :cs) = c : escape cs +iodataToText :: IOData -> String +iodataToText (IODataText str) = str +iodataToText (IODataBinary lbs) = fromUTF8LBS lbs + -- | Generate a Windows batch file that invokes a program. -- invocationAsBatchFile :: ProgramInvocation -> String @@ -81,7 +87,7 @@ Just input -> [ "(" ] - ++ [ "echo " ++ escape line | line <- lines input ] + ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ] ++ [ ") | " ++ "\"" ++ path ++ "\"" ++ concatMap (\arg -> ' ':quote arg) args ] diff --git a/Distribution/Simple/Program/Types.hs b/Distribution/Simple/Program/Types.hs --- a/Distribution/Simple/Program/Types.hs +++ b/Distribution/Simple/Program/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -133,6 +134,7 @@ deriving (Eq, Generic, Read, Show, Typeable) instance Binary ConfiguredProgram +instance Structured ConfiguredProgram -- | Where a program was found. Also tells us whether it's specified by user or -- not. This includes not just the path, but the program as well. @@ -142,9 +144,10 @@ -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 | FoundOnSystem { locationPath :: FilePath } -- ^The program was found automatically. - deriving (Eq, Generic, Read, Show) + deriving (Eq, Generic, Read, Show, Typeable) instance Binary ProgramLocation +instance Structured ProgramLocation -- | The full path of a configured program. programPath :: ConfiguredProgram -> FilePath diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -57,7 +58,8 @@ defaultBenchmarkFlags, benchmarkCommand, CopyDest(..), configureArgs, configureOptions, configureCCompiler, configureLinker, - buildOptions, haddockOptions, installDirsOptions, testOptions', + buildOptions, haddockOptions, installDirsOptions, + testOptions', benchmarkOptions', programDbOptions, programDbPaths', programFlagsDescription, replOptions, @@ -126,7 +128,7 @@ data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool, globalNumericVersion :: Flag Bool - } deriving (Generic) + } deriving (Generic, Typeable) defaultGlobalFlags :: GlobalFlags defaultGlobalFlags = GlobalFlags { @@ -282,9 +284,10 @@ -- tools (like cabal-install) so they can add multiple-public-libraries -- compatibility to older ghcs by checking visibility externally. } - deriving (Generic, Read, Show) + deriving (Generic, Read, Show, Typeable) instance Binary ConfigFlags +instance Structured ConfigFlags -- | More convenient version of 'configPrograms'. Results in an -- 'error' if internal invariant is violated. @@ -1034,7 +1037,7 @@ sDistListSources :: Flag FilePath, sDistVerbosity :: Flag Verbosity } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags { @@ -1107,7 +1110,7 @@ regArgs :: [String], regCabalFilePath :: Flag FilePath } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) defaultRegisterFlags :: RegisterFlags defaultRegisterFlags = RegisterFlags { @@ -1221,7 +1224,7 @@ hscolourVerbosity :: Flag Verbosity, hscolourCabalFilePath :: Flag FilePath } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) emptyHscolourFlags :: HscolourFlags emptyHscolourFlags = mempty @@ -1314,7 +1317,7 @@ doctestDistPref :: Flag FilePath, doctestVerbosity :: Flag Verbosity } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) defaultDoctestFlags :: DoctestFlags defaultDoctestFlags = DoctestFlags { @@ -1382,9 +1385,10 @@ -- from documentation tarballs, and we might also want to use different -- flags than for development builds, so in this case we store the generated -- documentation in @/doc/html/-docs@. -data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic) +data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable) instance Binary HaddockTarget +instance Structured HaddockTarget instance Pretty HaddockTarget where pretty ForHackage = Disp.text "for-hackage" @@ -1417,7 +1421,7 @@ haddockCabalFilePath :: Flag FilePath, haddockArgs :: [String] } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) defaultHaddockFlags :: HaddockFlags defaultHaddockFlags = HaddockFlags { @@ -1590,7 +1594,7 @@ cleanVerbosity :: Flag Verbosity, cleanCabalFilePath :: Flag FilePath } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) defaultCleanFlags :: CleanFlags defaultCleanFlags = CleanFlags { @@ -1648,7 +1652,7 @@ buildArgs :: [String], buildCabalFilePath :: Flag FilePath } - deriving (Read, Show, Generic) + deriving (Read, Show, Generic, Typeable) defaultBuildFlags :: BuildFlags defaultBuildFlags = BuildFlags { @@ -1738,7 +1742,7 @@ replReload :: Flag Bool, replReplOptions :: [String] } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) defaultReplFlags :: ReplFlags defaultReplFlags = ReplFlags { @@ -1837,9 +1841,10 @@ -- ------------------------------------------------------------ data TestShowDetails = Never | Failures | Always | Streaming | Direct - deriving (Eq, Ord, Enum, Bounded, Generic, Show) + deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) instance Binary TestShowDetails +instance Structured TestShowDetails knownTestShowDetails :: [TestShowDetails] knownTestShowDetails = [minBound..maxBound] @@ -1875,7 +1880,7 @@ testFailWhenNoTestSuites :: Flag Bool, -- TODO: think about if/how options are passed to test exes testOptions :: [PathTemplate] - } deriving (Generic) + } deriving (Generic, Typeable) defaultTestFlags :: TestFlags defaultTestFlags = TestFlags { @@ -1995,7 +2000,7 @@ benchmarkDistPref :: Flag FilePath, benchmarkVerbosity :: Flag Verbosity, benchmarkOptions :: [PathTemplate] - } deriving (Generic) + } deriving (Generic, Typeable) defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags = BenchmarkFlags { @@ -2026,30 +2031,33 @@ , "BENCHCOMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultBenchmarkFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity benchmarkVerbosity - (\v flags -> flags { benchmarkVerbosity = v }) - , optionDistPref - benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) - showOrParseArgs - , option [] ["benchmark-options"] - ("give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["benchmark-option"] - ("give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] + , commandOptions = benchmarkOptions' } +benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions' showOrParseArgs = + [ optionVerbosity benchmarkVerbosity + (\v flags -> flags { benchmarkVerbosity = v }) + , optionDistPref + benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) + showOrParseArgs + , option [] ["benchmark-options"] + ("give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["benchmark-option"] + ("give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + emptyBenchmarkFlags :: BenchmarkFlags emptyBenchmarkFlags = mempty @@ -2225,7 +2233,7 @@ data ShowBuildInfoFlags = ShowBuildInfoFlags { buildInfoBuildFlags :: BuildFlags , buildInfoOutputFile :: Maybe FilePath - } deriving Show + } deriving (Show, Typeable) defaultShowBuildFlags :: ShowBuildInfoFlags defaultShowBuildFlags = diff --git a/Distribution/Simple/ShowBuildInfo.hs b/Distribution/Simple/ShowBuildInfo.hs --- a/Distribution/Simple/ShowBuildInfo.hs +++ b/Distribution/Simple/ShowBuildInfo.hs @@ -56,6 +56,9 @@ module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where +import Distribution.Compat.Prelude +import Prelude () + import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.Program.GHC as GHC @@ -122,7 +125,7 @@ ] where bi = componentBuildInfo comp - Just comp = lookupComponent pkg_descr name + comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name compType = case comp of CLib _ -> "lib" CExe _ -> "exe" diff --git a/Distribution/Simple/Test/LibV09.hs b/Distribution/Simple/Test/LibV09.hs --- a/Distribution/Simple/Test/LibV09.hs +++ b/Distribution/Simple/Test/LibV09.hs @@ -207,7 +207,9 @@ writeSimpleTestStub t dir = do createDirectoryIfMissing True dir let filename = dir stubFilePath t - PD.TestSuiteLibV09 _ m = PD.testInterface t + m = case PD.testInterface t of + PD.TestSuiteLibV09 _ m' -> m' + _ -> error "writeSimpleTestStub: invalid TestSuite passed" writeFile filename $ simpleTestStub m -- | Source code for library test suite stub executable diff --git a/Distribution/Simple/Test/Log.hs b/Distribution/Simple/Test/Log.hs --- a/Distribution/Simple/Test/Log.hs +++ b/Distribution/Simple/Test/Log.hs @@ -143,7 +143,7 @@ where addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) --- | Print a summary of a single test case's result to the console, supressing +-- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () summarizeTest _ _ (GroupLogs {}) = return () diff --git a/Distribution/Simple/UHC.hs b/Distribution/Simple/UHC.hs --- a/Distribution/Simple/UHC.hs +++ b/Distribution/Simple/UHC.hs @@ -24,7 +24,6 @@ import Prelude () import Distribution.Compat.Prelude -import Data.Foldable (toList) import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId) @@ -117,9 +116,11 @@ getGlobalPackageDir verbosity progdb = do output <- getDbProgramOutput verbosity uhcProgram progdb ["--meta-pkgdir-system"] - -- call to "lines" necessary, because pkgdir contains an extra newline at the end - let [pkgdir] = lines output + -- we need to trim because pkgdir contains an extra newline at the end + let pkgdir = trimEnd output return pkgdir + where + trimEnd = reverse . dropWhile isSpace . reverse getUserPackageDir :: NoCallStackIO FilePath getUserPackageDir = do @@ -278,7 +279,7 @@ -> InstalledPackageInfo -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo = do - dbdir <- case last packageDbs of + dbdir <- case registrationPackageDB packageDbs of GlobalPackageDB -> getGlobalPackageDir verbosity progdb UserPackageDB -> getUserPackageDir SpecificPackageDB dir -> return dir diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -60,7 +61,8 @@ -- "Distribution.Utils.IOData" for convience as they're -- exposed in the API of 'rawSystemStdInOut' IOData(..), - IODataMode(..), + KnownIODataMode (..), + IODataMode (..), -- * copying files createDirectoryIfMissingVerbose, @@ -150,7 +152,10 @@ ordNub, ordNubBy, ordNubRight, + safeHead, safeTail, + safeLast, + safeInit, unintersperse, wrapText, wrapLine, @@ -169,11 +174,12 @@ import Distribution.Compat.Prelude import Distribution.Utils.Generic -import Distribution.Utils.IOData (IOData(..), IODataMode(..)) +import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) import qualified Distribution.Utils.IOData as IOData import Distribution.ModuleName as ModuleName import Distribution.System import Distribution.Version +import Distribution.Compat.Async import Distribution.Compat.CopyFile import Distribution.Compat.Internal.TempFile import Distribution.Compat.Exception @@ -199,8 +205,6 @@ import Distribution.Pretty import Distribution.Parsec -import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, takeMVar ) import Data.Typeable ( cast ) import qualified Data.ByteString.Lazy as BS @@ -225,9 +229,9 @@ ( unsafeInterleaveIO ) import qualified Control.Exception as Exception +import Foreign.C.Error (Errno (..), ePIPE) import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) -import Control.Exception (IOException, evaluate, throwIO) -import Control.Concurrent (forkIO) +import Control.Exception (IOException, evaluate, throwIO, fromException) import Numeric (showFFloat) import qualified System.Process as Process ( CreateProcess(..), StdStream(..), proc) @@ -235,6 +239,8 @@ ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess , showCommandForUser, waitForProcess) +import qualified GHC.IO.Exception as GHC + import qualified Text.PrettyPrint as Disp -- We only get our own version number when we're building with ourselves @@ -244,7 +250,7 @@ #elif defined(CABAL_VERSION) cabalVersion = mkVersion [CABAL_VERSION] #else -cabalVersion = mkVersion [1,9999] --used when bootstrapping +cabalVersion = mkVersion [3,0] --used when bootstrapping #endif -- ---------------------------------------------------------------------------- @@ -792,11 +798,10 @@ -- -- The output is assumed to be text in the locale encoding. -- -rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode rawSystemStdout verbosity path args = withFrozenCallStack $ do - (IODataText output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing Nothing - Nothing IODataModeText + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) when (exitCode /= ExitSuccess) $ die' verbosity errors return output @@ -805,15 +810,16 @@ -- also supply some input. Also provides control over whether the binary/text -- mode of the input and output. -- -rawSystemStdInOut :: Verbosity +rawSystemStdInOut :: KnownIODataMode mode + => Verbosity -> FilePath -- ^ Program location -> [String] -- ^ Arguments -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit -> Maybe IOData -- ^ input text and binary mode - -> IODataMode -- ^ output in binary mode - -> IO (IOData, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args mcwd menv input outputMode = withFrozenCallStack $ do + -> IODataMode mode -- ^ iodata mode, acts as proxy + -> IO (mode, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do printRawCommandAndArgs verbosity path args Exception.bracket @@ -828,53 +834,49 @@ -- fork off a couple threads to pull on the stderr and stdout -- so if the process writes to stderr we do not block. - err <- hGetContents errh - - out <- IOData.hGetContents outh outputMode + withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do + -- push all the input, if any + ignoreSigPipe $ case input of + Nothing -> hClose inh + Just inputData -> IOData.hPutContents inh inputData - mv <- newEmptyMVar - let force str = do - mberr <- Exception.try (evaluate (rnf str) >> return ()) - putMVar mv (mberr :: Either IOError ()) - _ <- forkIO $ force out - _ <- forkIO $ force err + -- wait for both to finish + mberr1 <- waitCatch outA + mberr2 <- waitCatch errA - -- push all the input, if any - case input of - Nothing -> return () - Just inputData -> do - -- input mode depends on what the caller wants - IOData.hPutContents inh inputData - --TODO: this probably fails if the process refuses to consume - -- or if it closes stdin (eg if it exits) + -- wait for the program to terminate + exitcode <- waitForProcess pid - -- wait for both to finish, in either order - mberr1 <- takeMVar mv - mberr2 <- takeMVar mv + -- get the stderr, so it can be added to error message + err <- reportOutputIOError mberr2 - -- wait for the program to terminate - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just d | IOData.null d -> "" - Just (IODataText inp) -> "\nstdin input:\n" ++ inp - Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp - -- Check if we we hit an exception while consuming the output - -- (e.g. a text decoding error) - reportOutputIOError mberr1 - reportOutputIOError mberr2 + -- Check if we we hit an exception while consuming the output + -- (e.g. a text decoding error) + out <- reportOutputIOError mberr1 - return (out, err, exitcode) + return (out, err, exitcode) where - reportOutputIOError :: Either IOError () -> NoCallStackIO () - reportOutputIOError = - either (\e -> throwIO (ioeSetFileName e ("output of " ++ path))) - return + reportOutputIOError :: Either Exception.SomeException a -> NoCallStackIO a + reportOutputIOError (Right x) = return x + reportOutputIOError (Left exc) = case fromException exc of + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc + + ignoreSigPipe :: NoCallStackIO () -> NoCallStackIO () + ignoreSigPipe = Exception.handle $ \e -> case e of + GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e -- | Look for a program and try to find it's version number. It can accept -- either an absolute path or the name of a program binary, in which case we diff --git a/Distribution/System.hs b/Distribution/System.hs --- a/Distribution/System.hs +++ b/Distribution/System.hs @@ -101,7 +101,7 @@ deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary OS - +instance Structured OS instance NFData OS where rnf = genericRnf knownOSs :: [OS] @@ -169,7 +169,7 @@ deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary Arch - +instance Structured Arch instance NFData Arch where rnf = genericRnf knownArches :: [Arch] @@ -217,7 +217,7 @@ deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary Platform - +instance Structured Platform instance NFData Platform where rnf = genericRnf instance Pretty Platform where diff --git a/Distribution/Types/AbiDependency.hs b/Distribution/Types/AbiDependency.hs --- a/Distribution/Types/AbiDependency.hs +++ b/Distribution/Types/AbiDependency.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.AbiDependency where @@ -25,7 +26,7 @@ depUnitId :: Package.UnitId, depAbiHash :: Package.AbiHash } - deriving (Eq, Generic, Read, Show) + deriving (Eq, Generic, Read, Show, Typeable) instance Pretty AbiDependency where pretty (AbiDependency uid abi) = @@ -39,4 +40,5 @@ return (AbiDependency uid abi) instance Binary AbiDependency +instance Structured AbiDependency instance NFData AbiDependency where rnf = genericRnf diff --git a/Distribution/Types/AbiHash.hs b/Distribution/Types/AbiHash.hs --- a/Distribution/Types/AbiHash.hs +++ b/Distribution/Types/AbiHash.hs @@ -25,7 +25,7 @@ -- -- @since 2.0.0.2 newtype AbiHash = AbiHash ShortText - deriving (Eq, Show, Read, Generic) + deriving (Eq, Show, Read, Generic, Typeable) -- | Construct a 'AbiHash' from a 'String' -- @@ -51,7 +51,7 @@ fromString = mkAbiHash instance Binary AbiHash - +instance Structured AbiHash instance NFData AbiHash where rnf = genericRnf instance Pretty AbiHash where diff --git a/Distribution/Types/Benchmark.hs b/Distribution/Types/Benchmark.hs --- a/Distribution/Types/Benchmark.hs +++ b/Distribution/Types/Benchmark.hs @@ -31,7 +31,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary Benchmark - +instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf instance L.HasBuildInfo Benchmark where diff --git a/Distribution/Types/BenchmarkInterface.hs b/Distribution/Types/BenchmarkInterface.hs --- a/Distribution/Types/BenchmarkInterface.hs +++ b/Distribution/Types/BenchmarkInterface.hs @@ -34,7 +34,7 @@ deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary BenchmarkInterface - +instance Structured BenchmarkInterface instance NFData BenchmarkInterface where rnf = genericRnf instance Monoid BenchmarkInterface where diff --git a/Distribution/Types/BenchmarkType.hs b/Distribution/Types/BenchmarkType.hs --- a/Distribution/Types/BenchmarkType.hs +++ b/Distribution/Types/BenchmarkType.hs @@ -23,7 +23,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary BenchmarkType - +instance Structured BenchmarkType instance NFData BenchmarkType where rnf = genericRnf knownBenchmarkTypes :: [BenchmarkType] diff --git a/Distribution/Types/BuildInfo.hs b/Distribution/Types/BuildInfo.hs --- a/Distribution/Types/BuildInfo.hs +++ b/Distribution/Types/BuildInfo.hs @@ -82,7 +82,7 @@ -- Example 2: a library that is being built by a foreing tool (e.g. rust) -- and copied and registered together with this library. The -- logic on how this library is built will have to be encoded in a - -- custom Setup for now. Oherwise cabal would need to lear how to + -- custom Setup for now. Otherwise cabal would need to lear how to -- call arbitrary library builders. extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This @@ -109,7 +109,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary BuildInfo - +instance Structured BuildInfo instance NFData BuildInfo where rnf = genericRnf instance Monoid BuildInfo where diff --git a/Distribution/Types/BuildType.hs b/Distribution/Types/BuildType.hs --- a/Distribution/Types/BuildType.hs +++ b/Distribution/Types/BuildType.hs @@ -27,7 +27,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary BuildType - +instance Structured BuildType instance NFData BuildType where rnf = genericRnf knownBuildTypes :: [BuildType] diff --git a/Distribution/Types/ComponentId.hs b/Distribution/Types/ComponentId.hs --- a/Distribution/Types/ComponentId.hs +++ b/Distribution/Types/ComponentId.hs @@ -56,6 +56,7 @@ fromString = mkComponentId instance Binary ComponentId +instance Structured ComponentId instance Pretty ComponentId where pretty = text . unComponentId diff --git a/Distribution/Types/ComponentLocalBuildInfo.hs b/Distribution/Types/ComponentLocalBuildInfo.hs --- a/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Distribution/Types/ComponentLocalBuildInfo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} @@ -108,9 +109,10 @@ componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } - deriving (Generic, Read, Show) + deriving (Generic, Read, Show, Typeable) instance Binary ComponentLocalBuildInfo +instance Structured ComponentLocalBuildInfo instance IsNode ComponentLocalBuildInfo where type Key ComponentLocalBuildInfo = UnitId diff --git a/Distribution/Types/ComponentName.hs b/Distribution/Types/ComponentName.hs --- a/Distribution/Types/ComponentName.hs +++ b/Distribution/Types/ComponentName.hs @@ -28,6 +28,7 @@ deriving (Eq, Generic, Ord, Read, Show, Typeable) instance Binary ComponentName +instance Structured ComponentName -- Build-target-ish syntax instance Pretty ComponentName where diff --git a/Distribution/Types/ComponentRequestedSpec.hs b/Distribution/Types/ComponentRequestedSpec.hs --- a/Distribution/Types/ComponentRequestedSpec.hs +++ b/Distribution/Types/ComponentRequestedSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ComponentRequestedSpec ( -- $buildable_vs_enabled_components @@ -66,8 +67,10 @@ = ComponentRequestedSpec { testsRequested :: Bool , benchmarksRequested :: Bool } | OneComponentRequestedSpec ComponentName - deriving (Generic, Read, Show, Eq) + deriving (Generic, Read, Show, Eq, Typeable) + instance Binary ComponentRequestedSpec +instance Structured ComponentRequestedSpec -- | The default set of enabled components. Historically tests and -- benchmarks are NOT enabled by default. diff --git a/Distribution/Types/CondTree.hs b/Distribution/Types/CondTree.hs --- a/Distribution/Types/CondTree.hs +++ b/Distribution/Types/CondTree.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Types.CondTree ( CondTree(..), @@ -63,7 +64,7 @@ deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) - +instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a) instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf -- | A 'CondBranch' represents a conditional branch, e.g., @if @@ -85,7 +86,7 @@ foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) - +instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a) instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a diff --git a/Distribution/Types/Condition.hs b/Distribution/Types/Condition.hs --- a/Distribution/Types/Condition.hs +++ b/Distribution/Types/Condition.hs @@ -97,7 +97,7 @@ mplus = mappend instance Binary c => Binary (Condition c) - +instance Structured c => Structured (Condition c) instance NFData c => NFData (Condition c) where rnf = genericRnf -- | Simplify the condition and return its free variables. diff --git a/Distribution/Types/ConfVar.hs b/Distribution/Types/ConfVar.hs new file mode 100644 --- /dev/null +++ b/Distribution/Types/ConfVar.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ConfVar ( + ConfVar(..), + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Flag +import Distribution.Types.VersionRange +import Distribution.Compiler +import Distribution.System + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show, Typeable, Data, Generic) + +instance Binary ConfVar +instance Structured ConfVar + +instance NFData ConfVar where rnf = genericRnf diff --git a/Distribution/Types/Dependency.hs b/Distribution/Types/Dependency.hs --- a/Distribution/Types/Dependency.hs +++ b/Distribution/Types/Dependency.hs @@ -29,7 +29,6 @@ import Distribution.Types.UnqualComponentName import Text.PrettyPrint ((<+>)) -import Data.Set (Set) import qualified Data.Set as Set -- | Describes a dependency on a source package (API) @@ -53,6 +52,7 @@ depLibraries (Dependency _ _ cs) = cs instance Binary Dependency +instance Structured Dependency instance NFData Dependency where rnf = genericRnf instance Pretty Dependency where diff --git a/Distribution/Types/DependencyMap.hs b/Distribution/Types/DependencyMap.hs --- a/Distribution/Types/DependencyMap.hs +++ b/Distribution/Types/DependencyMap.hs @@ -13,7 +13,6 @@ import Distribution.Types.LibraryName import Distribution.Version -import Data.Set (Set) import qualified Data.Map.Lazy as Map -- | A map of dependencies. Newtyped since the default monoid instance is not diff --git a/Distribution/Types/ExeDependency.hs b/Distribution/Types/ExeDependency.hs --- a/Distribution/Types/ExeDependency.hs +++ b/Distribution/Types/ExeDependency.hs @@ -27,6 +27,7 @@ deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary ExeDependency +instance Structured ExeDependency instance NFData ExeDependency where rnf = genericRnf instance Pretty ExeDependency where diff --git a/Distribution/Types/Executable.hs b/Distribution/Types/Executable.hs --- a/Distribution/Types/Executable.hs +++ b/Distribution/Types/Executable.hs @@ -30,7 +30,7 @@ buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) instance Binary Executable - +instance Structured Executable instance NFData Executable where rnf = genericRnf instance Monoid Executable where diff --git a/Distribution/Types/ExecutableScope.hs b/Distribution/Types/ExecutableScope.hs --- a/Distribution/Types/ExecutableScope.hs +++ b/Distribution/Types/ExecutableScope.hs @@ -28,7 +28,7 @@ pri = ExecutablePrivate <$ P.string "private" instance Binary ExecutableScope - +instance Structured ExecutableScope instance NFData ExecutableScope where rnf = genericRnf -- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True' diff --git a/Distribution/Types/ExposedModule.hs b/Distribution/Types/ExposedModule.hs --- a/Distribution/Types/ExposedModule.hs +++ b/Distribution/Types/ExposedModule.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ExposedModule where @@ -17,7 +18,7 @@ exposedName :: ModuleName, exposedReexport :: Maybe OpenModule } - deriving (Eq, Generic, Read, Show) + deriving (Eq, Generic, Read, Show, Typeable) instance Pretty ExposedModule where pretty (ExposedModule m reexport) = @@ -40,5 +41,5 @@ return (ExposedModule m reexport) instance Binary ExposedModule - +instance Structured ExposedModule instance NFData ExposedModule where rnf = genericRnf diff --git a/Distribution/Types/Flag.hs b/Distribution/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/Distribution/Types/Flag.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Types.Flag ( + Flag(..), + emptyFlag, + FlagName, + mkFlagName, + unFlagName, + FlagAssignment, + mkFlagAssignment, + unFlagAssignment, + lookupFlagAssignment, + insertFlagAssignment, + diffFlagAssignment, + findDuplicateFlagAssignments, + nullFlagAssignment, + showFlagValue, + dispFlagAssignment, + parsecFlagAssignment, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText +import Distribution.Utils.Generic (lowercase) + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.CharParsing as P + +-- ----------------------------------------------------------------------------- +-- The Flag' type + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq, Typeable, Data, Generic) + +instance Binary Flag +instance Structured Flag + +instance NFData Flag where rnf = genericRnf + +-- | A 'Flag' initialized with default parameters. +emptyFlag :: FlagName -> Flag +emptyFlag name = MkFlag + { flagName = name + , flagDescription = "" + , flagDefault = True + , flagManual = False + } + +-- | A 'FlagName' is the name of a user-defined configuration flag +-- +-- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype FlagName = FlagName ShortText + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) + +-- | Construct a 'FlagName' from a 'String' +-- +-- 'mkFlagName' is the inverse to 'unFlagName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'FlagName' is valid +-- +-- @since 2.0.0.2 +mkFlagName :: String -> FlagName +mkFlagName = FlagName . toShortText + +-- | 'mkFlagName' +-- +-- @since 2.0.0.2 +instance IsString FlagName where + fromString = mkFlagName + +-- | Convert 'FlagName' to 'String' +-- +-- @since 2.0.0.2 +unFlagName :: FlagName -> String +unFlagName (FlagName s) = fromShortText s + +instance Binary FlagName +instance Structured FlagName + +instance Pretty FlagName where + pretty = Disp.text . unFlagName + +instance Parsec FlagName where + -- Note: we don't check that FlagName doesn't have leading dash, + -- cabal check will do that. + parsec = mkFlagName . lowercase <$> parsec' + where + parsec' = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlphaNum c || c == '_') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +newtype FlagAssignment + = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } + deriving (Binary, Generic, NFData, Typeable) + +instance Structured FlagAssignment + +instance Eq FlagAssignment where + (==) (FlagAssignment m1) (FlagAssignment m2) + = fmap snd m1 == fmap snd m2 + +instance Ord FlagAssignment where + compare (FlagAssignment m1) (FlagAssignment m2) + = fmap snd m1 `compare` fmap snd m2 + +-- | Combines pairs of values contained in the 'FlagAssignment' Map. +-- +-- The last flag specified takes precedence, and we record the number +-- of times we have seen the flag. +-- +combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) +combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) + +-- The 'Semigroup' instance currently is right-biased. +-- +-- If duplicate flags are specified, we want the last flag specified to +-- take precedence and we want to know how many times the flag has been +-- specified so that we have the option of warning the user about +-- supplying duplicate flags. +instance Semigroup FlagAssignment where + (<>) (FlagAssignment m1) (FlagAssignment m2) + = FlagAssignment (Map.unionWith combineFlagValues m1 m2) + +instance Monoid FlagAssignment where + mempty = FlagAssignment Map.empty + mappend = (<>) + +-- | Construct a 'FlagAssignment' from a list of flag/value pairs. +-- +-- If duplicate flags occur in the input list, the later entries +-- in the list will take precedence. +-- +-- @since 2.2.0 +mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment +mkFlagAssignment = + FlagAssignment . + Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) + +-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. +-- +-- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ +-- +-- @since 2.2.0 +unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] +unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment + +-- | Test whether 'FlagAssignment' is empty. +-- +-- @since 2.2.0 +nullFlagAssignment :: FlagAssignment -> Bool +nullFlagAssignment = Map.null . getFlagAssignment + +-- | Lookup the value for a flag +-- +-- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. +-- +-- @since 2.2.0 +lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool +lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment + +-- | Insert or update the boolean value of a flag. +-- +-- If the flag is already present in the 'FlagAssigment', the +-- value will be updated and the fact that multiple values have +-- been provided for that flag will be recorded so that a +-- warning can be generated later on. +-- +-- @since 2.2.0 +insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment +-- TODO: this currently just shadows prior values for an existing +-- flag; rather than enforcing uniqueness at construction, it's +-- verified later on via `D.C.Dependency.configuredPackageProblems` +insertFlagAssignment flag val = + FlagAssignment . + Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment + +-- | Remove all flag-assignments from the first 'FlagAssignment' that +-- are contained in the second 'FlagAssignment' +-- +-- NB/TODO: This currently only removes flag assignments which also +-- match the value assignment! We should review the code which uses +-- this operation to figure out if this it's not enough to only +-- compare the flagnames without the values. +-- +-- @since 2.2.0 +diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment +diffFlagAssignment fa1 fa2 = FlagAssignment + (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) + +-- | Find the 'FlagName's that have been listed more than once. +-- +-- @since 2.2.0 +findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] +findDuplicateFlagAssignments = + Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment + +-- | @since 2.2.0 +instance Read FlagAssignment where + readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] + +-- | @since 2.2.0 +instance Show FlagAssignment where + showsPrec p (FlagAssignment xs) = showsPrec p xs + +-- | String representation of a flag-value pair. +showFlagValue :: (FlagName, Bool) -> String +showFlagValue (f, True) = '+' : unFlagName f +showFlagValue (f, False) = '-' : unFlagName f + +-- | Pretty-prints a flag assignment. +dispFlagAssignment :: FlagAssignment -> Disp.Doc +dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment + +-- | Parses a flag assignment. +parsecFlagAssignment :: CabalParsing m => m FlagAssignment +parsecFlagAssignment = mkFlagAssignment <$> + P.sepBy (onFlag <|> offFlag) P.skipSpaces1 + where + onFlag = do + _ <- P.optional (P.char '+') + f <- parsec + return (f, True) + offFlag = do + _ <- P.char '-' + f <- parsec + return (f, False) diff --git a/Distribution/Types/ForeignLib.hs b/Distribution/Types/ForeignLib.hs --- a/Distribution/Types/ForeignLib.hs +++ b/Distribution/Types/ForeignLib.hs @@ -82,7 +82,7 @@ return (mkLibVersionInfo t) instance Binary LibVersionInfo - +instance Structured LibVersionInfo instance NFData LibVersionInfo where rnf = genericRnf instance Pretty LibVersionInfo where @@ -135,7 +135,7 @@ buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) instance Binary ForeignLib - +instance Structured ForeignLib instance NFData ForeignLib where rnf = genericRnf instance Semigroup ForeignLib where diff --git a/Distribution/Types/ForeignLibOption.hs b/Distribution/Types/ForeignLibOption.hs --- a/Distribution/Types/ForeignLibOption.hs +++ b/Distribution/Types/ForeignLibOption.hs @@ -34,5 +34,5 @@ _ -> fail "unrecognized foreign-library option" instance Binary ForeignLibOption - +instance Structured ForeignLibOption instance NFData ForeignLibOption where rnf = genericRnf diff --git a/Distribution/Types/ForeignLibType.hs b/Distribution/Types/ForeignLibType.hs --- a/Distribution/Types/ForeignLibType.hs +++ b/Distribution/Types/ForeignLibType.hs @@ -42,7 +42,7 @@ _ -> ForeignLibTypeUnknown instance Binary ForeignLibType - +instance Structured ForeignLibType instance NFData ForeignLibType where rnf = genericRnf instance Semigroup ForeignLibType where diff --git a/Distribution/Types/GenericPackageDescription.hs b/Distribution/Types/GenericPackageDescription.hs --- a/Distribution/Types/GenericPackageDescription.hs +++ b/Distribution/Types/GenericPackageDescription.hs @@ -6,32 +6,10 @@ module Distribution.Types.GenericPackageDescription ( GenericPackageDescription(..), emptyGenericPackageDescription, - Flag(..), - emptyFlag, - FlagName, - mkFlagName, - unFlagName, - FlagAssignment, - mkFlagAssignment, - unFlagAssignment, - lookupFlagAssignment, - insertFlagAssignment, - diffFlagAssignment, - findDuplicateFlagAssignments, - nullFlagAssignment, - showFlagValue, - dispFlagAssignment, - parsecFlagAssignment, - ConfVar(..), ) where import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Distribution.Utils.Generic (lowercase) -import qualified Text.PrettyPrint as Disp -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as P -- lens import Distribution.Compat.Lens as L @@ -39,21 +17,17 @@ import Distribution.Types.PackageDescription +import Distribution.Types.Benchmark +import Distribution.Types.CondTree +import Distribution.Types.ConfVar import Distribution.Types.Dependency -import Distribution.Types.Library -import Distribution.Types.ForeignLib import Distribution.Types.Executable +import Distribution.Types.Flag +import Distribution.Types.ForeignLib +import Distribution.Types.Library import Distribution.Types.TestSuite -import Distribution.Types.Benchmark import Distribution.Types.UnqualComponentName -import Distribution.Types.CondTree - import Distribution.Package -import Distribution.Version -import Distribution.Compiler -import Distribution.System -import Distribution.Parsec -import Distribution.Pretty -- --------------------------------------------------------------------------- -- The 'GenericPackageDescription' type @@ -80,7 +54,7 @@ packageId = packageId . packageDescription instance Binary GenericPackageDescription - +instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf emptyGenericPackageDescription :: GenericPackageDescription @@ -100,230 +74,3 @@ <*> (traverse . L._2 . traverse . L.buildInfo) f x4 <*> (traverse . L._2 . traverse . L.buildInfo) f x5 <*> (traverse . L._2 . traverse . L.buildInfo) f x6 - --- ----------------------------------------------------------------------------- --- The Flag' type - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data Flag = MkFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Binary Flag - -instance NFData Flag where rnf = genericRnf - --- | A 'Flag' initialized with default parameters. -emptyFlag :: FlagName -> Flag -emptyFlag name = MkFlag - { flagName = name - , flagDescription = "" - , flagDefault = True - , flagManual = False - } - --- | A 'FlagName' is the name of a user-defined configuration flag --- --- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype FlagName = FlagName ShortText - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) - --- | Construct a 'FlagName' from a 'String' --- --- 'mkFlagName' is the inverse to 'unFlagName' --- --- Note: No validations are performed to ensure that the resulting --- 'FlagName' is valid --- --- @since 2.0.0.2 -mkFlagName :: String -> FlagName -mkFlagName = FlagName . toShortText - --- | 'mkFlagName' --- --- @since 2.0.0.2 -instance IsString FlagName where - fromString = mkFlagName - --- | Convert 'FlagName' to 'String' --- --- @since 2.0.0.2 -unFlagName :: FlagName -> String -unFlagName (FlagName s) = fromShortText s - -instance Binary FlagName - -instance Pretty FlagName where - pretty = Disp.text . unFlagName - -instance Parsec FlagName where - -- Note: we don't check that FlagName doesn't have leading dash, - -- cabal check will do that. - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- -newtype FlagAssignment - = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } - deriving (Binary, Generic, NFData) - -instance Eq FlagAssignment where - (==) (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 == fmap snd m2 - -instance Ord FlagAssignment where - compare (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 `compare` fmap snd m2 - --- | Combines pairs of values contained in the 'FlagAssignment' Map. --- --- The last flag specified takes precedence, and we record the number --- of times we have seen the flag. --- -combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) -combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) - --- The 'Semigroup' instance currently is right-biased. --- --- If duplicate flags are specified, we want the last flag specified to --- take precedence and we want to know how many times the flag has been --- specified so that we have the option of warning the user about --- supplying duplicate flags. -instance Semigroup FlagAssignment where - (<>) (FlagAssignment m1) (FlagAssignment m2) - = FlagAssignment (Map.unionWith combineFlagValues m1 m2) - -instance Monoid FlagAssignment where - mempty = FlagAssignment Map.empty - mappend = (<>) - --- | Construct a 'FlagAssignment' from a list of flag/value pairs. --- --- If duplicate flags occur in the input list, the later entries --- in the list will take precedence. --- --- @since 2.2.0 -mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment -mkFlagAssignment = - FlagAssignment . - Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) - --- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. --- --- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ --- --- @since 2.2.0 -unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] -unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment - --- | Test whether 'FlagAssignment' is empty. --- --- @since 2.2.0 -nullFlagAssignment :: FlagAssignment -> Bool -nullFlagAssignment = Map.null . getFlagAssignment - --- | Lookup the value for a flag --- --- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. --- --- @since 2.2.0 -lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool -lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment - --- | Insert or update the boolean value of a flag. --- --- If the flag is already present in the 'FlagAssigment', the --- value will be updated and the fact that multiple values have --- been provided for that flag will be recorded so that a --- warning can be generated later on. --- --- @since 2.2.0 -insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment --- TODO: this currently just shadows prior values for an existing --- flag; rather than enforcing uniqueness at construction, it's --- verified later on via `D.C.Dependency.configuredPackageProblems` -insertFlagAssignment flag val = - FlagAssignment . - Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment - --- | Remove all flag-assignments from the first 'FlagAssignment' that --- are contained in the second 'FlagAssignment' --- --- NB/TODO: This currently only removes flag assignments which also --- match the value assignment! We should review the code which uses --- this operation to figure out if this it's not enough to only --- compare the flagnames without the values. --- --- @since 2.2.0 -diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = FlagAssignment - (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) - --- | Find the 'FlagName's that have been listed more than once. --- --- @since 2.2.0 -findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] -findDuplicateFlagAssignments = - Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment - --- | @since 2.2.0 -instance Read FlagAssignment where - readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] - --- | @since 2.2.0 -instance Show FlagAssignment where - showsPrec p (FlagAssignment xs) = showsPrec p xs - --- | String representation of a flag-value pair. -showFlagValue :: (FlagName, Bool) -> String -showFlagValue (f, True) = '+' : unFlagName f -showFlagValue (f, False) = '-' : unFlagName f - --- | Pretty-prints a flag assignment. -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment - --- | Parses a flag assignment. -parsecFlagAssignment :: CabalParsing m => m FlagAssignment -parsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.optional (P.char '+') - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) --- {-# DEPRECATED parseFlagAssignment "Use parsecFlagAssignment. This symbol will be removed in Cabal-3.0 (est. Mar 2019)." #-} - --- ----------------------------------------------------------------------------- --- The 'CondVar' type - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | Flag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data, Generic) - -instance Binary ConfVar - -instance NFData ConfVar where rnf = genericRnf diff --git a/Distribution/Types/GenericPackageDescription/Lens.hs b/Distribution/Types/GenericPackageDescription/Lens.hs --- a/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Distribution/Types/GenericPackageDescription/Lens.hs @@ -21,9 +21,9 @@ import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.Benchmark (Benchmark) import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription(GenericPackageDescription) - , Flag(MkFlag), FlagName, ConfVar (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) +import Distribution.Types.Flag (Flag(MkFlag), FlagName) +import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.Library (Library) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.UnqualComponentName (UnqualComponentName) diff --git a/Distribution/Types/GivenComponent.hs b/Distribution/Types/GivenComponent.hs --- a/Distribution/Types/GivenComponent.hs +++ b/Distribution/Types/GivenComponent.hs @@ -25,4 +25,4 @@ deriving (Generic, Read, Show, Eq, Typeable) instance Binary GivenComponent - +instance Structured GivenComponent diff --git a/Distribution/Types/IncludeRenaming.hs b/Distribution/Types/IncludeRenaming.hs --- a/Distribution/Types/IncludeRenaming.hs +++ b/Distribution/Types/IncludeRenaming.hs @@ -30,6 +30,7 @@ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary IncludeRenaming +instance Structured IncludeRenaming instance NFData IncludeRenaming where rnf = genericRnf diff --git a/Distribution/Types/InstalledPackageInfo.hs b/Distribution/Types/InstalledPackageInfo.hs --- a/Distribution/Types/InstalledPackageInfo.hs +++ b/Distribution/Types/InstalledPackageInfo.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module Distribution.Types.InstalledPackageInfo ( InstalledPackageInfo (..), emptyInstalledPackageInfo, @@ -25,6 +26,7 @@ import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName import Distribution.Version (nullVersion) +import Distribution.Utils.ShortText (ShortText) import qualified Distribution.Package as Package import qualified Distribution.SPDX as SPDX @@ -50,15 +52,15 @@ instantiatedWith :: [(ModuleName, OpenModule)], compatPackageKey :: String, license :: Either SPDX.License License, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - homepage :: String, - pkgUrl :: String, - synopsis :: String, - description :: String, - category :: String, + copyright :: !ShortText, + maintainer :: !ShortText, + author :: !ShortText, + stability :: !ShortText, + homepage :: !ShortText, + pkgUrl :: !ShortText, + synopsis :: !ShortText, + description :: !ShortText, + category :: !ShortText, -- these parts are required by an installed package only: abiHash :: AbiHash, indefinite :: Bool, @@ -93,6 +95,7 @@ deriving (Eq, Generic, Typeable, Read, Show) instance Binary InstalledPackageInfo +instance Structured InstalledPackageInfo instance NFData InstalledPackageInfo where rnf = genericRnf diff --git a/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs --- a/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ b/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs @@ -67,15 +67,15 @@ <+> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] <+> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" <+> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) - <+> freeTextFieldDef "copyright" L.copyright - <+> freeTextFieldDef "maintainer" L.maintainer - <+> freeTextFieldDef "author" L.author - <+> freeTextFieldDef "stability" L.stability - <+> freeTextFieldDef "homepage" L.homepage - <+> freeTextFieldDef "package-url" L.pkgUrl - <+> freeTextFieldDef "synopsis" L.synopsis - <+> freeTextFieldDef "description" L.description - <+> freeTextFieldDef "category" L.category + <+> freeTextFieldDefST "copyright" L.copyright + <+> freeTextFieldDefST "maintainer" L.maintainer + <+> freeTextFieldDefST "author" L.author + <+> freeTextFieldDefST "stability" L.stability + <+> freeTextFieldDefST "homepage" L.homepage + <+> freeTextFieldDefST "package-url" L.pkgUrl + <+> freeTextFieldDefST "synopsis" L.synopsis + <+> freeTextFieldDefST "description" L.description + <+> freeTextFieldDefST "category" L.category -- Installed fields <+> optionalFieldDef "abi" L.abiHash (mkAbiHash "") <+> booleanFieldDef "indefinite" L.indefinite False diff --git a/Distribution/Types/InstalledPackageInfo/Lens.hs b/Distribution/Types/InstalledPackageInfo/Lens.hs --- a/Distribution/Types/InstalledPackageInfo/Lens.hs +++ b/Distribution/Types/InstalledPackageInfo/Lens.hs @@ -14,7 +14,9 @@ import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) import Distribution.Types.LibraryName (LibraryName) import Distribution.Types.LibraryVisibility (LibraryVisibility) +import Distribution.Utils.ShortText (ShortText) + import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.InstalledPackageInfo as T @@ -46,39 +48,39 @@ license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) {-# INLINE license #-} -copyright :: Lens' InstalledPackageInfo String +copyright :: Lens' InstalledPackageInfo ShortText copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) {-# INLINE copyright #-} -maintainer :: Lens' InstalledPackageInfo String +maintainer :: Lens' InstalledPackageInfo ShortText maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) {-# INLINE maintainer #-} -author :: Lens' InstalledPackageInfo String +author :: Lens' InstalledPackageInfo ShortText author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) {-# INLINE author #-} -stability :: Lens' InstalledPackageInfo String +stability :: Lens' InstalledPackageInfo ShortText stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) {-# INLINE stability #-} -homepage :: Lens' InstalledPackageInfo String +homepage :: Lens' InstalledPackageInfo ShortText homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) {-# INLINE homepage #-} -pkgUrl :: Lens' InstalledPackageInfo String +pkgUrl :: Lens' InstalledPackageInfo ShortText pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} -synopsis :: Lens' InstalledPackageInfo String +synopsis :: Lens' InstalledPackageInfo ShortText synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) {-# INLINE synopsis #-} -description :: Lens' InstalledPackageInfo String +description :: Lens' InstalledPackageInfo ShortText description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) {-# INLINE description #-} -category :: Lens' InstalledPackageInfo String +category :: Lens' InstalledPackageInfo ShortText category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) {-# INLINE category #-} diff --git a/Distribution/Types/LegacyExeDependency.hs b/Distribution/Types/LegacyExeDependency.hs --- a/Distribution/Types/LegacyExeDependency.hs +++ b/Distribution/Types/LegacyExeDependency.hs @@ -27,6 +27,7 @@ deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary LegacyExeDependency +instance Structured LegacyExeDependency instance NFData LegacyExeDependency where rnf = genericRnf instance Pretty LegacyExeDependency where @@ -40,7 +41,7 @@ verRange <- parsecMaybeQuoted parsec <|> pure anyVersion pure $ LegacyExeDependency name verRange where - nameP = intercalate "-" <$> P.sepBy1 component (P.char '-') + nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') component = do cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') if all isDigit cs then fail "invalid component" else return cs diff --git a/Distribution/Types/Library.hs b/Distribution/Types/Library.hs --- a/Distribution/Types/Library.hs +++ b/Distribution/Types/Library.hs @@ -34,7 +34,7 @@ buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) instance Binary Library - +instance Structured Library instance NFData Library where rnf = genericRnf emptyLibrary :: Library diff --git a/Distribution/Types/LibraryName.hs b/Distribution/Types/LibraryName.hs --- a/Distribution/Types/LibraryName.hs +++ b/Distribution/Types/LibraryName.hs @@ -28,6 +28,7 @@ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary LibraryName +instance Structured LibraryName instance NFData LibraryName where rnf = genericRnf -- | Pretty print 'LibraryName' in build-target-ish syntax. diff --git a/Distribution/Types/LibraryVisibility.hs b/Distribution/Types/LibraryVisibility.hs --- a/Distribution/Types/LibraryVisibility.hs +++ b/Distribution/Types/LibraryVisibility.hs @@ -38,6 +38,7 @@ _ -> fail $ "Unknown visibility: " ++ name instance Binary LibraryVisibility +instance Structured LibraryVisibility instance NFData LibraryVisibility where rnf = genericRnf instance Semigroup LibraryVisibility where diff --git a/Distribution/Types/LocalBuildInfo.hs b/Distribution/Types/LocalBuildInfo.hs --- a/Distribution/Types/LocalBuildInfo.hs +++ b/Distribution/Types/LocalBuildInfo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -156,9 +157,10 @@ progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables relocatable :: Bool -- ^Whether to build a relocatable package - } deriving (Generic, Read, Show) + } deriving (Generic, Read, Show, Typeable) instance Binary LocalBuildInfo +instance Structured LocalBuildInfo ------------------------------------------------------------------------------- -- Accessor functions diff --git a/Distribution/Types/Mixin.hs b/Distribution/Types/Mixin.hs --- a/Distribution/Types/Mixin.hs +++ b/Distribution/Types/Mixin.hs @@ -22,6 +22,7 @@ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary Mixin +instance Structured Mixin instance NFData Mixin where rnf = genericRnf diff --git a/Distribution/Types/Module.hs b/Distribution/Types/Module.hs --- a/Distribution/Types/Module.hs +++ b/Distribution/Types/Module.hs @@ -29,6 +29,7 @@ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary Module +instance Structured Module instance Pretty Module where pretty (Module uid mod_name) = diff --git a/Distribution/Types/ModuleReexport.hs b/Distribution/Types/ModuleReexport.hs --- a/Distribution/Types/ModuleReexport.hs +++ b/Distribution/Types/ModuleReexport.hs @@ -28,7 +28,7 @@ deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary ModuleReexport - +instance Structured ModuleReexport instance NFData ModuleReexport where rnf = genericRnf instance Pretty ModuleReexport where diff --git a/Distribution/Types/ModuleRenaming.hs b/Distribution/Types/ModuleRenaming.hs --- a/Distribution/Types/ModuleRenaming.hs +++ b/Distribution/Types/ModuleRenaming.hs @@ -69,6 +69,7 @@ instance Binary ModuleRenaming where +instance Structured ModuleRenaming where instance NFData ModuleRenaming where rnf = genericRnf diff --git a/Distribution/Types/MungedPackageId.hs b/Distribution/Types/MungedPackageId.hs --- a/Distribution/Types/MungedPackageId.hs +++ b/Distribution/Types/MungedPackageId.hs @@ -31,6 +31,7 @@ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary MungedPackageId +instance Structured MungedPackageId -- | -- diff --git a/Distribution/Types/MungedPackageName.hs b/Distribution/Types/MungedPackageName.hs --- a/Distribution/Types/MungedPackageName.hs +++ b/Distribution/Types/MungedPackageName.hs @@ -34,6 +34,7 @@ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary MungedPackageName +instance Structured MungedPackageName instance NFData MungedPackageName where rnf = genericRnf -- | Computes the package name for a library. If this is the public @@ -68,7 +69,7 @@ -- >>> prettyShow $ MungedPackageName "servant" LMainLibName -- "servant" -- --- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") +-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") -- "z-servant-z-lackey" -- instance Pretty MungedPackageName where @@ -77,7 +78,7 @@ -- indefinite package for us. pretty = Disp.text . encodeCompatPackageName' --- | +-- | -- -- >>> simpleParsec "servant" :: Maybe MungedPackageName -- Just (MungedPackageName (PackageName "servant") LMainLibName) @@ -137,7 +138,7 @@ parseZDashCode :: CabalParsing m => m [String] parseZDashCode = do - ns <- P.sepBy1 (some (P.satisfy (/= '-'))) (P.char '-') + ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') return (go ns) where go ns = case break (=="z") ns of diff --git a/Distribution/Types/PackageDescription.hs b/Distribution/Types/PackageDescription.hs --- a/Distribution/Types/PackageDescription.hs +++ b/Distribution/Types/PackageDescription.hs @@ -88,6 +88,7 @@ import Distribution.License import Distribution.Package import Distribution.Version +import Distribution.Utils.ShortText import qualified Distribution.SPDX as SPDX @@ -113,18 +114,18 @@ package :: PackageIdentifier, licenseRaw :: Either SPDX.License License, licenseFiles :: [FilePath], - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, + copyright :: !ShortText, + maintainer :: !ShortText, + author :: !ShortText, + stability :: !ShortText, testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: String, - pkgUrl :: String, - bugReports :: String, + homepage :: !ShortText, + pkgUrl :: !ShortText, + bugReports :: !ShortText, sourceRepos :: [SourceRepo], - synopsis :: String, -- ^A one-line summary of this package - description :: String, -- ^A more verbose description of this package - category :: String, + synopsis :: !ShortText, -- ^A one-line summary of this package + description :: !ShortText, -- ^A more verbose description of this package + category :: !ShortText, customFieldsPD :: [(String,String)], -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. @@ -152,6 +153,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary PackageDescription +instance Structured PackageDescription instance NFData PackageDescription where rnf = genericRnf @@ -223,18 +225,18 @@ licenseFiles = [], specVersionRaw = Right anyVersion, buildTypeRaw = Nothing, - copyright = "", - maintainer = "", - author = "", - stability = "", + copyright = mempty, + maintainer = mempty, + author = mempty, + stability = mempty, testedWith = [], - homepage = "", - pkgUrl = "", - bugReports = "", + homepage = mempty, + pkgUrl = mempty, + bugReports = mempty, sourceRepos = [], - synopsis = "", - description = "", - category = "", + synopsis = mempty, + description = mempty, + category = mempty, customFieldsPD = [], setupBuildInfo = Nothing, library = Nothing, @@ -473,6 +475,6 @@ <*> (traverse . L.buildInfo) f x6 -- benchmarks <*> pure a20 -- data files <*> pure a21 -- data dir - <*> pure a22 -- exta src files + <*> pure a22 -- extra src files <*> pure a23 -- extra temp files <*> pure a24 -- extra doc files diff --git a/Distribution/Types/PackageDescription/Lens.hs b/Distribution/Types/PackageDescription/Lens.hs --- a/Distribution/Types/PackageDescription/Lens.hs +++ b/Distribution/Types/PackageDescription/Lens.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module Distribution.Types.PackageDescription.Lens ( PackageDescription, module Distribution.Types.PackageDescription.Lens, @@ -9,27 +9,28 @@ import Distribution.Compat.Prelude import Prelude () -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Benchmark (Benchmark, benchmarkModules) -import Distribution.Types.Benchmark.Lens (benchmarkName, benchmarkBuildInfo) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.ComponentName (ComponentName(..)) -import Distribution.Types.Executable (Executable, exeModules) -import Distribution.Types.Executable.Lens (exeName, exeBuildInfo) -import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) -import Distribution.Types.ForeignLib.Lens (foreignLibName, foreignLibBuildInfo) -import Distribution.Types.Library (Library, explicitLibModules) -import Distribution.Types.Library.Lens (libName, libBuildInfo) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) -import Distribution.Types.SourceRepo (SourceRepo) -import Distribution.Types.TestSuite (TestSuite, testModules) -import Distribution.Types.TestSuite.Lens (testName, testBuildInfo) -import Distribution.Version (Version, VersionRange) +import Distribution.Compiler (CompilerFlavor) +import Distribution.License (License) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Benchmark (Benchmark, benchmarkModules) +import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.BuildType (BuildType) +import Distribution.Types.ComponentName (ComponentName (..)) +import Distribution.Types.Executable (Executable, exeModules) +import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) +import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) +import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) +import Distribution.Types.Library (Library, explicitLibModules) +import Distribution.Types.Library.Lens (libBuildInfo, libName) +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo) +import Distribution.Types.SourceRepo (SourceRepo) +import Distribution.Types.TestSuite (TestSuite, testModules) +import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) +import Distribution.Utils.ShortText (ShortText) +import Distribution.Version (Version, VersionRange) import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.PackageDescription as T @@ -42,23 +43,23 @@ licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) {-# INLINE licenseRaw #-} -licenseFiles :: Lens' PackageDescription [String] +licenseFiles :: Lens' PackageDescription [FilePath] licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) {-# INLINE licenseFiles #-} -copyright :: Lens' PackageDescription String +copyright :: Lens' PackageDescription ShortText copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) {-# INLINE copyright #-} -maintainer :: Lens' PackageDescription String +maintainer :: Lens' PackageDescription ShortText maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) {-# INLINE maintainer #-} -author :: Lens' PackageDescription String +author :: Lens' PackageDescription ShortText author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) {-# INLINE author #-} -stability :: Lens' PackageDescription String +stability :: Lens' PackageDescription ShortText stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) {-# INLINE stability #-} @@ -66,15 +67,15 @@ testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) {-# INLINE testedWith #-} -homepage :: Lens' PackageDescription String +homepage :: Lens' PackageDescription ShortText homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) {-# INLINE homepage #-} -pkgUrl :: Lens' PackageDescription String +pkgUrl :: Lens' PackageDescription ShortText pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} -bugReports :: Lens' PackageDescription String +bugReports :: Lens' PackageDescription ShortText bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) {-# INLINE bugReports #-} @@ -82,15 +83,15 @@ sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) {-# INLINE sourceRepos #-} -synopsis :: Lens' PackageDescription String +synopsis :: Lens' PackageDescription ShortText synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) {-# INLINE synopsis #-} -description :: Lens' PackageDescription String +description :: Lens' PackageDescription ShortText description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) {-# INLINE description #-} -category :: Lens' PackageDescription String +category :: Lens' PackageDescription ShortText category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) {-# INLINE category #-} @@ -165,18 +166,18 @@ componentModules cname = case cname of CLibName name -> componentModules' name allLibraries libName explicitLibModules - CFLibName name -> + CFLibName name -> componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules - CExeName name -> + CExeName name -> componentModules' name (executables . traverse) exeName exeModules - CTestName name -> + CTestName name -> componentModules' name (testSuites . traverse) testName testModules CBenchName name -> componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules where componentModules' :: (Eq name, Monoid r) - => name + => name -> Traversal' PackageDescription a -> Lens' a name -> (a -> [ModuleName]) @@ -192,21 +193,21 @@ -- | @since 2.4 componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo componentBuildInfo cname = case cname of - CLibName name -> + CLibName name -> componentBuildInfo' name allLibraries libName libBuildInfo - CFLibName name -> + CFLibName name -> componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo - CExeName name -> + CExeName name -> componentBuildInfo' name (executables . traverse) exeName exeBuildInfo - CTestName name -> + CTestName name -> componentBuildInfo' name (testSuites . traverse) testName testBuildInfo CBenchName name -> componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo where componentBuildInfo' :: Eq name - => name + => name -> Traversal' PackageDescription a - -> Lens' a name + -> Lens' a name -> Traversal' a BuildInfo -> Traversal' PackageDescription BuildInfo componentBuildInfo' name pdL nameL biL = diff --git a/Distribution/Types/PackageId.hs b/Distribution/Types/PackageId.hs --- a/Distribution/Types/PackageId.hs +++ b/Distribution/Types/PackageId.hs @@ -13,6 +13,7 @@ import Distribution.Types.PackageName import Distribution.Version (Version, nullVersion) +import qualified Data.List.NonEmpty as NE import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp @@ -28,6 +29,7 @@ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary PackageIdentifier +instance Structured PackageIdentifier instance Pretty PackageIdentifier where pretty (PackageIdentifier n v) @@ -58,10 +60,10 @@ -- instance Parsec PackageIdentifier where parsec = do - xs' <- P.sepBy1 component (P.char '-') - (v, xs) <- case simpleParsec (last xs') of - Nothing -> return (nullVersion, xs') -- all components are version - Just v -> return (v, init xs') + xs' <- P.sepByNonEmpty component (P.char '-') + (v, xs) <- case simpleParsec (NE.last xs') of + Nothing -> return (nullVersion, toList xs') -- all components are version + Just v -> return (v, NE.init xs') if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v else fail "all digits or a dot in a portion of package name" diff --git a/Distribution/Types/PackageName.hs b/Distribution/Types/PackageName.hs --- a/Distribution/Types/PackageName.hs +++ b/Distribution/Types/PackageName.hs @@ -46,6 +46,7 @@ fromString = mkPackageName instance Binary PackageName +instance Structured PackageName instance Pretty PackageName where pretty = Disp.text . unPackageName diff --git a/Distribution/Types/PackageVersionConstraint.hs b/Distribution/Types/PackageVersionConstraint.hs --- a/Distribution/Types/PackageVersionConstraint.hs +++ b/Distribution/Types/PackageVersionConstraint.hs @@ -24,6 +24,7 @@ deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary PackageVersionConstraint +instance Structured PackageVersionConstraint instance NFData PackageVersionConstraint where rnf = genericRnf instance Pretty PackageVersionConstraint where diff --git a/Distribution/Types/PkgconfigDependency.hs b/Distribution/Types/PkgconfigDependency.hs --- a/Distribution/Types/PkgconfigDependency.hs +++ b/Distribution/Types/PkgconfigDependency.hs @@ -25,6 +25,7 @@ deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary PkgconfigDependency +instance Structured PkgconfigDependency instance NFData PkgconfigDependency where rnf = genericRnf instance Pretty PkgconfigDependency where diff --git a/Distribution/Types/PkgconfigName.hs b/Distribution/Types/PkgconfigName.hs --- a/Distribution/Types/PkgconfigName.hs +++ b/Distribution/Types/PkgconfigName.hs @@ -47,6 +47,7 @@ fromString = mkPkgconfigName instance Binary PkgconfigName +instance Structured PkgconfigName -- pkg-config allows versions and other letters in package names, eg -- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package diff --git a/Distribution/Types/PkgconfigVersion.hs b/Distribution/Types/PkgconfigVersion.hs --- a/Distribution/Types/PkgconfigVersion.hs +++ b/Distribution/Types/PkgconfigVersion.hs @@ -34,6 +34,7 @@ PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b instance Binary PkgconfigVersion +instance Structured PkgconfigVersion instance NFData PkgconfigVersion where rnf = genericRnf instance Pretty PkgconfigVersion where diff --git a/Distribution/Types/PkgconfigVersionRange.hs b/Distribution/Types/PkgconfigVersionRange.hs --- a/Distribution/Types/PkgconfigVersionRange.hs +++ b/Distribution/Types/PkgconfigVersionRange.hs @@ -37,6 +37,7 @@ deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary PkgconfigVersionRange +instance Structured PkgconfigVersionRange instance NFData PkgconfigVersionRange where rnf = genericRnf instance Pretty PkgconfigVersionRange where diff --git a/Distribution/Types/SetupBuildInfo.hs b/Distribution/Types/SetupBuildInfo.hs --- a/Distribution/Types/SetupBuildInfo.hs +++ b/Distribution/Types/SetupBuildInfo.hs @@ -28,7 +28,7 @@ deriving (Generic, Show, Eq, Read, Typeable, Data) instance Binary SetupBuildInfo - +instance Structured SetupBuildInfo instance NFData SetupBuildInfo where rnf = genericRnf instance Monoid SetupBuildInfo where diff --git a/Distribution/Types/SourceRepo.hs b/Distribution/Types/SourceRepo.hs --- a/Distribution/Types/SourceRepo.hs +++ b/Distribution/Types/SourceRepo.hs @@ -95,7 +95,7 @@ } instance Binary SourceRepo - +instance Structured SourceRepo instance NFData SourceRepo where rnf = genericRnf -- | What this repo info is for, what it represents. @@ -115,7 +115,7 @@ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary RepoKind - +instance Structured RepoKind instance NFData RepoKind where rnf = genericRnf -- | An enumeration of common source control systems. The fields used in the @@ -128,7 +128,7 @@ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary RepoType - +instance Structured RepoType instance NFData RepoType where rnf = genericRnf knownRepoTypes :: [RepoType] diff --git a/Distribution/Types/TestSuite.hs b/Distribution/Types/TestSuite.hs --- a/Distribution/Types/TestSuite.hs +++ b/Distribution/Types/TestSuite.hs @@ -34,6 +34,7 @@ buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) instance Binary TestSuite +instance Structured TestSuite instance NFData TestSuite where rnf = genericRnf diff --git a/Distribution/Types/TestSuiteInterface.hs b/Distribution/Types/TestSuiteInterface.hs --- a/Distribution/Types/TestSuiteInterface.hs +++ b/Distribution/Types/TestSuiteInterface.hs @@ -39,6 +39,7 @@ deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary TestSuiteInterface +instance Structured TestSuiteInterface instance NFData TestSuiteInterface where rnf = genericRnf diff --git a/Distribution/Types/TestType.hs b/Distribution/Types/TestType.hs --- a/Distribution/Types/TestType.hs +++ b/Distribution/Types/TestType.hs @@ -22,6 +22,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary TestType +instance Structured TestType instance NFData TestType where rnf = genericRnf diff --git a/Distribution/Types/UnitId.hs b/Distribution/Types/UnitId.hs --- a/Distribution/Types/UnitId.hs +++ b/Distribution/Types/UnitId.hs @@ -66,6 +66,7 @@ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) instance Binary UnitId +instance Structured UnitId -- | The textual format for 'UnitId' coincides with the format -- GHC accepts for @-package-id@. @@ -113,6 +114,8 @@ -- unfilled holes. newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty) + +instance Structured DefUnitId -- Workaround for a GHC 8.0.1 bug, see -- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288 diff --git a/Distribution/Types/UnqualComponentName.hs b/Distribution/Types/UnqualComponentName.hs --- a/Distribution/Types/UnqualComponentName.hs +++ b/Distribution/Types/UnqualComponentName.hs @@ -49,6 +49,7 @@ fromString = mkUnqualComponentName instance Binary UnqualComponentName +instance Structured UnqualComponentName instance Pretty UnqualComponentName where pretty = showToken . unUnqualComponentName diff --git a/Distribution/Types/Version.hs b/Distribution/Types/Version.hs --- a/Distribution/Types/Version.hs +++ b/Distribution/Types/Version.hs @@ -81,6 +81,7 @@ return (mkVersion v) instance Binary Version +instance Structured Version instance NFData Version where rnf (PV0 _) = () @@ -92,7 +93,7 @@ (map Disp.int $ versionNumbers ver)) instance Parsec Version where - parsec = mkVersion <$> P.sepBy1 versionDigitParser (P.char '.') <* tags + parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags where tags = do ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) diff --git a/Distribution/Types/VersionInterval.hs b/Distribution/Types/VersionInterval.hs --- a/Distribution/Types/VersionInterval.hs +++ b/Distribution/Types/VersionInterval.hs @@ -118,9 +118,9 @@ doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals - | null intervals = [] - | otherwise = zip intervals (tail intervals) + adjacentIntervals = case intervals of + [] -> [] + (_:tl) -> zip intervals tl checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariant is) is diff --git a/Distribution/Types/VersionRange.hs b/Distribution/Types/VersionRange.hs --- a/Distribution/Types/VersionRange.hs +++ b/Distribution/Types/VersionRange.hs @@ -39,6 +39,7 @@ import Distribution.Compat.Prelude import Distribution.Types.Version import Distribution.Types.VersionRange.Internal +import Distribution.Utils.Generic import Prelude () -- | Fold over the basic syntactic structure of a 'VersionRange'. @@ -130,7 +131,9 @@ -- | @since 2.2 wildcardUpperBound :: Version -> Version wildcardUpperBound = alterVersion $ - \lowerBound -> init lowerBound ++ [last lowerBound + 1] + \lowerBound -> case unsnoc lowerBound of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] isWildcardRange :: Version -> Version -> Bool isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) diff --git a/Distribution/Types/VersionRange/Internal.hs b/Distribution/Types/VersionRange/Internal.hs --- a/Distribution/Types/VersionRange/Internal.hs +++ b/Distribution/Types/VersionRange/Internal.hs @@ -60,7 +60,7 @@ deriving ( Data, Eq, Generic, Read, Show, Typeable ) instance Binary VersionRange - +instance Structured VersionRange instance NFData VersionRange where rnf = genericRnf -- | The version range @-any@. That is, a version range containing all @@ -381,7 +381,7 @@ -- a plain version without tags or wildcards verPlain :: CabalParsing m => m Version - verPlain = mkVersion <$> P.sepBy1 digitParser (P.char '.') + verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') -- either wildcard or normal version verOrWild :: CabalParsing m => m (Bool, Version) diff --git a/Distribution/Utils/Generic.hs b/Distribution/Utils/Generic.hs --- a/Distribution/Utils/Generic.hs +++ b/Distribution/Utils/Generic.hs @@ -64,13 +64,18 @@ ordNub, ordNubBy, ordNubRight, + safeHead, safeTail, + safeLast, + safeInit, unintersperse, wrapText, wrapLine, unfoldrM, spanMaybe, breakMaybe, + unsnoc, + unsnocNE, -- * FilePath stuff isAbsoluteOnAnyPlatform, @@ -280,11 +285,11 @@ -- -- Example: -- --- >>> tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] +-- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] -- *** Exception: Prelude.undefined -- ... -- --- >>> tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] +-- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] -- [5,4,3] -- -- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] @@ -363,11 +368,35 @@ where bSet = Set.fromList b +-- | A total variant of 'head'. +-- +-- @since 3.2.0.0 +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + -- | A total variant of 'tail'. +-- +-- @since 3.2.0.0 safeTail :: [a] -> [a] safeTail [] = [] safeTail (_:xs) = xs +-- | A total variant of 'last'. +-- +-- @since 3.2.0.0 +safeLast :: [a] -> Maybe a +safeLast [] = Nothing +safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) + +-- | A total variant of 'init'. +-- +-- @since 3.2.0.0 +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit [_] = [] +safeInit (x:xs) = x : safeInit xs + equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y @@ -453,6 +482,39 @@ case m of Nothing -> return [] Just (a, b') -> liftM (a :) (go b') + +-- | The opposite of 'snoc', which is the reverse of 'cons' +-- +-- Example: +-- +-- >>> unsnoc [1, 2, 3] +-- Just ([1,2],3) +-- +-- >>> unsnoc [] +-- Nothing +-- +-- @since 3.2.0.0 +-- +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = Just (unsnocNE (x :| xs)) + +-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' +-- +-- Example: +-- +-- >>> unsnocNE (1 :| [2, 3]) +-- ([1,2],3) +-- +-- >>> unsnocNE (1 :| []) +-- ([],1) +-- +-- @since 3.2.0.0 +-- +unsnocNE :: NonEmpty a -> ([a], a) +unsnocNE (x:|xs) = go x xs where + go y [] = ([], y) + go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) -- ------------------------------------------------------------ -- * FilePath stuff diff --git a/Distribution/Utils/IOData.hs b/Distribution/Utils/IOData.hs --- a/Distribution/Utils/IOData.hs +++ b/Distribution/Utils/IOData.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} -- | @since 2.2.0 module Distribution.Utils.IOData ( -- * 'IOData' & 'IODataMode' type - IOData(..) - , IODataMode(..) + IOData (..) + , IODataMode (..) + , KnownIODataMode (..) + , withIOData , null - , hGetContents , hPutContents ) where -import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy as LBS import Distribution.Compat.Prelude hiding (null) import qualified Prelude import qualified System.IO @@ -16,46 +19,68 @@ -- | Represents either textual or binary data passed via I/O functions -- which support binary/text mode -- --- @since 2.2.0 -data IOData = IODataText String - -- ^ How Text gets encoded is usually locale-dependent. - | IODataBinary BS.ByteString - -- ^ Raw binary which gets read/written in binary mode. +-- @since 2.2 +data IOData + = IODataText String + -- ^ How Text gets encoded is usually locale-dependent. + | IODataBinary LBS.ByteString + -- ^ Raw binary which gets read/written in binary mode. +withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r +withIOData (IODataText str) k = k IODataModeText str +withIOData (IODataBinary lbs) k = k IODataModeBinary lbs + -- | Test whether 'IOData' is empty --- --- @since 2.2.0 null :: IOData -> Bool -null (IODataText s) = Prelude.null s -null (IODataBinary b) = BS.null b +null (IODataText s) = Prelude.null s +null (IODataBinary b) = LBS.null b instance NFData IOData where - rnf (IODataText s) = rnf s - rnf (IODataBinary bs) = rnf bs + rnf (IODataText s) = rnf s + rnf (IODataBinary lbs) = rnf lbs -data IODataMode = IODataModeText | IODataModeBinary +-- | @since 2.2 +class NFData mode => KnownIODataMode mode where + -- | 'IOData' Wrapper for 'System.IO.hGetContents' + -- + -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all + -- data to be read and consequently the internal file handle to be + -- closed. + -- + hGetIODataContents :: System.IO.Handle -> Prelude.IO mode --- | 'IOData' Wrapper for 'System.IO.hGetContents' --- --- __Note__: This operation uses lazy I/O. Use 'NFData' to force all --- data to be read and consequently the internal file handle to be --- closed. --- --- @since 2.2.0 -hGetContents :: System.IO.Handle -> IODataMode -> Prelude.IO IOData -hGetContents h IODataModeText = do - System.IO.hSetBinaryMode h False - IODataText <$> System.IO.hGetContents h -hGetContents h IODataModeBinary = do - System.IO.hSetBinaryMode h True - IODataBinary <$> BS.hGetContents h + toIOData :: mode -> IOData + iodataMode :: IODataMode mode +-- | @since 3.2 +data IODataMode mode where + IODataModeText :: IODataMode String + IODataModeBinary :: IODataMode LBS.ByteString + +instance a ~ Char => KnownIODataMode [a] where + hGetIODataContents h = do + System.IO.hSetBinaryMode h False + System.IO.hGetContents h + + toIOData = IODataText + iodataMode = IODataModeText + +instance KnownIODataMode LBS.ByteString where + hGetIODataContents h = do + System.IO.hSetBinaryMode h True + LBS.hGetContents h + + toIOData = IODataBinary + iodataMode = IODataModeBinary + -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' -- --- This is the dual operation ot 'ioDataHGetContents', +-- This is the dual operation ot 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. -- --- @since 2.2.0 +-- /Note:/ this performs lazy-IO. +-- +-- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () hPutContents h (IODataText c) = do System.IO.hSetBinaryMode h False @@ -63,5 +88,5 @@ System.IO.hClose h hPutContents h (IODataBinary c) = do System.IO.hSetBinaryMode h True - BS.hPutStr h c + LBS.hPutStr h c System.IO.hClose h diff --git a/Distribution/Utils/MD5.hs b/Distribution/Utils/MD5.hs new file mode 100644 --- /dev/null +++ b/Distribution/Utils/MD5.hs @@ -0,0 +1,54 @@ +module Distribution.Utils.MD5 ( + MD5, + showMD5, + md5, + -- * Binary + binaryPutMD5, + binaryGetMD5, + ) where + +import Data.Binary (Get, Put) +import Data.Binary.Get (getWord64le) +import Data.Binary.Put (putWord64le) +import Foreign.Ptr (castPtr) +import GHC.Fingerprint (Fingerprint (..), fingerprintData) +import Numeric (showHex) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +type MD5 = Fingerprint + +-- | Show 'MD5' in human readable form +-- +-- >>> showMD5 (Fingerprint 123 456) +-- "000000000000007b00000000000001c8" +-- +-- >>> showMD5 $ md5 $ BS.pack [0..127] +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- @since 3.2.0.0 +showMD5 :: MD5 -> String +showMD5 (Fingerprint a b) = pad a' ++ pad b' where + a' = showHex a "" + b' = showHex b "" + pad s = replicate (16 - length s) '0' ++ s + +-- | @since 3.2.0.0 +md5 :: BS.ByteString -> MD5 +md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + +-- | @since 3.2.0.0 +binaryPutMD5 :: MD5 -> Put +binaryPutMD5 (Fingerprint a b) = do + putWord64le a + putWord64le b + +-- | @since 3.2.0.0 +binaryGetMD5 :: Get MD5 +binaryGetMD5 = do + a <- getWord64le + b <- getWord64le + return (Fingerprint a b) diff --git a/Distribution/Utils/NubList.hs b/Distribution/Utils/NubList.hs --- a/Distribution/Utils/NubList.hs +++ b/Distribution/Utils/NubList.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Utils.NubList ( NubList -- opaque , toNubList -- smart construtor @@ -12,8 +13,8 @@ , overNubListR ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Utils @@ -66,7 +67,7 @@ -- | Helper used by NubList/NubListR's Read instances. readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) -readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec +readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and @@ -74,6 +75,8 @@ instance (Ord a, Binary a) => Binary (NubList a) where put (NubList l) = put l get = fmap toNubList get + +instance Structured a => Structured (NubList a) -- | NubListR : A right-biased version of 'NubList'. That is @toNubListR -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, diff --git a/Distribution/Utils/ShortText.hs b/Distribution/Utils/ShortText.hs --- a/Distribution/Utils/ShortText.hs +++ b/Distribution/Utils/ShortText.hs @@ -1,22 +1,37 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Compact representation of short 'Strings' +-- +-- This module is designed to be import qualifeid +-- +-- @ +-- import Distribution.Utils.ShortText (ShortText) +-- import qualifeid Distribution.Utils.ShortText as ShortText +-- @ module Distribution.Utils.ShortText ( -- * 'ShortText' type ShortText , toShortText , fromShortText + , unsafeFromUTF8BS + -- * Operations + , null + , length + -- * internal utilities , decodeStringUtf8 , encodeStringUtf8 ) where +import Distribution.Compat.Prelude hiding (length, null) import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.String +import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) +import Distribution.Utils.Structured (Structured (..), nominalStructure) + #if defined(MIN_VERSION_bytestring) # if MIN_VERSION_bytestring(0,10,4) # define HAVE_SHORTBYTESTRING 1 @@ -40,8 +55,13 @@ #define MIN_VERSION_binary(x, y, z) 0 #endif +import qualified Data.ByteString as BS +import qualified Data.List as List + #if HAVE_SHORTBYTESTRING import qualified Data.ByteString.Short as BS.Short +#else +import Distribution.Utils.Generic (fromUTF8BS) #endif -- | Construct 'ShortText' from 'String' @@ -50,6 +70,16 @@ -- | Convert 'ShortText' to 'String' fromShortText :: ShortText -> String +-- | Convert from UTF-8 encoded strict 'ByteString'. +-- +-- @since 3.2.0.0 +unsafeFromUTF8BS :: BS.ByteString -> ShortText + +-- | Text whether 'ShortText' is empty. +-- +-- @since 3.2.0.0 +null :: ShortText -> Bool + -- | Compact representation of short 'Strings' -- -- The data is stored internally as UTF8 in an @@ -75,9 +105,14 @@ get = fmap (ST . BS.Short.toShort) get # endif + toShortText = ST . BS.Short.pack . encodeStringUtf8 fromShortText = decodeStringUtf8 . BS.Short.unpack . unST + +unsafeFromUTF8BS = ST . BS.Short.toShort + +null = BS.Short.null . unST #else newtype ShortText = ST { unST :: String } deriving (Eq,Ord,Generic,Data,Typeable) @@ -89,8 +124,14 @@ toShortText = ST fromShortText = unST + +unsafeFromUTF8BS = ST . fromUTF8BS + +null = List.null . unST #endif +instance Structured ShortText where structure = nominalStructure + instance NFData ShortText where rnf = rnf . unST @@ -109,3 +150,10 @@ instance IsString ShortText where fromString = toShortText + +-- | /O(n)/. Length in characters. /Slow/ as converts to string. +-- +-- @since 3.2.0.0 +length :: ShortText -> Int +length = List.length . fromShortText +-- Note: avoid using it, we use it @cabal check@ implementation, where it's ok. diff --git a/Distribution/Utils/Structured.hs b/Distribution/Utils/Structured.hs new file mode 100644 --- /dev/null +++ b/Distribution/Utils/Structured.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 711 +{-# LANGUAGE PatternSynonyms #-} +#endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif +-- | +-- +-- Copyright: (c) 2019 Oleg Grenrus +-- +-- Structurally tag binary serialisaton stream. +-- Useful when most 'Binary' instances are 'Generic' derived. +-- +-- Say you have a data type +-- +-- @ +-- data Record = Record +-- { _recordFields :: HM.HashMap Text (Integer, ByteString) +-- , _recordEnabled :: Bool +-- } +-- deriving (Eq, Show, Generic) +-- +-- instance 'Binary' Record +-- instance 'Structured' Record +-- @ +-- +-- then you can serialise and deserialise @Record@ values with a structure tag by simply +-- +-- @ +-- 'structuredEncode' record :: 'LBS.ByteString' +-- 'structuredDecode' lbs :: IO Record +-- @ +-- +-- If structure of @Record@ changes in between, deserialisation will fail early. +-- +-- Technically, 'Structured' is not related to 'Binary', and may +-- be useful in other uses. +-- +module Distribution.Utils.Structured ( + -- * Encoding and decoding + -- | These functions operate like @binary@'s counterparts, + -- but the serialised version has a structure hash in front. + structuredEncode, + structuredEncodeFile, + structuredDecode, + structuredDecodeOrFailIO, + structuredDecodeFileOrFail, + -- * Structured class + Structured (structure), + MD5, + structureHash, + structureBuilder, + genericStructure, + GStructured, + nominalStructure, + containerStructure, + -- * Structure type + Structure (..), + TypeName, + ConstructorName, + TypeVersion, + SopStructure, + hashStructure, + typeVersion, + typeName, + ) where + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import Data.Word (Word, Word16, Word32, Word64, Word8) + +import qualified Control.Monad.Trans.State.Strict as State + +import Control.Exception (ErrorCall (..), catch, evaluate) + +import GHC.Generics + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Builder as Builder +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Time as Time +import qualified Distribution.Compat.Binary as Binary + +#ifdef MIN_VERSION_aeson +import qualified Data.Aeson as Aeson +#endif + +#if __GLASGOW_HASKELL__ >= 800 +import Data.Kind (Type) +#else +#define Type * +#endif + +import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) +import Distribution.Utils.MD5 + +import Data.Monoid (mconcat) + +import qualified Data.Semigroup +import qualified Data.Foldable + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure) +import Data.Traversable (traverse) +#endif + +#if !MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable1, typeOf1) +#endif + + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +type TypeName = String +type ConstructorName = String + +-- | A sematic version of a data type. Usually 0. +type TypeVersion = Word32 + +-- | Structure of a datatype. +-- +-- It can be infinite, as far as 'TypeRep's involved are finite. +-- (e.g. polymorphic recursion might cause troubles). +-- +data Structure + = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. + | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper + | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure + deriving (Eq, Ord, Show, Generic) + +type SopStructure = [(ConstructorName, [Structure])] + +-- | A MD5 hash digest of 'Structure'. +hashStructure :: Structure -> MD5 +hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder + +-- | A van-Laarhoven lens into 'TypeVersion' of 'Structure' +-- +-- @ +-- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' +-- @ +typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure +typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) +typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) +typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) + +-- | A van-Laarhoven lens into 'TypeName' of 'Structure' +-- +-- @ +-- 'typeName' :: Lens' 'Structure' 'TypeName' +-- @ +typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure +typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) +typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) +typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) + +------------------------------------------------------------------------------- +-- Builder +------------------------------------------------------------------------------- + +-- | Flatten 'Structure' into something we can calculate hash of. +-- +-- As 'Structure' can be potentially infinite. For mutually recursive types, +-- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred +-- another time. +structureBuilder :: Structure -> Builder.Builder +structureBuilder s0 = State.evalState (go s0) Map.empty where + go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder + go (Nominal t v n s) = withTypeRep t $ do + s' <- traverse go s + return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' + + go (Newtype t v n s) = withTypeRep t $ do + s' <- go s + return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] + + go (Structure t v n s) = withTypeRep t $ do + s' <- goSop s + return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] + + withTypeRep t k = do + acc <- State.get + case insert t acc of + Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] + Just acc' -> do + State.put acc' + k + + goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder + goSop sop = do + parts <- traverse part sop + return $ mconcat parts + + part (cn, s) = do + s' <- traverse go s + return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] + + insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) + insert tr m = case Map.lookup trShown m of + Nothing -> inserted + Just ne | tr `Data.Foldable.elem` ne -> Nothing + | otherwise -> inserted + where + inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) + trShown = show tr + +------------------------------------------------------------------------------- +-- Classes +------------------------------------------------------------------------------- + +-- | Class of types with a known 'Structure'. +-- +-- For regular data types 'Structured' can be derived generically. +-- +-- @ +-- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic') +-- instance 'Structured' Record +-- @ +-- +-- @since 3.2.0.0 +-- +class Typeable a => Structured a where + structure :: Proxy a -> Structure + default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure + structure = genericStructure + + -- This member is hidden. It's there to precalc + structureHash' :: Tagged a MD5 + structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) + +-- private Tagged +newtype Tagged a b = Tagged { untag :: b } + +-- | Semantically @'hashStructure' . 'structure'@. +structureHash :: forall a. Structured a => Proxy a -> MD5 +structureHash _ = untag (structureHash' :: Tagged a MD5) + +------------------------------------------------------------------------------- +-- Functions +------------------------------------------------------------------------------- + +-- | Structured 'Binary.encode'. +-- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'. +-- Encoding starts with 16 byte large structure hash. +structuredEncode + :: forall a. (Binary.Binary a, Structured a) + => a -> LBS.ByteString +structuredEncode x = Binary.encode (Tag :: Tag a, x) + +-- | Lazily serialise a value to a file +structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO () +structuredEncodeFile f = LBS.writeFile f . structuredEncode + +-- | Structured 'Binary.decode'. +-- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. +-- Throws pure exception on invalid inputs. +structuredDecode + :: forall a. (Binary.Binary a, Structured a) + => LBS.ByteString -> a +structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) + +structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a) +structuredDecodeOrFailIO bs = + catch (evaluate (structuredDecode bs) >>= return . Right) handler + where +#if MIN_VERSION_base(4,9,0) + handler (ErrorCallWithLocation str _) = return $ Left str +#else + handler (ErrorCall str) = return $ Left str +#endif + +-- | Lazily reconstruct a value previously written to a file. +structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) +structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f + +------------------------------------------------------------------------------- +-- Helper data +------------------------------------------------------------------------------- + +data Tag a = Tag + +instance Structured a => Binary.Binary (Tag a) where + get = do + actual <- binaryGetMD5 + if actual == expected + then return Tag + else fail $ concat + [ "Non-matching structured hashes: " + , showMD5 actual + , "; expected: " + , showMD5 expected + ] + where + expected = untag (structureHash' :: Tagged a MD5) + + put _ = binaryPutMD5 expected + where + expected = untag (structureHash' :: Tagged a MD5) + +------------------------------------------------------------------------------- +-- Smart constructors +------------------------------------------------------------------------------- + +-- | Use 'Typeable' to infer name +nominalStructure :: Typeable a => Proxy a -> Structure +nominalStructure p = Nominal tr 0 (show tr) [] where + tr = typeRep p + +#if MIN_VERSION_base(4,7,0) +containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure +containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) + [ structure (Proxy :: Proxy a) + ] + where + fTypeRep = typeRep (Proxy :: Proxy f) + faTypeRep = typeRep (Proxy :: Proxy (f a)) + +#else +containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure +containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) + [ structure (Proxy :: Proxy a) + ] + where + fTypeRep = typeOf1 (undefined :: f ()) + faTypeRep = typeRep (Proxy :: Proxy (f a)) +#endif + +------------------------------------------------------------------------------- +-- Generic +------------------------------------------------------------------------------- + +-- | Derive 'structure' genrically. +genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure +genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0 + +-- | Used to implement 'genericStructure'. +class GStructured (f :: Type -> Type) where + gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure + +instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where + gstructured tr _ v = case sop of +#if MIN_VERSION_base(4,7,0) + [(_, [s])] | isNewtype p -> Newtype tr v name s +#endif + _ -> Structure tr v name sop + where + p = undefined :: M1 i c f () + name = datatypeName p + sop = gstructuredSum (Proxy :: Proxy f) [] + +class GStructuredSum (f :: Type -> Type) where + gstructuredSum :: Proxy f -> SopStructure -> SopStructure + +instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where + gstructuredSum _ xs = (name, prod) : xs + where + name = conName (undefined :: M1 i c f ()) + prod = gstructuredProd (Proxy :: Proxy f) [] + +instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where + gstructuredSum _ xs + = gstructuredSum (Proxy :: Proxy f) + $ gstructuredSum (Proxy :: Proxy g) xs + +instance GStructuredSum V1 where + gstructuredSum _ = id + +class GStructuredProd (f :: Type -> Type) where + gstructuredProd :: Proxy f -> [Structure] -> [Structure] + +instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where + gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) + +instance Structured c => GStructuredProd (K1 i c) where + gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs + +instance GStructuredProd U1 where + gstructuredProd _ = id + +instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where + gstructuredProd _ xs + = gstructuredProd (Proxy :: Proxy f) + $ gstructuredProd (Proxy :: Proxy g) xs + +------------------------------------------------------------------------------- +-- instances +------------------------------------------------------------------------------- + +instance Structured () +instance Structured Bool +instance Structured Ordering + +instance Structured Char where structure = nominalStructure +instance Structured Int where structure = nominalStructure +instance Structured Integer where structure = nominalStructure + +instance Structured Data.Word.Word where structure = nominalStructure + +instance Structured Int8 where structure = nominalStructure +instance Structured Int16 where structure = nominalStructure +instance Structured Int32 where structure = nominalStructure +instance Structured Int64 where structure = nominalStructure + +instance Structured Word8 where structure = nominalStructure +instance Structured Word16 where structure = nominalStructure +instance Structured Word32 where structure = nominalStructure +instance Structured Word64 where structure = nominalStructure + +instance Structured Float where structure = nominalStructure +instance Structured Double where structure = nominalStructure + +instance Structured a => Structured (Maybe a) +instance (Structured a, Structured b) => Structured (Either a b) +instance Structured a => Structured (Ratio a) where structure = containerStructure +instance Structured a => Structured [a] where structure = containerStructure +instance Structured a => Structured (NonEmpty a) where structure = containerStructure + +instance (Structured a1, Structured a2) => Structured (a1, a2) +instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) +instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) + +instance Structured BS.ByteString where structure = nominalStructure +instance Structured LBS.ByteString where structure = nominalStructure + +instance Structured T.Text where structure = nominalStructure +instance Structured LT.Text where structure = nominalStructure + +instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] +instance (Structured k) => Structured (Set.Set k) where structure = containerStructure +instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure +instance Structured IS.IntSet where structure = nominalStructure +instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure + +instance Structured Time.UTCTime where structure = nominalStructure +instance Structured Time.DiffTime where structure = nominalStructure +instance Structured Time.UniversalTime where structure = nominalStructure +instance Structured Time.NominalDiffTime where structure = nominalStructure +instance Structured Time.Day where structure = nominalStructure +instance Structured Time.TimeZone where structure = nominalStructure +instance Structured Time.TimeOfDay where structure = nominalStructure +instance Structured Time.LocalTime where structure = nominalStructure + +-- Proxy isn't Typeable in base-4.8 / base + +-- #if __GLASGOW_HASKELL__ >= 800 +-- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a) +-- #else +-- instance (Typeable a) => Structured (Proxy a) where +-- structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])] +-- #endif diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs --- a/Distribution/Verbosity.hs +++ b/Distribution/Verbosity.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- @@ -55,7 +56,6 @@ import Distribution.ReadE import Data.List (elemIndex) -import Data.Set (Set) import Distribution.Parsec import Distribution.Verbosity.Internal @@ -66,7 +66,7 @@ vLevel :: VerbosityLevel, vFlags :: Set VerbosityFlag, vQuiet :: Bool - } deriving (Generic, Show, Read) + } deriving (Generic, Show, Read, Typeable) mkVerbosity :: VerbosityLevel -> Verbosity mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } @@ -86,6 +86,7 @@ maxBound = mkVerbosity maxBound instance Binary Verbosity +instance Structured Verbosity -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity diff --git a/Distribution/Verbosity/Internal.hs b/Distribution/Verbosity/Internal.hs --- a/Distribution/Verbosity/Internal.hs +++ b/Distribution/Verbosity/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Verbosity.Internal ( VerbosityLevel(..) @@ -8,9 +9,10 @@ import Distribution.Compat.Prelude data VerbosityLevel = Silent | Normal | Verbose | Deafening - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary VerbosityLevel +instance Structured VerbosityLevel data VerbosityFlag = VCallStack @@ -18,6 +20,7 @@ | VNoWrap | VMarkOutput | VTimestamp - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary VerbosityFlag +instance Structured VerbosityFlag diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -23,7 +23,7 @@ classifyExtension, ) where -import Prelude () +import qualified Prelude (head) import Distribution.Compat.Prelude import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) @@ -58,6 +58,7 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary Language +instance Structured Language instance NFData Language where rnf = genericRnf @@ -109,6 +110,7 @@ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary Extension +instance Structured Extension instance NFData Extension where rnf = genericRnf @@ -825,9 +827,22 @@ -- * | EmptyDataDeriving + -- | Enable detection of complete user-supplied kind signatures. + | CUSKs + + -- | Allows the syntax @import M qualified@. + | ImportQualifiedPost + + -- | Allow the use of standalone kind signatures. + | StandaloneKindSignatures + + -- | Enable unlifted newtypes. + | UnliftedNewtypes + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) instance Binary KnownExtension +instance Structured KnownExtension instance NFData KnownExtension where rnf = genericRnf @@ -889,6 +904,6 @@ knownExtensionTable :: Array Char [(String, KnownExtension)] knownExtensionTable = accumArray (flip (:)) [] ('A', 'Z') - [ (head str, (str, extension)) + [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string | extension <- [toEnum 0 ..] , let str = show extension ] diff --git a/doc/conf.py b/doc/conf.py --- a/doc/conf.py +++ b/doc/conf.py @@ -13,7 +13,7 @@ sys.path.insert(0, os.path.abspath('.')) import cabaldomain -version = "3.0.2.0" +version = "3.2.0.0" extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo'] diff --git a/doc/developing-packages.rst b/doc/developing-packages.rst --- a/doc/developing-packages.rst +++ b/doc/developing-packages.rst @@ -2184,14 +2184,28 @@ :pkg-field:`other-modules`, :pkg-field:`library:exposed-modules` or :pkg-field:`executable:main-is` fields. +.. pkg-field:: hs-source-dir: directory list + :deprecated: 2.0 + :removed: 3.0 + :default: ``.`` + + Root directories for the module hierarchy. + + Deprecated in favor of :pkg-field:`hs-source-dirs`. + .. pkg-field:: hs-source-dirs: directory list :default: ``.`` Root directories for the module hierarchy. - For backwards compatibility, the old variant ``hs-source-dir`` is - also recognized. + .. note:: + + Components can share source directories but modules found there will be + recompiled even if other components already built them, i.e., if a + library and an executable share a source directory and the executable + depends on the library and imports its ``Foo`` module, ``Foo`` will be + compiled twice, once as part of the library and again for the executable. .. pkg-field:: default-extensions: identifier list diff --git a/doc/installing-packages.rst b/doc/installing-packages.rst --- a/doc/installing-packages.rst +++ b/doc/installing-packages.rst @@ -57,7 +57,7 @@ anything; packages downloaded from this repository will be cached under ``~/.cabal/packages/hackage.haskell.org`` (or whatever name you specify; you can change the prefix by changing the value of -``remote-repo-cache``). If you want, you can configure multiple +:cfg-field:`remote-repo-cache`). If you want, you can configure multiple repositories, and ``cabal`` will combine them and be able to download packages from any of them. @@ -90,15 +90,40 @@ ``cabal`` will download the ``root.json`` field and use it without verification. Although this bootstrapping step is then unsafe, all subsequent access is secure (provided that the downloaded ``root.json`` -was not tempered with). Of course, adding ``root-keys`` and +was not tampered with). Of course, adding ``root-keys`` and ``key-threshold`` to your repository specification only shifts the problem, because now you somehow need to make sure that the key IDs you received were the right ones. How that is done is however outside the scope of ``cabal`` proper. More information about the security infrastructure can be found at -https://github.com/well-typed/hackage-security. +https://github.com/haskell/hackage-security. +Local no-index repositories +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +It's possible to use a directory of `.tar.gz` package files as a local package +repository. + +:: + + repository my-local-repository + url: file+noindex:///absolute/path/to/directory + +``cabal`` will construct the index automatically from the +``package-name-version.tar.gz`` files in the directory, and will use optional +corresponding ``package-name-version.cabal`` files as new revisions. + +The index is cached inside the given directory. If the directory is not +writable, you can append ``#shared-cache`` fragment to the URI, +then the cache will be stored inside the :cfg-field:`remote-repo-cache` directory. +The part of the path will be used to determine the cache key part. + +.. note:: + The URI scheme ``file:`` is interpreted as a remote repository, + as described in the previous sections, thus requiring manual construction + of ``01-index.tar`` file. + Legacy repositories ^^^^^^^^^^^^^^^^^^^ @@ -120,7 +145,7 @@ ``http://hackage.haskell.org/packages/archive`` will be silently translated to ``http://hackage.haskell.org/``. -The second kind of legacy repositories are so-called “local” +The second kind of legacy repositories are so-called “(legacy) local” repositories: :: @@ -340,7 +365,7 @@ $ cabal build It can be occasionally useful to run the compiler-specific package -manager tool (e.g. ``ghc-pkg``) tool on the sandbox package DB directly +manager tool (e.g. ``ghc-pkg``) on the sandbox package DB directly (for example, you may need to unregister some packages). The ``cabal sandbox hc-pkg`` command is a convenient wrapper that runs the compiler-specific package manager tool with the arguments: @@ -1228,7 +1253,8 @@ Specify that a particular dependency should used for a particular package name. In particular, it declares that any reference to - *pkgname* in a ``build-depends`` should be resolved to *ipid*. + *pkgname* in a :pkg-field:`build-depends` should be resolved to + *ipid*. .. option:: --exact-configuration @@ -1314,8 +1340,8 @@ $ cabal install --constraint="bar == 2.1" - Version bounds have the same syntax as ``build-depends``. As - a special case, the following prevents ``bar`` from being + Version bounds have the same syntax as :pkg-field:`build-depends`. + As a special case, the following prevents ``bar`` from being used at all: :: @@ -1354,11 +1380,11 @@ $ cabal install --constraint="bar test" --constraint="bar bench" By default, constraints only apply to build dependencies - (``build-depends``), build dependencies of build + (:pkg-field:`build-depends`), build dependencies of build dependencies, and so on. Constraints normally do not apply to dependencies of the ``Setup.hs`` script of any package - (``setup-depends``) nor do they apply to build tools - (``build-tool-depends``) or the dependencies of build + (:pkg-field:`setup-depends`) nor do they apply to build tools + (:pkg-field:`build-tool-depends`) or the dependencies of build tools. To explicitly apply a constraint to a setup or build tool dependency, you can add a qualifier to the constraint as follows: @@ -1671,6 +1697,8 @@ Keeps the configuration information so it is not necessary to run the configure step again before building. +.. _setup-test: + setup test ---------- @@ -1715,7 +1743,7 @@ .. option:: --test-option=option - give an extra option to the test executables. There is no need to + Give an extra option to the test executables. There is no need to quote options containing spaces because a single option is assumed, so options will not be split on spaces. @@ -1725,6 +1753,26 @@ execution context. The text executable path and test arguments are passed as arguments to the wrapper and it is expected that the wrapper will return the test's return code, as well as a copy of stdout/stderr. + +.. _setup-bench: + +setup bench +----------- + +Run the benchmarks specified in the package description file. Aside +from the following flags, Cabal accepts the name of one or more benchmarks +on the command line after ``bench``. When supplied, Cabal will run +only the named benchmarks, otherwise, Cabal will run all benchmarks in +the package. + +.. option:: --benchmark-options=options + Give extra options to the benchmark executables. + +.. option:: --benchmark-option=option + + Give an extra option to the benchmark executables. There is no need to + quote options containing spaces because a single option is assumed, + so options will not be split on spaces. .. _setup-sdist: diff --git a/doc/nix-local-build.rst b/doc/nix-local-build.rst --- a/doc/nix-local-build.rst +++ b/doc/nix-local-build.rst @@ -51,7 +51,7 @@ :: - $ cabal v2-build + $ cabal v2-build all To build a specific package, you can either run ``v2-build`` from the directory of the package in question: @@ -653,6 +653,14 @@ ``autogen-modules`` is able to replace uses of the hooks to add generated modules, along with the custom publishing of Haddock documentation to Hackage. +.. warning:: + + Packages that use Backpack will stop working if uploaded to + Hackage, due to `issue #6005 `_. + While this is happening, we recommend not uploading these packages + to Hackage (and instead referencing the package directly + as a ``source-repository-package``). + Configuring builds with cabal.project ===================================== @@ -1829,6 +1837,7 @@ ``haddock`` command). .. cfg-field:: haddock-html-location: templated path + --html-location=TEMPLATE :synopsis: Haddock HTML templates location. Specify a template for the location of HTML documentation for @@ -1839,15 +1848,19 @@ :: - html-location: 'http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html + The command line variant of this flag is ``--html-location`` (for + the ``haddock`` subcommand). + + :: + + --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + Here the argument is quoted to prevent substitution by the shell. If this option is omitted, the location for each package is obtained using the package tool (e.g. ``ghc-pkg``). - The command line variant of this flag is ``--html-location`` (for - the ``haddock`` subcommand). - .. cfg-field:: haddock-executables: boolean :synopsis: Generate documentation for executables. @@ -2101,6 +2114,23 @@ The command line variant of this field is ``--(no-)count-conflicts``. + +.. cfg-field:: fine-grained-conflicts: boolean + --fine-grained-conflicts + --no-fine-grained-conflicts + :synopsis: Skip a version of a package if it does not resolve any conflicts + encountered in the last version (solver optimization). + + :default: True + + When enabled, the solver will skip a version of a package if it does not + resolve any of the conflicts encountered in the last version of that + package. For example, if ``foo-1.2`` depended on ``bar``, and the solver + couldn't find consistent versions for ``bar``'s dependencies, then the + solver would skip ``foo-1.1`` if it also depended on ``bar``. + + The command line variant of this field is + ``--(no-)fine-grained-conflicts``. .. cfg-field:: minimize-conflict-set: boolean --minimize-conflict-set diff --git a/tests/CheckTests.hs b/tests/CheckTests.hs --- a/tests/CheckTests.hs +++ b/tests/CheckTests.hs @@ -17,6 +17,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 +import qualified Data.List.NonEmpty as NE tests :: TestTree tests = checkTests @@ -38,6 +39,7 @@ , checkTest "cxx-options-with-optimization.cabal" , checkTest "ghc-option-j.cabal" , checkTest "multiple-libs-2.cabal" + , checkTest "assoc-cpp-options.cabal" ] checkTest :: FilePath -> TestTree @@ -52,7 +54,7 @@ -- D.PD.Check functionality. unlines (map (showPWarning fp) ws) ++ unlines (map show (checkPackage gpd Nothing)) - Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) errs + Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs where input = "tests" "ParserTests" "regressions" fp correct = replaceExtension input "check" diff --git a/tests/HackageTests.hs b/tests/HackageTests.hs --- a/tests/HackageTests.hs +++ b/tests/HackageTests.hs @@ -70,6 +70,9 @@ import qualified Distribution.Types.PackageDescription.Lens as L import qualified Options.Applicative as O +-- import Distribution.Types.BuildInfo (BuildInfo (cppOptions)) +-- import qualified Distribution.Types.BuildInfo.Lens as L + #ifdef MIN_VERSION_tree_diff import Data.TreeDiff (ediff) import Data.TreeDiff.Pretty (ansiWlEditExprCompact) @@ -165,36 +168,50 @@ parseCheckTest :: FilePath -> B.ByteString -> IO CheckResult parseCheckTest fpath bs = do - let (_warnings, parsec) = Parsec.runParseResult $ - Parsec.parseGenericPackageDescription bs + let (warnings, parsec) = Parsec.runParseResult $ + Parsec.parseGenericPackageDescription bs case parsec of Right gpd -> do let checks = checkPackage gpd Nothing + let w [] = 0 + w _ = 1 + + -- Look into invalid cpp options + -- _ <- L.traverseBuildInfos checkCppFlags gpd + -- one for file, many checks - return (CheckResult 1 0 0 0 0 0 <> foldMap toCheckResult checks) + return (CheckResult 1 (w warnings) 0 0 0 0 0 <> foldMap toCheckResult checks) Left (_, errors) -> do traverse_ (putStrLn . Parsec.showPError fpath) errors exitFailure -data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int +-- checkCppFlags :: BuildInfo -> IO BuildInfo +-- checkCppFlags bi = do +-- for_ (cppOptions bi) $ \opt -> +-- unless (any (`isPrefixOf` opt) ["-D", "-U", "-I"]) $ +-- putStrLn opt +-- +-- return bi +data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int + instance NFData CheckResult where rnf !_ = () instance Semigroup CheckResult where - CheckResult n a b c d e <> CheckResult n' a' b' c' d' e' = - CheckResult (n + n') (a + a') (b + b') (c + c') (d + d') (e + e') + CheckResult n w a b c d e <> CheckResult n' w' a' b' c' d' e' = + CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') instance Monoid CheckResult where - mempty = CheckResult 0 0 0 0 0 0 + mempty = CheckResult 0 0 0 0 0 0 0 mappend = (<>) toCheckResult :: PackageCheck -> CheckResult -toCheckResult PackageBuildImpossible {} = CheckResult 0 1 0 0 0 0 -toCheckResult PackageBuildWarning {} = CheckResult 0 0 1 0 0 0 -toCheckResult PackageDistSuspicious {} = CheckResult 0 0 0 1 0 0 -toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 0 0 1 0 -toCheckResult PackageDistInexcusable {} = CheckResult 0 0 0 0 0 1 +toCheckResult PackageBuildImpossible {} = CheckResult 0 0 1 0 0 0 0 +toCheckResult PackageBuildWarning {} = CheckResult 0 0 0 1 0 0 0 +toCheckResult PackageDistSuspicious {} = CheckResult 0 0 0 0 1 0 0 +toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 0 0 0 1 0 +toCheckResult PackageDistInexcusable {} = CheckResult 0 0 0 0 0 0 1 ------------------------------------------------------------------------------- -- Roundtrip test @@ -214,8 +231,8 @@ let x1 = x0 & L.packageDescription . L.licenseFiles %~ stripEmpty let y2 = y1 & L.packageDescription . L.licenseFiles %~ stripEmpty - let y = y2 & L.packageDescription . L.description .~ "" - let x = x1 & L.packageDescription . L.description .~ "" + let y = y2 & L.packageDescription . L.description .~ mempty + let x = x1 & L.packageDescription . L.description .~ mempty assertEqual' bs' x y @@ -309,8 +326,9 @@ checkP = checkA <$> prefixP checkA pfx = do - CheckResult n a b c d e <- parseIndex pfx parseCheckTest + CheckResult n w a b c d e <- parseIndex pfx parseCheckTest putStrLn $ show n ++ " files processed" + putStrLn $ show w ++ " have lexer/parser warnings" putStrLn $ show a ++ " build impossible" putStrLn $ show b ++ " build warning" putStrLn $ show c ++ " build dist suspicious" diff --git a/tests/Instances/TreeDiff.hs b/tests/Instances/TreeDiff.hs --- a/tests/Instances/TreeDiff.hs +++ b/tests/Instances/TreeDiff.hs @@ -36,6 +36,7 @@ import Distribution.Types.PkgconfigDependency import Distribution.Types.UnitId (DefUnitId, UnitId) import Distribution.Types.UnqualComponentName +import Distribution.Utils.ShortText (ShortText, fromShortText) ------------------------------------------------------------------------------- -- instances @@ -94,3 +95,5 @@ instance ToExpr TestType instance ToExpr UnitId where toExpr = defaultExprViaShow instance ToExpr UnqualComponentName where toExpr = defaultExprViaShow + +instance ToExpr ShortText where toExpr = toExpr . fromShortText diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -26,6 +26,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 +import qualified Data.List.NonEmpty as NE import qualified Distribution.InstalledPackageInfo as IPI @@ -137,7 +138,7 @@ "UNXPECTED SUCCESS\n" ++ showGenericPackageDescription gpd Left (v, errs) -> - unlines $ ("VERSION: " ++ show v) : map (showPError fp) errs + unlines $ ("VERSION: " ++ show v) : map (showPError fp) (NE.toList errs) where input = "tests" "ParserTests" "errors" fp correct = replaceExtension input "errors" @@ -206,7 +207,7 @@ unlines (map (showPWarning fp) warns) ++ showGenericPackageDescription gpd Left (_, errs) -> - unlines $ "ERROR" : map (showPError fp) errs + unlines $ "ERROR" : map (showPError fp) (NE.toList errs) where input = "tests" "ParserTests" "regressions" fp correct = replaceExtension input "format" @@ -219,7 +220,7 @@ let (_, x) = runParseResult res case x of Right gpd -> pure (toExpr gpd) - Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) errs + Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) (NE.toList errs) where input = "tests" "ParserTests" "regressions" fp exprFile = replaceExtension input "expr" @@ -255,7 +256,7 @@ case x' of Right gpd -> pure gpd Left (_, errs) -> do - void $ assertFailure $ unlines (map (showPError fp) errs) + void $ assertFailure $ unlines (map (showPError fp) $ NE.toList errs) fail "failure" input = "tests" "ParserTests" "regressions" fp @@ -282,7 +283,7 @@ ipiFormatGoldenTest :: FilePath -> TestTree ipiFormatGoldenTest fp = cabalGoldenTest "format" correct $ do - contents <- readFile input + contents <- BS.readFile input let res = IPI.parseInstalledPackageInfo contents return $ toUTF8BS $ case res of Left err -> "ERROR " ++ show err @@ -295,7 +296,7 @@ #ifdef MIN_VERSION_tree_diff ipiTreeDiffGoldenTest :: FilePath -> TestTree ipiTreeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do - contents <- readFile input + contents <- BS.readFile input let res = IPI.parseInstalledPackageInfo contents case res of Left err -> fail $ "ERROR " ++ show err @@ -307,10 +308,10 @@ ipiFormatRoundTripTest :: FilePath -> TestTree ipiFormatRoundTripTest fp = testCase "roundtrip" $ do - contents <- readFile input + contents <- BS.readFile input x <- parse contents let contents' = IPI.showInstalledPackageInfo x - y <- parse contents' + y <- parse (toUTF8BS contents') -- ghc-pkg prints pkgroot itself, based on cli arguments! let x' = x { IPI.pkgRoot = Nothing } @@ -320,11 +321,11 @@ -- Complete round-trip let contents2 = IPI.showFullInstalledPackageInfo x - z <- parse contents2 + z <- parse (toUTF8BS contents2) assertEqual "re-parsed doesn't match" x z where - parse :: String -> IO IPI.InstalledPackageInfo + parse :: BS.ByteString -> IO IPI.InstalledPackageInfo parse c = do case IPI.parseInstalledPackageInfo c of Right (_, ipi) -> return ipi diff --git a/tests/ParserTests/errors/big-version.cabal b/tests/ParserTests/errors/big-version.cabal --- a/tests/ParserTests/errors/big-version.cabal +++ b/tests/ParserTests/errors/big-version.cabal @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: big-vesion +name: big-version -- 10 digits version: 1234567890 diff --git a/tests/ParserTests/regressions/assoc-cpp-options.cabal b/tests/ParserTests/regressions/assoc-cpp-options.cabal new file mode 100644 --- /dev/null +++ b/tests/ParserTests/regressions/assoc-cpp-options.cabal @@ -0,0 +1,48 @@ +cabal-version: 1.12 +name: assoc +version: 1.1 +license: BSD3 +license-file: LICENSE +synopsis: swap and assoc: Symmetric and Semigroupy Bifunctors +category: Data +description: + Provides generalisations of + @swap :: (a,b) -> (b,a)@ and + @assoc :: ((a,b),c) -> (a,(b,c))@ + to + @Bifunctor@s supporting similar operations (e.g. @Either@, @These@). + +author: Oleg Grenrus +maintainer: Oleg Grenrus +build-type: Simple +tested-with: + GHC ==7.0.4 + || ==7.2.2 + || ==7.4.2 + || ==7.6.3 + || ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.1 + +source-repository head + type: git + location: https://github.com/phadej/assoc.git + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + base >=4.3 && <4.13 + , bifunctors >=5.5.4 && <5.6 + + cpp-options: -traditional + + exposed-modules: + Data.Bifunctor.Assoc + Data.Bifunctor.Swap + + other-extensions: TypeFamilies diff --git a/tests/ParserTests/regressions/assoc-cpp-options.check b/tests/ParserTests/regressions/assoc-cpp-options.check new file mode 100644 --- /dev/null +++ b/tests/ParserTests/regressions/assoc-cpp-options.check @@ -0,0 +1,1 @@ +'cpp-options': -traditional is not portable C-preprocessor flag diff --git a/tests/ParserTests/regressions/big-version.cabal b/tests/ParserTests/regressions/big-version.cabal --- a/tests/ParserTests/regressions/big-version.cabal +++ b/tests/ParserTests/regressions/big-version.cabal @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: big-vesion +name: big-version -- 9 digits version: 123456789 diff --git a/tests/ParserTests/regressions/big-version.expr b/tests/ParserTests/regressions/big-version.expr --- a/tests/ParserTests/regressions/big-version.expr +++ b/tests/ParserTests/regressions/big-version.expr @@ -82,7 +82,7 @@ licenseRaw = Left NONE, maintainer = "", package = PackageIdentifier - {pkgName = `PackageName "big-vesion"`, + {pkgName = `PackageName "big-version"`, pkgVersion = `mkVersion [123456789]`}, pkgUrl = "", setupBuildInfo = Nothing, diff --git a/tests/ParserTests/regressions/big-version.format b/tests/ParserTests/regressions/big-version.format --- a/tests/ParserTests/regressions/big-version.format +++ b/tests/ParserTests/regressions/big-version.format @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: big-vesion +name: big-version version: 123456789 library diff --git a/tests/Test/Laws.hs b/tests/Test/Laws.hs --- a/tests/Test/Laws.hs +++ b/tests/Test/Laws.hs @@ -53,7 +53,7 @@ monoid_2 x y z = (x `mappend` y) `mappend` z == x `mappend` (y `mappend` z) --- | The 'mconcat' definition. It can be overidden for the sake of effeciency +-- | The 'mconcat' definition. It can be overidden for the sake of efficiency -- but it must still satisfy the property given by the default definition: -- -- > mconcat = foldr mappend mempty diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -24,6 +24,7 @@ import qualified UnitTests.Distribution.Utils.Generic import qualified UnitTests.Distribution.Utils.NubList import qualified UnitTests.Distribution.Utils.ShortText +import qualified UnitTests.Distribution.Utils.Structured import qualified UnitTests.Distribution.Version (versionTests) import qualified UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) import qualified UnitTests.Distribution.SPDX (spdxTests) @@ -67,6 +68,7 @@ UnitTests.Distribution.PkgconfigVersion.pkgconfigVersionTests , testGroup "Distribution.SPDX" UnitTests.Distribution.SPDX.spdxTests + , UnitTests.Distribution.Utils.Structured.tests ] extraOptions :: [OptionDescription] diff --git a/tests/UnitTests/Distribution/Simple/Program/GHC.hs b/tests/UnitTests/Distribution/Simple/Program/GHC.hs --- a/tests/UnitTests/Distribution/Simple/Program/GHC.hs +++ b/tests/UnitTests/Distribution/Simple/Program/GHC.hs @@ -19,6 +19,14 @@ options_8_8_all assertListEquals flags options_8_8_affects + , testCase "options added in GHC-8.10" $ do + let flags :: [String] + flags = normaliseGhcArgs + (Just $ mkVersion [8,10,1]) + emptyPackageDescription + options_8_10_all + + assertListEquals flags options_8_10_affects ] ] @@ -35,7 +43,7 @@ ] ------------------------------------------------------------------------------- --- Options +-- GHC 8.8 ------------------------------------------------------------------------------- -- | Options added in GHC-8.8, to generate: @@ -90,4 +98,45 @@ , "-hiesuf" , "-keep-hscpp-file" , "-keep-hscpp-files" + ] + +------------------------------------------------------------------------------- +-- GHC 8.10 +------------------------------------------------------------------------------- + +options_8_10_all :: [String] +options_8_10_all = + [ "-ddump-cmm-verbose-by-proc" + , "-ddump-stg-final" + , "-ddump-stg-unarised" + , "-Wderiving-defaults" + , "-Winferred-safe-imports" + , "-Wmissing-safe-haskell-mode" + , "-Wno-deriving-defaults" + , "-Wno-inferred-safe-imports" + , "-Wno-missing-safe-haskell-mode" + , "-Wno-prepositive-qualified-module" + , "-Wno-redundant-record-wildcards" + , "-Wno-unused-packages" + , "-Wno-unused-record-wildcards" + , "-Wprepositive-qualified-module" + , "-Wredundant-record-wildcards" + , "-Wunused-packages" + , "-Wunused-record-wildcards" + , "-fdefer-diagnostics" + , "-fkeep-going" + , "-fprint-axiom-incomps" + , "-fno-defer-diagnostics" + , "-fno-keep-going" + , "-fno-print-axiom-incomps" + ] ++ options_8_10_affects + +options_8_10_affects :: [String] +options_8_10_affects = + [ "-dno-typeable-binds" + , "-fbinary-blob-threshold" + , "-fmax-pmcheck-models" + , "-fplugin-trustworthy" + , "-include-cpp-deps" + , "-optcxx" ] diff --git a/tests/UnitTests/Distribution/Simple/Utils.hs b/tests/UnitTests/Distribution/Simple/Utils.hs --- a/tests/UnitTests/Distribution/Simple/Utils.hs +++ b/tests/UnitTests/Distribution/Simple/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} module UnitTests.Distribution.Simple.Utils ( tests ) where @@ -69,7 +70,7 @@ hClose handleExe -- Compile - (IODataText resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal + (resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal ghcPath ["-o", filenameExe, filenameHs] Nothing Nothing Nothing IODataModeText @@ -82,8 +83,7 @@ Nothing Nothing Nothing IODataModeText -- not binary mode output, ie utf8 text mode so try to decode case res of - Right (IODataText x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1,x2,x3) - Right (IODataBinary _, _, _) -> assertFailure "internal error" + Right (x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1,x2,x3) Left err | isDoesNotExistError err -> Exception.throwIO err -- no ghc! | otherwise -> return () diff --git a/tests/UnitTests/Distribution/Utils/Structured.hs b/tests/UnitTests/Distribution/Utils/Structured.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Utils/Structured.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} +module UnitTests.Distribution.Utils.Structured (tests) where + +import Data.Proxy (Proxy (..)) +import Distribution.Utils.Structured (structureHash) +import GHC.Fingerprint (Fingerprint (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Distribution.SPDX.License (License) +import Distribution.Types.VersionRange (VersionRange) + +#if MIN_VERSION_base(4,7,0) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo) +#endif + +import UnitTests.Orphans () + +tests :: TestTree +tests = testGroup "Distribution.Utils.Structured" + -- This test also verifies that structureHash doesn't loop. + [ testCase "VersionRange" $ structureHash (Proxy :: Proxy VersionRange) @?= Fingerprint 0x3827faffd22242bf 0xfd0c337e60fc808b + , testCase "SPDX.License" $ structureHash (Proxy :: Proxy License) @?= Fingerprint 0xd3d4a09f517f9f75 0xbc3d16370d5a853a + -- The difference is in encoding of newtypes +#if MIN_VERSION_base(4,7,0) + , testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0xb48ff44b0e5d96ff 0xfc099544337e90ab +#endif + ] diff --git a/tests/UnitTests/Distribution/Version.hs b/tests/UnitTests/Distribution/Version.hs --- a/tests/UnitTests/Distribution/Version.hs +++ b/tests/UnitTests/Distribution/Version.hs @@ -12,6 +12,7 @@ import Distribution.Types.VersionRange.Internal import Distribution.Parsec (simpleParsec) import Distribution.Pretty +import Distribution.Utils.Generic import Data.Typeable (typeOf) import Math.NumberTheory.Logarithms (intLog2) @@ -317,7 +318,9 @@ withinRange v' (withinVersion v) == (v' >= v && v' < upper v) where - upper = alterVersion $ \numbers -> init numbers ++ [last numbers + 1] + upper = alterVersion $ \numbers -> case unsnoc numbers of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] prop_foldVersionRange :: VersionRange -> Property prop_foldVersionRange range = @@ -342,7 +345,9 @@ expandVR (VersionRangeParens v) = expandVR v expandVR v = v - upper = alterVersion $ \numbers -> init numbers ++ [last numbers + 1] + upper = alterVersion $ \numbers -> case unsnoc numbers of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] prop_isAnyVersion1 :: VersionRange -> Version -> Property prop_isAnyVersion1 range version = @@ -362,11 +367,11 @@ prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property prop_isSpecificVersion1 range (NonEmpty versions) = isJust version && not (null versions') ==> - allEqual (fromJust version : versions') + allEqual (fromJust version) versions' where - version = isSpecificVersion range - versions' = filter (`withinRange` range) versions - allEqual xs = and (zipWith (==) xs (tail xs)) + version = isSpecificVersion range + versions' = filter (`withinRange` range) versions + allEqual x xs = and (zipWith (==) (x:xs) xs) prop_isSpecificVersion2 :: VersionRange -> Property prop_isSpecificVersion2 range = diff --git a/tests/UnitTests/Orphans.hs b/tests/UnitTests/Orphans.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Orphans.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module UnitTests.Orphans where + +#if !MIN_VERSION_base(4,7,0) +import GHC.Fingerprint (Fingerprint (..)) + +deriving instance Show Fingerprint +#endif