Mixed.hs

{- |
Functions that cope both with plain and non-empty structures.

If there are two versions of a function,
where one works on fixed-length lists,
then place the fixed-length list variant in NonEmpty
and the other one here.
-}
module Data.NonEmpty.Mixed where

import qualified Data.NonEmpty.Foldable as FoldU
import qualified Data.NonEmpty.Class as C
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Empty as Empty
import qualified Data.List.HT as ListHT
import Data.Traversable (Traversable, mapAccumL, sequenceA, )
import Data.Foldable (Foldable, foldr, )
import Data.Tuple.HT (mapFst, mapSnd, )
import Data.Eq.HT (equating, )

import Prelude hiding (splitAt, take, foldr, scanl, scanr, )


{- $setup
>>> import qualified Data.NonEmpty as NonEmpty
>>> import qualified Data.List.Match as Match
>>> import Data.NonEmpty.Mixed (chopNothing)
>>> import Data.NonEmpty.Class (append)
>>> import Data.Eq.HT (equating)
-}


groupBy ::
   (Foldable f) =>
   (a -> a -> Bool) -> f a -> [NonEmpty.T [] a]
groupBy p =
   foldr
      (\x0 yt ->
         let (xr,yr) =
               case yt of
                  NonEmpty.Cons x1 xs : ys ->
                     if p x0 x1
                       then (x1:xs,ys)
                       else ([],yt)
                  [] -> ([],yt)
         in  NonEmpty.Cons x0 xr : yr)
      []

groupPairs :: (Foldable f, Eq a) => f (a,b) -> [(a, NonEmpty.T [] b)]
groupPairs =
   map (\xs -> (fst $ NonEmpty.head xs, fmap snd xs)) .
   groupBy (equating fst)

groupKey :: (Foldable f, Eq a) => (b -> a) -> f b -> [(a, NonEmpty.T [] b)]
groupKey f = groupPairs . FoldU.Mapped (\b -> (f b, b))

groupEithers ::
   (Foldable f) =>
   f (Either a b) -> [Either (NonEmpty.T [] a) (NonEmpty.T [] b)]
groupEithers =
   foldr
      (\x xs ->
         case x of
            Left a ->
               uncurry (:) $ mapFst (Left . NonEmpty.Cons a) $
               case xs of
                  Left as : ys -> (NonEmpty.flatten as, ys)
                  ys -> ([], ys)
            Right b ->
               uncurry (:) $ mapFst (Right . NonEmpty.Cons b) $
               case xs of
                  Right bs : ys -> (NonEmpty.flatten bs, ys)
                  ys -> ([], ys))
      []

{- |
>>> chopNothing ([] :: [Maybe String])
[]!:[]

>>> chopNothing [Nothing :: Maybe String]
[]!:[]:[]

>>> chopNothing [Just "a", Just "b", Nothing, Just "c", Nothing, Just "d", Just "e"]
["a","b"]!:["c"]:["d","e"]:[]

prop> \xs ys -> chopNothing (xs ++ Nothing : ys) == append (chopNothing xs) (chopNothing (ys :: [Maybe Int]))

prop> \ns xs -> equating (Match.take (ns::[()]) . NonEmpty.flatten) (NonEmpty.cycle (chopNothing xs)) (chopNothing (cycle (xs ++ [Nothing :: Maybe Int])))
-}
chopNothing :: (Foldable f) => f (Maybe a) -> NonEmpty.T [] [a]
chopNothing =
   NonEmpty.force .
   foldr
      (\mx ~(NonEmpty.Cons ys yss) ->
         case mx of
            Nothing -> NonEmpty.Cons [] (ys:yss)
            Just x -> NonEmpty.Cons (x:ys) yss)
      (NonEmpty.singleton [])


segmentAfter ::
   (Foldable f) =>
   (a -> Bool) -> f a -> ([NonEmpty.T [] a], [a])
segmentAfter p =
   foldr
      (\x ~(ys,zs) ->
         if p x
           then (NonEmpty.singleton x : ys, zs)
           else
              case ys of
                 [] -> (ys, x:zs)
                 w:ws -> (C.cons x w : ws, zs))
      ([],[])

