{-# LANGUAGE FlexibleContexts, OverloadedStrings, TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Util (
	withCurrentDirectory,
	directoryContents,
	traverseDirectory, searchPath,
	haskellSource,
	cabalFile,
	-- * String utils
	tab,
	trim, split,
	-- * Other utils
	ordNub, uniqueBy, mapBy,
	-- * Helper
	(.::), (.::?), (.::?!), objectUnion, noNulls, fromJSON',
	-- * Exceptions
	liftException, liftE, tries, triesMap, liftIOErrors,
	logAll,
	-- * UTF-8
	fromUtf8, toUtf8, readFileUtf8, writeFileUtf8,
	-- * IO
	hGetLineBS, logIO, ignoreIO, logAsync,
	-- * Command line
	FromCmd(..),
	cmdJson, guardCmd,
	withHelp, cmd, parseArgs,
	-- * Version stuff
	version,
	-- * Parse
	parseDT,

	-- * Log utils
	timer,

	-- * Reexportss
	module Control.Monad.Except,
	MonadIO(..)
	) where

import Control.Arrow (second, left, (&&&))
import Control.Exception
import Control.DeepSeq
import Control.Monad
import Control.Monad.Except
import qualified Control.Monad.Catch as C
import Data.Aeson hiding (Result(..), Error)
import qualified Data.Aeson.Types as A
import Data.Char (isSpace)
import Data.List (unfoldr)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HM (HashMap, toList, union)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Text (Text)
import qualified Data.Text.IO as ST
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import Data.Time.Clock.POSIX
import Distribution.Text (simpleParse)
#if MIN_VERSION_Cabal(3,0,0)
import qualified Distribution.Parsec as DT
#else
import qualified Distribution.Text as DT
#endif
import Options.Applicative
import qualified System.Directory as Dir
import System.FilePath
import System.Log.Simple
import System.IO
import Text.Format
import Text.Read (readMaybe)

#if !MIN_VERSION_directory(1,2,6)
#if mingw32_HOST_OS
import qualified System.Win32 as Win32
import Data.Bits ((.&.))
#else
import qualified System.Posix as Posix
#endif
#endif

import HsDev.Version

-- | Run action with current directory set
withCurrentDirectory :: (MonadIO m, C.MonadMask m) => FilePath -> m a -> m a
withCurrentDirectory :: FilePath -> m a -> m a
withCurrentDirectory FilePath
cur m a
act = m FilePath -> (FilePath -> m ()) -> (FilePath -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
C.bracket (IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
Dir.getCurrentDirectory) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (FilePath -> IO ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
Dir.setCurrentDirectory) ((FilePath -> m a) -> m a) -> (FilePath -> m a) -> m a
forall a b. (a -> b) -> a -> b
$
	m a -> FilePath -> m a
forall a b. a -> b -> a
const (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ()
Dir.setCurrentDirectory FilePath
cur) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
act)

-- | Is directory symbolic link
dirIsSymLink :: FilePath -> IO Bool
#if MIN_VERSION_directory(1,3,0)
dirIsSymLink :: FilePath -> IO Bool
dirIsSymLink = FilePath -> IO Bool
Dir.pathIsSymbolicLink
#elif MIN_VERSION_directory(1,2,6)
dirIsSymLink = Dir.isSymbolicLink
#else
dirIsSymLink path = do
#if mingw32_HOST_OS
	isReparsePoint <$> Win32.getFileAttributes path
	where
		fILE_ATTRIBUTE_REPARSE_POINT = 0x400
		isReparsePoint attr = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0
#else
	Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path
#endif
#endif

-- | Get directory contents safely: no fail, ignoring symbolic links, also prepends paths with dir name
directoryContents :: FilePath -> IO [FilePath]
directoryContents :: FilePath -> IO [FilePath]
directoryContents FilePath
p = (SomeException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO [FilePath]
ignore (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
	Bool
b <- FilePath -> IO Bool
Dir.doesDirectoryExist FilePath
p
	Bool
isLink <- FilePath -> IO Bool
dirIsSymLink FilePath
p
	if Bool
b Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isLink)
		then ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
p FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
".", FilePath
".."])) (FilePath -> IO [FilePath]
Dir.getDirectoryContents FilePath
p)
		else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
	where
		ignore :: SomeException -> IO [FilePath]
		ignore :: SomeException -> IO [FilePath]
