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: 951be5b6ce053014c505b53854ecea04601503a1e77d11bef3189384163fb53f +-- hash: f543ec5c7d7cc3d366a63cb8df782d521cd7dc1a76f423f3fbb4aa43a2b84153 name: corenlp-parser -version: 0.3.0.0 +version: 0.3.0.1 synopsis: Launches CoreNLP and parses the JSON output description: Launches CoreNLP and parses the JSON output category: Natural Language Processing @@ -25,8 +25,11 @@ hs-source-dirs: src ghc-options: -Wall + extra-libraries: + rocksdb build-depends: aeson + , async , base >=4.7 && <5 , cryptonite , data-default @@ -35,6 +38,7 @@ , raw-strings-qq , rocksdb-haskell , safe-exceptions + , split , store , string-class , temporary diff --git a/src/NLP/CoreNLP.hs b/src/NLP/CoreNLP.hs --- a/src/NLP/CoreNLP.hs +++ b/src/NLP/CoreNLP.hs @@ -29,6 +29,8 @@ ) where import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Async import Control.Exception.Safe import Control.Monad (forM, when) import qualified Crypto.Hash as Crypto @@ -37,6 +39,7 @@ import Data.Default import Data.Either import Data.HashMap.Strict (HashMap) +import Data.List.Split (chunksOf) import Data.Maybe import Data.Semigroup import qualified Data.Store as Store @@ -137,7 +140,7 @@ | WRB -- ^ Wh-adverb | LRB -- ^ "-LRB-"? No idea what's this | RRB -- ^ "-RRB-"? No idea what's this - | PosPunctuation Text -- ^ anyOf ".:,''$#$,", sometimes few together + | PosPunctuation -- ^ anyOf ".:,''$#$,", sometimes few together deriving (Show, Eq, Generic) instance Store.Store PennPOS @@ -149,13 +152,13 @@ parseJSON (J.String "-RRB-") = pure RRB parseJSON x = J.genericParseJSON jsonOpts x <|> parsePunctuation x where - parsePunctuation (J.String y) = pure (PosPunctuation y) + parsePunctuation (J.String _) = pure PosPunctuation parsePunctuation _ = fail "Expecting POS to be a String" instance ToJSON PennPOS where toJSON WPDollar = J.String "WP$" toJSON PRPDollar = J.String "PRP$" - toJSON (PosPunctuation t) = J.String t + toJSON PosPunctuation = J.String "." toJSON LRB = J.String "-LRB-" toJSON RRB = J.String "-RRB-" toJSON x = J.genericToJSON jsonOpts x @@ -284,11 +287,21 @@ -- | Additional options data LaunchOptions = LaunchOptions { cacheDb :: Maybe FilePath -- ^ Optional path to a RocksDB file which will be used as a cache + , memSizeMb :: Int -- ^ The "-Xmx" Java parameter + , chunkSize :: Int -- ^ Number of elements by which to split the input. Good for caching upon a failure + , numWorkers :: Int -- ^ Number of CoreNLP workers to launch in parallel } deriving (Show, Eq) instance Default LaunchOptions where - def = LaunchOptions Nothing + def = LaunchOptions Nothing 8096 1000 2 +-- | Got this from https:\/\/stackoverflow.com\/questions\/29155068\/running-parallel-url-downloads-with-a-worker-pool-in-haskell +traverseThrottled :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) +traverseThrottled concLevel action taskContainer = do + sem <- newQSem concLevel + let throttledAction = bracket_ (waitQSem sem) (signalQSem sem) . action + runConcurrently (traverse (Concurrently . throttledAction) taskContainer) + -- | 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 @@ -310,43 +323,55 @@ if t !! (Prelude.length t - 1) == '/' then t else t <> "/" + go :: Maybe Rocks.DB -> FilePath -> [Text] -> IO [ParsedDocument] 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 + withSystemTempDirectory "corenlp-parser" $ \tempDir -> + withCurrentDirectory tempDir $ do + (cachedDocs, texts) <- getCachedDocs mcacheDb texts'' + Prelude.putStrLn $ + "Got documents out of cache: " ++ show (Prelude.length cachedDocs) + res <- + Prelude.concat <$> + traverseThrottled + numWorkers + (goByChunk tempDir mcacheDb fp) + (zip ([1 ..] :: [Integer]) (chunksOf chunkSize texts)) + return (cachedDocs ++ res) + goByChunk tempDir mcacheDb fp (chunkId, texts) = do + Prelude.putStrLn "> goByChunk started" + if Prelude.length texts <= 0 + then return [] 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) + Prelude.putStrLn $ "Temp dir used is: " <> tempDir + tmpFileNames <- + forM (zip [1 ..] texts) $ \(i :: Integer, txt) -> do + let fname = "text-" ++ show chunkId ++ "-" ++ 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 ++ + "*\" -Xmx" ++ + show memSizeMb ++ + "m 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 rv getCachedDocs :: Maybe Rocks.DB -> [Text] -> IO ([ParsedDocument], [Text]) getCachedDocs Nothing texts = return ([], texts) getCachedDocs (Just rocks) texts = do