-- | This module provides an API for "marking up" text with arbitrary
-- values. A piece of markup can then be converted to a list of pairs
-- representing the sequences of characters assigned the same markup
-- value.
--
-- This interface is experimental. Don't use this for your full-file
-- syntax highlighter just yet!
module Data.Text.Markup
  ( Markup
  , markupToList
  , markupSet
  , fromList
  , fromText
  , toText
  , isEmpty
  , (@@)
  )
where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid
#endif

import qualified Data.Semigroup as Sem
import Data.String (IsString(..))
import qualified Data.Text as T

-- | Markup with metadata type 'a' assigned to each character.
data Markup a = Markup [(Char, a)]
              deriving Int -> Markup a -> ShowS
[Markup a] -> ShowS
Markup a -> String
(Int -> Markup a -> ShowS)
-> (Markup a -> String) -> ([Markup a] -> ShowS) -> Show (Markup a)
forall a. Show a => Int -> Markup a -> ShowS
forall a. Show a => [Markup a] -> ShowS
forall a. Show a => Markup a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Markup a] -> ShowS
$cshowList :: forall a. Show a => [Markup a] -> ShowS
show :: Markup a -> String
$cshow :: forall a. Show a => Markup a -> String
showsPrec :: Int -> Markup a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Markup a -> ShowS
Show

instance Sem.Semigroup (Markup a) where
    (Markup [(Char, a)]
t1) <> :: Markup a -> Markup a -> Markup a
<> (Markup [(Char, a)]
t2) = [(Char, a)] -> Markup a
forall a. [(Char, a)] -> Markup a
Markup ([(Char, a)]
t1 [(Char, a)] -> [(Char, a)] -> [(Char, a)]
forall a. Monoid a => a -> a -> a
`mappend` [(Char, a)]
t2)

instance Monoid (Markup a) where
    mempty :: Markup a
mempty = [(Char, a)] -> Markup a
forall a. [(Char, a)] -> Markup a
Markup [(Char, a)]
forall a. Monoid a => a
mempty
    mappend :: Markup a -> Markup a -> Markup a
mappend = Markup a -> Markup a -> Markup a
forall a. Semigroup a => a -> a -> a
(Sem.<>)

instance (Monoid a) => IsString (Markup a) where
    fromString :: String -> Markup a
fromString = Text -> Markup a
forall a. Monoid a => Text -> Markup a
fromText (Text -> Markup a) -> (String -> Text) -> String -> Markup a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Build a piece of markup; assign the specified metadata to every
-- character in the specified text.
(@@) :: T.Text -> a -> Markup a
Text
t @@ :: Text -> a -> Markup a
@@ a
val = [(Char, a)] -> Markup a
forall a. [(Char, a)] -> Markup a
Markup [(Char
c, a
val) | Char
c <- Text -> String
T.unpack Text
t]

-- | Build markup from text with the default metadata.
fromText :: (Monoid a) => T.Text -> Markup a
fromText :: Text -> Markup a
fromText = (Text -> a -> Markup a
forall a. Text -> a -> Markup a
@@ a
forall a. Monoid a => a
mempty)

