{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards #-}

module Development.Shake.Internal.Core.Types(
    BuiltinRun, BuiltinLint, RunResult(..), RunChanged(..),
    UserRule(..), UserRule_(..),
    BuiltinRule(..), Global(..), Local(..), Action(..),
    newLocal, localClearMutable, localMergeMutable
    ) where

import Control.DeepSeq
import Control.Monad.IO.Class
import Control.Applicative
import Data.Typeable
import General.Binary
import qualified Data.HashMap.Strict as Map
import Data.IORef
import qualified Data.ByteString as BS
import System.Time.Extra

import Development.Shake.Internal.Core.Pool
import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Value
import Development.Shake.Internal.Options
import General.Cleanup
import Prelude

#if __GLASGOW_HASKELL__ >= 800
import Control.Monad.Fail
#endif


---------------------------------------------------------------------
-- UNDERLYING DATA TYPE

-- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files.
--   Action values are used by 'addUserRule' and 'action'. The 'Action' monad tracks the dependencies of a rule.
--   To raise an exception call 'error', 'fail' or @'liftIO' . 'throwIO'@.
newtype Action a = Action {Action a -> RAW Global Local a
fromAction :: RAW Global Local a}
    deriving (a -> Action b -> Action a
(a -> b) -> Action a -> Action b
(forall a b. (a -> b) -> Action a -> Action b)
-> (forall a b. a -> Action b -> Action a) -> Functor Action
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
<$ :: a -> Action b -> Action a
$c<$ :: forall a b. a -> Action b -> Action a
fmap :: (a -> b) -> Action a -> Action b
$cfmap :: forall a b. (a -> b) -> Action a -> Action b
Functor, Functor Action
a -> Action a
Functor Action =>
(forall a. a -> Action a)
-> (forall a b. Action (a -> b) -> Action a -> Action b)
-> (forall a b c.
    (a -> b -> c) -> Action a -> Action b -> Action c)
-> (forall a b. Action a -> Action b -> Action b)
-> (forall a b. Action a -> Action b -> Action a)
-> Applicative Action
Action a -> Action b -> Action b
Action a -> Action b -> Action a
Action (a -> b) -> Action a -> Action b
(a -> b -> c) -> Action a -> Action b -> Action c
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
<* :: Action a -> Action b -> Action a
$c<* :: forall a b. Action a -> Action b -> Action a
*> :: Action a -> Action b -> Action b
$c*> :: forall a b. Action a -> Action b -> Action b
liftA2 :: (a -> b -> c) -> Action a -> Action b -> Action c
$cliftA2 :: forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c
<*> :: Action (a -> b) -> Action a -> Action b
$c<*> :: forall a b. Action (a -> b) -> Action a -> Action b
pure :: a -> Action a
$cpure :: forall a. a -> Action a
$cp1Applicative :: Functor Action
Applicative, Applicative Action
a -> Action a
Applicative Action =>
(forall a b. Action a -> (a -> Action b) -> Action b)
-> (forall a b. Action a -> Action b -> Action b)
-> (forall a. a -> Action a)
-> Monad Action
Action a -> (a -> Action b) -> Action b
Action a -> Action b -> Action b
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 :: a -> Action a
$creturn :: forall a. a -> Action a
>> :: Action a -> Action b -> Action b
$c>> :: forall a b. Action a -> Action b -> Action b
>>= :: Action a -> (a -> Action b) -> Action b
$c>>= :: forall a b. Action a -> (a -> Action b) -> Action b
$cp1Monad :: Applicative Action
Monad, Monad Action
Monad Action => (forall a. IO a -> Action a) -> MonadIO Action
IO a -> Action a
forall a. IO a -> Action a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Action a
$cliftIO :: forall a. IO a -> Action a
$cp1MonadIO :: Monad Action
MonadIO, Typeable
#if __GLASGOW_HASKELL__ >= 800
             ,Monad Action
Monad Action => (forall a. String -> Action a) -> MonadFail Action
String -> Action a
forall a. String -> Action a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
fail :: String -> Action a
$cfail :: forall a. String -> Action a
$cp1MonadFail :: Monad Action
MonadFail
#endif
        )

-- | How has a rule changed.
data RunChanged
    = ChangedNothing -- ^ Nothing has changed.
    | ChangedStore -- ^ The persisted value has changed, but in a way that should be considered identical.
    | ChangedRecomputeSame -- ^ I recomputed the value and it was the same.
    | ChangedRecomputeDiff -- ^ I recomputed the value and it was different.
      deriving (RunChanged -> RunChanged -> Bool
(RunChanged -> RunChanged -> Bool)
-> (RunChanged -> RunChanged -> Bool) -> Eq RunChanged
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 -> String
(Int -> RunChanged -> ShowS)
-> (RunChanged -> String)
-> ([RunChanged] -> ShowS)
-> Show RunChanged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunChanged] -> ShowS
$cshowList :: [RunChanged] -> ShowS
show :: RunChanged -> String
$cshow :: RunChanged -> String
showsPrec :: Int -> RunChanged -> ShowS
$cshowsPrec :: Int -> RunChanged -> ShowS
Show)

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


