{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Dense.Base
-- Copyright   :  (c) Christopher Chalmers
-- License     :  BSD3
--
-- Maintainer  :  Christopher Chalmers
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Base module for multidimensional arrays. This module exports the
-- constructors for the 'Array' data type.
--
-- Also, to prevent this module becomming too large, only the data types
-- and the functions nessesary for the instances are defined here. All
-- other functions are defined in "Data.Dense.Generic".
-----------------------------------------------------------------------------
module Data.Dense.Base
  (
    -- * Array types
    Array (..)
  , Boxed

    -- ** Lenses
  , vector
  , values

  -- ** Conversion to/from mutable arrays

  , unsafeThaw
  , unsafeFreeze

  -- * Delayed

  , Delayed (..)
  , delay
  , manifest
  , genDelayed
  , indexDelayed

  -- * Focused

  , Focused (..)

  ) where


#if __GLASGOW_HASKELL__ <= 708
import           Control.Applicative             (pure, (*>))
import           Data.Foldable                   (Foldable)
import           Data.Monoid                     (Monoid, mappend, mempty)
#endif

import           Control.Applicative             (liftA2)
import           Control.Comonad
import           Control.Comonad.Store
import           Control.DeepSeq
import           Control.Lens
import           Control.Lens.Internal           (noEffect)
import           Control.Monad                   (guard, liftM)
import           Control.Monad.Primitive
import           Data.Binary                     as Binary
import           Data.Bytes.Serial
import           Data.Data
import qualified Data.Foldable                   as F
import           Data.Functor.Apply
import           Data.Functor.Classes
import           Data.Functor.Extend
import           Data.Hashable
import           Data.Serialize                  as Cereal
import           Data.Traversable                (for)
import qualified Data.Vector                     as B
import           Data.Vector.Generic             (Vector)
import qualified Data.Vector.Generic             as G
import           Data.Vector.Generic.Lens        (vectorTraverse)
import qualified Data.Vector.Generic.Mutable     as GM
import qualified Data.Vector.Generic.New         as New
-- import           GHC.Generics                    (Generic, Generic1)
import           Linear                          hiding (vector)
import           Text.ParserCombinators.ReadPrec (readS_to_Prec)
import qualified Text.Read                       as Read

import           Data.Dense.Index
import           Data.Dense.Mutable              (MArray (..))

import           Control.Concurrent              (forkOn, getNumCapabilities,
                                                  newEmptyMVar, putMVar,
                                                  takeMVar)
import           System.IO.Unsafe                (unsafePerformIO)

import           Prelude                         hiding (null, replicate,
                                                  zipWith, zipWith3)

import           GHC.Types                       (SPEC (..))

-- | An 'Array' is a vector with a shape.
data Array v f a = Array !(Layout f) !(v a)
  deriving Typeable

-- Lenses --------------------------------------------------------------

-- | Indexed traversal over the elements of an array. The index is the
--   current position in the array.
values :: (Shape f, Vector v a, Vector w b)
       => IndexedTraversal (f Int) (Array v f a) (Array w f b) a b
values :: IndexedTraversal (f Int) (Array v f a) (Array w f b) a b
values = \p a (f b)
f Array v f a
arr -> (Int -> f Int)
-> (Indexed Int a (f b) -> Array v f a -> f (Array w f b))
-> p a (f b)
-> Array v f a
-> f (Array w f b)
forall j (p :: * -> * -> *) i a b r.
Indexable j p =>
(i -> j) -> (Indexed i a b -> r) -> p a b -> r
reindexed (f Int -> Int -> f Int
forall (f :: * -> *). Shape f => Layout f -> Int -> Layout f
shapeFromIndex (f Int -> Int -> f Int) -> f Int -> Int -> f Int
forall a b. (a -> b) -> a -> b
$ Array v f a -> f Int
forall (f :: * -> *) a. HasLayout f a => a -> f Int
extent Array v f a
arr) ((v a -> f (w b)) -> Array v f a -> f (Array w f b)
forall (v :: * -> *) a (w :: * -> *) b (f :: * -> *).
(Vector v a, Vector w b) =>
IndexedLens (Layout f) (Array v f a) (Array w f b) (v a) (w b)
vector ((v a -> f (w b)) -> Array v f a -> f (Array w f b))
-> (Indexed Int a (f b) -> v a -> f (w b))
-> Indexed Int a (f b)
-> Array v f a
-> f (Array w f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Indexed Int a (f b) -> v a -> f (w b)
forall (v :: * -> *) a (w :: * -> *) b.
(Vector v a, Vector w b) =>
IndexedTraversal Int (v a) (w b) a b
vectorTraverse) p a (f b)
f Array v f a
arr
{-# INLINE values #-}

-- | Indexed lens over the underlying vector of an array. The index is
--   the 'extent' of the array. You must _not_ change the length of the
--   vector, otherwise an error will be thrown (even for 'V1' layouts,
--   use 'flat' for 'V1').
vector :: (Vector v a, Vector w b) => IndexedLens (Layout f) (Array v f a) (Array w f b) (v a) (w b)
vector :: IndexedLens (Layout f) (Array v f a) (Array w f b) (v a) (w b)
vector p (v a) (f (w b))
f (Array Layout f
l v a
v) =
  p (v a) (f (w b)) -> Layout f -> v a -> f (w b)
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p (v a) (f (w b))
f Layout f
l v a
v f (w b) -> (w b -> Array w f b) -> f (Array w f b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \w b
w ->
  Int -> Int -> String -> Array w f b -> Array w f b
forall a. Int -> Int -> String -> a -> a
sizeMissmatch (v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.length v a
v) (w b -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.length w b
w)
     (String
"vector: trying to replace vector of length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.length v a
v) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with one of length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (w b -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.length w b
w))
     (Array w f b -> Array w f b) -> Array w f b -> Array w f b
forall a b. (a -> b) -> a -> b
$ Layout f -> w b -> Array w f b
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array Layout f
l w b
w
{-# INLINE vector #-}

-- Mutable conversion --------------------------------------------------

-- | O(1) Unsafe convert a mutable array to an immutable one without
-- copying. The mutable array may not be used after this operation.
unsafeFreeze :: (PrimMonad m, Vector v a)
             => MArray (G.Mutable v) f (PrimState m) a -> m (Array v f a)
unsafeFreeze :: MArray (Mutable v) f (PrimState m) a -> m (Array v f a)
unsafeFreeze (MArray Layout f
l Mutable v (PrimState m) a
mv) = Layout f -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array Layout f
l (v a -> Array v f a) -> m (v a) -> m (Array v f a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Mutable v (PrimState m) a -> m (v a)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
G.unsafeFreeze Mutable v (PrimState m) a
mv
{-# INLINE unsafeFreeze #-}

-- | O(1) Unsafely convert an immutable array to a mutable one without
--   copying. The immutable array may not be used after this operation.
unsafeThaw :: (PrimMonad m, Vector v a)
           => Array v f a -> m (MArray (G.Mutable v) f (PrimState m) a)
unsafeThaw :: Array v f a -> m (MArray (Mutable v) f (PrimState m) a)
unsafeThaw (Array Layout f
l v a
v) = Layout f
-> Mutable v (PrimState m) a
-> MArray (Mutable v) f (PrimState m) a
forall (v :: * -> * -> *) (l :: * -> *) s a.
Layout l -> v s a -> MArray v l s a
MArray Layout f
l (Mutable v (PrimState m) a -> MArray (Mutable v) f (PrimState m) a)
-> m (Mutable v (PrimState m) a)
-> m (MArray (Mutable v) f (PrimState m) a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` v a -> m (Mutable v (PrimState m) a)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
v a -> m (Mutable v (PrimState m) a)
G.unsafeThaw v a
v
{-# INLINE unsafeThaw #-}

------------------------------------------------------------------------
-- Instances
------------------------------------------------------------------------

-- | The 'size' of the 'layout' __must__ remain the same or an error is thrown.
instance Shape f => HasLayout f (Array v f a) where
  layout :: (Layout f -> f (Layout f)) -> Array v f a -> f (Array v f a)
layout Layout f -> f (Layout f)
f (Array Layout f
l v a
v) = Layout f -> f (Layout f)
f Layout f
l f (Layout f) -> (Layout f -> Array v f a) -> f (Array v f a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Layout f
l' ->
    Int -> Int -> String -> Array v f a -> Array v f a
forall a. Int -> Int -> String -> a -> a
sizeMissmatch (Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l) (Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l')
      (String
"layout (Array): trying to replace shape " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Layout f -> String
forall (f :: * -> *). Shape f => f Int -> String
showShape Layout f
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Layout f -> String
forall (f :: * -> *). Shape f => f Int -> String
showShape Layout f
l')
      (Array v f a -> Array v f a) -> Array v f a -> Array v f a
forall a b. (a -> b) -> a -> b
$ Layout f -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array Layout f
l' v a
v
  {-# INLINE layout #-}

-- layout :: (Shape l, Shape t) => Lens (Array v l a) (Array v t a) (Layout l) (Layout t)

instance (Vector v a, Eq1 f, Eq a) => Eq (Array v f a) where
  Array Layout f
l1 v a
v1 == :: Array v f a -> Array v f a -> Bool
== Array Layout f
l2 v a
v2 = Layout f -> Layout f -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 Layout f
l1 Layout f
l2 Bool -> Bool -> Bool
&& v a -> v a -> Bool
forall (v :: * -> *) a. (Vector v a, Eq a) => v a -> v a -> Bool
G.eq v a
v1 v a
v2
  {-# INLINE (==) #-}

instance (Vector v a, Show1 f, Show a) => Show (Array v f a) where
  showsPrec :: Int -> Array v f a -> String -> String
showsPrec Int
p (Array Layout f
l v a
v2) = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    String -> String -> String
showString String
"Array " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Layout f -> String -> String
forall (f :: * -> *) a.
(Show1 f, Show a) =>
Int -> f a -> String -> String
showsPrec1 Int
11 Layout f
l (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> v a -> String -> String
forall (v :: * -> *) a.
(Vector v a, Show a) =>
Int -> v a -> String -> String
G.showsPrec Int
11 v a
v2

type instance Index (Array v f a) = f Int
type instance IxValue (Array v f a) = a

instance (Shape f, Vector v a) => Ixed (Array v f a) where
  ix :: Index (Array v f a)
-> Traversal' (Array v f a) (IxValue (Array v f a))
ix Index (Array v f a)
x IxValue (Array v f a) -> f (IxValue (Array v f a))
f (Array Layout f
l v a
v)
    | Layout f -> Layout f -> Bool
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Bool
shapeInRange Layout f
l Layout f
Index (Array v f a)
x = IxValue (Array v f a) -> f (IxValue (Array v f a))
f (v a -> Int -> a
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
G.unsafeIndex v a
v Int
i) f a -> (a -> Array v f a) -> f (Array v f a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
        \a
a -> Layout f -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array Layout f
l ((forall s. Mutable v s a -> ST s ()) -> v a -> v a
forall (v :: * -> *) a.
Vector v a =>
(forall s. Mutable v s a -> ST s ()) -> v a -> v a
G.modify (\Mutable v s a
mv -> Mutable v (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
GM.unsafeWrite Mutable v s a
Mutable v (PrimState (ST s)) a
mv Int
i a
a) v a
v)
      where i :: Int
i = Layout f -> Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Int
shapeToIndex Layout f
l Layout f
Index (Array v f a)
x
  ix Index (Array v f a)
_ IxValue (Array v f a) -> f (IxValue (Array v f a))
_ Array v f a
arr = Array v f a -> f (Array v f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Array v f a
arr
  {-# INLINE ix #-}

instance (Vector v a, Vector v b) => Each (Array v f a) (Array v f b) a b where
  each :: (a -> f b) -> Array v f a -> f (Array v f b)
each = (v a -> f (v b)) -> Array v f a -> f (Array v f b)
forall (v :: * -> *) a (w :: * -> *) b (f :: * -> *).
(Vector v a, Vector w b) =>
IndexedLens (Layout f) (Array v f a) (Array w f b) (v a) (w b)
vector ((v a -> f (v b)) -> Array v f a -> f (Array v f b))
-> ((a -> f b) -> v a -> f (v b))
-> (a -> f b)
-> Array v f a
-> f (Array v f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> v a -> f (v b)
forall (v :: * -> *) a (w :: * -> *) b.
(Vector v a, Vector w b) =>
IndexedTraversal Int (v a) (w b) a b
vectorTraverse
  {-# INLINE each #-}

instance (Shape f, Vector v a) => AsEmpty (Array v f a) where
  _Empty :: p () (f ()) -> p (Array v f a) (f (Array v f a))
_Empty = Array v f a -> (Array v f a -> Bool) -> Prism' (Array v f a) ()
forall a. a -> (a -> Bool) -> Prism' a ()
nearly (Layout f -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array Layout f
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero v a
forall (v :: * -> *) a. Vector v a => v a
G.empty) ((Int -> Bool) -> Layout f -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) (Layout f -> Bool)
-> (Array v f a -> Layout f) -> Array v f a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array v f a -> Layout f
forall (f :: * -> *) a. HasLayout f a => a -> f Int
extent)
  {-# INLINE _Empty #-}

instance (Vector v a, Read1 f, Read a) => Read (Array v f a) where
  readPrec :: ReadPrec (Array v f a)
readPrec = ReadPrec (Array v f a) -> ReadPrec (Array v f a)
forall a. ReadPrec a -> ReadPrec a
Read.parens (ReadPrec (Array v f a) -> ReadPrec (Array v f a))
-> ReadPrec (Array v f a) -> ReadPrec (Array v f a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Array v f a) -> ReadPrec (Array v f a)
forall a. Int -> ReadPrec a -> ReadPrec a
Read.prec Int
10 (ReadPrec (Array v f a) -> ReadPrec (Array v f a))
-> ReadPrec (Array v f a) -> ReadPrec (Array v f a)
forall a b. (a -> b) -> a -> b
$ do
    Read.Ident String
"Array" <- ReadPrec Lexeme
Read.lexP
    f Int
l <- (Int -> ReadS (f Int)) -> ReadPrec (f Int)
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec Int -> ReadS (f Int)
forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1
    v a
v <- ReadPrec (v a)
forall (v :: * -> *) a. (Vector v a, Read a) => ReadPrec (v a)
G.readPrec
    Array v f a -> ReadPrec (Array v f a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array v f a -> ReadPrec (Array v f a))
-> Array v f a -> ReadPrec (Array v f a)
forall a b. (a -> b) -> a -> b
$ f Int -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array f Int
l v a
v

instance (NFData (f Int), NFData (v a)) => NFData (Array v f a) where
  rnf :: Array v f a -> ()
rnf (Array f Int
l v a
v) = f Int -> ()
forall a. NFData a => a -> ()
rnf f Int
l () -> () -> ()
`seq` v a -> ()
forall a. NFData a => a -> ()
rnf v a
v
  {-# INLINE rnf #-}

-- Boxed instances -----------------------------------------------------

-- | The vector is the boxed vector.
type Boxed v = v ~ B.Vector

instance Boxed v => Functor (Array v f) where
  fmap :: (a -> b) -> Array v f a -> Array v f b
fmap = ASetter (Array v f a) (Array v f b) (Vector a) (Vector b)
-> (Vector a -> Vector b) -> Array v f a -> Array v f b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Array v f a) (Array v f b) (Vector a) (Vector b)
forall (v :: * -> *) a (w :: * -> *) b (f :: * -> *).
(Vector v a, Vector w b) =>
IndexedLens (Layout f) (Array v f a) (Array w f b) (v a) (w b)
vector ((Vector a -> Vector b) -> Array v f a -> Array v f b)
-> ((a -> b) -> Vector a -> Vector b)
-> (a -> b)
-> Array v f a
-> Array v f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  {-# INLINE fmap #-}

instance Boxed v => F.Foldable (Array v f) where
  foldMap :: (a -> m) -> Array v f a -> m
foldMap a -> m
f = (a -> m) -> Vector a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f (Vector a -> m) -> (Array v f a -> Vector a) -> Array v f a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Vector a) (Array Vector f a) (Vector a)
-> Array Vector f a -> Vector a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Vector a) (Array Vector f a) (Vector a)
forall (v :: * -> *) a (w :: * -> *) b (f :: * -> *).
(Vector v a, Vector w b) =>
IndexedLens (Layout f) (Array v f a) (Array w f b) (v a) (w b)
vector
  {-# INLINE foldMap #-}

instance Boxed v => Traversable (Array v f) where
  traverse :: (a -> f b) -> Array v f a -> f (Array v f b)
traverse = (a -> f b) -> Array v f a -> f (Array v f b)
forall s t a b. Each s t a b => Traversal s t a b
each
  {-# INLINE traverse #-}

#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0))
instance (Boxed v, Eq1 f) => Eq1 (Array v f) where
  liftEq :: (a -> b -> Bool) -> Array v f a -> Array v f b -> Bool
liftEq a -> b -> Bool
f (Array Layout f
l1 v a
v1) (Array Layout f
l2 v b
v2) = Layout f -> Layout f -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 Layout f
l1 Layout f
l2 Bool -> Bool -> Bool
&& v Bool -> Bool
forall (v :: * -> *). Vector v Bool => v Bool -> Bool
G.and ((a -> b -> Bool) -> v a -> v b -> v Bool
forall (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
G.zipWith a -> b -> Bool
f v a
v1 v b
v2)
  {-# INLINE liftEq #-}

instance (Boxed v, Read1 f) => Read1 (Array v f) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array v f a)
liftReadsPrec Int -> ReadS a
_ ReadS [a]
f = (String -> ReadS (Array v f a)) -> Int -> ReadS (Array v f a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Array v f a)) -> Int -> ReadS (Array v f a))
-> (String -> ReadS (Array v f a)) -> Int -> ReadS (Array v f a)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS (f Int))
-> (Int -> ReadS [a])
-> String
-> (f Int -> [a] -> Array v f a)
-> String
-> ReadS (Array v f a)
forall a b t.
(Int -> ReadS a)
-> (Int -> ReadS b) -> String -> (a -> b -> t) -> String -> ReadS t
readsBinaryWith Int -> ReadS (f Int)
forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1 (ReadS [a] -> Int -> ReadS [a]
forall a b. a -> b -> a
const ReadS [a]
f) String
"Array" (\f Int
c [a]
l -> f Int -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array f Int
c ([a] -> v a
forall (v :: * -> *) a. Vector v a => [a] -> v a
G.fromList [a]
l))
  {-# INLINE liftReadsPrec #-}
#else
instance (Boxed v, Eq1 f) => Eq1 (Array v f) where
  eq1 = (==)
  {-# INLINE eq1 #-}

instance (Boxed v, Read1 f) => Read1 (Array v f) where
  readsPrec1 = readsPrec
  {-# INLINE readsPrec1 #-}
#endif

instance (Boxed v, Shape f) => FunctorWithIndex (f Int) (Array v f)
instance (Boxed v, Shape f) => FoldableWithIndex (f Int) (Array v f)
instance (Boxed v, Shape f) => TraversableWithIndex (f Int) (Array v f) where
  itraverse :: (f Int -> a -> f b) -> Array v f a -> f (Array v f b)
itraverse = (Indexed (f Int) a (f b) -> Array v f a -> f (Array v f b))
-> (f Int -> a -> f b) -> Array v f a -> f (Array v f b)
forall i a (f :: * -> *) b s t.
(Indexed i a (f b) -> s -> f t) -> (i -> a -> f b) -> s -> f t
itraverseOf Indexed (f Int) a (f b) -> Array v f a -> f (Array v f b)
forall (f :: * -> *) (v :: * -> *) a (w :: * -> *) b.
(Shape f, Vector v a, Vector w b) =>
IndexedTraversal (f Int) (Array v f a) (Array w f b) a b
values
  {-# INLINE itraverse #-}
  itraversed :: p a (f b) -> Array v f a -> f (Array v f b)
itraversed = p a (f b) -> Array v f a -> f (Array v f b)
forall (f :: * -> *) (v :: * -> *) a (w :: * -> *) b.
(Shape f, Vector v a, Vector w b) =>
IndexedTraversal (f Int) (Array v f a) (Array w f b) a b
values
  {-# INLINE itraversed #-}

instance (Boxed v, Shape f, Serial1 f) => Serial1 (Array v f) where
  serializeWith :: (a -> m ()) -> Array v f a -> m ()
serializeWith a -> m ()
putF (Array Layout f
l v a
v) = do
    (Int -> m ()) -> Layout f -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Serial1 f, MonadPut m) =>
(a -> m ()) -> f a -> m ()
serializeWith Int -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Layout f
l
    (a -> m ()) -> v a -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ a -> m ()
putF v a
v
  deserializeWith :: m a -> m (Array v f a)
deserializeWith = m (Layout f) -> m a -> m (Array v f a)
forall (m :: * -> *) (v :: * -> *) a (f :: * -> *).
(Monad m, Vector v a, Shape f) =>
m (f Int) -> m a -> m (Array v f a)
genGet (m Int -> m (Layout f)
forall (f :: * -> *) (m :: * -> *) a.
(Serial1 f, MonadGet m) =>
m a -> m (f a)
deserializeWith m Int
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize)

-- deriving instance (Generic1 v, Generic1 f) => Generic1 (Array v f)

-- instance (v ~ B.Vector, Shape l) => Apply (Array v l) where
-- instance (v ~ B.Vector, Shape l) => Bind (Array v l) where
-- instance (v ~ B.Vector, Shape l) => Additive (Array v l) where
-- instance (v ~ B.Vector, Shape l) => Metric (Array v l) where

-- V1 instances --------------------------------------------------------

-- Array v V1 a is essentially v a with a wrapper.

type instance G.Mutable (Array v f) = MArray (G.Mutable v) f

-- | 1D Arrays can be used as a generic 'Vector'.
instance (Vector v a, f ~ V1) => Vector (Array v f) a where
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw   #-}
  {-# INLINE basicLength       #-}
  {-# INLINE basicUnsafeSlice  #-}
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeFreeze :: Mutable (Array v f) (PrimState m) a -> m (Array v f a)
basicUnsafeFreeze                = Mutable (Array v f) (PrimState m) a -> m (Array v f a)
forall (m :: * -> *) (v :: * -> *) a (f :: * -> *).
(PrimMonad m, Vector v a) =>
MArray (Mutable v) f (PrimState m) a -> m (Array v f a)
unsafeFreeze
  basicUnsafeThaw :: Array v f a -> m (Mutable (Array v f) (PrimState m) a)
basicUnsafeThaw                  = Array v f a -> m (Mutable (Array v f) (PrimState m) a)
forall (m :: * -> *) (v :: * -> *) a (f :: * -> *).
(PrimMonad m, Vector v a) =>
Array v f a -> m (MArray (Mutable v) f (PrimState m) a)
unsafeThaw
  basicLength :: Array v f a -> Int
basicLength (Array (V1 n) v a
_)     = Int
n
  basicUnsafeSlice :: Int -> Int -> Array v f a -> Array v f a
basicUnsafeSlice Int
i Int
n (Array Layout f
_ v a
v) = Layout V1 -> v a -> Array v V1 a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array (Int -> Layout V1
forall a. a -> V1 a
V1 Int
n) (v a -> Array v V1 a) -> v a -> Array v V1 a
forall a b. (a -> b) -> a -> b
$ Int -> Int -> v a -> v a
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
G.basicUnsafeSlice Int
i Int
n v a
v
  basicUnsafeIndexM :: Array v f a -> Int -> m a
basicUnsafeIndexM (Array Layout f
_ v a
v)    = v a -> Int -> m a
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, Monad m) =>
v a -> Int -> m a
G.basicUnsafeIndexM v a
v

-- Serialise instances -------------------------------------------------

instance (Vector v a, Shape f, Serial1 f, Serial a) => Serial (Array v f a) where
  serialize :: Array v f a -> m ()
serialize (Array Layout f
l v a
v) = do
    (Int -> m ()) -> Layout f -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Serial1 f, MonadPut m) =>
(a -> m ()) -> f a -> m ()
serializeWith Int -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Layout f
l
    Getting (Traversed () m) (v a) a -> (a -> m ()) -> v a -> m ()
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> (a -> f r) -> s -> f ()
traverseOf_ Getting (Traversed () m) (v a) a
forall (v :: * -> *) a (w :: * -> *) b.
(Vector v a, Vector w b) =>
IndexedTraversal Int (v a) (w b) a b
vectorTraverse a -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize v a
v
  {-# INLINE serialize #-}
  deserialize :: m (Array v f a)
deserialize = m (Layout f) -> m a -> m (Array v f a)
forall (m :: * -> *) (v :: * -> *) a (f :: * -> *).
(Monad m, Vector v a, Shape f) =>
m (f Int) -> m a -> m (Array v f a)
genGet (m Int -> m (Layout f)
forall (f :: * -> *) (m :: * -> *) a.
(Serial1 f, MonadGet m) =>
m a -> m (f a)
deserializeWith m Int
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize) m a
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
  {-# INLINE deserialize #-}

instance (Vector v a, Shape f, Binary (f Int), Binary a) => Binary (Array v f a) where
  put :: Array v f a -> Put
put (Array f Int
l v a
v) = do
    f Int -> Put
forall t. Binary t => t -> Put
Binary.put f Int
l
    Getting (Traversed () PutM) (v a) a -> (a -> Put) -> v a -> Put
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> (a -> f r) -> s -> f ()
traverseOf_ Getting (Traversed () PutM) (v a) a
forall (v :: * -> *) a (w :: * -> *) b.
(Vector v a, Vector w b) =>
IndexedTraversal Int (v a) (w b) a b
vectorTraverse a -> Put
forall t. Binary t => t -> Put
Binary.put v a
v
  {-# INLINE put #-}
  get :: Get (Array v f a)
get = Get (f Int) -> Get a -> Get (Array v f a)
forall (m :: * -> *) (v :: * -> *) a (f :: * -> *).
(Monad m, Vector v a, Shape f) =>
m (f Int) -> m a -> m (Array v f a)
genGet Get (f Int)
forall t. Binary t => Get t
Binary.get Get a
forall t. Binary t => Get t
Binary.get
  {-# INLINE get #-}

instance (Vector v a, Shape f, Serialize (f Int), Serialize a) => Serialize (Array v f a) where
  put :: Putter (Array v f a)
put (Array f Int
l v a
v) = do
    Putter (f Int)
forall t. Serialize t => Putter t
Cereal.put f Int
l
    Getting (Traversed () PutM) (v a) a -> (a -> Put) -> v a -> Put
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> (a -> f r) -> s -> f ()
traverseOf_ Getting (Traversed () PutM) (v a) a
forall (v :: * -> *) a (w :: * -> *) b.
(Vector v a, Vector w b) =>
IndexedTraversal Int (v a) (w b) a b
vectorTraverse a -> Put
forall t. Serialize t => Putter t
Cereal.put v a
v
  {-# INLINE put #-}
  get :: Get (Array v f a)
get = Get (f Int) -> Get a -> Get (Array v f a)
forall (m :: * -> *) (v :: * -> *) a (f :: * -> *).
(Monad m, Vector v a, Shape f) =>
m (f Int) -> m a -> m (Array v f a)
genGet Get (f Int)
forall t. Serialize t => Get t
Cereal.get Get a
forall t. Serialize t => Get t
Cereal.get
  {-# INLINE get #-}

genGet :: Monad m => (Vector v a, Shape f) => m (f Int) -> m a -> m (Array v f a)
genGet :: m (f Int) -> m a -> m (Array v f a)
genGet m (f Int)
getL m a
getA = do
  f Int
l <- m (f Int)
getL
  let n :: Int
n       = f Int -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize f Int
l
      nv0 :: New v a
nv0     = (forall s. ST s (Mutable v s a)) -> New v a
forall (v :: * -> *) a. (forall s. ST s (Mutable v s a)) -> New v a
New.create (Int -> ST s (Mutable v (PrimState (ST s)) a)
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
GM.new Int
n)
      f :: New v a -> Int -> m (New v a)
f New v a
acc Int
i = (\a
a -> (forall s. Mutable v s a -> ST s ()) -> New v a -> New v a
forall (v :: * -> *) a.
(forall s. Mutable v s a -> ST s ()) -> New v a -> New v a
New.modify (\Mutable v s a
mv -> Mutable v (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
GM.write Mutable v s a
Mutable v (PrimState (ST s)) a
mv Int
i a
a) New v a
acc) (a -> New v a) -> m a -> m (New v a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m a
getA
  New v a
nv <- (New v a -> Int -> m (New v a)) -> New v a -> [Int] -> m (New v a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM New v a -> Int -> m (New v a)
f New v a
nv0 [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  Array v f a -> m (Array v f a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array v f a -> m (Array v f a)) -> Array v f a -> m (Array v f a)
forall a b. (a -> b) -> a -> b
$! f Int -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array f Int
l (New v a -> v a
forall (v :: * -> *) a. Vector v a => New v a -> v a
G.new New v a
nv)
{-# INLINE genGet #-}

instance (Vector v a, Foldable f, Hashable a) => Hashable (Array v f a) where
  hashWithSalt :: Int -> Array v f a -> Int
hashWithSalt Int
s (Array Layout f
l v a
v) = (Int -> a -> Int) -> Int -> v a -> Int
forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
G.foldl' Int -> a -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s' v a
v
    where s' :: Int
s' = (Int -> Int -> Int) -> Int -> Layout f -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s Layout f
l
  {-# INLINE hashWithSalt #-}

-- deriving instance (Generic (v a), Generic1 f) => Generic (Array v f a)
deriving instance (Typeable f, Typeable v, Typeable a, Data (f Int), Data (v a)) => Data (Array v f a)


-- instance (Vector v a, Typeable v, Typeable l, Shape l, Data a) => Data (Array v l a) where
--   gfoldl f z (Array l a) =
--     z (\l' a' -> Array (l & partsOf traverse .~ l') (G.fromList a')) `f` F.toList l `f` G.toList a
--   gunfold k z _ = k (k (z (\l a -> Array (zero & partsOf traverse .~ l) (G.fromList a))))
--   toConstr _ = con
--   dataTypeOf _ = ty
--   dataCast1 = gcast1

-- ty :: DataType
-- ty = mkDataType "Array" [con]

-- con :: Constr
-- con = mkConstr ty "Array" [] Prefix

------------------------------------------------------------------------
-- Delayed
------------------------------------------------------------------------

-- | A delayed representation of an array. This useful for mapping over
--   an array in parallel.
data Delayed f a = Delayed !(Layout f) (f Int -> a)
  deriving (Typeable, a -> Delayed f b -> Delayed f a
(a -> b) -> Delayed f a -> Delayed f b
(forall a b. (a -> b) -> Delayed f a -> Delayed f b)
-> (forall a b. a -> Delayed f b -> Delayed f a)
-> Functor (Delayed f)
forall a b. a -> Delayed f b -> Delayed f a
forall a b. (a -> b) -> Delayed f a -> Delayed f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) a b. a -> Delayed f b -> Delayed f a
forall (f :: * -> *) a b. (a -> b) -> Delayed f a -> Delayed f b
<$ :: a -> Delayed f b -> Delayed f a
$c<$ :: forall (f :: * -> *) a b. a -> Delayed f b -> Delayed f a
fmap :: (a -> b) -> Delayed f a -> Delayed f b
$cfmap :: forall (f :: * -> *) a b. (a -> b) -> Delayed f a -> Delayed f b
Functor)

-- | Turn a material array into a delayed one with the same shape.
delay :: (Vector v a, Shape f) => Array v f a -> Delayed f a
delay :: Array v f a -> Delayed f a
delay (Array Layout f
l v a
v) = Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
l (v a -> Int -> a
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
G.unsafeIndex v a
v (Int -> a) -> (Layout f -> Int) -> Layout f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout f -> Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Int
shapeToIndex Layout f
l)
{-# INLINE delay #-}

-- | The 'size' of the 'layout' __must__ remain the same or an error is thrown.
instance Shape f => HasLayout f (Delayed f a) where
  layout :: (Layout f -> f (Layout f)) -> Delayed f a -> f (Delayed f a)
layout Layout f -> f (Layout f)
f (Delayed Layout f
l Layout f -> a
ixF) = Layout f -> f (Layout f)
f Layout f
l f (Layout f) -> (Layout f -> Delayed f a) -> f (Delayed f a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Layout f
l' ->
    Int -> Int -> String -> Delayed f a -> Delayed f a
forall a. Int -> Int -> String -> a -> a
sizeMissmatch (Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l) (Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l')
      (String
"layout (Delayed): trying to replace shape " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Layout f -> String
forall (f :: * -> *). Shape f => f Int -> String
showShape Layout f
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Layout f -> String
forall (f :: * -> *). Shape f => f Int -> String
showShape Layout f
l')
      (Delayed f a -> Delayed f a) -> Delayed f a -> Delayed f a
forall a b. (a -> b) -> a -> b
$ Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
l' Layout f -> a
ixF
  {-# INLINE layout #-}

-- | 'foldMap' in parallel.
instance Shape f => Foldable (Delayed f) where
  foldr :: (a -> b -> b) -> b -> Delayed f a -> b
foldr a -> b -> b
f b
b (Delayed Layout f
l Layout f -> a
ixF) = Getting (Endo b) (Layout f) (Layout f)
-> (Layout f -> b -> b) -> b -> Layout f -> b
forall r s a. Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r
foldrOf Getting (Endo b) (Layout f) (Layout f)
forall (f :: * -> *).
Shape f =>
IndexedFold Int (Layout f) (Layout f)
shapeIndexes (\Layout f
x -> a -> b -> b
f (Layout f -> a
ixF Layout f
x)) b
b Layout f
l
  {-# INLINE foldr #-}

  foldMap :: (a -> m) -> Delayed f a -> m
foldMap = (Layout f -> a -> m) -> Delayed f a -> m
forall (f :: * -> *) m a.
(Shape f, Monoid m) =>
(f Int -> a -> m) -> Delayed f a -> m
foldDelayed ((Layout f -> a -> m) -> Delayed f a -> m)
-> ((a -> m) -> Layout f -> a -> m) -> (a -> m) -> Delayed f a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m) -> Layout f -> a -> m
forall a b. a -> b -> a
const

#if __GLASGOW_HASKELL__ >= 710
  length :: Delayed f a -> Int
length = Delayed f a -> Int
forall (f :: * -> *) a. HasLayout f a => a -> Int
size
  {-# INLINE length #-}
#endif

instance (Shape f, Show1 f, Show a) => Show (Delayed f a) where
  showsPrec :: Int -> Delayed f a -> String -> String
showsPrec Int
p arr :: Delayed f a
arr@(Delayed Layout f
l Layout f -> a
_) = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    String -> String -> String
showString String
"Delayed " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Layout f -> String -> String
forall (f :: * -> *) a.
(Show1 f, Show a) =>
Int -> f a -> String -> String
showsPrec1 Int
11 Layout f
l (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 (Delayed f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Delayed f a
arr)

-- instance (Shape f, Show1 f) => Show1 (Delayed f) where
--   showsPrec1 = showsPrec

instance Shape f => Traversable (Delayed f) where
  traverse :: (a -> f b) -> Delayed f a -> f (Delayed f b)
traverse a -> f b
f Delayed f a
arr = Array Vector f b -> Delayed f b
forall (v :: * -> *) a (f :: * -> *).
(Vector v a, Shape f) =>
Array v f a -> Delayed f a
delay (Array Vector f b -> Delayed f b)
-> f (Array Vector f b) -> f (Delayed f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Array Vector f a -> f (Array Vector f b)
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed a -> f b
f (Delayed f a -> Array Vector f a
forall (v :: * -> *) a (f :: * -> *).
(Vector v a, Shape f) =>
Delayed f a -> Array v f a
manifest Delayed f a
arr)

instance Shape f => Apply (Delayed f) where
  {-# INLINE (<.>) #-}
  {-# INLINE (<. ) #-}
  {-# INLINE ( .>) #-}
  <.> :: Delayed f (a -> b) -> Delayed f a -> Delayed f b
(<.>) = ((a -> b) -> a -> b)
-> Delayed f (a -> b) -> Delayed f a -> Delayed f b
forall (f :: * -> *) a b c.
Additive f =>
(a -> b -> c) -> f a -> f b -> f c
liftI2 (a -> b) -> a -> b
forall a. a -> a
id
  (<. ) = (a -> b -> a) -> Delayed f a -> Delayed f b -> Delayed f a
forall (f :: * -> *) a b c.
Additive f =>
(a -> b -> c) -> f a -> f b -> f c
liftI2 a -> b -> a
forall a b. a -> b -> a
const
  ( .>) = (a -> b -> b) -> Delayed f a -> Delayed f b -> Delayed f b
forall (f :: * -> *) a b c.
Additive f =>
(a -> b -> c) -> f a -> f b -> f c
liftI2 ((b -> b) -> a -> b -> b
forall a b. a -> b -> a
const b -> b
forall a. a -> a
id)

instance Shape f => Additive (Delayed f) where
  zero :: Delayed f a
zero = Tagged () (Identity ())
-> Tagged (Delayed f a) (Identity (Delayed f a))
forall a. AsEmpty a => Prism' a ()
_Empty (Tagged () (Identity ())
 -> Tagged (Delayed f a) (Identity (Delayed f a)))
-> () -> Delayed f a
forall t b. AReview t b -> b -> t
# ()
  {-# INLINE zero #-}

  -- This can only be satisfied on if one array is larger than the other
  -- in all dimensions, otherwise there will be gaps in the array
  liftU2 :: (a -> a -> a) -> Delayed f a -> Delayed f a -> Delayed f a
liftU2 a -> a -> a
f (Delayed Layout f
l Layout f -> a
ixF) (Delayed Layout f
k Layout f -> a
ixG)
    | Layout f
l Layout f -> Layout f -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
`eq1` Layout f
k       = Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
l ((a -> a -> a)
-> (Layout f -> a) -> (Layout f -> a) -> Layout f -> a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
f Layout f -> a
ixF Layout f -> a
ixG)

    -- l > k
    | (Ordering -> Bool) -> f Ordering -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (Ordering -> Ordering -> Bool
forall a. Ord a => a -> a -> Bool
>= Ordering
EQ) f Ordering
cmp = Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
l ((Layout f -> a) -> Delayed f a) -> (Layout f -> a) -> Delayed f a
forall a b. (a -> b) -> a -> b
$ \Layout f
x ->
        if | Layout f -> Layout f -> Bool
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Bool
shapeInRange Layout f
l Layout f
x -> (a -> a -> a)
-> (Layout f -> a) -> (Layout f -> a) -> Layout f -> a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
f Layout f -> a
ixF Layout f -> a
ixG Layout f
x
           | Bool
otherwise        -> Layout f -> a
ixF Layout f
x

    -- k > l
    | (Ordering -> Bool) -> f Ordering -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (Ordering -> Ordering -> Bool
forall a. Ord a => a -> a -> Bool
<= Ordering
EQ) f Ordering
cmp = Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
k ((Layout f -> a) -> Delayed f a) -> (Layout f -> a) -> Delayed f a
forall a b. (a -> b) -> a -> b
$ \Layout f
x ->
        if | Layout f -> Layout f -> Bool
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Bool
shapeInRange Layout f
k Layout f
x -> (a -> a -> a)
-> (Layout f -> a) -> (Layout f -> a) -> Layout f -> a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
f Layout f -> a
ixF Layout f -> a
ixG Layout f
x
           | Bool
otherwise        -> Layout f -> a
ixG Layout f
x

    -- not possible to union array sizes because there would be gaps,
    -- just intersect them instead
    | Bool
otherwise       = Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed (Layout f -> Layout f -> Layout f
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Layout f
shapeIntersect Layout f
l Layout f
k) ((Layout f -> a) -> Delayed f a) -> (Layout f -> a) -> Delayed f a
forall a b. (a -> b) -> a -> b
$ (a -> a -> a)
-> (Layout f -> a) -> (Layout f -> a) -> Layout f -> a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
f Layout f -> a
ixF Layout f -> a
ixG
    where cmp :: f Ordering
cmp = (Int -> Int -> Ordering) -> Layout f -> Layout f -> f Ordering
forall (f :: * -> *) a b c.
Additive f =>
(a -> b -> c) -> f a -> f b -> f c
liftI2 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Layout f
l Layout f
k

  liftI2 :: (a -> b -> c) -> Delayed f a -> Delayed f b -> Delayed f c
liftI2 a -> b -> c
f (Delayed Layout f
l Layout f -> a
ixF) (Delayed Layout f
k Layout f -> b
ixG) = Layout f -> (Layout f -> c) -> Delayed f c
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed (Layout f -> Layout f -> Layout f
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Layout f
shapeIntersect Layout f
l Layout f
k) ((Layout f -> c) -> Delayed f c) -> (Layout f -> c) -> Delayed f c
forall a b. (a -> b) -> a -> b
$ (a -> b -> c)
-> (Layout f -> a) -> (Layout f -> b) -> Layout f -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Layout f -> a
ixF Layout f -> b
ixG
  {-# INLINE liftI2 #-}

instance Shape f => Metric (Delayed f)

instance FunctorWithIndex (f Int) (Delayed f) where
  imap :: (f Int -> a -> b) -> Delayed f a -> Delayed f b
imap f Int -> a -> b
f (Delayed f Int
l f Int -> a
ixF) = f Int -> (f Int -> b) -> Delayed f b
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed f Int
l ((f Int -> b) -> Delayed f b) -> (f Int -> b) -> Delayed f b
forall a b. (a -> b) -> a -> b
$ \f Int
x -> f Int -> a -> b
f f Int
x (f Int -> a
ixF f Int
x)
  {-# INLINE imap #-}

-- | 'ifoldMap' in parallel.
instance Shape f => FoldableWithIndex (f Int) (Delayed f) where
  ifoldr :: (f Int -> a -> b -> b) -> b -> Delayed f a -> b
ifoldr f Int -> a -> b -> b
f b
b (Delayed f Int
l f Int -> a
ixF) = Getting (Endo b) (f Int) (f Int)
-> (f Int -> b -> b) -> b -> f Int -> b
forall r s a. Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r
foldrOf Getting (Endo b) (f Int) (f Int)
forall (f :: * -> *).
Shape f =>
IndexedFold Int (Layout f) (Layout f)
shapeIndexes (\f Int
x -> f Int -> a -> b -> b
f f Int
x (f Int -> a
ixF f Int
x)) b
b f Int
l
  {-# INLINE ifoldr #-}

  ifolded :: p a (f a) -> Delayed f a -> f (Delayed f a)
ifolded = ((f Int -> a -> f a -> f a) -> f a -> Delayed f a -> f a)
-> p a (f a) -> Delayed f a -> f (Delayed f a)
forall i (p :: * -> * -> *) (f :: * -> *) a s t b.
(Indexable i p, Contravariant f, Applicative f) =>
((i -> a -> f a -> f a) -> f a -> s -> f a) -> Over p f s t a b
ifoldring (f Int -> a -> f a -> f a) -> f a -> Delayed f a -> f a
forall i (f :: * -> *) a b.
FoldableWithIndex i f =>
(i -> a -> b -> b) -> b -> f a -> b
ifoldr
  {-# INLINE ifolded #-}

  ifoldMap :: (f Int -> a -> m) -> Delayed f a -> m
ifoldMap = (f Int -> a -> m) -> Delayed f a -> m
forall (f :: * -> *) m a.
(Shape f, Monoid m) =>
(f Int -> a -> m) -> Delayed f a -> m
foldDelayed
  {-# INLINE ifoldMap #-}

instance Shape f => TraversableWithIndex (f Int) (Delayed f) where
  itraverse :: (f Int -> a -> f b) -> Delayed f a -> f (Delayed f b)
itraverse f Int -> a -> f b
f Delayed f a
arr = Array Vector f b -> Delayed f b
forall (v :: * -> *) a (f :: * -> *).
(Vector v a, Shape f) =>
Array v f a -> Delayed f a
delay (Array Vector f b -> Delayed f b)
-> f (Array Vector f b) -> f (Delayed f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f Int -> a -> f b) -> Array Vector f a -> f (Array Vector f b)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse f Int -> a -> f b
f (Delayed f a -> Array Vector f a
forall (v :: * -> *) a (f :: * -> *).
(Vector v a, Shape f) =>
Delayed f a -> Array v f a
manifest Delayed f a
arr)
  {-# INLINE itraverse #-}

instance Shape f => Each (Delayed f a) (Delayed f b) a b where
  each :: (a -> f b) -> Delayed f a -> f (Delayed f b)
each = (a -> f b) -> Delayed f a -> f (Delayed f b)
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed
  {-# INLINE each #-}

instance Shape f => AsEmpty (Delayed f a) where
  _Empty :: p () (f ()) -> p (Delayed f a) (f (Delayed f a))
_Empty = Delayed f a -> (Delayed f a -> Bool) -> Prism' (Delayed f a) ()
forall a. a -> (a -> Bool) -> Prism' a ()
nearly (Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero (String -> Layout f -> a
forall a. HasCallStack => String -> a
error String
"empty delayed array"))
                  (\(Delayed Layout f
l Layout f -> a
_) -> (Int -> Bool) -> Layout f -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) Layout f
l)
  {-# INLINE _Empty #-}

type instance Index (Delayed f a) = f Int
type instance IxValue (Delayed f a) = a
instance Shape f => Ixed (Delayed f a) where
  ix :: Index (Delayed f a)
-> Traversal' (Delayed f a) (IxValue (Delayed f a))
ix Index (Delayed f a)
x IxValue (Delayed f a) -> f (IxValue (Delayed f a))
f arr :: Delayed f a
arr@(Delayed Layout f
l Layout f -> a
ixF)
    | Layout f -> Layout f -> Bool
forall (f :: * -> *). Shape f => Layout f -> Layout f -> Bool
shapeInRange Layout f
l Layout f
Index (Delayed f a)
x = IxValue (Delayed f a) -> f (IxValue (Delayed f a))
f (Layout f -> a
ixF Layout f
Index (Delayed f a)
x) f a -> (a -> Delayed f a) -> f (Delayed f a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \a
a ->
      let g :: Layout f -> a
g Layout f
y | Layout f -> Layout f -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 Layout f
Index (Delayed f a)
x Layout f
y   = a
a
              | Bool
otherwise = Layout f -> a
ixF Layout f
Index (Delayed f a)
x
      in  Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
l Layout f -> a
g
    | Bool
otherwise        = Delayed f a -> f (Delayed f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Delayed f a
arr
  {-# INLINE ix #-}

-- | Index a delayed array, returning a 'IndexOutOfBounds' exception if
--   the index is out of range.
indexDelayed :: Shape f => Delayed f a -> f Int -> a
indexDelayed :: Delayed f a -> f Int -> a
indexDelayed (Delayed f Int
l f Int -> a
ixF) f Int
x =
  f Int -> f Int -> a -> a
forall (l :: * -> *) a. Shape l => Layout l -> Layout l -> a -> a
boundsCheck f Int
l f Int
x (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ f Int -> a
ixF f Int
x
{-# INLINE indexDelayed #-}

foldDelayed :: (Shape f, Monoid m) => (f Int -> a -> m) -> (Delayed f a) -> m
foldDelayed :: (f Int -> a -> m) -> Delayed f a -> m
foldDelayed f Int -> a -> m
f (Delayed f Int
l f Int -> a
ixF) = IO m -> m
forall a. IO a -> a
unsafePerformIO (IO m -> m) -> IO m -> m
forall a b. (a -> b) -> a -> b
$ do
  [MVar m]
childs <- [Int] -> (Int -> IO (MVar m)) -> IO [MVar m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Int
0 .. Int
threads Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO (MVar m)) -> IO [MVar m])
-> (Int -> IO (MVar m)) -> IO [MVar m]
forall a b. (a -> b) -> a -> b
$ \Int
c -> do
    MVar m
child <- IO (MVar m)
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <- Int -> IO () -> IO ThreadId
forkOn Int
c (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      let k :: Int
k | Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
threads Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 = Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r
            | Bool
otherwise        = Int
q
          x :: Int
x = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
q
          m :: Int
m = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k
          go :: Int -> Maybe (f Int) -> m -> m
go Int
i (Just f Int
s) m
acc
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
m       = m
acc
            | Bool
otherwise    = let !acc' :: m
acc' = m
acc m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` f Int -> a -> m
f f Int
s (f Int -> a
ixF f Int
s)
                             in  Int -> Maybe (f Int) -> m -> m
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (f Int -> f Int -> Maybe (f Int)
forall (f :: * -> *).
Shape f =>
Layout f -> Layout f -> Maybe (Layout f)
shapeStep f Int
l f Int
s) m
acc'
          go Int
_ Maybe (f Int)
Nothing m
acc = m
acc
      MVar m -> m -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar m
child (m -> IO ()) -> m -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> Maybe (f Int) -> m -> m
go Int
x (f Int -> Maybe (f Int)
forall a. a -> Maybe a
Just (f Int -> Maybe (f Int)) -> f Int -> Maybe (f Int)
forall a b. (a -> b) -> a -> b
$ f Int -> Int -> f Int
forall (f :: * -> *). Shape f => Layout f -> Int -> Layout f
shapeFromIndex f Int
l Int
x) m
forall a. Monoid a => a
mempty
    MVar m -> IO (MVar m)
forall (m :: * -> *) a. Monad m => a -> m a
return MVar m
child
  [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ([m] -> m) -> IO [m] -> IO m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MVar m] -> (MVar m -> IO m) -> IO [m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [MVar m]
childs MVar m -> IO m
forall a. MVar a -> IO a
takeMVar
  where
  !n :: Int
n       = f Int -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize f Int
l
  !(Int
q, Int
r)  = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
threads
  !threads :: Int
threads = IO Int -> Int
forall a. IO a -> a
unsafePerformIO IO Int
getNumCapabilities
{-# INLINE foldDelayed #-}

-- | Parallel manifestation of a delayed array into a material one.
manifest :: (Vector v a, Shape f) => Delayed f a -> Array v f a
manifest :: Delayed f a -> Array v f a
manifest (Delayed Layout f
l Layout f -> a
ixF) = Layout f -> v a -> Array v f a
forall (v :: * -> *) (f :: * -> *) a.
Layout f -> v a -> Array v f a
Array Layout f
l v a
v
  where
    !v :: v a
v = IO (v a) -> v a
forall a. IO a -> a
unsafePerformIO (IO (v a) -> v a) -> IO (v a) -> v a
forall a b. (a -> b) -> a -> b
$! do
      Mutable v RealWorld a
mv <- Int -> IO (Mutable v (PrimState IO) a)
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
GM.new Int
n
      [MVar ()]
childs <- [Int] -> (Int -> IO (MVar ())) -> IO [MVar ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Int
0 .. Int
threads Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO (MVar ())) -> IO [MVar ()])
-> (Int -> IO (MVar ())) -> IO [MVar ()]
forall a b. (a -> b) -> a -> b
$ \Int
c -> do
        MVar ()
child <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
        ThreadId
_ <- Int -> IO () -> IO ThreadId
forkOn Int
c (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
          let k :: Int
k | Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
threads Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 = Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r
                | Bool
otherwise        = Int
q
              x :: Int
x = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
q
          IndexedGetting Int (Traversed () IO) (Layout f) (Layout f)
-> Layout f -> (Int -> Layout f -> IO ()) -> IO ()
forall (f :: * -> *) i r s a.
Functor f =>
IndexedGetting i (Traversed r f) s a
-> s -> (i -> a -> f r) -> f ()
iforOf_ (Int -> Int -> IndexedFold Int (Layout f) (Layout f)
forall (f :: * -> *).
Shape f =>
Int -> Int -> IndexedFold Int (Layout f) (Layout f)
linearIndexesBetween Int
x (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k)) Layout f
l ((Int -> Layout f -> IO ()) -> IO ())
-> (Int -> Layout f -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i Layout f
s ->
            Mutable v (PrimState IO) a -> Int -> a -> IO ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
GM.unsafeWrite Mutable v RealWorld a
Mutable v (PrimState IO) a
mv Int
i (Layout f -> a
ixF Layout f
s)
          MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
child ()
        MVar () -> IO (MVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return MVar ()
child
      [MVar ()] -> (MVar () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
F.for_ [MVar ()]
childs MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar
      Mutable v (PrimState IO) a -> IO (v a)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
G.unsafeFreeze Mutable v RealWorld a
Mutable v (PrimState IO) a
mv
    !n :: Int
n       = Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l
    !(Int
q, Int
r)  = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
threads
    !threads :: Int
threads = IO Int -> Int
forall a. IO a -> a
unsafePerformIO IO Int
getNumCapabilities
{-# INLINE manifest #-}

linearIndexesBetween :: Shape f => Int -> Int -> IndexedFold Int (Layout f) (f Int)
linearIndexesBetween :: Int -> Int -> IndexedFold Int (Layout f) (Layout f)
linearIndexesBetween Int
i0 Int
k p (Layout f) (f (Layout f))
g Layout f
l = SPEC -> Int -> Maybe (Layout f) -> f (Layout f)
go SPEC
SPEC Int
i0 (Layout f -> Maybe (Layout f)
forall a. a -> Maybe a
Just (Layout f -> Maybe (Layout f)) -> Layout f -> Maybe (Layout f)
forall a b. (a -> b) -> a -> b
$ Layout f -> Int -> Layout f
forall (f :: * -> *). Shape f => Layout f -> Int -> Layout f
shapeFromIndex Layout f
l Int
i0)
  where
  go :: SPEC -> Int -> Maybe (Layout f) -> f (Layout f)
go !SPEC
_ Int
i (Just Layout f
x) = p (Layout f) (f (Layout f)) -> Int -> Layout f -> f (Layout f)
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p (Layout f) (f (Layout f))
g Int
i Layout f
x f (Layout f) -> f (Layout f) -> f (Layout f)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SPEC -> Int -> Maybe (Layout f) -> f (Layout f)
go SPEC
SPEC (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k) Maybe () -> Maybe (Layout f) -> Maybe (Layout f)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Layout f -> Layout f -> Maybe (Layout f)
forall (f :: * -> *).
Shape f =>
Layout f -> Layout f -> Maybe (Layout f)
shapeStep Layout f
l Layout f
x)
  go !SPEC
_ Int
_ Maybe (Layout f)
_        = f (Layout f)
forall (f :: * -> *) a. (Contravariant f, Applicative f) => f a
noEffect
{-# INLINE linearIndexesBetween #-}

-- | Generate a 'Delayed' array using the given 'Layout' and
--   construction function.
genDelayed :: Layout f -> (f Int -> a) -> Delayed f a
genDelayed :: Layout f -> (Layout f -> a) -> Delayed f a
genDelayed = Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed
{-# INLINE genDelayed #-}

------------------------------------------------------------------------
-- Focused
------------------------------------------------------------------------

-- | A delayed representation of an array with a focus on a single
--   element. This element is the target of 'extract'.
data Focused f a = Focused !(f Int) !(Delayed f a)
  deriving (Typeable, a -> Focused f b -> Focused f a
(a -> b) -> Focused f a -> Focused f b
(forall a b. (a -> b) -> Focused f a -> Focused f b)
-> (forall a b. a -> Focused f b -> Focused f a)
-> Functor (Focused f)
forall a b. a -> Focused f b -> Focused f a
forall a b. (a -> b) -> Focused f a -> Focused f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) a b. a -> Focused f b -> Focused f a
forall (f :: * -> *) a b. (a -> b) -> Focused f a -> Focused f b
<$ :: a -> Focused f b -> Focused f a
$c<$ :: forall (f :: * -> *) a b. a -> Focused f b -> Focused f a
fmap :: (a -> b) -> Focused f a -> Focused f b
$cfmap :: forall (f :: * -> *) a b. (a -> b) -> Focused f a -> Focused f b
Functor)

-- | The 'size' of the 'layout' __must__ remain the same or an error is thrown.
instance Shape f => HasLayout f (Focused f a) where
  layout :: (Layout f -> f (Layout f)) -> Focused f a -> f (Focused f a)
layout Layout f -> f (Layout f)
f (Focused Layout f
x (Delayed Layout f
l Layout f -> a
ixF)) = Layout f -> f (Layout f)
f Layout f
l f (Layout f) -> (Layout f -> Focused f a) -> f (Focused f a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Layout f
l' ->
    Int -> Int -> String -> Focused f a -> Focused f a
forall a. Int -> Int -> String -> a -> a
sizeMissmatch (Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l) (Layout f -> Int
forall (f :: * -> *). Shape f => Layout f -> Int
shapeSize Layout f
l')
      (String
"layout (Focused): trying to replace shape " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Layout f -> String
forall (f :: * -> *). Shape f => f Int -> String
showShape Layout f
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Layout f -> String
forall (f :: * -> *). Shape f => f Int -> String
showShape Layout f
l')
      (Focused f a -> Focused f a) -> Focused f a -> Focused f a
forall a b. (a -> b) -> a -> b
$ Layout f -> Delayed f a -> Focused f a
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused Layout f
x (Layout f -> (Layout f -> a) -> Delayed f a
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
Delayed Layout f
l' Layout f -> a
ixF)
  {-# INLINE layout #-}

instance Shape f => Comonad (Focused f) where
  {-# INLINE extract #-}
  {-# INLINE extend  #-}
  extract :: Focused f a -> a
extract (Focused f Int
x Delayed f a
d) = Delayed f a -> f Int -> a
forall (f :: * -> *) a. Shape f => Delayed f a -> f Int -> a
indexDelayed Delayed f a
d f Int
x
  extend :: (Focused f a -> b) -> Focused f a -> Focused f b
extend Focused f a -> b
f (Focused f Int
x d :: Delayed f a
d@(Delayed f Int
l f Int -> a
_)) =
    f Int -> Delayed f b -> Focused f b
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
x (f Int -> (f Int -> b) -> Delayed f b
forall (f :: * -> *) a. Layout f -> (Layout f -> a) -> Delayed f a
genDelayed f Int
l ((f Int -> b) -> Delayed f b) -> (f Int -> b) -> Delayed f b
forall a b. (a -> b) -> a -> b
$ \f Int
i -> Focused f a -> b
f (f Int -> Delayed f a -> Focused f a
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
i Delayed f a
d))

instance Shape f => Extend (Focused f) where
  {-# INLINE extended #-}
  extended :: (Focused f a -> b) -> Focused f a -> Focused f b
extended = (Focused f a -> b) -> Focused f a -> Focused f b
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend

instance Shape f => ComonadStore (f Int) (Focused f) where
  {-# INLINE pos   #-}
  {-# INLINE peek  #-}
  {-# INLINE peeks #-}
  {-# INLINE seek  #-}
  {-# INLINE seeks #-}
  pos :: Focused f a -> f Int
pos     (Focused f Int
x Delayed f a
_) = f Int
x
  peek :: f Int -> Focused f a -> a
peek  f Int
x (Focused f Int
_ Delayed f a
d) = Delayed f a -> f Int -> a
forall (f :: * -> *) a. Shape f => Delayed f a -> f Int -> a
indexDelayed Delayed f a
d f Int
x
  peeks :: (f Int -> f Int) -> Focused f a -> a
peeks f Int -> f Int
f (Focused f Int
x Delayed f a
d) = Delayed f a -> f Int -> a
forall (f :: * -> *) a. Shape f => Delayed f a -> f Int -> a
indexDelayed Delayed f a
d (f Int -> f Int
f f Int
x)
  seek :: f Int -> Focused f a -> Focused f a
seek  f Int
x (Focused f Int
_ Delayed f a
d) = f Int -> Delayed f a -> Focused f a
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
x Delayed f a
d
  seeks :: (f Int -> f Int) -> Focused f a -> Focused f a
seeks f Int -> f Int
f (Focused f Int
x Delayed f a
d) = f Int -> Delayed f a -> Focused f a
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused (f Int -> f Int
f f Int
x) Delayed f a
d

instance (Shape f, Show1 f, Show a) => Show (Focused f a) where
  showsPrec :: Int -> Focused f a -> String -> String
showsPrec Int
p (Focused f Int
l Delayed f a
d) = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    String -> String -> String
showString String
"Focused " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f Int -> String -> String
forall (f :: * -> *) a.
(Show1 f, Show a) =>
Int -> f a -> String -> String
showsPrec1 Int
11 f Int
l (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Delayed f a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 Delayed f a
d

-- instance (Shape f, Show1 f) => Show1 (Focused f) where
--   showsPrec1 = showsPrec

type instance Index (Focused f a) = f Int
type instance IxValue (Focused f a) = a

instance Shape f => Foldable (Focused f) where
  foldr :: (a -> b -> b) -> b -> Focused f a -> b
foldr a -> b -> b
f b
b (Focused f Int
_ Delayed f a
d) = (a -> b -> b) -> b -> Delayed f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr a -> b -> b
f b
b Delayed f a
d
  {-# INLINE foldr #-}

  foldMap :: (a -> m) -> Focused f a -> m
foldMap a -> m
f (Focused f Int
_ Delayed f a
d) = (a -> m) -> Delayed f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f Delayed f a
d
  {-# INLINE foldMap #-}

#if __GLASGOW_HASKELL__ >= 710
  length :: Focused f a -> Int
length = Focused f a -> Int
forall (f :: * -> *) a. HasLayout f a => a -> Int
size
  {-# INLINE length #-}
#endif

instance Shape f => Traversable (Focused f) where
  traverse :: (a -> f b) -> Focused f a -> f (Focused f b)
traverse a -> f b
f (Focused f Int
u Delayed f a
d) = f Int -> Delayed f b -> Focused f b
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
u (Delayed f b -> Focused f b) -> f (Delayed f b) -> f (Focused f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Delayed f a -> f (Delayed f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Delayed f a
d
  {-# INLINE traverse #-}

-- | Index relative to focus.
instance Shape f => FunctorWithIndex (f Int) (Focused f) where
  imap :: (f Int -> a -> b) -> Focused f a -> Focused f b
imap f Int -> a -> b
f (Focused f Int
u Delayed f a
d) = f Int -> Delayed f b -> Focused f b
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
u ((f Int -> a -> b) -> Delayed f a -> Delayed f b
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap (f Int -> a -> b
f (f Int -> a -> b) -> (f Int -> f Int) -> f Int -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Int -> f Int -> f Int
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ f Int
u)) Delayed f a
d)
  {-# INLINE imap #-}

-- | Index relative to focus.
instance Shape f => FoldableWithIndex (f Int) (Focused f) where
  ifoldr :: (f Int -> a -> b -> b) -> b -> Focused f a -> b
ifoldr f Int -> a -> b -> b
f b
b (Focused f Int
u Delayed f a
d) = (f Int -> a -> b -> b) -> b -> Delayed f a -> b
forall i (f :: * -> *) a b.
FoldableWithIndex i f =>
(i -> a -> b -> b) -> b -> f a -> b
ifoldr (f Int -> a -> b -> b
f (f Int -> a -> b -> b) -> (f Int -> f Int) -> f Int -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Int -> f Int -> f Int
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ f Int
u)) b
b Delayed f a
d
  {-# INLINE ifoldr #-}

  ifolded :: p a (f a) -> Focused f a -> f (Focused f a)
ifolded = ((f Int -> a -> f a -> f a) -> f a -> Focused f a -> f a)
-> p a (f a) -> Focused f a -> f (Focused f a)
forall i (p :: * -> * -> *) (f :: * -> *) a s t b.
(Indexable i p, Contravariant f, Applicative f) =>
((i -> a -> f a -> f a) -> f a -> s -> f a) -> Over p f s t a b
ifoldring (f Int -> a -> f a -> f a) -> f a -> Focused f a -> f a
forall i (f :: * -> *) a b.
FoldableWithIndex i f =>
(i -> a -> b -> b) -> b -> f a -> b
ifoldr
  {-# INLINE ifolded #-}

  ifoldMap :: (f Int -> a -> m) -> Focused f a -> m
ifoldMap f Int -> a -> m
f (Focused f Int
u Delayed f a
d) = (f Int -> a -> m) -> Delayed f a -> m
forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap (f Int -> a -> m
f (f Int -> a -> m) -> (f Int -> f Int) -> f Int -> a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Int -> f Int -> f Int
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
(^-^) f Int
u) Delayed f a
d
  {-# INLINE ifoldMap #-}

-- | Index relative to focus.
instance Shape f => TraversableWithIndex (f Int) (Focused f) where
  itraverse :: (f Int -> a -> f b) -> Focused f a -> f (Focused f b)
itraverse f Int -> a -> f b
f (Focused f Int
u Delayed f a
d) = f Int -> Delayed f b -> Focused f b
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
u (Delayed f b -> Focused f b) -> f (Delayed f b) -> f (Focused f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f Int -> a -> f b) -> Delayed f a -> f (Delayed f b)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (f Int -> a -> f b
f (f Int -> a -> f b) -> (f Int -> f Int) -> f Int -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Int -> f Int -> f Int
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ f Int
u)) Delayed f a
d
  {-# INLINE itraverse #-}

-- | Index relative to focus.
instance Shape f => Ixed (Focused f a) where
  ix :: Index (Focused f a)
-> Traversal' (Focused f a) (IxValue (Focused f a))
ix Index (Focused f a)
i IxValue (Focused f a) -> f (IxValue (Focused f a))
f (Focused f Int
u Delayed f a
d) = f Int -> Delayed f a -> Focused f a
forall (f :: * -> *) a. f Int -> Delayed f a -> Focused f a
Focused f Int
u (Delayed f a -> Focused f a) -> f (Delayed f a) -> f (Focused f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index (Delayed f a)
-> (IxValue (Delayed f a) -> f (IxValue (Delayed f a)))
-> Delayed f a
-> f (Delayed f a)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (f Int
Index (Focused f a)
i f Int -> f Int -> f Int
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ f Int
u) IxValue (Focused f a) -> f (IxValue (Focused f a))
IxValue (Delayed f a) -> f (IxValue (Delayed f a))
f Delayed f a
d
  {-# INLINE ix #-}