feat: Adds missing instances for NonEmpty and adds some Linear counterpart of Data.List.NonEmpty

linear-base.cabal

@@ -79,6 +79,7 @@ library
         Data.HashMap.Mutable.Linear
         Data.HashMap.Mutable.Linear.Internal
         Data.List.Linear
+        Data.List.NonEmpty.Linear
         Data.Maybe.Linear
         Data.Monoid.Linear
         Data.Monoid.Linear.Internal.Monoid

src/Data/Functor/Linear/Internal/Functor.hs

@@ -32,6 +32,7 @@ import Data.Functor.Identity
 import Data.Functor.Product
 import Data.Functor.Sum
 import Data.Kind (FUN)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Unrestricted.Linear.Internal.Consumable
 import Data.Unrestricted.Linear.Internal.Ur
 import GHC.Types (Multiplicity (..))
@@ -76,6 +77,11 @@ instance Functor [] where
       go [] = []
       go (a : as) = f a : go as
 
+deriving via
+  Generically1 NonEmpty
+  instance
+    Functor NonEmpty
+
 deriving via
   Generically1 (Const x)
   instance

src/Data/Functor/Linear/Internal/Traversable.hs

@@ -34,6 +34,7 @@ import qualified Control.Functor.Linear.Internal.State as Control
 import Data.Functor.Const
 import qualified Data.Functor.Linear.Internal.Applicative as Data
 import qualified Data.Functor.Linear.Internal.Functor as Data
+import Data.List.NonEmpty (NonEmpty (..))
 import GHC.Types (Multiplicity (..))
 import Generics.Linear
 import Prelude.Linear.Internal
@@ -131,6 +132,12 @@ instance Traversable [] where
       go [] = Control.pure []
       go (x : xs) = Control.liftA2 (:) (f x) (go xs)
 
+instance Traversable NonEmpty where
+  -- We define traverse explicitly both to allow specialization
+  -- to the appropriate Applicative and to allow specialization to
+  -- the passed function. The generic definition allows neither, sadly.
+  traverse f (x :| xs) = (:|) Control.<$> f x Control.<*> traverse f xs
+
 instance Traversable ((,) a) where
   traverse = genericTraverse
 

src/Data/List/NonEmpty/Linear.hs

