{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Error
-- Copyright   : [2009..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Error (

  HasCallStack,
  internalError,   boundsError,   unsafeError,
  internalCheck,   boundsCheck,   unsafeCheck,   indexCheck,
  internalWarning, boundsWarning, unsafeWarning,

) where

import Debug.Trace
import Data.List                                          ( intercalate )
import Text.Printf
import Prelude                                            hiding ( error )

import GHC.Stack

data Check = Bounds | Unsafe | Internal


-- | Issue an internal error message
--
internalError :: HasCallStack => String -> a
internalError :: String -> a
internalError = (HasCallStack => String -> a) -> String -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> a) -> String -> a)
-> (HasCallStack => String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> a
forall a. HasCallStack => Check -> String -> a
error Check
Internal

boundsError :: HasCallStack => String -> a
boundsError :: String -> a
boundsError = (HasCallStack => String -> a) -> String -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> a) -> String -> a)
-> (HasCallStack => String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> a
forall a. HasCallStack => Check -> String -> a
error Check
Bounds

unsafeError :: HasCallStack => String -> a
unsafeError :: String -> a
unsafeError = (HasCallStack => String -> a) -> String -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> a) -> String -> a)
-> (HasCallStack => String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> a
forall a. HasCallStack => Check -> String -> a
error Check
Unsafe


-- | Throw an error if the condition evaluates to False, otherwise evaluate the
-- result.
--
--   $internalCheck :: String -> String -> Bool -> a -> a
--
internalCheck :: HasCallStack => String -> Bool -> a -> a
internalCheck :: String -> Bool -> a -> a
internalCheck = (HasCallStack => String -> Bool -> a -> a)
-> String -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Bool -> a -> a)
 -> String -> Bool -> a -> a)
-> (HasCallStack => String -> Bool -> a -> a)
-> String
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> Bool -> a -> a
forall a. HasCallStack => Check -> String -> Bool -> a -> a
check Check
Internal

boundsCheck :: HasCallStack => String -> Bool -> a -> a
boundsCheck :: String -> Bool -> a -> a
boundsCheck = (HasCallStack => String -> Bool -> a -> a)
-> String -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Bool -> a -> a)
 -> String -> Bool -> a -> a)
-> (HasCallStack => String -> Bool -> a -> a)
-> String
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> Bool -> a -> a
forall a. HasCallStack => Check -> String -> Bool -> a -> a
check Check
Bounds

unsafeCheck :: HasCallStack => String -> Bool -> a -> a
unsafeCheck :: String -> Bool -> a -> a
unsafeCheck = (HasCallStack => String -> Bool -> a -> a)
-> String -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Bool -> a -> a)
 -> String -> Bool -> a -> a)
-> (HasCallStack => String -> Bool -> a -> a)
-> String
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> Bool -> a -> a
forall a. HasCallStack => Check -> String -> Bool -> a -> a
check Check
Unsafe


-- | Throw an error if the index is not in range, otherwise evaluate the result.
--
indexCheck :: HasCallStack => Int -> Int -> a -> a
indexCheck :: Int -> Int -> a -> a
indexCheck Int
i Int
n =
  String -> Bool -> a -> a
forall a. HasCallStack => String -> Bool -> a -> a
boundsCheck (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"index out of bounds: i=%d, n=%d" Int
i Int
n) (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n)

-- | Print a warning message if the condition evaluates to False.
--
--   $internalWarning :: String -> String -> Bool -> a -> a
--
internalWarning :: HasCallStack => String -> Bool -> a -> a
internalWarning :: String -> Bool -> a -> a
internalWarning = (HasCallStack => String -> Bool -> a -> a)
-> String -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Bool -> a -> a)
 -> String -> Bool -> a -> a)
-> (HasCallStack => String -> Bool -> a -> a)
-> String
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> Bool -> a -> a
forall a. HasCallStack => Check -> String -> Bool -> a -> a
warning Check
Internal

boundsWarning :: HasCallStack => String -> Bool -> a -> a
boundsWarning :: String -> Bool -> a -> a
boundsWarning = (HasCallStack => String -> Bool -> a -> a)
-> String -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Bool -> a -> a)
 -> String -> Bool -> a -> a)
-> (HasCallStack => String -> Bool -> a -> a)
-> String
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> Bool -> a -> a
forall a. HasCallStack => Check -> String -> Bool -> a -> a
warning Check
Bounds

