Cabal/src/Distribution/Simple/PackageDescription.hs

   1 -----------------------------------------------------------------------------
   2
   3 -- |
   4 -- Module      :  Distribution.Simple.PackageDescription
   5 -- Copyright   :  Isaac Jones 2003-2005
   6 -- License     :  BSD3
   7 --
   8 -- Maintainer  :  cabal-devel@haskell.org
   9 -- Portability :  portable
  10 --
  11 -- This defines parsers for the @.cabal@ format
  12 module Distribution.Simple.PackageDescription
  13   ( -- * Read and Parse files
  14     readGenericPackageDescription
  15   , readHookedBuildInfo
  16
  17     -- * Utility Parsing function
  18   , parseString
  19   ) where
  20
  21 import Distribution.Compat.Prelude
  22 import Prelude ()
  23
  24 import qualified Data.ByteString as BS
  25 import Data.List (groupBy)
  26 import Distribution.Fields.ParseResult
  27 import Distribution.PackageDescription
  28 import Distribution.PackageDescription.Parsec
  29   ( parseGenericPackageDescription
  30   , parseHookedBuildInfo
  31   )
  32 import Distribution.Parsec.Error (showPError)
  33 import Distribution.Parsec.Warning
  34   ( PWarnType (PWTExperimental)
  35   , PWarning (..)
  36   , showPWarning
  37   )
  38 import Distribution.Simple.Errors
  39 import Distribution.Simple.Utils (dieWithException, equating, warn)
  40 import Distribution.Verbosity (Verbosity, normal)
  41 import System.Directory (doesFileExist)
  42 import Text.Printf (printf)
  43
  44 readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
  45 readGenericPackageDescription = readAndParseFile parseGenericPackageDescription
  46
  47 readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
  48 readHookedBuildInfo = readAndParseFile parseHookedBuildInfo
  49
  50 -- | Helper combinator to do parsing plumbing for files.
  51 --
  52 -- Given a parser and a filename, return the parse of the file,
  53 -- after checking if the file exists.
  54 --
  55 -- Argument order is chosen to encourage partial application.
  56 readAndParseFile
  57   :: (BS.ByteString -> ParseResult a)
  58   -- ^ File contents to final value parser
  59   -> Verbosity
  60   -- ^ Verbosity level
  61   -> FilePath
  62   -- ^ File to read
  63   -> IO a
  64 readAndParseFile parser verbosity fpath = do
  65   exists <- doesFileExist fpath
  66   unless exists $
  67     dieWithException verbosity $
  68       ErrorParsingFileDoesntExist fpath
  69   bs <- BS.readFile fpath
  70   parseString parser verbosity fpath bs
  71
  72 parseString
  73   :: (BS.ByteString -> ParseResult a)
  74   -- ^ File contents to final value parser
  75   -> Verbosity
  76   -- ^ Verbosity level
  77   -> String
  78   -- ^ File name
  79   -> BS.ByteString
  80   -> IO a
  81 parseString parser verbosity name bs = do
  82   let (warnings, result) = runParseResult (parser bs)
  83   traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings)
  84   case result of
  85     Right x -> return x
  86     Left (_, errors) -> do
  87       traverse_ (warn verbosity . showPError name) errors
  88       dieWithException verbosity $ FailedParsing name
  89
  90 -- | Collapse duplicate experimental feature warnings into single warning, with
  91 -- a count of further sites
  92 flattenDups :: Verbosity -> [PWarning] -> [PWarning]
  93 flattenDups verbosity ws
  94   | verbosity <= normal = rest ++ experimentals
  95   | otherwise = ws -- show all instances
  96   where
  97     (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws
  98     experimentals =
  99       concatMap flatCount
 100         . groupBy (equating warningStr)
 101         . sortBy (comparing warningStr)
 102         $ exps
 103
 104     warningStr (PWarning _ _ w) = w
 105
 106     -- flatten if we have 3 or more examples
 107     flatCount :: [PWarning] -> [PWarning]
 108     flatCount w@[] = w
 109     flatCount w@[_] = w
 110     flatCount w@[_, _] = w
 111     flatCount (PWarning t pos w : xs) =
 112       [ PWarning
 113           t
 114           pos
 115           (w <> printf " (and %d more occurrences)" (length xs))
 116       ]