data-named 0.3.0 → 0.4.0

raw patch · 5 files changed

+181/−88 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Named/Graph.hs +16/−17
• Data/Named/IOB.hs +7/−8
• Data/Named/Tree.hs +62/−29
• Text/Named/Enamex.hs +95/−33
• data-named.cabal +1/−1

@@ -16,7 +16,6 @@ import Data.Ix (Ix, range, inRange) import qualified Data.Set as S import qualified Data.Map as M-import qualified Data.Tree as T  import Data.Named.Tree @@ -50,35 +49,35 @@     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 -> T.Tree (Either n w)-generate g (Left k) = T.Node (Left k) (map (generate g) (edges g k))-generate _ w        = T.Node w []+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 => T.Forest (Either n w) -> T.Forest (Either n 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) -> T.Forest (Either n w) -> T.Forest (Either n w)-addWords (p, q) [] = [T.Node (Right x) [] | x <- range (p, q)]+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 . T.subForest+    = unSpanForest . subForest     . sortTree . fillTree     . dummyRoot     . spanForest $ ts   where-    dummyRoot = T.Node (undefined, Span p q)-    mkLeaf k  = T.Node (Right k, leafSpan k) []+    dummyRoot = Node (undefined, Span p q)+    mkLeaf k  = Node (Right k, leafSpan k) []      fillForest = map fillTree-    fillTree (T.Node n []) = T.Node n []-    fillTree (T.Node (k, s) us) =+    fillTree (Node n []) = Node n []+    fillTree (Node (k, s) us) =         let m = spanSet s S.\\ S.unions (map (spanSet . span) us)-        in  T.Node (k, s) (fillForest us ++ map mkLeaf (S.toList m))+        in  Node (k, s) (fillForest us ++ map mkLeaf (S.toList m))  -- | Transform graph into a disjoint forest, i.e. with no mutually -- overlapping trees.-toForest :: (Ord n, Ix w) => Graph n w -> T.Forest (Either n w)+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.@@ -99,9 +98,9 @@ include :: w -> RanM w () include k = RanM $ \_ -> ((), Just k) -chop :: Ord w => T.Forest (k, Span w) -> RanM w (T.Forest (k, Span w))+chop :: Ord w => Forest (k, Span w) -> RanM w (Forest (k, Span w)) chop [] = return []-chop (T.Node (k, s) ts : us) = do+chop (Node (k, s) ts : us) = do     visited <- contains (end s)     if visited then         chop us@@ -109,4 +108,4 @@         as <- chop ts         include (end s)         bs <- chop us-        return (T.Node (k, s) as : bs)+        return (Node (k, s) as : bs)

@@ -3,11 +3,10 @@      Example: ->>> :m Data.Tree Data.Text Text.Named.Enamex Data.Named.IOB+>>> :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>"->>> let parseIt = fmap (mapTwo id id . fmap unpack) . parseForest ->>> putStr . drawForest . fmap (fmap show) . parseIt $ enamex+>>> putStr . drawForest . mapForest show . parseForest $ enamex Left "x" | `- Right "w1.1 w1.2"@@ -22,7 +21,7 @@ | `- Right "w4" ->>> mapM_ print . encodeForest . parseIt $ enamex+>>> 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"]}@@ -39,7 +38,7 @@  import Control.Applicative ((<$>)) import Data.Maybe (fromJust)-import Data.Tree+import Data.Named.Tree hiding (span)  -- | An 'IOB' data structure consists of a word with a corresponding -- compound label.@@ -85,12 +84,12 @@ isI _     = False  -- | Encode the forest with the IOB method.-encodeForest :: Forest (Either a w) -> [IOB w a]+encodeForest :: NeForest a w -> [IOB w a] encodeForest [] = [] encodeForest (x:xs) = encodeTree x ++ encodeForest xs  -- | Encode the tree using the IOB method.-encodeTree :: Tree (Either a w) -> [IOB w a]+encodeTree :: NeTree a w -> [IOB w a]  encodeTree (Node (Left _) []) =     error "encodeTree: label node with no children"@@ -104,7 +103,7 @@ encodeTree (Node (Right w) _) = [IOB w []]  -- | Decode the forest using the IOB method.-decodeForest :: Eq a => [IOB w a] -> Forest (Either a w)+decodeForest :: Eq a => [IOB w a] -> NeForest a w decodeForest [] = [] decodeForest xs =     tree : decodeForest xs'

