{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
module Development.IDE.Types.Shake
  ( Q (..),
    A (..),
    Value (..),
    ValueWithDiagnostics (..),
    Values,
    Key (..),
    BadDependency (..),
    ShakeValue(..),
    currentValue,
    isBadDependency,
  toShakeValue,encodeShakeValue,decodeShakeValue)
where

import Control.DeepSeq
import Control.Exception
import qualified Data.ByteString.Char8 as BS
import Data.Dynamic
import Data.Hashable
import Data.HashMap.Strict
import Data.Vector (Vector)
import Data.Typeable
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.Shake (RuleResult, ShakeException (shakeExceptionInner))
import Development.Shake.Classes
import GHC.Generics
import Language.LSP.Types
import Development.IDE.Core.PositionMapping

data Value v
    = Succeeded TextDocumentVersion v
    | Stale (Maybe PositionDelta) TextDocumentVersion v
    | Failed Bool -- True if we already tried the persistent rule

    deriving (a -> Value b -> Value a
(a -> b) -> Value a -> Value b
(forall a b. (a -> b) -> Value a -> Value b)
-> (forall a b. a -> Value b -> Value a) -> Functor Value
forall a b. a -> Value b -> Value a
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Value b -> Value a
$c<$ :: forall a b. a -> Value b -> Value a
fmap :: (a -> b) -> Value a -> Value b
$cfmap :: forall a b. (a -> b) -> Value a -> Value b
Functor, (forall x. Value v -> Rep (Value v) x)
-> (forall x. Rep (Value v) x -> Value v) -> Generic (Value v)
forall x. Rep (Value v) x -> Value v
forall x. Value v -> Rep (Value v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v x. Rep (Value v) x -> Value v
forall v x. Value v -> Rep (Value v) x
$cto :: forall v x. Rep (Value v) x -> Value v
$cfrom :: forall v x. Value v -> Rep (Value v) x
Generic, Int -> Value v -> ShowS
[Value v] -> ShowS
Value v -> String
(Int -> Value v -> ShowS)
-> (Value v -> String) -> ([Value v] -> ShowS) -> Show (Value v)
forall v. Show v => Int -> Value v -> ShowS
forall v. Show v => [Value v] -> ShowS
forall v. Show v => Value v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value v] -> ShowS
$cshowList :: forall v. Show v => [Value v] -> ShowS
show :: Value v -> String
$cshow :: forall v. Show v => Value v -> String
showsPrec :: Int -> Value v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> Value v -> ShowS
Show)

instance NFData v => NFData (Value v)

-- | Convert a Value to a Maybe. This will only return `Just` for

-- up2date results not for stale values.

currentValue :: Value v -> Maybe v
currentValue :: Value v -> Maybe v
currentValue (Succeeded TextDocumentVersion
_ v
v) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
currentValue (Stale Maybe PositionDelta
_ TextDocumentVersion
_ v
_) = Maybe v
forall a. Maybe a
Nothing
currentValue Failed{} = Maybe v
forall a. Maybe a
Nothing

data ValueWithDiagnostics
  = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic)

-- | The state of the all values and diagnostics

type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics

-- | Key type

data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k

instance Show Key where
  show :: Key -> String
show (Key k
k) = k -> String
forall a. Show a => a -> String
show k
k

instance Eq Key where
    Key k
k1 == :: Key -> Key -> Bool
== Key k
k2 | Just k
k2' <- k -> Maybe k
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast k
k2 = k
k1 k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k2'
                     | Bool
otherwise = Bool
False

instance Hashable Key where
    hashWithSalt :: Int -> Key -> Int
hashWithSalt Int
salt (Key k
key) = Int -> (TypeRep, k) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (k -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf k
key, k
key)

-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency

--   which short-circuits the rest of the action

newtype BadDependency = BadDependency String deriving Int -> BadDependency -> ShowS
[BadDependency] -> ShowS
BadDependency -> String
(Int -> BadDependency -> ShowS)
-> (BadDependency -> String)
-> ([BadDependency] -> ShowS)
-> Show BadDependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadDependency] -> ShowS
$cshowList :: [BadDependency] -> ShowS
show :: BadDependency -> String
$cshow :: BadDependency -> String
showsPrec :: Int -> BadDependency -> ShowS
$cshowsPrec :: Int -> BadDependency -> ShowS
Show
instance Exception BadDependency

isBadDependency :: SomeException -> Bool
isBadDependency :: SomeException -> Bool
isBadDependency SomeException
x
    | Just (ShakeException
x :: ShakeException) <- SomeException -> Maybe ShakeException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x = SomeException -> Bool
isBadDependency (SomeException -> Bool) -> SomeException -> Bool
forall a b. (a -> b) -> a -> b
$ ShakeException -> SomeException
shakeExceptionInner ShakeException
x
    | Just (BadDependency
_ :: BadDependency) <- SomeException -> Maybe BadDependency
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x = Bool
True
    | Bool
otherwise = Bool
False

