-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2015-2018  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-|
Module      : CabalHelper.Shared.Common
Description : Shared utility functions
License     : Apache-2.0
-}

{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings #-}
module CabalHelper.Shared.Common where

#ifdef MIN_VERSION_Cabal
#undef CH_MIN_VERSION_Cabal
#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal
#endif

import Distribution.PackageDescription
    ( GenericPackageDescription
    )
import Distribution.Verbosity
    ( Verbosity
    )

#if CH_MIN_VERSION_Cabal(2,2,0)
import qualified Distribution.PackageDescription.Parsec as P
#else
import qualified Distribution.PackageDescription.Parse as P
#endif

import Control.Applicative
import Control.Exception as E
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Version
import Data.Typeable
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import System.Environment
import System.IO
import qualified System.Info
import System.Exit
import System.Directory
import System.FilePath
import Text.ParserCombinators.ReadP
import Prelude

data Panic = Panic String deriving (Typeable)
instance Exception Panic
instance Show Panic where
    show :: Panic -> String
show (Panic String
msg) = String
"panic! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

panic :: String -> a
panic :: String -> a
panic String
msg = Panic -> a
forall a e. Exception e => e -> a
throw (Panic -> a) -> Panic -> a
forall a b. (a -> b) -> a -> b
$ String -> Panic
Panic String
msg

panicIO :: String -> IO a
panicIO :: String -> IO a
panicIO String
msg = Panic -> IO a
forall e a. Exception e => e -> IO a
throwIO (Panic -> IO a) -> Panic -> IO a
forall a b. (a -> b) -> a -> b
$ String -> Panic
Panic String
msg

handlePanic :: IO a -> IO a
handlePanic :: IO a -> IO a
handlePanic IO a
action =
    IO a
action IO a -> (Panic -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(Panic String
msg) -> String -> IO ()
errMsg String
msg IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
exitFailure

errMsg :: String -> IO ()
errMsg :: String -> IO ()
errMsg String
str = do
  String
prog <- IO String
getProgName
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prog String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

parsePkgId :: String -> Maybe (String, Version)
parsePkgId :: String -> Maybe (String, Version)
parsePkgId String
s =
    case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'-') (ShowS
forall a. [a] -> [a]
reverse String
s) of
      (String
vers, Char
'-':String
pkg) -> (String, Version) -> Maybe (String, Version)
forall a. a -> Maybe a
Just (ShowS
forall a. [a] -> [a]
reverse String
pkg, String -> Version
parseVer (ShowS
forall a. [a] -> [a]
reverse String
vers))
      (String, String)
_ -> Maybe (String, Version)
forall a. Maybe a
Nothing

parsePkgIdBS :: ByteString -> Maybe (ByteString, Version)
parsePkgIdBS :: ByteString -> Maybe (ByteString, Version)
parsePkgIdBS ByteString
bs =
    case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'-') (ByteString -> ByteString
BS.reverse ByteString
bs) of
      (ByteString
vers, ByteString
pkg') ->
          (ByteString, Version) -> Maybe (ByteString, Version)
forall a. a -> Maybe a
Just ( ByteString -> ByteString
BS.reverse (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.tail ByteString
pkg'
               , String -> Version
parseVer (ByteString -> String
BS8.unpack (ByteString -> ByteString
BS.reverse ByteString
vers)))

parseVer :: String -> Version
parseVer :: String -> Version
parseVer String
vers = ReadP Version -> String -> Version
forall t. ReadP t -> String -> t
runReadP ReadP Version
parseVersion String
vers

parseVerMay :: String -> Maybe Version
parseVerMay :: String -> Maybe Version
parseVerMay String
vers = ReadP Version -> String -> Maybe Version
forall t. ReadP t -> String -> Maybe t
runReadPMay ReadP Version
parseVersion String
vers

trim :: String -> String
trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace

majorVer :: Version -> Version
majorVer :: Version -> Version
majorVer (Version [Int]
b [String]
_) = [Int] -> [String] -> Version
Version (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
2 [Int]
b) []

sameMajorVersionAs :: Version -> Version -> Bool
sameMajorVersionAs :: Version -> Version -> Bool
sameMajorVersionAs Version
a Version
b = Version -> Version
majorVer Version
a Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> Version
majorVer Version
b

runReadP :: ReadP t -> String -> t
runReadP :: ReadP t -> String -> t
runReadP ReadP t
p String
i =
  case ReadP t -> String -> Maybe t
forall t. ReadP t -> String -> Maybe t
runReadPMay ReadP t
p String
i of
    Just t
x -> t
x
    Maybe t
Nothing -> String -> t
forall a. HasCallStack => String -> a
error (String -> t) -> String -> t
forall a b. (a -> b) -> a -> b
$ String
"Error parsing version: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
i

runReadPMay :: ReadP t -> String -> Maybe t
runReadPMay :: ReadP t -> String -> Maybe t
runReadPMay ReadP t
p String
i = case ((t, String) -> Bool) -> [(t, String)] -> [(t, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"") (String -> Bool) -> ((t, String) -> String) -> (t, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t, String) -> String
forall a b. (a, b) -> b
snd) ([(t, String)] -> [(t, String)]) -> [(t, String)] -> [(t, String)]
forall a b. (a -> b) -> a -> b
$ ReadP t -> ReadS t
forall a. ReadP a -> ReadS a
readP_to_S ReadP t
p String
i of
                 (t
a,String
""):[] -> t -> Maybe t
forall a. a -> Maybe a
Just t
a
                 [(t, String)]
_ -> Maybe t
forall a. Maybe a
Nothing


appCacheDir :: IO FilePath
appCacheDir :: IO String
appCacheDir =
    (String -> ShowS
</> String
"cabal-helper") ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String -> IO String
getEnvDefault String
"XDG_CACHE_HOME" (String -> IO String
homeRel String
cache)
 where
    -- for GHC 7.4
    lookupEnv' :: String -> IO (Maybe String)
lookupEnv' String
var = do [(String, String)]
env <- IO [(String, String)]
getEnvironment; Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
var [(String, String)]
env)
    getEnvDefault :: String -> IO String -> IO String
getEnvDefault String
var IO String
def = String -> IO (Maybe String)
lookupEnv' String
var IO (Maybe String) -> (Maybe String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe String
m -> case Maybe String
m of Maybe String
Nothing -> IO String
def; Just String
x -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
    homeRel :: String -> IO String
homeRel String
path = (String -> ShowS
</> String
path) ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
    cache :: String
cache =
        case String
System.Info.os of
          String
"mingw32" -> String
windowsCache
          String
_         -> String
unixCache

    windowsCache :: String
windowsCache = String
"Local Settings" String -> ShowS
</> String
"Cache"
    unixCache :: String
unixCache = String
".cache"

replace :: String -> String -> String -> String
replace :: String -> String -> ShowS
replace String
n String
r String
hs' = String -> ShowS
go String
"" String
hs'
 where
   go :: String -> ShowS
go String
acc String
h
       | Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n) String
h String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n =
           ShowS
forall a. [a] -> [a]
reverse String
acc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n) String
h
   go String
acc (Char
h:String
hs) = String -> ShowS
go (Char
hChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) String
hs
   go String
acc [] = ShowS
forall a. [a] -> [a]
reverse String
acc


readPackageDescription
    :: Verbosity
    -> FilePath
    -> IO GenericPackageDescription
#if CH_MIN_VERSION_Cabal(2,0,0)
readPackageDescription :: Verbosity -> String -> IO GenericPackageDescription
readPackageDescription = Verbosity -> String -> IO GenericPackageDescription
Verbosity -> String -> IO GenericPackageDescription
P.readGenericPackageDescription
#else
readPackageDescription = P.readPackageDescription
#endif

mightExist :: FilePath -> IO (Maybe FilePath)
mightExist :: String -> IO (Maybe String)
mightExist String
f = do
  Bool
exists <- String -> IO Bool
doesFileExist String
f
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ if Bool
exists then (String -> Maybe String
forall a. a -> Maybe a
Just String
f) else (Maybe String
forall a. Maybe a
Nothing)