-- | Utility functions
module Language.Haskell.Ghcid.Util(
    ghciFlagsRequired, ghciFlagsRequiredVersioned,
    ghciFlagsUseful, ghciFlagsUsefulVersioned,
    dropPrefixRepeatedly,
    takeRemainder,
    outStr, outStrLn,
    ignored,
    allGoodMessage,
    getModTime, getModTimeResolution, getShortTime
    ) where

import Control.Concurrent.Extra
import System.Time.Extra
import System.IO.Unsafe
import System.IO.Extra
import System.FilePath
import System.Info.Extra
import System.Console.ANSI
import Data.Version.Extra
import Data.List.Extra
import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
import System.IO.Error
import System.Directory
import Control.Exception
import Control.Monad.Extra
import Control.Applicative
import Prelude


-- | Flags that are required for ghcid to function and are supported on all GHC versions
ghciFlagsRequired :: [String]
ghciFlagsRequired :: [String]
ghciFlagsRequired =
    [String
"-fno-break-on-exception",String
"-fno-break-on-error" -- see #43
    ,String
"-v1" -- see #110
    ]

-- | Flags that are required for ghcid to function, but are only supported on some GHC versions
ghciFlagsRequiredVersioned :: [String]
ghciFlagsRequiredVersioned :: [String]
ghciFlagsRequiredVersioned =
    [String
"-fno-hide-source-paths" -- see #132, GHC 8.2 and above
    ]

-- | Flags that make ghcid work better and are supported on all GHC versions
ghciFlagsUseful :: [String]
ghciFlagsUseful :: [String]
ghciFlagsUseful =
    [String
"-ferror-spans" -- see #148
    ,String
"-j" -- see #153, GHC 7.8 and above, but that's all I support anyway
    ]

-- | Flags that make ghcid work better, but are only supported on some GHC versions
ghciFlagsUsefulVersioned :: [String]
ghciFlagsUsefulVersioned :: [String]
ghciFlagsUsefulVersioned =
    [String
"-fdiagnostics-color=always" -- see #144, GHC 8.2 and above
    ]


-- | Drop a prefix from a list, no matter how many times that prefix is present
dropPrefixRepeatedly :: Eq a => [a] -> [a] -> [a]
dropPrefixRepeatedly :: forall a. Eq a => [a] -> [a] -> [a]
dropPrefixRepeatedly []  [a]
s = [a]
s
dropPrefixRepeatedly [a]
pre [a]
s = [a] -> ([a] -> [a]) -> Maybe [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a]
s ([a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
dropPrefixRepeatedly [a]
pre) (Maybe [a] -> [a]) -> Maybe [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
pre [a]
s


{-# NOINLINE lock #-}
lock :: Lock
lock :: Lock
lock = IO Lock -> Lock
forall a. IO a -> a
unsafePerformIO IO Lock
newLock

-- | Output a string with some level of locking
outStr :: String -> IO ()
outStr :: String -> IO ()
outStr String
msg = do
    Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
msg
    Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
msg

outStrLn :: String -> IO ()
outStrLn :: String -> IO ()
outStrLn String
xs = String -> IO ()
outStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- | Ignore all exceptions coming from an action
ignored :: IO () -> IO ()
ignored :: IO () -> IO ()
ignored IO ()
act = do
    bar <- IO (Barrier ())
forall a. IO (Barrier a)
newBarrier
    forkFinally act $ const $ signalBarrier bar ()
    waitBarrier bar

-- | The message to show when no errors have been reported
allGoodMessage :: String
allGoodMessage :: String
allGoodMessage = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green] String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"All good" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode []

-- | Given a 'FilePath' return either 'Nothing' (file does not exist) or 'Just' (the modification time)
getModTime :: FilePath -> IO (Maybe UTCTime)
getModTime :: String -> IO (Maybe UTCTime)
getModTime String
file = (IOError -> Maybe ())
-> (() -> IO (Maybe UTCTime))
-> IO (Maybe UTCTime)
-> IO (Maybe UTCTime)
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
    (\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
    (\()
_ -> Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing)
    (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO UTCTime
getModificationTime String
file)

-- | Returns both the amount left (could have been taken more) and the list
takeRemainder :: Int -> [a] -> (Int, [a])
takeRemainder :: forall a. Int -> [a] -> (Int, [a])
takeRemainder Int
n [a]
xs = let ys :: [a]
ys = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n [a]
xs in (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys, [a]
ys)

-- | Get the current time in the current timezone in HH:MM:SS format
getShortTime :: IO String
getShortTime :: IO String
getShortTime = TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%H:%M:%S" (ZonedTime -> String) -> IO ZonedTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime


-- | Get the smallest difference that can be reported by two modification times
getModTimeResolution :: IO Seconds
getModTimeResolution :: IO Seconds
getModTimeResolution = Seconds -> IO Seconds
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seconds
getModTimeResolutionCache

{-# NOINLINE getModTimeResolutionCache #-}
-- Cache the result so only computed once per run
getModTimeResolutionCache :: Seconds
getModTimeResolutionCache :: Seconds
getModTimeResolutionCache = IO Seconds -> Seconds
forall a. IO a -> a
unsafePerformIO (IO Seconds -> Seconds) -> IO Seconds -> Seconds
forall a b. (a -> b) -> a -> b
$ (String -> IO Seconds) -> IO Seconds
forall a. (String -> IO a) -> IO a
withTempDir ((String -> IO Seconds) -> IO Seconds)
-> (String -> IO Seconds) -> IO Seconds
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    let file :: String
file = String
dir String -> String -> String
</> String
"calibrate.txt"

    -- with 10 measurements can get a bit slow, see Shake issue tracker #451
    -- if it rounds to a second then 1st will be a fraction, but 2nd will be full second
    mtime <- ([Seconds] -> Seconds) -> IO [Seconds] -> IO Seconds
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Seconds] -> Seconds
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (IO [Seconds] -> IO Seconds) -> IO [Seconds] -> IO Seconds
forall a b. (a -> b) -> a -> b
$ [Integer] -> (Integer -> IO Seconds) -> IO [Seconds]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Integer
1..Integer
3] ((Integer -> IO Seconds) -> IO [Seconds])
-> (Integer -> IO Seconds) -> IO [Seconds]
forall a b. (a -> b) -> a -> b
$ \Integer
i -> ((Seconds, ()) -> Seconds) -> IO (Seconds, ()) -> IO Seconds
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seconds, ()) -> Seconds
forall a b. (a, b) -> a
fst (IO (Seconds, ()) -> IO Seconds) -> IO (Seconds, ()) -> IO Seconds
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO () -> IO (Seconds, ())) -> IO () -> IO (Seconds, ())
forall a b. (a -> b) -> a -> b
$ do
        String -> String -> IO ()
writeFile String
file (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i
        t1 <- String -> IO UTCTime
getModificationTime String
file
        flip loopM 0 $ \Integer
j -> do
            String -> String -> IO ()
writeFile String
file (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (Integer, Integer) -> String
forall a. Show a => a -> String
show (Integer
i,Integer
j)
            t2 <- String -> IO UTCTime
getModificationTime String
file
            pure $ if t1 == t2 then Left $ j+1 else Right ()

    -- GHC 7.6 and below only have 1 sec resolution timestamps
    mtime <- pure $ if compilerVersion < makeVersion [7,8] then max mtime 1 else mtime

    putStrLn $ "Longest file modification time lag was " ++ show (ceiling (mtime * 1000)) ++ "ms"
    -- add a little bit of safety, but if it's really quick, don't make it that much slower
    pure $ mtime + min 0.1 mtime