segmentBefore ::
   (Foldable f) =>
   (a -> Bool) -> f a -> ([a], [NonEmpty.T [] a])
segmentBefore p =
   foldr
      (\ x ys ->
         if p x
           then ([], NonEmpty.Cons x (fst ys) : snd ys)
           else (x : fst ys, snd ys))
      ([],[])

filterToInfixes ::
   (Foldable f) =>
   (a -> Bool) -> f a -> [NonEmpty.T [] a]
filterToInfixes p =
   let cons = uncurry $ maybe id (:) . NonEmpty.fetch
   in  cons .
       foldr
          (\x yzs ->
             if p x
               then mapFst (x:) yzs
               else ([], cons yzs))
          ([], [])

mapAdjacent ::
   (C.Cons f, C.Zip f) => (a -> a -> b) -> NonEmpty.T f a -> f b
mapAdjacent f xs =
   C.zipWith f (NonEmpty.flatten xs) (NonEmpty.tail xs)


take ::
   (C.View g, C.Repeat f, Traversable f) =>
   g a -> Maybe (f a)
take = fst . splitAt

splitAt ::
   (C.View g, C.Repeat f, Traversable f) =>
   g a -> (Maybe (f a), g a)
splitAt xs0 =
   (\(xs1, mys) -> (mys, maybe xs0 (const xs1) mys)) $
   mapSnd sequenceA $
   mapAccumL
      (\xt () ->
         case C.viewL xt of
            Nothing -> (xt, Nothing)
            Just (x,xs) -> (xs, Just x))
      xs0 (C.repeat ())

sliceVertical ::
   (C.View g, C.Repeat f, Traversable f) =>
   g a -> ([f a], g a)
sliceVertical x0 =
   case splitAt x0 of
      (my,x1) ->
         case my of
            Nothing -> ([], x1)
            Just y -> mapFst (y:) $ sliceVertical x1



{- |
This implementation is more efficient for Sequence than 'NonEmpty.viewR'.
-}
viewR :: (C.ViewR f, C.Empty f, C.Cons f) => NonEmpty.T f a -> (f a, a)
viewR (NonEmpty.Cons x xs) =
   case C.viewR xs of
      Nothing -> (C.empty, x)
      Just (ys, y) -> (C.cons x ys, y)

init :: (C.ViewR f, C.Empty f, C.Cons f) => NonEmpty.T f a -> f a
init = fst . viewR

last :: (C.ViewR f) => NonEmpty.T f a -> a
last (NonEmpty.Cons x xs) =
   case C.viewR xs of
      Nothing -> x
      Just (_, y) -> y


tails ::
   (C.ViewL f, C.Empty f) =>
   f a -> NonEmpty.T [] (f a)
tails xt =
   NonEmpty.force $
   case C.viewL xt of
      Nothing -> NonEmpty.Cons C.empty []
      Just (_, xs) -> C.cons xt $ tails xs

inits ::
   (C.ViewL f, C.Cons f, C.Empty f) =>
   f a -> NonEmpty.T [] (f a)
inits xt =
   NonEmpty.Cons C.empty $
   case C.viewL xt of
      Nothing -> []
      Just (x,xs) -> map (C.cons x) $ NonEmpty.flatten $ inits xs


appendLeft :: (C.Cons f) => [a] -> f a -> f a
appendLeft = flip $ foldr C.cons


iterate :: (C.Repeat f, Traversable f) => (a -> a) -> a -> f a
iterate f x0 =
   snd $ mapAccumL (\xi fi -> (fi xi, xi)) x0 $ C.repeat f


class Choose f where
   {- |
   Select tuples of list elements:
   @choose "abc" == ['a'!:'b'!:empty,'a'!:'c'!:empty,'b'!:'c'!:empty]@
   -}
   choose :: [a] -> [f a]

instance Choose Empty.T where
   choose _ = [Empty.Cons]

instance (Choose f) => Choose (NonEmpty.T f) where
   choose xs = do
      (y:ys) <- ListHT.tails xs
      map (NonEmpty.cons y) $ choose ys

instance Choose [] where
   choose [] = [[]]
   choose (x:xs) =
      let ys = choose xs
      in  map (x:) ys ++ ys