{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module AutoInstrument.Internal.Config
  ( Config(..)
  , ConfigCache(..)
  , Target(..)
  , getConfigCache
  , getConfigFilePath
  , defaultConfigFile
  , TargetCon(..)
  , ConstraintSet
  ) where

import           Control.Applicative ((<|>))
import           Control.Concurrent.MVar
import           Data.IORef
import           Data.Maybe
import           Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text.IO as T
import           Data.Time
import qualified System.Directory as Dir
import           System.IO.Unsafe (unsafePerformIO)
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
import qualified Text.Parsec.String as P
import qualified Toml.Schema.FromValue as Toml
import qualified Toml

import qualified AutoInstrument.Internal.GhcFacade as Ghc

data ConfigCache = MkConfigCache
  { ConfigCache -> UTCTime
timestamp :: !UTCTime
  , ConfigCache -> Config
getConfig :: !Config
  , ConfigCache -> Fingerprint
fingerprint :: !Ghc.Fingerprint
  }

configCache :: IORef (Maybe ConfigCache)
configCache :: IORef (Maybe ConfigCache)
configCache = IO (IORef (Maybe ConfigCache)) -> IORef (Maybe ConfigCache)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe ConfigCache)) -> IORef (Maybe ConfigCache))
-> IO (IORef (Maybe ConfigCache)) -> IORef (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ Maybe ConfigCache -> IO (IORef (Maybe ConfigCache))
forall a. a -> IO (IORef a)
newIORef Maybe ConfigCache
forall a. Maybe a
Nothing
{-# NOINLINE configCache #-}

-- | Used to ensure that the config file is only read by one thread when the
-- cache expires or needs to be initialized.
semaphore :: MVar ()
semaphore :: MVar ()
semaphore = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
{-# NOINLINE semaphore #-}

-- Cache expires after 20 seconds
cacheDuration :: NominalDiffTime
cacheDuration :: NominalDiffTime
cacheDuration = NominalDiffTime
20

data Config = MkConfig
  { Config -> [Target]
targets :: [Target]
  , Config -> [Target]
exclusions :: [Target]
  }

data Target
  = Constructor TargetCon
  | Constraints ConstraintSet

data TargetCon
  = TyVar String
  | WC
  | App TargetCon TargetCon
  | Unit
  | Tuple [TargetCon]
  deriving (Int -> TargetCon -> ShowS
[TargetCon] -> ShowS
TargetCon -> String
(Int -> TargetCon -> ShowS)
-> (TargetCon -> String)
-> ([TargetCon] -> ShowS)
-> Show TargetCon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TargetCon -> ShowS
showsPrec :: Int -> TargetCon -> ShowS
$cshow :: TargetCon -> String
show :: TargetCon -> String
$cshowList :: [TargetCon] -> ShowS
showList :: [TargetCon] -> ShowS
Show, TargetCon -> TargetCon -> Bool
(TargetCon -> TargetCon -> Bool)
-> (TargetCon -> TargetCon -> Bool) -> Eq TargetCon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetCon -> TargetCon -> Bool
== :: TargetCon -> TargetCon -> Bool
$c/= :: TargetCon -> TargetCon -> Bool
/= :: TargetCon -> TargetCon -> Bool
Eq, Eq TargetCon
Eq TargetCon =>
(TargetCon -> TargetCon -> Ordering)
-> (TargetCon -> TargetCon -> Bool)
-> (TargetCon -> TargetCon -> Bool)
-> (TargetCon -> TargetCon -> Bool)
-> (TargetCon -> TargetCon -> Bool)
-> (TargetCon -> TargetCon -> TargetCon)
-> (TargetCon -> TargetCon -> TargetCon)
-> Ord TargetCon
TargetCon -> TargetCon -> Bool
TargetCon -> TargetCon -> Ordering
TargetCon -> TargetCon -> TargetCon
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TargetCon -> TargetCon -> Ordering
compare :: TargetCon -> TargetCon -> Ordering
$c< :: TargetCon -> TargetCon -> Bool
< :: TargetCon -> TargetCon -> Bool
$c<= :: TargetCon -> TargetCon -> Bool
<= :: TargetCon -> TargetCon -> Bool
$c> :: TargetCon -> TargetCon -> Bool
> :: TargetCon -> TargetCon -> Bool
$c>= :: TargetCon -> TargetCon -> Bool
>= :: TargetCon -> TargetCon -> Bool
$cmax :: TargetCon -> TargetCon -> TargetCon
max :: TargetCon -> TargetCon -> TargetCon
$cmin :: TargetCon -> TargetCon -> TargetCon
min :: TargetCon -> TargetCon -> TargetCon
Ord)

skipSpaces :: P.Parser ()
skipSpaces :: Parser ()
skipSpaces = ParsecT String () Identity Char -> Parser ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
P.skipMany ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.space

targetParser :: P.Parser TargetCon
targetParser :: Parser TargetCon
targetParser = Parser TargetCon
appP
  where
    appP :: Parser TargetCon
appP = Parser TargetCon
-> ParsecT String () Identity (TargetCon -> TargetCon -> TargetCon)
-> Parser TargetCon
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
P.chainl1 (Parser TargetCon -> Parser TargetCon
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try Parser TargetCon
unitP Parser TargetCon -> Parser TargetCon -> Parser TargetCon
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TargetCon
varP Parser TargetCon -> Parser TargetCon -> Parser TargetCon
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TargetCon
parenP) ((TargetCon -> TargetCon -> TargetCon)
-> ParsecT String () Identity (TargetCon -> TargetCon -> TargetCon)
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TargetCon -> TargetCon -> TargetCon
App) Parser TargetCon -> Parser () -> Parser TargetCon
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces
    unitP :: Parser TargetCon
unitP = TargetCon
Unit TargetCon -> ParsecT String () Identity String -> Parser TargetCon
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"()" Parser TargetCon -> Parser () -> Parser TargetCon
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces
    varP :: Parser TargetCon
varP = do
      String
v <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy ((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
' ', Char
'(', Char
')', Char
',']) ParsecT String () Identity String
-> Parser () -> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces
      case String
v of
        String
"_" -> TargetCon -> Parser TargetCon
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TargetCon
WC
        String
_ -> TargetCon -> Parser TargetCon
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TargetCon -> Parser TargetCon) -> TargetCon -> Parser TargetCon
forall a b. (a -> b) -> a -> b
$ String -> TargetCon
TyVar String
v
    parenP :: Parser TargetCon
parenP = do
      [TargetCon]
inParens <-
        ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity [TargetCon]
-> ParsecT String () Identity [TargetCon]
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
P.between (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'(' ParsecT String () Identity Char
-> Parser () -> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces) (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
')')
          (Parser TargetCon
-> ParsecT String () Identity Char
-> ParsecT String () Identity [TargetCon]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
P.sepBy1 Parser TargetCon
targetParser (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
',' ParsecT String () Identity Char
-> Parser () -> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces))
          ParsecT String () Identity [TargetCon]
-> Parser () -> ParsecT String () Identity [TargetCon]
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces
      case [TargetCon]
inParens of
        [TargetCon
t] -> TargetCon -> Parser TargetCon
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TargetCon
t
        [TargetCon]
_ -> TargetCon -> Parser TargetCon
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TargetCon -> Parser TargetCon) -> TargetCon -> Parser TargetCon
forall a b. (a -> b) -> a -> b
$ [TargetCon] -> TargetCon
Tuple [TargetCon]
inParens

type ConstraintSet = Set TargetCon

instance Toml.FromValue Config where
  fromValue :: forall l. Value' l -> Matcher l Config
fromValue = ParseTable l Config -> Value' l -> Matcher l Config
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l Config -> Value' l -> Matcher l Config)
-> ParseTable l Config -> Value' l -> Matcher l Config
forall a b. (a -> b) -> a -> b
$
    [Target] -> [Target] -> Config
MkConfig
      ([Target] -> [Target] -> Config)
-> ParseTable l [Target] -> ParseTable l ([Target] -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParseTable l [Target]
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"targets"
      ParseTable l ([Target] -> Config)
-> ParseTable l [Target] -> ParseTable l Config
forall a b.
ParseTable l (a -> b) -> ParseTable l a -> ParseTable l b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Target] -> Maybe [Target] -> [Target]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Target] -> [Target])
-> ParseTable l (Maybe [Target]) -> ParseTable l [Target]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParseTable l (Maybe [Target])
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"exclusions")

