{-# 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 { timestamp :: !UTCTime , getConfig :: !Config , fingerprint :: !Ghc.Fingerprint } configCache :: IORef (Maybe ConfigCache) configCache = unsafePerformIO $ newIORef 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 = unsafePerformIO $ newMVar () {-# NOINLINE semaphore #-} -- Cache expires after 20 seconds cacheDuration :: NominalDiffTime cacheDuration = 20 data Config = MkConfig { targets :: [Target] , exclusions :: [Target] } data Target = Constructor TargetCon | Constraints ConstraintSet data TargetCon = TyVar String | WC | App TargetCon TargetCon | Unit | Tuple [TargetCon] deriving (Show, Eq, Ord) skipSpaces :: P.Parser () skipSpaces = P.skipMany P.space targetParser :: P.Parser TargetCon targetParser = appP where appP = P.chainl1 (P.try unitP <|> varP <|> parenP) (pure App) <* skipSpaces unitP = Unit <$ P.string "()" <* skipSpaces varP = do v <- P.many1 (P.satisfy $ \c -> c `notElem` [' ', '(', ')', ',']) <* skipSpaces case v of "_" -> pure WC _ -> pure $ TyVar v parenP = do inParens <- P.between (P.char '(' <* skipSpaces) (P.char ')') (P.sepBy1 targetParser (P.char ',' <* skipSpaces)) <* skipSpaces case inParens of [t] -> pure t _ -> pure $ Tuple inParens type ConstraintSet = Set TargetCon instance Toml.FromValue Config where fromValue = Toml.parseTableFromValue $ MkConfig <$> Toml.reqKey "targets" <*> (fromMaybe [] <$> Toml.optKey "exclusions") instance Toml.FromValue Target where fromValue = Toml.parseTableFromValue $ do tag <- Toml.reqKey "type" case tag of "constructor" -> do value <- Toml.reqKey "value" case P.parse (skipSpaces *> targetParser <* P.eof) "" value of Right target -> pure $ Constructor target Left err -> fail $ showParsecError err "constraints" -> do value <- Toml.reqKey "value" let parsePred v = case P.parse (skipSpaces *> targetParser <* P.eof) "" v of Right target -> pure target Left err -> fail $ showParsecError err Constraints . S.fromList <$> traverse parsePred value _ -> fail $ "Unrecognized targed type: " <> tag -- | Doesn't show the source location showParsecError :: P.ParseError -> String showParsecError = drop 1 . P.showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . P.errorMessages getConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache) getConfigCache opts = do mCached <- readIORef configCache case mCached of Nothing -> getConfigOrRefresh opts Just cached -> do expired <- isCacheExpired cached if expired then getConfigOrRefresh opts else pure $ Just 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 opts = do withMVar semaphore $ \_ -> do mCached <- readIORef configCache case mCached of Nothing -> refreshConfigCache opts Just existing -> do expired <- isCacheExpired existing if expired then refreshConfigCache opts else pure $ Just existing isCacheExpired :: ConfigCache -> IO Bool isCacheExpired cached = do now <- getCurrentTime let diff = diffUTCTime now $ timestamp cached pure $ diff >= cacheDuration refreshConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache) refreshConfigCache opts = do newCache <- mkConfigCache opts writeIORef configCache newCache pure newCache mkConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache) mkConfigCache opts = do let cfgFile = getConfigFilePath opts exists <- Dir.doesFileExist cfgFile if exists then do result <- Toml.decode <$> T.readFile cfgFile case result of Toml.Success _ config -> do now <- getCurrentTime fp <- Ghc.getFileHash cfgFile pure $ Just MkConfigCache { timestamp = now , getConfig = config , fingerprint = fp } Toml.Failure errs -> do putStr $ unlines $ "================================================================================" : "Failed to parse auto instrument config file:" : errs ++ ["================================================================================"] pure Nothing else do pure Nothing getConfigFilePath :: [Ghc.CommandLineOption] -> FilePath getConfigFilePath (opt : _) = opt getConfigFilePath [] = defaultConfigFile defaultConfigFile :: FilePath defaultConfigFile = "auto-instrument-config.toml"