{-# LANGUAGE DataKinds #-}

-----------------------------------------------------------------------------

-- |
-- 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 Distribution.Compat.Prelude
import Prelude ()

import qualified Data.ByteString as BS
import Data.List (groupBy)
import Distribution.Fields.ParseResult
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
  ( parseGenericPackageDescription
  , parseHookedBuildInfo
  )
import Distribution.Parsec.Error (showPError)
import Distribution.Parsec.Warning
  ( PWarnType (PWTExperimental)
  , PWarning (..)
  , showPWarning
  )
import Distribution.Simple.Errors
import Distribution.Simple.Utils (dieWithException, equating, warn)
import Distribution.Utils.Path
import Distribution.Verbosity (Verbosity, normal)
import GHC.Stack
import System.Directory (doesFileExist)
import Text.Printf (printf)

readGenericPackageDescription
  :: HasCallStack
  => Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> SymbolicPath Pkg File
  -> IO GenericPackageDescription
readGenericPackageDescription :: HasCallStack =>
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription =
  (ByteString -> ParseResult GenericPackageDescription)
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
forall a.
(ByteString -> ParseResult a)
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO a
readAndParseFile ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription

readHookedBuildInfo
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ working directory
  -> SymbolicPath Pkg File
  -> IO HookedBuildInfo
readHookedBuildInfo :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO HookedBuildInfo
readHookedBuildInfo =
  (ByteString -> ParseResult HookedBuildInfo)
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO HookedBuildInfo
forall a.
(ByteString -> ParseResult a)
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> 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
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ Working directory
  -> SymbolicPath Pkg File
  -- ^ File to read
  -> IO a
readAndParseFile :: forall a.
(ByteString -> ParseResult a)
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO a
readAndParseFile ByteString -> ParseResult a
parser Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg 'File
fpath = do
  let ipath :: String
ipath = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg 'File
fpath
      upath :: String
upath = SymbolicPath Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg 'File
fpath
  exists <- String -> IO Bool
doesFileExist String
ipath
  unless exists $
    dieWithException verbosity $
      ErrorParsingFileDoesntExist upath
  bs <- BS.readFile ipath
  parseString parser verbosity upath 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 -> CabalException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO a) -> CabalException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> CabalException
FailedParsing String
name

-- | 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))
      ]