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