ignore SomeException
_ = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Collect all file names in directory recursively
traverseDirectory :: FilePath -> IO [FilePath]
traverseDirectory :: FilePath -> IO [FilePath]
traverseDirectory FilePath
p = (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO [FilePath]
onError (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
	[FilePath]
cts <- FilePath -> IO [FilePath]
directoryContents FilePath
p
	([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[FilePath]] -> IO [FilePath])
-> IO [[FilePath]] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
cts ((FilePath -> IO [FilePath]) -> IO [[FilePath]])
-> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ \FilePath
c -> do
		Bool
isDir <- FilePath -> IO Bool
Dir.doesDirectoryExist FilePath
c
		if Bool
isDir
			then (FilePath
c FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
traverseDirectory FilePath
c
			else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
c]
	where
		onError :: IOException -> IO [FilePath]
		onError :: IOException -> IO [FilePath]
onError IOException
_ = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Search something up
searchPath :: (MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m a) -> m a
searchPath :: FilePath -> (FilePath -> m a) -> m a
searchPath FilePath
p FilePath -> m a
f = do
	FilePath
p' <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
Dir.canonicalizePath FilePath
p
	Bool
isDir <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
Dir.doesDirectoryExist FilePath
p'
	FilePath -> m a
search' (if Bool
isDir then FilePath
p' else FilePath -> FilePath
takeDirectory FilePath
p')
	where
		search' :: FilePath -> m a
search' FilePath
dir
			| FilePath -> Bool
isDrive FilePath
dir = FilePath -> m a
f FilePath
dir
			| Bool
otherwise = FilePath -> m a
f FilePath
dir m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> m a
search' (FilePath -> FilePath
takeDirectory FilePath
dir)

-- | Is haskell source?
haskellSource :: FilePath -> Bool
haskellSource :: FilePath -> Bool
haskellSource FilePath
f = FilePath -> FilePath
takeExtension FilePath
f FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".hs", FilePath
".lhs"]

-- | Is cabal file?
cabalFile :: FilePath -> Bool
cabalFile :: FilePath -> Bool
cabalFile FilePath
f = FilePath -> FilePath
takeExtension FilePath
f FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"

-- | Add N tabs to line
tab :: Int -> String -> String
tab :: Int -> FilePath -> FilePath
tab Int
n FilePath
s = Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
n Char
'\t' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s

-- | Trim string
trim :: String -> String
trim :: FilePath -> FilePath
trim = FilePath -> FilePath
p (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
p where
	p :: FilePath -> FilePath
p = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- | Split list
split :: (a -> Bool) -> [a] -> [[a]]
split :: (a -> Bool) -> [a] -> [[a]]
split a -> Bool
p = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Maybe ([a], [a])) -> [a] -> [[a]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just (([a], [a]) -> Maybe ([a], [a]))
-> ([a] -> ([a], [a])) -> [a] -> Maybe ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1) (([a], [a]) -> ([a], [a]))
-> ([a] -> ([a], [a])) -> [a] -> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p)

-- | nub is quadratic, https://github.com/nh2/haskell-ordnub/#ordnub
ordNub :: Ord a => [a] -> [a]
ordNub :: [a] -> [a]
ordNub = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty where
	go :: Set a -> [a] -> [a]
go Set a
_ [] = []
	go Set a
s (a
x:[a]
xs)
		| a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s = Set a -> [a] -> [a]
go Set a
s [a]
xs
		| Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs

uniqueBy :: Ord b => (a -> b) -> [a] -> [a]
uniqueBy :: (a -> b) -> [a] -> [a]
uniqueBy a -> b
f = Map b a -> [a]
forall k a. Map k a -> [a]
M.elems (Map b a -> [a]) -> ([a] -> Map b a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> Map b a
forall b a. Ord b => (a -> b) -> [a] -> Map b a
mapBy a -> b
f

mapBy :: Ord b => (a -> b) -> [a] -> M.Map b a
mapBy :: (a -> b) -> [a] -> Map b a
mapBy a -> b
f = [(b, a)] -> Map b a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(b, a)] -> Map b a) -> ([a] -> [(b, a)]) -> [a] -> Map b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (b, a)) -> [a] -> [(b, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> b
f (a -> b) -> (a -> a) -> a -> (b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> a
forall a. a -> a
id)

-- | Workaround, sometimes we get HM.lookup "foo" v == Nothing, but lookup "foo" (HM.toList v) == Just smth
(.::) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser a
HashMap Text Value
v .:: :: HashMap Text Value -> Text -> Parser a
.:: Text
name = Parser a -> (Value -> Parser a) -> Maybe Value -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser a) -> FilePath -> Parser a
forall a b. (a -> b) -> a -> b
$ FilePath
"key " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not present") Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON (Maybe Value -> Parser a) -> Maybe Value -> Parser a
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name ([(Text, Value)] -> Maybe Value) -> [(Text, Value)] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text Value
v

-- | Returns @Nothing@ when key doesn't exist or value is @Null@
(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a)
HashMap Text Value
v .::? :: HashMap Text Value -> Text -> Parser (Maybe a)
.::? Text
name = (Maybe (Maybe a) -> Maybe a)
-> Parser (Maybe (Maybe a)) -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Parser (Maybe (Maybe a)) -> Parser (Maybe a))
-> Parser (Maybe (Maybe a)) -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ (Value -> Parser (Maybe a))
-> Maybe Value -> Parser (Maybe (Maybe a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser (Maybe a)
forall a. FromJSON a => Value -> Parser a
parseJSON (Maybe Value -> Parser (Maybe (Maybe a)))
-> Maybe Value -> Parser (Maybe (Maybe a))
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name ([(Text, Value)] -> Maybe Value) -> [(Text, Value)] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text Value
v

-- | Same as @.::?@ for list, returns empty list for non-existant key or @Null@ value
(.::?!) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser [a]
HashMap Text Value
v .::?! :: HashMap Text Value -> Text -> Parser [a]
.::?! Text
name = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [a] -> [a]) -> Parser (Maybe [a]) -> Parser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe [a])
forall a.
FromJSON a =>
HashMap Text Value -> Text -> Parser (Maybe a)
.::? Text
name)

-- | Union two JSON objects
objectUnion :: Value -> Value -> Value
objectUnion :: Value -> Value -> Value
objectUnion (Object HashMap Text Value
l) (Object HashMap Text Value
r) = HashMap Text Value -> Value
Object (HashMap Text Value -> Value) -> HashMap Text Value -> Value
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> HashMap Text Value -> HashMap Text Value
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union HashMap Text Value
l HashMap Text Value
r
objectUnion (Object HashMap Text Value
l) Value
_ = HashMap Text Value -> Value
Object HashMap Text Value
l
objectUnion Value
_ (Object HashMap Text Value
r) = HashMap Text Value -> Value
Object HashMap Text Value
r
objectUnion Value
_ Value
_ = Value
Null

-- | No Nulls in JSON object
noNulls :: [A.Pair] -> [A.Pair]
noNulls :: [(Text, Value)] -> [(Text, Value)]
noNulls = ((Text, Value) -> Bool) -> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Text, Value) -> Bool) -> (Text, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
isNull (Value -> Bool)
-> ((Text, Value) -> Value) -> (Text, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> Value
forall a b. (a, b) -> b
snd) where
	isNull :: Value -> Bool
isNull Value
Null = Bool
True
	isNull Value
v = Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
A.emptyArray Bool -> Bool -> Bool
|| Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
A.emptyObject Bool -> Bool -> Bool
|| Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
A.String Text
""

-- | Try convert json to value
fromJSON' :: FromJSON a => Value -> Maybe a
fromJSON' :: Value -> Maybe a
fromJSON' Value
v = case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
	A.Success a
r -> a -> Maybe a
forall a. a -> Maybe a
Just a
r
	Result a
_ -> Maybe a
forall a. Maybe a
Nothing

-- | Lift IO exception to ExceptT
liftException :: C.MonadCatch m => m a -> ExceptT String m a
liftException :: m a -> ExceptT FilePath m a
liftException = m (Either FilePath a) -> ExceptT FilePath m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either FilePath a) -> ExceptT FilePath m a)
-> (m a -> m (Either FilePath a)) -> m a -> ExceptT FilePath m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either SomeException a -> Either FilePath a)
-> m (Either SomeException a) -> m (Either FilePath a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((SomeException -> FilePath)
-> Either SomeException a -> Either FilePath a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((SomeException -> FilePath)
 -> Either SomeException a -> Either FilePath a)
-> (SomeException -> FilePath)
-> Either SomeException a
-> Either FilePath a
forall a b. (a -> b) -> a -> b
$ \(SomeException e
e) -> e -> FilePath
forall e. Exception e => e -> FilePath
displayException e
e) (m (Either SomeException a) -> m (Either FilePath a))
-> (m a -> m (Either SomeException a))
-> m a
-> m (Either FilePath a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
C.try

-- | Same as @liftException@
liftE :: C.MonadCatch m => m a -> ExceptT String m a
liftE :: m a -> ExceptT FilePath m a
liftE = m a -> ExceptT FilePath m a
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT FilePath m a
liftException

-- | Run actions ignoring errors
tries :: MonadPlus m => [m a] -> m [a]
tries :: [m a] -> m [a]
tries [m a]
acts = ([Maybe a] -> [a]) -> m [Maybe a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe a] -> m [a]) -> m [Maybe a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [m (Maybe a)] -> m [Maybe a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [(a -> Maybe a) -> m a -> m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just m a
act m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing | m a
act <- [m a]
acts]

triesMap :: MonadPlus m => (a -> m b) -> [a] -> m [b]
triesMap :: (a -> m b) -> [a] -> m [b]
triesMap a -> m b
f = [m b] -> m [b]
forall (m :: * -> *) a. MonadPlus m => [m a] -> m [a]
tries ([m b] -> m [b]) -> ([a] -> [m b]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m b) -> [a] -> [m b]
forall a b. (a -> b) -> [a] -> [b]
map a -> m b
f

-- | Lift IO exceptions to ExceptT
liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a
liftIOErrors :: ExceptT FilePath m a -> ExceptT FilePath m a
liftIOErrors ExceptT FilePath m a
act = m (Either FilePath a) -> ExceptT FilePath m (Either FilePath a)
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT FilePath m a
liftException (ExceptT FilePath m a -> m (Either FilePath a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT FilePath m a
act) ExceptT FilePath m (Either FilePath a)
-> (Either FilePath a -> ExceptT FilePath m a)
-> ExceptT FilePath m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> ExceptT FilePath m a)
-> (a -> ExceptT FilePath m a)
-> Either FilePath a
-> ExceptT FilePath m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> ExceptT FilePath m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> ExceptT FilePath m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Log exceptions and ignore
logAll :: (MonadLog m, C.MonadCatch m) => m () -> m ()
logAll :: m () -> m ()
logAll = (SomeException -> m ()) -> m () -> m ()
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
C.handleAll SomeException -> m ()
forall (m :: * -> *) e. (MonadLog m, Exception e) => e -> m ()
logExc' where
	logExc' :: e -> m ()
logExc' e
e = Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
sendLog Level
Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"exception: {}" Format -> FilePath -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ e -> FilePath
forall e. Exception e => e -> FilePath
displayException e
e

fromUtf8 :: ByteString -> String
fromUtf8 :: ByteString -> FilePath
fromUtf8 = Text -> FilePath
T.unpack (Text -> FilePath)
-> (ByteString -> Text) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8

toUtf8 :: String -> ByteString
toUtf8 :: FilePath -> ByteString
toUtf8 = Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack

-- | Read file in UTF8
readFileUtf8 :: FilePath -> IO Text
readFileUtf8 :: FilePath -> IO Text
readFileUtf8 FilePath
f = FilePath -> IOMode -> (Handle -> IO Text) -> IO Text
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
f IOMode
ReadMode ((Handle -> IO Text) -> IO Text) -> (Handle -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
	Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
	Text
cts <- Handle -> IO Text
ST.hGetContents Handle
h
	Text
cts Text -> IO Text -> IO Text
forall a b. NFData a => a -> b -> b
`deepseq` Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
cts

writeFileUtf8 :: FilePath -> Text -> IO ()
writeFileUtf8 :: FilePath -> Text -> IO ()
writeFileUtf8 FilePath
f Text
cts = FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
f IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
	Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
	Handle -> Text -> IO ()
ST.hPutStr Handle
h Text
cts

hGetLineBS :: Handle -> IO ByteString
hGetLineBS :: Handle -> IO ByteString
hGetLineBS = (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
L.fromStrict (IO ByteString -> IO ByteString)
-> (Handle -> IO ByteString) -> Handle -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ByteString
B.hGetLine

logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m ()
logIO :: FilePath -> (FilePath -> m ()) -> m () -> m ()
logIO FilePath
pre FilePath -> m ()
out = (m () -> (IOException -> m ()) -> m ())
-> (IOException -> m ()) -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
C.catch ((FilePath -> m ()) -> IOException -> m ()
forall a. (FilePath -> a) -> IOException -> a
onIO FilePath -> m ()
out) where
	onIO :: (String -> a) -> IOException -> a
	onIO :: (FilePath -> a) -> IOException -> a
onIO FilePath -> a
out' IOException
e = FilePath -> a
out' (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ FilePath
pre FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e

logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m ()
logAsync :: (FilePath -> m ()) -> m () -> m ()
logAsync FilePath -> m ()
out = (m () -> (AsyncException -> m ()) -> m ())
-> (AsyncException -> m ()) -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> (AsyncException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
C.catch ((FilePath -> m ()) -> AsyncException -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
(FilePath -> m ()) -> AsyncException -> m ()
onAsync FilePath -> m ()
out) where
	onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m ()
	onAsync :: (FilePath -> m ()) -> AsyncException -> m ()
onAsync FilePath -> m ()
out' AsyncException
e = FilePath -> m ()
out' (AsyncException -> FilePath
forall e. Exception e => e -> FilePath
displayException AsyncException
e) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AsyncException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
C.throwM AsyncException
e

ignoreIO :: C.MonadCatch m => m () -> m ()
ignoreIO :: m () -> m ()
ignoreIO = (IOException -> m ()) -> m () -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
C.handle IOException -> m ()
forall (m :: * -> *). Monad m => IOException -> m ()
ignore' where
	ignore' :: Monad m => IOException -> m ()
	ignore' :: IOException -> m ()
ignore' IOException
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

class FromCmd a where
	cmdP :: Parser a

cmdJson :: String -> [A.Pair] -> Value
cmdJson :: FilePath -> [(Text, Value)] -> Value
cmdJson FilePath
nm [(Text, Value)]
ps = [(Text, Value)] -> Value
object ([(Text, Value)] -> Value) -> [(Text, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ (Text
"command" Text -> FilePath -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath
nm) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: [(Text, Value)]
ps

guardCmd :: String -> Object -> A.Parser ()
guardCmd :: FilePath -> HashMap Text Value -> Parser ()
guardCmd FilePath
nm HashMap Text Value
obj = do
	FilePath
cmdName <- HashMap Text Value
obj HashMap Text Value -> Text -> Parser FilePath
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.:: Text
"command"
	Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FilePath
nm FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
cmdName)

-- | Add help command to parser
withHelp :: Parser a -> Parser a
withHelp :: Parser a -> Parser a
withHelp = (Parser (a -> a)
forall a. Parser (a -> a)
helper' Parser (a -> a) -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) where
	helper' :: Parser (a -> a)
helper' = ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
ShowHelpText (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"help" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'?' Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"show help" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden

-- | Subcommand
cmd :: String -> String -> Parser a -> Mod CommandFields a
cmd :: FilePath -> FilePath -> Parser a -> Mod CommandFields a
cmd FilePath
n FilePath
d Parser a
p = FilePath -> ParserInfo a -> Mod CommandFields a
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
n (Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser a -> Parser a
forall a. Parser a -> Parser a
withHelp Parser a
p) (FilePath -> InfoMod a
forall a. FilePath -> InfoMod a
progDesc FilePath
d))

-- | Parse arguments or return help
parseArgs :: String -> ParserInfo a -> [String] -> Either String a
parseArgs :: FilePath -> ParserInfo a -> [FilePath] -> Either FilePath a
parseArgs FilePath
nm ParserInfo a
p = ParserResult a -> Either FilePath a
forall a. ParserResult a -> Either FilePath a
handle' (ParserResult a -> Either FilePath a)
-> ([FilePath] -> ParserResult a)
-> [FilePath]
-> Either FilePath a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs -> ParserInfo a -> [FilePath] -> ParserResult a
forall a.
ParserPrefs -> ParserInfo a -> [FilePath] -> ParserResult a
execParserPure (PrefsMod -> ParserPrefs
prefs PrefsMod
forall a. Monoid a => a
mempty) (ParserInfo a
p { infoParser :: Parser a
infoParser = Parser a -> Parser a
forall a. Parser a -> Parser a
withHelp (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
p) }) where
	handle' :: ParserResult a -> Either String a
	handle' :: ParserResult a -> Either FilePath a
handle' (Success a
r) = a -> Either FilePath a
forall a b. b -> Either a b
Right a
r
	handle' (Failure ParserFailure ParserHelp
f) = FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ (FilePath, ExitCode) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, ExitCode) -> FilePath)
-> (FilePath, ExitCode) -> FilePath
forall a b. (a -> b) -> a -> b
$ ParserFailure ParserHelp -> FilePath -> (FilePath, ExitCode)
renderFailure ParserFailure ParserHelp
f FilePath
nm
	handle' ParserResult a
_ = FilePath -> Either FilePath a
forall a b. a -> Either a b
Left FilePath
"error: completion invoked result"

-- instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where
-- 	askLog = lift Log.askLog

-- | Get hsdev version as list of integers
version :: Maybe [Int]
version :: Maybe [Int]
version = (FilePath -> Maybe Int) -> [FilePath] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe ([FilePath] -> Maybe [Int]) -> [FilePath] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> [FilePath]
forall a. (a -> Bool) -> [a] -> [[a]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') FilePath
$cabalVersion

-- | Parse Distribution.Text
#if MIN_VERSION_Cabal(3,0,0)
#if __GLASGOW_HASKELL__ >= 808
parseDT :: (MonadFail m, Monad m, DT.Parsec a) => String -> String -> m a
#else
parseDT :: (Monad m, DT.Parsec a) => String -> String -> m a
#endif
#else
parseDT :: (Monad m, DT.Text a) => String -> String -> m a
#endif
parseDT :: FilePath -> FilePath -> m a
parseDT FilePath
typeName FilePath
v = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall a. m a
err a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe a
forall a. Parsec a => FilePath -> Maybe a
simpleParse FilePath
v) where
	err :: m a
err = FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m a) -> FilePath -> m a
forall a b. (a -> b) -> a -> b
$ Format
"Can't parse {}: {}" Format -> FilePath -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ FilePath
typeName Format -> FilePath -> FilePath
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ FilePath
v

-- | Measure time of action
timer :: MonadLog m => Text -> m a -> m a
timer :: Text -> m a -> m a
timer Text
msg m a
act = do
	POSIXTime
s <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
	a
r <- m a
act
	POSIXTime
e <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
	Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
sendLog Level
Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"{}: {}" Format -> Text -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
msg Format -> FilePath -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ POSIXTime -> FilePath
forall a. Show a => a -> FilePath
show (POSIXTime
e POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
s)
	a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r