{-# 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 {fromAction :: RAW Global Local a}
    deriving (Functor, Applicative, Monad, MonadIO, Typeable
#if __GLASGOW_HASKELL__ >= 800
             ,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 (Eq,Show)

instance NFData RunChanged where rnf x = x `seq` ()


-- | The result of 'BuiltinRun'.
data RunResult value = RunResult
    {runChanged :: RunChanged
        -- ^ What has changed from the previous time.
    ,runStore :: BS.ByteString
        -- ^ Return the new value to store. Often a serialised version of 'runValue'.
    ,runValue :: value
        -- ^ Return the produced value.
    } deriving Functor

instance NFData value => NFData (RunResult value) where
    rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf 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
    {builtinRun :: BuiltinRun Key Value
    ,builtinLint :: BuiltinLint Key Value
    ,builtinResult :: TypeRep
    ,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 (Eq,Show,Functor,Typeable)


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

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

newLocal :: Stack -> Verbosity -> Local
newLocal stack verb = Local stack verb Nothing [] 0 [] [] []

-- Clear all the local mutable variables
localClearMutable :: Local -> Local
localClearMutable Local{..} = (newLocal localStack localVerbosity){localBlockApply=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 root xs = Local
    -- immutable/stack that need copying
    {localStack = localStack root
    ,localVerbosity = localVerbosity root
    ,localBlockApply = localBlockApply root
    -- mutable locals that need integrating
        -- note that a lot of the lists are stored in reverse, assume root happened first
    ,localDepends =  concatMap localDepends xs ++ localDepends root
    ,localDiscount = localDiscount root + maximum (0:map localDiscount xs)
    ,localTraces = concatMap localTraces xs ++ localTraces root
    ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows xs
    ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed xs
    }