Make Control.Exception buildable by nhc98.

[haskell-directory.git] / GHC / PArr.hs

diff --git a/GHC/PArr.hs b/GHC/PArr.hs
index fe58b94..cd2f03b 100644 (file)
--- a/GHC/PArr.hs
+++ b/GHC/PArr.hs
@@ -135,11 +135,14 @@ module GHC.PArr (
   fold1P,              -- :: (e -> e -> e) ->      [:e:] -> e
   permuteP,            -- :: [:Int:] -> [:e:] ->          [:e:]
   bpermuteP,           -- :: [:Int:] -> [:e:] ->          [:e:]
-  bpermuteDftP,                -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
+  dpermuteP,           -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
   crossP,              -- :: [:a:] -> [:b:] -> [:(a, b):]
+  crossMapP,           -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
   indexOfP             -- :: (a -> Bool) -> [:a:] -> [:Int:]
 ) where
 
+#ifndef __HADDOCK__
+
 import Prelude
 
 import GHC.ST   ( ST(..), STRep, runST )
@@ -457,7 +460,18 @@ fold1P  = foldl1P
 -- (EXPORTED)
 --
 permuteP       :: [:Int:] -> [:e:] -> [:e:]
-permuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
+permuteP is es 
+  | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
+  | otherwise      = runST (do
+                      marr <- newArray isLen noElem
+                      permute marr is es
+                      mkPArr isLen marr)
+  where
+    noElem = error "GHC.PArr.permuteP: I do not exist!"
+            -- unlike standard Haskell arrays, this value represents an
+            -- internal error
+    isLen = lengthP is
+    esLen = lengthP es
 
 -- permute an array according to the back-permutation vector in the first
 -- argument (EXPORTED)
@@ -466,17 +480,32 @@ permuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
 --   the result is undefined
 --
 bpermuteP       :: [:Int:] -> [:e:] -> [:e:]
-bpermuteP is es  = error "Prelude.bpermuteP: not implemented yet" -- FIXME
+bpermuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
 
--- permute an array according to the back-permutation vector in the first
+-- permute an array according to the permutation vector in the first
 -- argument, which need not be surjective (EXPORTED)
 --
--- * any elements in the result that are not covered by the back-permutation
+-- * any elements in the result that are not covered by the permutation
 --   vector assume the value of the corresponding position of the third
 --   argument 
 --
-bpermuteDftP       :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
-bpermuteDftP is es  = error "Prelude.bpermuteDftP: not implemented yet"-- FIXME
+dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
+dpermuteP is es dft
+  | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
+  | otherwise      = runST (do
+                      marr <- newArray dftLen noElem
+                      trans 0 (isLen - 1) marr dft copyOne noAL
+                      permute marr is es
+                      mkPArr dftLen marr)
+  where
+    noElem = error "GHC.PArr.permuteP: I do not exist!"
+            -- unlike standard Haskell arrays, this value represents an
+            -- internal error
+    isLen  = lengthP is
+    esLen  = lengthP es
+    dftLen = lengthP dft
+
+    copyOne e _ = (Just e, noAL)
 
 -- computes the cross combination of two arrays (EXPORTED)
 --
@@ -506,6 +535,25 @@ crossP a1 a2  = let
                zipP x1 x2
  -}
 
+-- |Compute a cross of an array and the arrays produced by the given function
+-- for the elements of the first array.
+--
+crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
+crossMapP a f = let
+                 bs   = mapP f a
+                 segd = mapP lengthP bs
+                 as   = zipWithP replicateP segd a
+               in
+               zipP (concatP as) (concatP bs)
+
+{- The following may seem more straight forward, but the above is very cheap
+   with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are
+   constant time, and `map f' uses the lifted version of `f'.
+
+crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a
+
+ -}
+
 -- computes an index array for all elements of the second argument for which
 -- the predicate yields `True' (EXPORTED)
 --
@@ -566,7 +614,7 @@ loopFromTo from to mf start arr = runST (do
   arr       <- mkPArr n' marr
   return (arr, acc))
   where
-    noElem = error "PrelPArr.loopFromTo: I do not exist!"
+    noElem = error "GHC.PArr.loopFromTo: I do not exist!"
             -- unlike standard Haskell arrays, this value represents an
             -- internal error
 
@@ -597,6 +645,17 @@ trans from to marr arr mf start = trans' from 0 start
                                        return $ marrOff + 1
                         trans' (arrOff + 1) marrOff' acc'
 
+-- Permute the given elements into the mutable array.
+--
+permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s ()
+permute marr is es = perm 0
+  where
+    perm i
+      | i == n = return ()
+      | otherwise  = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1)
+      where
+        n = lengthP is
+
 
 -- common patterns for using `loop'
 --
@@ -655,3 +714,6 @@ writeMPArr (MPArr n# marr#) (I# i#) e
   | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++
                        "idx = " ++ show (I# i#) ++ ", arr len = "
                        ++ show (I# n#)
+
+#endif /* __HADDOCK__ */
+