@@ -0,0 +1,211 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- |
+-- Linear versions of 'NonEmpty' functions.
+--
+-- This module only contains minimal amount of documentation; consult the
+-- original "Data.List.NonEmpty" module for more detailed information.
+module Data.List.NonEmpty.Linear
+  ( -- * Non-empty stream transformations
+    NonEmpty (..),
+    map,
+    intersperse,
+    scanl,
+    scanr,
+    scanl1,
+    scanr1,
+    transpose,
+    NonLinear.sortBy,
+    NonLinear.sortWith,
+
+    -- * Basic functions
+    length,
+    NonLinear.head,
+    NonLinear.tail,
+    NonLinear.last,
+    NonLinear.init,
+    singleton,
+    (<|),
+    cons,
+    uncons,
+    unfoldr,
+    NonLinear.sort,
+    reverse,
+    append,
+    appendList,
+    prependList,
+
+    -- * Extracting sublists
+    take,
+    drop,
+    splitAt,
+    takeWhile,
+    dropWhile,
+    span,
+    break,
+    filter,
+    partition,
+
+    -- * Zipping and unzipping streams
+    zip,
+    zipWith,
+    zip',
+    zipWith',
+    unzip,
+    unzip3,
+
+    -- * Converting to and from a list
+    fromList,
+    toList,
+    nonEmpty,
+    xor,
+  )
+where
+
+import qualified Data.List.Linear as List
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NonLinear
+import Data.Vector.Internal.Check (HasCallStack)
+import Prelude.Linear hiding (drop, dropWhile, filter, intersperse, length, map, partition, reverse, scanl, scanl1, scanr, scanr1, span, splitAt, take, takeWhile, transpose, uncons, unfoldr, unzip, unzip3, zip, zip', zipWith, zipWith')
+import qualified Unsafe.Linear as Unsafe
+import qualified Prelude as Prelude
+
+map :: (a %1 -> b) -> NonEmpty a %1 -> NonEmpty b
+map f (x :| xs) = f x :| List.map f xs
+
+intersperse :: a -> NonEmpty a %1 -> NonEmpty a
+intersperse a = Unsafe.toLinear (NonLinear.intersperse a)
+
+reverse :: NonEmpty a %1 -> NonEmpty a
+reverse = Unsafe.toLinear NonLinear.reverse
+
+scanl :: (Dupable b) => (b %1 -> a %1 -> b) -> b %1 -> NonEmpty a %1 -> NonEmpty b
+scanl f z = fromList . List.scanl f z . toList
+
+scanr :: (Dupable b) => (a %1 -> b %1 -> b) -> b %1 -> NonEmpty a %1 -> NonEmpty b
+scanr f z = fromList . List.scanr f z . toList
+
+scanl1 :: (Dupable a) => (a %1 -> a %1 -> a) -> NonEmpty a %1 -> NonEmpty a
+scanl1 f (x :| xs) = fromList $ List.scanl f x xs
+
+scanr1 :: (Dupable a) => (a %1 -> a %1 -> a) -> NonEmpty a %1 -> NonEmpty a
+scanr1 f (x :| xs) = fromList $ List.scanr1 f (x : xs)
+
+transpose :: NonEmpty (NonEmpty a) %1 -> NonEmpty (NonEmpty a)
+transpose = Unsafe.toLinear NonLinear.transpose
+
+singleton :: a %1 -> NonEmpty a
+singleton = (:| [])
+
+infixr 5 <|
+
+(<|) :: a %1 -> NonEmpty a %1 -> NonEmpty a
+a <| bs = a :| toList bs
+
+cons :: a %1 -> NonEmpty a %1 -> NonEmpty a
+cons = (<|)
+
+uncons :: NonEmpty a %1 -> (a, Maybe (NonEmpty a))
+uncons (x :| xs) = (x, nonEmpty xs)
+
+unfoldr :: (a %1 -> (b, Maybe a)) -> a %1 -> NonEmpty b
+unfoldr f a = case f a of
+  (b, mc) -> b :| maybe [] go mc
+  where
+    go c = case f c of
+      (d, me) -> d : maybe [] go me
+
+append :: NonEmpty a %1 -> NonEmpty a %1 -> NonEmpty a
+append = (<>)
+
+appendList :: NonEmpty a %1 -> [a] %1 -> NonEmpty a
+appendList (x :| xs) ys = x :| (xs <> ys)
+
+prependList :: [a] %1 -> NonEmpty a %1 -> NonEmpty a
+prependList ls ne = case ls of
+  [] -> ne
+  (y : ys) -> y :| (ys <> toList ne)
+
+-- | __NOTE__: This does not short-circuit and always traverses the
+-- entire list to consume the rest of the elements.
+take :: (Consumable a) => Int -> NonEmpty a %1 -> [a]
+take n = List.take n . toList
+
+drop :: (Consumable a) => Int -> NonEmpty a %1 -> [a]
+drop n = List.drop n . toList
+
+splitAt :: (Consumable a) => Int -> NonEmpty a %1 -> ([a], [a])
+splitAt n = List.splitAt n . toList
+
+-- | __NOTE__: This does not short-circuit and always traverses the
+-- entire list to consume the rest of the elements.
+takeWhile :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> [a]
+takeWhile p = List.takeWhile p . toList
+
+dropWhile :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> [a]
+dropWhile p = List.dropWhile p . toList
+
+span :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> ([a], [a])
+span p = List.span p . toList
+
+break :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> ([a], [a])
+break p = span (not . p)
+
+filter :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> [a]
+filter p = List.filter p . toList
+
+partition :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> ([a], [a])
+partition p = List.partition p . toList
+
+-- | Return the length of the given list alongside with the list itself.
+length :: NonEmpty a %1 -> (Ur Int, NonEmpty a)
+length = Unsafe.toLinear $ \xs ->
+  (Ur (NonLinear.length xs), xs)
+
+fromList :: (HasCallStack) => [a] %1 -> (NonEmpty a)
+fromList (x : xs) = x :| xs
+fromList [] = Prelude.error "NonEmpty.Linear.fromList: empty list"
+
+toList :: NonEmpty a %1 -> [a]
+toList (x :| xs) = x : xs
+
+nonEmpty :: [a] %1 -> Maybe (NonEmpty a)
+nonEmpty (x : xs) = Just (x :| xs)
+nonEmpty [] = Nothing
+
+xor :: NonEmpty Bool %1 -> Bool
+xor = Unsafe.toLinear NonLinear.xor
+
+zip :: (Consumable a, Consumable b) => NonEmpty a %1 -> NonEmpty b %1 -> NonEmpty (a, b)
+zip = zipWith (,)
+
+zipWith :: (Consumable a, Consumable b) => (a %1 -> b %1 -> c) -> NonEmpty a %1 -> NonEmpty b %1 -> NonEmpty c
+zipWith f (a :| as) (b :| bs) = f a b :| List.zipWith f as bs
+
+-- | Same as 'zipWith', but returns the leftovers instead of consuming them.
+-- Because the leftovers are returned at toplevel, @zipWith'@ is pretty strict:
+-- forcing the second cons cell of the returned list forces all the recursive
+-- calls.
+zipWith' :: (a %1 -> b %1 -> c) -> NonEmpty a %1 -> NonEmpty b %1 -> (NonEmpty c, Maybe (Either (NonEmpty a) (NonEmpty b)))
+zipWith' f (a :| as) (b :| bs) =
+  case List.zipWith' f as bs of
+    (cs, may) -> (f a b :| cs, may)
+
+-- | Same as 'zip', but returns the leftovers instead of consuming them.
+zip' :: NonEmpty a %1 -> NonEmpty b %1 -> (NonEmpty (a, b), Maybe (Either (NonEmpty a) (NonEmpty b)))
+zip' = zipWith' (,)
+
+unzip :: NonEmpty (a, b) %1 -> (NonEmpty a, NonEmpty b)
+unzip ((a, b) :| asbs) =
+  List.unzip asbs & \(as, bs) ->
+    (a :| as, b :| bs)
+
+unzip3 :: NonEmpty (a, b, c) %1 -> (NonEmpty a, NonEmpty b, NonEmpty c)
+unzip3 ((a, b, c) :| abs) =
+  List.unzip3 abs & \(as, bs, cs) ->
+    (a :| as, b :| bs, c :| cs)

