alpino-tools 0.0.5 → 0.1.0

raw patch · 4 files changed

+441/−3 lines, 4 filesdep +hexpat-pickledep +mtldep +rosezipperPVP ok

version bump matches the API change (PVP)

Dependencies added: hexpat-pickle, mtl, rosezipper

API changes (from Hackage documentation)

Files

• alpino-tools.cabal +6/−3
• src/Data/Alpino/DepStruct.hs +72/−0
• src/Data/Alpino/DepStruct/Pickle.hs +211/−0
• src/Data/Alpino/DepStruct/Triples.hs +152/−0

@@ -1,5 +1,5 @@ Name:		alpino-tools-Version:	0.0.5+Version:	0.1.0 License:	OtherLicense License-file:	LICENSE Copyright:	Copyright 2010 Daniël de Kok@@ -13,12 +13,15 @@ Build-Type:	Simple  Library-  Exposed-Modules:	Data.Alpino.Model, Data.Alpino.Model.Enumerator+  Exposed-Modules:      Data.Alpino.DepStruct, Data.Alpino.DepStruct.Pickle,+                        Data.Alpino.DepStruct.Triples, Data.Alpino.Model,+                        Data.Alpino.Model.Enumerator   Build-Depends:	base >= 4 && < 5, bytestring >= 0.9.1.7,                         utf8-string >= 0.3.6, bytestring-lexing >= 0.2.1,                         enumerator >= 0.4.8 && < 0.5, transformers >= 0.2.2.0,                         containers >= 0.3.0.0, random >= 1.0.0.3,-                        random-shuffle >= 0.0.2+                        random-shuffle >= 0.0.2, hexpat-pickle >= 0.4,+                        rosezipper >= 0.2, mtl >= 2.0.1.0   HS-Source-Dirs:       src   Ghc-Options:		-O2 -Wall 

@@ -0,0 +1,72 @@+-- |+-- Module      : Data.Alpino.DepStruct+-- Copyright   : (c) 2011 Daniël de Kok+-- License     : Apache 2+--+-- Maintainer  : Daniël de Kok <me@danieldk.eu>+-- Stability   : experimental+--+-- Definitions for Alpino dependency structures.++module Data.Alpino.DepStruct (++  -- * Dependency structures+  AlpinoDS(..),+  Cat(..),+  DSLabel(..),+  Rel(..)++) where++import Data.Tree++-- | Alpino dependency structures define syntactic relations between+--   words. For convenience, the dependency structure is represented+--   as a rose tree. Additionally, the dependency structure contains+--   the sentence corresponding to the dependency structure.+data AlpinoDS = AlpinoDS {+  -- | Root of the dependency tree. +  dsRoot     :: Tree DSLabel,+  -- | Sentence corresponding to the dependency tree. +  dsSentence :: String+} deriving(Show, Eq)++-- | Label containing syntactic or lexical information of a node.+data DSLabel =+   CatLabel {+    -- | Category+    labelRel   :: Rel,+    -- | Dependency relation+    labelCat   :: Cat,+    -- | Coindexation+    labelIdx   :: Maybe Integer,+    -- | Start position+    labelBegin :: Maybe Integer,+    -- | End position+    labelEnd   :: Maybe Integer+   }+  | LexLabel {+    -- | Dependency relation+    labelRel  :: Rel,+    -- | Part of speech tag+    labelPos  :: String,+    -- | Root/stem+    labelRoot :: String,+    -- | Coindexation+    labelIdx  :: Maybe Integer,+    -- | Start position+    labelBegin :: Maybe Integer,+    -- | End position+    labelEnd   :: Maybe Integer+  } deriving (Show, Eq)++data Rel = Hdf | Hd | Cmp | Sup | Su | Obj1 | PObj1 | Obj2| Se | PC | VC+  | SVP | PredC | Ld | Me | PredM | ObComp | Mod | Body | Det | App | Whd+  | Rhd | Cnj | Crd | Nucl | Sat | Tag | DP | Top | MWP | DLink | DashDash +  deriving (Eq, Ord, Show)++data Cat = SMain | NP | PPart | PPres | PP | SSub | Inf | Cp | DU | Ap+  | AdvP | TI | Rel | WhRel | WhSub | Conj | WhQ | Oti | Ahi | DetP | SV1+  | SVan | MWU | TopCat+  deriving (Eq, Ord, Show)+

