module Data.Rope.Annotated.Internal
( A(A,rope)
, Ann
, Annotation(..)
, (:~>)
, null
, head
, last
, unpack
, uncons
, unsnoc
, drop
, take
, splitAt
, unit
, snoc
, cons
, empty
, append
, break
, span
, takeWhile
, dropWhile
, Drop, Take, Snoc, Cons, Tail, Init, Empty, (:<>)
, (:*:)(..), fstF, sndF
) where
import Prelude hiding (null, head, last, take, drop, span, break, splitAt, takeWhile, dropWhile)
import Control.Applicative hiding (empty)
import Data.Rope.Util.Comonad
import Data.Monoid
import qualified Data.Rope.Util.Reducer as Reducer
import Data.Rope.Util.Reducer (Reducer)
import Data.FingerTree (Measured(..))
import Data.Foldable (Foldable, foldMap)
import qualified Data.Foldable
import Data.Traversable (Traversable(traverse))
import qualified Data.Rope.Internal as Rope
import Data.Rope.Body (Offset(..))
import Data.Rope.Internal (Rope(..),Breakable, Unpackable)
type f :~> g = forall a. f a -> g a
data A s a = A { rope :: !Rope, extractA :: a }
null :: A s a -> Bool
null = Rope.null . rope
head :: Unpackable t => A s a -> t
head = Rope.head . rope
last :: Unpackable t => A s a -> t
last = Rope.last . rope
type Ann a f = A a (f a)
instance Measured Offset (A s a) where
measure = measure . rope
instance Functor (A s) where
fmap f (A s a) = A s (f a)
instance Comonad (A s) where
extract = extractA
extend f a@(A s _) = A s (f a)
duplicate a@(A s _) = A s a
instance Foldable (A s) where
foldr f z (A _ a) = f a z
foldr1 _ (A _ a) = a
foldl f z (A _ a) = f z a
foldl1 _ (A _ a) = a
foldMap f (A _ a) = f a
instance Traversable (A s) where
traverse f (A s a) = A s <$> f a
class Annotation f where
unitA :: Rope -> f a
splitAtA :: Int -> Rope -> f a -> (f b, f c)
takeA :: Int -> Rope -> f a -> f b
dropA :: Int -> Rope -> f a -> f b
snocA :: Rope -> Int -> f a -> f b
consA :: Int -> Rope -> f a -> f b
emptyA :: f Empty
appendA :: Ann a f -> Ann b f -> f (a :<> b)
takeA n r = fst . splitAtA n r
dropA n r = snd . splitAtA n r
empty :: Annotation f => Ann Empty f
empty = A Rope.empty emptyA
unit :: (Reducer t Rope, Annotation f) => t -> Ann a f
unit t = A r (unitA r)
where
r :: Rope
r = Reducer.unit t
splitAt :: Annotation f => Int -> Ann a f -> (forall n. Ann (Take n a) f -> Ann (Drop n a) f -> r) -> r
splitAt n (A r a) k = k (A r b) (A r c)
where (b, c) = splitAtA n r a
drop :: Annotation f => Int -> Ann a f -> (forall n. Ann (Drop n a) f -> r) -> r
drop n (A r a) k = k (A r (dropA n r a))
take :: Annotation f => Int -> Ann a f -> (forall n. Ann (Take n a) f -> r) -> r
take n (A r a) k = k (A r (takeA n r a))
snoc :: (Annotation f, Reducer t Rope) => Ann a f -> t -> (forall c. Ann (Snoc c t a) f -> r) -> r
snoc (A r a) t k = k (A r' (snocA r' (Rope.length r' Rope.length r) a))
where r' = Reducer.snoc r t
cons :: (Annotation f, Reducer t Rope) => t -> Ann a f -> (forall c. Ann (Cons c t a) f -> r) -> r
cons t (A r a) k = k (A r' (consA (Rope.length r' Rope.length r) r' a))
where r' = Reducer.cons t r
append :: Annotation f => Ann a f -> Ann b f -> Ann (a :<> b) f
append a@(A r _) b@(A s _) = A (r `mappend` s) (a `appendA` b)
break :: (Annotation f, Breakable t) => (t -> Bool) -> Ann a f -> (forall n. Ann (Take n a) f -> Ann (Drop n a) f -> r) -> r
break p (A r a) k = k (A x b) (A y c) where
(x,y) = Rope.break p r
(b,c) = splitAtA (Rope.length x) r a
span :: (Annotation f, Breakable t) => (t -> Bool) -> Ann a f -> (forall n. Ann (Take n a) f -> Ann (Drop n a) f -> r) -> r
span p (A r a) k = k (A x b) (A y c) where
(x,y) = Rope.span p r
(b,c) = splitAtA (Rope.length x) r a
takeWhile :: (Annotation f, Breakable t) => (t -> Bool) -> Ann a f -> (forall n. Ann (Take n a) f -> r) -> r
takeWhile p (A r a) k = k (A x b) where
x = Rope.takeWhile p r
b = takeA (Rope.length x) r a
dropWhile :: (Annotation f, Breakable t) => (t -> Bool) -> Ann a f -> (forall n. Ann (Drop n a) f -> r) -> r
dropWhile p (A r a) k = k (A y c) where
y = Rope.dropWhile p r
c = dropA (Rope.length r Rope.length y) r a
uncons :: (Annotation f, Unpackable t) => Ann a f -> Maybe (t, Ann (Tail t a) f)
uncons (A r a) = case Rope.uncons r of
Just (c,cs) -> Just (c, A cs (dropA (Rope.length r Rope.length cs) r a))
Nothing -> Nothing
unsnoc :: (Annotation f, Unpackable t) => Ann a f -> Maybe (Ann (Init a t) f, t)
unsnoc (A r a) = case Rope.unsnoc r of
Just (cs,c) -> Just (A cs (dropA (Rope.length cs) r a), c)
Nothing -> Nothing
infixr 5 :*:
data (f :*: g) a = f a :*: g a
fstF :: (f :*: g) :~> f
fstF ~(f :*: _) = f
sndF :: (f :*: g) :~> g
sndF ~(_ :*: g) = g
instance (Functor f, Functor g) => Functor (f :*: g) where
fmap f (a :*: b) = fmap f a :*: fmap f b
instance (Applicative f, Applicative g) => Applicative (f :*: g) where
pure a = pure a :*: pure a
(f :*: g) <*> (a :*: b) = (f <*> a) :*: (g <*> b)
instance (Foldable f, Foldable g) => Foldable (f :*: g) where
foldMap f (a :*: b) = foldMap f a `mappend` foldMap f b
instance (Traversable f, Traversable g) => Traversable (f :*: g) where
traverse f (a :*: b) = (:*:) <$> traverse f a <*> traverse f b
instance (Annotation f, Annotation g) => Annotation (f :*: g) where
unitA r = unitA r :*: unitA r
emptyA = emptyA :*: emptyA
dropA n r (f :*: g) = dropA n r f :*: dropA n r g
takeA n r (f :*: g) = takeA n r f :*: takeA n r g
splitAtA n r (f :*: g) = (f' :*: g' , f'' :*: g'') where
(f',f'') = splitAtA n r f
(g',g'') = splitAtA n r g
snocA r n (f :*: g) = snocA r n f :*: snocA r n g
consA n r (f :*: g) = consA n r f :*: consA n r g
appendA (A r (a :*: a')) (A s (b :*: b')) =
appendA (A r a) (A s b) :*: appendA (A r a') (A s b')
data Take n a
data Drop n a
data Empty
data Cons s t a
data Snoc a s t
data (:<>) a b
data Tail t a
data Init a t
unpack :: Unpackable t => A s a -> [t]
unpack (A s _) = Rope.unpack s