data-named 0.2.0 → 0.3.0

raw patch · 3 files changed

+103/−94 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Named/Graph.hs +66/−47
• Data/Named/Tree.hs +36/−46
• data-named.cabal +1/−1

@@ -1,77 +1,105 @@ {-# LANGUAGE DoAndIfThenElse #-} --- | Implementation of a graph with each node identified by a unique key.--- It is a provisional module and it might be replaced by the standard--- graph from containers package in the future.+-- | 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-, node , edges , roots-, disjointForest+, 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 qualified Data.Tree as T  import Data.Named.Tree --- | A graph.-data Graph k v = Graph-    { nodeMap :: M.Map k v-    , edgeMap :: M.Map k [k] }+-- | A graph over a sentence.+data Graph n w = Graph+    { bounds  :: (w, w)+    , edgeMap :: M.Map n [Either n w] } --- | Make a graph from a list of (key, value, [children keys]) tuples.-mkGraph :: Ord k => [(k, v, [k])] -> Graph k v-mkGraph xs = -    Graph ns es+-- | 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-    ns = M.fromList [(k, v)  | (k, v, _)  <- xs]-    es = M.fromList [(k, ks) | (k, _, ks) <- xs]---- | Get node with the given key.-node :: (Show k, Ord k) => Graph k v -> k -> v-node g k = case M.lookup k (nodeMap g) of-    Nothing -> error $ "node: key " ++ show k ++ " not in the nodes map"-    Just v  -> v-{-# INLINE node #-}+    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 :: (Show k, Ord k) => Graph k v -> k -> [k]+edges :: Ord n => Graph n w -> n -> [Either n w] edges g k = case M.lookup k (edgeMap g) of-    Nothing -> error $ "edges: key " ++ show k ++ " not in the edges map"+    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 k => Graph k v -> [k]+roots :: Ord n => Graph n w -> [n] roots g =-    let desc = S.fromList . concat . M.elems $ edgeMap g-    in  [k | (k, _) <- M.assocs (nodeMap g), not (k `S.member` desc)]+    let desc = S.fromList . lefts . concat . M.elems $ edgeMap g+    in  [k | k <- M.keys (edgeMap g), not (k `S.member` desc)] -generate :: (Show k, Ord k) => Graph k v -> k -> T.Tree k-generate g k  = T.Node k (map (generate g) (edges g k))+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 [] +prune :: Ord w => T.Forest (Either n w) -> T.Forest (Either 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 (p, q) ts+    = unSpanForest . T.subForest+    . sortTree . fillTree+    . dummyRoot+    . spanForest $ ts+  where+    dummyRoot = T.Node (undefined, Span p q)+    mkLeaf k  = T.Node (Right k, leafSpan k) []++    fillForest = map fillTree+    fillTree (T.Node n []) = T.Node n []+    fillTree (T.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))++-- | 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 g = addWords (bounds g) . prune . map (generate g . Left) . roots $ g+ -- | A stateful monad for forest pruning.-newtype RanM a = RanM { runRanM :: Int -> (a, Int) }+newtype RanM w a = RanM { runRanM :: Maybe w -> (a, Maybe w) } -instance Monad RanM where+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 a -> a-run act = fst (runRanM act (-1))+run :: RanM w a -> a+run act = fst (runRanM act Nothing) -contains :: Int -> RanM Bool-contains k = RanM $ \m -> (k <= m, m)+contains :: Ord w => w -> RanM w Bool+contains k = RanM $ \m -> case m of+    Just x  -> (k <= x, m)+    Nothing -> (False,  m) -include :: Int -> RanM ()-include k = RanM $ \_ -> ((), k)+include :: w -> RanM w ()+include k = RanM $ \_ -> ((), Just k) -chop :: T.Forest (k, Span) -> RanM (T.Forest (k, Span))+chop :: Ord w => T.Forest (k, Span w) -> RanM w (T.Forest (k, Span w)) chop [] = return [] chop (T.Node (k, s) ts : us) = do     visited <- contains (end s)@@ -82,12 +110,3 @@         include (end s)         bs <- chop us         return (T.Node (k, s) as : bs)--prune :: (k -> Int) -> T.Forest k -> T.Forest k-prune f = unSpanForest . run . chop . sortForest . spanForest f---- | Spanning-like forest of a DAG.  Trees in the resulting forest are--- disjoint with respect to their ranges.  It is not checked if the input--- graph is actually a DAG.-disjointForest :: (Show k, Ord k) => (k -> Int) -> Graph k v -> T.Forest k-disjointForest f g = prune f . map (generate g) . roots $ g

@@ -2,11 +2,11 @@  module Data.Named.Tree ( --- * Combine with words-  addWords+-- -- * Combine with words+--   addWords  -- * Span-, Span (..)+  Span (..) , leafSpan , (<>) , spanSet@@ -21,90 +21,80 @@ , sortForest  -- * Utilities+, mapLeaves+, mapNodes , mapTrees ) 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 qualified Data.IntSet as S-import qualified Data.Map as M+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) []++-- | 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) []+ -- | Map function over each tree from the forest. mapTrees :: (a -> b) -> T.Forest a -> T.Forest b mapTrees f = map (fmap f)  -- | Spanning of a tree.-data Span = Span-    { beg   :: Int-    , end   :: Int }+data Span w = Span+    { beg   :: w+    , end   :: w }     deriving (Show, Eq, Ord)  -- | Make span for a leaf node.-leafSpan :: Int -> Span+leafSpan :: w -> Span w leafSpan i = Span i i  -- | Minimum span overlapping both input spans.-(<>) :: Span -> Span -> Span+(<>) :: 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 :: Span -> S.IntSet-spanSet s = S.fromList [beg s .. end s]+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 :: T.Tree (a, Span) -> Span+span :: T.Tree (a, Span w) -> Span w span = snd . T.rootLabel  -- | Annotate tree nodes with spanning info given the function -- which assignes indices to leaf nodes.-spanTree :: (k -> Int) -> T.Tree k -> T.Tree (k, Span)-spanTree f (T.Node k []) = T.Node (k, leafSpan (f k)) []-spanTree f (T.Node k ts) =-    let us = spanForest f ts+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) =+    let us = spanForest ts         s  = foldl1 (<>) (map span us)     in  T.Node (k, s) us  -- | Annotate forest nodes with spanning info.-spanForest :: (k -> Int) -> T.Forest k -> T.Forest (k, Span)-spanForest f ts = map (spanTree f) ts+spanForest :: Ord w => T.Forest (Either n w) -> T.Forest (Either n w, Span w)+spanForest = map spanTree  -- | Remove span annotations from the tree.-unSpanTree :: T.Tree (k, Span) -> T.Tree k+unSpanTree :: T.Tree (k, Span w) -> T.Tree k unSpanTree = fmap fst  -- | Remove span annotations from the forest.-unSpanForest :: T.Forest (k, Span) -> T.Forest k+unSpanForest :: T.Forest (k, Span w) -> T.Forest k unSpanForest = map unSpanTree  -- | Sort the tree with respect to spanning info.-sortTree :: T.Tree (k, Span) -> T.Tree (k, Span)+sortTree :: Ord w => T.Tree (k, Span w) -> T.Tree (k, Span w) sortTree (T.Node x ts) = T.Node x (sortForest ts)  -- | Sort the forest with respect to spanning info.-sortForest :: T.Forest (k, Span) -> T.Forest (k, Span)+sortForest :: Ord w => T.Forest (k, Span w) -> T.Forest (k, Span w) sortForest = sortBy (comparing span) . map sortTree---- | Combine the disjoint forest with the list of words.--- Discontinuities will be patched with no trace.-addWords :: Ord k => T.Forest k -> [k] -> T.Forest k-addWords [] xs = [T.Node x [] | x <- xs]-addWords ts xs-    = unSpanForest . T.subForest-    . sortTree . fillTree-    . dummyRoot-    . spanForest f $ ts-  where-    f = (M.!) $ M.fromList (zip xs [0..])-    g = (M.!) $ M.fromList (zip [0..] xs)--    dummyRoot = T.Node (undefined, bounds)-    bounds = Span 0 (length xs - 1)--    fillForest = map fillTree-    fillTree (T.Node n []) = T.Node n []-    fillTree (T.Node (k, s) us) =-        let m = spanSet s S.\\ S.unions (map (spanSet . span) us)-            mkLeaf i = T.Node (g i, leafSpan i) []-        in  T.Node (k, s) (fillForest us ++ map mkLeaf (S.toList m))

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