-- | The result of 'BuiltinRun'.
data RunResult value = RunResult
    {RunResult value -> RunChanged
runChanged :: RunChanged
        -- ^ What has changed from the previous time.
    ,RunResult value -> ByteString
runStore :: BS.ByteString
        -- ^ Return the new value to store. Often a serialised version of 'runValue'.
    ,RunResult value -> value
runValue :: value
        -- ^ Return the produced value.
    } deriving a -> RunResult b -> RunResult a
(a -> b) -> RunResult a -> RunResult b
(forall a b. (a -> b) -> RunResult a -> RunResult b)
-> (forall a b. a -> RunResult b -> RunResult a)
-> Functor RunResult
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
<$ :: a -> RunResult b -> RunResult a
$c<$ :: forall a b. a -> RunResult b -> RunResult a
fmap :: (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 x1 :: RunChanged
x1 x2 :: ByteString
x2 x3 :: value
x3) = RunChanged -> ()
forall a. NFData a => a -> ()
rnf RunChanged
x1 () -> () -> ()
forall a b. a -> b -> b
`seq` ByteString
x2 ByteString -> () -> ()
forall a b. a -> b -> b
`seq` value -> ()
forall a. NFData a => a -> ()
rnf value
x3


-- | Define a rule between @key@ and @value@. A rule for a class of artifacts (e.g. /files/) provides:
--
-- * How to identify individual artifacts, given by the @key@ type, e.g. with file names.
--
-- * How to describe the state of an artifact, given by the @value@ type, e.g. the file modification time.
--
-- * How to persist the state of an artifact, using the 'ByteString' values, e.g. seralised @value@.
--
--   The arguments comprise the @key@, the value of the previous serialisation or 'Nothing' if the rule
--   has not been run previously, and 'True' to indicate the dependencies have changed or 'False' that
--   they have not.
type BuiltinRun key value
    = key
    -> Maybe BS.ByteString
    -> Bool
    -> Action (RunResult value)

-- | The action performed by @--lint@ for a given @key@/@value@ pair.
--   At the end of the build the lint action will be called for each @key@ that was built this run,
--   passing the @value@ it produced. Return 'Nothing' to indicate the value has not changed and
--   is acceptable, or 'Just' an error message to indicate failure.
--
--   For builtin rules where the value is expected to change use 'Development.Shake.Rules.noLint'.
type BuiltinLint key value = key -> value -> IO (Maybe String)

data BuiltinRule = BuiltinRule
    {BuiltinRule -> BuiltinRun Key Value
builtinRun :: BuiltinRun Key Value
    ,BuiltinRule -> BuiltinLint Key Value
builtinLint :: BuiltinLint Key Value
    ,BuiltinRule -> TypeRep
builtinResult :: TypeRep
    ,BuiltinRule -> BinaryOp Key
builtinKey :: BinaryOp Key
    }


data UserRule_ = forall a . Typeable a => UserRule_ (UserRule a)

