-- We deliberately want to ensure the function we add to the rule database
-- has the constraints we need on it when we get it out.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Development.IDE.Graph.Internal.Rules where

import           Control.Exception.Extra
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader
import qualified Data.ByteString                      as BS
import           Data.Dynamic
import qualified Data.HashMap.Strict                  as Map
import           Data.IORef
import           Data.Maybe
import           Data.Typeable
import           Development.IDE.Graph.Classes
import           Development.IDE.Graph.Internal.Types

-- | The type mapping between the @key@ or a rule and the resulting @value@.
type family RuleResult key -- = value

action :: Action a -> Rules ()
action :: forall a. Action a -> Rules ()
action Action a
x = do
    IORef [Action ()]
ref <- forall a. ReaderT SRules IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SRules -> IORef [Action ()]
rulesActions
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Action ()]
ref (forall (f :: * -> *) a. Functor f => f a -> f ()
void Action a
xforall a. a -> [a] -> [a]
:)

addRule
    :: forall key value .
       (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)
    => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value))
    -> Rules ()
addRule :: forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule key -> Maybe ByteString -> RunMode -> Action (RunResult value)
f = do
    IORef TheRules
ref <- forall a. ReaderT SRules IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SRules -> IORef TheRules
rulesMap
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef TheRules
ref forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy key)) (forall a. Typeable a => a -> Dynamic
toDyn Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
f2)
    where
        f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
        f2 :: Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
f2 (Key a
a) Maybe ByteString
b RunMode
c = do
            RunResult value
v <- key -> Maybe ByteString -> RunMode -> Action (RunResult value)
f (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a :: key) Maybe ByteString
b RunMode
c
            RunResult value
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate RunResult value
v
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dynamic -> Value
Value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> Dynamic
toDyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunResult value
v

runRule
    :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
runRule :: TheRules
-> Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
runRule TheRules
rules key :: Key
key@(Key a
t) Maybe ByteString
bs RunMode
mode = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (forall a. Typeable a => a -> TypeRep
typeOf a
t) TheRules
rules of
    Maybe Dynamic
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"Could not find key: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key
key
    Just Dynamic
x  -> forall a. Typeable a => Dynamic -> a
unwrapDynamic Dynamic
x Key
key Maybe ByteString
bs RunMode
mode

runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
runRules Dynamic
rulesExtra (Rules ReaderT SRules IO ()
rules) = do
    IORef [Action ()]
rulesActions <- forall a. a -> IO (IORef a)
newIORef []
    IORef TheRules
rulesMap <- forall a. a -> IO (IORef a)
newIORef forall k v. HashMap k v
Map.empty
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT SRules IO ()
rules SRules{Dynamic
IORef [Action ()]
IORef TheRules
rulesExtra :: Dynamic
rulesMap :: IORef TheRules
rulesActions :: IORef [Action ()]
rulesExtra :: Dynamic
rulesMap :: IORef TheRules
rulesActions :: IORef [Action ()]
..}
    (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef TheRules
rulesMap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IORef a -> IO a
readIORef IORef [Action ()]
rulesActions