instance Toml.FromValue Target where
  fromValue :: forall l. Value' l -> Matcher l Target
fromValue = ParseTable l Target -> Value' l -> Matcher l Target
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l Target -> Value' l -> Matcher l Target)
-> ParseTable l Target -> Value' l -> Matcher l Target
forall a b. (a -> b) -> a -> b
$ do
    String
tag <- Text -> ParseTable l String
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"type"
    case String
tag of
      String
"constructor" -> do
        String
value <- Text -> ParseTable l String
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"value"
        case Parser TargetCon -> String -> String -> Either ParseError TargetCon
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse (Parser ()
skipSpaces Parser () -> Parser TargetCon -> Parser TargetCon
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TargetCon
targetParser Parser TargetCon -> Parser () -> Parser TargetCon
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof) String
"" String
value of
          Right TargetCon
target -> Target -> ParseTable l Target
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Target -> ParseTable l Target) -> Target -> ParseTable l Target
forall a b. (a -> b) -> a -> b
$ TargetCon -> Target
Constructor TargetCon
target
          Left ParseError
err -> String -> ParseTable l Target
forall a. String -> ParseTable l a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParseTable l Target) -> String -> ParseTable l Target
forall a b. (a -> b) -> a -> b
$ ParseError -> String
showParsecError ParseError
err
      String
