data-named 0.5.2 → 0.6.1

raw patch · 10 files changed

+610/−575 lines, 10 filesdep ~attoparsecdep ~basedep ~binaryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: attoparsec, base, binary, containers, text

API changes (from Hackage documentation)

Files

• Data/Named/Graph.hs +0/−113
• Data/Named/IOB.hs +0/−137
• Data/Named/Tree.hs +0/−155
• Text/Named/Enamex.hs +0/−164
• changelog +9/−0
• data-named.cabal +10/−6
• src/Data/Named/Graph.hs +124/−0
• src/Data/Named/IOB.hs +137/−0
• src/Data/Named/Tree.hs +166/−0
• src/Text/Named/Enamex.hs +164/−0

@@ -1,113 +0,0 @@-{-# LANGUAGE DoAndIfThenElse #-}---- | Implementation of a graph with each internal node identified by a--- unique key and each leaf represented by a position in the sentence.--module Data.Named.Graph-( Graph (..)-, mkGraph-, edges-, roots-, toForest-) where--import Prelude hiding (span)-import Data.Either (lefts, rights)-import Data.Ix (Ix, range, inRange)-import qualified Data.Set as S-import qualified Data.Map as M--import Data.Named.Tree---- | A graph over a sentence.-data Graph n w = Graph-    { bounds  :: (w, w)-    , edgeMap :: M.Map n [Either n w] }---- | Make a graph given the bounds and list of edges.-mkGraph :: (Ord n, Ix w) => (w, w) -> [(n, [Either n w])] -> Graph n w-mkGraph bs =-    Graph bs . M.fromList . map check-  where-    check (k, ks)-        | null ks =-            error "mkGraph: Left, internal node without output edges"-        | any (not . inRange bs) (rights ks) =-            error "mkGraph: Right, leaf node outside of bounds"-        | otherwise = (k, ks)---- | Get keys of adjacent nodes for the given node key.-edges :: Ord n => Graph n w -> n -> [Either n w]-edges g k = case M.lookup k (edgeMap g) of-    Nothing -> error "edges: key not in the map"-    Just v  -> v-{-# INLINE edges #-}---- | Return all graph roots (i.e. nodes with no parents).-roots :: Ord n => Graph n w -> [n]-roots g =-    let desc = S.fromList . lefts . concat . M.elems $ edgeMap g-    in  [k | k <- M.keys (edgeMap g), not (k `S.member` desc)]--generate :: Ord n => Graph n w -> Either n w -> NeTree n w-generate g (Left k) = Node (Left k) (map (generate g) (edges g k))-generate _ w        = Node w []--prune :: Ord w => NeForest n w -> NeForest n w-prune = unSpanForest . run . chop . sortForest . spanForest---- | Combine the disjoint forest with the list of words.--- Discontinuities will be patched with no trace.-addWords :: Ix w => (w, w) -> NeForest n w -> NeForest n w-addWords (p, q) [] = [Node (Right x) [] | x <- range (p, q)]-addWords (p, q) ts-    = unSpanForest . subForest-    . sortTree . fillTree-    . dummyRoot-    . spanForest $ ts-  where-    dummyRoot = Node (undefined, Span p q)-    mkLeaf k  = Node (Right k, leafSpan k) []--    fillForest = map fillTree-    fillTree (Node n []) = Node n []-    fillTree (Node (k, s) us) =-        let m = spanSet s S.\\ S.unions (map (spanSet . span) us)-        in  Node (k, s) (fillForest us ++ map mkLeaf (S.toList m))---- | Transform a graph into a disjoint forest, i.e. a forest with--- no mutually overlapping trees.--- The process is lossy, discontinuity and overlapping cannot--- be represented with the `NeForest` data type.-toForest :: (Ord n, Ix w) => Graph n w -> NeForest n w-toForest g = addWords (bounds g) . prune . map (generate g . Left) . roots $ g---- | A stateful monad for forest pruning.-newtype RanM w a = RanM { runRanM :: Maybe w -> (a, Maybe w) }--instance Monad (RanM w) where-    return x     = RanM $ \s -> (x, s)-    RanM v >>= f = RanM $ \s -> case v s of (x, s') -> runRanM (f x) s'--run :: RanM w a -> a-run act = fst (runRanM act Nothing)--contains :: Ord w => w -> RanM w Bool-contains k = RanM $ \m -> case m of-    Just x  -> (k <= x, m)-    Nothing -> (False,  m)--include :: w -> RanM w ()-include k = RanM $ \_ -> ((), Just k)--chop :: Ord w => Forest (k, Span w) -> RanM w (Forest (k, Span w))-chop [] = return []-chop (Node (k, s) ts : us) = do-    visited <- contains (end s)-    if visited then-        chop us-    else do-        as <- chop ts-        include (end s)-        bs <- chop us-        return (Node (k, s) as : bs)

@@ -1,137 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--{- |-    IOB encoding method extended to forests.--    Example:-->>> :m Data.Named.IOB Data.Named.Tree Text.Named.Enamex Data.Text.Lazy->>> let enamex = pack "<x>w1.1\\ w1.2</x> w2 <y><z>w3</z> w4</y>"-->>> putStr . drawForest . mapForest show . parseForest $ enamex-Left "x"-|-`- Right "w1.1 w1.2"-,-Right "w2"-,-Left "y"-|-+- Left "z"-|  |-|  `- Right "w3"-|-`- Right "w4"-->>> mapM_ print . encodeForest . parseForest $ enamex-IOB {word = "w1.1 w1.2", label = [B "x"]}-IOB {word = "w2", label = []}-IOB {word = "w3", label = [B "y",B "z"]}-IOB {word = "w4", label = [I "y"]}--}--module Data.Named.IOB-( IOB (..)-, Label-, Atom (..)-, encodeForest-, decodeForest-) where--import Control.Applicative ((<$>))-import Data.Maybe (fromJust)-import Data.Binary (Binary, get, put)-import Data.Named.Tree hiding (span)---- | An 'IOB' data structure consists of a word with a corresponding--- compound label.-data IOB w a = IOB-    { word  :: w-    , label :: Label a-    } deriving (Show)---- | A 'Label' consists of a list of atomic 'Atom' labels.-type Label a = [Atom a]---- | An 'Atom' is the atomic label with additional marker.-data Atom a  = B a      -- ^ Beginning marker-             | I a      -- ^ Inside marker -             deriving (Show, Eq, Ord, Functor)--instance Binary a => Binary (Atom a) where-    put (B x) = put '1' >> put x-    put (I x) = put '2' >> put x-    get = get >>= \i -> case i of-        '1' -> B <$> get-        '2' -> I <$> get-        _   -> error "Atom Binary instance: invalid code"--push :: Atom a -> IOB w a -> IOB w a-push x (IOB w xs) = IOB w (x:xs)--popMaybe :: IOB w a -> Maybe (Atom a, IOB w a)-popMaybe (IOB w (x:xs)) = Just (x, IOB w xs)-popMaybe (IOB _ [])     = Nothing--topMaybe :: IOB w a -> Maybe (Atom a)-topMaybe iob = fst <$> popMaybe iob--pop :: IOB w a -> (Atom a, IOB w a)-pop = fromJust . popMaybe---- top :: IOB w a -> Atom a--- top = fromJust . topMaybe--raw :: Atom a -> a-raw (B x) = x-raw (I x) = x---- isB :: Atom a -> Bool--- isB (B _) = True--- isB _     = False--isI :: Atom a -> Bool-isI (I _) = True-isI _     = False---- | Encode the forest with the IOB method.-encodeForest :: NeForest a w -> [IOB w a]-encodeForest [] = []-encodeForest (x:xs) = encodeTree x ++ encodeForest xs---- | Encode the tree using the IOB method.-encodeTree :: NeTree a w -> [IOB w a]--encodeTree (Node (Left _) []) =-    error "encodeTree: label node with no children"-encodeTree (Node (Left e) forest) =-    let addLayer (x:xs) = push (B e) x : map (push $ I e) xs-        addLayer []     = []-    in  addLayer (encodeForest forest)--encodeTree (Node (Right _) (_:_)) =-    error "encodeTree: word node with children"-encodeTree (Node (Right w) _) = [IOB w []]---- | Decode the forest using the IOB method.-decodeForest :: Eq a => [IOB w a] -> NeForest a w-decodeForest [] = []-decodeForest xs =-    tree : decodeForest xs'-  where-    (chunk, xs') = followTop xs-    tree = case topMaybe $ head chunk of-        Nothing -> Node (Right . word $ head chunk) []-        Just e  -> Node (Left $ raw e) (decodeForest $ map rmTop chunk)-    rmTop = snd . pop---- | Take iob elements as long as the top label doesn't change.  --- Return obtained part together with the rest of iob.-followTop :: Eq a => [IOB w a] -> ([IOB w a], [IOB w a])-followTop [] = error "followTop: empty iob"-followTop (x:xs) =-    (x:chunk, rest)-  where-    (chunk, rest) = span (cond (topMaybe x) . topMaybe) xs-    cond (Just a) (Just b) = raw a == raw b && isI b-    cond _ _ = False

@@ -1,155 +0,0 @@--- | Working with NE trees and forests.--module Data.Named.Tree-( --- * Auxiliary types-  NeTree-, NeForest---- * Span-, Span (..)-, leafSpan-, (<>)-, spanSet---- * Trees with span-, span-, spanTree-, spanForest-, unSpanTree-, unSpanForest-, sortTree-, sortForest---- * Utilities-, mapForest-, mapTree-, onLeaf-, onNode-, onEither-, onBoth-, groupForestLeaves-, groupTreeLeaves--, module Data.Tree-) where--import Prelude hiding (span)-import Data.List (sortBy, groupBy)-import Data.Either (rights)-import Data.Ord (comparing)-import Data.Ix (Ix, range)-import Data.Tree-import qualified Data.Set as S---- | A tree with a values in internal nodes and b values in leaves.-type NeTree a b   = Tree (Either a b)---- | A forest with a values in internal nodes and b values in leaves.-type NeForest a b = Forest (Either a b)---- | Map function over the leaf value.-onLeaf :: (a -> b) -> Either c a -> Either c b-onLeaf _ (Left x)  = Left x-onLeaf f (Right x) = Right (f x)-{-# INLINE onLeaf #-}---- | Map function over the internal node value.-onNode :: (a -> b) -> Either a c -> Either b c-onNode f (Left x)  = Left (f x)-onNode _ (Right x) = Right x-{-# INLINE onNode #-}---- | Map the first function over internal node value--- and the second one over leaf value.-onEither :: (a -> c) -> (b -> d) -> Either a b -> Either c d-onEither f _ (Left x)  = Left (f x)-onEither _ g (Right x) = Right (g x)-{-# INLINE onEither #-}---- | Map one function over both node and leaf values.-onBoth :: (a -> b) -> Either a a -> Either b b-onBoth f (Left x)  = Left (f x)-onBoth f (Right x) = Right (f x)-{-# INLINE onBoth #-}---- | Map function over each tree from the forest.-mapForest :: (a -> b) -> Forest a -> Forest b-mapForest = map . mapTree-{-# INLINE mapForest #-}---- | Map function over the tree.-mapTree :: (a -> b) -> Tree a -> Tree b-mapTree = fmap-{-# INLINE mapTree #-}---- | Group leaves with respect to the given equality function.-groupForestLeaves :: (b -> b -> Bool) -> NeForest a b -> NeForest a [b]-groupForestLeaves f-    = concatMap joinLeaves-    . groupBy (both isLeaf)-    . map (groupTreeLeaves f)-  where-    joinLeaves [x]  = [x]-    joinLeaves xs =-        let ys = (concat . rights) (map rootLabel xs)-        in  [Node (Right ys') [] | ys' <- groupBy f ys]-    both g x y                  = g x && g y-    isLeaf (Node (Right _) [])  = True-    isLeaf _                    = False---- | Group leaves with respect to the given equality function.-groupTreeLeaves :: (b -> b -> Bool) -> NeTree a b -> NeTree a [b]-groupTreeLeaves f (Node v xs) = Node (fmap (:[]) v) (groupForestLeaves f xs)---- | Spanning of a tree.-data Span w = Span-    { beg   :: w-    , end   :: w }-    deriving (Show, Eq, Ord)---- | Make span for a leaf node.-leafSpan :: w -> Span w-leafSpan i = Span i i---- | Minimum span overlapping both input spans.-(<>) :: Ord w => Span w -> Span w -> Span w-Span p q <> Span p' q' = Span (min p p') (max q q')-{-# INLINE (<>) #-}---- | Set of positions covered by the span.-spanSet :: Ix w => Span w -> S.Set w-spanSet s = S.fromList $ range (beg s, end s)---- | Get span of the span-annotated tree.-span :: Tree (a, Span w) -> Span w-span = snd . rootLabel---- | Annotate tree nodes with spanning info given the function--- which assignes indices to leaf nodes.-spanTree :: Ord w => Tree (Either n w) -> Tree (Either n w, Span w)-spanTree (Node (Right k) []) = Node (Right k, leafSpan k) []-spanTree (Node k ts) =-    let us = spanForest ts-        s  = foldl1 (<>) (map span us)-    in  Node (k, s) us---- | Annotate forest nodes with spanning info.-spanForest :: Ord w => Forest (Either n w) -> Forest (Either n w, Span w)-spanForest = map spanTree---- | Remove span annotations from the tree.-unSpanTree :: Tree (k, Span w) -> Tree k-unSpanTree = fmap fst---- | Remove span annotations from the forest.-unSpanForest :: Forest (k, Span w) -> Forest k-unSpanForest = map unSpanTree---- | Sort the tree with respect to spanning info.-sortTree :: Ord w => Tree (k, Span w) -> Tree (k, Span w)-sortTree (Node x ts) = Node x (sortForest ts)---- | Sort the forest with respect to spanning info.-sortForest :: Ord w => Forest (k, Span w) -> Forest (k, Span w)-sortForest = sortBy (comparing span) . map sortTree

@@ -1,164 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{- |-    Parsing text in the Enamex data format.  Each node is enclosed between-    opening and closing tags with tag name representing the label and contents-    representing children of the node.  Both leaf and label values should be-    escaped by prepending the \\ character before special >, <, \\ and space-    characters.--    Example:-->>> :m Text.Named.Enamex Data.Named.Tree Data.Text.Lazy->>> let drawIt = putStr . drawForest . mapForest show . parseForest->>> drawIt $ pack "<x>w1.1\\ w1.2</x> <y><z>w2</z> w3</y>"-Left "x"-|-`- Right "w1.1 w1.2"-,-Left "y"-|-+- Left "z"-|  |-|  `- Right "w2"-|-`- Right "w3"--}--module Text.Named.Enamex-(--- * Parsing-  parseForest-, parseEnamex---- * Printing-, showForest-, showEnamex-) where--import Control.Applicative-import Control.Monad ((<=<), when)-import Data.Monoid-import Data.Attoparsec.Text.Lazy-import Data.List (intersperse)-import Data.Function (on)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as L-import qualified Data.Named.Tree as Tr--pForest :: Parser (Tr.NeForest T.Text T.Text)-pForest = pTree `sepBy` (space *> skipSpace)--pTree :: Parser (Tr.NeTree T.Text T.Text)-pTree = pNode-    <|> pLeaf--pLeaf :: Parser (Tr.NeTree T.Text T.Text)-pLeaf = Tr.Node <$> (Right <$> pWord) <*> pure []--pNode :: Parser (Tr.NeTree T.Text T.Text)-pNode = do-    x    <- pOpenTag-    kids <- pForest-    x'   <- pCloseTag-    when (x /= x') (fail "Tag start/end mismatch")-    return $ Tr.Node (Left x) kids--pOpenTag :: Parser T.Text-pOpenTag = "<" .*> pWord <*. ">"--pCloseTag :: Parser T.Text-pCloseTag = "</" .*> pWord <*. ">"--pWord :: Parser T.Text-pWord =-    unEscape <$> scan False special-  where-    special False c =-      case c == ' ' || c == '<' || c == '>' of-        True    -> Nothing-        False   -> if c == '\\'-            then Just True-            else Just False-    special True _  = Just False---- | TODO: Use lazy text builder to avoid slowness in the pessimistic case.-unEscape :: T.Text -> T.Text-unEscape xs = x `T.append` case drop1 rest of-    Just (y, ys) -> y `T.cons` unEscape ys-    Nothing      -> ""-  where-    drop1 = T.uncons <=< return . snd <=< T.uncons-    (x, rest) = T.breakOn "\\" xs ---- | TODO: Use lazy text builder to avoid slowness in the pessimistic case.-escape :: T.Text -> T.Text-escape x = case T.uncons z of-    Nothing     -> y-    Just (c, q) -> y-        `T.append` ('\\'-        `T.cons` (c-        `T.cons` escape q))-  where-    (y, z) = T.break special x-    special c = c == ' ' || c == '<' || c == '>' || c == '\\'---- | Parse the enamex forest.-parseForest :: L.Text -> Tr.NeForest T.Text T.Text-parseForest = either error id . eitherResult . parse (pForest <* endOfInput)---- | Parse the enamex file.-parseEnamex :: L.Text -> [Tr.NeForest T.Text T.Text]-parseEnamex = map parseForest . L.lines--data Tag = Open | Close | Body---- | Function which determines between which two tag elements a space--- character should be inserted.-noSpace :: Tag -> Tag -> Bool-noSpace Open  _     = True-noSpace Body  Close = True-noSpace Close Close = True-noSpace _     _     = False---- | We define our own groupBy because the standard version from Data.List--- assumes that the predicate is transitive.-groupBy :: (a -> a -> Bool) -> [a] -> [[a]]-groupBy p (x : y : xs)-    | p x y     = join x $ groupBy p (y : xs)-    | otherwise = [x]    : groupBy p (y : xs)-  where-    join z (zs : zss) = (z : zs) : zss-    join z [] = [[z]]-groupBy _ [x] = [[x]]-groupBy _ []  = []--buildForest :: Tr.NeForest t t -> [(t, Tag)]-buildForest = concat . map buildTree--buildTree :: Tr.NeTree t t -> [(t, Tag)]-buildTree (Tr.Node (Left x) ts) = (x, Open) : buildForest ts ++ [(x, Close)]-buildTree (Tr.Node (Right x) _) = [(x, Body)]--buildStream :: [(T.Text, Tag)] -> L.Builder-buildStream-    = mconcat . intersperse " "-    . map (mconcat . map buildTag)-    . groupBy (noSpace `on` snd)--buildTag :: (T.Text, Tag) -> L.Builder-buildTag (x, tag) = case tag of-    Open    -> "<"  `mappend` y `mappend` ">"-    Close   -> "</" `mappend` y `mappend` ">"-    _       -> y-  where-    y = L.fromText (escape x)---- | Show the forest.-showForest :: Tr.NeForest T.Text T.Text -> L.Text-showForest = L.toLazyText . buildStream . buildForest---- | Show the enamex file.-showEnamex :: [Tr.NeForest T.Text T.Text] -> L.Text-showEnamex = L.toLazyText . mconcat . map (L.fromLazyText . showForest)

