packages feed

data-named 0.5.2 → 0.6.2

raw patch · 11 files changed

Files

− Data/Named/Graph.hs 
@@ -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)
− Data/Named/IOB.hs 
@@ -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
− Data/Named/Tree.hs 
@@ -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
+ README.md view
@@ -0,0 +1,18 @@+Data-named+==========++The library provides data types which can be used to represent forest+structures with labels stored in internal nodes and words kept in leaves.+In particular, those types are well suited for representing the layer of named+entities (NEs).++The IOB method is implemented in the `Data.Named.IOB` module and can be used to+translate between a forest of entities and a sequence of compound IOB labels.+This method can be used together with a sequence classifier to indirectly model+forest structures.++The `Data.Named.Graph` module can be used to represent more general, graph+structures of entities.  The module provides also a lossy conversion from a DAG+to a disjoint forest of entities.++[![Build Status](https://travis-ci.org/kawu/data-named.svg)](https://travis-ci.org/kawu/data-named)
− Text/Named/Enamex.hs 
@@ -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)
data-named.cabal view
@@ -1,47 +1,46 @@-name:               data-named-version:            0.5.2-synopsis:           Data types for named entities-description:-    The library provides data types which can be used to represent-    forest structures with labels stored in internal nodes and-    words kept in leaves.  In particular, those types are well suited-    for representing the layer of named entities (NEs).-    .-    The IOB method is implemented in the Data.Named.IOB module and can-    be used to translate between a forest of entities and a sequence-    of compound IOB labels.  This method can be used together with a-    sequence classifier to indirectly model forest structures.-    .-    The Data.Named.Graph module can be used to represent more general,-    graph structures of entities.  The module provides also a lossy-    conversion from a DAG to a disjoint forest of entities.-license:            BSD3-license-file:       LICENSE-cabal-version:      >= 1.6-copyright:          Copyright (c) 2012 IPI PAN-author:             Jakub Waszczuk-maintainer:         waszczuk.kuba@gmail.com-stability:          experimental-category:           Natural Language Processing-homepage:           https://github.com/kawu/data-named-build-type:         Simple--library-    build-depends:-        base >= 4 && < 5-      , containers-      , text-      , attoparsec-      , binary+cabal-version: 1.12 -    exposed-modules:-        Data.Named.Tree-      , Data.Named.Graph-      , Data.Named.IOB-      , Text.Named.Enamex+-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 23b5a0797e6af3d7628e695ce2f4d21b4d0ce1c515c5a9419551ccca0db6834e -    ghc-options: -Wall+name:           data-named+version:        0.6.2+synopsis:       Data types for named entities+description:    Please see the README on GitHub at <https://github.com/kawu/data-named#readme>+category:       Natural Language Processing+homepage:       https://github.com/kawu/data-named#readme+bug-reports:    https://github.com/kawu/data-named/issues+author:         Jakub Waszczuk+maintainer:     waszczuk.kuba@gmail.com+copyright:      2012-2019 IPI PAN, Jakub Waszczuk+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md  source-repository head-    type: git-    location: git://github.com/kawu/data-named.git+  type: git+  location: https://github.com/kawu/data-named++library+  exposed-modules:+      Data.Named.DAG+      Data.Named.Graph+      Data.Named.IOB+      Data.Named.Tree+      Text.Named.Enamex+  other-modules:+      Paths_data_named+  hs-source-dirs:+      src+  build-depends:+      attoparsec >=0.12 && <0.14+    , base >=4.8 && <5+    , binary >=0.7 && <0.9+    , containers >=0.5 && <0.7+    , text >=1.1 && <1.3+  default-language: Haskell2010
+ src/Data/Named/DAG.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE RecordWildCards #-}++-- | Implementation of a DAG with each node identified by a unique key.++module Data.Named.DAG+( +-- * DAG+  DAG (..)+, mkDAG+, unDAG++-- * Access by key+, vertex+, node+, edges+, maybeNode+, maybeEdges++-- * Access by vertex (index)+, nodeV+, keyV+, edgesV++-- * Conversion to forest+, toForest+, toForestBy++-- * Utilities+, roots+, leaves+) where++import Control.Applicative ((<$>))+import Data.List (sortBy, minimumBy)+import qualified Data.Set as S+import qualified Data.Tree as T+import qualified Data.Graph as G++-- | A directed acyclic graph.+data DAG k v = DAG {+    -- | The underlying graph.+    graph       :: G.Graph,+    -- | Map vertex identifier to a node description.+    nodeDesc    :: G.Vertex -> (v, k, [k]),+    -- | Map key to a vertex identifier.  Return Nothing if the key is not+    -- a member of the graph.+    maybeVertex :: k -> Maybe G.Vertex }++-- | The node for the given key.  Return Nothing if the key is not+-- a member of the graph.+maybeNode :: DAG k v -> k -> Maybe v+maybeNode DAG{..} k = _1 . nodeDesc <$> maybeVertex k+{-# INLINE maybeNode #-}++-- | The edge list for the given key.  Return Nothing if the key is not+-- a member of the graph.+maybeEdges :: DAG k v -> k -> Maybe [k]+maybeEdges DAG{..} k = _3 . nodeDesc <$> maybeVertex k+{-# INLINE maybeEdges #-}++-- | Map key to a vertex identifier.  Report error if the key is not a member+-- of the graph.+vertex :: Show k => DAG k v -> k -> G.Vertex+vertex dag k = case maybeVertex dag k of+    Nothing -> error $ "vertex: key " ++ show k ++ " not in the graph"+    Just x  -> x++-- | The node for the given key.  Report error if the key is not a member+-- of the graph.+node :: Show k => DAG k v -> k -> v+node dag k = case maybeNode dag k of+    Nothing -> error $ "node: key " ++ show k ++ " not in the graph"+    Just x  -> x++-- | The edge list for the given key.  Report error if the key is not a member+-- of the graph.+edges :: Show k => DAG k v -> k -> [k]+edges dag k = case maybeEdges dag k of+    Nothing -> error $ "edges: key " ++ show k ++ " not in the graph"+    Just x  -> x++nodeV :: DAG k v -> G.Vertex -> v+nodeV DAG{..} = _1 . nodeDesc+{-# INLINE nodeV #-}++keyV :: DAG k v -> G.Vertex -> k+keyV DAG{..} = _2 . nodeDesc+{-# INLINE keyV #-}++edgesV :: DAG k v -> G.Vertex -> [k]+edgesV DAG{..} = _3 . nodeDesc+{-# INLINE edgesV #-}++leaves :: DAG k v -> [k]+leaves dag = [k | (_, k, []) <- unDAG dag]++roots :: Ord k => DAG k v -> [k]+roots dag =+    let desc = S.fromList . concat . map _3 $ unDAG dag+    in  [k | (_, k, _) <- unDAG dag, not (k `S.member` desc)]++-- | Smart constructur which verifies that the graph is actually a DAG.+-- Return Nothing if the input list constitutes a graph with cycles. +mkDAG :: (Show k, Ord k) => [(v, k, [k])] -> Maybe (DAG k v)+mkDAG xs +    | any ((>1) . length . T.flatten) (G.scc _graph) = Nothing+    | otherwise = Just $ DAG+        { graph         = _graph+        , nodeDesc      = _nodeDesc+        , maybeVertex   = _maybeVertex }+  where+    (_graph, _nodeDesc, _maybeVertex) = G.graphFromEdges xs++unDAG :: DAG k v -> [(v, k, [k])]+unDAG DAG{..} = map nodeDesc (G.vertices graph)++-- | Spanning forest of the DAG.  Non-overloaded version of the 'toForest'+-- function.  The comparison function is used to sort the list of leaves+-- and the spanning tree is computed with respect to the resulting order.+toForestBy :: (Show k, Ord k) => (k -> k -> Ordering) -> DAG k v -> T.Forest k+toForestBy cmp dag@DAG{..} =+    let proxy = minimumBy cmp . map (keyV dag)+              . G.reachable graph . vertex dag+        cmpRoots r r' = cmp (proxy r) (proxy r')+        xs = map (vertex dag) . sortBy cmpRoots $ roots dag+    in  map (fmap (_2 . nodeDesc)) (G.dfs graph xs)++-- | Spanning forest of the DAG using the standard 'compare' function to+-- compare keys kept in DAG leaves.  Overloaded version of the 'toForestBy'+-- function.+toForest :: (Show k, Ord k) => DAG k v -> T.Forest k+toForest = toForestBy compare++_1 :: (a, b, c) -> a+_1 (x, _, _) = x+{-# INLINE _1 #-}++_2 :: (a, b, c) -> b+_2 (_, x, _) = x+{-# INLINE _2 #-}++_3 :: (a, b, c) -> c+_3 (_, _, x) = x+{-# INLINE _3 #-}
+ src/Data/Named/Graph.hs view
@@ -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)
+ src/Data/Named/IOB.hs view
@@ -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
+ src/Data/Named/Tree.hs view
@@ -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
+ src/Text/Named/Enamex.hs view
@@ -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)