{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UnboxedTuples         #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Trifecta.Util.It
-- Copyright   :  (C) 2011-2019 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- harder, better, faster, stronger...
----------------------------------------------------------------------------
module Text.Trifecta.Util.It
  ( It(Pure, It)
  , needIt
  , wantIt
  , simplifyIt
  , foldIt
  , runIt
  , fillIt
  , rewindIt
  , sliceIt
  ) where

import Control.Comonad
import Control.Monad

import Data.ByteString                as Strict
import Data.ByteString.Lazy           as Lazy
import Data.Profunctor
import Text.Trifecta.Delta
import Text.Trifecta.Rope
import Text.Trifecta.Util.Combinators as Util

-- $setup
-- >>> import Control.Comonad (extract)
-- >>> import Data.ByteString as Strict
-- >>> import Text.Trifecta.Delta
-- >>> import Text.Trifecta.Rope
-- >>> import Text.Trifecta.Util.It

-- | @'It'@ is an <https://wiki.haskell.org/Enumerator_and_iteratee Iteratee>
-- that can produce partial results.
--
-- @'It' r a@ consumes a feed of @r@s and produces @a@s on the way. New values
-- can be fed using @'simplifyIt'@, the current (partial or final) result is
-- extracted using @'extract'@.
--
-- >>> let keepIt    a = Pure a
-- >>> let replaceIt a = It a replaceIt
--
-- >>> extract (keepIt 0)
-- 0
--
-- >>> extract (replaceIt 0)
-- 0
--
-- >>> extract (simplifyIt (keepIt 0) 5)
-- 0
--
-- >>> extract (simplifyIt (replaceIt 0) 5)
-- 5
data It r a
  = Pure a
  -- ^ Final result, rest of the feed is discarded
  | It a (r -> It r a)
  -- ^ Intermediate result, consumed values produce new results

instance Show a => Show (It r a) where
  showsPrec :: Int -> It r a -> ShowS
showsPrec Int
d (Pure a
a) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Pure " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a
  showsPrec Int
d (It a
a r -> It r a
_) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"It " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ..."

instance Functor (It r) where
  fmap :: (a -> b) -> It r a -> It r b
fmap a -> b
f (Pure a
a) = b -> It r b
forall r a. a -> It r a
Pure (b -> It r b) -> b -> It r b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  fmap a -> b
f (It a
a r -> It r a
k) = b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (a -> b
f a
a) ((r -> It r b) -> It r b) -> (r -> It r b) -> It r b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> It r a -> It r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (It r a -> It r b) -> (r -> It r a) -> r -> It r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> It r a
k

instance Profunctor It where
  rmap :: (b -> c) -> It a b -> It a c
rmap = (b -> c) -> It a b -> It a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  lmap :: (a -> b) -> It b c -> It a c
lmap a -> b
_ (Pure c
a) = c -> It a c
forall r a. a -> It r a
Pure c
a
  lmap a -> b
f (It c
a b -> It b c
g) = c -> (a -> It a c) -> It a c
forall r a. a -> (r -> It r a) -> It r a
It c
a ((a -> b) -> It b c -> It a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f (It b c -> It a c) -> (a -> It b c) -> a -> It a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> It b c
g (b -> It b c) -> (a -> b) -> a -> It b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative (It r) where
  pure :: a -> It r a
pure = a -> It r a
forall r a. a -> It r a
Pure
  Pure a -> b
f  <*> :: It r (a -> b) -> It r a -> It r b
<*> Pure a
a  = b -> It r b
forall r a. a -> It r a
Pure (b -> It r b) -> b -> It r b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  Pure a -> b
f  <*> It a
a r -> It r a
ka = b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (a -> b
f a
a) ((r -> It r b) -> It r b) -> (r -> It r b) -> It r b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> It r a -> It r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (It r a -> It r b) -> (r -> It r a) -> r -> It r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> It r a
ka
  It a -> b
f r -> It r (a -> b)
kf <*> Pure a
a  = b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (a -> b
f a
a) ((r -> It r b) -> It r b) -> (r -> It r b) -> It r b
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> b) -> It r (a -> b) -> It r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) (It r (a -> b) -> It r b) -> (r -> It r (a -> b)) -> r -> It r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> It r (a -> b)
kf
  It a -> b
