text-markup (empty) → 0.1
raw patch · 7 files changed
+387/−0 lines, 7 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, quickcheck-text, tasty, tasty-quickcheck, text, text-markup
Files
- CHANGELOG.md +4/−0
- LICENSE +30/−0
- README.md +43/−0
- Setup.hs +2/−0
- src/Data/Text/Markup.hs +162/−0
- tests/Main.hs +102/−0
- text-markup.cabal +44/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1+---++Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Jonathan Daugherty++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jonathan Daugherty nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,43 @@+text-markup+===========++This library provides a data structure for associating arbitrary+metadata ("markup") with subsequences of text. The motivation for+this library is to provide a tool for mapping text attributes to text+sequences in terminal applications where we may want to perform many+such mappings by searching text with regular expressions or using+parsers to do syntax highlighting.++The main interface to the library is through three functions:++ * `toMarkup` - convert a `Text` into a `Markup a`,+ * `markRegion` - mark a region of the `Text` with a metadata value of+ type `a`, and+ * `fromMarkup` - recover the subsequences of the text with accompanying+ metadata.++For example,++```+> let m = toMarkup (T.pack "some@email.com 192.168.1.1 http://google.com/") Nothing+> fromMarkup $ markRegion 27 18 (Just "url")+ $ markRegion 15 11 (Just "ipv4")+ $ markRegion 0 14 (Just "e-mail") m+[ ("some@email.com" , Just "e-mail")+, (" " , Nothing)+, ("192.168.1.1" , Just "ipv4")+, (" " , Nothing)+, ("http://google.com/", Just "url")+]+```++Applying the same markup to adjacent regions results in a merge:++```+> let m = toMarkup (T.pack "foobar") Nothing+> fromMarkup $ markRegion 0 3 (Just "token") m+[("foo",Just "token"),("bar",Nothing)]+> fromMarkup $ markRegion 3 3 (Just "token")+ $ markRegion 0 3 (Just "token") m+[("foobar",Just "token")]+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Text/Markup.hs view
@@ -0,0 +1,162 @@+-- | Annotate subsequences of a 'Text' string with arbitrary metadata.+module Data.Text.Markup+ ( Markup+ , toMarkup+ , fromMarkup+ , markRegion+ )+where++import qualified Data.Sequence as S+import Data.Monoid ((<>))+import qualified Data.Text as T++data SequenceTree a =+ Node Int Int (S.Seq (SequenceTree a))+ | Leaf Int Int a+ deriving (Show, Eq)++-- | Markup. This contains text along with markup.+data Markup a =+ Markup { _sourceText :: T.Text+ , _markupMapping :: SequenceTree a+ }+ deriving (Show, Eq)++-- | Convert a 'Text' value into 'Markup' with the accompanying metadata+-- value assigned to the entire 'Text' sequence.+toMarkup :: T.Text -> a -> Markup a+toMarkup t a = Markup t (Leaf 0 (T.length t) a)++-- | Recover the original text along with metadata assigned with+-- 'markRegion'.+fromMarkup :: Markup a -> [(T.Text, a)]+fromMarkup (Markup txt tree) =+ -- Get all leave nodes from the tree in order, then use their+ -- descriptors to chop up the text+ let descs = leaves tree+ initialState :: (T.Text, [(T.Text, a)])+ initialState = (txt, [])+ nextChunk (remainingText, prevChunks) (_, len, val) =+ let (thisText, remainingText') = T.splitAt len remainingText+ thisChunk = (thisText, val)+ in (remainingText', prevChunks <> [thisChunk])+ (_, chunks) = foldl nextChunk initialState descs+ in chunks++-- | Mark a region of text with the specified metadata.+markRegion :: (Eq a)+ => Int+ -- ^ The starting index to mark.+ -> Int+ -- ^ The size of the region to mark.+ -> a+ -- ^ The metadata to store for this region.+ -> Markup a+ -- ^ The markup to modify.+ -> Markup a+markRegion start len val m@(Markup txt t0) =+ if start < 0 || len < 0 then m else Markup txt t1+ where+ t1 = treeMarkRegion start len val t0++-- Need recursive algorithm to rebuild tree with nodes split up as+-- necessary+treeMarkRegion :: (Eq a) => Int -> Int -> a -> SequenceTree a -> SequenceTree a+treeMarkRegion newStart newLen newVal leaf@(Leaf lStart lLen oldVal) =+ if newLen == 0 || not (startInLeaf || endInLeaf || containsLeaf) then leaf+ else if length validLeaves == 1+ then S.index validLeaves 0+ else if S.length validLeaves > 1+ then case mergeNodes validLeaves of+ Left l -> l+ Right ls -> Node lStart lLen ls+ else leaf+ where+ end = newStart + newLen+ lEnd = lStart + lLen+ startInLeaf = newStart >= lStart && newStart <= lEnd+ endInLeaf = end >= lStart && end <= lEnd+ containsLeaf = newStart < lStart && newLen > lLen++ -- Clamp the new node leaf to the size of the current leaf since+ -- the request could be larger than this leaf+ newStart' = max lStart newStart+ newEnd = min lEnd (newStart + newLen)+ newLen' = newEnd - newStart'++ newLeaves = S.fromList [ Leaf lStart (newStart - lStart) oldVal+ , Leaf newStart' newLen' newVal+ , Leaf newEnd (lEnd - newEnd) oldVal+ ]+ validLeaves = S.filter isValidLeaf newLeaves+ isValidLeaf (Leaf _ l _) = l > 0+ isValidLeaf _ = error "BUG: isValidLeaf got a Node!"++treeMarkRegion start len newVal node@(Node lStart lLen cs) =+ let end = start + len+ lEnd = lStart + lLen+ startInNode = start >= lStart && start <= lEnd+ endInNode = end >= lStart && end <= lEnd+ containsNode = start < lStart && len > lLen+ -- If the start or end is somewhere in this node, we need to process+ -- the children+ in if startInNode || endInNode || containsNode+ then let newChildren = treeMarkRegion start len newVal <$> cs+ in case mergeNodes newChildren of+ Left single -> single+ Right many -> Node lStart lLen many+ else node++mergeNodes :: (Eq a) => S.Seq (SequenceTree a) -> Either (SequenceTree a) (S.Seq (SequenceTree a))+mergeNodes s+ | S.null s = Right S.empty+ | S.length s == 1 = Left $ S.index s 0+ | otherwise =+ let a = S.index s 0+ b = S.index s 1+ rest = S.drop 2 s+ in case mergeNodePair a b of+ Just m -> mergeNodes $ m S.<| rest+ Nothing -> case mergeNodes $ b S.<| rest of+ Left l -> Right $ S.fromList [a, l]+ Right ls -> Right $ a S.<| ls++sInit :: S.Seq a -> S.Seq a+sInit s = S.take ((S.length s) - 1) s++sHead :: S.Seq a -> a+sHead s = S.index s 0++sTail :: S.Seq a -> S.Seq a+sTail = S.drop 1++sLast :: S.Seq a -> a+sLast s = S.index s ((S.length s) - 1)++mergeNodePair :: (Eq a) => SequenceTree a -> SequenceTree a -> Maybe (SequenceTree a)+mergeNodePair (Leaf aStart aLen aVal) (Leaf bStart bLen bVal)+ | aVal == bVal && bStart == aStart + aLen = Just $ Leaf aStart (aLen + bLen) aVal+ | otherwise = Nothing+mergeNodePair leaf@(Leaf aStart aLen _) (Node _ bLen bs) = do+ merged <- mergeNodePair leaf $ sHead bs+ case mergeNodes $ merged S.<| (sTail bs) of+ Left single -> return single+ Right many -> return $ Node aStart (aStart + aLen + bLen) many+mergeNodePair (Node aStart aLen as) leaf@(Leaf _ bLen _)+ | length as > 0 = do+ merged <- mergeNodePair (sLast as) leaf+ case mergeNodes $ sInit as <> S.singleton merged of+ Left single -> return single+ Right many -> return $ Node aStart (aStart + aLen + bLen) many+mergeNodePair (Node aStart aLen as) (Node _ bLen bs)+ | length as > 0 && length bs > 0 = do+ merged <- mergeNodePair (sLast as) (sHead bs)+ case mergeNodes $ sInit as <> S.singleton merged <> sTail bs of+ Left single -> return single+ Right many -> return $ Node aStart (aStart + aLen + bLen) many+mergeNodePair _ _ = Nothing++leaves :: SequenceTree a -> [(Int, Int, a)]+leaves (Leaf st len a) = [(st, len, a)]+leaves (Node _ _ cs) = concat $ leaves <$> cs
+ tests/Main.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Data.Monoid ((<>))+import qualified Data.Text as T+import Test.Tasty as T+import Test.Tasty.QuickCheck as T+-- For Arbitrary instance for Text+import Data.Text.Arbitrary ()+import qualified Data.Text as Text++import Data.Text.Markup++arbitraryText :: Gen T.Text+arbitraryText = T.pack <$> listOf (elements $ ' ':['a'..'z']<>['0'..'9'])++propertyTests :: T.TestTree+propertyTests = T.testGroup "Markup"+ -- Markup with no markings shall preserve the original text in one+ -- chunk.+ [ testProperty "no marking" $ property $ \t ->+ (fromMarkup $ toMarkup t ()) == [(t, ())]++ , testProperty "text preservation" $ property $ do+ txt <- arbitrary+ start <- arbitrary+ len <- arbitrary+ let m1 = markRegion start len 2 m0+ m0 :: Markup Int+ m0 = toMarkup txt 1+ return $ counterexample (show (txt, start, len, m1)) $+ (Text.concat $ fst <$> fromMarkup m1) == txt++ -- A no-op marking on a valid range is ignored.+ , testProperty "no-op marking 1" $ property $ do+ txt <- arbitrary+ -- Generate a no-op edit: it starts and ends outside the text+ -- range.+ start <- arbitrary `suchThat` (\s -> (s < 0) ||+ (s >= Text.length txt))+ len <- arbitrary `suchThat` (\l -> (l >= 0))+ return $ counterexample (show (txt, start, len)) $+ let m1 = markRegion start len 1 m0+ m0 :: Markup Int+ m0 = toMarkup txt 1+ in m0 == m1++ -- A marking that is outside the text range shall have no effect.+ , testProperty "no-op marking 2" $ property $ do+ txt <- arbitrary+ -- Generate a no-op edit: it starts and ends outside the text+ -- range.+ start <- arbitrary `suchThat` (\s -> (s < 0) ||+ (s >= Text.length txt))+ len <- arbitrary `suchThat` (\l -> (l >= 0) &&+ ((start < 0 && start + l < 0) ||+ (start >= Text.length txt)))+ return $ counterexample (show (txt, start, len)) $+ let m1 = markRegion start len 2 m0+ m0 :: Markup Int+ m0 = toMarkup txt 1+ in m0 == m1++ -- Adjancent markings are merged.+ , testProperty "merged marking" $ property $ do+ txt <- arbitrary+ -- Generate the first range...+ r1Start <- arbitrary `suchThat` (\s -> (s >= 0))+ r1Len <- arbitrary `suchThat` (\l -> (l >= 0))+ -- then an adjacent one.+ let r2Start = r1Start + r1Len+ r2Len <- arbitrary `suchThat` (\l -> (l >= 0))++ let m1 = markRegion r1Start r1Len 2 m0+ m2 = markRegion r2Start r2Len 2 m1+ m0 :: Markup Int+ m0 = toMarkup txt 1+ m3 = markRegion r1Start (r1Len + r2Len) 2 m0+ return $ counterexample (show (txt, r1Start, r1Len, r2Len, fromMarkup m2, fromMarkup m3)) $+ fromMarkup m2 == fromMarkup m3++ -- Applying a small marking A followed by an enclosing marking B is+ -- equivalent to just applying B.+ , testProperty "containing marking" $ property $ do+ txt <- arbitraryText+ -- Generate the containing range...+ r1Start <- arbitrary `suchThat` (\s -> (s >= 0))+ r1Len <- arbitrary `suchThat` (\l -> (l >= 3))+ -- Then a contained one.+ let r2Start = r1Start + 1+ r2Len = r1Len - 1+ m0 :: Markup Int+ m0 = toMarkup txt 1+ m1 = markRegion r2Start r2Len 2 m0+ m2 = markRegion r1Start r1Len 3 m1+ m3 = markRegion r1Start r1Len 3 m0+ return $ counterexample (show (txt, (r1Start, r1Len), (r2Start, r2Len), fromMarkup m1, fromMarkup m2, fromMarkup m3)) $+ fromMarkup m2 == fromMarkup m3+ ]++main :: IO ()+main = T.defaultMain propertyTests
+ text-markup.cabal view
@@ -0,0 +1,44 @@+name: text-markup+version: 0.1+synopsis: A data structure for mapping metadata to text subsequences+license: BSD3+license-file: LICENSE+author: Jonathan Daugherty+maintainer: cygnus@foobox.com+copyright: (c) 2016 Jonathan Daugherty+category: Text+build-type: Simple+cabal-version: >=1.10+Homepage: https://github.com/jtdaugherty/text-markup/+Bug-reports: https://github.com/jtdaugherty/text-markup/issues+data-files: README.md,+ CHANGELOG.md++Source-Repository head+ type: git+ location: git://github.com/jtdaugherty/text-markup.git++library+ exposed-modules: + Data.Text.Markup++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends: base >=4.8 && <5.0,+ containers,+ text++test-suite test-markup-tests+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Main.hs+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ Build-Depends: base >= 4.8 && < 5.0,+ text-markup,+ QuickCheck <= 2.8.2,+ tasty,+ tasty-quickcheck,+ text,+ quickcheck-text