-- | Extract the text from markup, discarding the markup metadata.
toText :: (Eq a) => Markup a -> T.Text
toText :: Markup a -> Text
toText = [Text] -> Text
T.concat ([Text] -> Text) -> (Markup a -> [Text]) -> Markup a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, a) -> Text
forall a b. (a, b) -> a
fst ((Text, a) -> Text) -> [(Text, a)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([(Text, a)] -> [Text])
-> (Markup a -> [(Text, a)]) -> Markup a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Text, a)]] -> [(Text, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, a)]] -> [(Text, a)])
-> (Markup a -> [[(Text, a)]]) -> Markup a -> [(Text, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup a -> [[(Text, a)]]
forall a. Eq a => Markup a -> [[(Text, a)]]
markupToList

-- | Test whether the markup is empty.
isEmpty :: Markup a -> Bool
isEmpty :: Markup a -> Bool
isEmpty (Markup [(Char, a)]
ls) = [(Char, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Char, a)]
ls

-- | Set the metadata for a range of character positions in a piece of
-- markup. This is useful for, e.g., syntax highlighting.
markupSet :: (Eq a) => (Int, Int) -> a -> Markup a -> Markup a
markupSet :: (Int, Int) -> a -> Markup a -> Markup a
markupSet (Int
start, Int
len) a
val m :: Markup a
m@(Markup [(Char, a)]
l) = if Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [(Char, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Char, a)]
l
                                          then Markup a
m
                                          else Markup a
newM
    where
        newM :: Markup a
newM = [(Char, a)] -> Markup a
forall a. [(Char, a)] -> Markup a
Markup ([(Char, a)] -> Markup a) -> [(Char, a)] -> Markup a
forall a b. (a -> b) -> a -> b
$ [(Char, a)]
theHead [(Char, a)] -> [(Char, a)] -> [(Char, a)]
forall a. [a] -> [a] -> [a]
++ [(Char, a)]
theNewEntries [(Char, a)] -> [(Char, a)] -> [(Char, a)]
forall a. [a] -> [a] -> [a]
++ [(Char, a)]
theTail
        ([(Char, a)]
theHead, [(Char, a)]
theLongTail) = Int -> [(Char, a)] -> ([(Char, a)], [(Char, a)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
start [(Char, a)]
l
        ([(Char, a)]
theOldEntries, [(Char, a)]
theTail) = Int -> [(Char, a)] -> ([(Char, a)], [(Char, a)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len [(Char, a)]
theLongTail
        theNewEntries :: [(Char, a)]
theNewEntries = String -> [a] -> [(Char, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Char, a) -> Char
forall a b. (a, b) -> a
fst ((Char, a) -> Char) -> [(Char, a)] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Char, a)]
theOldEntries) (a -> [a]
forall a. a -> [a]
repeat a
val)

-- | Convert markup to a list of lines. Each line is represented by a
-- list of pairs in which each pair contains the longest subsequence of
-- characters having the same metadata.
markupToList :: (Eq a) => Markup a -> [[(T.Text, a)]]
markupToList :: Markup a -> [[(Text, a)]]
markupToList (Markup [(Char, a)]
thePairs) = [(Char, a)] -> [(Text, a)]
forall b. Eq b => [(Char, b)] -> [(Text, b)]
toList ([(Char, a)] -> [(Text, a)]) -> [[(Char, a)]] -> [[(Text, a)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Char, a)]] -> [(Char, a)] -> [(Char, a)] -> [[(Char, a)]]
forall b.
[[(Char, b)]] -> [(Char, b)] -> [(Char, b)] -> [[(Char, b)]]
toLines [] [] [(Char, a)]
thePairs
    where
        toLines :: [[(Char, b)]] -> [(Char, b)] -> [(Char, b)] -> [[(Char, b)]]
toLines [[(Char, b)]]
ls [(Char, b)]
cur [] = [[(Char, b)]]
ls [[(Char, b)]] -> [[(Char, b)]] -> [[(Char, b)]]
forall a. [a] -> [a] -> [a]
++ [[(Char, b)]
cur]
        toLines [[(Char, b)]]
ls [(Char, b)]
cur ((Char
ch, b
val):[(Char, b)]
rest)
            | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = [[(Char, b)]] -> [(Char, b)] -> [(Char, b)] -> [[(Char, b)]]
toLines ([[(Char, b)]]
ls [[(Char, b)]] -> [[(Char, b)]] -> [[(Char, b)]]
forall a. [a] -> [a] -> [a]
++ [[(Char, b)]
cur]) [] [(Char, b)]
rest
            | Bool
otherwise = [[(Char, b)]] -> [(Char, b)] -> [(Char, b)] -> [[(Char, b)]]
toLines [[(Char, b)]]
ls ([(Char, b)]
cur [(Char, b)] -> [(Char, b)] -> [(Char, b)]
forall a. [a] -> [a] -> [a]
++ [(Char
ch, b
val)]) [(Char, b)]
rest

        toList :: [(Char, b)] -> [(Text, b)]
toList [] = []
        toList ((Char
ch, b
val):[(Char, b)]
rest) = (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: ((Char, b) -> Char
forall a b. (a, b) -> a
fst ((Char, b) -> Char) -> [(Char, b)] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Char, b)]
matching), b
val) (Text, b) -> [(Text, b)] -> [(Text, b)]
forall a. a -> [a] -> [a]
: [(Char, b)] -> [(Text, b)]
toList [(Char, b)]
remaining
            where
                ([(Char, b)]
matching, [(Char, b)]
remaining) = ((Char, b) -> Bool) -> [(Char, b)] -> ([(Char, b)], [(Char, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\(Char
_, b
v) -> b
v b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
val) [(Char, b)]
rest

-- | Convert a list of text and metadata pairs into markup.
fromList :: [(T.Text, a)] -> Markup a
fromList :: [(Text, a)] -> Markup a
fromList [(Text, a)]
pairs = [(Char, a)] -> Markup a
forall a. [(Char, a)] -> Markup a
Markup ([(Char, a)] -> Markup a) -> [(Char, a)] -> Markup a
forall a b. (a -> b) -> a -> b
$ ((Text, a) -> [(Char, a)]) -> [(Text, a)] -> [(Char, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
t, a
val) -> [(Char
c, a
val) | Char
c <- Text -> String
T.unpack Text
t]) [(Text, a)]
pairs