ZipArrays - Applicative and Monadic zipping for PureScript Arrays

ZipArray.purs

module Data.Array.ZipArray where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Array as A
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.NonEmpty.Internal (NonEmptyArray(..))
import Data.Array.NonEmpty.Internal (NonEmptyArray) as Internal
import Data.Bifunctor (bimap)
import Data.Foldable (class Foldable)
import Data.Foldable (class Foldable)
import Data.Maybe (Maybe(..), fromJust)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype, unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Semigroup.Foldable (class Foldable1)
import Data.Semigroup.Foldable as F
import Data.Traversable (class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1, unfoldr1)
import Partial.Unsafe (unsafePartial)
import Prim.TypeError (class Warn, Text)
import Safe.Coerce (coerce)
import Unsafe.Coerce (unsafeCoerce)

newtype ZipArray a = ZipArray (NonEmptyArray a)

instance showZipArray :: Show a => Show (ZipArray a) where
  show (ZipArray xs) = "(ZipArray " <> show xs <> " ...)"

derive instance newtypeZipArray :: Newtype (ZipArray a) _

derive newtype instance eqZipArray :: Eq a => Eq (ZipArray a)

derive newtype instance ordZipArray :: Ord a => Ord (ZipArray a)

derive newtype instance semigroupZipArray :: Semigroup (ZipArray a)

-- derive newtype instance monoidZipArray :: Monoid (ZipArray a)

derive newtype instance foldableZipArray :: Foldable ZipArray

derive newtype instance traversableZipArray :: Traversable ZipArray

derive newtype instance functorZipArray :: Functor ZipArray

instance Apply ZipArray where
  apply (ZipArray fs) (ZipArray xs) =
    ZipArray (NEA.zipWith ($) (pad len fs) (pad len xs))
    where
    len = max (NEA.length fs) (NEA.length xs)

instance Applicative ZipArray where
  pure a = ZipArray (NEA.singleton a)

instance Alt ZipArray where
  alt (ZipArray xs) (ZipArray ys) = ZipArray $ case NEA.fromArray (NEA.drop (NEA.length xs) ys) of
    Nothing -> xs
    Just ys' -> xs <> ys'

cons :: forall a. a -> Array a -> ZipArray a
cons x xs = ZipArray (NEA.cons' x xs)

snoc :: forall a. Array a -> a -> ZipArray a
snoc xs x = ZipArray (NEA.snoc' xs x)

fromNonEmpty :: forall a. NEA.NonEmptyArray a -> ZipArray a
fromNonEmpty = ZipArray

fromArray :: forall a. Array a -> Maybe (ZipArray a)
fromArray = map ZipArray <<< NEA.fromArray

index :: forall a. Int -> ZipArray a -> a
index idx (ZipArray xs) =
  fromMaybe (NEA.last xs) (xs NEA.!! idx)

dropZipArray :: forall a. Int -> ZipArray a -> Array a
dropZipArray idx (ZipArray xs) = NEA.drop idx xs

joinZipArray :: forall a. ZipArray (ZipArray a) -> ZipArray a
joinZipArray (ZipArray ys) =
  ZipArray $ NEA.cons' (NEA.head firstRow) (go 1 (NEA.tail firstRow) (NEA.tail ys))
  where
    firstRow = unwrap $ NEA.head ys
    go :: Int -> Array a -> Array (ZipArray a) -> Array a
    go idx rem xs = case A.uncons xs of
      Nothing -> rem
      Just x -> A.cons
        (index idx x.head)
        (go (idx+1) (dropZipArray idx x.head) x.tail)

instance Bind ZipArray where
  bind m f = joinZipArray (map f m)

instance Monad ZipArray