-- | A 'UserRule' data type, representing user-defined rules associated with a particular type.
--   As an example 'Development.Shake.?>' and 'Development.Shake.%>' will add entries to the 'UserRule' data type.
data UserRule a
-- > priority p1 (priority p2 x) == priority p1 x
-- > priority p (x `ordered` y) = priority p x `ordered` priority p y
-- > priority p (x `unordered` y) = priority p x `unordered` priority p y
-- > ordered is associative
-- > unordered is associative and commutative
-- > alternative does not obey priorities, until picking the best one
    = UserRule a -- ^ Added to the state with @'addUserRule' :: Typeable a => a -> 'Rules' ()@.
    | Unordered [UserRule a] -- ^ Rules combined with the 'Monad' \/ 'Monoid'.
    | Priority Double (UserRule a) -- ^ Rules defined under 'priority'.
    | Alternative (UserRule a) -- ^ Rule defined under 'alternatives', matched in order.
      deriving (UserRule a -> UserRule a -> Bool
(UserRule a -> UserRule a -> Bool)
-> (UserRule a -> UserRule a -> Bool) -> Eq (UserRule a)
forall a. Eq a => UserRule a -> UserRule a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserRule a -> UserRule a -> Bool
$c/= :: forall a. Eq a => UserRule a -> UserRule a -> Bool
== :: UserRule a -> UserRule a -> Bool
$c== :: forall a. Eq a => UserRule a -> UserRule a -> Bool
Eq,Int -> UserRule a -> ShowS
[UserRule a] -> ShowS
UserRule a -> String
(Int -> UserRule a -> ShowS)
-> (UserRule a -> String)
-> ([UserRule a] -> ShowS)
-> Show (UserRule a)
forall a. Show a => Int -> UserRule a -> ShowS
forall a. Show a => [UserRule a] -> ShowS
forall a. Show a => UserRule a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserRule a] -> ShowS
$cshowList :: forall a. Show a => [UserRule a] -> ShowS
show :: UserRule a -> String
$cshow :: forall a. Show a => UserRule a -> String
showsPrec :: Int -> UserRule a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> UserRule a -> ShowS
Show,a -> UserRule b -> UserRule a
(a -> b) -> UserRule a -> UserRule b
(forall a b. (a -> b) -> UserRule a -> UserRule b)
-> (forall a b. a -> UserRule b -> UserRule a) -> Functor UserRule
forall a b. a -> UserRule b -> UserRule a
forall a b. (a -> b) -> UserRule a -> UserRule b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UserRule b -> UserRule a
$c<$ :: forall a b. a -> UserRule b -> UserRule a
fmap :: (a -> b) -> UserRule a -> UserRule b
$cfmap :: forall a b. (a -> b) -> UserRule a -> UserRule b
Functor,Typeable)


-- global constants of Action
data Global = Global
    {Global -> Database
globalDatabase :: Database -- ^ Database, contains knowledge of the state of each key
    ,Global -> Pool
globalPool :: Pool -- ^ Pool, for queuing new elements
    ,Global -> Cleanup
globalCleanup :: Cleanup -- ^ Cleanup operations
    ,Global -> IO Seconds
globalTimestamp :: IO Seconds -- ^ Clock saying how many seconds through the build
    ,Global -> HashMap TypeRep BuiltinRule
globalRules :: Map.HashMap TypeRep BuiltinRule -- ^ Rules for this build
    ,Global -> Verbosity -> String -> IO ()
globalOutput :: Verbosity -> String -> IO () -- ^ Output function
    ,Global -> ShakeOptions
globalOptions  :: ShakeOptions -- ^ Shake options
    ,Global -> IO String -> IO ()
globalDiagnostic :: IO String -> IO () -- ^ Debugging function
    ,Global -> String
globalCurDir :: FilePath -- ^ getCurrentDirectory when we started
    ,Global -> IORef [IO ()]
globalAfter :: IORef [IO ()] -- ^ Operations to run on success, e.g. removeFilesAfter
    ,Global -> IORef [(Key, Key)]
globalTrackAbsent :: IORef [(Key, Key)] -- ^ Tracked things, in rule fst, snd must be absent
    ,Global -> IO Progress
globalProgress :: IO Progress -- ^ Request current progress state
    ,Global -> HashMap TypeRep UserRule_
globalUserRules :: Map.HashMap TypeRep UserRule_
    }

-- local variables of Action
data Local = Local
    -- constants
    {Local -> Stack
localStack :: Stack -- ^ The stack that ran to get here.
    -- stack scoped local variables
    ,Local -> Verbosity
localVerbosity :: Verbosity -- ^ Verbosity, may be changed locally
    ,Local -> Maybe String
localBlockApply ::  Maybe String -- ^ Reason to block apply, or Nothing to allow
    -- mutable local variables
    ,Local -> [Depends]
localDepends :: [Depends] -- ^ Dependencies, built up in reverse
    ,Local -> Seconds
localDiscount :: !Seconds -- ^ Time spend building dependencies
    ,Local -> [Trace]
localTraces :: [Trace] -- ^ Traces, built in reverse
    ,Local -> [Key -> Bool]
localTrackAllows :: [Key -> Bool] -- ^ Things that are allowed to be used
    ,Local -> [Key]
localTrackUsed :: [Key] -- ^ Things that have been used
    }

newLocal :: Stack -> Verbosity -> Local
newLocal :: Stack -> Verbosity -> Local
newLocal stack :: Stack
stack verb :: Verbosity
verb = Stack
-> Verbosity
-> Maybe String
-> [Depends]
-> Seconds
-> [Trace]
-> [Key -> Bool]
-> [Key]
-> Local
Local Stack
stack Verbosity
verb Maybe String
forall a. Maybe a
Nothing [] 0 [] [] []

-- Clear all the local mutable variables
localClearMutable :: Local -> Local
localClearMutable :: Local -> Local
localClearMutable Local{..} = (Stack -> Verbosity -> Local
newLocal Stack
localStack Verbosity
localVerbosity){localBlockApply :: Maybe String
localBlockApply=Maybe String
localBlockApply}

-- Merge, works well assuming you clear the variables first
localMergeMutable :: Local -> [Local] -> Local
-- don't construct with RecordWildCards so any new fields raise an error
localMergeMutable :: Local -> [Local] -> Local
localMergeMutable root :: Local
root xs :: [Local]
xs = $WLocal :: Stack
-> Verbosity
-> Maybe String
-> [Depends]
-> Seconds
-> [Trace]
-> [Key -> Bool]
-> [Key]
-> Local
Local
    -- immutable/stack that need copying
    {localStack :: Stack
localStack = Local -> Stack
localStack Local
root
    ,localVerbosity :: Verbosity
localVerbosity = Local -> Verbosity
localVerbosity Local
root
    ,localBlockApply :: Maybe String
localBlockApply = Local -> Maybe String
localBlockApply Local
root
    -- mutable locals that need integrating
        -- note that a lot of the lists are stored in reverse, assume root happened first
    ,localDepends :: [Depends]
localDepends =  (Local -> [Depends]) -> [Local] -> [Depends]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Local -> [Depends]
localDepends [Local]
xs [Depends] -> [Depends] -> [Depends]
forall a. [a] -> [a] -> [a]
++ Local -> [Depends]
localDepends Local
root
    ,localDiscount :: Seconds
localDiscount = Local -> Seconds
localDiscount Local
root Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
+ [Seconds] -> Seconds
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0Seconds -> [Seconds] -> [Seconds]
forall a. a -> [a] -> [a]
:(Local -> Seconds) -> [Local] -> [Seconds]
forall a b. (a -> b) -> [a] -> [b]
map Local -> Seconds
localDiscount [Local]
xs)
    ,localTraces :: [Trace]
localTraces = (Local -> [Trace]) -> [Local] -> [Trace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Local -> [Trace]
localTraces [Local]
xs [Trace] -> [Trace] -> [Trace]
forall a. [a] -> [a] -> [a]
++ Local -> [Trace]
localTraces Local
root
    ,localTrackAllows :: [Key -> Bool]
localTrackAllows = Local -> [Key -> Bool]
localTrackAllows Local
root [Key -> Bool] -> [Key -> Bool] -> [Key -> Bool]
forall a. [a] -> [a] -> [a]
++ (Local -> [Key -> Bool]) -> [Local] -> [Key -> Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Local -> [Key -> Bool]
localTrackAllows [Local]
xs
    ,localTrackUsed :: [Key]
localTrackUsed = Local -> [Key]
localTrackUsed Local
root [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ (Local -> [Key]) -> [Local] -> [Key]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Local -> [Key]
localTrackUsed [Local]
xs
    }