{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE ViewPatterns               #-}

module Development.IDE.Graph.Internal.Types where

import           Control.Applicative
import           Control.Monad.Catch
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader
import           Data.Aeson                    (FromJSON, ToJSON)
import           Data.Bifunctor                (second)
import qualified Data.ByteString               as BS
import           Data.Coerce
import           Data.Dynamic
import qualified Data.HashMap.Strict           as Map
import qualified Data.IntMap.Strict            as IM
import           Data.IntMap                   (IntMap)
import qualified Data.IntSet                   as IS
import           Data.IntSet                   (IntSet)
import qualified Data.Text                     as T
import           Data.Text                     (Text)
import           Data.IORef
import           Data.List                     (intercalate)
import           Data.Maybe
import           Data.Typeable
import           Development.IDE.Graph.Classes
import           GHC.Conc                      (TVar, atomically)
import           GHC.Generics                  (Generic)
import qualified ListT
import qualified StmContainers.Map             as SMap
import           StmContainers.Map             (Map)
import           System.Time.Extra             (Seconds)
import           System.IO.Unsafe
import           UnliftIO                      (MonadUnliftIO)


unwrapDynamic :: forall a . Typeable a => Dynamic -> a
unwrapDynamic :: forall a. Typeable a => Dynamic -> a
unwrapDynamic Dynamic
x = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
msg) forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
x
    where msg :: [Char]
msg = [Char]
"unwrapDynamic failed: Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall a. [a] -> [a] -> [a]
++
                [Char]
", but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Dynamic -> TypeRep
dynTypeRep Dynamic
x)

---------------------------------------------------------------------
-- RULES

type TheRules = Map.HashMap TypeRep Dynamic

-- | A computation that defines all the rules that form part of the computation graph.
--
-- 'Rules' has access to 'IO' through 'MonadIO'. Use of 'IO' is at your own risk: if
-- you write 'Rules' that throw exceptions, then you need to make sure to handle them
-- yourself when you run the resulting 'Rules'.
newtype Rules a = Rules (ReaderT SRules IO a)
    deriving newtype (Applicative Rules
forall a. a -> Rules a
forall a b. Rules a -> Rules b -> Rules b
forall a b. Rules a -> (a -> Rules b) -> Rules b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Rules a
$creturn :: forall a. a -> Rules a
>> :: forall a b. Rules a -> Rules b -> Rules b
$c>> :: forall a b. Rules a -> Rules b -> Rules b
>>= :: forall a b. Rules a -> (a -> Rules b) -> Rules b
$c>>= :: forall a b. Rules a -> (a -> Rules b) -> Rules b
Monad, Functor Rules
forall a. a -> Rules a
forall a b. Rules a -> Rules b -> Rules a
forall a b. Rules a -> Rules b -> Rules b
forall a b. Rules (a -> b) -> Rules a -> Rules b
forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Rules a -> Rules b -> Rules a
$c<* :: forall a b. Rules a -> Rules b -> Rules a
*> :: forall a b. Rules a -> Rules b -> Rules b
$c*> :: forall a b. Rules a -> Rules b -> Rules b
liftA2 :: forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
$cliftA2 :: forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
<*> :: forall a b. Rules (a -> b) -> Rules a -> Rules b
$c<*> :: forall a b. Rules (a -> b) -> Rules a -> Rules b
pure :: forall a. a -> Rules a
$cpure :: forall a. a -> Rules a
Applicative, forall a b. a -> Rules b -> Rules a
forall a b. (a -> b) -> Rules a -> Rules 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 -> Rules b -> Rules a
$c<$ :: forall a b. a -> Rules b -> Rules a
fmap :: forall a b. (a -> b) -> Rules a -> Rules b
$cfmap :: forall a b. (a -> b) -> Rules a -> Rules b
Functor, Monad Rules
forall a. IO a -> Rules a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Rules a
$cliftIO :: forall a. IO a -> Rules a
MonadIO)

data SRules = SRules {
    SRules -> Dynamic
rulesExtra   :: !Dynamic,
    SRules -> IORef [Action ()]
rulesActions :: !(IORef [Action ()]),
    SRules -> IORef TheRules
rulesMap     :: !(IORef TheRules)
    }


---------------------------------------------------------------------
-- ACTIONS

