diff options
author | Alberto Ruiz <aruiz@um.es> | 2015-06-05 16:57:19 +0200 |
---|---|---|
committer | Alberto Ruiz <aruiz@um.es> | 2015-06-05 16:57:19 +0200 |
commit | 9f0b5e4e0800cf3effb7a7f3b0ef2662c72fdb57 (patch) | |
tree | fcd0210cd1662e62801c2cddf50b40be76abdda3 /packages/base/src/Internal/Devel.hs | |
parent | a5d14b70e70a93b2dec29fc0dfa7940488dc264a (diff) |
move common and devel
Diffstat (limited to 'packages/base/src/Internal/Devel.hs')
-rw-r--r-- | packages/base/src/Internal/Devel.hs | 123 |
1 files changed, 123 insertions, 0 deletions
diff --git a/packages/base/src/Internal/Devel.hs b/packages/base/src/Internal/Devel.hs new file mode 100644 index 0000000..61d2c85 --- /dev/null +++ b/packages/base/src/Internal/Devel.hs | |||
@@ -0,0 +1,123 @@ | |||
1 | {-# LANGUAGE TypeOperators #-} | ||
2 | |||
3 | -- | | ||
4 | -- Module : Internal.Devel | ||
5 | -- Copyright : (c) Alberto Ruiz 2007-15 | ||
6 | -- License : BSD3 | ||
7 | -- Maintainer : Alberto Ruiz | ||
8 | -- Stability : provisional | ||
9 | -- | ||
10 | |||
11 | module Internal.Devel where | ||
12 | |||
13 | |||
14 | import Internal.Tools ( (//) ) | ||
15 | import Control.Monad ( when ) | ||
16 | import Foreign.C.Types ( CInt ) | ||
17 | --import Foreign.Storable.Complex () | ||
18 | import Foreign.Ptr(Ptr) | ||
19 | import Control.Exception as E ( SomeException, catch ) | ||
20 | |||
21 | |||
22 | -- hmm.. | ||
23 | ww2 w1 o1 w2 o2 f = w1 o1 $ w2 o2 . f | ||
24 | ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ ww2 w2 o2 w3 o3 . f | ||
25 | ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ ww3 w2 o2 w3 o3 w4 o4 . f | ||
26 | ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 f = w1 o1 $ ww4 w2 o2 w3 o3 w4 o4 w5 o5 . f | ||
27 | ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 f = w1 o1 $ ww5 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 . f | ||
28 | ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 f = w1 o1 $ ww6 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 . f | ||
29 | ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 f = w1 o1 $ ww7 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 . f | ||
30 | ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 f = w1 o1 $ ww8 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 . f | ||
31 | ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 f = w1 o1 $ ww9 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 . f | ||
32 | |||
33 | type Adapt f t r = t -> ((f -> r) -> IO()) -> IO() | ||
34 | |||
35 | type Adapt1 f t1 = Adapt f t1 (IO CInt) -> t1 -> String -> IO() | ||
36 | type Adapt2 f t1 r1 t2 = Adapt f t1 r1 -> t1 -> Adapt1 r1 t2 | ||
37 | type Adapt3 f t1 r1 t2 r2 t3 = Adapt f t1 r1 -> t1 -> Adapt2 r1 t2 r2 t3 | ||
38 | type Adapt4 f t1 r1 t2 r2 t3 r3 t4 = Adapt f t1 r1 -> t1 -> Adapt3 r1 t2 r2 t3 r3 t4 | ||
39 | type Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 = Adapt f t1 r1 -> t1 -> Adapt4 r1 t2 r2 t3 r3 t4 r4 t5 | ||
40 | type Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 = Adapt f t1 r1 -> t1 -> Adapt5 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 | ||
41 | type Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 = Adapt f t1 r1 -> t1 -> Adapt6 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 | ||
42 | type Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 = Adapt f t1 r1 -> t1 -> Adapt7 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 | ||
43 | type Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 = Adapt f t1 r1 -> t1 -> Adapt8 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 | ||
44 | type Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 = Adapt f t1 r1 -> t1 -> Adapt9 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 | ||
45 | |||
46 | app1 :: f -> Adapt1 f t1 | ||
47 | app2 :: f -> Adapt2 f t1 r1 t2 | ||
48 | app3 :: f -> Adapt3 f t1 r1 t2 r2 t3 | ||
49 | app4 :: f -> Adapt4 f t1 r1 t2 r2 t3 r3 t4 | ||
50 | app5 :: f -> Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 | ||
51 | app6 :: f -> Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 | ||
52 | app7 :: f -> Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 | ||
53 | app8 :: f -> Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 | ||
54 | app9 :: f -> Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 | ||
55 | app10 :: f -> Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 | ||
56 | |||
57 | app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s | ||
58 | app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s | ||
59 | app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $ | ||
60 | \a1 a2 a3 -> f // a1 // a2 // a3 // check s | ||
61 | app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $ | ||
62 | \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s | ||
63 | app5 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 s = ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 $ | ||
64 | \a1 a2 a3 a4 a5 -> f // a1 // a2 // a3 // a4 // a5 // check s | ||
65 | app6 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 s = ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 $ | ||
66 | \a1 a2 a3 a4 a5 a6 -> f // a1 // a2 // a3 // a4 // a5 // a6 // check s | ||
67 | app7 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 s = ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 $ | ||
68 | \a1 a2 a3 a4 a5 a6 a7 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // check s | ||
69 | app8 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 s = ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 $ | ||
70 | \a1 a2 a3 a4 a5 a6 a7 a8 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // check s | ||
71 | app9 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 s = ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 $ | ||
72 | \a1 a2 a3 a4 a5 a6 a7 a8 a9 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // check s | ||
73 | app10 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 s = ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 $ | ||
74 | \a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // a10 // check s | ||
75 | |||
76 | |||
77 | |||
78 | -- GSL error codes are <= 1024 | ||
79 | -- | error codes for the auxiliary functions required by the wrappers | ||
80 | errorCode :: CInt -> String | ||
81 | errorCode 2000 = "bad size" | ||
82 | errorCode 2001 = "bad function code" | ||
83 | errorCode 2002 = "memory problem" | ||
84 | errorCode 2003 = "bad file" | ||
85 | errorCode 2004 = "singular" | ||
86 | errorCode 2005 = "didn't converge" | ||
87 | errorCode 2006 = "the input matrix is not positive definite" | ||
88 | errorCode 2007 = "not yet supported in this OS" | ||
89 | errorCode n = "code "++show n | ||
90 | |||
91 | |||
92 | -- | clear the fpu | ||
93 | foreign import ccall unsafe "asm_finit" finit :: IO () | ||
94 | |||
95 | -- | check the error code | ||
96 | check :: String -> IO CInt -> IO () | ||
97 | check msg f = do | ||
98 | -- finit | ||
99 | err <- f | ||
100 | when (err/=0) $ error (msg++": "++errorCode err) | ||
101 | return () | ||
102 | |||
103 | -- | Error capture and conversion to Maybe | ||
104 | mbCatch :: IO x -> IO (Maybe x) | ||
105 | mbCatch act = E.catch (Just `fmap` act) f | ||
106 | where f :: SomeException -> IO (Maybe x) | ||
107 | f _ = return Nothing | ||
108 | |||
109 | -------------------------------------------------------------------------------- | ||
110 | |||
111 | type CM b r = CInt -> CInt -> Ptr b -> r | ||
112 | type CV b r = CInt -> Ptr b -> r | ||
113 | type OM b r = CInt -> CInt -> CInt -> CInt -> Ptr b -> r | ||
114 | |||
115 | type CIdxs r = CV CInt r | ||
116 | type Ok = IO CInt | ||
117 | |||
118 | infixr 5 :>, ::>, ..> | ||
119 | type (:>) t r = CV t r | ||
120 | type (::>) t r = OM t r | ||
121 | type (..>) t r = CM t r | ||
122 | |||
123 | |||