{-# 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.Core.RuleTypes       (FileVersion)
import           Development.IDE.Graph                (Key (..), RuleResult, newKey)
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

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 -> 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
<$ :: forall a b. a -> Value b -> Value a
$c<$ :: forall a b. a -> Value b -> Value a
fmap :: forall a b. (a -> b) -> Value a -> Value b
$cfmap :: forall a b. (a -> b) -> Value a -> Value b
Functor, 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
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
showList :: [Value v] -> ShowS
$cshowList :: forall v. Show v => [Value v] -> ShowS
show :: Value v -> [Char]
$cshow :: forall v. Show v => Value v -> [Char]
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 :: forall v. Value v -> Maybe v
currentValue (Succeeded Maybe FileVersion
_ v
v) = forall a. a -> Maybe a
Just v
v
currentValue (Stale Maybe PositionDelta
_ Maybe FileVersion
_ v
_)   = forall a. Maybe a
Nothing
currentValue Failed{}        = 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BadDependency] -> ShowS
$cshowList :: [BadDependency] -> ShowS
show :: BadDependency -> [Char]
$cshow :: BadDependency -> [Char]
showsPrec :: Int -> BadDependency -> ShowS
$cshowsPrec :: Int -> BadDependency -> ShowS
Show
instance Exception BadDependency

isBadDependency :: SomeException -> Bool
isBadDependency :: SomeException -> Bool
isBadDependency SomeException
x
    | Just (BadDependency
_ :: 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 = (forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKeyforall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. ((a, b) -> c) -> a -> b -> c
curry 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)) <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
k = forall a. a -> Maybe a
Just (k
k', NormalizedFilePath
f)
  | Bool
otherwise = 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 forall a. Typeable a => a -> TypeRep a
typeOf a
k of
    App (Con TyCon
tc) TypeRep b
a | TyCon
tc forall a. Eq a => a -> a -> Bool
== forall {k} (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Q)
        -> case forall a b. a -> b
unsafeCoerce a
k of
         Q (()
_ :: (), NormalizedFilePath
f) -> forall a. a -> Maybe a
Just (forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
a, NormalizedFilePath
f)
    TypeRep a
_ -> 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 = forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey forall a b. (a -> b) -> a -> b
$ forall k. (k, NormalizedFilePath) -> Q k
Q (k
k, NormalizedFilePath
emptyFilePath)

newtype Q k = Q (k, NormalizedFilePath)
    deriving newtype (Q k -> Q k -> Bool
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
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
Hashable, 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 -> [Char]
show (Q (k
k, NormalizedFilePath
file)) = forall a. Show a => a -> [Char]
show k
k forall a. [a] -> [a] -> [a]
++ [Char]
"; " 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
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
showList :: [A v] -> ShowS
$cshowList :: forall v. Show v => [A v] -> ShowS
show :: A v -> [Char]
$cshow :: forall v. Show v => A v -> [Char]
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 seq :: 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 = 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. 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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ShakeValue] -> ShowS
$cshowList :: [ShakeValue] -> ShowS
show :: ShakeValue -> [Char]
$cshow :: ShakeValue -> [Char]
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 forall a. Eq a => a -> a -> Bool
== Char
'r' -> ByteString -> ShakeValue
ShakeResult ByteString
xs
    | Char
x forall a. Eq a => a -> a -> Bool
== Char
's' -> ByteString -> ShakeValue
ShakeStale ByteString
xs
    | Bool
otherwise -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse shake value " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
bs