-- | An action representing something that can be run as part of a 'Rule'.
-- 
-- 'Action's can be pure functions but also have access to 'IO' via 'MonadIO' and 'MonadUnliftIO.
-- It should be assumed that actions throw exceptions, these can be caught with
-- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is 
-- permissible to use the 'MonadFail' instance, which will lead to an 'IOException'.
newtype Action a = Action {forall a. Action a -> ReaderT SAction IO a
fromAction :: ReaderT SAction IO a}
    deriving newtype (Applicative Action
forall a. a -> Action a
forall a b. Action a -> Action b -> Action b
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Action a
$creturn :: forall a. a -> Action a
>> :: forall a b. Action a -> Action b -> Action b
$c>> :: forall a b. Action a -> Action b -> Action b
>>= :: forall a b. Action a -> (a -> Action b) -> Action b
$c>>= :: forall a b. Action a -> (a -> Action b) -> Action b
Monad, Functor Action
forall a. a -> Action a
forall a b. Action a -> Action b -> Action a
forall a b. Action a -> Action b -> Action b
forall a b. Action (a -> b) -> Action a -> Action b
forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Action a -> Action b -> Action a
$c<* :: forall a b. Action a -> Action b -> Action a
*> :: forall a b. Action a -> Action b -> Action b
$c*> :: forall a b. Action a -> Action b -> Action b
liftA2 :: forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c
$cliftA2 :: forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c
<*> :: forall a b. Action (a -> b) -> Action a -> Action b
$c<*> :: forall a b. Action (a -> b) -> Action a -> Action b
pure :: forall a. a -> Action a
$cpure :: forall a. a -> Action a
Applicative, forall a b. a -> Action b -> Action a
forall a b. (a -> b) -> Action a -> Action 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 -> Action b -> Action a
$c<$ :: forall a b. a -> Action b -> Action a
fmap :: forall a b. (a -> b) -> Action a -> Action b
$cfmap :: forall a b. (a -> b) -> Action a -> Action b
Functor, Monad Action
forall a. IO a -> Action a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Action a
$cliftIO :: forall a. IO a -> Action a
MonadIO, Monad Action
forall a. [Char] -> Action a
forall (m :: * -> *).
Monad m -> (forall a. [Char] -> m a) -> MonadFail m
fail :: forall a. [Char] -> Action a
$cfail :: forall a. [Char] -> Action a
MonadFail, Monad Action
forall e a. Exception e => e -> Action a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> Action a
$cthrowM :: forall e a. Exception e => e -> Action a
MonadThrow, MonadThrow Action
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a. Exception e => Action a -> (e -> Action a) -> Action a
$ccatch :: forall e a. Exception e => Action a -> (e -> Action a) -> Action a
MonadCatch, MonadCatch Action
forall b.
((forall a. Action a -> Action a) -> Action b) -> Action b
forall a b c.
Action a
-> (a -> ExitCase b -> Action c)
-> (a -> Action b)
-> Action (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
Action a
-> (a -> ExitCase b -> Action c)
-> (a -> Action b)
-> Action (b, c)
$cgeneralBracket :: forall a b c.
Action a
-> (a -> ExitCase b -> Action c)
-> (a -> Action b)
-> Action (b, c)
uninterruptibleMask :: forall b.
((forall a. Action a -> Action a) -> Action b) -> Action b
$cuninterruptibleMask :: forall b.
((forall a. Action a -> Action a) -> Action b) -> Action b
mask :: forall b.
((forall a. Action a -> Action a) -> Action b) -> Action b
$cmask :: forall b.
((forall a. Action a -> Action a) -> Action b) -> Action b
MonadMask, MonadIO Action
forall b. ((forall a. Action a -> IO a) -> IO b) -> Action b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b. ((forall a. Action a -> IO a) -> IO b) -> Action b
$cwithRunInIO :: forall b. ((forall a. Action a -> IO a) -> IO b) -> Action b
MonadUnliftIO)

data SAction = SAction {
    SAction -> Database
actionDatabase :: !Database,
    SAction -> IORef ResultDeps
actionDeps     :: !(IORef ResultDeps),
    SAction -> Stack
actionStack    :: !Stack
    }

getDatabase :: Action Database
getDatabase :: Action Database
getDatabase = forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> Database
actionDatabase

---------------------------------------------------------------------
-- DATABASE

data ShakeDatabase = ShakeDatabase !Int [Action ()] Database

newtype Step = Step Int
    deriving newtype (Step -> Step -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c== :: Step -> Step -> Bool
Eq,Eq Step
Step -> Step -> Bool
Step -> Step -> Ordering
Step -> Step -> Step
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Step -> Step -> Step
$cmin :: Step -> Step -> Step
max :: Step -> Step -> Step
$cmax :: Step -> Step -> Step
>= :: Step -> Step -> Bool
$c>= :: Step -> Step -> Bool
> :: Step -> Step -> Bool
$c> :: Step -> Step -> Bool
<= :: Step -> Step -> Bool
$c<= :: Step -> Step -> Bool
< :: Step -> Step -> Bool
$c< :: Step -> Step -> Bool
compare :: Step -> Step -> Ordering
$ccompare :: Step -> Step -> Ordering
Ord,Eq Step
Int -> Step -> Int
Step -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Step -> Int
$chash :: Step -> Int
hashWithSalt :: Int -> Step -> Int
$chashWithSalt :: Int -> Step -> Int
Hashable)

---------------------------------------------------------------------
-- Keys

data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text

newtype Key = UnsafeMkKey Int

pattern $mKey :: forall {r}.
Key
-> (forall {a}. (Typeable a, Hashable a, Show a) => a -> r)
-> ((# #) -> r)
-> r
Key a <- (lookupKeyValue -> KeyValue a _)

data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int

keyMap :: IORef GlobalKeyValueMap
keyMap :: IORef GlobalKeyValueMap
keyMap = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (HashMap KeyValue Key -> IntMap KeyValue -> Int -> GlobalKeyValueMap
GlobalKeyValueMap forall k v. HashMap k v
Map.empty forall a. IntMap a
IM.empty Int
0)

{-# NOINLINE keyMap #-}

newKey :: (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey :: forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey a
k = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  let !newKey :: KeyValue
newKey = forall a.
(Eq a, Typeable a, Hashable a, Show a) =>
a -> Text -> KeyValue
KeyValue a
k ([Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show a
k))
  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GlobalKeyValueMap
keyMap forall a b. (a -> b) -> a -> b
$ \km :: GlobalKeyValueMap
km@(GlobalKeyValueMap HashMap KeyValue Key
hm IntMap KeyValue
im Int
n) ->
    let new_key :: Maybe Key
new_key = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup KeyValue
newKey HashMap KeyValue Key
hm
    in case Maybe Key
new_key of
          Just Key
v  -> (GlobalKeyValueMap
km, Key
v)
          Maybe Key
Nothing ->
            let !new_index :: Key
new_index = Int -> Key
UnsafeMkKey Int
n
            in (HashMap KeyValue Key -> IntMap KeyValue -> Int -> GlobalKeyValueMap
GlobalKeyValueMap (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert KeyValue
newKey Key
new_index HashMap KeyValue Key
hm) (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
n KeyValue
newKey IntMap KeyValue
im) (Int
nforall a. Num a => a -> a -> a
+Int
1), Key
new_index)
{-# NOINLINE newKey #-}

lookupKeyValue :: Key -> KeyValue
lookupKeyValue :: Key -> KeyValue
lookupKeyValue (UnsafeMkKey Int
x) = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  GlobalKeyValueMap HashMap KeyValue Key
_ IntMap KeyValue
im Int
_ <- forall a. IORef a -> IO a
readIORef IORef GlobalKeyValueMap
keyMap
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! IntMap KeyValue
im forall a. IntMap a -> Int -> a
IM.! Int
x

{-# NOINLINE lookupKeyValue #-}

instance Eq Key where
  UnsafeMkKey Int
a == :: Key -> Key -> Bool
== UnsafeMkKey Int
b = Int
a forall a. Eq a => a -> a -> Bool
== Int
b
instance Hashable Key where
  hashWithSalt :: Int -> Key -> Int
hashWithSalt Int
i (UnsafeMkKey Int
x) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i Int
x
instance Show Key where
  show :: Key -> [Char]
show (Key a
x) = forall a. Show a => a -> [Char]
show a
x

instance Eq KeyValue where
    KeyValue a
a Text
_ == :: KeyValue -> KeyValue -> Bool
== KeyValue a
b Text
_ = forall a. a -> Maybe a
Just a
a forall a. Eq a => a -> a -> Bool
== forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
b
instance Hashable KeyValue where
    hashWithSalt :: Int -> KeyValue -> Int
hashWithSalt Int
i (KeyValue a
x Text
_) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (forall a. Typeable a => a -> TypeRep
typeOf a
x, a
x)
instance Show KeyValue where
    show :: KeyValue -> [Char]
show (KeyValue a
x Text
t) = Text -> [Char]
T.unpack Text
t

renderKey :: Key -> Text
renderKey :: Key -> Text
renderKey (Key -> KeyValue
lookupKeyValue -> KeyValue a
_ Text
t) = Text
t

newtype KeySet = KeySet IntSet
  deriving newtype (KeySet -> KeySet -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeySet -> KeySet -> Bool
$c/= :: KeySet -> KeySet -> Bool
== :: KeySet -> KeySet -> Bool
$c== :: KeySet -> KeySet -> Bool
Eq, Eq KeySet
KeySet -> KeySet -> Bool
KeySet -> KeySet -> Ordering
KeySet -> KeySet -> KeySet
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KeySet -> KeySet -> KeySet
$cmin :: KeySet -> KeySet -> KeySet
max :: KeySet -> KeySet -> KeySet
$cmax :: KeySet -> KeySet -> KeySet
>= :: KeySet -> KeySet -> Bool
$c>= :: KeySet -> KeySet -> Bool
> :: KeySet -> KeySet -> Bool
$c> :: KeySet -> KeySet -> Bool
<= :: KeySet -> KeySet -> Bool
$c<= :: KeySet -> KeySet -> Bool
< :: KeySet -> KeySet -> Bool
$c< :: KeySet -> KeySet -> Bool
compare :: KeySet -> KeySet -> Ordering
$ccompare :: KeySet -> KeySet -> Ordering
Ord, NonEmpty KeySet -> KeySet
KeySet -> KeySet -> KeySet
forall b. Integral b => b -> KeySet -> KeySet
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> KeySet -> KeySet
$cstimes :: forall b. Integral b => b -> KeySet -> KeySet
sconcat :: NonEmpty KeySet -> KeySet
$csconcat :: NonEmpty KeySet -> KeySet
<> :: KeySet -> KeySet -> KeySet
$c<> :: KeySet -> KeySet -> KeySet
Semigroup, Semigroup KeySet
KeySet
[KeySet] -> KeySet
KeySet -> KeySet -> KeySet
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [KeySet] -> KeySet
$cmconcat :: [KeySet] -> KeySet
mappend :: KeySet -> KeySet -> KeySet
$cmappend :: KeySet -> KeySet -> KeySet
mempty :: KeySet
$cmempty :: KeySet
Monoid)

instance Show KeySet where
  showsPrec :: Int -> KeySet -> ShowS
showsPrec Int
p (KeySet IntSet
is)= Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      [Char] -> ShowS
showString [Char]
"fromList " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows [Key]
ks
    where ks :: [Key]
ks = coerce :: forall a b. Coercible a b => a -> b
coerce (IntSet -> [Int]
IS.toList IntSet
is) :: [Key]

insertKeySet :: Key -> KeySet -> KeySet
insertKeySet :: Key -> KeySet -> KeySet
insertKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce Int -> IntSet -> IntSet
IS.insert

memberKeySet :: Key -> KeySet -> Bool
memberKeySet :: Key -> KeySet -> Bool
memberKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce Int -> IntSet -> Bool
IS.member

toListKeySet :: KeySet -> [Key]
toListKeySet :: KeySet -> [Key]
toListKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce IntSet -> [Int]
IS.toList

nullKeySet :: KeySet -> Bool
nullKeySet :: KeySet -> Bool
nullKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce IntSet -> Bool
IS.null

differenceKeySet :: KeySet -> KeySet -> KeySet
differenceKeySet :: KeySet -> KeySet -> KeySet
differenceKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce IntSet -> IntSet -> IntSet
IS.difference

deleteKeySet :: Key -> KeySet -> KeySet
deleteKeySet :: Key -> KeySet -> KeySet
deleteKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce Int -> IntSet -> IntSet
IS.delete

fromListKeySet :: [Key] -> KeySet
fromListKeySet :: [Key] -> KeySet
fromListKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce [Int] -> IntSet
IS.fromList

singletonKeySet :: Key -> KeySet
singletonKeySet :: Key -> KeySet
singletonKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce Int -> IntSet
IS.singleton

filterKeySet :: (Key -> Bool) -> KeySet -> KeySet
filterKeySet :: (Key -> Bool) -> KeySet -> KeySet
filterKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce (Int -> Bool) -> IntSet -> IntSet
IS.filter

lengthKeySet :: KeySet -> Int
lengthKeySet :: KeySet -> Int
lengthKeySet = coerce :: forall a b. Coercible a b => a -> b
coerce IntSet -> Int
IS.size

newtype KeyMap a = KeyMap (IntMap a)
  deriving newtype (KeyMap a -> KeyMap a -> Bool
forall a. Eq a => KeyMap a -> KeyMap a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyMap a -> KeyMap a -> Bool
$c/= :: forall a. Eq a => KeyMap a -> KeyMap a -> Bool
== :: KeyMap a -> KeyMap a -> Bool
$c== :: forall a. Eq a => KeyMap a -> KeyMap a -> Bool
Eq, KeyMap a -> KeyMap a -> Bool
KeyMap a -> KeyMap a -> Ordering
KeyMap a -> KeyMap a -> KeyMap a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (KeyMap a)
forall a. Ord a => KeyMap a -> KeyMap a -> Bool
forall a. Ord a => KeyMap a -> KeyMap a -> Ordering
forall a. Ord a => KeyMap a -> KeyMap a -> KeyMap a
min :: KeyMap a -> KeyMap a -> KeyMap a
$cmin :: forall a. Ord a => KeyMap a -> KeyMap a -> KeyMap a
max :: KeyMap a -> KeyMap a -> KeyMap a
$cmax :: forall a. Ord a => KeyMap a -> KeyMap a -> KeyMap a
>= :: KeyMap a -> KeyMap a -> Bool
$c>= :: forall a. Ord a => KeyMap a -> KeyMap a -> Bool
> :: KeyMap a -> KeyMap a -> Bool
$c> :: forall a. Ord a => KeyMap a -> KeyMap a -> Bool
<= :: KeyMap a -> KeyMap a -> Bool
$c<= :: forall a. Ord a => KeyMap a -> KeyMap a -> Bool
< :: KeyMap a -> KeyMap a -> Bool
$c< :: forall a. Ord a => KeyMap a -> KeyMap a -> Bool
compare :: KeyMap a -> KeyMap a -> Ordering
$ccompare :: forall a. Ord a => KeyMap a -> KeyMap a -> Ordering
Ord, NonEmpty (KeyMap a) -> KeyMap a
KeyMap a -> KeyMap a -> KeyMap a
forall b. Integral b => b -> KeyMap a -> KeyMap a
forall a. NonEmpty (KeyMap a) -> KeyMap a
forall a. KeyMap a -> KeyMap a -> KeyMap a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> KeyMap a -> KeyMap a
stimes :: forall b. Integral b => b -> KeyMap a -> KeyMap a
$cstimes :: forall a b. Integral b => b -> KeyMap a -> KeyMap a
sconcat :: NonEmpty (KeyMap a) -> KeyMap a
$csconcat :: forall a. NonEmpty (KeyMap a) -> KeyMap a
<> :: KeyMap a -> KeyMap a -> KeyMap a
$c<> :: forall a. KeyMap a -> KeyMap a -> KeyMap a
Semigroup, KeyMap a
[KeyMap a] -> KeyMap a
KeyMap a -> KeyMap a -> KeyMap a
forall a. Semigroup (KeyMap a)
forall a. KeyMap a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [KeyMap a] -> KeyMap a
forall a. KeyMap a -> KeyMap a -> KeyMap a
mconcat :: [KeyMap a] -> KeyMap a
$cmconcat :: forall a. [KeyMap a] -> KeyMap a
mappend :: KeyMap a -> KeyMap a -> KeyMap a
$cmappend :: forall a. KeyMap a -> KeyMap a -> KeyMap a
mempty :: KeyMap a
$cmempty :: forall a. KeyMap a
Monoid)

instance Show a => Show (KeyMap a) where
  showsPrec :: Int -> KeyMap a -> ShowS
showsPrec Int
p (KeyMap IntMap a
im)= Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      [Char] -> ShowS
showString [Char]
"fromList " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows [(Key, a)]
ks
    where ks :: [(Key, a)]
ks = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. IntMap a -> [(Int, a)]
IM.toList IntMap a
im) :: [(Key,a)]

mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b
mapKeyMap :: forall a b. (a -> b) -> KeyMap a -> KeyMap b
mapKeyMap a -> b
f (KeyMap IntMap a
m) = forall a. IntMap a -> KeyMap a
KeyMap (forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map a -> b
f IntMap a
m)

insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a
insertKeyMap :: forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap (UnsafeMkKey Int
k) a
v (KeyMap IntMap a
m) = forall a. IntMap a -> KeyMap a
KeyMap (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k a
v IntMap a
m)

lookupKeyMap :: Key -> KeyMap a -> Maybe a
lookupKeyMap :: forall a. Key -> KeyMap a -> Maybe a
lookupKeyMap (UnsafeMkKey Int
k) (KeyMap IntMap a
m) = forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap a
m

lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a
lookupDefaultKeyMap :: forall a. a -> Key -> KeyMap a -> a
lookupDefaultKeyMap a
a (UnsafeMkKey Int
k) (KeyMap IntMap a
m) = forall a. a -> Int -> IntMap a -> a
IM.findWithDefault a
a Int
k IntMap a
m

fromListKeyMap :: [(Key,a)] -> KeyMap a
fromListKeyMap :: forall a. [(Key, a)] -> KeyMap a
fromListKeyMap [(Key, a)]
xs = forall a. IntMap a -> KeyMap a
KeyMap (forall a. [(Int, a)] -> IntMap a
IM.fromList (coerce :: forall a b. Coercible a b => a -> b
coerce [(Key, a)]
xs))

fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a
fromListWithKeyMap :: forall a. (a -> a -> a) -> [(Key, a)] -> KeyMap a
fromListWithKeyMap a -> a -> a
f [(Key, a)]
xs = forall a. IntMap a -> KeyMap a
KeyMap (forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith a -> a -> a
f (coerce :: forall a b. Coercible a b => a -> b
coerce [(Key, a)]
xs))

toListKeyMap :: KeyMap a -> [(Key,a)]
toListKeyMap :: forall a. KeyMap a -> [(Key, a)]
toListKeyMap (KeyMap IntMap a
m) = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. IntMap a -> [(Int, a)]
IM.toList IntMap a
m)

elemsKeyMap :: KeyMap a -> [a]
elemsKeyMap :: forall a. KeyMap a -> [a]
elemsKeyMap (KeyMap IntMap a
m) = forall a. IntMap a -> [a]
IM.elems IntMap a
m

restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a
restrictKeysKeyMap :: forall a. KeyMap a -> KeySet -> KeyMap a
restrictKeysKeyMap (KeyMap IntMap a
m) (KeySet IntSet
s) = forall a. IntMap a -> KeyMap a
KeyMap (forall a. IntMap a -> IntSet -> IntMap a
IM.restrictKeys IntMap a
m IntSet
s)


newtype Value = Value Dynamic

data KeyDetails = KeyDetails {
    KeyDetails -> Status
keyStatus      :: !Status,
    KeyDetails -> KeySet
keyReverseDeps :: !KeySet
    }

onKeyReverseDeps :: (KeySet -> KeySet) -> KeyDetails -> KeyDetails
onKeyReverseDeps :: (KeySet -> KeySet) -> KeyDetails -> KeyDetails
onKeyReverseDeps KeySet -> KeySet
f it :: KeyDetails
it@KeyDetails{Status
KeySet
keyReverseDeps :: KeySet
keyStatus :: Status
keyReverseDeps :: KeyDetails -> KeySet
keyStatus :: KeyDetails -> Status
..} =
    KeyDetails
it{keyReverseDeps :: KeySet
keyReverseDeps = KeySet -> KeySet
f KeySet
keyReverseDeps}

data Database = Database {
    Database -> Dynamic
databaseExtra  :: Dynamic,
    Database -> TheRules
databaseRules  :: TheRules,
    Database -> TVar Step
databaseStep   :: !(TVar Step),
    Database -> Map Key KeyDetails
databaseValues :: !(Map Key KeyDetails)
    }

getDatabaseValues :: Database -> IO [(Key, Status)]
getDatabaseValues :: Database -> IO [(Key, Status)]
getDatabaseValues = forall a. STM a -> IO a
atomically
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second KeyDetails -> Status
keyStatus)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key value. Map key value -> ListT STM (key, value)
SMap.listT
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> Map Key KeyDetails
databaseValues

data Status
    = Clean !Result
    | Dirty (Maybe Result)
    | Running {
        Status -> Step
runningStep   :: !Step,
        Status -> IO ()
runningWait   :: !(IO ()),
        Status -> Result
runningResult :: Result,     -- LAZY
        Status -> Maybe Result
runningPrev   :: !(Maybe Result)
        }

viewDirty :: Step -> Status -> Status
viewDirty :: Step -> Status -> Status
viewDirty Step
currentStep (Running Step
s IO ()
_ Result
_ Maybe Result
re) | Step
currentStep forall a. Eq a => a -> a -> Bool
/= Step
s = Maybe Result -> Status
Dirty Maybe Result
re
viewDirty Step
_ Status
other = Status
other

getResult :: Status -> Maybe Result
getResult :: Status -> Maybe Result
getResult (Clean Result
re)           = forall a. a -> Maybe a
Just Result
re
getResult (Dirty Maybe Result
m_re)         = Maybe Result
m_re
getResult (Running Step
_ IO ()
_ Result
_ Maybe Result
m_re) = Maybe Result
m_re -- watch out: this returns the previous result

data Result = Result {
    Result -> Value
resultValue     :: !Value,
    Result -> Step
resultBuilt     :: !Step, -- ^ the step when it was last recomputed
    Result -> Step
resultChanged   :: !Step, -- ^ the step when it last changed
    Result -> Step
resultVisited   :: !Step, -- ^ the step when it was last looked up
    Result -> ResultDeps
resultDeps      :: !ResultDeps,
    Result -> Seconds
resultExecution :: !Seconds, -- ^ How long it took, last time it ran
    Result -> ByteString
resultData      :: !BS.ByteString
    }

data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet
  deriving (ResultDeps -> ResultDeps -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResultDeps -> ResultDeps -> Bool
$c/= :: ResultDeps -> ResultDeps -> Bool
== :: ResultDeps -> ResultDeps -> Bool
$c== :: ResultDeps -> ResultDeps -> Bool
Eq, Int -> ResultDeps -> ShowS
[ResultDeps] -> ShowS
ResultDeps -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ResultDeps] -> ShowS
$cshowList :: [ResultDeps] -> ShowS
show :: ResultDeps -> [Char]
$cshow :: ResultDeps -> [Char]
showsPrec :: Int -> ResultDeps -> ShowS
$cshowsPrec :: Int -> ResultDeps -> ShowS
Show)

getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
getResultDepsDefault KeySet
_ (ResultDeps KeySet
ids)      = KeySet
ids
getResultDepsDefault KeySet
_ (AlwaysRerunDeps KeySet
ids) = KeySet
ids
getResultDepsDefault KeySet
def ResultDeps
UnknownDeps         = KeySet
def

mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
mapResultDeps KeySet -> KeySet
f (ResultDeps KeySet
ids)      = KeySet -> ResultDeps
ResultDeps forall a b. (a -> b) -> a -> b
$ KeySet -> KeySet
f KeySet
ids
mapResultDeps KeySet -> KeySet
f (AlwaysRerunDeps KeySet
ids) = KeySet -> ResultDeps
AlwaysRerunDeps forall a b. (a -> b) -> a -> b
$ KeySet -> KeySet
f KeySet
ids
mapResultDeps KeySet -> KeySet
_ ResultDeps
UnknownDeps           = ResultDeps
UnknownDeps

instance Semigroup ResultDeps where
    ResultDeps
UnknownDeps <> :: ResultDeps -> ResultDeps -> ResultDeps
<> ResultDeps
x = ResultDeps
x
    ResultDeps
x <> ResultDeps
UnknownDeps = ResultDeps
x
    AlwaysRerunDeps KeySet
ids <> ResultDeps
x = KeySet -> ResultDeps
AlwaysRerunDeps (KeySet
ids forall a. Semigroup a => a -> a -> a
<> KeySet -> ResultDeps -> KeySet
getResultDepsDefault forall a. Monoid a => a
mempty ResultDeps
x)
    ResultDeps
x <> AlwaysRerunDeps KeySet
ids = KeySet -> ResultDeps
AlwaysRerunDeps (KeySet -> ResultDeps -> KeySet
getResultDepsDefault forall a. Monoid a => a
mempty ResultDeps
x forall a. Semigroup a => a -> a -> a
<> KeySet
ids)
    ResultDeps KeySet
ids <> ResultDeps KeySet
ids' = KeySet -> ResultDeps
ResultDeps (KeySet
ids forall a. Semigroup a => a -> a -> a
<> KeySet
ids')

instance Monoid ResultDeps where
    mempty :: ResultDeps
mempty = ResultDeps
UnknownDeps

---------------------------------------------------------------------
-- Running builds

-- | What mode a rule is running in, passed as an argument to 'BuiltinRun'.
data RunMode
    = RunDependenciesSame -- ^ My dependencies have not changed.
    | RunDependenciesChanged -- ^ At least one of my dependencies from last time have changed, or I have no recorded dependencies.
      deriving (RunMode -> RunMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunMode -> RunMode -> Bool
$c/= :: RunMode -> RunMode -> Bool
== :: RunMode -> RunMode -> Bool
$c== :: RunMode -> RunMode -> Bool
Eq,Int -> RunMode -> ShowS
[RunMode] -> ShowS
RunMode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RunMode] -> ShowS
$cshowList :: [RunMode] -> ShowS
show :: RunMode -> [Char]
$cshow :: RunMode -> [Char]
showsPrec :: Int -> RunMode -> ShowS
$cshowsPrec :: Int -> RunMode -> ShowS
Show)

instance NFData RunMode where rnf :: RunMode -> ()
rnf RunMode
x = RunMode
x seq :: forall a b. a -> b -> b
`seq` ()

-- | How the output of a rule has changed.
data RunChanged
    = ChangedNothing -- ^ Nothing has changed.
    | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely).
    | ChangedRecomputeSame -- ^ I recomputed the value and it was the same.
    | ChangedRecomputeDiff -- ^ I recomputed the value and it was different.
      deriving (RunChanged -> RunChanged -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunChanged -> RunChanged -> Bool
$c/= :: RunChanged -> RunChanged -> Bool
== :: RunChanged -> RunChanged -> Bool
$c== :: RunChanged -> RunChanged -> Bool
Eq,Int -> RunChanged -> ShowS
[RunChanged] -> ShowS
RunChanged -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RunChanged] -> ShowS
$cshowList :: [RunChanged] -> ShowS
show :: RunChanged -> [Char]
$cshow :: RunChanged -> [Char]
showsPrec :: Int -> RunChanged -> ShowS
$cshowsPrec :: Int -> RunChanged -> ShowS
Show,forall x. Rep RunChanged x -> RunChanged
forall x. RunChanged -> Rep RunChanged x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RunChanged x -> RunChanged
$cfrom :: forall x. RunChanged -> Rep RunChanged x
Generic)
      deriving anyclass (Value -> Parser [RunChanged]
Value -> Parser RunChanged
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RunChanged]
$cparseJSONList :: Value -> Parser [RunChanged]
parseJSON :: Value -> Parser RunChanged
$cparseJSON :: Value -> Parser RunChanged
FromJSON, [RunChanged] -> Encoding
[RunChanged] -> Value
RunChanged -> Encoding
RunChanged -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RunChanged] -> Encoding
$ctoEncodingList :: [RunChanged] -> Encoding
toJSONList :: [RunChanged] -> Value
$ctoJSONList :: [RunChanged] -> Value
toEncoding :: RunChanged -> Encoding
$ctoEncoding :: RunChanged -> Encoding
toJSON :: RunChanged -> Value
$ctoJSON :: RunChanged -> Value
ToJSON)

instance NFData RunChanged where rnf :: RunChanged -> ()
rnf RunChanged
x = RunChanged
x seq :: forall a b. a -> b -> b
`seq` ()

-- | The result of 'BuiltinRun'.
data RunResult value = RunResult
    {forall value. RunResult value -> RunChanged
runChanged :: RunChanged
        -- ^ How has the 'RunResult' changed from what happened last time.
    ,forall value. RunResult value -> ByteString
runStore   :: BS.ByteString
        -- ^ The value to store in the Shake database.
    ,forall value. RunResult value -> value
runValue   :: value
        -- ^ The value to return from 'Development.Shake.Rule.apply'.
    } deriving forall a b. a -> RunResult b -> RunResult a
forall a b. (a -> b) -> RunResult a -> RunResult 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 -> RunResult b -> RunResult a
$c<$ :: forall a b. a -> RunResult b -> RunResult a
fmap :: forall a b. (a -> b) -> RunResult a -> RunResult b
$cfmap :: forall a b. (a -> b) -> RunResult a -> RunResult b
Functor

instance NFData value => NFData (RunResult value) where
    rnf :: RunResult value -> ()
rnf (RunResult RunChanged
x1 ByteString
x2 value
x3) = forall a. NFData a => a -> ()
rnf RunChanged
x1 seq :: forall a b. a -> b -> b
`seq` ByteString
x2 seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf value
x3