"constraints" -> do
        [String]
value <- Text -> ParseTable l [String]
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"value"
        let parsePred :: String -> f TargetCon
parsePred String
v =
              case Parser TargetCon -> String -> String -> Either ParseError TargetCon
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse (Parser ()
skipSpaces Parser () -> Parser TargetCon -> Parser TargetCon
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TargetCon
targetParser Parser TargetCon -> Parser () -> Parser TargetCon
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof) String
"" String
v of
                Right TargetCon
target -> TargetCon -> f TargetCon
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TargetCon
target
                Left ParseError
err -> String -> f TargetCon
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f TargetCon) -> String -> f TargetCon
forall a b. (a -> b) -> a -> b
$ ParseError -> String
showParsecError ParseError
err
        ConstraintSet -> Target
Constraints (ConstraintSet -> Target)
-> ([TargetCon] -> ConstraintSet) -> [TargetCon] -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TargetCon] -> ConstraintSet
forall a. Ord a => [a] -> Set a
S.fromList ([TargetCon] -> Target)
-> ParseTable l [TargetCon] -> ParseTable l Target
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ParseTable l TargetCon)
-> [String] -> ParseTable l [TargetCon]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> ParseTable l TargetCon
forall {f :: * -> *}. MonadFail f => String -> f TargetCon
parsePred [String]
value
      String
_ -> String -> ParseTable l Target
forall a. String -> ParseTable l a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParseTable l Target) -> String -> ParseTable l Target
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized targed type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tag

-- | Doesn't show the source location
showParsecError :: P.ParseError -> String
showParsecError :: ParseError -> String
showParsecError
  = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1
  ShowS -> (ParseError -> String) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> String -> String -> String -> String -> [Message] -> String
P.showErrorMessages String
"or" String
"unknown parse error" String
"expecting" String
"unexpected" String
"end of input"
  ([Message] -> String)
-> (ParseError -> [Message]) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Message]
P.errorMessages

getConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)
getConfigCache :: [String] -> IO (Maybe ConfigCache)
getConfigCache [String]
opts = do
  Maybe ConfigCache
mCached <- IORef (Maybe ConfigCache) -> IO (Maybe ConfigCache)
forall a. IORef a -> IO a
readIORef IORef (Maybe ConfigCache)
configCache
  case Maybe ConfigCache
mCached of
    Maybe ConfigCache
Nothing -> [String] -> IO (Maybe ConfigCache)
getConfigOrRefresh [String]
opts
    Just ConfigCache
cached -> do
      Bool
expired <- ConfigCache -> IO Bool
isCacheExpired ConfigCache
cached
      if Bool
