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

import           Control.DeepSeq
import           Control.Exception
import qualified Data.ByteString.Char8                as BS
import           Data.Dynamic
import           Data.Hashable
import           Data.Typeable                        (cast)
import           Data.Vector                          (Vector)
import           Development.IDE.Core.PositionMapping
import           Development.IDE.Core.RuleTypes       (FileVersion)
import           Development.IDE.Graph                (Key, RuleResult, newKey,
                                                       pattern Key)
import qualified Development.IDE.Graph                as Shake
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Location
import           GHC.Generics
import           HieDb.Types                          (HieDb)
import qualified StmContainers.Map                    as STM
import           Type.Reflection                      (SomeTypeRep (SomeTypeRep),
                                                       pattern App, pattern Con,
                                                       typeOf, typeRep,
                                                       typeRepTyCon)
import           Unsafe.Coerce                        (unsafeCoerce)

-- | Intended to represent HieDb calls wrapped with (currently) retry
-- functionality
type WithHieDb = forall a. (HieDb -> IO a) -> IO a

-- used to smuggle RankNType WithHieDb through dbMVar
newtype WithHieDbShield = WithHieDbShield WithHieDb

data Value v
    = Succeeded (Maybe FileVersion) v
    | Stale (Maybe PositionDelta) (Maybe FileVersion) v
    | Failed Bool -- True if we already tried the persistent rule
    deriving ((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
$cfmap :: forall a b. (a -> b) -> Value a -> Value b
fmap :: forall a b. (a -> b) -> Value a -> Value b
$c<$ :: forall a b. a -> Value b -> Value a
<$ :: forall a b. a -> Value b -> Value a
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
$cfrom :: forall v x. Value v -> Rep (Value v) x
from :: forall x. Value v -> Rep (Value v) x
$cto :: forall v x. Rep (Value v) x -> Value v
to :: forall x. Rep (Value v) x -> Value v
Generic, Int -> Value v -> ShowS
[Value v] -> ShowS
Value v -> [Char]
(Int -> Value v -> ShowS)
-> (Value v -> [Char]) -> ([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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Value v -> ShowS
showsPrec :: Int -> Value v -> ShowS
$cshow :: forall v. Show v => Value v -> [Char]
show :: Value v -> [Char]
$cshowList :: forall v. Show v => [Value v] -> ShowS
showList :: [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 :: forall v. Value v -> Maybe v
currentValue (Succeeded Maybe FileVersion
_ v
v) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
currentValue (Stale Maybe PositionDelta
_ Maybe FileVersion
_ 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 = STM.Map Key ValueWithDiagnostics

-- | 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 -> [Char]
(Int -> BadDependency -> ShowS)
-> (BadDependency -> [Char])
-> ([BadDependency] -> ShowS)
-> Show BadDependency
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadDependency -> ShowS
showsPrec :: Int -> BadDependency -> ShowS
$cshow :: BadDependency -> [Char]
show :: BadDependency -> [Char]
$cshowList :: [BadDependency] -> ShowS
showList :: [BadDependency] -> ShowS
Show
instance Exception BadDependency

isBadDependency :: SomeException -> Bool
isBadDependency :: SomeException -> Bool
isBadDependency SomeException
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 -> Key
toKey :: forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey = (Q k -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey.) ((NormalizedFilePath -> Q k) -> NormalizedFilePath -> Key)
-> (k -> NormalizedFilePath -> Q k)
-> k
-> NormalizedFilePath
-> Key
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

fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath)
fromKey :: forall k. Typeable k => Key -> Maybe (k, NormalizedFilePath)
fromKey (Key a
k)
  | Just (Q (k
k', NormalizedFilePath
f)) <- a -> Maybe (Q k)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
k = (k, NormalizedFilePath) -> Maybe (k, NormalizedFilePath)
forall a. a -> Maybe a
Just (k
k', NormalizedFilePath
f)
  | Bool
otherwise = Maybe (k, NormalizedFilePath)
forall a. Maybe a
Nothing

-- | fromKeyType (Q (k,f)) = (typeOf k, f)
fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath)
fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath)
fromKeyType (Key a
k) = case a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf a
k of
    App (Con TyCon
tc) TypeRep b
a | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep Q -> TyCon
forall {k} (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> *). Typeable a => TypeRep a
typeRep @Q)
        -> case a -> Q ()
forall a b. a -> b
unsafeCoerce a
k of
         Q (()
_ :: (), NormalizedFilePath
f) -> (SomeTypeRep, NormalizedFilePath)
-> Maybe (SomeTypeRep, NormalizedFilePath)
forall a. a -> Maybe a
Just (TypeRep b -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
a, NormalizedFilePath
f)
    TypeRep a
_ -> Maybe (SomeTypeRep, NormalizedFilePath)
forall a. Maybe a
Nothing

toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key
toNoFileKey :: forall k. (Show k, Typeable k, Eq k, Hashable k) => k -> Key
toNoFileKey k
k = Q k -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey (Q k -> Key) -> Q k -> Key
forall a b. (a -> b) -> a -> b
$ (k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q (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
$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
/= :: Q k -> Q k -> Bool
Eq, Eq (Q k)
Eq (Q k) => (Int -> Q k -> Int) -> (Q k -> Int) -> Hashable (Q k)
Int -> Q k -> Int
Q k -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall k. Hashable k => Eq (Q k)
forall k. Hashable k => Int -> Q k -> Int
forall k. Hashable k => Q k -> Int
$chashWithSalt :: forall k. Hashable k => Int -> Q k -> Int
hashWithSalt :: Int -> Q k -> Int
$chash :: forall k. Hashable k => Q k -> Int
hash :: Q k -> Int
Hashable, Q k -> ()
(Q k -> ()) -> NFData (Q k)
forall k. NFData k => Q k -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall k. NFData k => Q k -> ()
rnf :: Q k -> ()
NFData)

instance Show k => Show (Q k) where
    show :: Q k -> [Char]
show (Q (k
k, NormalizedFilePath
file)) = k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> [Char]
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 -> [Char]
(Int -> A v -> ShowS)
-> (A v -> [Char]) -> ([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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> A v -> ShowS
showsPrec :: Int -> A v -> ShowS
$cshow :: forall v. Show v => A v -> [Char]
show :: A v -> [Char]
$cshowList :: forall v. Show v => [A v] -> ShowS
showList :: [A v] -> ShowS
Show

instance NFData (A v) where rnf :: A v -> ()
rnf (A Value v
v) = Value v
v Value v -> () -> ()
forall a b. a -> b -> b
`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
$cfrom :: forall x. ShakeValue -> Rep ShakeValue x
from :: forall x. ShakeValue -> Rep ShakeValue x
$cto :: forall x. Rep ShakeValue x -> ShakeValue
to :: forall x. Rep ShakeValue x -> ShakeValue
Generic, Int -> ShakeValue -> ShowS
[ShakeValue] -> ShowS
ShakeValue -> [Char]
(Int -> ShakeValue -> ShowS)
-> (ShakeValue -> [Char])
-> ([ShakeValue] -> ShowS)
-> Show ShakeValue
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShakeValue -> ShowS
showsPrec :: Int -> ShakeValue -> ShowS
$cshow :: ShakeValue -> [Char]
show :: ShakeValue -> [Char]
$cshowList :: [ShakeValue] -> ShowS
showList :: [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 -> [Char] -> ShakeValue
forall a. HasCallStack => [Char] -> a
error ([Char] -> ShakeValue) -> [Char] -> ShakeValue
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse shake value " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs