Internal.hs

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

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

{-# LANGUAGE CPP #-}

{-

We use __GLASGOW_HASKELL__ everywhere, so, rather than check if it's defined in
multiple places, we assert an error here if it is not. Since the rest of the
package depends on this module ('Data.DList.Internal'), we don't perform the
same check everywhere else.

-}
#if !defined(__GLASGOW_HASKELL__)
#error "Your compiler is not GHC. Let us know if dlist can be made to work on it."
#endif

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

-- CPP: GHC >= 7.8 for pattern synonyms, Safe Haskell, view patterns
#if __GLASGOW_HASKELL__ >= 708
{- ORMOLU_ENABLE -}
{-# LANGUAGE PatternSynonyms #-}
{-

The 'Data.DList.Internal' module exports 'UnsafeDList' and 'unsafeApplyDList',
which allow breaking the invariant of the 'DList' newtype. Therefore, we
explicitly mark 'Data.DList.Internal' as unsafe.

-}
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ViewPatterns #-}
{- ORMOLU_DISABLE -}
#endif

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

{-|

Module: Data.DList.Internal
Copyright: © 2006-2009 Don Stewart, 2013-2020 Sean Leather
License: BSD-3-Clause

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

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

-}
{- ORMOLU_ENABLE -}

module Data.DList.Internal where

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

import qualified Control.Applicative as Applicative
import Control.DeepSeq (NFData (..))
import qualified Control.Monad as Monad
-- CPP: base >= 4.9 for MonadFail
-- CPP: base >= 4.13 for MonadFail exported from Control.Monad
#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0)
import qualified Control.Monad.Fail as Monad
#endif
import qualified Data.Foldable as Foldable
import Data.Function (on)
import qualified Data.List as List
import qualified Data.Monoid as Monoid
-- CPP: base >= 4.9 for Semigroup
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup
#endif
import Data.String (IsString (..))
import qualified Data.Traversable as Traversable
-- CPP: GHC >= 7.8 for IsList
#if __GLASGOW_HASKELL__ >= 708
import qualified GHC.Exts as Exts
#endif
import qualified Text.Read as Read
import Prelude hiding (concat, foldr, head, map, replicate, tail)

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

{- ORMOLU_DISABLE -}
{-|

A difference list is an abstraction representing a list that
supports \(\mathcal{O}\)(@1@) 'append' and 'snoc' operations, making it
useful for replacing frequent applications of '++' such as logging and pretty
printing (esp. if those uses of '++' are left-nested).

-}
{- ORMOLU_ENABLE -}

newtype DList a = UnsafeDList {unsafeApplyDList :: [a] -> [a]}

{- ORMOLU_DISABLE -}
{-|

__@fromList xs@__ is a 'DList' representing the list __@xs@__.

@fromList@ obeys the laws:

@
'toList' . __fromList__ = 'id'
__fromList__ . 'toList' = 'id'
@

This function is implemented with '++'. Repeated uses of @fromList@ 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
'DList' representation and library:

@
__fromList__ . f . 'toList'
@

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

@
'toList' . g . __fromList__
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE fromList #-}
fromList :: [a] -> DList a
fromList = UnsafeDList . (++)

{- ORMOLU_DISABLE -}
{-|

__@toList xs@__ is the list represented by __@xs@__.

@toList@ obeys the laws:

@
__toList__ . 'fromList' = 'id'
'fromList' . __toList__ = 'id'
@

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

-}
{- ORMOLU_ENABLE -}

{-# INLINE toList #-}
toList :: DList a -> [a]
toList = ($ []) . unsafeApplyDList

-- CPP: GHC >= 7.8 for pattern synonyms
#if __GLASGOW_HASKELL__ >= 708

-- CPP: GHC >= 7.10 for pattern synonym signatures

{- ORMOLU_DISABLE -}
{-|

A unidirectional pattern synonym for 'empty'. This is implemented with 'toList'.

-}
{- ORMOLU_ENABLE -}

#if __GLASGOW_HASKELL__ >= 710
pattern Nil :: DList a
#endif
pattern Nil <- (toList -> [])

{- ORMOLU_DISABLE -}
{-|

A unidirectional pattern synonym for 'cons'. This is implemented with 'toList'.

-}
{- ORMOLU_ENABLE -}

#if __GLASGOW_HASKELL__ >= 710
pattern Cons :: a -> [a] -> DList a
#endif
pattern Cons x xs <- (toList -> x : xs)

#endif

{- ORMOLU_DISABLE -}
{-|

__@apply xs ys@__ is the list represented by the __@xs@__ after appending
__@ys@__ to it.

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

@apply@ obeys the law:

@
__apply__ xs ys = 'toList' xs '++' ys
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE apply #-}
apply :: DList a -> [a] -> [a]
apply = unsafeApplyDList

{- ORMOLU_DISABLE -}
{-|

__@empty@__ is a 'DList' with no elements.

@empty@ obeys the law:

@
'toList' __empty__ = []
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE empty #-}
empty :: DList a
empty = UnsafeDList id

{- ORMOLU_DISABLE -}
{-|

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

@singleton@ obeys the law:

@
'toList' (__singleton__ x) = [x]
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE singleton #-}
singleton :: a -> DList a
singleton = UnsafeDList . (:)

{- ORMOLU_DISABLE -}
{-|

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

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

@cons@ obeys the law:

@
'toList' (__cons__ x xs) = x : 'toList' xs
@

-}
{- ORMOLU_ENABLE -}

infixr 9 `cons`

{-# INLINE cons #-}
cons :: a -> DList a -> DList a
cons x xs = UnsafeDList $ (x :) . unsafeApplyDList xs

infixl 9 `snoc`

{- ORMOLU_DISABLE -}
{-|

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

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

@snoc@ obeys the law:

@
'toList' (__snoc__ xs x) = 'toList' xs '++' [x]
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE snoc #-}
snoc :: DList a -> a -> DList a
snoc xs x = UnsafeDList $ unsafeApplyDList xs . (x :)

{- ORMOLU_DISABLE -}
{-|

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

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

@append@ obeys the law:

@
'toList' (__append__ xs ys) = 'toList' xs '++' 'toList' ys
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE append #-}
append :: DList a -> DList a -> DList a
append xs ys = UnsafeDList $ unsafeApplyDList xs . unsafeApplyDList ys

{- ORMOLU_DISABLE -}
{-|

__@concat xss@__ is a 'DList' representing the concatenation of all 'DList's in
the list __@xss@__.

\(\mathcal{O}\)(@'length' xss@).

@concat@ obeys the law:

@
'toList' (__concat__ xss) = 'List.concat' ('List.map' 'toList' xss)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE concat #-}
concat :: [DList a] -> DList a
concat = List.foldr append empty

{- ORMOLU_DISABLE -}
{-|

__@replicate n x@__ is a 'DList' of length __@n@__ with __@x@__ as the value of
every element.

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

@replicate@ obeys the law:

@
'toList' (__replicate__ n x) = 'List.replicate' n x
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE replicate #-}
replicate :: Int -> a -> DList a
replicate n x = UnsafeDList $ \xs ->
  let go m
        | m <= 0 = xs
        | otherwise = x : go (m -1)
   in go n

{- ORMOLU_DISABLE -}
{-|

__@head xs@__ is the first element of __@xs@__. If @xs@ is empty, an 'error' is
raised.

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

@head@ obeys the law:

@
__head__ xs = 'List.head' ('toList' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE head #-}
head :: DList a -> a
head xs = case toList xs of
  x : _ -> x
  [] -> error "Data.DList.head: empty DList"

{- ORMOLU_DISABLE -}
{-|

__@tail xs@__ is a list of the elements in __@xs@__ excluding the first element.
If @xs@ is empty, an 'error' is raised.

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

@tail@ obeys the law:

@
__tail__ xs = 'List.tail' ('toList' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE tail #-}
tail :: DList a -> [a]
tail xs = case toList xs of
  _ : ys -> ys
  [] -> error "Data.DList.tail: empty DList"

{- ORMOLU_DISABLE -}
{-|

__@unfoldr f z@__ is the 'DList' 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}\)(@'length' ('List.unfoldr' f z)@).

@unfoldr@ obeys the law:

@
'toList' (__unfoldr__ f z) = 'List.unfoldr' f z
@

-}
{- ORMOLU_ENABLE -}

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

{- ORMOLU_DISABLE -}
{-|

__@foldr f z xs@__ is the right-fold of __@f@__ over __@xs@__.

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

@foldr@ obeys the law:

@
__foldr__ f z xs = 'List.foldr' f z ('toList' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE foldr #-}
foldr :: (a -> b -> b) -> b -> DList a -> b
foldr f z = List.foldr f z . toList

{- ORMOLU_DISABLE -}
{-|

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

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

@map@ obeys the law:

@
'toList' (__map__ f xs) = 'List.map' f ('toList' xs)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE map #-}
map :: (a -> b) -> DList a -> DList b
map f = foldr (cons . f) empty

{- ORMOLU_DISABLE -}
{-|

__@intercalate xs xss@__ is the concatenation of __@xss@__ after the insertion
of __@xs@__ between every pair of
elements.

\(\mathcal{O}\)(@'length' xss@).

@intercalate@ obeys the law:

@
'toList' (__intercalate__ xs xss) = 'List.intercalate' ('toList' xs) ('map' 'toList' xss)
@

-}
{- ORMOLU_ENABLE -}

{-# INLINE intercalate #-}
intercalate :: DList a -> [DList a] -> DList a
intercalate sep = concat . List.intersperse sep

instance Eq a => Eq (DList a) where
  (==) = (==) `on` toList

instance Ord a => Ord (DList a) where
  compare = compare `on` toList

-- The 'Read' and 'Show' instances were adapted from 'Data.Sequence'.

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

instance Show a => Show (DList a) where
  showsPrec p dl =
    showParen (p > 10) $
      showString "fromList " . shows (toList dl)

instance Monoid.Monoid (DList a) where
  {-# INLINE mempty #-}
  mempty = empty

-- CPP: base >= 4.11 for Semigroup as a superclass of Monoid
#if MIN_VERSION_base(4,11,0)

#else

  {-# INLINE mappend #-}
-- CPP: base >= 4.9 for Semigroup in base
#if MIN_VERSION_base(4,9,0)
  -- Canonical definition
  mappend = (Semigroup.<>)
#else
  mappend = append
#endif

#endif

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

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

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

instance Applicative.Alternative DList where
  {-# INLINE empty #-}
  empty = empty

  {-# INLINE (<|>) #-}
  (<|>) = append

instance Monad DList where
  {-# INLINE (>>=) #-}
  m >>= k =
    -- = concat (toList (fmap k m))
    -- = (concat . toList . fromList . List.map k . toList) m
    -- = concat . List.map k . toList $ m
    -- = List.foldr append empty . List.map k . toList $ m
    -- = List.foldr (append . k) empty . toList $ m
    foldr (append . k) empty m

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

-- CPP: base < 4.13 for fail in Monad
#if !MIN_VERSION_base(4,13,0)
  {-# INLINE fail #-}
  fail _ = empty
#endif

-- CPP: base >= 4.9 for MonadFail
#if MIN_VERSION_base(4,9,0)
instance Monad.MonadFail DList where
  {-# INLINE fail #-}
  fail _ = empty
#endif

instance Monad.MonadPlus DList where
  {-# INLINE mzero #-}
  mzero = empty

  {-# INLINE mplus #-}
  mplus = append

instance Foldable.Foldable DList where
  {-# INLINE fold #-}
  fold = Monoid.mconcat . toList

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

  {-# INLINE foldr #-}
  foldr f x = List.foldr f x . toList

  {-# INLINE foldl #-}
  foldl f x = List.foldl f x . toList

  {-# INLINE foldr1 #-}
  foldr1 f = List.foldr1 f . toList

  {-# INLINE foldl1 #-}
  foldl1 f = List.foldl1 f . toList

-- CPP: GHC >= 7.6 for foldl', foldr' in Foldable
#if __GLASGOW_HASKELL__ >= 706
  {-# INLINE foldl' #-}
  foldl' f x = List.foldl' f x . toList

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

-- CPP: base >= 4.8 for toList in Foldable
#if MIN_VERSION_base(4,8,0)
  {-# INLINE toList #-}
  toList = Data.DList.Internal.toList
#endif

instance Traversable.Traversable DList where
  {-# INLINE traverse #-}
  traverse f = foldr cons_f (Applicative.pure empty)
    where
      cons_f x = Applicative.liftA2 cons (f x)

instance NFData a => NFData (DList a) where
  {-# INLINE rnf #-}
  rnf = rnf . toList

{-

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 (DList a) where
  {-# INLINE fromString #-}
  fromString = fromList

-- CPP: GHC >= 7.8 for IsList
#if __GLASGOW_HASKELL__ >= 708
instance Exts.IsList (DList a) where
  type Item (DList a) = a

  {-# INLINE fromList #-}
  fromList = fromList

  {-# INLINE toList #-}
  toList = toList
#endif

{-

We use 'compare n 0' in the definition of 'Semigroup.stimes' since the same
expression is used in 'Semigroup.stimesMonoid' and we should get a lazy
advantage. However, we prefer the error to be sourced here instead of
'Semigroup.stimesMonoid'.

-}

-- CPP: base >= 4.9 for Semigroup
#if MIN_VERSION_base(4,9,0)
instance Semigroup.Semigroup (DList a) where
  {-# INLINE (<>) #-}
  (<>) = append

  stimes n = case compare n 0 of
    LT -> error "Data.DList.stimes: negative multiplier"
    _ -> Semigroup.stimesMonoid n
#endif