diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +# Google's SyntaxNet API in Haskell + +[![Build Status](https://travis-ci.com/mgajda/syntaxnet-haskell.svg?token=DtSUtnf37TUDy1p4x6fT&branch=master)](https://travis-ci.com/mgajda/syntaxnet-haskell) + +Haskell library for using [Google's SyntaxNet](https://github.com/tensorflow/models/tree/master/syntaxnet). +SyntaxNet is natural language parser including: +* Part of Speech tagger, +* syntax tree generator, +* recognition of referential expressions. + +This API allows: +1. Reading saved SyntaxNet parse tree, POS, or reference assignment from file. +2. Easy manipulation of the parse trees with extra information (given by POS and/or reference assignment.) + +# Documentation +Documentation will put into [docs](docs/) folder. + +# Tests +Examples of parsed [SyntaxNet inputs](test/examples/) are attached. + +There are following files there for each test: +* `.txt` file contains the input +* `.cnll` file contains the SyntaxNet output from `run.sh` script (parsed by the library) +* `.tree` file contains the SyntaxNet output from `demo.sh` script (if present) + +# Usage + +``` +1) stack repl +2) :load src/NLP/SyntaxNet/SyntaxNet.hs +3) > tr <- readParseTree "test/examples/test1.tree" +4) > drawTree' $ fromJust $ tr +for Testing. +``` + +# Acknowledgements + +- [Michał J. Gajda](https://github.com/mgajda) +- [Sergey Bushnyak](https://github.com/sigrlami) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/NLP/SyntaxNet/SyntaxNet.hs b/src/NLP/SyntaxNet/SyntaxNet.hs new file mode 100644 --- /dev/null +++ b/src/NLP/SyntaxNet/SyntaxNet.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +module NLP.SyntaxNet.SyntaxNet + ( readCnll + , readParseTree + ) where + +import Control.Applicative +import Control.Concurrent +import qualified Control.Exception as E +import Control.Lens hiding (at) +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.Char +import qualified Data.Csv as Csv +import Data.Tree +import Data.Maybe +import Protolude +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BSL +import Data.Functor ((<$>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TEL +import qualified Data.Vector as V +import Safe as S +import Data.String + +import Data.ConllToken +import Data.ParsedSentence +import Data.SyntaxTree +import Data.TagLabel +import NLP.SyntaxNet.Types.CoNLL +import NLP.SyntaxNet.Types.ParseTree + +-------------------------------------------------------------------------------- + +readCnll :: FilePath -> IO [SnConllToken Text] +readCnll fpath = do + csvData <- BSL.readFile fpath + case TEL.decodeUtf8' csvData of + Left err -> do + putStrLn $ "error decoding" ++ (show err) + return [] + Right dat -> do + let res = (Csv.decodeWith cnllOptions Csv.NoHeader $ TEL.encodeUtf8 dat) :: Either String (V.Vector (SnConllToken Text)) + case res of + Left err -> do + putStrLn $ "error decoding" ++ (show err) + return [] + Right vals -> + return $ V.toList vals + +preprocess :: TL.Text -> TL.Text +preprocess txt = TL.cons '\"' $ TL.snoc escaped '\"' + where escaped = TL.concatMap escaper txt + +escaper :: Char -> TL.Text +escaper c + | c == '\t' = "\"\t\"" + | c == '\n' = "\"\n\"" + | c == '\"' = "\"\"" + | otherwise = TL.singleton c + + +-- | Define custom options to read tab-delimeted files +cnllOptions = + Csv.defaultDecodeOptions + { Csv.decDelimiter = fromIntegral (ord '\t') + } + +-------------------------------------------------------------------------------- +-- Dealing with trees + +readParseTree :: FilePath -> IO (Maybe (Tree (SnConllToken Text))) +readParseTree fpath = do + treeData <- BSC.readFile fpath + let ls = BSC.lines treeData + + let lls = map ( \x -> BSC.split ' ' x) ls + lln = map parseNode lls + + let tree = fromList lln + + return $ tree + +-- | Same as readParseTree but for debugging +-- +readParseTree' :: FilePath -> IO () +readParseTree' fpath = do + treeData <- BSC.readFile fpath + let ls = BSC.lines treeData + + mapM_ (putStrLn . T.pack . show ) ls + + let lls = map ( \x -> BSC.split ' ' x) ls + + lln <- mapM parseNode' ls + + tree <- fromList' $ lln + + mapM_ (putStrLn . T.pack . show ) lln + putStrLn $ T.pack $ "----\n" + putStrLn $ T.pack $ show $ drawTree' $ fromJust tree + + return $ () + +parseNode :: [BSC.ByteString] -> SnConllToken Text +parseNode llbs = do + let llss = map BSC.unpack llbs + lenLB = 3 -- useful labels like TOKEN POS ER + lenWP = (length $ filter (==" ") llss ) -- each identation takes 2 spaces + + let lls = map T.pack llss + lvl = (length lls) - lenLB - lenWP -- calculate actual level + lbls = drop ((length lls) - 3) lls -- extract only lables + + ConllToken lvl -- reuse id to indicate level, when working with trees + (lbls `at` 0) + "" + UnkCg + (parsePosFg $ lbls `at` 1) + "" + 0 + (parseGER $ lbls `at` 2) + "" + "" + +parseNode' :: BSC.ByteString -> IO (SnConllToken Text) +parseNode' bs = do + let llbs = filter (/="|") $ BSC.split ' ' bs + llss = map BSC.unpack llbs + lenLB = 3 -- useful labels like TOKEN POS ER + lenWP = (length $ filter (=="") llss) -- always have 1 in front, each identation takes 2 spaces + + + let llt = map T.pack llss + llsf = filter (/="") llt + lvl = ((mod lenWP 2))+1 -- calculate actual level + lbls = drop ((length llt) - 3) llt -- extract only lables + + putStrLn $ T.pack $ show $ llss + putStrLn $ T.pack $ show $ llsf + putStrLn $ T.pack $ show $ lenWP + putStrLn $ T.pack $ show $ lvl + + return $ ConllToken lvl -- reuse id to indicate level, when working with trees + (lbls `at` 0) + "" + UnkCg + (parsePosFg $ lbls `at` 1) + "" + 0 + (parseGER $ lbls `at` 2) + "" + "" diff --git a/src/NLP/SyntaxNet/Types/CoNLL.hs b/src/NLP/SyntaxNet/Types/CoNLL.hs new file mode 100644 --- /dev/null +++ b/src/NLP/SyntaxNet/Types/CoNLL.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module NLP.SyntaxNet.Types.CoNLL where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Char (toUpper, isUpper, toLower) +import Data.Csv as Csv +import Data.Maybe +import Data.Default +import Protolude +import Data.List.Split +import qualified Data.Text as T +import GHC.Generics + +import Data.ConllToken (ConllToken(..), SyntaxErrorCoNLL(..)) +import Data.SyntaxTree (SyntaxtTree(..), createSyntaxTree) +import Model.PennTreebank +import Model.UniversalTreebank +import Data.TagLabel + +-------------------------------------------------------------------------------- + +type SnConllToken a = ConllToken PosCG POS REL T.Text a +type SnConllTree a = SyntaxtTree PosCG POS REL T.Text a + +-- | See "A Universal Part-of-Speech Tagset" by Slav Petrov, Dipanjan Das and Ryan McDonald +-- for more details http://arxiv.org/abs/1104.2086 +-- Sum type for 12 universal part-of-speech tags, coarse-grained +data PosCG = + VERB -- verbs (all tenses and modes) + | NOUN -- nouns (common and proper) + | PRON -- pronouns + | ADJ -- adjectives + | ADV -- adverbs + | ADP -- adpositions (prepositions and postpositions) + | CONJ -- conjunctions + | DET -- determiners + | NUM -- cardinal numbers + | PRT -- particles or other function words + | X -- other: foreign words, typos, abbreviations + | PUNCT -- punctuation + | UnkCg -- unknown + deriving (Show, Eq, Generic) + +-------------------------------------------------------------------------------- + +instance Csv.FromRecord (SnConllToken T.Text) where + parseRecord v = do + a0 <- v .! 0 + a1 <- v .! 1 + a2 <- v .! 2 + a3 <- ( parsePosCf <$> v .! 3) + a4 <- ( parsePosFg <$> v .! 4) + a5 <- v .! 5 + a6 <- v .! 6 + a7 <- ( parseGER <$> v .! 7) + a8 <- v .! 8 + a9 <- v .! 9 + return (ConllToken a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) + +-- | Converting coarse-grained textual types int +-- ADT representation +parsePosCf :: T.Text -> PosCG +parsePosCf s = + case (map toUpper $ T.unpack s) of + "VERB" -> VERB + "NOUN" -> NOUN + "PRON" -> PRON + "ADJ" -> ADJ + "ADV" -> ADV + "ADP" -> ADP + "CONJ" -> CONJ + "DET" -> DET + "NUM" -> NUM + "PRT" -> PRT + "X" -> X + "." -> PUNCT + otherwise -> UnkCg + +-- | Converting fine-grained textual types into +-- ADT representation +parsePosFg :: T.Text -> POS +parsePosFg s = + case (map toUpper $ T.unpack s) of + "CC" -> CC + "CD" -> CD + "DT" -> DT + "EX" -> EX + "FW" -> FW + "IN" -> IN + "JJ" -> JJ + "JJR" -> JJR + "JJS" -> JJS + "LS" -> LS + "MD" -> MD + "NN" -> NN + "NNS" -> NNS + "NNP" -> NNP + "NNPS"-> NNPS + "PDT" -> PDT + "POS" -> POS + "PRP" -> PRP + "PRP$"-> fromJust $ fromLabelText "RPR$" + "RB" -> RB + "RBR" -> RBR + "RBS" -> RBS + "RP" -> RP + "SYM" -> SYM + "TO" -> TO + "UH" -> UH + "VB" -> VB + "VBD" -> VBD + "VBG" -> VBG + "VBN" -> VBN + "VBP" -> VBP + "VBZ" -> VBZ + "WDT" -> WDT + "WP" -> WP +-- "WPS" -> WPS + "WRB" -> WRB + otherwise -> CC -- haskell-conll doesn't support fallback + +parseGER :: T.Text -> REL +parseGER s = + case s of + "acl" -> Acl + "acl:relcl" -> fromJust $ fromLabelText "acl:relcl" + "advck" -> Advcl + "advmod" -> Advmod + "amod" -> Amod + "appos" -> Appos + "aux" -> Aux + "auxpass" -> Auxpass + "case" -> Case + "cc" -> Cc + "cc:preconj" -> fromJust $ fromLabelText "cc:preconj" + "ccomp" -> Ccomp + "compound" -> Compound + "compound:prt"-> fromJust $ fromLabelText "compound:prt" + "conj" -> Conj + "cop" -> Cop + "csubj" -> Csubj + "csubjpass" -> Csubjpass + "dep" -> Dep + "det" -> Det + "det:predet" -> fromJust $ fromLabelText "det:predet" -- haskell-conll have inconsistency in naming, why use _ whee you have camelcase + "discource" -> Discourse + "discolated" -> Dislocated + "dobj" -> Dobj + "expl" -> Expl + "fixed" -> fromJust $ fromLabelText "fixed" + "fixed:not" -> fromJust $ fromLabelText "fixed:not" -- haskell-conll doesn't support this one + "flat" -> Flat + "foreign" -> Foreign + "goeswith" -> Goeswith + "iobj" -> Iobj + "list" -> List + "mark" -> Mark + "neg" -> Neg + "nmod" -> Nmod + "nmod:npmod" -> fromJust $ fromLabelText "nmod:npmod" + "nmod:poss" -> fromJust $ fromLabelText "nmod:poss" + "nmod:tmod" -> fromJust $ fromLabelText "nmod:tmod" + "nsubj" -> Nsubj + "nsubjpass" -> Nsubjpass + "nummod" -> Nummod + "orphan" -> Orphan + "parataxis" -> Parataxis + "punct" -> Punct + "reparandum" -> Reparandum + "ROOT" -> ROOT + "vocatile" -> Vocative + "xcomp" -> Xcomp + otherwise -> Punct -- haskell-conll doesn't support uknown type, like UnkGer, so fall back ro Punct diff --git a/src/NLP/SyntaxNet/Types/ParseTree.hs b/src/NLP/SyntaxNet/Types/ParseTree.hs new file mode 100644 --- /dev/null +++ b/src/NLP/SyntaxNet/Types/ParseTree.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ViewPatterns #-} + +module NLP.SyntaxNet.Types.ParseTree where + +import Control.Lens +import Data.Default +import Data.Text +import Data.Tree +import Data.Tree.Lens +import qualified Data.Map as M +import Prelude as P + +import Data.ConllToken +--import Data.SyntaxTree (SyntaxtTree(..), createSyntaxTree) +import Model.PennTreebank +import Model.UniversalTreebank +import Data.TagLabel + +import NLP.SyntaxNet.Types.CoNLL + +-------------------------------------------------------------------------------- + +-- |A 'Tree' of 'SnConllToken Text's +type TokenTree = Tree (SnConllToken Text) + +-- |A 'Forest' of 'SnConllToken Text's +type TokenForest = [Tree (SnConllToken Text)] + +-- |A Map of text values the appropriate tree +type TokenMap = M.Map Text TokenTree + +drawTree' :: TokenTree -> String +drawTree' = P.unlines . draw + +-- | Neat 2-dimensional drawing of a forest. +drawForest' :: TokenForest -> String +drawForest' = P.unlines . P.map drawTree' + +draw :: TokenTree -> [String] +draw (Node tkn ts0) = + P.lines ((unpack $ _tnWord tkn) + ++ " " + ++ (show $ _tnPosFG tkn) + ++ " " + ++ (unpack $ toLabelText $ _tnRel tkn)) ++ drawSubTrees ts0 + where + drawSubTrees [] = [] + drawSubTrees [t] = shift " +-- " " " (draw t) + drawSubTrees (t:ts) = shift " +-- " " | " (draw t) ++ drawSubTrees ts + + shift first other = P.zipWith (++) (first : repeat other) + +-------------------------------------------------------------------------------- + +-- |Given a list of 'TokenTree's, return the top-level 'token's. +forestTokens :: [TokenTree] -> [Text] +forestTokens = P.map forestToken + +-- |Given a 'TokenTree', return the top-level 'token'. +forestToken :: TokenTree -> Text +forestToken (Node tkn subf) = _tnWord tkn + +-- |Given a list of 'TokenTree's, return a map of each token with +-- the appropriate tree. +mkMap :: TokenForest -> TokenMap +mkMap = + M.fromList . tokenTreeAlist + where + tokenTreeAlist frs = P.zip (forestTokens frs) frs + +-- | Return the elements at level i from a forest. 0-based indexing. +-- +getLevel :: Forest a -> Int -> [a] +getLevel fs 0 = P.map rootLabel fs +getLevel fs n = P.concatMap (\fs' -> getLevel (subForest fs') (n-1)) fs + +-- | Convert list of nodes with defined level +-- into Tree structure +fromList :: [(SnConllToken Text)] -> Maybe TokenTree +fromList (n:nodes) = + Just $ Node n (fromListAux nodes []) + where fromListAux :: [(SnConllToken Text)] -- ^ List of parsed Tokens + -> [TokenTree] -- ^ Building Forest + -> [TokenTree] -- ^ Final Forest + fromListAux [] f = f + fromListAux (t:ts:tss) f + -- check current and next level + | _tnId t == _tnId ts = do + -- next element on the same level, attach only + fromListAux (ts:tss) (f ++ [Node t []]) + | _tnId t < _tnId ts = do + -- attach and move recursevly deep + fromListAux (ts:tss) (f ++ [(Node t (fromListAux (ts:tss) [] ))]) + | _tnId t > _tnId ts = do + -- next level is higher, attach only and move forest up + f ++ [Node t []] + +-- | Debug version of fromList inside IO monad +-- +fromList' :: [(SnConllToken Text)] -> IO (Maybe TokenTree) +fromList' (n:nodes) = do + forest <- fromListAux nodes [] + return $ Just $ Node n forest + where fromListAux :: [(SnConllToken Text)] -- ^ List of parsed Tokens + -> [TokenTree] -- ^ Building Forest + -> IO [TokenTree] -- ^ Final Forest + fromListAux [] f = return $ f + fromListAux (t:ts:tss) f + -- check current and next level + | _tnId t == _tnId ts = do + -- next element on the same level, attach only + let lvl = P.replicate (_tnId t) '-' + lvl'= P.replicate (_tnId t) ' ' + putStrLn $ lvl + putStrLn $ lvl' ++ "ch: 1; " ++ "lv: " ++ (show $ _tnId t) ++ " ; wr: " ++ (unpack $ _tnWord $ t) + + fromListAux (ts:tss) (f ++ [Node t []]) + | _tnId t < _tnId ts = do + -- attach and move recursevly deep + let lvl = P.replicate (_tnId t) '-' + lvl'= P.replicate (_tnId t) ' ' + putStrLn $ lvl + putStrLn $ lvl' ++ "ch: 2; " ++ "lv: " ++ (show $ _tnId t) ++ " ; wr: " ++ (unpack $ _tnWord $ t) + + sforest <- fromListAux (ts:tss) [] -- < + fromListAux (ts:tss) (f ++ [(Node t sforest)]) + | _tnId t > _tnId ts = do + -- next level is higher, attach only and move forest up + let lvl = P.replicate (_tnId t) '-' + lvl'= P.replicate (_tnId t) ' ' + putStrLn $ lvl + putStrLn $ lvl' ++ "ch: 2; " ++ "lv: " ++ (show $ _tnId t) ++ " ; wr: " ++ (unpack $ _tnWord t) + + return $ f ++ [Node t []] + + +-- | Convert Tree structure to a sequantial list structure +-- +toList :: TokenTree -> [(SnConllToken Text)] +toList t = + toListAux t [] + where + toListAux (Node x ts) xs = x : P.foldr toListAux xs ts diff --git a/syntaxnet-haskell.cabal b/syntaxnet-haskell.cabal new file mode 100644 --- /dev/null +++ b/syntaxnet-haskell.cabal @@ -0,0 +1,60 @@ +name: syntaxnet-haskell +version: 0.1.1.0 +synopsis: Working with Google's SyntaxNet output files - CoNLL, Tree +description: Allows to parse SyntaxNet output files in CoNLL or Syntax Tree formats. +homepage: https://github.com/mgajda/syntaxnet-haskell#readme +license: MIT +license-file: LICENSE +author: Sergey Bushnyak, Michal Gajda +maintainer: sergey.bushnyak@sigrlami.eu +copyright: Copyright: (c) 2017 Michal Gajda, Sergey Bushnyak +category: NLP +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: NLP.SyntaxNet.SyntaxNet + other-modules: NLP.SyntaxNet.Types.ParseTree + , NLP.SyntaxNet.Types.CoNLL + build-depends: base >= 4.7 && < 5 + , bytestring + , aeson + , lens + , vector + , text + , text-format + , data-default + , cassava + , containers + , protolude + , safe + , split + , haskell-conll + default-extensions: OverloadedStrings + , TemplateHaskell + other-extensions: ScopedTypeVariables + , FlexibleContexts + , DeriveGeneric + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + , OverloadedStrings +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , aeson + , hspec + , haskell-conll + , cassava + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + , OverloadedStrings + +source-repository head + type: git + location: https://github.com/sigrlami/syntaxnet-haskell diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main (main) where + +import Test.Hspec + +-------------------------------------------------------------------------------- + +main :: IO () +main = + hspec spec + +spec :: Spec +spec = + describe "Testing CoNLL parsing" $ do + it "" $ do + + -- Do Golden testing against + it "" $ do + input <- liftIO $ readFile "examples/test-simple.conll" + output <- liftIO $ readFile "examples/test-simple.conll.dump"