f r -> It r (a -> b)
kf <*> It a
a r -> It r a
ka = b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (a -> b
f a
a) ((r -> It r b) -> It r b) -> (r -> It r b) -> It r b
forall a b. (a -> b) -> a -> b
$ \r
r -> r -> It r (a -> b)
kf r
r It r (a -> b) -> It r a -> It r b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> r -> It r a
ka r
r

indexIt :: It r a -> r -> a
indexIt :: It r a -> r -> a
indexIt (Pure a
a) r
_ = a
a
indexIt (It a
_ r -> It r a
k) r
r = It r a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract (r -> It r a
k r
r)

-- | Feed a value to 'It', obtaining a new (partial or final) result.
simplifyIt :: It r a -> r -> It r a
simplifyIt :: It r a -> r -> It r a
simplifyIt (It a
_ r -> It r a
k) r
r = r -> It r a
k r
r
simplifyIt It r a
pa r
_       = It r a
pa

instance Monad (It r) where
  return :: a -> It r a
return = a -> It r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Pure a
a >>= :: It r a -> (a -> It r b) -> It r b
>>= a -> It r b
f = a -> It r b
f a
a
  It a
a r -> It r a
k >>= a -> It r b
f = b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (It r b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract (a -> It r b
f a
a)) ((r -> It r b) -> It r b) -> (r -> It r b) -> It r b
forall a b. (a -> b) -> a -> b
$ \r
r -> case r -> It r a
k r
r of
    It a
a' r -> It r a
k' -> b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (It r b -> r -> b
forall r a. It r a -> r -> a
indexIt (a -> It r b
f a
a') r
r) ((r -> It r b) -> It r b) -> (r -> It r b) -> It r b
forall a b. (a -> b) -> a -> b
$ r -> It r a
k' (r -> It r a) -> (a -> It r b) -> r -> It r b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> It r b
f
    Pure a
