diff options
Diffstat (limited to 'packages/base/src/Data/Packed/Internal/Common.hs')
-rw-r--r-- | packages/base/src/Data/Packed/Internal/Common.hs | 160 |
1 files changed, 0 insertions, 160 deletions
diff --git a/packages/base/src/Data/Packed/Internal/Common.hs b/packages/base/src/Data/Packed/Internal/Common.hs deleted file mode 100644 index 615bbdf..0000000 --- a/packages/base/src/Data/Packed/Internal/Common.hs +++ /dev/null | |||
@@ -1,160 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | -- | | ||
3 | -- Module : Data.Packed.Internal.Common | ||
4 | -- Copyright : (c) Alberto Ruiz 2007 | ||
5 | -- License : BSD3 | ||
6 | -- Maintainer : Alberto Ruiz | ||
7 | -- Stability : provisional | ||
8 | -- | ||
9 | -- | ||
10 | -- Development utilities. | ||
11 | -- | ||
12 | |||
13 | |||
14 | module Data.Packed.Internal.Common( | ||
15 | Adapt, | ||
16 | app1, app2, app3, app4, | ||
17 | app5, app6, app7, app8, app9, app10, | ||
18 | (//), check, mbCatch, | ||
19 | splitEvery, common, compatdim, | ||
20 | fi, | ||
21 | table, | ||
22 | finit | ||
23 | ) where | ||
24 | |||
25 | import Control.Monad(when) | ||
26 | import Foreign.C.Types | ||
27 | import Foreign.Storable.Complex() | ||
28 | import Data.List(transpose,intersperse) | ||
29 | import Control.Exception as E | ||
30 | |||
31 | -- | @splitEvery 3 [1..9] == [[1,2,3],[4,5,6],[7,8,9]]@ | ||
32 | splitEvery :: Int -> [a] -> [[a]] | ||
33 | splitEvery _ [] = [] | ||
34 | splitEvery k l = take k l : splitEvery k (drop k l) | ||
35 | |||
36 | -- | obtains the common value of a property of a list | ||
37 | common :: (Eq a) => (b->a) -> [b] -> Maybe a | ||
38 | common f = commonval . map f where | ||
39 | commonval :: (Eq a) => [a] -> Maybe a | ||
40 | commonval [] = Nothing | ||
41 | commonval [a] = Just a | ||
42 | commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing | ||
43 | |||
44 | -- | common value with \"adaptable\" 1 | ||
45 | compatdim :: [Int] -> Maybe Int | ||
46 | compatdim [] = Nothing | ||
47 | compatdim [a] = Just a | ||
48 | compatdim (a:b:xs) | ||
49 | | a==b = compatdim (b:xs) | ||
50 | | a==1 = compatdim (b:xs) | ||
51 | | b==1 = compatdim (a:xs) | ||
52 | | otherwise = Nothing | ||
53 | |||
54 | -- | Formatting tool | ||
55 | table :: String -> [[String]] -> String | ||
56 | table sep as = unlines . map unwords' $ transpose mtp where | ||
57 | mt = transpose as | ||
58 | longs = map (maximum . map length) mt | ||
59 | mtp = zipWith (\a b -> map (pad a) b) longs mt | ||
60 | pad n str = replicate (n - length str) ' ' ++ str | ||
61 | unwords' = concat . intersperse sep | ||
62 | |||
63 | -- | postfix function application (@flip ($)@) | ||
64 | (//) :: x -> (x -> y) -> y | ||
65 | infixl 0 // | ||
66 | (//) = flip ($) | ||
67 | |||
68 | -- | specialized fromIntegral | ||
69 | fi :: Int -> CInt | ||
70 | fi = fromIntegral | ||
71 | |||
72 | -- hmm.. | ||
73 | ww2 w1 o1 w2 o2 f = w1 o1 $ w2 o2 . f | ||
74 | ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ ww2 w2 o2 w3 o3 . f | ||
75 | ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ ww3 w2 o2 w3 o3 w4 o4 . f | ||
76 | ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 f = w1 o1 $ ww4 w2 o2 w3 o3 w4 o4 w5 o5 . f | ||
77 | 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 | ||
78 | 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 | ||
79 | 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 | ||
80 | 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 | ||
81 | 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 | ||
82 | |||
83 | type Adapt f t r = t -> ((f -> r) -> IO()) -> IO() | ||
84 | |||
85 | type Adapt1 f t1 = Adapt f t1 (IO CInt) -> t1 -> String -> IO() | ||
86 | type Adapt2 f t1 r1 t2 = Adapt f t1 r1 -> t1 -> Adapt1 r1 t2 | ||
87 | type Adapt3 f t1 r1 t2 r2 t3 = Adapt f t1 r1 -> t1 -> Adapt2 r1 t2 r2 t3 | ||
88 | type Adapt4 f t1 r1 t2 r2 t3 r3 t4 = Adapt f t1 r1 -> t1 -> Adapt3 r1 t2 r2 t3 r3 t4 | ||
89 | 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 | ||
90 | 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 | ||
91 | 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 | ||
92 | 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 | ||
93 | 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 | ||
94 | 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 | ||
95 | |||
96 | app1 :: f -> Adapt1 f t1 | ||
97 | app2 :: f -> Adapt2 f t1 r1 t2 | ||
98 | app3 :: f -> Adapt3 f t1 r1 t2 r2 t3 | ||
99 | app4 :: f -> Adapt4 f t1 r1 t2 r2 t3 r3 t4 | ||
100 | app5 :: f -> Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 | ||
101 | app6 :: f -> Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 | ||
102 | app7 :: f -> Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 | ||
103 | app8 :: f -> Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 | ||
104 | app9 :: f -> Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 | ||
105 | app10 :: f -> Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 | ||
106 | |||
107 | app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s | ||
108 | app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s | ||
109 | app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $ | ||
110 | \a1 a2 a3 -> f // a1 // a2 // a3 // check s | ||
111 | app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $ | ||
112 | \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s | ||
113 | app5 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 s = ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 $ | ||
114 | \a1 a2 a3 a4 a5 -> f // a1 // a2 // a3 // a4 // a5 // check s | ||
115 | 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 $ | ||
116 | \a1 a2 a3 a4 a5 a6 -> f // a1 // a2 // a3 // a4 // a5 // a6 // check s | ||
117 | 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 $ | ||
118 | \a1 a2 a3 a4 a5 a6 a7 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // check s | ||
119 | 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 $ | ||
120 | \a1 a2 a3 a4 a5 a6 a7 a8 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // check s | ||
121 | 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 $ | ||
122 | \a1 a2 a3 a4 a5 a6 a7 a8 a9 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // check s | ||
123 | 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 $ | ||
124 | \a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // a10 // check s | ||
125 | |||
126 | |||
127 | |||
128 | -- GSL error codes are <= 1024 | ||
129 | -- | error codes for the auxiliary functions required by the wrappers | ||
130 | errorCode :: CInt -> String | ||
131 | errorCode 2000 = "bad size" | ||
132 | errorCode 2001 = "bad function code" | ||
133 | errorCode 2002 = "memory problem" | ||
134 | errorCode 2003 = "bad file" | ||
135 | errorCode 2004 = "singular" | ||
136 | errorCode 2005 = "didn't converge" | ||
137 | errorCode 2006 = "the input matrix is not positive definite" | ||
138 | errorCode 2007 = "not yet supported in this OS" | ||
139 | errorCode n = "code "++show n | ||
140 | |||
141 | |||
142 | -- | clear the fpu | ||
143 | foreign import ccall unsafe "asm_finit" finit :: IO () | ||
144 | |||
145 | -- | check the error code | ||
146 | check :: String -> IO CInt -> IO () | ||
147 | check msg f = do | ||
148 | #if FINIT | ||
149 | finit | ||
150 | #endif | ||
151 | err <- f | ||
152 | when (err/=0) $ error (msg++": "++errorCode err) | ||
153 | return () | ||
154 | |||
155 | -- | Error capture and conversion to Maybe | ||
156 | mbCatch :: IO x -> IO (Maybe x) | ||
157 | mbCatch act = E.catch (Just `fmap` act) f | ||
158 | where f :: SomeException -> IO (Maybe x) | ||
159 | f _ = return Nothing | ||
160 | |||