{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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 Data.Text.Lazy.Builder
import Debug.Trace
import Formatting
import Prelude                                                      hiding ( error )

import GHC.Stack

data Check = Bounds | Unsafe | Internal


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

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

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


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

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

unsafeCheck :: HasCallStack => Builder -> Bool -> a -> a
unsafeCheck :: forall a. HasCallStack => Builder -> Bool -> a -> a
unsafeCheck = (HasCallStack => Builder -> Bool -> a -> a)
-> Builder -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Builder -> Bool -> a -> a)
 -> Builder -> Bool -> a -> a)
-> (HasCallStack => Builder -> Bool -> a -> a)
-> Builder
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> Builder -> Bool -> a -> a
forall a. HasCallStack => Check -> Builder -> 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 :: forall a. HasCallStack => Int -> Int -> a -> a
indexCheck Int
i Int
n =
  Builder -> Bool -> a -> a
forall a. HasCallStack => Builder -> Bool -> a -> a
boundsCheck (Format Builder (Int -> Int -> Builder) -> Int -> Int -> Builder
forall a. Format Builder a -> a
bformat (Format (Int -> Int -> Builder) (Int -> Int -> Builder)
"index out of bounds: i=" Format (Int -> Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Builder) (Int -> Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format (Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Builder) (Int -> Builder)
", n=" Format (Int -> Builder) (Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Builder (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int) 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 :: HasCallStack => Builder -> Bool -> a -> a
internalWarning :: forall a. HasCallStack => Builder -> Bool -> a -> a
internalWarning = (HasCallStack => Builder -> Bool -> a -> a)
-> Builder -> Bool -> a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Builder -> Bool -> a -> a)
 -> Builder -> Bool -> a -> a)
-> (HasCallStack => Builder -> Bool -> a -> a)
-> Builder
-> Bool
-> a
-> a
forall a b. (a -> b) -> a -> b
$ Check -> Builder -> Bool -> a -> a
forall a. HasCallStack => Check -> Builder -> Bool -> a -> a
warning Check
Internal

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

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


error :: HasCallStack => Check -> Format r a -> a
error :: forall r a. HasCallStack => Check -> Format r a -> a
error Check
kind Format r a
fmt = Format r a -> (Builder -> r) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format r a
fmt ((Builder -> r) -> a) -> (Builder -> r) -> a
forall a b. (a -> b) -> a -> b
$ \Builder
msg -> [Char] -> r
forall a. [Char] -> a
errorWithoutStackTrace (HasCallStack => Check -> Builder -> [Char]
Check -> Builder -> [Char]
decorated Check
kind Builder
msg)

check :: HasCallStack => Check -> Builder -> Bool -> a -> a
check :: forall a. HasCallStack => Check -> Builder -> Bool -> a -> a
check Check
kind Builder
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 -> [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace (HasCallStack => Check -> Builder -> [Char]
Check -> Builder -> [Char]
decorated Check
kind Builder
msg)

warning :: HasCallStack => Check -> Builder -> Bool -> a -> a
warning :: forall a. HasCallStack => Check -> Builder -> Bool -> a -> a
warning Check
kind Builder
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 -> [Char] -> a -> a
forall a. [Char] -> a -> a
trace (HasCallStack => Check -> Builder -> [Char]
Check -> Builder -> [Char]
decorated Check
kind Builder
msg) a
k

decorated :: HasCallStack => Check -> Builder -> String
decorated :: HasCallStack => Check -> Builder -> [Char]
decorated Check
kind Builder
msg = Format [Char] ([Builder] -> [Char]) -> [Builder] -> [Char]
forall a. Format [Char] a -> a
formatToString (Text
-> Format Builder (Builder -> Builder)
-> Format [Char] ([Builder] -> [Char])
forall (t :: * -> *) a r.
Foldable t =>
Text -> Format Builder (a -> Builder) -> Format r (t a -> r)
intercalated Text
"\n" Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder) [ Builder
header, Builder
msg, CallStack -> Builder
ppCallStack CallStack
HasCallStack => CallStack
callStack ]
  where
    header :: Builder
header =
      case Check
kind of
        Check
Internal -> Format Builder ([Builder] -> Builder) -> [Builder] -> Builder
forall a. Format Builder a -> a
bformat (Text
-> Format Builder (Builder -> Builder)
-> Format Builder ([Builder] -> Builder)
forall (t :: * -> *) a r.
Foldable t =>
Text -> Format Builder (a -> Builder) -> Format r (t a -> r)
intercalated Text
"\n" Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder)
                      [Builder
""
                      ,Builder
"*** Internal error in package accelerate ***"
                      ,Builder
"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"
                      ,Builder
""
                      ]
        Check
_        -> Builder
forall a. Monoid a => a
mempty

ppCallStack :: CallStack -> Builder
ppCallStack :: CallStack -> Builder
ppCallStack = CallStack -> Builder
ppLines
  where
    ppLines :: CallStack -> Builder
ppLines CallStack
cs =
      case CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
cs of
        [] -> Builder
forall a. Monoid a => a
mempty
        [([Char], SrcLoc)]
st -> Format Builder ([([Char], SrcLoc)] -> Builder)
-> [([Char], SrcLoc)] -> Builder
forall a. Format Builder a -> a
bformat (Format
  ([([Char], SrcLoc)] -> Builder) ([([Char], SrcLoc)] -> Builder)
"CallStack (from HasCallStack):\n" Format
  ([([Char], SrcLoc)] -> Builder) ([([Char], SrcLoc)] -> Builder)
-> Format Builder ([([Char], SrcLoc)] -> Builder)
-> Format Builder ([([Char], SrcLoc)] -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int
-> Format Builder (([Char], SrcLoc) -> Builder)
-> Format Builder ([([Char], SrcLoc)] -> Builder)
forall (t :: * -> *) a r.
Foldable t =>
Int -> Format Builder (a -> Builder) -> Format r (t a -> r)
indentedLines Int
2 ((([Char], SrcLoc) -> Builder)
-> Format Builder (([Char], SrcLoc) -> Builder)
forall a r. (a -> Builder) -> Format r (a -> r)
later ([Char], SrcLoc) -> Builder
ppCallSite)) [([Char], SrcLoc)]
st

    ppCallSite :: ([Char], SrcLoc) -> Builder
ppCallSite ([Char]
fun, SrcLoc
loc) =
      Format Builder ([Char] -> Builder -> Builder)
-> [Char] -> Builder -> Builder
forall a. Format Builder a -> a
bformat (Format (Builder -> Builder) ([Char] -> Builder -> Builder)
forall r. Format r ([Char] -> r)
string Format (Builder -> Builder) ([Char] -> Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder ([Char] -> Builder -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Builder -> Builder) (Builder -> Builder)
": " Format (Builder -> Builder) (Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder (Builder -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Builder (Builder -> Builder)
forall a r. Buildable a => Format r (a -> r)
build)
        [Char]
fun
        (SrcLoc -> Builder
ppSrcLoc SrcLoc
loc)

    ppSrcLoc :: SrcLoc -> Builder
ppSrcLoc SrcLoc{Int
[Char]
srcLocPackage :: [Char]
srcLocModule :: [Char]
srcLocFile :: [Char]
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
srcLocPackage :: SrcLoc -> [Char]
srcLocModule :: SrcLoc -> [Char]
srcLocFile :: SrcLoc -> [Char]
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
..} =
      Format Builder ([Char] -> Int -> Int -> Builder)
-> [Char] -> Int -> Int -> Builder
forall a. Format Builder a -> a
bformat (Format (Int -> Int -> Builder) ([Char] -> Int -> Int -> Builder)
forall r. Format r ([Char] -> r)
string Format (Int -> Int -> Builder) ([Char] -> Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder ([Char] -> Int -> Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Int -> Builder) (Int -> Int -> Builder)
":" Format (Int -> Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Builder) (Int -> Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format (Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Builder) (Int -> Builder)
":" Format (Int -> Builder) (Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Builder (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int)
        [Char]
srcLocModule
        Int
srcLocStartLine
        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