a' -> It r b -> r -> It r b
forall r a. It r a -> r -> It r a
simplifyIt (a -> It r b
f a
a') r
r

instance ComonadApply (It r) where <@> :: It r (a -> b) -> It r a -> It r b
(<@>) = It r (a -> b) -> It r a -> It r b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

-- | 'It' is a cofree comonad
instance Comonad (It r) where
  duplicate :: It r a -> It r (It r a)
duplicate p :: It r a
p@Pure{}   = It r a -> It r (It r a)
forall r a. a -> It r a
Pure It r a
p
  duplicate p :: It r a
p@(It a
_ r -> It r a
k) = It r a -> (r -> It r (It r a)) -> It r (It r a)
forall r a. a -> (r -> It r a) -> It r a
It It r a
p (It r a -> It r (It r a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate (It r a -> It r (It r a)) -> (r -> It r a) -> r -> It r (It r a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> It r a
k)

  extend :: (It r a -> b) -> It r a -> It r b
extend It r a -> b
f p :: It r a
p@Pure{}   = b -> It r b
forall r a. a -> It r a
Pure (It r a -> b
f It r a
p)
  extend It r a -> b
f p :: It r a
p@(It a
_ r -> It r a
k) = b -> (r -> It r b) -> It r b
forall r a. a -> (r -> It r a) -> It r a
It (It r a -> b
f It r a
p) ((It r a -> b) -> It r a -> It r b
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend It r a -> b
f (It r a -> It r b) -> (r -> It r a) -> r -> It r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> It r a
k)

  extract :: It r a -> a
extract (Pure a
a) = a
a
  extract (It a
a r -> It r a
_) = a
a

-- | Consumes input until a value can be produced.
--
-- >>> :{
-- let needTen = needIt 0 (\n -> if n < 10 then Nothing else Just n) :: It Int Int
-- :}
--
-- >>> extract needTen
-- 0
--
-- >>> extract (simplifyIt needTen 5)
-- 0
--
-- >>> extract (simplifyIt needTen 11)
-- 11
--
-- >>> extract (simplifyIt (simplifyIt (simplifyIt needTen 5) 11) 15)
-- 11
needIt
    :: a               -- ^ Initial result
    -> (r -> Maybe a)  -- ^ Produce a result if possible
    -> It r a
needIt :: a -> (r -> Maybe a) -> It r a
needIt a
z r -> Maybe a
f = It r a
k where
  k :: It r a
k = a -> (r -> It r a) -> It r a
forall r a. a -> (r -> It r a) -> It r a
It a
z ((r -> It r a) -> It r a) -> (r -> It r a) -> It r a
forall a b. (a -> b) -> a -> b
$ \r
r -> case r -> Maybe a
f r
r of
    Just a
a -> a -> It r a
forall r a. a -> It r a
Pure a
a
    Maybe a
Nothing -> It r a
k

-- | Consumes input and produces partial results until a condition is met.
-- Unlike 'needIt', partial results are already returned when the condition is
-- not fulfilled yet.
--
-- > >>> :{
-- > let wantTen :: It Int Int
-- >     wantTen = wantIt 0 (\n -> (# n >= 10, n #))
-- > :}
--
-- > >>> extract wantTen
-- > 0
--
-- > >>> extract (simplifyIt wantTen 5)
-- > 5
--
-- > >>> extract (simplifyIt wantTen 11)
-- > 11
--
-- > >>> extract (simplifyIt (simplifyIt (simplifyIt wantTen 5) 11) 15)
-- > 11
wantIt
    :: a                 -- ^ Initial result
    -> (r -> (# Bool, a #))  -- ^ Produce a partial or final result
    -> It r a
wantIt :: a -> (r -> (# Bool, a #)) -> It r a
wantIt a
z r -> (# Bool, a #)
f = a -> (r -> It r a) -> It r a
forall r a. a -> (r -> It r a) -> It r a
It a
z r -> It r a
k where
  k :: r -> It r a
k r
r = case r -> (# Bool, a #)
f r
r of
    (# Bool
False, a
a #) -> a -> (r -> It r a) -> It r a
forall r a. a -> (r -> It r a) -> It r a
It a
a r -> It r a
k
    (# Bool
True,  a
a #) -> a -> It r a
forall r a. a -> It r a
Pure a
a

-- | The generalized fold (Böhm-Berarducci decoding) over 'It r a'.
--
-- 'foldIt' satisfies the property:
--
-- @foldIt Pure It = id@
foldIt :: (a -> o) -> (a -> (r -> o) -> o) -> It r a -> o
foldIt :: (a -> o) -> (a -> (r -> o) -> o) -> It r a -> o
foldIt a -> o
p a -> (r -> o) -> o
_ (Pure a
a) = a -> o
p a
a
foldIt a -> o
p a -> (r -> o) -> o
i (It a
a r -> It r a
k) = a -> (r -> o) -> o
i a
a (\r
r -> (a -> o) -> (a -> (r -> o) -> o) -> It r a -> o
forall a o r. (a -> o) -> (a -> (r -> o) -> o) -> It r a -> o
foldIt a -> o
p a -> (r -> o) -> o
i (r -> It r a
k r
r))

-- | Scott decoding of 'It r a'.
--
-- The scott decoding is similar to the generalized fold over a data type, but
-- leaves the recursion step to the calling function.
--
-- 'runIt' satiesfies the property:
--
-- @runIt Pure It = id@
--
-- See also the Scott decoding of lists:
--
-- @runList :: (a -> [a] -> b) -> b -> [a] -> b@
--
-- and compare it with 'foldr' (the Böhm-Berarducci decoding for lists):
--
-- @foldr :: (a -> b -> b) -> b -> [a] -> b@
runIt :: (a -> o) -> (a -> (r -> It r a) -> o) -> It r a -> o
runIt :: (a -> o) -> (a -> (r -> It r a) -> o) -> It r a -> o
runIt a -> o
p a -> (r -> It r a) -> o
_ (Pure a
a) = a -> o
p a
a
runIt a -> o
_ a -> (r -> It r a) -> o
i (It a
a r -> It r a
k) = a -> (r -> It r a) -> o
i a
a r -> It r a
k

-- * Rope specifics

-- | Given a position, go there, and grab the rest of the line forward from that
-- point.
--
-- >>> :set -XOverloadedStrings
-- >>> let secondLine = fillIt Nothing (const Just) (delta ("foo\nb" :: Strict.ByteString))
--
-- >>> extract secondLine
-- Nothing
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo"))
-- Nothing
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar"))
-- Just "ar"
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar\nbaz"))
-- Just "ar\n"
fillIt :: r -> (Delta -> Strict.ByteString -> r) -> Delta -> It Rope r
fillIt :: r -> (Delta -> ByteString -> r) -> Delta -> It Rope r
fillIt r
kf Delta -> ByteString -> r
ks Delta
n = r -> (Rope -> (# Bool, r #)) -> It Rope r
forall a r. a -> (r -> (# Bool, a #)) -> It r a
wantIt r
kf ((Rope -> (# Bool, r #)) -> It Rope r)
-> (Rope -> (# Bool, r #)) -> It Rope r
forall a b. (a -> b) -> a -> b
$ \Rope
r ->
  (# Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes Delta
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes (Delta -> Delta
rewind (Rope -> Delta
forall t. HasDelta t => t -> Delta
delta Rope
r))
  ,  Delta -> Rope -> r -> (Delta -> ByteString -> r) -> r
forall r. Delta -> Rope -> r -> (Delta -> ByteString -> r) -> r
grabLine Delta
n Rope
r r
kf Delta -> ByteString -> r
ks #)

-- | Return the text of the line that contains a given position
--
-- >>> :set -XOverloadedStrings
-- >>> let secondLine = rewindIt (delta ("foo\nb" :: Strict.ByteString))
--
-- >>> extract secondLine
-- Nothing
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo"))
-- Nothing
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar"))
-- Just "bar"
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar\nbaz"))
-- Just "bar\n"
rewindIt :: Delta -> It Rope (Maybe Strict.ByteString)
rewindIt :: Delta -> It Rope (Maybe ByteString)
rewindIt Delta
n = Maybe ByteString
-> (Rope -> (# Bool, Maybe ByteString #))
-> It Rope (Maybe ByteString)
forall a r. a -> (r -> (# Bool, a #)) -> It r a
wantIt Maybe ByteString
forall a. Maybe a
Nothing ((Rope -> (# Bool, Maybe ByteString #))
 -> It Rope (Maybe ByteString))
-> (Rope -> (# Bool, Maybe ByteString #))
-> It Rope (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Rope
r ->
  (# Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes Delta
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes (Delta -> Delta
rewind (Rope -> Delta
forall t. HasDelta t => t -> Delta
delta Rope
r))
  ,  Delta
-> Rope
-> Maybe ByteString
-> (Delta -> ByteString -> Maybe ByteString)
-> Maybe ByteString
forall r. Delta -> Rope -> r -> (Delta -> ByteString -> r) -> r
grabLine (Delta -> Delta
rewind Delta
n) Rope
r Maybe ByteString
forall a. Maybe a
Nothing ((Delta -> ByteString -> Maybe ByteString) -> Maybe ByteString)
-> (Delta -> ByteString -> Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString)
-> Delta -> ByteString -> Maybe ByteString
forall a b. a -> b -> a
const ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just #)

-- | Return the text between two offsets.
--
-- >>> :set -XOverloadedStrings
-- >>> let secondLine = sliceIt (delta ("foo\n" :: Strict.ByteString)) (delta ("foo\nbar\n" :: Strict.ByteString))
--
-- >>> extract secondLine
-- ""
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo"))
-- ""
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar"))
-- "bar"
--
-- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar\nbaz"))
-- "bar\n"
sliceIt :: Delta -> Delta -> It Rope Strict.ByteString
sliceIt :: Delta -> Delta -> It Rope ByteString
sliceIt !Delta
i !Delta
j = ByteString
-> (Rope -> (# Bool, ByteString #)) -> It Rope ByteString
forall a r. a -> (r -> (# Bool, a #)) -> It r a
wantIt ByteString
forall a. Monoid a => a
mempty ((Rope -> (# Bool, ByteString #)) -> It Rope ByteString)
-> (Rope -> (# Bool, ByteString #)) -> It Rope ByteString
forall a b. (a -> b) -> a -> b
$ \Rope
r ->
  (# Int64
bj Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes (Delta -> Delta
rewind (Rope -> Delta
forall t. HasDelta t => t -> Delta
delta Rope
r))
  ,  Delta
-> Rope
-> ByteString
-> (Delta -> ByteString -> ByteString)
-> ByteString
forall r. Delta -> Rope -> r -> (Delta -> ByteString -> r) -> r
grabRest Delta
i Rope
r ByteString
forall a. Monoid a => a
mempty ((Delta -> ByteString -> ByteString) -> ByteString)
-> (Delta -> ByteString -> ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> Delta -> ByteString -> ByteString
forall a b. a -> b -> a
const ((ByteString -> ByteString) -> Delta -> ByteString -> ByteString)
-> (ByteString -> ByteString) -> Delta -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Util.fromLazy (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
Lazy.take (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
bj Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
bi)) #)
  where
    bi :: Int64
bi = Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes Delta
i
    bj :: Int64
bj = Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes Delta
j