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
ghciFlagsRequired :: [String]
ghciFlagsRequired :: [String]
ghciFlagsRequired =
[String
"-fno-break-on-exception",String
"-fno-break-on-error"
,String
"-v1"
]
ghciFlagsRequiredVersioned :: [String]
ghciFlagsRequiredVersioned :: [String]
ghciFlagsRequiredVersioned =
[String
"-fno-hide-source-paths"
]
ghciFlagsUseful :: [String]
ghciFlagsUseful :: [String]
ghciFlagsUseful =
[String
"-ferror-spans"
,String
"-j"
]
ghciFlagsUsefulVersioned :: [String]
ghciFlagsUsefulVersioned :: [String]
ghciFlagsUsefulVersioned =
[String
"-fdiagnostics-color=always"
]
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
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"
ignored :: IO () -> IO ()
ignored :: IO () -> IO ()
ignored IO ()
act = do
Barrier ()
bar <- IO (Barrier ())
forall a. IO (Barrier a)
newBarrier
IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally IO ()
act ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> Either SomeException () -> IO ()
forall a b. a -> b -> a
const (IO () -> Either SomeException () -> IO ())
-> IO () -> Either SomeException () -> IO ()
forall a b. (a -> b) -> a -> b
$ Barrier () -> () -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier ()
bar ()
Barrier () -> IO ()
forall a. Barrier a -> IO a
waitBarrier Barrier ()
bar
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 []
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)
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)
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
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 #-}
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"
Seconds
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
UTCTime
t1 <- String -> IO UTCTime
getModificationTime String
file
((Integer -> IO (Either Integer ())) -> Integer -> IO ())
-> Integer -> (Integer -> IO (Either Integer ())) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Integer -> IO (Either Integer ())) -> Integer -> IO ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Either a b)) -> a -> m b
loopM Integer
0 ((Integer -> IO (Either Integer ())) -> IO ())
-> (Integer -> IO (Either Integer ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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)
UTCTime
t2 <- String -> IO UTCTime
getModificationTime String
file
Either Integer () -> IO (Either Integer ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Integer () -> IO (Either Integer ()))
-> Either Integer () -> IO (Either Integer ())
forall a b. (a -> b) -> a -> b
$ if UTCTime
t1 UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
t2 then Integer -> Either Integer ()
forall a b. a -> Either a b
Left (Integer -> Either Integer ()) -> Integer -> Either Integer ()
forall a b. (a -> b) -> a -> b
$ Integer
jInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1 else () -> Either Integer ()
forall a b. b -> Either a b
Right ()
Seconds
mtime <- Seconds -> IO Seconds
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seconds -> IO Seconds) -> Seconds -> IO Seconds
forall a b. (a -> b) -> a -> b
$ if Version
compilerVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
makeVersion [Int
7,Int
8] then Seconds -> Seconds -> Seconds
forall a. Ord a => a -> a -> a
max Seconds
mtime Seconds
1 else Seconds
mtime
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Longest file modification time lag was " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Seconds -> Integer
forall b. Integral b => Seconds -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Seconds
mtime Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
* Seconds
1000)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ms"
Seconds -> IO Seconds
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seconds -> IO Seconds) -> Seconds -> IO Seconds
forall a b. (a -> b) -> a -> b
$ Seconds
mtime Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
+ Seconds -> Seconds -> Seconds
forall a. Ord a => a -> a -> a
min Seconds
0.1 Seconds
mtime