@@ -0,0 +1,211 @@+-- |+-- Module      : Data.Alpino.DepStruct.Pickle+-- Copyright   : (c) 2011 Daniël de Kok+-- License     : Apache 2+--+-- Maintainer  : Daniël de Kok <me@danieldk.eu>+-- Stability   : experimental+--+-- Pickling and unpickling of Alpino dependency structures from XML.++module Data.Alpino.DepStruct.Pickle (xpAlpinoDS) where++import Control.Monad.State (State, evalState, get, put)+import Data.Tree (rootLabel, subForest)+import qualified Data.Tree as DT+import Text.Printf (printf)+import Text.XML.Expat.Pickle++import Data.Alpino.DepStruct ++data LabelOrRef =+  Label {+    lorLabel :: DSLabel+  }+  | Ref {+    lorRel :: Rel,+    lorIdx :: Integer+} deriving (Show)++-- | Pickler for Alpino dependency structures.+xpAlpinoDS :: PU [UNode String] AlpinoDS+xpAlpinoDS = +  xpElemNodes "alpino_ds" $+  xpWrap (+    \(lOrRefTree, sent) ->+      AlpinoDS (evalState (resolveTree lOrRefTree) []) sent,+    \n -> (+      evalState (refTree $ dsRoot n) [],+      dsSentence n+    )+  ) $+  xpPair+    xpNode+    xpSentence++xpNode :: PU [UNode String] (DT.Tree LabelOrRef)+xpNode =+  xpAlt picklerIndex [xpLexNode, xpCatNode, xpRefNode]+  where+    picklerIndex (DT.Node lr _) = case lr of+      (Label label) -> case label of+        LexLabel _ _ _ _ _ _ -> 0+        CatLabel _ _ _ _ _   -> 1+      Ref _ _       -> 2++xpCatNode :: PU [UNode String] (DT.Tree LabelOrRef)+xpCatNode =+  xpWrap (+    \((rel, cat, idx, begin, end), forest) ->+      DT.Node (Label $ CatLabel rel cat idx begin end) forest,+    \t -> (+      (labelRel   $ lorLabel $ rootLabel t,+       labelCat   $ lorLabel $ rootLabel t,+       labelIdx   $ lorLabel $ rootLabel t,+       labelBegin $ lorLabel $ rootLabel t,+       labelEnd   $ lorLabel $ rootLabel t),+      subForest t)+    ) $+    xpElem "node"+    (xp5Tuple+      (xpAttr        "rel"   xpRel)+      (xpAttr        "cat"   xpCat)+      (xpAttrImplied "index" xpickle)+      (xpAttrImplied "begin" xpickle)+      (xpAttrImplied "end"   xpickle))+    (xpList xpNode)++xpLexNode :: PU [UNode String] (DT.Tree LabelOrRef)+xpLexNode =+  xpWrap (+    \(rel, pos, root, idx, begin, end) ->+      DT.Node (Label $ LexLabel rel pos root idx begin end) [],+    \t -> +      (labelRel   $ lorLabel $ rootLabel t,+       labelPos   $ lorLabel $ rootLabel t,+       labelRoot  $ lorLabel $ rootLabel t,+       labelIdx   $ lorLabel $ rootLabel t,+       labelBegin $ lorLabel $ rootLabel t,+       labelEnd   $ lorLabel $ rootLabel t)) $+  xpElemAttrs "node"+    (xp6Tuple+      (xpAttr        "rel"   xpRel)+      (xpAttr        "pos"   xpText)+      (xpAttr        "root"  xpText)+      (xpAttrImplied "index" xpickle)+      (xpAttrImplied "begin" xpickle)+      (xpAttrImplied "end"   xpickle))++xpRefNode :: PU [UNode String] (DT.Tree LabelOrRef)+xpRefNode =+  xpWrap (+    \(rel, idx) ->+      DT.Node (Ref rel idx) [],+    \t ->+      (lorRel $ rootLabel t,+       lorIdx $ rootLabel t)) $+  xpElemAttrs "node"+    (xpPair+      (xpAttr "rel"   xpRel)+      (xpAttr "index" xpickle))++cats :: [(Cat, String)]+cats = [(SMain, "smain"), (NP, "np"), (PPart, "ppart"), (PPres, "ppres"),+        (PP, "pp"), (SSub, "ssub"), (Inf, "inf"), (Cp, "cp"), (DU, "du"),+        (Ap, "ap"), (AdvP, "advp"), (TI, "ti"), (Rel, "rel"), (WhRel, "whrel"),+        (WhSub, "whsub"), (Conj, "conj"), (WhQ, "whq"), (Oti, "oti"),+        (Ahi, "ahi"), (DetP, "detp"), (SV1, "sv1"), (SVan, "svan"),+        (MWU, "mwu"), (TopCat, "top")]++xpCat :: PU String Cat+xpCat =+  xpWrapMaybe_+    "Could not parse 'cat' attribute."+    (\cat -> lookup cat $ map (\(a, b) -> (b, a)) cats,+    -- Fixme: We should use pattern matching completeness check.+     \cat -> case lookup cat cats of+       Just c  -> c+       Nothing -> error "Bug: Category list is incomplete!"+    )+  xpText++rels :: [(Rel, String)]+rels = [(Hdf, "hdf"), (Hd, "hd"), (Cmp, "cmp"), (Sup, "sup"),+        (Su, "su"), (Obj1, "obj1"), (PObj1, "pobj1"), (Obj2, "obj2"),+        (Se, "se"), (PC, "pc"), (VC, "vc"), (SVP, "svp"), (PredC, "predc"),+        (Ld, "ld"), (Me, "me"), (PredM, "predm"), (ObComp, "obcomp"),+        (Mod, "mod"), (Body, "body"), (Det, "det"), (App, "app"),+        (Whd, "whd"), (Rhd, "rhd"), (Cnj, "cnj"), (Crd, "crd"),+        (Nucl, "nucl"), (Sat, "sat"), (Tag, "tag"), (DP, "dp"),+        (Top, "top"), (MWP, "mwp"), (DLink, "dlink"), (DashDash, "--")]++xpRel :: PU String Rel+xpRel =+  xpWrapMaybe_+    "Could not parse 'rel' attribute."+      (\rel -> lookup rel $ map (\(a, b) -> (b, a)) rels,+      -- Fixme: We should use pattern matching completeness check.+       \rel -> case lookup rel rels of+         Just r  -> r+         Nothing -> error "Bug: Relation list is incomplete!"+      )+  xpText++xpSentence :: PU [UNode String] String+xpSentence =+  xpElemNodes "sentence" (xpContent xpText0)++--+-- There is a discrepancy between our representation of dependency trees+-- in Haskell, and those in XML. In the XML representation, coreferent nodes+-- are only represented once in full. Subsequent occurances just have the+-- 'index' attribute.+--+-- This representation is annoying in real-life use, because a function+-- that processes a dependency structure has to resolve these 'reference+-- nodes'. For these reason, we add the full structure to all instances of+-- a coreferent node. Two functions are used:+--+-- resolveTree - expands reference nodes to full nodes (used during+--               pickling)+-- refTree     - replaces duplicate coreferent nodes by a reference (used+--               during unpickling)+--++type ResolveState = [(Integer, DT.Tree DSLabel)]++-- Resolve nodes that only have a coreference index and a relation.+resolveTree :: DT.Tree LabelOrRef -> State ResolveState (DT.Tree DSLabel)+resolveTree (DT.Node (Label l) sf) = do+  lsf <- mapM resolveTree sf+  let node = DT.Node l lsf+  case labelIdx l of+    Just idx -> do+      coIndexed <- get+      put $ (idx, node):coIndexed+    Nothing  -> return () +  return node++resolveTree (DT.Node (Ref rel idx) _) = do+  coIndexed <- get+  let (DT.Node l ds) = case lookup idx coIndexed of+                         Just n  -> n+                         Nothing -> error $ printf "Invalid coreference: %i" idx+  let newLabel = l { labelRel = rel }+  return $ DT.Node newLabel ds++type RefState = [Integer]++refTree :: DT.Tree DSLabel -> State RefState (DT.Tree LabelOrRef)+refTree (DT.Node l sf) = do+  coIndexed <- get+  case labelIdx l of+    Just idx -> if elem idx coIndexed then +                  return $ DT.Node (Ref (labelRel l) idx) []+                else do+                  lrSf <- mapM refTree sf+                  put $ idx : coIndexed +                  return $ DT.Node (Label l) lrSf +    Nothing  -> do+      lrSf <- mapM refTree sf+      return $ DT.Node (Label l) lrSf

