{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      :  Internal.Devel
-- Copyright   :  (c) Alberto Ruiz 2007-15
-- License     :  BSD3
-- Maintainer  :  Alberto Ruiz
-- Stability   :  provisional
--

module Internal.Devel where


import Control.Monad ( when )
import Foreign.C.Types ( CInt )
--import Foreign.Storable.Complex ()
import Foreign.Ptr(Ptr)
import           Control.Exception (SomeException, SomeAsyncException (..))
import qualified Control.Exception as Exception
import Internal.Vector(Vector,avec)
import Foreign.Storable(Storable)

-- | postfix function application (@flip ($)@)
(//) :: x -> (x -> y) -> y
infixl 0 //
// :: x -> (x -> y) -> y
(//) = ((x -> y) -> x -> y) -> x -> (x -> y) -> y
forall a b c. (a -> b -> c) -> b -> a -> c
flip (x -> y) -> x -> y
forall a b. (a -> b) -> a -> b
($)


-- GSL error codes are <= 1024
-- | error codes for the auxiliary functions required by the wrappers
errorCode :: CInt -> String
errorCode :: CInt -> String
errorCode CInt
2000 = String
"bad size"
errorCode CInt
2001 = String
"bad function code"
errorCode CInt
2002 = String
"memory problem"
errorCode CInt
2003 = String
"bad file"
errorCode CInt
2004 = String
"singular"
errorCode CInt
2005 = String
"didn't converge"
errorCode CInt
2006 = String
"the input matrix is not positive definite"
errorCode CInt
2007 = String
"not yet supported in this OS"
errorCode CInt
n    = String
"code "String -> String -> String
forall a. [a] -> [a] -> [a]
++CInt -> String
forall a. Show a => a -> String
show CInt
n


-- | clear the fpu
foreign import ccall unsafe "asm_finit" finit :: IO ()

-- | check the error code
check :: String -> IO CInt -> IO ()
check :: String -> IO CInt -> IO ()
check String
msg IO CInt
f = do
--  finit
    CInt
err <- IO CInt
f
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
errCInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/=CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String
msgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": "String -> String -> String
forall a. [a] -> [a] -> [a]
++CInt -> String
errorCode CInt
err)
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | postfix error code check
infixl 0 #|
(#|) :: IO CInt -> String -> IO ()
#| :: IO CInt -> String -> IO ()
(#|) = (String -> IO CInt -> IO ()) -> IO CInt -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> IO CInt -> IO ()
check

-- | Error capture and conversion to Maybe
mbCatch :: IO x -> IO (Maybe x)
mbCatch :: IO x -> IO (Maybe x)
mbCatch IO x
act =
  Either SomeException x -> Maybe x
forall a b. Either a b -> Maybe b
hush (Either SomeException x -> Maybe x)
-> IO (Either SomeException x) -> IO (Maybe x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (SomeException -> Maybe SomeException)
-> IO x -> IO (Either SomeException x)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
Exception.tryJust
      (\SomeException
e -> if SomeException -> Bool
isSyncException SomeException
e then SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e else Maybe SomeException
forall a. Maybe a
Nothing)
      IO x
act

  where
    hush :: Either a b -> Maybe b
    hush :: Either a b -> Maybe b
hush = (a -> Maybe b) -> (b -> Maybe b) -> Either a b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> a -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just

    isSyncException :: SomeException -> Bool
    isSyncException :: SomeException -> Bool
isSyncException SomeException
e =
      case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
Exception.fromException SomeException
e of
        Just (SomeAsyncException e
_) -> Bool
False
        Maybe SomeAsyncException
Nothing -> Bool
True

--------------------------------------------------------------------------------

type CM b r = CInt -> CInt -> Ptr b -> r
type CV b r = CInt -> Ptr b -> r
type OM b r = CInt -> CInt -> CInt -> CInt -> Ptr b -> r

type CIdxs r = CV CInt r
type Ok = IO CInt

infixr 5 :>, ::>, ..>
type (:>)  t r = CV t r
type (::>) t r = OM t r
type (..>) t r = CM t r

class TransArray c
  where
    type Trans c b
    type TransRaw c b
    apply      :: c -> (b -> IO r) -> (Trans c b) -> IO r
    applyRaw   :: c -> (b -> IO r) -> (TransRaw c b) -> IO r
    infixl 1 `apply`, `applyRaw`

instance Storable t => TransArray (Vector t)
  where
    type Trans (Vector t) b    = CInt -> Ptr t -> b
    type TransRaw (Vector t) b = CInt -> Ptr t -> b
    apply :: Vector t -> (b -> IO r) -> Trans (Vector t) b -> IO r
apply = Vector t -> (b -> IO r) -> Trans (Vector t) b -> IO r
forall a f r.
Storable a =>
Vector a -> (f -> IO r) -> (CInt -> Ptr a -> f) -> IO r
avec
    {-# INLINE apply #-}
    applyRaw :: Vector t -> (b -> IO r) -> TransRaw (Vector t) b -> IO r
applyRaw = Vector t -> (b -> IO r) -> TransRaw (Vector t) b -> IO r
forall a f r.
Storable a =>
Vector a -> (f -> IO r) -> (CInt -> Ptr a -> f) -> IO r
avec
    {-# INLINE applyRaw #-}