@@ -2,11 +2,12 @@  module Data.Named.Tree ( --- -- * Combine with words---   addWords+-- * Auxiliary types+  NeTree+, NeForest  -- * Span-  Span (..)+, Span (..) , leafSpan , (<>) , spanSet@@ -21,32 +22,64 @@ , sortForest  -- * Utilities-, mapLeaves-, mapNodes-, mapTrees+, mapForest+, mapTree+, onLeaf+, onNode+, onEither+, onBoth++, module Data.Tree ) where  import Prelude hiding (span) import Data.List (sortBy) import Data.Ord (comparing) import Data.Ix (Ix, range)-import qualified Data.Tree as T+import Data.Tree import qualified Data.Set as S --- | Map function over tree leaves.-mapLeaves :: (a -> b) -> T.Tree (Either c a) -> T.Tree (Either c b)-mapLeaves f (T.Node (Left x) ts) = T.Node (Left x) (map (mapLeaves f) ts)-mapLeaves f (T.Node (Right x) _) = T.Node (Right $ f x) []+-- | A tree with a values in internal nodes and b values in leaves.+type NeTree a b   = Tree (Either a b) --- | Map function over tree internal nodes.-mapNodes :: (a -> b) -> T.Tree (Either a c) -> T.Tree (Either b c)-mapNodes f (T.Node (Left x) ts) = T.Node (Left $ f x) (map (mapNodes f) ts)-mapNodes _ (T.Node (Right x) _) = T.Node (Right x) []+-- | 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.-mapTrees :: (a -> b) -> T.Forest a -> T.Forest b-mapTrees f = map (fmap f)+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 #-}+ -- | Spanning of a tree. data Span w = Span     { beg   :: w@@ -67,34 +100,34 @@ spanSet s = S.fromList $ range (beg s, end s)  -- | Get span of the span-annotated tree.-span :: T.Tree (a, Span w) -> Span w-span = snd . T.rootLabel+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 => T.Tree (Either n w) -> T.Tree (Either n w, Span w)-spanTree (T.Node (Right k) []) = T.Node (Right k, leafSpan k) []-spanTree (T.Node k ts) =+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  T.Node (k, s) us+    in  Node (k, s) us  -- | Annotate forest nodes with spanning info.-spanForest :: Ord w => T.Forest (Either n w) -> T.Forest (Either n w, Span w)+spanForest :: Ord w => Forest (Either n w) -> Forest (Either n w, Span w) spanForest = map spanTree  -- | Remove span annotations from the tree.-unSpanTree :: T.Tree (k, Span w) -> T.Tree k+unSpanTree :: Tree (k, Span w) -> Tree k unSpanTree = fmap fst  -- | Remove span annotations from the forest.-unSpanForest :: T.Forest (k, Span w) -> T.Forest k+unSpanForest :: Forest (k, Span w) -> Forest k unSpanForest = map unSpanTree  -- | Sort the tree with respect to spanning info.-sortTree :: Ord w => T.Tree (k, Span w) -> T.Tree (k, Span w)-sortTree (T.Node x ts) = T.Node x (sortForest ts)+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 => T.Forest (k, Span w) -> T.Forest (k, Span w)+sortForest :: Ord w => Forest (k, Span w) -> Forest (k, Span w) sortForest = sortBy (comparing span) . map sortTree

@@ -9,62 +9,61 @@      Example: ->>> :m Data.Tree Data.Text Text.Named.Enamex->>> let drawIt = putStr . drawForest . fmap (fmap unpack) . parseForest+>>> :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>"-x+Left "x" |-`- w1.1 w1.2+`- Right "w1.1 w1.2" ,-y+Left "y" |-+- z++- Left "z" |  |-|  `- w2+|  `- Right "w2" |-`- w3+`- Right "w3" -}  module Text.Named.Enamex-( parseForest+(+-- * Parsing+  parseForest , parseEnamex-, mapTwo++-- * Printing+, showForest+, showEnamex ) where  import Control.Applicative-import Control.Monad-import Data.Attoparsec.Text+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.Tree as Tree---type Tree = Tree.Tree T.Text-type Forest = Tree.Forest T.Text---- | Map the first function over internal nodes--- and the second one over leaves.-mapTwo :: (a -> b) -> (a -> c) -> Tree.Tree a -> Tree.Tree (Either b c)-mapTwo _ g (Tree.Node x [])   = Tree.Node (Right $ g x) []-mapTwo f g (Tree.Node x kids) = Tree.Node (Left $ f x) (map (mapTwo f g) kids)+import qualified Data.Text.Lazy.Builder as L+import qualified Data.Named.Tree as Tr -pForest :: Parser Forest+pForest :: Parser (Tr.NeForest T.Text T.Text) pForest = pTree `sepBy` (space *> skipSpace) -pTree :: Parser Tree+pTree :: Parser (Tr.NeTree T.Text T.Text) pTree = pNode     <|> pLeaf -pLeaf :: Parser Tree-pLeaf = Tree.Node <$> pWord <*> pure []+pLeaf :: Parser (Tr.NeTree T.Text T.Text)+pLeaf = Tr.Node <$> (Right <$> pWord) <*> pure [] -pNode :: Parser Tree+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 $ Tree.Node x kids+    return $ Tr.Node (Left x) kids  pOpenTag :: Parser T.Text pOpenTag = "<" .*> pWord <*. ">"@@ -93,10 +92,73 @@     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 :: T.Text -> Forest-parseForest = either error id . parseOnly (pForest <* endOfInput)+parseForest :: L.Text -> Tr.NeForest T.Text T.Text+parseForest = either error id . eitherResult . parse (pForest <* endOfInput)  -- | Parse the enamex file.-parseEnamex :: L.Text -> [Forest]-parseEnamex = map (parseForest . L.toStrict) . L.lines+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)

@@ -1,5 +1,5 @@ name:               data-named-version:            0.3.0+version:            0.4.0 synopsis:           Data types for named entities description:     The library provides data types which can be used to represent