-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.PackageDescription
-- Copyright   :  Isaac Jones 2003-2005
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This defines parsers for the @.cabal@ format

module Distribution.Simple.PackageDescription (
    -- * Read and Parse files
    readGenericPackageDescription,
    readHookedBuildInfo,

    -- * Utility Parsing function
    parseString,
    ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Fields.ParseResult
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
    ( parseGenericPackageDescription, parseHookedBuildInfo )
import Distribution.Parsec.Error ( showPError )
import Distribution.Parsec.Warning
    ( PWarning(..), PWarnType(PWTExperimental), showPWarning )
import Distribution.Simple.Utils ( equating, die', warn )
import Distribution.Verbosity ( normal, Verbosity )

import Data.List ( groupBy )
import Text.Printf ( printf )
import qualified Data.ByteString as BS
import System.Directory (doesFileExist)

readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription :: Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription = (ByteString -> ParseResult GenericPackageDescription)
-> Verbosity -> String -> IO GenericPackageDescription
forall a.
(ByteString -> ParseResult a) -> Verbosity -> String -> IO a
readAndParseFile ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription

readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
readHookedBuildInfo :: Verbosity -> String -> IO HookedBuildInfo
readHookedBuildInfo = (ByteString -> ParseResult HookedBuildInfo)
-> Verbosity -> String -> IO HookedBuildInfo
forall a.
(ByteString -> ParseResult a) -> Verbosity -> String -> IO a
readAndParseFile ByteString -> ParseResult HookedBuildInfo
parseHookedBuildInfo

-- | Helper combinator to do parsing plumbing for files.
--
-- Given a parser and a filename, return the parse of the file,
-- after checking if the file exists.
--
-- Argument order is chosen to encourage partial application.
readAndParseFile
    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
    -> Verbosity                         -- ^ Verbosity level
    -> FilePath                          -- ^ File to read
    -> IO a
readAndParseFile :: forall a.
(ByteString -> ParseResult a) -> Verbosity -> String -> IO a
readAndParseFile ByteString -> ParseResult a
parser Verbosity
verbosity String
fpath = do
    Bool
exists <- String -> IO Bool
doesFileExist String
fpath
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Error Parsing: file \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fpath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" doesn't exist. Cannot continue."
    ByteString
bs <- String -> IO ByteString
BS.readFile String
fpath
    (ByteString -> ParseResult a)
-> Verbosity -> String -> ByteString -> IO a
forall a.
(ByteString -> ParseResult a)
-> Verbosity -> String -> ByteString -> IO a
parseString ByteString -> ParseResult a
parser Verbosity
verbosity String
fpath ByteString
bs

parseString
    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
    -> Verbosity                         -- ^ Verbosity level
    -> String                            -- ^ File name
    -> BS.ByteString
    -> IO a
parseString :: forall a.
(ByteString -> ParseResult a)
-> Verbosity -> String -> ByteString -> IO a
parseString ByteString -> ParseResult a
parser Verbosity
verbosity String
name ByteString
bs = do
    let ([PWarning]
warnings, Either (Maybe Version, NonEmpty PError) a
result) = ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ByteString -> ParseResult a
parser ByteString
bs)
    (PWarning -> IO ()) -> [PWarning] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> (PWarning -> String) -> PWarning -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PWarning -> String
showPWarning String
name) (Verbosity -> [PWarning] -> [PWarning]
flattenDups Verbosity
verbosity [PWarning]
warnings)
    case Either (Maybe Version, NonEmpty PError) a
result of
        Right a
x -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Left (Maybe Version
_, NonEmpty PError
errors) -> do
            (PError -> IO ()) -> NonEmpty PError -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> (PError -> String) -> PError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PError -> String
showPError String
name) NonEmpty PError
errors
            Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Failed parsing \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"."

-- | Collapse duplicate experimental feature warnings into single warning, with
-- a count of further sites
flattenDups :: Verbosity -> [PWarning] -> [PWarning]
flattenDups :: Verbosity -> [PWarning] -> [PWarning]
flattenDups Verbosity
verbosity [PWarning]
ws
    | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
normal = [PWarning]
rest [PWarning] -> [PWarning] -> [PWarning]
forall a. [a] -> [a] -> [a]
++ [PWarning]
experimentals
    | Bool
otherwise = [PWarning]
ws -- show all instances
    where
        ([PWarning]
exps, [PWarning]
rest) = (PWarning -> Bool) -> [PWarning] -> ([PWarning], [PWarning])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(PWarning PWarnType
w Position
_ String
_) -> PWarnType
w PWarnType -> PWarnType -> Bool
forall a. Eq a => a -> a -> Bool
== PWarnType
PWTExperimental) [PWarning]
ws
        experimentals :: [PWarning]
experimentals =
             ([PWarning] -> [PWarning]) -> [[PWarning]] -> [PWarning]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [PWarning] -> [PWarning]
flatCount
           ([[PWarning]] -> [PWarning])
-> ([PWarning] -> [[PWarning]]) -> [PWarning] -> [PWarning]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PWarning -> PWarning -> Bool) -> [PWarning] -> [[PWarning]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((PWarning -> String) -> PWarning -> PWarning -> Bool
forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating PWarning -> String
warningStr)
           ([PWarning] -> [[PWarning]])
-> ([PWarning] -> [PWarning]) -> [PWarning] -> [[PWarning]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PWarning -> PWarning -> Ordering) -> [PWarning] -> [PWarning]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((PWarning -> String) -> PWarning -> PWarning -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing PWarning -> String
warningStr)
           ([PWarning] -> [PWarning]) -> [PWarning] -> [PWarning]
forall a b. (a -> b) -> a -> b
$ [PWarning]
exps

        warningStr :: PWarning -> String
warningStr (PWarning PWarnType
_ Position
_ String
w) = String
w

        -- flatten if we have 3 or more examples
        flatCount :: [PWarning] -> [PWarning]
        flatCount :: [PWarning] -> [PWarning]
flatCount w :: [PWarning]
w@[] = [PWarning]
w
        flatCount w :: [PWarning]
w@[PWarning
_] = [PWarning]
w
        flatCount w :: [PWarning]
w@[PWarning
_,PWarning
_] = [PWarning]
w
        flatCount (PWarning PWarnType
t Position
pos String
w:[PWarning]
xs) =
            [PWarnType -> Position -> String -> PWarning
PWarning PWarnType
t Position
pos
                (String
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
" (and %d more occurrences)" ([PWarning] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PWarning]
xs))
            ]