-- 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 msg :: String
msg) = "panic! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

panic :: String -> a
panic :: String -> a
panic msg :: 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 msg :: 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 action :: 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 msg :: 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 str :: 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

parsePkgId :: String -> Maybe (String, Version)
parsePkgId :: String -> Maybe (String, Version)
parsePkgId s :: 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
/='-') (ShowS
forall a. [a] -> [a]
reverse String
s) of
      (vers :: String
vers, '-':pkg :: 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))
      _ -> Maybe (String, Version)
forall a. Maybe a
Nothing

parsePkgIdBS :: ByteString -> Maybe (ByteString, Version)
parsePkgIdBS :: ByteString -> Maybe (ByteString, Version)
parsePkgIdBS bs :: ByteString
bs =
    case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='-') (ByteString -> ByteString
BS.reverse ByteString
bs) of
      (vers :: ByteString
vers, pkg' :: 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 vers :: 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 vers :: 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 b :: [Int]
b _) = [Int] -> [String] -> Version
Version (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take 2 [Int]
b) []

sameMajorVersionAs :: Version -> Version -> Bool
sameMajorVersionAs :: Version -> Version -> Bool
sameMajorVersionAs a :: Version
a b :: 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 p :: ReadP t
p i :: String
i =
  case ReadP t -> String -> Maybe t
forall t. ReadP t -> String -> Maybe t
runReadPMay ReadP t
p String
i of
    Just x :: t
x -> t
x
    Nothing -> String -> t
forall a. HasCallStack => String -> a
error (String -> t) -> String -> t
forall a b. (a -> b) -> a -> b
$ "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 p :: ReadP t
p i :: 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 -> 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
                 (a :: t
a,""):[] -> t -> Maybe t
forall a. a -> Maybe a
Just t
a
                 _ -> Maybe t
forall a. Maybe a
Nothing


appCacheDir :: IO FilePath
appCacheDir :: IO String
appCacheDir =
    (String -> ShowS
</> "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 "XDG_CACHE_HOME" (String -> IO String
homeRel String
cache)
 where
    -- for GHC 7.4
    lookupEnv' :: String -> IO (Maybe String)
lookupEnv' var :: 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 var :: String
var def :: 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
>>= \m :: Maybe String
m -> case Maybe String
m of Nothing -> IO String
def; Just x :: String
x -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
    homeRel :: String -> IO String
homeRel path :: 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
          "mingw32" -> String
windowsCache
          _         -> String
unixCache

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

replace :: String -> String -> String -> String
replace :: String -> String -> ShowS
replace n :: String
n r :: String
r hs' :: String
hs' = String -> ShowS
go "" String
hs'
 where
   go :: String -> ShowS
go acc :: String
acc h :: 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 acc :: String
acc (h :: Char
h:hs :: String
hs) = String -> ShowS
go (Char
hChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) String
hs
   go acc :: 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 f :: 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)