unsafeWarning :: HasCallStack => String -> Bool -> a -> a
unsafeWarning :: String -> Bool -> a -> a
unsafeWarning = (HasCallStack => String -> Bool -> a -> a)
-> String -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Bool -> a -> a)
 -> String -> Bool -> a -> a)
-> (HasCallStack => String -> Bool -> a -> a)
-> String
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> String -> Bool -> a -> a
forall a. HasCallStack => Check -> String -> Bool -> a -> a
warning Check
Unsafe


error :: HasCallStack => Check -> String -> a
error :: Check -> String -> a
error Check
kind String
msg = String -> a
forall a. String -> a
errorWithoutStackTrace (HasCallStack => Check -> String -> String
Check -> String -> String
format Check
kind String
msg)

check :: HasCallStack => Check -> String -> Bool -> a -> a
check :: Check -> String -> Bool -> a -> a
check Check
kind String
msg Bool
cond a
k =
  case Bool -> Bool
not (Check -> Bool
doChecks Check
kind) Bool -> Bool -> Bool
|| Bool
cond of
    Bool
True  -> a
k
    Bool
False -> String -> a
forall a. String -> a
errorWithoutStackTrace (HasCallStack => Check -> String -> String
Check -> String -> String
format Check
kind String
msg)

warning :: HasCallStack => Check -> String -> Bool -> a -> a
warning :: Check -> String -> Bool -> a -> a
warning Check
kind String
msg Bool
cond a
k =
  case Bool -> Bool
not (Check -> Bool
doChecks Check
kind) Bool -> Bool -> Bool
|| Bool
cond of
    Bool
True  -> a
k
    Bool
False -> String -> a -> a
forall a. String -> a -> a
trace (HasCallStack => Check -> String -> String
Check -> String -> String
format Check
kind String
msg) a
k

format :: HasCallStack => Check -> String -> String
format :: Check -> String -> String
format Check
kind String
msg = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [ String
header, String
msg, CallStack -> String
ppCallStack CallStack
HasCallStack => CallStack
callStack ]
  where
    header :: String
header
      = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ case Check
kind of
          Check
Internal -> [String
""
                      ,String
"*** Internal error in package accelerate ***"
                      ,String
"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"
                      ,String
""]
          Check
_        -> []

ppCallStack :: CallStack -> String
ppCallStack :: CallStack -> String
ppCallStack = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> (CallStack -> [String]) -> CallStack -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [String]
ppLines
  where
    ppLines :: CallStack -> [String]
ppLines CallStack
cs =
      case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
        [] -> []
        [(String, SrcLoc)]
st -> String
""
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"CallStack (from HasCallStack):"
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String, SrcLoc) -> String) -> [(String, SrcLoc)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((String, SrcLoc) -> String) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> String
ppCallSite) [(String, SrcLoc)]
st

    ppCallSite :: (String, SrcLoc) -> String
ppCallSite (String
f, SrcLoc
loc) = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
ppSrcLoc SrcLoc
loc

    ppSrcLoc :: SrcLoc -> String
ppSrcLoc SrcLoc{Int
String
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..} =
      (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
""
        [ String
srcLocModule, String
":"
        , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine, String
":"
        , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartCol
        ]

-- CPP malarky
-- -----------

{-# INLINE doChecks #-}
doChecks :: Check -> Bool
doChecks :: Check -> Bool
doChecks Check
Bounds   = Bool
doBoundsChecks
doChecks Check
Unsafe   = Bool
doUnsafeChecks
doChecks Check
Internal = Bool
doInternalChecks

doBoundsChecks :: Bool
#ifdef ACCELERATE_BOUNDS_CHECKS
doBoundsChecks :: Bool
doBoundsChecks = Bool
True
#else
doBoundsChecks = False
#endif

doUnsafeChecks :: Bool
#ifdef ACCELERATE_UNSAFE_CHECKS
doUnsafeChecks = True
#else
doUnsafeChecks :: Bool
doUnsafeChecks = Bool
False
#endif

doInternalChecks :: Bool
#ifdef ACCELERATE_INTERNAL_CHECKS
doInternalChecks = True
#else
doInternalChecks :: Bool
doInternalChecks = Bool
False
#endif