{-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards, CPP #-}
module Development.Shake.Internal.Errors(
ShakeException(..),
errorInternal,
errorStructured,
errorNoRuleToBuildType, errorRuleDefinedMultipleTimes,
errorMultipleRulesMatch, errorRuleRecursion, errorComplexRecursion, errorNoApply,
errorDirectoryNotFile
) where
import Data.Tuple.Extra
import Control.Exception.Extra
import Data.Typeable
import Data.List
errorInternal :: String -> a
errorInternal :: String -> a
errorInternal msg :: String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "Development.Shake: Internal error, please report to Neil Mitchell (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
alternatives :: [(String, String)]
alternatives = let * :: a -> b -> (a, b)
(*) = (,) in
["_rule_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "oracle"
,"_Rule_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "Oracle"
,"_key_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "question"
,"_Key_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "Question"
,"_result_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "answer"
,"_Result_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "Answer"
,"_addBuiltinRule_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "addOracle"
,"_apply_" String -> String -> (String, String)
forall a b. a -> b -> (a, b)
* "askOracle"]
errorStructured :: String -> [(String, Maybe String)] -> String -> IO a
errorStructured :: String -> [(String, Maybe String)] -> String -> IO a
errorStructured msg :: String
msg args :: [(String, Maybe String)]
args hint :: String
hint = String -> IO a
forall a. HasCallStack => String -> IO a
errorIO (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> String
errorStructuredContents String
msg [(String, Maybe String)]
args String
hint
errorStructuredContents :: String -> [(String, Maybe String)] -> String -> String
errorStructuredContents :: String -> [(String, Maybe String)] -> String -> String
errorStructuredContents msg :: String
msg args :: [(String, Maybe String)]
args hint :: String
hint = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ [':' | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ""] String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) ' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b | (a :: String
a,b :: String
b) <- [(String, String)]
args2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[String
hint | String
hint String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ""]
where
as :: Int
as = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ 0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((String, String) -> Int) -> [(String, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, String) -> String) -> (String, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
args2
args2 :: [(String, String)]
args2 = [(String
a,String
b) | (a :: String
a,Just b :: String
b) <- [(String, Maybe String)]
args]
structured :: Bool -> String -> [(String, Maybe String)] -> String -> IO a
structured :: Bool -> String -> [(String, Maybe String)] -> String -> IO a
structured alt :: Bool
alt msg :: String
msg args :: [(String, Maybe String)]
args hint :: String
hint = String -> [(String, Maybe String)] -> String -> IO a
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured (String -> String
f String
msg) (((String, Maybe String) -> (String, Maybe String))
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String)
-> (String, Maybe String) -> (String, Maybe String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first String -> String
f) [(String, Maybe String)]
args) (String -> String
f String
hint)
where
f :: String -> String
f = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '_') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
alt then String -> String
g else String -> String
forall a. a -> a
id)
g :: String -> String
g xs :: String
xs | (a :: String
a,b :: String
b):_ <- ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a :: String
a,b :: String
b) -> String
a String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs) [(String, String)]
alternatives = String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
g (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a) String
xs)
g (x :: Char
x:xs :: String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
g String
xs
g [] = []
errorDirectoryNotFile :: FilePath -> IO a
errorDirectoryNotFile :: String -> IO a
errorDirectoryNotFile dir :: String
dir = String -> [(String, Maybe String)] -> String -> IO a
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
"Build system error - expected a file, got a directory"
[("Directory", String -> Maybe String
forall a. a -> Maybe a
Just String
dir)]
"Probably due to calling 'need' on a directory. Shake only permits 'need' on files."
errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> IO a
errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> IO a
errorNoRuleToBuildType tk :: TypeRep
tk k :: Maybe String
k tv :: Maybe TypeRep
tv = Bool -> String -> [(String, Maybe String)] -> String -> IO a
forall a.
Bool -> String -> [(String, Maybe String)] -> String -> IO a
structured (TypeRep -> Bool
specialIsOracleKey TypeRep
tk)
"Build system error - no _rule_ matches the _key_ type"
[("_Key_ type", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk)
,("_Key_ value", Maybe String
k)
,("_Result_ type", (TypeRep -> String) -> Maybe TypeRep -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeRep -> String
forall a. Show a => a -> String
show Maybe TypeRep
tv)]
"You are missing a call to _addBuiltinRule_, or your call to _apply_ has the wrong _key_ type"
errorRuleDefinedMultipleTimes :: TypeRep-> IO a
errorRuleDefinedMultipleTimes :: TypeRep -> IO a
errorRuleDefinedMultipleTimes tk :: TypeRep
tk = Bool -> String -> [(String, Maybe String)] -> String -> IO a
forall a.
Bool -> String -> [(String, Maybe String)] -> String -> IO a
structured (TypeRep -> Bool
specialIsOracleKey TypeRep
tk)
"Build system error - _rule_ defined twice at one _key_ type"
[("_Key_ type", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk)]
"You have called _addBuiltinRule_ more than once on the same key type"
errorMultipleRulesMatch :: TypeRep -> String -> Int -> IO a
errorMultipleRulesMatch :: TypeRep -> String -> Int -> IO a
errorMultipleRulesMatch tk :: TypeRep
tk k :: String
k count :: Int
count
| TypeRep -> Bool
specialIsOracleKey TypeRep
tk, Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 =
String -> IO a
forall a. String -> a
errorInternal (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ "no oracle match for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk
| TypeRep -> Bool
specialIsOracleKey TypeRep
tk = String -> [(String, Maybe String)] -> String -> IO a
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
"Build system error - duplicate oracles for the same question type"
[("Question type",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk)
,("Question value",String -> Maybe String
forall a. a -> Maybe a
Just String
k)]
"Only one call to addOracle is allowed per question type"
| Bool
otherwise = String -> [(String, Maybe String)] -> String -> IO a
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
("Build system error - key matches " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then "no" else "multiple") String -> String -> String
forall a. [a] -> [a] -> [a]
++ " rules")
[("Key type",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk)
,("Key value",String -> Maybe String
forall a. a -> Maybe a
Just String
k)
,("Rules matched",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
count)]
(if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then "Either add a rule that produces the above key, or stop requiring the above key"
else "Modify your rules/defaultRules so only one can produce the above key")
errorRuleRecursion :: [String] -> TypeRep -> String -> IO a
errorRuleRecursion :: [String] -> TypeRep -> String -> IO a
errorRuleRecursion stack :: [String]
stack tk :: TypeRep
tk k :: String
k = SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeException -> IO a) -> SomeException -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> SomeException
wrap (SomeException -> SomeException) -> SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (ErrorCall -> SomeException) -> ErrorCall -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> String -> String
errorStructuredContents
"Build system error - recursion detected"
[("Key type",String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk)
,("Key value",String -> Maybe String
forall a. a -> Maybe a
Just String
k)]
"Rules may not be recursive"
where
wrap :: SomeException -> SomeException
wrap = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
stack then SomeException -> SomeException
forall a. a -> a
id else ShakeException -> SomeException
forall e. Exception e => e -> SomeException
toException (ShakeException -> SomeException)
-> (SomeException -> ShakeException)
-> SomeException
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> SomeException -> ShakeException
ShakeException ([String] -> String
forall a. [a] -> a
last [String]
stack) [String]
stack
errorComplexRecursion :: [String] -> IO a
errorComplexRecursion :: [String] -> IO a
errorComplexRecursion ks :: [String]
ks = String -> [(String, Maybe String)] -> String -> IO a
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
"Build system error - indirect recursion detected"
[("Key value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i, String -> Maybe String
forall a. a -> Maybe a
Just String
k) | (i :: Integer
i, k :: String
k) <- [Integer] -> [String] -> [(Integer, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [String]
ks]
"Rules may not be recursive"
errorNoApply :: TypeRep -> Maybe String -> String -> IO a
errorNoApply :: TypeRep -> Maybe String -> String -> IO a
errorNoApply tk :: TypeRep
tk k :: Maybe String
k msg :: String
msg = Bool -> String -> [(String, Maybe String)] -> String -> IO a
forall a.
Bool -> String -> [(String, Maybe String)] -> String -> IO a
structured (TypeRep -> Bool
specialIsOracleKey TypeRep
tk)
"Build system error - cannot currently call _apply_"
[("Reason", String -> Maybe String
forall a. a -> Maybe a
Just String
msg)
,("_Key_ type", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
tk)
,("_Key_ value", Maybe String
k)]
"Move the _apply_ call earlier/later"
specialIsOracleKey :: TypeRep -> Bool
specialIsOracleKey :: TypeRep -> Bool
specialIsOracleKey t :: TypeRep
t = String
con String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "OracleQ"
where con :: String
con = TyCon -> String
forall a. Show a => a -> String
show (TyCon -> String) -> TyCon -> String
forall a b. (a -> b) -> a -> b
$ (TyCon, [TypeRep]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [TypeRep]) -> TyCon) -> (TyCon, [TypeRep]) -> TyCon
forall a b. (a -> b) -> a -> b
$ TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t
data ShakeException = ShakeException
{ShakeException -> String
shakeExceptionTarget :: String
,ShakeException -> [String]
shakeExceptionStack :: [String]
,ShakeException -> SomeException
shakeExceptionInner :: SomeException
}
deriving Typeable
instance Exception ShakeException
instance Show ShakeException where
show :: ShakeException -> String
show ShakeException{..} = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
"Error when running Shake build system:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("* " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
shakeExceptionStack [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
shakeExceptionInner]