diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# corenlp-parser +# corenlp-parser [![Build Status](https://travis-ci.org/k-bx/corenlp-parser.svg?branch=master)](https://travis-ci.org/k-bx/corenlp-parser) Launches CoreNLP and parses the JSON output. See `NLP.CoreNLP` haddocks for the documentation (or read the source) http://hackage.haskell.org/package/corenlp-parser @@ -6,6 +6,7 @@ Building via: ``` +sudo apt install librocksdb-dev # "brew install rocksdb" on macOS stack build ``` diff --git a/corenlp-parser.cabal b/corenlp-parser.cabal --- a/corenlp-parser.cabal +++ b/corenlp-parser.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e8a7cb9abd37d5caa6e148ad4d63629e9f60c0f297c21244bf1fff026e90c24c +-- hash: 951be5b6ce053014c505b53854ecea04601503a1e77d11bef3189384163fb53f name: corenlp-parser -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Launches CoreNLP and parses the JSON output description: Launches CoreNLP and parses the JSON output category: Natural Language Processing @@ -28,9 +28,14 @@ build-depends: aeson , base >=4.7 && <5 + , cryptonite + , data-default , directory , process , raw-strings-qq + , rocksdb-haskell + , safe-exceptions + , store , string-class , temporary , text diff --git a/src/NLP/CoreNLP.hs b/src/NLP/CoreNLP.hs --- a/src/NLP/CoreNLP.hs +++ b/src/NLP/CoreNLP.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Module provides a handy wrapper around the CoreNLP project\'s -- command-line utility https://nlp.stanford.edu/software/corenlp.html @@ -20,21 +21,32 @@ , Corefs , Document(..) , NamedEntity(..) + , ParsedDocument(..) + , LaunchOptions(..) -- * Internal + , extractSuccessDocs , test ) where import Control.Applicative +import Control.Exception.Safe import Control.Monad (forM, when) +import qualified Crypto.Hash as Crypto import qualified Data.Aeson as J import Data.Aeson (FromJSON, ToJSON) +import Data.Default +import Data.Either import Data.HashMap.Strict (HashMap) +import Data.Maybe import Data.Semigroup +import qualified Data.Store as Store import Data.String.Class as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Database.RocksDB.Base as Rocks import GHC.Generics (Generic) +import System.Directory import System.Exit import System.IO (hFlush) import System.IO.Temp @@ -58,6 +70,8 @@ , dependentGloss :: Text } deriving (Show, Eq, Generic) +instance Store.Store Dependency + instance FromJSON Dependency where parseJSON = J.genericParseJSON jsonOpts @@ -76,6 +90,8 @@ , normalizedNER :: Maybe Text } deriving (Show, Eq, Generic) +instance Store.Store Entitymention + instance FromJSON Entitymention where parseJSON = J.genericParseJSON jsonOpts @@ -124,6 +140,8 @@ | PosPunctuation Text -- ^ anyOf ".:,''$#$,", sometimes few together deriving (Show, Eq, Generic) +instance Store.Store PennPOS + instance FromJSON PennPOS where parseJSON (J.String "WP$") = pure WPDollar parseJSON (J.String "PRP$") = pure PRPDollar @@ -170,6 +188,8 @@ | O -- ^ Not a named entity? TODO: check somehow deriving (Show, Eq, Generic) +instance Store.Store NamedEntity + instance FromJSON NamedEntity where parseJSON = J.genericParseJSON jsonOpts @@ -190,6 +210,8 @@ , after :: Text } deriving (Show, Eq, Generic) +instance Store.Store Token + instance FromJSON Token where parseJSON = J.genericParseJSON jsonOpts @@ -206,6 +228,8 @@ , tokens :: [Token] } deriving (Show, Eq, Generic) +instance Store.Store Sentence + instance FromJSON Sentence where parseJSON = J.genericParseJSON jsonOpts @@ -227,6 +251,8 @@ , isRepresentativeMention :: Bool } deriving (Show, Eq, Generic) +instance Store.Store Coref + instance FromJSON Coref where parseJSON = J.genericParseJSON jsonOpts @@ -243,6 +269,8 @@ , corefs :: Corefs } deriving (Show, Eq, Generic) +instance Store.Store Document + instance FromJSON Document where parseJSON = J.genericParseJSON jsonOpts @@ -253,39 +281,113 @@ parseJsonDoc :: Text -> Either String Document parseJsonDoc = J.eitherDecode . S.fromText +-- | Additional options +data LaunchOptions = LaunchOptions + { cacheDb :: Maybe FilePath -- ^ Optional path to a RocksDB file which will be used as a cache + } deriving (Show, Eq) + +instance Default LaunchOptions where + def = LaunchOptions Nothing + -- | Launch CoreNLP with your inputs. This function will put every piece of 'Text' in a separate file, launch CoreNLP subprocess, and parse the results launchCoreNLP :: FilePath -- ^ Path to the directory where you extracted the CoreNLP project + -> LaunchOptions -> [Text] -- ^ List of inputs - -> IO [Either String Document] -- ^ List of parsed results -launchCoreNLP fp texts = - withSystemTempDirectory "corenlp-parser" $ \tempDir -> do - Prelude.putStrLn $ "Temp dir used is is: " <> tempDir - tmpFileNames <- - forM (zip [1 ..] texts) $ \(i :: Integer, txt) -> do - let fname = ("text-" ++ show i ++ ".txt") - T.writeFile (tempDir ++ "/" ++ fname) txt - return fname - withSystemTempFile "filelist.txt" $ \filelistTxt hfilelistTxt -> do - Prelude.putStrLn $ "Filelist.txt: " ++ show filelistTxt - Prelude.putStrLn $ "Temporary files: " ++ show tmpFileNames - let filesList = - T.unlines (map (\x -> S.toText (tempDir <> "/" <> x)) tmpFileNames) - Prelude.putStrLn $ "Filelist.txt filesList: " ++ show filesList - T.hPutStrLn hfilelistTxt (T.strip filesList) - hFlush hfilelistTxt - let spec = - shell - ("java --add-modules java.se.ee -cp \"" ++ - fp ++ - "*\" -Xmx2g edu.stanford.nlp.pipeline.StanfordCoreNLP -annotators tokenize,ssplit,pos,lemma,ner,parse,dcoref -outputFormat json -filelist " <> - filelistTxt) - (_, _, _, processHandle) <- createProcess spec - code <- waitForProcess processHandle - when (code /= ExitSuccess) (error (show code)) - let tmpFileNamesJson = map (<> ".json") tmpFileNames - results <- forM tmpFileNamesJson $ \fname -> T.readFile fname - return (map parseJsonDoc results) + -> IO [ParsedDocument] -- ^ List of parsed results +launchCoreNLP fp' LaunchOptions {..} texts' = do + let fp = ensureEndSlash fp' + case cacheDb of + Nothing -> go Nothing fp texts' + Just cacheFp -> + bracket + (Rocks.open cacheFp def {Rocks.createIfMissing = True}) + Rocks.close + (\db -> go (Just db) fp texts') + where + ensureEndSlash :: String -> String + ensureEndSlash t = + if t !! (Prelude.length t - 1) == '/' + then t + else t <> "/" + go mcacheDb fp texts'' = do + (cachedDocs, texts) <- getCachedDocs mcacheDb texts'' + Prelude.putStrLn $ + "Got documents out of cache: " ++ show (Prelude.length cachedDocs) + if (Prelude.length texts <= 0) + then return cachedDocs + else do + withSystemTempDirectory "corenlp-parser" $ \tempDir -> do + withCurrentDirectory tempDir $ do + Prelude.putStrLn $ "Temp dir used is is: " <> tempDir + tmpFileNames <- + forM (zip [1 ..] texts) $ \(i :: Integer, txt) -> do + let fname = ("text-" ++ show i ++ ".txt") + T.writeFile (tempDir ++ "/" ++ fname) txt + return fname + withSystemTempFile "filelist.txt" $ \filelistTxt hfilelistTxt -> do + Prelude.putStrLn $ "Filelist.txt: " ++ show filelistTxt + let filesList = + T.unlines + (map (\x -> S.toText (tempDir <> "/" <> x)) tmpFileNames) + T.hPutStrLn hfilelistTxt (T.strip filesList) + hFlush hfilelistTxt + let cmd = + "java --add-modules java.se.ee -cp \"" ++ + fp ++ + "*\" -Xmx4g edu.stanford.nlp.pipeline.StanfordCoreNLP -annotators tokenize,ssplit,pos,lemma,ner,parse,dcoref -outputFormat json -filelist " <> + filelistTxt + Prelude.putStrLn $ "Running a command: " ++ cmd + let spec = shell cmd + (_, _, _, processHandle) <- createProcess spec + code <- waitForProcess processHandle + when (code /= ExitSuccess) (error (show code)) + let tmpFileNamesJson = map (<> ".json") tmpFileNames + results <- forM tmpFileNamesJson $ \fname -> T.readFile fname + rv <- extractSuccessDocs (zip texts (map parseJsonDoc results)) + cacheResults mcacheDb rv + return (cachedDocs ++ rv) + getCachedDocs :: Maybe Rocks.DB -> [Text] -> IO ([ParsedDocument], [Text]) + getCachedDocs Nothing texts = return ([], texts) + getCachedDocs (Just rocks) texts = do + (rv :: [Either ParsedDocument Text]) <- + forM texts $ \t -> do + res <- Rocks.get rocks def (hash t) + case res of + Nothing -> return (Right t) + Just bs -> + case Store.decode bs of + Left _e -> return (Right t) + Right x -> return (Left x) + return (partitionEithers rv) + cacheResults Nothing _ = return () + cacheResults (Just rocks) results = do + let batch = map resultToOp results + Rocks.write rocks def batch + return () + resultToOp pd@ParsedDocument {..} = + Rocks.Put (hash origText) (Store.encode pd) + hash t = + S.fromString + (show + (Crypto.hash (S.toStrictByteString t) :: Crypto.Digest Crypto.SHA256)) + +-- | Datatype holding original text and a parsed 'Document' +data ParsedDocument = ParsedDocument + { origText :: Text + , doc :: Document + } deriving (Show, Eq, Generic) + +instance Store.Store ParsedDocument + +-- | Simple function to extract success results and print out errors +extractSuccessDocs :: [(Text, Either String Document)] -> IO [ParsedDocument] +extractSuccessDocs = fmap catMaybes . mapM f + where + f (_t, Left err) = + Prelude.putStrLn ("Error parsing CoreNLP result: " ++ err) >> + return Nothing + f (t, Right r') = return (Just (ParsedDocument t r')) headlines :: Text headlines =