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

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

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, NFData 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 -> k -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt k
key

instance Binary Key where
    get :: Get Key
get = String -> Get Key
forall a. HasCallStack => String -> a
error String
"not really"
    put :: Key -> Put
put Key
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"not really"

instance NFData Key where
    rnf :: Key -> ()
rnf (Key k
k) = k -> ()
forall a. NFData a => a -> ()
rnf k
k

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


toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue
toKey :: k -> NormalizedFilePath -> SomeShakeValue
toKey = (Q k -> SomeShakeValue
forall k. ShakeValue k => k -> SomeShakeValue
SomeShakeValue (Q k -> SomeShakeValue)
-> (NormalizedFilePath -> Q k)
-> NormalizedFilePath
-> SomeShakeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((NormalizedFilePath -> Q k)
 -> NormalizedFilePath -> SomeShakeValue)
-> (k -> NormalizedFilePath -> Q k)
-> k
-> NormalizedFilePath
-> SomeShakeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, NormalizedFilePath) -> Q k) -> k -> NormalizedFilePath -> Q k
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q

toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, Binary k, NFData k) => k -> SomeShakeValue
toNoFileKey :: k -> SomeShakeValue
toNoFileKey k
k = k -> NormalizedFilePath -> SomeShakeValue
forall k. ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue
toKey k
k NormalizedFilePath
emptyFilePath

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