newtype Q k = Q (k, NormalizedFilePath)
    deriving newtype (Q k -> Q k -> Bool
(Q k -> Q k -> Bool) -> (Q k -> Q k -> Bool) -> Eq (Q k)
forall k. Eq k => Q k -> Q k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Q k -> Q k -> Bool
$c/= :: forall k. Eq k => Q k -> Q k -> Bool
== :: Q k -> Q k -> Bool
$c== :: forall k. Eq k => Q k -> Q k -> Bool
Eq, Int -> Q k -> Int
Q k -> Int
(Int -> Q k -> Int) -> (Q k -> Int) -> Hashable (Q k)
forall k. Hashable k => Int -> Q k -> Int
forall k. Hashable k => Q k -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Q k -> Int
$chash :: forall k. Hashable k => Q k -> Int
hashWithSalt :: Int -> Q k -> Int
$chashWithSalt :: forall k. Hashable k => Int -> Q k -> Int
Hashable, Q k -> ()
(Q k -> ()) -> NFData (Q k)
forall k. NFData k => Q k -> ()
forall a. (a -> ()) -> NFData a
rnf :: Q k -> ()
$crnf :: forall k. NFData k => Q k -> ()
NFData)

instance Binary k => Binary (Q k) where
    put :: Q k -> Put
put (Q (k
k, NormalizedFilePath
fp)) = (k, NormalizedFilePath) -> Put
forall t. Binary t => t -> Put
put (k
k, NormalizedFilePath
fp)
    get :: Get (Q k)
get = do
        (k
k, String
fp) <- Get (k, String)
forall t. Binary t => Get t
get
        -- The `get` implementation of NormalizedFilePath

        -- does not handle empty file paths so we

        -- need to handle this ourselves here.

        Q k -> Get (Q k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q (k
k, String -> NormalizedFilePath
toNormalizedFilePath' String
fp))

instance Show k => Show (Q k) where
    show :: Q k -> String
show (Q (k
k, NormalizedFilePath
file)) = k -> String
forall a. Show a => a -> String
show k
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file

-- | Invariant: the 'v' must be in normal form (fully evaluated).

--   Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

newtype A v = A (Value v)
    deriving Int -> A v -> ShowS
[A v] -> ShowS
A v -> String
(Int -> A v -> ShowS)
-> (A v -> String) -> ([A v] -> ShowS) -> Show (A v)
forall v. Show v => Int -> A v -> ShowS
forall v. Show v => [A v] -> ShowS
forall v. Show v => A v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [A v] -> ShowS
$cshowList :: forall v. Show v => [A v] -> ShowS
show :: A v -> String
$cshow :: forall v. Show v => A v -> String
showsPrec :: Int -> A v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> A v -> ShowS
Show

instance NFData (A v) where rnf :: A v -> ()
rnf (A Value v
v) = Value v
v Value v -> () -> ()
`seq` ()

-- In the Shake database we only store one type of key/result pairs,

-- namely Q (question) / A (answer).

type instance RuleResult (Q k) = A (RuleResult k)


toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
toShakeValue :: (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue = ShakeValue
-> (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShakeValue
ShakeNoCutoff

data ShakeValue
  = -- | This is what we use when we get Nothing from

    -- a rule.

    ShakeNoCutoff
  | -- | This is used both for `Failed`

    -- as well as `Succeeded`.

    ShakeResult !BS.ByteString
  | ShakeStale !BS.ByteString
  deriving ((forall x. ShakeValue -> Rep ShakeValue x)
-> (forall x. Rep ShakeValue x -> ShakeValue) -> Generic ShakeValue
forall x. Rep ShakeValue x -> ShakeValue
forall x. ShakeValue -> Rep ShakeValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShakeValue x -> ShakeValue
$cfrom :: forall x. ShakeValue -> Rep ShakeValue x
Generic, Int -> ShakeValue -> ShowS
[ShakeValue] -> ShowS
ShakeValue -> String
(Int -> ShakeValue -> ShowS)
-> (ShakeValue -> String)
-> ([ShakeValue] -> ShowS)
-> Show ShakeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShakeValue] -> ShowS
$cshowList :: [ShakeValue] -> ShowS
show :: ShakeValue -> String
$cshow :: ShakeValue -> String
showsPrec :: Int -> ShakeValue -> ShowS
$cshowsPrec :: Int -> ShakeValue -> ShowS
Show)

instance NFData ShakeValue

encodeShakeValue :: ShakeValue -> BS.ByteString
encodeShakeValue :: ShakeValue -> ByteString
encodeShakeValue = \case
  ShakeValue
ShakeNoCutoff -> ByteString
BS.empty
  ShakeResult ByteString
r -> Char -> ByteString -> ByteString
BS.cons Char
'r' ByteString
r
  ShakeStale ByteString
r -> Char -> ByteString -> ByteString
BS.cons Char
's' ByteString
r

decodeShakeValue :: BS.ByteString -> ShakeValue
decodeShakeValue :: ByteString -> ShakeValue
decodeShakeValue ByteString
bs = case ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
bs of
  Maybe (Char, ByteString)
Nothing -> ShakeValue
ShakeNoCutoff
  Just (Char
x, ByteString
xs)
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'r' -> ByteString -> ShakeValue
ShakeResult ByteString
xs
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
's' -> ByteString -> ShakeValue
ShakeStale ByteString
xs
    | Bool
otherwise -> String -> ShakeValue
forall a. HasCallStack => String -> a
error (String -> ShakeValue) -> String -> ShakeValue
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse shake value " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs