{-# LANGUAGE DerivingStrategies        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE RankNTypes                #-}
{-# 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)
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.Graph                (Key (..), RuleResult)
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)
import Development.IDE.Core.RuleTypes (FileVersion)

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

data Value v
    = Succeeded (Maybe FileVersion) v
    | Stale (Maybe PositionDelta) (Maybe FileVersion) 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 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 -> 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 (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 :: k -> NormalizedFilePath -> Key
toKey = (Q k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key(Q k -> Key)
-> (NormalizedFilePath -> Q k) -> NormalizedFilePath -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((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 :: 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 (Typeable Q => TypeRep Q
forall k (a :: k). 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 :: k -> Key
toNoFileKey k
k = Q k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key (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
/= :: 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, 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
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
$cp1Hashable :: forall k. Hashable k => Eq (Q k)
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 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