{-# LANGUAGE ParallelArrays #-}
{-# OPTIONS_GHC -fvectorise #-}

-- | User level interface of parallel arrays.
--
--   This library is deprecated. Using it can result in the vectorised program
--   having asymptotically worse complexity than the original. Your program
--   could be 10000x slower than it should be with this library.
--
--   Use the @dph-lifted-vseg@ package instead.
 
-- 
-- /WARNING:/ In the current implementation, the functionality provided in
-- this module is tied to the vectoriser pass of GHC invoked by passing the
-- `-fvectorise` option.  Without vectorisation these functions will not work
-- at all!
---
-- The semantic difference between standard Haskell arrays (aka "lazy
-- arrays") and parallel arrays (aka "strict arrays") is that the evaluation
-- of two different elements of a lazy array is independent, whereas in a
-- strict array either non or all elements are evaluated.  In other words,
-- when a parallel array is evaluated to WHNF, all its elements will be
-- evaluated to WHNF.  The name parallel array indicates that all array
-- elements may, in general, be evaluated to WHNF in parallel without any
-- need to resort to speculative evaluation.  This parallel evaluation
-- semantics is also beneficial in the sequential case, as it facilitates
-- loop-based array processing as known from classic array-based languages,
-- such as Fortran.
--
-- The interface of this module is essentially a variant of the list
-- component of the Prelude, but also includes some functions (such as
-- permutations) that are not provided for lists.  The following list of
-- operations are not supported on parallel arrays, as they would require the
-- infinite parallel arrays: `iterate', `repeat', and `cycle'.
--
-- UGLY HACK ALERT: 
--  Same ugly hack as in 'base:GHC.PArr'!  We could do without in this module by
--  using the type synonym 'PArr' instead of '[::]', but that would lead to
--  significantly worse error message for end users.

module Data.Array.Parallel (
  module Data.Array.Parallel.Prelude,
  
  -- [::],    -- Built-in syntax

  -- * Operations on parallel arrays '[::]'
  emptyP, singletonP, replicateP, lengthP, (!:),
  (+:+), concatP,
  mapP, filterP, combineP,
  {- minimumP, maximumP, sumP, productP, -}  -- removed until we support type classes
  zipP, zip3P, unzipP, unzip3P, zipWithP, zipWith3P,
  {- enumFromToP, enumFromThenToP, -}        -- removed until we support type classes
  bpermuteP, updateP, indexedP, sliceP,
  crossMapP,
  
  -- * Conversions
  PArray, fromPArrayP, toPArrayP, fromNestedPArrayP
) where

import Data.Array.Parallel.Prim ()       -- dependency required by the vectoriser

import Data.Array.Parallel.PArr      hiding (PArr)
import Data.Array.Parallel.Prelude
import Data.Array.Parallel.Lifted
import Data.Array.Parallel.Lifted.Combinators


infixl 9 !:
infixr 5 +:+


-- Vectorise Prelude.undefined
{-# VECTORISE undefined = undefined_v #-}
undefined_v :: forall a. PA a => a
undefined_v = error "Data.Array.Parallel: undefined vectorised"
{-# NOVECTORISE undefined_v #-}

-- We only define the signatures of operations on parallel arrays (and bodies that convince GHC
-- that these functions don't just return diverge).  The vectoriser rewrites them to entirely
-- the code given in the VECTORISE pragmas.

emptyP :: [:a:]
{-# NOINLINE emptyP #-}
emptyP = emptyPArr
{-# VECTORISE emptyP = emptyPA #-}

singletonP :: a -> [:a:]
{-# NOINLINE singletonP #-}
singletonP = singletonPArr
{-# VECTORISE singletonP = singletonPA #-}

replicateP :: Int -> a -> [:a:]
{-# NOINLINE replicateP #-}
replicateP = replicatePArr
{-# VECTORISE replicateP = replicatePA #-}

lengthP :: [:a:] -> Int
{-# NOINLINE lengthP #-}
lengthP = lengthPArr
{-# VECTORISE lengthP = lengthPA #-}

(!:) :: [:a:] -> Int -> a
{-# NOINLINE (!:) #-}
(!:) = indexPArr
{-# VECTORISE (!:) = indexPA #-}

(+:+) :: [:a:] -> [:a:] -> [:a:]
{-# NOINLINE (+:+) #-}
(+:+) xs !_ = xs
{-# VECTORISE (+:+) = appPA #-}

concatP :: [:[:a:]:] -> [:a:]
{-# NOINLINE concatP #-}
concatP xss = indexPArr xss 0
{-# VECTORISE concatP = concatPA #-}

mapP :: (a -> b) -> [:a:] -> [:b:]
{-# NOINLINE mapP #-}
mapP !_ !_ = emptyP
{-# VECTORISE mapP = mapPA #-}

filterP :: (a -> Bool) -> [:a:] -> [:a:]
{-# NOINLINE filterP #-}
filterP !_ xs = xs
{-# VECTORISE filterP = filterPA #-}

-- sumP :: Num a => [:a:] -> a
-- {-# NOINLINE sumP #-}
-- sumP a = a !: 0
-- -- no VECTORISE pragma as we still have the type-specific mock Prelude modules
-- 
-- productP :: Num a => [:a:] -> a
-- {-# NOINLINE productP #-}
-- productP a = a !: 0
-- 
-- maximumP :: Ord a => [:a:] -> a
-- {-# NOINLINE maximumP #-}
-- maximumP a = a !: 0
-- 
-- minimumP :: Ord a => [:a:] -> a
-- {-# NOINLINE minimumP #-}
-- minimumP a = a !: 0

zipP :: [:a:] -> [:b:] -> [:(a, b):]
{-# NOINLINE zipP #-}
zipP !_ !_ = emptyP
{-# VECTORISE zipP = zipPA #-}

zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
{-# NOINLINE zip3P #-}
zip3P !_ !_ !_ = emptyP
{-# VECTORISE zip3P = zip3PA #-}

unzipP :: [:(a, b):] -> ([:a:], [:b:])
{-# NOINLINE unzipP #-}
unzipP !_ = (emptyP, emptyP)
{-# VECTORISE unzipP = unzipPA #-}

unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
{-# NOINLINE unzip3P #-}
unzip3P !_ = (emptyP, emptyP, emptyP)
{-# VECTORISE unzip3P = unzip3PA #-}

zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
{-# NOINLINE zipWithP #-}
zipWithP !_ !_ !_ = emptyP
{-# VECTORISE zipWithP = zipWithPA #-}

zipWith3P :: (a -> b -> c -> d) -> [:a:] -> [:b:] -> [:c:] -> [:d:]
{-# NOINLINE zipWith3P #-}
zipWith3P !_ !_ !_ !_ = emptyP
{-# VECTORISE zipWith3P = zipWith3PA #-}

-- enumFromToP :: Enum a => a -> a -> [:a:]
-- {-# NOINLINE enumFromToP #-}
-- enumFromToP x y = [:x, y:]
-- 
-- enumFromThenToP :: Enum a => a -> a -> a -> [:a:]
-- {-# NOINLINE enumFromThenToP #-}
-- enumFromThenToP x y z = [:x, y, z:]

combineP :: [:a:] -> [:a:] -> [:Int:] -> [:a:]
{-# NOINLINE combineP #-}
combineP xs !_ !_ = xs
{-# VECTORISE combineP = combine2PA #-}

updateP :: [:a:] -> [:(Int, a):] -> [:a:]
{-# NOINLINE updateP #-}
updateP xs !_ = xs
{-# VECTORISE updateP = updatePA #-}

bpermuteP :: [:a:] -> [:Int:] -> [:a:]
{-# NOINLINE bpermuteP #-}
bpermuteP xs !_ = xs
{-# VECTORISE bpermuteP = bpermutePA #-}

indexedP :: [:a:] -> [:(Int, a):]
{-# NOINLINE indexedP #-}
indexedP !_ = emptyP
{-# VECTORISE indexedP = indexedPA #-}

sliceP :: Int -> Int -> [:e:] -> [:e:]
{-# NOINLINE sliceP #-}
sliceP !_ !_ xs = xs
{-# VECTORISE sliceP = slicePA #-}

crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
{-# NOINLINE crossMapP #-}
crossMapP !_ !_ = emptyP
{-# VECTORISE crossMapP = crossMapPA #-}

fromPArrayP :: PArray a -> [:a:]
{-# NOINLINE fromPArrayP #-}
fromPArrayP !_ = emptyP
{-# VECTORISE fromPArrayP = fromPArrayPA #-}

toPArrayP :: [:a:] -> PArray a
{-# NOINLINE toPArrayP #-}
toPArrayP !_ = PArray 0# undefined
{-# VECTORISE toPArrayP = toPArrayPA #-}

fromNestedPArrayP :: PArray (PArray a) -> [:[:a:]:]
{-# NOINLINE fromNestedPArrayP #-}
fromNestedPArrayP !_ = emptyP
{-# VECTORISE fromNestedPArrayP = fromNestedPArrayPA #-}

{- ================================================================================================
   This is the old code from GHC.PArr that we used to implement parallel arrays without
   vectorisation.  As soon as partial vectorisation has been implemented, we should revise
   this code to support the mixed use of vectorised and non-vectorised code with parallel
   arrays.  This will probably require the use of a different representation of parallel arrays
   that is a sum of the flattened and an unflattened representation.

{-# LANGUAGE MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module GHC.PArr (
  -- [::],              -- Built-in syntax

  mapP,                 -- :: (a -> b) -> [:a:] -> [:b:]
  (+:+),                -- :: [:a:] -> [:a:] -> [:a:]
  filterP,              -- :: (a -> Bool) -> [:a:] -> [:a:]
  concatP,              -- :: [:[:a:]:] -> [:a:]
  concatMapP,           -- :: (a -> [:b:]) -> [:a:] -> [:b:]
--  head, last, tail, init,   -- it's not wise to use them on arrays
  nullP,                -- :: [:a:] -> Bool
  lengthP,              -- :: [:a:] -> Int
  (!:),                 -- :: [:a:] -> Int -> a
  foldlP,               -- :: (a -> b -> a) -> a -> [:b:] -> a
  foldl1P,              -- :: (a -> a -> a) ->      [:a:] -> a
  scanlP,               -- :: (a -> b -> a) -> a -> [:b:] -> [:a:]
  scanl1P,              -- :: (a -> a -> a) ->      [:a:] -> [:a:]
  foldrP,               -- :: (a -> b -> b) -> b -> [:a:] -> b
  foldr1P,              -- :: (a -> a -> a) ->      [:a:] -> a
  scanrP,               -- :: (a -> b -> b) -> b -> [:a:] -> [:b:]
  scanr1P,              -- :: (a -> a -> a) ->      [:a:] -> [:a:]
--  iterate, repeat,          -- parallel arrays must be finite
  singletonP,           -- :: a -> [:a:]
  emptyP,               -- :: [:a:]
  replicateP,           -- :: Int -> a -> [:a:]
--  cycle,                    -- parallel arrays must be finite
  takeP,                -- :: Int -> [:a:] -> [:a:]
  dropP,                -- :: Int -> [:a:] -> [:a:]
  splitAtP,             -- :: Int -> [:a:] -> ([:a:],[:a:])
  takeWhileP,           -- :: (a -> Bool) -> [:a:] -> [:a:]
  dropWhileP,           -- :: (a -> Bool) -> [:a:] -> [:a:]
  spanP,                -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
  breakP,               -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
--  lines, words, unlines, unwords,  -- is string processing really needed
  reverseP,             -- :: [:a:] -> [:a:]
  andP,                 -- :: [:Bool:] -> Bool
  orP,                  -- :: [:Bool:] -> Bool
  anyP,                 -- :: (a -> Bool) -> [:a:] -> Bool
  allP,                 -- :: (a -> Bool) -> [:a:] -> Bool
  elemP,                -- :: (Eq a) => a -> [:a:] -> Bool
  notElemP,             -- :: (Eq a) => a -> [:a:] -> Bool
  lookupP,              -- :: (Eq a) => a -> [:(a, b):] -> Maybe b
  sumP,                 -- :: (Num a) => [:a:] -> a
  productP,             -- :: (Num a) => [:a:] -> a
  maximumP,             -- :: (Ord a) => [:a:] -> a
  minimumP,             -- :: (Ord a) => [:a:] -> a
  zipP,                 -- :: [:a:] -> [:b:]          -> [:(a, b)   :]
  zip3P,                -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
  zipWithP,             -- :: (a -> b -> c)      -> [:a:] -> [:b:] -> [:c:]
  zipWith3P,            -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
  unzipP,               -- :: [:(a, b)   :] -> ([:a:], [:b:])
  unzip3P,              -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])

  -- overloaded functions
  --
  enumFromToP,          -- :: Enum a => a -> a      -> [:a:]
  enumFromThenToP,      -- :: Enum a => a -> a -> a -> [:a:]

  -- the following functions are not available on lists
  --
  toP,                  -- :: [a] -> [:a:]
  fromP,                -- :: [:a:] -> [a]
  sliceP,               -- :: Int -> Int -> [:e:] -> [:e:]
  foldP,                -- :: (e -> e -> e) -> e -> [:e:] -> e
  fold1P,               -- :: (e -> e -> e) ->      [:e:] -> e
  permuteP,             -- :: [:Int:] -> [:e:] ->          [:e:]
  bpermuteP,            -- :: [:Int:] -> [:e:] ->          [:e:]
  dpermuteP,            -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
  crossP,               -- :: [:a:] -> [:b:] -> [:(a, b):]
  crossMapP,            -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
  indexOfP              -- :: (a -> Bool) -> [:a:] -> [:Int:]
) where


import Prelude

import GHC.ST   ( ST(..), runST )
import GHC.Base ( Int#, Array#, Int(I#), MutableArray#, newArray#,
                  unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) )

infixl 9  !:
infixr 5  +:+
infix  4  `elemP`, `notElemP`


-- representation of parallel arrays
-- ---------------------------------

-- this rather straight forward implementation maps parallel arrays to the
-- internal representation used for standard Haskell arrays in GHC's Prelude
-- (EXPORTED ABSTRACTLY)
--
-- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'!
--
data [::] e = PArr Int# (Array# e)


-- exported operations on parallel arrays
-- --------------------------------------

-- operations corresponding to list operations
--

mapP   :: (a -> b) -> [:a:] -> [:b:]
mapP f  = fst . loop (mapEFL f) noAL

(+:+)     :: [:a:] -> [:a:] -> [:a:]
a1 +:+ a2  = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1))
                       -- we can't use the [:x..y:] form here for tedious
                       -- reasons to do with the typechecker and the fact that
                       -- `enumFromToP' is defined in the same module
             where
               len1 = lengthP a1
               len2 = lengthP a2
               --
               sel i | i < len1  = a1!:i
                     | otherwise = a2!:(i - len1)

filterP   :: (a -> Bool) -> [:a:] -> [:a:]
filterP p  = fst . loop (filterEFL p) noAL

concatP     :: [:[:a:]:] -> [:a:]
concatP xss  = foldlP (+:+) [::] xss

concatMapP   :: (a -> [:b:]) -> [:a:] -> [:b:]
concatMapP f  = concatP . mapP f

--  head, last, tail, init,   -- it's not wise to use them on arrays

nullP      :: [:a:] -> Bool
nullP [::]  = True
nullP _     = False

lengthP             :: [:a:] -> Int
lengthP (PArr n# _)  = I# n#

(!:) :: [:a:] -> Int -> a
(!:)  = indexPArr

foldlP     :: (a -> b -> a) -> a -> [:b:] -> a
foldlP f z  = snd . loop (foldEFL (flip f)) z

foldl1P        :: (a -> a -> a) -> [:a:] -> a
foldl1P _ [::]  = error "Prelude.foldl1P: empty array"
foldl1P f a     = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a

scanlP     :: (a -> b -> a) -> a -> [:b:] -> [:a:]
scanlP f z  = fst . loop (scanEFL (flip f)) z

scanl1P        :: (a -> a -> a) -> [:a:] -> [:a:]
scanl1P _ [::]  = error "Prelude.scanl1P: empty array"
scanl1P f a     = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a

foldrP :: (a -> b -> b) -> b -> [:a:] -> b
foldrP  = error "Prelude.foldrP: not implemented yet" -- FIXME

foldr1P :: (a -> a -> a) -> [:a:] -> a
foldr1P  = error "Prelude.foldr1P: not implemented yet" -- FIXME

scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:]
scanrP  = error "Prelude.scanrP: not implemented yet" -- FIXME

scanr1P :: (a -> a -> a) -> [:a:] -> [:a:]
scanr1P  = error "Prelude.scanr1P: not implemented yet" -- FIXME

--  iterate, repeat           -- parallel arrays must be finite

singletonP             :: a -> [:a:]
{-# INLINE singletonP #-}
singletonP e = replicateP 1 e
  
emptyP:: [:a:]
{- NOINLINE emptyP #-}
emptyP = replicateP 0 undefined


replicateP             :: Int -> a -> [:a:]
{-# INLINE replicateP #-}
replicateP n e  = runST (do
  marr# <- newArray n e
  mkPArr n marr#)

--  cycle                     -- parallel arrays must be finite

takeP   :: Int -> [:a:] -> [:a:]
takeP n  = sliceP 0 n

dropP     :: Int -> [:a:] -> [:a:]
dropP n a  = sliceP n (lengthP a - n) a

splitAtP      :: Int -> [:a:] -> ([:a:],[:a:])
splitAtP n xs  = (takeP n xs, dropP n xs)

takeWhileP :: (a -> Bool) -> [:a:] -> [:a:]
takeWhileP  = error "Prelude.takeWhileP: not implemented yet" -- FIXME

dropWhileP :: (a -> Bool) -> [:a:] -> [:a:]
dropWhileP  = error "Prelude.dropWhileP: not implemented yet" -- FIXME

spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
spanP  = error "Prelude.spanP: not implemented yet" -- FIXME

breakP   :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
breakP p  = spanP (not . p)

--  lines, words, unlines, unwords,  -- is string processing really needed

reverseP   :: [:a:] -> [:a:]
reverseP a  = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a
                       -- we can't use the [:x, y..z:] form here for tedious
                       -- reasons to do with the typechecker and the fact that
                       -- `enumFromThenToP' is defined in the same module
              where
                len = lengthP a

andP :: [:Bool:] -> Bool
andP  = foldP (&&) True

orP :: [:Bool:] -> Bool
orP  = foldP (||) True

anyP   :: (a -> Bool) -> [:a:] -> Bool
anyP p  = orP . mapP p

allP :: (a -> Bool) -> [:a:] -> Bool
allP p  = andP . mapP p

elemP   :: (Eq a) => a -> [:a:] -> Bool
elemP x  = anyP (== x)

notElemP   :: (Eq a) => a -> [:a:] -> Bool
notElemP x  = allP (/= x)

lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b
lookupP  = error "Prelude.lookupP: not implemented yet" -- FIXME

sumP :: (Num a) => [:a:] -> a
sumP  = foldP (+) 0

productP :: (Num a) => [:a:] -> a
productP  = foldP (*) 1

maximumP      :: (Ord a) => [:a:] -> a
maximumP [::]  = error "Prelude.maximumP: empty parallel array"
maximumP xs    = fold1P max xs

minimumP :: (Ord a) => [:a:] -> a
minimumP [::]  = error "Prelude.minimumP: empty parallel array"
minimumP xs    = fold1P min xs

zipP :: [:a:] -> [:b:] -> [:(a, b):]
zipP  = zipWithP (,)

zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
zip3P  = zipWith3P (,,)

zipWithP         :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
zipWithP f a1 a2  = let 
                      len1 = lengthP a1
                      len2 = lengthP a2
                      len  = len1 `min` len2
                    in
                    fst $ loopFromTo 0 (len - 1) combine 0 a1
                    where
                      combine e1 i = (Just $ f e1 (a2!:i), i + 1)

zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
zipWith3P f a1 a2 a3 = let 
                        len1 = lengthP a1
                        len2 = lengthP a2
                        len3 = lengthP a3
                        len  = len1 `min` len2 `min` len3
                      in
                      fst $ loopFromTo 0 (len - 1) combine 0 a1
                      where
                        combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1)

unzipP   :: [:(a, b):] -> ([:a:], [:b:])
unzipP a  = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a)
-- FIXME: these two functions should be optimised using a tupled custom loop
unzip3P   :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
unzip3P x  = (fst $ loop (mapEFL fst3) noAL x, 
              fst $ loop (mapEFL snd3) noAL x,
              fst $ loop (mapEFL trd3) noAL x)
             where
               fst3 (a, _, _) = a
               snd3 (_, b, _) = b
               trd3 (_, _, c) = c

-- instances
--

instance Eq a => Eq [:a:] where
  a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2)
           | otherwise                = False

instance Ord a => Ord [:a:] where
  compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of
                    EQ | lengthP a1 == lengthP a2 -> EQ
                       | lengthP a1 <  lengthP a2 -> LT
                       | otherwise                -> GT
                  where
                    combineOrdering EQ    EQ    = EQ
                    combineOrdering EQ    other = other
                    combineOrdering other _     = other

instance Functor [::] where
  fmap = mapP

instance Monad [::] where
  m >>= k  = foldrP ((+:+) . k      ) [::] m
  m >>  k  = foldrP ((+:+) . const k) [::] m
  return x = [:x:]
  fail _   = [::]

instance Show a => Show [:a:]  where
  showsPrec _  = showPArr . fromP
    where
      showPArr []     s = "[::]" ++ s
      showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s)

      showPArr' []     s = ":]" ++ s
      showPArr' (y:ys) s = ',' : shows y (showPArr' ys s)

instance Read a => Read [:a:]  where
  readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a]
    where
      readPArr = readParen False (\r -> do
                                          ("[:",s) <- lex r
                                          readPArr1 s)
      readPArr1 s = 
        (do { (":]", t) <- lex s; return ([], t) }) ++
        (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) })

      readPArr2 s = 
        (do { (":]", t) <- lex s; return ([], t) }) ++
        (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; 
              return (x:xs, v) })

-- overloaded functions
-- 

-- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of
-- `Enum'.  On the other hand, we really do not want to change `Enum'.  Thus,
-- for the moment, we hope that the compiler is sufficiently clever to
-- properly fuse the following definitions.

enumFromToP     :: Enum a => a -> a -> [:a:]
enumFromToP x0 y0  = mapP toEnum (eftInt (fromEnum x0) (fromEnum y0))
  where
    eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1

enumFromThenToP       :: Enum a => a -> a -> a -> [:a:]
enumFromThenToP x0 y0 z0  = 
  mapP toEnum (efttInt (fromEnum x0) (fromEnum y0) (fromEnum z0))
  where
    efttInt x y z = scanlP (+) x $ 
                      replicateP (abs (z - x) `div` abs delta + 1) delta
      where
       delta = y - x

-- the following functions are not available on lists
--

-- create an array from a list (EXPORTED)
--
toP   :: [a] -> [:a:]
toP l  = fst $ loop store l (replicateP (length l) ())
         where
           store _ (x:xs) = (Just x, xs)

-- convert an array to a list (EXPORTED)
--
fromP   :: [:a:] -> [a]
fromP a  = [a!:i | i <- [0..lengthP a - 1]]

-- cut a subarray out of an array (EXPORTED)
--
sliceP :: Int -> Int -> [:e:] -> [:e:]
sliceP from to a = 
  fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a

-- parallel folding (EXPORTED)
--
-- * the first argument must be associative; otherwise, the result is undefined
--
foldP :: (e -> e -> e) -> e -> [:e:] -> e
foldP  = foldlP

-- parallel folding without explicit neutral (EXPORTED)
--
-- * the first argument must be associative; otherwise, the result is undefined
--
fold1P :: (e -> e -> e) -> [:e:] -> e
fold1P  = foldl1P

-- permute an array according to the permutation vector in the first argument
-- (EXPORTED)
--
permuteP       :: [:Int:] -> [:e:] -> [:e:]
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)
--
-- * the permutation vector must represent a surjective function; otherwise,
--   the result is undefined
--
bpermuteP       :: [:Int:] -> [:e:] -> [:e:]
bpermuteP is es  = fst $ loop (mapEFL (es!:)) noAL is

-- 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 permutation
--   vector assume the value of the corresponding position of the third
--   argument 
--
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)
--
crossP       :: [:a:] -> [:b:] -> [:(a, b):]
crossP a1 a2  = fst $ loop combine (0, 0) $ replicateP len ()
                where
                  len1 = lengthP a1
                  len2 = lengthP a2
                  len  = len1 * len2
                  --
                  combine _ (i, j) = (Just $ (a1!:i, a2!:j), next)
                                     where
                                       next | (i + 1) == len1 = (0    , j + 1)
                                            | otherwise       = (i + 1, j)

{- An alternative implementation
   * The one above is certainly better for flattened code, but here where we
     are handling boxed arrays, the trade off is less clear.  However, I
     think, the above one is still better.

crossP a1 a2  = let
                  len1 = lengthP a1
                  len2 = lengthP a2
                  x1   = concatP $ mapP (replicateP len2) a1
                  x2   = concatP $ replicateP len1 a2
                in
                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)
--
indexOfP     :: (a -> Bool) -> [:a:] -> [:Int:]
indexOfP p a  = fst $ loop calcIdx 0 a
                where
                  calcIdx e idx | p e       = (Just idx, idx + 1)
                                | otherwise = (Nothing , idx    )


-- auxiliary functions
-- -------------------

-- internally used mutable boxed arrays
--
data MPArr s e = MPArr Int# (MutableArray# s e)

-- allocate a new mutable array that is pre-initialised with a given value
--
newArray             :: Int -> e -> ST s (MPArr s e)
{-# INLINE newArray #-}
newArray (I# n#) e  = ST $ \s1# ->
  case newArray# n# e s1# of { (# s2#, marr# #) ->
  (# s2#, MPArr n# marr# #)}

-- convert a mutable array into the external parallel array representation
--
mkPArr                           :: Int -> MPArr s e -> ST s [:e:]
{-# INLINE mkPArr #-}
mkPArr (I# n#) (MPArr _ marr#)  = ST $ \s1# ->
  case unsafeFreezeArray# marr# s1#   of { (# s2#, arr# #) ->
  (# s2#, PArr n# arr# #) }

-- general array iterator
--
-- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty &
--   Keller, ICFP 2001
--
loop :: (e -> acc -> (Maybe e', acc))    -- mapping & folding, once per element
     -> acc                              -- initial acc value
     -> [:e:]                            -- input array
     -> ([:e':], acc)
{-# INLINE loop #-}
loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr

-- general array iterator with bounds
--
loopFromTo :: Int                        -- from index
           -> Int                        -- to index
           -> (e -> acc -> (Maybe e', acc))
           -> acc
           -> [:e:]
           -> ([:e':], acc)
{-# INLINE loopFromTo #-}
loopFromTo from to mf start arr = runST (do
  marr      <- newArray (to - from + 1) noElem
  (n', acc) <- trans from to marr arr mf start
  arr'      <- mkPArr n' marr
  return (arr', acc))
  where
    noElem = error "GHC.PArr.loopFromTo: I do not exist!"
             -- unlike standard Haskell arrays, this value represents an
             -- internal error

-- actual loop body of `loop'
--
-- * for this to be really efficient, it has to be translated with the
--   constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03
--   this requires an optimisation level of at least -O2
--
trans :: Int                            -- index of first elem to process
      -> Int                            -- index of last elem to process
      -> MPArr s e'                     -- destination array
      -> [:e:]                          -- source array
      -> (e -> acc -> (Maybe e', acc))  -- mutator
      -> acc                            -- initial accumulator
      -> ST s (Int, acc)                -- final destination length/final acc
{-# INLINE trans #-}
trans from to marr arr mf start = trans' from 0 start
  where
    trans' arrOff marrOff acc 
      | arrOff > to = return (marrOff, acc)
      | otherwise   = do
                        let (oe', acc') = mf (arr `indexPArr` arrOff) acc
                        marrOff' <- case oe' of
                                      Nothing -> return marrOff 
                                      Just e' -> do
                                        writeMPArr marr marrOff e'
                                        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'
--

-- initial value for the accumulator when the accumulator is not needed
--
noAL :: ()
noAL  = ()

-- `loop' mutator maps a function over array elements
--
mapEFL   :: (e -> e') -> (e -> () -> (Maybe e', ()))
{-# INLINE mapEFL #-}
mapEFL f  = \e _ -> (Just $ f e, ())

-- `loop' mutator that filter elements according to a predicate
--
filterEFL   :: (e -> Bool) -> (e -> () -> (Maybe e, ()))
{-# INLINE filterEFL #-}
filterEFL p  = \e _ -> if p e then (Just e, ()) else (Nothing, ())

-- `loop' mutator for array folding
--
foldEFL   :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc))
{-# INLINE foldEFL #-}
foldEFL f  = \e a -> (Nothing, f e a)

-- `loop' mutator for array scanning
--
scanEFL   :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc))
{-# INLINE scanEFL #-}
scanEFL f  = \e a -> (Just a, f e a)

-- elementary array operations
--

-- unlifted array indexing 
--
indexPArr                       :: [:e:] -> Int -> e
{-# INLINE indexPArr #-}
indexPArr (PArr n# arr#) (I# i#) 
  | i# >=# 0# && i# <# n# =
    case indexArray# arr# i# of (# e #) -> e
  | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++
                        "idx = " ++ show (I# i#) ++ ", arr len = "
                        ++ show (I# n#)

-- encapsulate writing into a mutable array into the `ST' monad
--
writeMPArr                           :: MPArr s e -> Int -> e -> ST s ()
{-# INLINE writeMPArr #-}
writeMPArr (MPArr n# marr#) (I# i#) e 
  | i# >=# 0# && i# <# n# =
    ST $ \s# ->
    case writeArray# marr# i# e s# of s'# -> (# s'#, () #)
  | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++
                        "idx = " ++ show (I# i#) ++ ", arr len = "
                        ++ show (I# n#)

-}