@@ -0,0 +1,9 @@+-*-change-log-*-++0.6.1	Jun 2016+        * Add stack.yaml+        * Add README+        * Add `Applicative` instances where needed (as a result of the `Applicative => Monad` proposal)++0.6.0	Jul 2014+	* Add `concatForestLeaves` function (inverse of `groupForestLeaves`)

@@ -1,5 +1,5 @@ name:               data-named-version:            0.5.2+version:            0.6.1 synopsis:           Data types for named entities description:     The library provides data types which can be used to represent@@ -26,13 +26,17 @@ homepage:           https://github.com/kawu/data-named build-type:         Simple +extra-source-files: changelog+ library+    hs-source-dirs: src+     build-depends:-        base >= 4 && < 5-      , containers-      , text-      , attoparsec-      , binary+        base                >= 4.8      && < 5+      , containers          >= 0.5      && < 0.6+      , text                >= 1.1      && < 1.3+      , attoparsec          >= 0.12     && < 0.14+      , binary              >= 0.7      && < 0.9      exposed-modules:         Data.Named.Tree

@@ -0,0 +1,124 @@+{-# LANGUAGE DoAndIfThenElse    #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}++-- | Implementation of a graph with each internal node identified by a+-- unique key and each leaf represented by a position in the sentence.++module Data.Named.Graph+( Graph (..)+, mkGraph+, edges+, roots+, toForest+) where++import           Data.Either     (lefts, rights)+import           Data.Ix         (Ix, inRange, range)+import qualified Data.Map        as M+import qualified Data.Set        as S+import           Prelude         hiding (span)++import           Data.Named.Tree++-- | A graph over a sentence.+data Graph n w = Graph+    { bounds  :: (w, w)+    , edgeMap :: M.Map n [Either n w] }++-- | Make a graph given the bounds and list of edges.+mkGraph :: (Ord n, Ix w) => (w, w) -> [(n, [Either n w])] -> Graph n w+mkGraph bs =+    Graph bs . M.fromList . map check+  where+    check (k, ks)+        | null ks =+            error "mkGraph: Left, internal node without output edges"+        | any (not . inRange bs) (rights ks) =+            error "mkGraph: Right, leaf node outside of bounds"+        | otherwise = (k, ks)++-- | Get keys of adjacent nodes for the given node key.+edges :: Ord n => Graph n w -> n -> [Either n w]+edges g k = case M.lookup k (edgeMap g) of+    Nothing -> error "edges: key not in the map"+    Just v  -> v+{-# INLINE edges #-}++-- | Return all graph roots (i.e. nodes with no parents).+roots :: Ord n => Graph n w -> [n]+roots g =+    let desc = S.fromList . lefts . concat . M.elems $ edgeMap g+    in  [k | k <- M.keys (edgeMap g), not (k `S.member` desc)]++generate :: Ord n => Graph n w -> Either n w -> NeTree n w+generate g (Left k) = Node (Left k) (map (generate g) (edges g k))+generate _ w        = Node w []++prune :: Ord w => NeForest n w -> NeForest n w+prune = unSpanForest . run . chop . sortForest . spanForest++-- | Combine the disjoint forest with the list of words.+-- Discontinuities will be patched with no trace.+addWords :: Ix w => (w, w) -> NeForest n w -> NeForest n w+addWords (p, q) [] = [Node (Right x) [] | x <- range (p, q)]+addWords (p, q) ts+    = unSpanForest . subForest+    . sortTree . fillTree+    . dummyRoot+    . spanForest $ ts+  where+    dummyRoot = Node (undefined, Span p q)+    mkLeaf k  = Node (Right k, leafSpan k) []++    fillForest = map fillTree+    fillTree (Node n []) = Node n []+    fillTree (Node (k, s) us) =+        let m = spanSet s S.\\ S.unions (map (spanSet . span) us)+        in  Node (k, s) (fillForest us ++ map mkLeaf (S.toList m))++-- | Transform a graph into a disjoint forest, i.e. a forest with+-- no mutually overlapping trees.+-- The process is lossy, discontinuity and overlapping cannot+-- be represented with the `NeForest` data type.+toForest :: (Ord n, Ix w) => Graph n w -> NeForest n w+toForest g = addWords (bounds g) . prune . map (generate g . Left) . roots $ g++-- | A stateful monad for forest pruning.+newtype RanM w a = RanM { runRanM :: Maybe w -> (a, Maybe w) }++deriving instance Functor (RanM w)++instance Applicative (RanM w) where+  pure x = RanM $ \s -> (x, s)+  RanM v <*> RanM w = RanM $+    \s -> case v s of+      (f, s') -> case w s' of+        (x, s'') -> (f x, s'')++instance Monad (RanM w) where+    return x     = RanM $ \s -> (x, s)+    RanM v >>= f = RanM $ \s -> case v s of (x, s') -> runRanM (f x) s'++run :: RanM w a -> a+run act = fst (runRanM act Nothing)++contains :: Ord w => w -> RanM w Bool+contains k = RanM $ \m -> case m of+    Just x  -> (k <= x, m)+    Nothing -> (False,  m)++include :: w -> RanM w ()+include k = RanM $ \_ -> ((), Just k)++chop :: Ord w => Forest (k, Span w) -> RanM w (Forest (k, Span w))+chop [] = return []+chop (Node (k, s) ts : us) = do+    visited <- contains (end s)+    if visited then+        chop us+    else do+        as <- chop ts+        include (end s)+        bs <- chop us+        return (Node (k, s) as : bs)

@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveFunctor #-}++{- |+    IOB encoding method extended to forests.++    Example:++>>> :m Data.Named.IOB Data.Named.Tree Text.Named.Enamex Data.Text.Lazy+>>> let enamex = pack "<x>w1.1\\ w1.2</x> w2 <y><z>w3</z> w4</y>"++>>> putStr . drawForest . mapForest show . parseForest $ enamex+Left "x"+|+`- Right "w1.1 w1.2"+,+Right "w2"+,+Left "y"+|++- Left "z"+|  |+|  `- Right "w3"+|+`- Right "w4"++>>> mapM_ print . encodeForest . parseForest $ enamex+IOB {word = "w1.1 w1.2", label = [B "x"]}+IOB {word = "w2", label = []}+IOB {word = "w3", label = [B "y",B "z"]}+IOB {word = "w4", label = [I "y"]}+-}++module Data.Named.IOB+( IOB (..)+, Label+, Atom (..)+, encodeForest+, decodeForest+) where++import Control.Applicative ((<$>))+import Data.Maybe (fromJust)+import Data.Binary (Binary, get, put)+import Data.Named.Tree hiding (span)++-- | An 'IOB' data structure consists of a word with a corresponding+-- compound label.+data IOB w a = IOB+    { word  :: w+    , label :: Label a+    } deriving (Show)++-- | A 'Label' consists of a list of atomic 'Atom' labels.+type Label a = [Atom a]++-- | An 'Atom' is the atomic label with additional marker.+data Atom a  = B a      -- ^ Beginning marker+             | I a      -- ^ Inside marker +             deriving (Show, Eq, Ord, Functor)++instance Binary a => Binary (Atom a) where+    put (B x) = put '1' >> put x+    put (I x) = put '2' >> put x+    get = get >>= \i -> case i of+        '1' -> B <$> get+        '2' -> I <$> get+        _   -> error "Atom Binary instance: invalid code"++push :: Atom a -> IOB w a -> IOB w a+push x (IOB w xs) = IOB w (x:xs)++popMaybe :: IOB w a -> Maybe (Atom a, IOB w a)+popMaybe (IOB w (x:xs)) = Just (x, IOB w xs)+popMaybe (IOB _ [])     = Nothing++topMaybe :: IOB w a -> Maybe (Atom a)+topMaybe iob = fst <$> popMaybe iob++pop :: IOB w a -> (Atom a, IOB w a)+pop = fromJust . popMaybe++-- top :: IOB w a -> Atom a+-- top = fromJust . topMaybe++raw :: Atom a -> a+raw (B x) = x+raw (I x) = x++-- isB :: Atom a -> Bool+-- isB (B _) = True+-- isB _     = False++isI :: Atom a -> Bool+isI (I _) = True+isI _     = False++-- | Encode the forest with the IOB method.+encodeForest :: NeForest a w -> [IOB w a]+encodeForest [] = []+encodeForest (x:xs) = encodeTree x ++ encodeForest xs++-- | Encode the tree using the IOB method.+encodeTree :: NeTree a w -> [IOB w a]++encodeTree (Node (Left _) []) =+    error "encodeTree: label node with no children"+encodeTree (Node (Left e) forest) =+    let addLayer (x:xs) = push (B e) x : map (push $ I e) xs+        addLayer []     = []+    in  addLayer (encodeForest forest)++encodeTree (Node (Right _) (_:_)) =+    error "encodeTree: word node with children"+encodeTree (Node (Right w) _) = [IOB w []]++-- | Decode the forest using the IOB method.+decodeForest :: Eq a => [IOB w a] -> NeForest a w+decodeForest [] = []+decodeForest xs =+    tree : decodeForest xs'+  where+    (chunk, xs') = followTop xs+    tree = case topMaybe $ head chunk of+        Nothing -> Node (Right . word $ head chunk) []+        Just e  -> Node (Left $ raw e) (decodeForest $ map rmTop chunk)+    rmTop = snd . pop++-- | Take iob elements as long as the top label doesn't change.  +-- Return obtained part together with the rest of iob.+followTop :: Eq a => [IOB w a] -> ([IOB w a], [IOB w a])+followTop [] = error "followTop: empty iob"+followTop (x:xs) =+    (x:chunk, rest)+  where+    (chunk, rest) = span (cond (topMaybe x) . topMaybe) xs+    cond (Just a) (Just b) = raw a == raw b && isI b+    cond _ _ = False

@@ -0,0 +1,166 @@+-- | Working with NE trees and forests.++module Data.Named.Tree+( +-- * Auxiliary types+  NeTree+, NeForest++-- * Span+, Span (..)+, leafSpan+, (<>)+, spanSet++-- * Trees with span+, span+, spanTree+, spanForest+, unSpanTree+, unSpanForest+, sortTree+, sortForest++-- * Utilities+, mapForest+, mapTree+, onLeaf+, onNode+, onEither+, onBoth+, groupForestLeaves+, groupTreeLeaves+, concatForestLeaves+, concatTreeLeaves++, module Data.Tree+) where++import Prelude hiding (span)+import Data.List (sortBy, groupBy)+import Data.Either (rights)+import Data.Ord (comparing)+import Data.Ix (Ix, range)+import Data.Tree+import qualified Data.Set as S++-- | A tree with a values in internal nodes and b values in leaves.+type NeTree a b   = Tree (Either a b)++-- | A forest with a values in internal nodes and b values in leaves.+type NeForest a b = Forest (Either a b)++-- | Map function over the leaf value.+onLeaf :: (a -> b) -> Either c a -> Either c b+onLeaf _ (Left x)  = Left x+onLeaf f (Right x) = Right (f x)+{-# INLINE onLeaf #-}++-- | Map function over the internal node value.+onNode :: (a -> b) -> Either a c -> Either b c+onNode f (Left x)  = Left (f x)+onNode _ (Right x) = Right x+{-# INLINE onNode #-}++-- | Map the first function over internal node value+-- and the second one over leaf value.+onEither :: (a -> c) -> (b -> d) -> Either a b -> Either c d+onEither f _ (Left x)  = Left (f x)+onEither _ g (Right x) = Right (g x)+{-# INLINE onEither #-}++-- | Map one function over both node and leaf values.+onBoth :: (a -> b) -> Either a a -> Either b b+onBoth f (Left x)  = Left (f x)+onBoth f (Right x) = Right (f x)+{-# INLINE onBoth #-}++-- | Map function over each tree from the forest.+mapForest :: (a -> b) -> Forest a -> Forest b+mapForest = map . mapTree+{-# INLINE mapForest #-}++-- | Map function over the tree.+mapTree :: (a -> b) -> Tree a -> Tree b+mapTree = fmap+{-# INLINE mapTree #-}++-- | Group leaves with respect to the given equality function.+groupForestLeaves :: (b -> b -> Bool) -> NeForest a b -> NeForest a [b]+groupForestLeaves f+    = concatMap joinLeaves+    . groupBy (both isLeaf)+    . map (groupTreeLeaves f)+  where+    joinLeaves [x]  = [x]+    joinLeaves xs =+        let ys = (concat . rights) (map rootLabel xs)+        in  [Node (Right ys') [] | ys' <- groupBy f ys]+    both g x y                  = g x && g y+    isLeaf (Node (Right _) [])  = True+    isLeaf _                    = False++-- | Group leaves with respect to the given equality function.+groupTreeLeaves :: (b -> b -> Bool) -> NeTree a b -> NeTree a [b]+groupTreeLeaves f (Node v xs) = Node (fmap (:[]) v) (groupForestLeaves f xs)++-- | Group leaves with respect to the given equality function.+concatForestLeaves ::  NeForest a [b] -> NeForest a b+concatForestLeaves = concatMap concatTreeLeaves++-- | Group leaves with respect to the given equality function.+concatTreeLeaves :: NeTree a [b] -> NeForest a b+concatTreeLeaves (Node (Left x) xs)  = [Node (Left x) (concatForestLeaves xs)]+concatTreeLeaves (Node (Right xs) _) = [Node (Right x) [] | x <- xs]++-- | Spanning of a tree.+data Span w = Span+    { beg   :: w+    , end   :: w }+    deriving (Show, Eq, Ord)++-- | Make span for a leaf node.+leafSpan :: w -> Span w+leafSpan i = Span i i++-- | Minimum span overlapping both input spans.+(<>) :: Ord w => Span w -> Span w -> Span w+Span p q <> Span p' q' = Span (min p p') (max q q')+{-# INLINE (<>) #-}++-- | Set of positions covered by the span.+spanSet :: Ix w => Span w -> S.Set w+spanSet s = S.fromList $ range (beg s, end s)++-- | Get span of the span-annotated tree.+span :: Tree (a, Span w) -> Span w+span = snd . rootLabel++-- | Annotate tree nodes with spanning info given the function+-- which assignes indices to leaf nodes.+spanTree :: Ord w => Tree (Either n w) -> Tree (Either n w, Span w)+spanTree (Node (Right k) []) = Node (Right k, leafSpan k) []+spanTree (Node k ts) =+    let us = spanForest ts+        s  = foldl1 (<>) (map span us)+    in  Node (k, s) us++-- | Annotate forest nodes with spanning info.+spanForest :: Ord w => Forest (Either n w) -> Forest (Either n w, Span w)+spanForest = map spanTree++-- | Remove span annotations from the tree.+unSpanTree :: Tree (k, Span w) -> Tree k+unSpanTree = fmap fst++-- | Remove span annotations from the forest.+unSpanForest :: Forest (k, Span w) -> Forest k+unSpanForest = map unSpanTree++-- | Sort the tree with respect to spanning info.+sortTree :: Ord w => Tree (k, Span w) -> Tree (k, Span w)+sortTree (Node x ts) = Node x (sortForest ts)++-- | Sort the forest with respect to spanning info.+sortForest :: Ord w => Forest (k, Span w) -> Forest (k, Span w)+sortForest = sortBy (comparing span) . map sortTree

@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+    Parsing text in the Enamex data format.  Each node is enclosed between+    opening and closing tags with tag name representing the label and contents+    representing children of the node.  Both leaf and label values should be+    escaped by prepending the \\ character before special >, <, \\ and space+    characters.++    Example:++>>> :m Text.Named.Enamex Data.Named.Tree Data.Text.Lazy+>>> let drawIt = putStr . drawForest . mapForest show . parseForest+>>> drawIt $ pack "<x>w1.1\\ w1.2</x> <y><z>w2</z> w3</y>"+Left "x"+|+`- Right "w1.1 w1.2"+,+Left "y"+|++- Left "z"+|  |+|  `- Right "w2"+|+`- Right "w3"+-}++module Text.Named.Enamex+(+-- * Parsing+  parseForest+, parseEnamex++-- * Printing+, showForest+, showEnamex+) where++import           Control.Applicative+import           Control.Monad             (when, (<=<))+-- import Data.Monoid+import           Data.Attoparsec.Text.Lazy+import           Data.Function             (on)+import           Data.List                 (intersperse)+import qualified Data.Named.Tree           as Tr+import qualified Data.Text                 as T+import qualified Data.Text.Lazy            as L+import qualified Data.Text.Lazy.Builder    as L++pForest :: Parser (Tr.NeForest T.Text T.Text)+pForest = pTree `sepBy` (space *> skipSpace)++pTree :: Parser (Tr.NeTree T.Text T.Text)+pTree = pNode+    <|> pLeaf++pLeaf :: Parser (Tr.NeTree T.Text T.Text)+pLeaf = Tr.Node <$> (Right <$> pWord) <*> pure []++pNode :: Parser (Tr.NeTree T.Text T.Text)+pNode = do+    x    <- pOpenTag+    kids <- pForest+    x'   <- pCloseTag+    when (x /= x') (fail "Tag start/end mismatch")+    return $ Tr.Node (Left x) kids++pOpenTag :: Parser T.Text+pOpenTag = "<" *> pWord <* ">"++pCloseTag :: Parser T.Text+pCloseTag = "</" *> pWord <* ">"++pWord :: Parser T.Text+pWord =+    unEscape <$> scan False special+  where+    special False c =+      case c == ' ' || c == '<' || c == '>' of+        True    -> Nothing+        False   -> if c == '\\'+            then Just True+            else Just False+    special True _  = Just False++-- | TODO: Use lazy text builder to avoid slowness in the pessimistic case.+unEscape :: T.Text -> T.Text+unEscape xs = x `T.append` case drop1 rest of+    Just (y, ys) -> y `T.cons` unEscape ys+    Nothing      -> ""+  where+    drop1 = T.uncons <=< return . snd <=< T.uncons+    (x, rest) = T.breakOn "\\" xs++-- | TODO: Use lazy text builder to avoid slowness in the pessimistic case.+escape :: T.Text -> T.Text+escape x = case T.uncons z of+    Nothing     -> y+    Just (c, q) -> y+        `T.append` ('\\'+        `T.cons` (c+        `T.cons` escape q))+  where+    (y, z) = T.break special x+    special c = c == ' ' || c == '<' || c == '>' || c == '\\'++-- | Parse the enamex forest.+parseForest :: L.Text -> Tr.NeForest T.Text T.Text+parseForest = either error id . eitherResult . parse (pForest <* endOfInput)++-- | Parse the enamex file.+parseEnamex :: L.Text -> [Tr.NeForest T.Text T.Text]+parseEnamex = map parseForest . L.lines++data Tag = Open | Close | Body++-- | Function which determines between which two tag elements a space+-- character should be inserted.+noSpace :: Tag -> Tag -> Bool+noSpace Open  _     = True+noSpace Body  Close = True+noSpace Close Close = True+noSpace _     _     = False++-- | We define our own groupBy because the standard version from Data.List+-- assumes that the predicate is transitive.+groupBy :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy p (x : y : xs)+    | p x y     = join x $ groupBy p (y : xs)+    | otherwise = [x]    : groupBy p (y : xs)+  where+    join z (zs : zss) = (z : zs) : zss+    join z [] = [[z]]+groupBy _ [x] = [[x]]+groupBy _ []  = []++buildForest :: Tr.NeForest t t -> [(t, Tag)]+buildForest = concat . map buildTree++buildTree :: Tr.NeTree t t -> [(t, Tag)]+buildTree (Tr.Node (Left x) ts) = (x, Open) : buildForest ts ++ [(x, Close)]+buildTree (Tr.Node (Right x) _) = [(x, Body)]++buildStream :: [(T.Text, Tag)] -> L.Builder+buildStream+    = mconcat . intersperse " "+    . map (mconcat . map buildTag)+    . groupBy (noSpace `on` snd)++buildTag :: (T.Text, Tag) -> L.Builder+buildTag (x, tag) = case tag of+    Open    -> "<"  `mappend` y `mappend` ">"+    Close   -> "</" `mappend` y `mappend` ">"+    _       -> y+  where+    y = L.fromText (escape x)++-- | Show the forest.+showForest :: Tr.NeForest T.Text T.Text -> L.Text+showForest = L.toLazyText . buildStream . buildForest++-- | Show the enamex file.+showEnamex :: [Tr.NeForest T.Text T.Text] -> L.Text+showEnamex = L.toLazyText . mconcat . map (L.fromLazyText . showForest)