expired
      then [String] -> IO (Maybe ConfigCache)
getConfigOrRefresh [String]
opts
      else Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ConfigCache -> IO (Maybe ConfigCache))
-> Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just ConfigCache
cached

-- | This blocks on the MVar to ensure that the file is only read by one thread when necessary.
-- contention for the MVar only occurs when the cache expires or hasn't been initialized.
getConfigOrRefresh :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)
getConfigOrRefresh :: [String] -> IO (Maybe ConfigCache)
getConfigOrRefresh [String]
opts = do
  MVar () -> (() -> IO (Maybe ConfigCache)) -> IO (Maybe ConfigCache)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
semaphore ((() -> IO (Maybe ConfigCache)) -> IO (Maybe ConfigCache))
-> (() -> IO (Maybe ConfigCache)) -> IO (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    Maybe ConfigCache
mCached <- IORef (Maybe ConfigCache) -> IO (Maybe ConfigCache)
forall a. IORef a -> IO a
readIORef IORef (Maybe ConfigCache)
configCache
    case Maybe ConfigCache
mCached of
      Maybe ConfigCache
Nothing -> [String] -> IO (Maybe ConfigCache)
refreshConfigCache [String]
opts
      Just ConfigCache
existing -> do
        Bool
expired <- ConfigCache -> IO Bool
isCacheExpired ConfigCache
existing
        if Bool
expired
        then [String] -> IO (Maybe ConfigCache)
refreshConfigCache [String]
opts
        else Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ConfigCache -> IO (Maybe ConfigCache))
-> Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just ConfigCache
existing

isCacheExpired :: ConfigCache -> IO Bool
isCacheExpired :: ConfigCache -> IO Bool
isCacheExpired ConfigCache
cached = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let diff :: NominalDiffTime
diff = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now (UTCTime -> NominalDiffTime) -> UTCTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ConfigCache -> UTCTime
timestamp ConfigCache
cached
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
cacheDuration

refreshConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)
refreshConfigCache :: [String] -> IO (Maybe ConfigCache)
refreshConfigCache [String]
opts = do
  Maybe ConfigCache
newCache <- [String] -> IO (Maybe ConfigCache)
mkConfigCache [String]
opts
  IORef (Maybe ConfigCache) -> Maybe ConfigCache -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe ConfigCache)
configCache Maybe ConfigCache
newCache
  Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConfigCache
newCache

mkConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)
mkConfigCache :: [String] -> IO (Maybe ConfigCache)
mkConfigCache [String]
opts = do
  let cfgFile :: String
cfgFile = [String] -> String
getConfigFilePath [String]
opts
  Bool
exists <- String -> IO Bool
Dir.doesFileExist String
cfgFile
  if Bool
exists
     then do
       Result String Config
result <- Text -> Result String Config
forall a. FromValue a => Text -> Result String a
Toml.decode (Text -> Result String Config)
-> IO Text -> IO (Result String Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
cfgFile
       case Result String Config
result of
         Toml.Success [String]
_ Config
config -> do
           UTCTime
now <- IO UTCTime
getCurrentTime
           Fingerprint
fp <- String -> IO Fingerprint
Ghc.getFileHash String
cfgFile
           Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ConfigCache -> IO (Maybe ConfigCache))
-> Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just MkConfigCache
             { timestamp :: UTCTime
timestamp = UTCTime
now
             , getConfig :: Config
getConfig = Config
config
             , fingerprint :: Fingerprint
fingerprint = Fingerprint
fp
             }
         Toml.Failure [String]
errs -> do
           String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"================================================================================"
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"Failed to parse auto instrument config file:"
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
errs
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"================================================================================"]
           Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConfigCache
forall a. Maybe a
Nothing
     else do
       Maybe ConfigCache -> IO (Maybe ConfigCache)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConfigCache
forall a. Maybe a
Nothing

getConfigFilePath :: [Ghc.CommandLineOption] -> FilePath
getConfigFilePath :: [String] -> String
getConfigFilePath (String
opt : [String]
_) = String
opt
getConfigFilePath [] = String
defaultConfigFile

defaultConfigFile :: FilePath
defaultConfigFile :: String
defaultConfigFile = String
"auto-instrument-config.toml"