diff options
Diffstat (limited to 'lib/Data/Packed/Internal/Common.hs')
-rw-r--r-- | lib/Data/Packed/Internal/Common.hs | 35 |
1 files changed, 5 insertions, 30 deletions
diff --git a/lib/Data/Packed/Internal/Common.hs b/lib/Data/Packed/Internal/Common.hs index 1212968..5548285 100644 --- a/lib/Data/Packed/Internal/Common.hs +++ b/lib/Data/Packed/Internal/Common.hs | |||
@@ -1,4 +1,4 @@ | |||
1 | {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} | 1 | {-# OPTIONS_GHC -fglasgow-exts #-} |
2 | ----------------------------------------------------------------------------- | 2 | ----------------------------------------------------------------------------- |
3 | -- | | 3 | -- | |
4 | -- Module : Data.Packed.Internal.Common | 4 | -- Module : Data.Packed.Internal.Common |
@@ -23,13 +23,6 @@ import Data.List(transpose,intersperse) | |||
23 | import Data.Typeable | 23 | import Data.Typeable |
24 | import Data.Maybe(fromJust) | 24 | import Data.Maybe(fromJust) |
25 | 25 | ||
26 | debug x = trace (show x) x | ||
27 | |||
28 | data Vector t = V { dim :: Int | ||
29 | , fptr :: ForeignPtr t | ||
30 | , ptr :: Ptr t | ||
31 | } -- deriving Typeable | ||
32 | |||
33 | ---------------------------------------------------------------------- | 26 | ---------------------------------------------------------------------- |
34 | instance (Storable a, RealFloat a) => Storable (Complex a) where -- | 27 | instance (Storable a, RealFloat a) => Storable (Complex a) where -- |
35 | alignment x = alignment (realPart x) -- | 28 | alignment x = alignment (realPart x) -- |
@@ -40,6 +33,8 @@ instance (Storable a, RealFloat a) => Storable (Complex a) where -- | |||
40 | poke p (a :+ b) = pokeArray (castPtr p) [a,b] -- | 33 | poke p (a :+ b) = pokeArray (castPtr p) [a,b] -- |
41 | ---------------------------------------------------------------------- | 34 | ---------------------------------------------------------------------- |
42 | 35 | ||
36 | debug x = trace (show x) x | ||
37 | |||
43 | on :: (a -> a -> b) -> (t -> a) -> t -> t -> b | 38 | on :: (a -> a -> b) -> (t -> a) -> t -> t -> b |
44 | on f g = \x y -> f (g x) (g y) | 39 | on f g = \x y -> f (g x) (g y) |
45 | 40 | ||
@@ -55,13 +50,12 @@ common f = commonval . map f where | |||
55 | commonval [a] = Just a | 50 | commonval [a] = Just a |
56 | commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing | 51 | commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing |
57 | 52 | ||
58 | xor :: Bool -> Bool -> Bool | ||
59 | xor a b = a && not b || b && not a | ||
60 | |||
61 | (//) :: x -> (x -> y) -> y | 53 | (//) :: x -> (x -> y) -> y |
62 | infixl 0 // | 54 | infixl 0 // |
63 | (//) = flip ($) | 55 | (//) = flip ($) |
64 | 56 | ||
57 | -- our codes should start from 1024 | ||
58 | |||
65 | errorCode :: Int -> String | 59 | errorCode :: Int -> String |
66 | errorCode 1000 = "bad size" | 60 | errorCode 1000 = "bad size" |
67 | errorCode 1001 = "bad function code" | 61 | errorCode 1001 = "bad function code" |
@@ -71,25 +65,6 @@ errorCode 1004 = "singular" | |||
71 | errorCode 1005 = "didn't converge" | 65 | errorCode 1005 = "didn't converge" |
72 | errorCode n = "code "++show n | 66 | errorCode n = "code "++show n |
73 | 67 | ||
74 | check :: String -> [Vector a] -> IO Int -> IO () | ||
75 | check msg ls f = do | ||
76 | err <- f | ||
77 | when (err/=0) (error (msg++": "++errorCode err)) | ||
78 | mapM_ (touchForeignPtr . fptr) ls | ||
79 | return () | ||
80 | |||
81 | --class (Storable a, Typeable a) => Field a | ||
82 | --instance (Storable a, Typeable a) => Field a | ||
83 | |||
84 | --isReal :: (Data.Typeable.Typeable a) => (t -> a) -> t -> Bool | ||
85 | --isReal w x = typeOf (undefined :: Double) == typeOf (w x) | ||
86 | |||
87 | --isComp :: (Data.Typeable.Typeable a) => (t -> a) -> t -> Bool | ||
88 | --isComp w x = typeOf (undefined :: Complex Double) == typeOf (w x) | ||
89 | |||
90 | --scast :: forall a . forall b . (Typeable a, Typeable b) => a -> b | ||
91 | --scast = fromJust . cast | ||
92 | |||
93 | {- | conversion of Haskell functions into function pointers that can be used in the C side | 68 | {- | conversion of Haskell functions into function pointers that can be used in the C side |
94 | -} | 69 | -} |
95 | foreign import ccall "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) | 70 | foreign import ccall "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) |