{-# 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 cur act = C.bracket (liftIO Dir.getCurrentDirectory) (liftIO . Dir.setCurrentDirectory) $
        const (liftIO (Dir.setCurrentDirectory cur) >> act)

-- | Is directory symbolic link
dirIsSymLink :: FilePath -> IO Bool
#if MIN_VERSION_directory(1,3,0)
dirIsSymLink = 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 p = handle ignore $ do
        b <- Dir.doesDirectoryExist p
        isLink <- dirIsSymLink p
        if b && (not isLink)
                then liftM (map (p </>) . filter (`notElem` [".", ".."])) (Dir.getDirectoryContents p)
                else return []
        where
                ignore :: SomeException -> IO [FilePath]
                ignore _ = return []

-- | Collect all file names in directory recursively
traverseDirectory :: FilePath -> IO [FilePath]
traverseDirectory p = handle onError $ do
        cts <- directoryContents p
        liftM concat $ forM cts $ \c -> do
                isDir <- Dir.doesDirectoryExist c
                if isDir
                        then (c :) <$> traverseDirectory c
                        else return [c]
        where
                onError :: IOException -> IO [FilePath]
                onError _ = return []

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

-- | Is haskell source?
haskellSource :: FilePath -> Bool
haskellSource f = takeExtension f `elem` [".hs", ".lhs"]

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

-- | Add N tabs to line
tab :: Int -> String -> String
tab n s = replicate n '\t' ++ s

-- | Trim string
trim :: String -> String
trim = p . p where
        p = reverse . dropWhile isSpace

-- | Split list
split :: (a -> Bool) -> [a] -> [[a]]
split p = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break p)

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

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

mapBy :: Ord b => (a -> b) -> [a] -> M.Map b a
mapBy f = M.fromList . map (f &&& 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
v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v

-- | Returns @Nothing@ when key doesn't exist or value is @Null@
(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a)
v .::? name = fmap join $ traverse parseJSON $ lookup name $ HM.toList 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]
v .::?! name = fromMaybe [] <$> (v .::? name)

-- | Union two JSON objects
objectUnion :: Value -> Value -> Value
objectUnion (Object l) (Object r) = Object $ HM.union l r
objectUnion (Object l) _ = Object l
objectUnion _ (Object r) = Object r
objectUnion _ _ = Null

-- | No Nulls in JSON object
noNulls :: [A.Pair] -> [A.Pair]
noNulls = filter (not . isNull . snd) where
        isNull Null = True
        isNull v = v == A.emptyArray || v == A.emptyObject || v == A.String ""

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

-- | Lift IO exception to ExceptT
liftException :: C.MonadCatch m => m a -> ExceptT String m a
liftException = ExceptT . liftM (left $ \(SomeException e) -> displayException e) . C.try

-- | Same as @liftException@
liftE :: C.MonadCatch m => m a -> ExceptT String m a
liftE = liftException

-- | Run actions ignoring errors
tries :: MonadPlus m => [m a] -> m [a]
tries acts = liftM catMaybes $ sequence [liftM Just act `mplus` return Nothing | act <- acts]

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

-- | Lift IO exceptions to ExceptT
liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a
liftIOErrors act = liftException (runExceptT act) >>= either throwError return

-- | Log exceptions and ignore
logAll :: (MonadLog m, C.MonadCatch m) => m () -> m ()
logAll = C.handleAll logExc' where
        logExc' e = sendLog Warning $ "exception: {}" ~~ displayException e

fromUtf8 :: ByteString -> String
fromUtf8 = T.unpack . T.decodeUtf8

toUtf8 :: String -> ByteString
toUtf8 = T.encodeUtf8 . T.pack

-- | Read file in UTF8
readFileUtf8 :: FilePath -> IO Text
readFileUtf8 f = withFile f ReadMode $ \h -> do
        hSetEncoding h utf8
        cts <- ST.hGetContents h
        cts `deepseq` return cts

writeFileUtf8 :: FilePath -> Text -> IO ()
writeFileUtf8 f cts = withFile f WriteMode $ \h -> do
        hSetEncoding h utf8
        ST.hPutStr h cts

hGetLineBS :: Handle -> IO ByteString
hGetLineBS = fmap L.fromStrict . B.hGetLine

logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m ()
logIO pre out = flip C.catch (onIO out) where
        onIO :: (String -> a) -> IOException -> a
        onIO out' e = out' $ pre ++ displayException e

logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m ()
logAsync out = flip C.catch (onAsync out) where
        onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m ()
        onAsync out' e = out' (displayException e) >> C.throwM e

ignoreIO :: C.MonadCatch m => m () -> m ()
ignoreIO = C.handle ignore' where
        ignore' :: Monad m => IOException -> m ()
        ignore' _ = return ()

class FromCmd a where
        cmdP :: Parser a

cmdJson :: String -> [A.Pair] -> Value
cmdJson nm ps = object $ ("command" .= nm) : ps

guardCmd :: String -> Object -> A.Parser ()
guardCmd nm obj = do
        cmdName <- obj .:: "command"
        guard (nm == cmdName)

-- | Add help command to parser
withHelp :: Parser a -> Parser a
withHelp = (helper' <*>) where
        helper' = abortOption ShowHelpText $ long "help" <> short '?' <> help "show help" <> hidden

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

-- | Parse arguments or return help
parseArgs :: String -> ParserInfo a -> [String] -> Either String a
parseArgs nm p = handle' . execParserPure (prefs mempty) (p { infoParser = withHelp (infoParser p) }) where
        handle' :: ParserResult a -> Either String a
        handle' (Success r) = Right r
        handle' (Failure f) = Left $ fst $ renderFailure f nm
        handle' _ = Left "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 = mapM readMaybe $ split (== '.') $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 typeName v = maybe err return (simpleParse v) where
        err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v

-- | Measure time of action
timer :: MonadLog m => Text -> m a -> m a
timer msg act = do
        s <- liftIO getPOSIXTime
        r <- act
        e <- liftIO getPOSIXTime
        sendLog Trace $ "{}: {}" ~~ msg ~~ show (e - s)
        return r