{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards, FlexibleInstances #-}
module Development.Shake.Internal.Core.Types(
BuiltinRun, BuiltinLint, BuiltinIdentity,
RunMode(..), RunResult(..), RunChanged(..),
UserRule(..), UserRuleVersioned(..),
BuiltinRule(..), Global(..), Local(..), Action(..), runAction, addDiscount,
newLocal, localClearMutable, localMergeMutable,
Stack, Step(..), Result(..), Database(..), Depends(..), Status(..), Trace(..), BS_Store,
getResult, exceptionStack, statusType, addStack, addCallStack,
incStep, newTrace, nubDepends, emptyStack, topStack, showTopStack,
stepKey, StepKey(..), toStepResult, fromStepResult, NoShow(..)
) where
import Control.Monad.IO.Class
import Control.Applicative
import Control.DeepSeq
import Foreign.Storable
import Data.Word
import Data.Typeable
import General.Binary
import Control.Exception
import Data.Maybe
import General.Extra
import Control.Concurrent.Extra
import Development.Shake.Internal.History.Shared
import Development.Shake.Internal.History.Cloud
import Development.Shake.Internal.History.Types
import General.Wait
import Development.Shake.Internal.Errors
import qualified General.TypeMap as TMap
import Data.IORef
import qualified Data.ByteString.Char8 as BS
import Numeric.Extra
import System.Time.Extra
import General.Intern(Id, Intern)
import qualified Data.HashSet as Set
import qualified Data.HashMap.Strict as Map
import qualified General.Ids as Ids
import Data.Tuple.Extra
import General.Pool
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Value
import Development.Shake.Internal.Options
import Development.Shake.Classes
import Data.Semigroup
import General.Cleanup
import Prelude
#if __GLASGOW_HASKELL__ >= 800
import Control.Monad.Fail
#endif
newtype Action a = Action {fromAction :: RAW Global Local a}
deriving (Functor, Applicative, Monad, MonadIO, Typeable, Semigroup, Monoid
#if __GLASGOW_HASKELL__ >= 800
,MonadFail
#endif
)
runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)
runAction g l (Action x) = runRAW g l x
data RunMode
= RunDependenciesSame
| RunDependenciesChanged
deriving (Eq,Show)
instance NFData RunMode where rnf x = x `seq` ()
data RunChanged
= ChangedNothing
| ChangedStore
| ChangedRecomputeSame
| ChangedRecomputeDiff
deriving (Eq,Show)
instance NFData RunChanged where rnf x = x `seq` ()
data RunResult value = RunResult
{runChanged :: RunChanged
,runStore :: BS.ByteString
,runValue :: value
} deriving Functor
instance NFData value => NFData (RunResult value) where
rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3
newtype Step = Step Word32 deriving (Eq,Ord,Show,Storable,BinaryEx,NFData,Hashable,Typeable)
incStep (Step i) = Step $ i + 1
newtype StepKey = StepKey ()
deriving (Show,Eq,Typeable,Hashable,Binary,BinaryEx,NFData)
stepKey :: Key
stepKey = newKey $ StepKey ()
toStepResult :: Step -> Result (Value, BS_Store)
toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] 0 []
fromStepResult :: Result BS_Store -> Step
fromStepResult = getEx . result
data Stack = Stack (Maybe Key) [Either Key [String]] !(Set.HashSet Id) deriving Show
exceptionStack :: Stack -> SomeException -> ShakeException
exceptionStack stack@(Stack _ xs _) = ShakeException (showTopStack stack) $
concatMap f (reverse xs) ++ ["* Raised the exception:" | not $ null xs]
where
f (Left x) = ["* Depends on: " ++ show x]
f (Right x) = map (" at " ++) x
showTopStack :: Stack -> String
showTopStack = maybe "<unknown>" show . topStack
addStack :: Id -> Key -> Stack -> Either SomeException Stack
addStack i k (Stack _ ks is)
| i `Set.member` is = Left $ toException $ exceptionStack stack2 $ errorRuleRecursion (typeKey k) (show k)
| otherwise = Right stack2
where stack2 = Stack (Just k) (Left k:ks) (Set.insert i is)
addCallStack :: [String] -> Stack -> Stack
addCallStack xs (Stack t a b) = Stack t (Right xs : dropWhile (== Right xs) a) b
topStack :: Stack -> Maybe Key
topStack (Stack t _ _) = t
emptyStack :: Stack
emptyStack = Stack Nothing [] Set.empty
data Trace = Trace
{traceMessage :: {-# UNPACK #-} !BS.ByteString
,traceStart :: {-# UNPACK #-} !Float
,traceEnd :: {-# UNPACK #-} !Float
}
deriving Show
instance NFData Trace where
rnf x = x `seq` ()
instance BinaryEx Trace where
putEx (Trace a b c) = putEx b <> putEx c <> putEx a
getEx x | (b,c,a) <- binarySplit2 x = Trace a b c
instance BinaryEx [Trace] where
putEx = putExList . map putEx
getEx = map getEx . getExList
newTrace :: String -> Seconds -> Seconds -> Trace
newTrace msg start stop = Trace (BS.pack msg) (doubleToFloat start) (doubleToFloat stop)
newtype NoShow a = NoShow a
instance Show (NoShow a) where show _ = "NoShow"
type OneShot a = a
data Status
= Ready (Result (Value, OneShot BS_Store))
| Error SomeException (OneShot (Maybe (Result BS_Store)))
| Loaded (Result BS_Store)
| Running (NoShow (Either SomeException (Result (Value, BS_Store)) -> Locked ())) (Maybe (Result BS_Store))
| Missing
deriving Show
instance NFData Status where
rnf x = case x of
Ready x -> rnfResult (\(a,b) -> b `seq` rnf a) x
Error x y -> rnfException x `seq` maybe () (rnfResult id) y
Loaded x -> rnfResult id x
Running _ x -> maybe () (rnfResult id) x
Missing -> ()
where
rnfException = rnf . show
rnfResult by (Result a _ _ b _ c) = by a `seq` rnf b `seq` rnf c `seq` ()
{-# INLINE rnfResult #-}
data Result a = Result
{result :: a
,built :: {-# UNPACK #-} !Step
,changed :: {-# UNPACK #-} !Step
,depends :: [Depends]
,execution :: {-# UNPACK #-} !Float
,traces :: [Trace]
} deriving (Show,Functor)
statusType Ready{} = "Ready"
statusType Error{} = "Error"
statusType Loaded{} = "Loaded"
statusType Running{} = "Running"
statusType Missing{} = "Missing"
getResult :: Status -> Maybe (Result (Either BS_Store Value))
getResult (Ready r) = Just $ Right . fst <$> r
getResult (Loaded r) = Just $ Left <$> r
getResult (Running _ r) = fmap Left <$> r
getResult _ = Nothing
newtype Depends = Depends {fromDepends :: [Id]}
deriving NFData
instance Show Depends where
show = show . fromDepends
instance BinaryEx Depends where
putEx (Depends xs) = putExStorableList xs
getEx = Depends . getExStorableList
instance BinaryEx [Depends] where
putEx = putExList . map putEx
getEx = map getEx . getExList
nubDepends :: [Depends] -> [Depends]
nubDepends = fMany Set.empty
where
fMany _ [] = []
fMany seen (Depends d:ds) = [Depends d2 | d2 /= []] ++ fMany seen2 ds
where (d2,seen2) = fOne seen d
fOne seen [] = ([], seen)
fOne seen (x:xs) | x `Set.member` seen = fOne seen xs
fOne seen (x:xs) = first (x:) $ fOne (Set.insert x seen) xs
type BuiltinRun key value
= key
-> Maybe BS.ByteString
-> RunMode
-> Action (RunResult value)
type BuiltinLint key value = key -> value -> IO (Maybe String)
type BuiltinIdentity key value = key -> value -> BS.ByteString
data BuiltinRule = BuiltinRule
{builtinLint :: BuiltinLint Key Value
,builtinIdentity :: BuiltinIdentity Key Value
,builtinRun :: BuiltinRun Key Value
,builtinKey :: BinaryOp Key
,builtinVersion :: Ver
,builtinLocation :: String
}
data UserRule a
= UserRule a
| Unordered [UserRule a]
| Priority Double (UserRule a)
| Alternative (UserRule a)
| Versioned Ver (UserRule a)
deriving (Eq,Show,Functor,Typeable)
data UserRuleVersioned a = UserRuleVersioned
{userRuleVersioned :: Bool
,userRuleContents :: UserRule a
}
instance Semigroup (UserRuleVersioned a) where
UserRuleVersioned b1 x1 <> UserRuleVersioned b2 x2 = UserRuleVersioned (b1 || b2) (x1 <> x2)
instance Monoid (UserRuleVersioned a) where
mempty = UserRuleVersioned False mempty
mappend = (<>)
instance Semigroup (UserRule a) where
x <> y = Unordered $ fromUnordered x ++ fromUnordered y
where
fromUnordered (Unordered xs) = xs
fromUnordered x = [x]
instance Monoid (UserRule a) where
mempty = Unordered []
mappend = (<>)
data Database = Database
{intern :: IORef (Intern Key)
,status :: Ids.Ids (Key, Status)
,journal :: Id -> Key -> Result BS_Store -> IO ()
}
data Global = Global
{globalDatabase :: Var Database
,globalPool :: Pool
,globalCleanup :: Cleanup
,globalTimestamp :: IO Seconds
,globalRules :: Map.HashMap TypeRep BuiltinRule
,globalOutput :: Verbosity -> String -> IO ()
,globalOptions :: ShakeOptions
,globalDiagnostic :: IO String -> IO ()
,globalCurDir :: FilePath
,globalAfter :: IORef [IO ()]
,globalTrackAbsent :: IORef [(Key, Key)]
,globalProgress :: IO Progress
,globalUserRules :: TMap.Map UserRuleVersioned
,globalShared :: Maybe Shared
,globalCloud :: Maybe Cloud
,globalStep :: {-# UNPACK #-} !Step
,globalOneShot :: Bool
}
data Local = Local
{localStack :: Stack
,localBuiltinVersion :: Ver
,localVerbosity :: Verbosity
,localBlockApply :: Maybe String
,localDepends :: [Depends]
,localDiscount :: !Seconds
,localTraces :: [Trace]
,localTrackAllows :: [Key -> Bool]
,localTrackUsed :: [Key]
,localProduces :: [(Bool, FilePath)]
,localHistory :: !Bool
}
addDiscount :: Seconds -> Local -> Local
addDiscount s l = l{localDiscount = s + localDiscount l}
newLocal :: Stack -> Verbosity -> Local
newLocal stack verb = Local stack (Ver 0) verb Nothing [] 0 [] [] [] [] True
localClearMutable :: Local -> Local
localClearMutable Local{..} = (newLocal localStack localVerbosity){localBlockApply=localBlockApply, localBuiltinVersion=localBuiltinVersion}
localMergeMutable :: Local -> [Local] -> Local
localMergeMutable root xs = Local
{localStack = localStack root
,localBuiltinVersion = localBuiltinVersion root
,localVerbosity = localVerbosity root
,localBlockApply = localBlockApply root
,localDepends = concatMap localDepends xs ++ localDepends root
,localDiscount = sum $ map localDiscount $ root : xs
,localTraces = concatMap localTraces xs ++ localTraces root
,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows xs
,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed xs
,localProduces = concatMap localProduces xs ++ localProduces root
,localHistory = all localHistory $ root:xs
}