{-# 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 as T
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 as Toml
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
      ConstructorType -> Constructor <$> Toml.reqKey "value"
      ConstraintsType -> Constraints . S.fromList <$> Toml.reqKey "value"

data TargetType = ConstructorType | ConstraintsType

instance Toml.FromValue TargetType where
  fromValue (Toml.Text' _ tag)
    | tag == "constructor" = pure ConstructorType
    | tag == "constraints" = pure ConstraintsType
  fromValue v = Toml.failAt (Toml.valueAnn v) "must be 'constructor' or 'constraints'"

instance Toml.FromValue TargetCon where
  fromValue (Toml.Text' a v) =
    case P.parse (skipSpaces *> targetParser <* P.eof) "" (T.unpack v) of
      Right target -> pure target
      Left err -> Toml.failAt a (showParsecError err)
  fromValue v = Toml.typeError "string" v

-- | 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"