{-# 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 as E ( SomeException, catch )
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 2000 = "bad size"
errorCode 2001 = "bad function code"
errorCode 2002 = "memory problem"
errorCode 2003 = "bad file"
errorCode 2004 = "singular"
errorCode 2005 = "didn't converge"
errorCode 2006 = "the input matrix is not positive definite"
errorCode 2007 = "not yet supported in this OS"
errorCode n :: CInt
n    = "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 msg :: String
msg f :: 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
/=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
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 act :: IO x
act = IO (Maybe x) -> (SomeException -> IO (Maybe x)) -> IO (Maybe x)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (x -> Maybe x
forall a. a -> Maybe a
Just (x -> Maybe x) -> IO x -> IO (Maybe x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO x
act) SomeException -> IO (Maybe x)
forall x. SomeException -> IO (Maybe x)
f
    where f :: SomeException -> IO (Maybe x)
          f :: SomeException -> IO (Maybe x)
f _ = Maybe x -> IO (Maybe x)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe x
forall a. Maybe a
Nothing

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

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 #-}