---------------------------------------------------------------------
-- EXCEPTIONS

data GraphException = forall e. Exception e => GraphException {
    GraphException -> [Char]
target :: String, -- ^ The key that was being built
    GraphException -> [[Char]]
stack  :: [String], -- ^ The stack of keys that led to this exception
    ()
inner  :: e -- ^ The underlying exception
}
  deriving (Typeable, Show GraphException
Typeable GraphException
SomeException -> Maybe GraphException
GraphException -> [Char]
GraphException -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> Exception e
displayException :: GraphException -> [Char]
$cdisplayException :: GraphException -> [Char]
fromException :: SomeException -> Maybe GraphException
$cfromException :: SomeException -> Maybe GraphException
toException :: GraphException -> SomeException
$ctoException :: GraphException -> SomeException
Exception)

instance Show GraphException where
    show :: GraphException -> [Char]
show GraphException{e
[Char]
[[Char]]
inner :: e
stack :: [[Char]]
target :: [Char]
inner :: ()
stack :: GraphException -> [[Char]]
target :: GraphException -> [Char]
..} = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
        [[Char]
"GraphException: " forall a. [a] -> [a] -> [a]
++ [Char]
target] forall a. [a] -> [a] -> [a]
++
        [[Char]]
stack forall a. [a] -> [a] -> [a]
++
        [[Char]
"Inner exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show e
inner]

