-- 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@.

--   See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.

type family RuleResult key -- = value


action :: Action a -> Rules ()
action :: Action a -> Rules ()
action Action a
x = do
    IORef [Action ()]
ref <- ReaderT SRules IO (IORef [Action ()]) -> Rules (IORef [Action ()])
forall a. ReaderT SRules IO a -> Rules a
Rules (ReaderT SRules IO (IORef [Action ()])
 -> Rules (IORef [Action ()]))
-> ReaderT SRules IO (IORef [Action ()])
-> Rules (IORef [Action ()])
forall a b. (a -> b) -> a -> b
$ (SRules -> IORef [Action ()])
-> ReaderT SRules IO (IORef [Action ()])
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SRules -> IORef [Action ()]
rulesActions
    IO () -> Rules ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ IORef [Action ()] -> ([Action ()] -> [Action ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Action ()]
ref (Action a -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Action a
xAction () -> [Action ()] -> [Action ()]
forall 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 :: (key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule key -> Maybe ByteString -> RunMode -> Action (RunResult value)
f = do
    IORef TheRules
ref <- ReaderT SRules IO (IORef TheRules) -> Rules (IORef TheRules)
forall a. ReaderT SRules IO a -> Rules a
Rules (ReaderT SRules IO (IORef TheRules) -> Rules (IORef TheRules))
-> ReaderT SRules IO (IORef TheRules) -> Rules (IORef TheRules)
forall a b. (a -> b) -> a -> b
$ (SRules -> IORef TheRules) -> ReaderT SRules IO (IORef TheRules)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SRules -> IORef TheRules
rulesMap
    IO () -> Rules ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ IORef TheRules -> (TheRules -> TheRules) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef TheRules
ref ((TheRules -> TheRules) -> IO ())
-> (TheRules -> TheRules) -> IO ()
forall a b. (a -> b) -> a -> b
$ TypeRep -> Dynamic -> TheRules -> TheRules
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (Proxy key -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy key
forall k (t :: k). Proxy t
Proxy :: Proxy key)) ((Key -> Maybe ByteString -> RunMode -> Action (RunResult Value))
-> Dynamic
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 (Maybe key -> key
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe key -> key) -> Maybe key -> key
forall a b. (a -> b) -> a -> b
$ a -> Maybe key
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a :: key) Maybe ByteString
b RunMode
c
            RunResult value
v <- IO (RunResult value) -> Action (RunResult value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RunResult value) -> Action (RunResult value))
-> IO (RunResult value) -> Action (RunResult value)
forall a b. (a -> b) -> a -> b
$ RunResult value -> IO (RunResult value)
forall a. a -> IO a
evaluate RunResult value
v
            RunResult Value -> Action (RunResult Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Value -> Action (RunResult Value))
-> RunResult Value -> Action (RunResult Value)
forall a b. (a -> b) -> a -> b
$ Dynamic -> Value
Value (Dynamic -> Value) -> (value -> Dynamic) -> value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. value -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (value -> Value) -> RunResult value -> RunResult Value
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 TypeRep -> TheRules -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
t) TheRules
rules of
    Maybe Dynamic
Nothing -> IO (RunResult Value) -> Action (RunResult Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RunResult Value) -> Action (RunResult Value))
-> IO (RunResult Value) -> Action (RunResult Value)
forall a b. (a -> b) -> a -> b
$ String -> IO (RunResult Value)
forall a. HasCallStack => String -> IO a
errorIO String
"Could not find key"
    Just Dynamic
x  -> Dynamic
-> Key -> Maybe ByteString -> RunMode -> Action (RunResult Value)
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 <- [Action ()] -> IO (IORef [Action ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef TheRules
rulesMap <- TheRules -> IO (IORef TheRules)
forall a. a -> IO (IORef a)
newIORef TheRules
forall k v. HashMap k v
Map.empty
    ReaderT SRules IO () -> SRules -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT SRules IO ()
rules SRules :: Dynamic -> IORef [Action ()] -> IORef TheRules -> SRules
SRules{Dynamic
IORef [Action ()]
IORef TheRules
rulesExtra :: Dynamic
rulesMap :: IORef TheRules
rulesActions :: IORef [Action ()]
rulesExtra :: Dynamic
rulesMap :: IORef TheRules
rulesActions :: IORef [Action ()]
..}
    (,) (TheRules -> [Action ()] -> (TheRules, [Action ()]))
-> IO TheRules -> IO ([Action ()] -> (TheRules, [Action ()]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef TheRules -> IO TheRules
forall a. IORef a -> IO a
readIORef IORef TheRules
rulesMap IO ([Action ()] -> (TheRules, [Action ()]))
-> IO [Action ()] -> IO (TheRules, [Action ()])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef [Action ()] -> IO [Action ()]
forall a. IORef a -> IO a
readIORef IORef [Action ()]
rulesActions