src/Data/Monoid/Linear/Internal/Semigroup.hs

@@ -11,6 +11,7 @@
 module Data.Monoid.Linear.Internal.Semigroup
   ( -- * Semigroup
     Semigroup (..),
+    sconcat,
 
     -- * Endo
     Endo (..),
@@ -34,6 +35,7 @@ import qualified Data.Functor.Compose as Functor
 import Data.Functor.Const (Const (..))
 import Data.Functor.Identity (Identity (..))
 import qualified Data.Functor.Product as Functor
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Monoid as Monoid
 import Data.Ord (Down (..))
 import Data.Proxy (Proxy (..))
@@ -65,6 +67,13 @@ class Semigroup a where
   (<>) :: a %1 -> a %1 -> a
   infixr 6 <> -- same fixity as base.<>
 
+sconcat :: (Semigroup a) => NonEmpty a %1 -> a
+sconcat (x :| xs :: NonEmpty a) = go x xs
+  where
+    go :: a %1 -> [a] %1 -> a
+    go acc [] = acc
+    go acc (x' : xs') = go (acc <> x') xs'
+
 -- | An @'Endo' a@ is just a linear function of type @a %1-> a@.
 -- This has a classic monoid definition with 'id' and '(.)'.
 newtype Endo a = Endo (a %1 -> a)

src/Data/Ord/Linear/Internal/Eq.hs

@@ -13,6 +13,7 @@ where
 
 import Data.Bool.Linear
 import Data.Int (Int16, Int32, Int64, Int8)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Unrestricted.Linear
 import Data.Word (Word16, Word32, Word64, Word8)
 import Prelude.Linear.Internal
@@ -47,6 +48,9 @@ instance (Consumable a, Eq a) => Eq [a] where
   (x : xs) == (y : ys) = x == y && xs == ys
   xs == ys = (xs, ys) `lseq` False
 
+instance (Consumable a, Eq a) => Eq (NonEmpty a) where
+  (x :| xs) == (y :| ys) = x == y && xs == ys
+
 instance (Consumable a, Eq a) => Eq (Prelude.Maybe a) where
   Prelude.Nothing == Prelude.Nothing = True
   Prelude.Just x == Prelude.Just y = x == y

src/Data/Ord/Linear/Internal/Ord.hs

@@ -15,6 +15,7 @@ where
 
 import Data.Bool.Linear (Bool (..), not)
 import Data.Int (Int16, Int32, Int64, Int8)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Monoid.Linear
 import Data.Ord (Ordering (..))
 import Data.Ord.Linear.Internal.Eq
@@ -119,6 +120,10 @@ instance (Consumable a, Ord a) => Ord [a] where
       EQ -> compare xs ys
       res -> (xs, ys) `lseq` res
 
+instance (Consumable a, Ord a) => Ord (NonEmpty a) where
+  compare (x :| xs) (y :| ys) =
+    compare x y <> compare xs ys
+
 instance (Ord a, Ord b) => Ord (a, b) where
   (a, b) `compare` (a', b') =
     compare a a' <> compare b b'