fromGraphException :: Typeable b => SomeException -> Maybe b
fromGraphException :: forall b. Typeable b => SomeException -> Maybe b
fromGraphException SomeException
x = do
    GraphException [Char]
_ [[Char]]
_ e
e <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

---------------------------------------------------------------------
-- CALL STACK

data Stack = Stack [Key] !KeySet

instance Show Stack where
    show :: Stack -> [Char]
show (Stack [Key]
kk KeySet
_) = [Char]
"Stack: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" -> " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Key]
kk)

newtype StackException = StackException Stack
  deriving (Typeable, Int -> StackException -> ShowS
[StackException] -> ShowS
StackException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [StackException] -> ShowS
$cshowList :: [StackException] -> ShowS
show :: StackException -> [Char]
$cshow :: StackException -> [Char]
showsPrec :: Int -> StackException -> ShowS
$cshowsPrec :: Int -> StackException -> ShowS
Show)

instance Exception StackException where
    fromException :: SomeException -> Maybe StackException
fromException = forall b. Typeable b => SomeException -> Maybe b
fromGraphException
    toException :: StackException -> SomeException
toException this :: StackException
this@(StackException (Stack [Key]
stack KeySet
_)) = forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$
        forall e. Exception e => [Char] -> [[Char]] -> e -> GraphException