@@ -0,0 +1,152 @@+-- |+-- Module      : Data.Alpino.DepStruct.Triples+-- Copyright   : (c) 2011 Daniël de Kok+-- License     : Apache 2+--+-- Maintainer  : Daniël de Kok <me@danieldk.eu>+-- Stability   : experimental+--+-- Definition and extraction of Alpino dependency triples.++module Data.Alpino.DepStruct.Triples (++  -- * Dependency triples+  DepTriple(..),+  DepTripleComponent(..),+  depTriples,++  -- * Utility functions+  tzFold++) where++import Control.Monad (ap)+import Data.Maybe (catMaybes, fromJust)+import Data.Set (Set, fromList)+import Data.Tree.Zipper++import Data.Alpino.DepStruct++-- Dependency triples++-- | The 'DepTriple' type represents a dependency that occurs in+--   a dependency structure. The triple consists of the head, a dependent, and+--   the relation between the head and the dependeny. For convenience, the+--   triple is composed of two 'DepTripleComponent' instances: the first+--   representing the head and its role in the relation, the second+--   representing the dependant and its role in the relation.+data DepTriple = DepTriple {+  tripleHead :: DepTripleComponent,+  tripleDep  :: DepTripleComponent+} deriving (Eq, Ord, Show)++-- | The 'DepTripleComponent' type represents a head or a dependant in a+--   dependency relation.+data DepTripleComponent = DepTripleComponent {+  triplePos  :: String,+  tripleRoot :: String,+  tripleRel  :: Rel+} deriving (Eq, Ord, Show)++-- | Extract 'DepTriples' from the tree starting at the node represented by+--   the 'TreePos' zipper.+depTriples :: TreePos Full DSLabel -> Set DepTriple+depTriples =+  fromList . map (uncurry hdDepToTriple) . hdsDeps . heads+  where+    hdsDeps = concat . map hdDeps           -- Find dependencies of given heads.+    hdDeps = (zip . repeat) `ap` dependants -- Find dependencies of a head.++heads :: TreePos Full DSLabel -> [TreePos Full DSLabel]+heads =+  tzFilter isHead++isHead :: TreePos Full DSLabel -> Bool+isHead t = case label t of+  (LexLabel rel _ _ _ _ _) -> rel `elem` headRels+  _                    -> False++headRels :: [Rel]+headRels = [Hd, Cmp, Crd, DLink, Rhd, Whd]++-- Find dependants of a node. Dependants are:+--+-- * Siblings that are lexical nodes+-- * Heads of non-lexical nodes+--+dependants :: TreePos Full DSLabel -> [TreePos Full DSLabel]+dependants = catMaybes . map lexOrHdDtr . siblings++-- Get zippers for the siblings of a node.+siblings :: TreePos Full DSLabel ->+  [TreePos Full DSLabel]+siblings t =+  case parent t of+    (Just p) -> filter ((/=) t) $ childList p+    Nothing  -> [] -- No parent? No siblings.++-- Get zippers fo the children of a node.+childList :: TreePos Full DSLabel -> [TreePos Full DSLabel]+childList = curLevel . firstChild+  where+    curLevel (Nothing) = []+    curLevel (Just t') = t':curLevel (next t')++-- If the node is a lexical node, return it as-is. If not, return its+-- head daughter.+lexOrHdDtr :: TreePos Full DSLabel -> Maybe (TreePos Full DSLabel)+lexOrHdDtr t = +  case label t of+    (LexLabel _ _ _ _ _ _) -> Just t+    (CatLabel _ _ _ _ _)   -> case filter isHead $ childList t of+                           [c] -> Just c+                           _   -> Nothing++-- Retrieve the relation of a node if it serves as a dependent.+relAsDependent :: TreePos Full DSLabel -> Maybe Rel+relAsDependent t =+  case label t of+    (LexLabel rel _ _ _ _ _) -> if rel `elem` headRels then+                              case parent t of+                                Just p -> case label p of+                                  (LexLabel rel' _ _ _ _ _) -> Just rel'+                                  (CatLabel rel' _ _ _ _)   -> Just rel'+                                Nothing -> Nothing+                            else+                             Just rel+    (CatLabel _ _ _ _ _)     -> Nothing++hdDepToTriple :: TreePos Full DSLabel -> TreePos Full DSLabel ->+  DepTriple+hdDepToTriple hd dep = DepTriple hdTripleComp depTripleComp+  where+    hdTripleComp = DepTripleComponent (labelPos hdLabel) (labelRoot hdLabel) (labelRel hdLabel)+    hdLabel = label hd+    depTripleComp = DepTripleComponent (labelPos depLabel) (labelRoot depLabel) (fromJust $ relAsDependent dep)+    depLabel = label dep++-- Utility functions++-- | Fold over a tree depth-first, starting at the node wrapped in the+--   'TreePos' zipper.+tzFold :: (a -> TreePos Full b -> a) -> a -> TreePos Full b -> a+tzFold f acc t =+  foldSiblings $ foldChildren $ f acc t+  where+    foldChildren acc' =+      case firstChild t of+        Just c  -> tzFold f acc' c+        Nothing -> acc'+    foldSiblings acc' =+      case next t of+        Just s  -> tzFold f acc' s+        Nothing -> acc'++tzFilter :: (TreePos Full b -> Bool) -> TreePos Full b -> [TreePos Full b]+tzFilter f =+  tzFold adder []+  where+    adder acc t+      | f t       = t:acc+      | otherwise = acc+