{- ORMOLU_DISABLE -}
-- Options passed to GHC
{-# OPTIONS_GHC -O2 #-}
-- Options passed to Haddock
{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------

{-# LANGUAGE CPP #-}

-- CPP: GHC >= 7.8 for Safe Haskell
#if __GLASGOW_HASKELL__ >= 708
{-

This module imports the unsafe module 'GHC.Exts' for 'IsList' but does not use
any unsafe features. Therefore, we mark the module as trustworthy.

-}
{-# LANGUAGE Trustworthy #-}
#endif

-- For the IsList and IsString instances
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------

{-|

Module: Data.DList.DNonEmpty.Internal
Copyright: © 2017-2020 Oleg Grenrus, 2020 Sean Leather
License: BSD-3-Clause

Maintainer: sean.leather@gmail.com
Stability: stable

This module includes everything related to 'DNonEmpty' and is not exposed to
users of the @dlist@ package.

-}
{- ORMOLU_ENABLE -}

module Data.DList.DNonEmpty.Internal where

-----------------------------------------------------------------------------

import qualified Control.Applicative as Applicative
import Control.DeepSeq (NFData (..))
import qualified Control.Monad as Monad
import Data.DList (DList)
import qualified Data.DList as DList
import qualified Data.Foldable as Foldable
import Data.Function (on)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup as Semigroup
import Data.String (IsString (..))
import qualified GHC.Exts as Exts
import qualified Text.Read as Read
import Prelude hiding (head, map, tail)

-----------------------------------------------------------------------------

{- ORMOLU_DISABLE -}
{-|

A non-empty difference list is a pair of a 'head' element and a (possibly empty)
difference list.

Just as 'DList' is a representation of a list, so is @DNonEmpty@ a
representation of a 'NonEmpty'. @DNonEmpty@ supports \(\mathcal{O}\)(@1@)
'append' and 'snoc' operations, making it useful for replacing frequent
applications of 'Semigroup.<>' on 'NonEmpty' (which is implemented with '++'),
especially if those uses are left-nested (e.g.&#x00A0;@(a __'Semigroup.<>'__ b)
'Semigroup.<>' c@ ).

Unlike 'DList', @DNonEmpty@ is not an abstract type: its constructor is
exported. An alternative definition of @DNonEmpty@ is:

@
newtype DNonEmpty a = DNonEmpty ([a] -> 'NonEmpty' a)
@

This type would need to be abstract to avoid producing @DNonEmpty@ values that
are not isomorphic to 'NonEmpty' values. However, this type would also require
some functions (such as 'map') to be implemented with 'fromNonEmpty' (and thus
'++'), which could introduce efficiencies.

-}
{- ORMOLU_ENABLE -}

infixr 5 :|

data DNonEmpty a = a :| DList a

{- ORMOLU_DISABLE -}
{-|

__@fromNonEmpty xs@__ is a 'DNonEmpty' representing the 'NonEmpty' __@xs@__.

@fromNonEmpty@ obeys the laws:

@
'toNonEmpty' . __fromNonEmpty__ = 'id'
__fromNonEmpty__ . 'toNonEmpty' = 'id'
@

As with 'DList.fromList', this function is implemented with '++'. Repeated uses
of @fromNonEmpty@ are just as inefficient as repeated uses of '++'. If you find
yourself doing some form of the following (possibly indirectly), you may not be
taking advantage of the 'DNonEmpty' representation and library:

@
__fromNonEmpty__ . f . 'toNonEmpty'
@

More likely, you will convert from a 'NonEmpty', perform some operation on the
'DNonEmpty', and convert back to a 'NonEmpty':

@
'toNonEmpty' . g . __fromNonEmpty__
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE fromNonEmpty #-}
fromNonEmpty :: NonEmpty a -> DNonEmpty a
fromNonEmpty ~(x NonEmpty.:| xs) = x :| DList.fromList xs

{- ORMOLU_DISABLE -}
{-|

__@toNonEmpty xs@__ is the 'NonEmpty' represented by __@xs@__.

@toNonEmpty@ obeys the laws:

@
__toNonEmpty__ . 'fromNonEmpty' = 'id'
'fromNonEmpty' . __toNonEmpty__ = 'id'
@

As with 'DList.toList', evaluating @toNonEmpty xs@ may “collapse” the chain of
function composition underlying many 'DList' functions ('DList.append' in
particular) used to construct the 'tail' of @xs@. This may affect any efficiency
you achieved due to laziness in the construction.

-}
{- ORMOLU_ENABLE -}

{-# INLINE toNonEmpty #-}
toNonEmpty :: DNonEmpty a -> NonEmpty a
toNonEmpty ~(x :| xs) = x NonEmpty.:| DList.toList xs

{- ORMOLU_DISABLE -}
{-|

__@toDList xs@__ is the non-empty 'DList' represented by __@xs@__.

@toDList@ obeys the law:

@
__toDList__ (x ':|' xs) = 'DList.cons' x xs
@

Note that this function is used only in this module.

-}
{- ORMOLU_ENABLE -}

toDList :: DNonEmpty a -> DList a
toDList ~(x :| xs) = DList.cons x xs

{- ORMOLU_DISABLE -}
{-|

__@toList xs@__ is the non-empty list represented by __@xs@__.

@toList@ obeys the law:

@
__toList__ xs = 'NonEmpty.toList' ('toNonEmpty' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE toList #-}
toList :: DNonEmpty a -> [a]
toList = DList.toList . toDList

{- ORMOLU_DISABLE -}
{-|

__@fromList xs@__ is a 'DNonEmpty' representing the list __@xs@__. If @xs@ is
empty, an 'error' is raised.

@fromList@ obeys the law:

@
__fromList__ xs = 'fromNonEmpty' ('NonEmpty.fromList' xs)
@

-}
{- ORMOLU_ENABLE -}

fromList :: [a] -> DNonEmpty a
fromList (x : xs) = x :| DList.fromList xs
fromList [] = error "Data.DList.DNonEmpty.fromList: empty list"

{- ORMOLU_DISABLE -}
{-|

__@singleton x@__ is a 'DNonEmpty' with the single element __@x@__.

@singleton@ obeys the law:

@
'toNonEmpty' (__singleton__ x) = x 'NonEmpty.:|' []
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE singleton #-}
singleton :: a -> DNonEmpty a
singleton x = x :| DList.empty

{- ORMOLU_DISABLE -}
{-|

__@cons x xs@__ is a 'DNonEmpty' with the 'head' __@x@__ and the 'tail' __@xs@__.

\(\mathcal{O}\)(@1@).

@cons@ obeys the law:

@
'toNonEmpty' (__cons__ x xs) = 'NonEmpty.cons' x ('toNonEmpty' xs)
@

-}
{- ORMOLU_ENABLE -}

infixr 9 `cons`

{-# INLINE cons #-}
cons :: a -> DNonEmpty a -> DNonEmpty a
cons x ~(y :| ys) = x :| DList.cons y ys

infixl 9 `snoc`

{- ORMOLU_DISABLE -}
{-|

__@snoc xs x@__ is a 'DNonEmpty' with the initial 'DNonEmpty' __@xs@__ and the
last element __@x@__.

\(\mathcal{O}\)(@1@).

@snoc@ obeys the law:

@
'toNonEmpty' (__snoc__ xs x) = 'toNonEmpty' xs 'Semigroup.<>' (x 'NonEmpty.:|' [])
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE snoc #-}
snoc :: DNonEmpty a -> a -> DNonEmpty a
snoc ~(x :| xs) y = x :| DList.snoc xs y

{- ORMOLU_DISABLE -}
{-|

__@append xs ys@__ is a 'DNonEmpty' obtained from the concatenation of the
elements of __@xs@__ and __@ys@__.

\(\mathcal{O}\)(@1@).

@append@ obeys the law:

@
'toNonEmpty' (__append__ xs ys) = 'toNonEmpty' xs 'Semigroup.<>' 'toNonEmpty' ys
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE append #-}
append :: DNonEmpty a -> DNonEmpty a -> DNonEmpty a
append (x :| xs) ~(y :| ys) = x :| DList.append xs (DList.cons y ys)

{- ORMOLU_DISABLE -}
{-|

__@head xs@__ is the first element of __@xs@__.

\(\mathcal{O}\)(@1@).

@head@ obeys the law:

@
__head__ xs = 'NonEmpty.head' ('toNonEmpty' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE head #-}
head :: DNonEmpty a -> a
head ~(x :| _) = x

{- ORMOLU_DISABLE -}
{-|

__@tail xs@__ is a 'DList' of the elements in __@xs@__ excluding the first
element.

\(\mathcal{O}\)(@1@).

@tail@ obeys the law:

@
'DList.toList' (__tail__ xs) = 'NonEmpty.tail' ('toNonEmpty' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE tail #-}
tail :: DNonEmpty a -> DList a
tail ~(_ :| xs) = xs

{- ORMOLU_DISABLE -}
{-|

__@unfoldr f z@__ is the 'DNonEmpty' constructed from the recursive application
of __@f@__. The recursion starts with the seed value __@z@__ and ends when, for
some @z' : b@, @f z' == 'Nothing'@.

\(\mathcal{O}\)(@'NonEmpty.length' ('NonEmpty.unfoldr' f z)@).

@unfoldr@ obeys the law:

@
'toNonEmpty' (__unfoldr__ f z) = 'NonEmpty.unfoldr' f z
@

-}
{- ORMOLU_ENABLE -}

unfoldr :: (b -> (a, Maybe b)) -> b -> DNonEmpty a
unfoldr f z =
  case f z of
    (x, Nothing) -> singleton x
    (x, Just z') -> cons x $ unfoldr f z'

{- ORMOLU_DISABLE -}
{-|

__@map f xs@__ is the 'DNonEmpty' obtained by applying __@f@__ to each element
of __@xs@__.

\(\mathcal{O}\)(@'NonEmpty.length' ('toNonEmpty' xs)@).

@map@ obeys the law:

@
'toNonEmpty' (__map__ f xs) = 'NonEmpty.map' f ('toNonEmpty' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE map #-}
map :: (a -> b) -> DNonEmpty a -> DNonEmpty b
map f ~(x :| xs) = f x :| DList.map f xs

instance Eq a => Eq (DNonEmpty a) where
  (==) = (==) `on` toNonEmpty

instance Ord a => Ord (DNonEmpty a) where
  compare = compare `on` toNonEmpty

instance Read a => Read (DNonEmpty a) where
  readPrec = Read.parens $
    Read.prec 10 $ do
      Read.Ident "fromNonEmpty" <- Read.lexP
      dl <- Read.readPrec
      return $ fromNonEmpty dl
  readListPrec = Read.readListPrecDefault

instance Show a => Show (DNonEmpty a) where
  showsPrec p dl =
    showParen (p > 10) $
      showString "fromNonEmpty " . shows (toNonEmpty dl)

instance Functor DNonEmpty where
  {-# INLINE fmap #-}
  fmap = map

instance Applicative.Applicative DNonEmpty where
  {-# INLINE pure #-}
  pure = singleton

  {-# INLINE (<*>) #-}
  (<*>) = Monad.ap

instance Monad DNonEmpty where
  ~(x :| xs) >>= k = y :| DList.append ys (xs >>= toDList . k)
    where
      y :| ys = k x

  {-# INLINE return #-}
  return = Applicative.pure

instance Foldable.Foldable DNonEmpty where
  {-# INLINE fold #-}
  fold = Foldable.fold . toNonEmpty

  {-# INLINE foldMap #-}
  foldMap f = Foldable.foldMap f . toNonEmpty

  {-# INLINE foldr #-}
  foldr f x = Foldable.foldr f x . toNonEmpty

  {-# INLINE foldl #-}
  foldl f x = Foldable.foldl f x . toNonEmpty

  {-# INLINE foldr1 #-}
  foldr1 f = Foldable.foldr1 f . toNonEmpty

  {-# INLINE foldl1 #-}
  foldl1 f = Foldable.foldl1 f . toNonEmpty

  {-# INLINE foldl' #-}
  foldl' f x = Foldable.foldl' f x . toNonEmpty

  {-# INLINE foldr' #-}
  foldr' f x = Foldable.foldr' f x . toNonEmpty

  {-# INLINE toList #-}
  toList = toList

instance NFData a => NFData (DNonEmpty a) where
  {-# INLINE rnf #-}
  rnf = rnf . toNonEmpty

{-

The 'IsString' instance is _not_ a flexible instance to allow certain uses of
overloaded strings. See tests/OverloadedStrings.hs for an example and
https://gitlab.haskell.org/ghc/ghc/-/commit/b225b234a6b11e42fef433dcd5d2a38bb4b466bf
for the same change made to the IsString instance for lists.

-}

instance a ~ Char => IsString (DNonEmpty a) where
  {-# INLINE fromString #-}
  fromString = fromList

instance Exts.IsList (DNonEmpty a) where
  type Item (DNonEmpty a) = a

  {-# INLINE fromList #-}
  fromList = fromList

  {-# INLINE toList #-}
  toList = toList

instance Semigroup.Semigroup (DNonEmpty a) where
  {-# INLINE (<>) #-}
  (<>) = append