GraphException (forall a. Show a => a -> [Char]
showforall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [Key]
stack) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Key]
stack) StackException
this

addStack :: Key -> Stack -> Either StackException Stack
addStack :: Key -> Stack -> Either StackException Stack
addStack Key
k (Stack [Key]
ks KeySet
is)
    | Key
k Key -> KeySet -> Bool
`memberKeySet` KeySet
is = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Stack -> StackException
StackException Stack
stack2
    | Bool
otherwise = forall a b. b -> Either a b
Right Stack
stack2
    where stack2 :: Stack
stack2 = [Key] -> KeySet -> Stack
Stack (Key
kforall a. a -> [a] -> [a]
:[Key]
ks) (Key -> KeySet -> KeySet
insertKeySet Key
k KeySet
is)

memberStack :: Key -> Stack -> Bool
memberStack :: Key -> Stack -> Bool
memberStack Key
k (Stack [Key]
_ KeySet
ks) = Key
k Key -> KeySet -> Bool
`memberKeySet` KeySet
ks

emptyStack :: Stack
emptyStack :: Stack
emptyStack = [Key] -> KeySet -> Stack
Stack [] forall a. Monoid a => a
mempty
---------------------------------------------------------------------
-- INSTANCES

instance Semigroup a => Semigroup (Rules a) where
    Rules a
a <> :: Rules a -> Rules a -> Rules a
<> Rules a
b = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>) Rules a
a Rules a
b

instance Monoid a => Monoid (Rules a) where
    mempty :: Rules a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty