diff --git a/dictionaries.cabal b/dictionaries.cabal --- a/dictionaries.cabal +++ b/dictionaries.cabal @@ -1,5 +1,5 @@ name: dictionaries -version: 0.1.0.1 +version: 0.2.0 synopsis: Tools to handle StarDict dictionaries. -- description: license: BSD3 @@ -24,7 +24,9 @@ exposed-modules: NLP.Dictionary NLP.Dictionary.StarDict + NLP.Dictionary.StarDict.Common NLP.Dictionary.StarDict.InMemory + NLP.Dictionary.StarDict.Regular build-depends: base >= 4.8.2 && < 4.11 , attoparsec >= 0.10.4.0 && < 0.14 @@ -32,12 +34,77 @@ , bytestring >= 0.10.6.0 && < 0.11 , containers >= 0.5.6.2 && < 0.6 , data-default >= 0.7.1.1 && < 0.8 + , deepseq , directory >= 1.2.2.0 && < 1.4 , exceptions >= 0.8.3 && < 0.9 , filepath >= 1.4.0.0 && < 1.5 + , tagged , text >= 1.2.2.1 && < 1.3 , time >= 1.5.0.1 && < 1.9 , transformers >= 0.4.2.0 && < 0.6 , zlib >= 0.6.1.2 && < 0.7 hs-source-dirs: src default-language: Haskell2010 + + ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + else + ghc-options: -O2 + + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Test.hs + + build-depends: base >= 4.7 && < 5.0 + , QuickCheck >= 2.4 && < 3.0 + , bytestring + , hspec >= 2.0 && < 3.0 + , tagged + , time >= 1.5 && < 1.8 + , containers + , dictionaries + , directory + , filepath + , random + , text + default-language: Haskell2010 + + ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + else + ghc-options: -O2 + + +executable bench + -- type: exitcode-stdio-1.0 + + hs-source-dirs: tests + main-is: Benchmark.hs + + default-language: Haskell2010 + + build-depends: base >= 4.7 && < 5.0 + , bytestring + , criterion >= 0.6.2.1 && < 1.2 + , containers + , dictionaries + , directory + , exceptions + , filepath + , random + , random-shuffle + , tagged + , text + , transformers + , deepseq + + ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + else + ghc-options: -O2 + diff --git a/src/NLP/Dictionary/StarDict.hs b/src/NLP/Dictionary/StarDict.hs --- a/src/NLP/Dictionary/StarDict.hs +++ b/src/NLP/Dictionary/StarDict.hs @@ -7,343 +7,25 @@ = Description Tools for StarDict dictionaries. - To load a dictionary you should call 'mkDictionary' with path to .ifo file - and render function. - Every call of getEntry will perform file reading operation to retrieve - requested data. For in-memory version see 'NLP.Dictionary.StarDict.InMemory'. --} + This module (re)exports core classes that are needed to work with + dictionaries. To create dictionary, use `mkDictionary` method + together with `tag` from one of implementations: + @ + import NLP.Dictionary.StarDict (StarDict(..)) + import qualified NLP.Dictionery.StarDict.Regular as SDR -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} + ... -module NLP.Dictionary.StarDict ( - StarDict (..) - , StarDictException (..) - , mkDictionary + dictionary <- mkDictionary (SDR.tag "/path/to/a/dictionary.ifo") renderer + @ +-} - , mkDataParser - , DataEntry (..) - , Renderer - , checkFiles - , checkGZFiles - - , IfoFile(..) - , IfoFilePath - , readIfoFile - , indexNumberParser - , ifoDateFormat - - , Index - , IndexEntry - , readIndexFile - - , checkDataFile +module NLP.Dictionary.StarDict ( + DataEntry(..) + , Renderer + , StarDict(..) ) where -import Prelude hiding (takeWhile) -import Control.Applicative (liftA2, many) -import Control.Arrow ((***)) -import Control.Monad (when, unless) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Catch (Exception, MonadThrow, throwM) -import Data.Attoparsec.ByteString.Lazy (Result(..), Parser, parse, string, takeWhile, inClass) -import Data.Attoparsec.ByteString.Char8 (isEndOfLine, endOfLine, skipSpace, char) -import Data.Binary.Get (Get, runGet, runGetOrFail, isEmpty) -import Data.Binary.Get (getRemainingLazyByteString, getLazyByteStringNul, getLazyByteString) -import Data.Binary.Get (getWord32be, getWord64be) -import Data.ByteString.Lazy (ByteString) -import Data.Char (chr) -import Data.List (intercalate) -import Data.Map.Strict (Map) -import Data.Maybe (maybeToList) -import Data.Typeable (Typeable) -import Data.Time (parseTimeM, defaultTimeLocale) -import Data.Time.Clock (UTCTime) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8, decodeLatin1) -import System.Directory (doesFileExist, getTemporaryDirectory) -import System.FilePath.Posix (dropExtension, joinPath, takeBaseName, (-<.>), (<.>)) -import System.IO (Handle, IOMode(..), SeekMode(..), withFile, hSeek) -import NLP.Dictionary (Dictionary(..)) -import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BSC8 -import qualified Data.Map.Strict as Map -import qualified Data.Text.Lazy as T - --- | Exceptions that are thrown when something with this module went wrong. -data StarDictException - = WrongIfoFormat FilePath String - -- ^ Thrown when information file (.ifo) has unsupported format. - - | IndexNotFound FilePath - -- ^ Thrown when index file (.idx, .idx.gz) is not found. - - | WrongIndexFormat FilePath String - -- ^ Thrown when index file has unsupported format. - - | DictionaryNotFound FilePath - -- ^ Thrown when dictionary file (.dict, .dict.dz) has unsupported format. - deriving (Eq, Show, Typeable) - -instance Exception StarDictException - - --- | Representation of .ifo file. -data IfoFile = IfoFile { - ifoMagicData :: ByteString - , ifoVersion :: String - , ifoBookName :: Text - , ifoWordCount :: Int - , ifoIdxFileSize :: Int - , ifoIdxOffsetBits :: Maybe Int - , ifoSynWordCount :: Maybe Int - , ifoAuthor :: Maybe Text - , ifoEmail :: Maybe Text - , ifoWebsite :: Maybe Text - , ifoDescription :: Maybe Text - , ifoDate :: Maybe UTCTime - , ifoSameTypeSequence :: Maybe String - , ifoDictType :: Maybe String - } deriving (Eq, Show) - --- | Date format of 'ifoDate' in IfoFile. -ifoDateFormat :: String -ifoDateFormat = "%0Y.%m.%d" - --- | Read .ifo file at the given path. -readIfoFile :: (MonadThrow m, MonadIO m) => FilePath -> m IfoFile -readIfoFile ifoPath = (liftIO . BS.readFile $ ifoPath) >>= parseContents where - parseContents contents = case (parse ifoFile contents) of - (Fail _ _ msg) -> throwM $ WrongIfoFormat ifoPath msg - (Done _ r) -> return r - - expect :: (Eq a, Show a) => String -> a -> [a] -> Parser () - expect name x xs = unless (x `elem` xs) . fail . concat $ [ - name, " must be ", fmts xs, " (", show x, " provided)" - ] where - fmt y = '\'':(show y) ++ "'" - - fmts = \case - [] -> "" - (y:[]) -> fmt y - ys -> (intercalate ", " . map fmt . init $ ys) ++ " or " ++ (fmt . last $ ys) - - justExpect :: (Eq a, Show a) => String -> Maybe a -> [a] -> Parser () - justExpect name mx xs = maybe (return ()) (\x -> expect name x xs) mx - - ifoFile :: Parser IfoFile - ifoFile = do - ifoMagicData <- magicData - expect "magic data" ifoMagicData ["StarDict's dict ifo file"] - - (_, ifoVersion) <- (id *** BSC8.unpack) <$> (endOfLine *> pair (Just "version")) - expect "version" ifoVersion ["2.4.2", "3.0.0"] - - ifoData <- Map.fromList <$> (endOfLine *> (many (pair Nothing) <* endOfLine)) - let get = flip Map.lookup ifoData - let require field = ( $ (get field)) $ maybe - (fail $ "required field " ++ BSC8.unpack field ++ " not found") (return) - - ifoBookName <- decodeUtf8 <$> require "bookname" - ifoWordCount <- read . BSC8.unpack <$> require "wordcount" - ifoIdxFileSize <- read . BSC8.unpack <$> require "idxfilesize" - - let ifoIdxOffsetBits = read . BSC8.unpack <$> get "idxoffsetbits" - justExpect "idxoffsetbits" ifoIdxOffsetBits [32, 64] - - let ifoSynWordCount = read . BSC8.unpack <$> get "synwordcount" - let ifoAuthor = decodeUtf8 <$> get "author" - let ifoEmail = decodeUtf8 <$> get "email" - let ifoWebsite = decodeUtf8 <$> get "website" - let ifoDescription = decodeUtf8 <$> get "description" - - let ifoDate = get "date" >>= parseTimeM False defaultTimeLocale ifoDateFormat . BSC8.unpack - - let ifoSameTypeSequence = BSC8.unpack <$> get "sametypesequence" - - let ifoDictType = BSC8.unpack <$> get "dicttype" - justExpect "dicttype" ifoDictType ["wordnet"] - - return IfoFile {..} - - - magicData :: Parser ByteString - magicData = BS.fromStrict <$> takeWhile (not . isEndOfLine) - - pair :: Maybe ByteString -> Parser (ByteString, ByteString) - pair = pair' . maybe - (takeWhile $ inClass "A-Za-z0-9-_") - (string . BS.toStrict) where - - pair' key = do - k <- BS.fromStrict <$> (skipSpace *> key) - _ <- skipSpace *> char '=' - v <- BS.fromStrict <$> (skipSpace *> takeWhile (not . isEndOfLine)) - return (k, v) - --- | Get 32-bit or 64-bit integer depending on description in the .ifo file. -indexNumberParser :: IfoFile -> Get Int -indexNumberParser IfoFile {..} = case ifoIdxOffsetBits of - (Just 64) -> fromIntegral <$> getWord64be - _ -> fromIntegral <$> getWord32be - --- | Representation of an .idx file. -type Index = Map Text (Int, Int) - --- | Representation of an .idx file entry. -type IndexEntry = (Text, (Int, Int)) - --- | Given .ifo file name and list of extensions, returns first existing file with the same basename. -checkFiles :: IfoFilePath -> [FilePath] -> IO (Maybe FilePath) -checkFiles _ [] = return Nothing -checkFiles ifoPath (ext:exts) = let fn = ifoPath -<.> ext - in (doesFileExist fn) >>= \case - True -> return . Just $ fn - False -> checkFiles ifoPath exts - --- | Given .ifo file name and two lists of extensions, returns first --- existing file with with the same basename and extension from the first --- list or (if such file doesn't exists) from the second list. -checkGZFiles - :: IfoFilePath - -> [FilePath] - -> [FilePath] - -> IO (Maybe (Either FilePath FilePath)) -checkGZFiles ifoPath exts exts' = (checkFiles ifoPath exts) >>= maybe - (fmap (Right <$>) (checkFiles ifoPath exts')) - (return . Just . Left) - --- | Type synonym to distinguish usage of paths. -type IfoFilePath = FilePath - --- | Read .idx (.idx.gz) file. -readIndexFile :: (MonadThrow m, MonadIO m) => IfoFilePath -> Get Int -> m Index -readIndexFile fn num = checkIndexFile fn >>= getIndexContents >>= mkIndex where - - checkIndexFile :: (MonadThrow m, MonadIO m) => IfoFilePath -> m (Either FilePath FilePath) - checkIndexFile ifoPath = (liftIO $ checkGZFiles ifoPath ["idx"] ["idx.gz"]) >>= \case - Nothing -> throwM $ IndexNotFound ifoPath - Just path -> return path - - getIndexContents :: (MonadThrow m, MonadIO m) - => Either FilePath FilePath -> m (FilePath, ByteString) - getIndexContents path = liftIO . fmap (fn,) . postprocess . BS.readFile $ fn where - postprocess = either (const id) (const $ fmap GZip.decompress) path - fn = either id id path - - mkIndex :: (MonadThrow m, MonadIO m) => (FilePath, ByteString) -> m Index - mkIndex (fn, contents) = either - (\(_, _, err) -> throwM $ WrongIndexFormat fn err) - (\(_, _, res) -> return . Map.fromList $ res) - (runGetOrFail getIndexEntries contents) - - getIndexEntries :: Get [IndexEntry] - getIndexEntries = isEmpty >>= \case - True -> return [] - False -> liftA2 (:) getIndexEntry getIndexEntries - - getIndexEntry :: Get IndexEntry - getIndexEntry = (,) <$> (decodeUtf8 <$> getLazyByteStringNul) - <*> ((,) <$> num <*> num) - --- | Returns path of decompressed dictionary. -checkDataFile :: (MonadThrow m, MonadIO m) => IfoFilePath -> m FilePath -checkDataFile ifoPath = (liftIO $ checkGZFiles ifoPath ["dict1"] ["dict.dz"]) >>= \case - Nothing -> throwM $ DictionaryNotFound ifoPath - Just (Left fn) -> return fn - Just (Right fn) -> liftIO $ do - fn' <- (joinPath . (:[(takeBaseName ifoPath) <.> "dict"])) <$> getTemporaryDirectory - GZip.decompress <$> (BS.readFile fn) >>= BS.writeFile fn' - return fn' - --- | Possible dictionary entry formats. -data DataEntry - = UTF8Text Text - | LocaleText Text - | Pango Text - | Phonetics Text - | XDXF Text - | CJK Text - | PowerWord Text - | MediaWiki Text - | HTML Text - | Resource [FilePath] - | WAVEAudio ByteString - | Picture ByteString - | Reserved ByteString - deriving (Eq, Show) - --- | Parser for a list of elements. -getMany :: Get a -> Get [a] -getMany p = isEmpty >>= \case - True -> return [] - False -> liftA2 (:) p (getMany p) - --- | Returns parser based on description in .ifo file. -mkDataParser :: Maybe String -> Get [DataEntry] -mkDataParser = maybe (getMany getGenericEntry) getSpecificEntries where - - getGenericEntry :: Get DataEntry - getGenericEntry = BSC8.head <$> getLazyByteString 1 - >>= getSpecificEntry getLazyByteStringNul - - getSpecificEntries :: [Char] -> Get [DataEntry] - getSpecificEntries cs = sequence $ zipWith getSpecificEntry ps cs where - ps :: [Get ByteString] - ps = reverse . take (length cs) $ getRemainingLazyByteString:(repeat getLazyByteStringNul) - - getSpecificEntry :: Get ByteString -> Char -> Get DataEntry - getSpecificEntry getData = \case - 'm' -> UTF8Text . decodeUtf8 <$> getData - 'l' -> LocaleText . decodeLatin1 <$> getData - 'g' -> Pango . decodeUtf8 <$> getData - 't' -> Phonetics . decodeUtf8 <$> getData - 'x' -> XDXF . decodeUtf8 <$> getData - 'y' -> CJK . decodeUtf8 <$> getData - 'k' -> PowerWord . decodeUtf8 <$> getData - 'w' -> MediaWiki . decodeUtf8 <$> getData - 'h' -> HTML . decodeUtf8 <$> getData - 'n' -> Resource . lines . T.unpack . decodeUtf8 <$> getData - 'r' -> Resource . lines . T.unpack . decodeUtf8 <$> getData - 'W' -> WAVEAudio <$> getData - 'P' -> Picture <$> getData - 'X' -> Reserved <$> getData - _ -> error "type not supported" - --- | Type of function to transform dictionary entries to a text. -type Renderer = DataEntry -> Text - --- | Representation of the dictionary. -data StarDict = StarDict { - sdIfoFile :: IfoFile - , sdIndex :: Index - , sdDataPath :: FilePath - , sdDataParser :: Get [DataEntry] - , sdRender :: Renderer - } - --- | Create dictionary. -mkDictionary :: (MonadThrow m, MonadIO m) => IfoFilePath -> Renderer -> m StarDict -mkDictionary ifoPath sdRender = do - sdIfoFile <- readIfoFile ifoPath - sdIndex <- readIndexFile ifoPath (indexNumberParser sdIfoFile) - sdDataPath <- checkDataFile ifoPath - let sdDataParser = mkDataParser (ifoSameTypeSequence sdIfoFile) - return StarDict {..} - -instance Dictionary StarDict where - getEntries str (StarDict {..}) = withFile sdDataPath ReadMode extractEntries where - - extractEntries :: Handle -> IO [Text] - extractEntries h = mapM (extractEntry h) . maybeToList . Map.lookup str $ sdIndex - - extractEntry :: Handle -> (Int, Int) -> IO Text - extractEntry h (offset, size) = do - hSeek h AbsoluteSeek (fromIntegral offset) - T.concat . map sdRender . runGet sdDataParser <$> BS.hGet h size - +import NLP.Dictionary.StarDict.Common (StarDict(..), DataEntry(..), Renderer) diff --git a/src/NLP/Dictionary/StarDict/Common.hs b/src/NLP/Dictionary/StarDict/Common.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Dictionary/StarDict/Common.hs @@ -0,0 +1,371 @@ +{-| + Module: NLP.Dictionary.StarDict.Common + Copyright: (c) 2016 Al Zohali + License: BSD3 + Maintainer: Al Zohali + Stability: experimental + + = Description + Common functions and types for StarDict dictionaries. +-} + + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} + +module NLP.Dictionary.StarDict.Common ( + StarDictException (..) + + , checkFiles + , checkGZFiles + + , IfoFile(..) + , IfoFilePath + , ifoDateFormat + , readIfoFile + , renderIfoFile + + , IndexEntry + , readIndexFile + , renderIndexFile + , getIndexNumber + , putIndexNumber + + , checkDataFile + + , DataEntry (..) + , Renderer + , mkDataParser + + , StarDict (..) + ) where + +import Prelude hiding (takeWhile) +import Control.Applicative (liftA2, many) +import Control.Arrow ((***)) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Catch (Exception, MonadThrow, throwM) +import Data.Attoparsec.ByteString.Lazy (Result(..), Parser, parse, string, takeWhile, inClass) +import Data.Attoparsec.ByteString.Char8 (isEndOfLine, endOfLine, skipSpace, char) +import Data.Binary.Get (Get, runGetOrFail, isEmpty) +import Data.Binary.Get (getRemainingLazyByteString, getLazyByteStringNul, getLazyByteString) +import Data.Binary.Get (getWord32be, getWord64be) +import Data.Binary.Builder (Builder, fromLazyByteString, empty, toLazyByteString) +import Data.Binary.Builder (putWord64be, putWord32be, singleton) +import Data.ByteString.Lazy (ByteString) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Tagged (Tagged) +import Data.Typeable (Typeable) +import Data.Time (parseTimeM, defaultTimeLocale, formatTime) +import Data.Time.Clock (UTCTime) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8, decodeLatin1) +import NLP.Dictionary (Dictionary) +import System.Directory (doesFileExist, getTemporaryDirectory) +import System.FilePath.Posix (joinPath, takeBaseName, (-<.>), (<.>)) +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC8 +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as T +import Control.DeepSeq (NFData(..)) +import GHC.Generics (Generic) + + +-- | Exceptions that are thrown when something with this module went wrong. +data StarDictException + = WrongIfoFormat FilePath String + -- ^ Thrown when information file (.ifo) has unsupported format. + + | IndexNotFound FilePath + -- ^ Thrown when index file (.idx, .idx.gz) is not found. + + | WrongIndexFormat FilePath String + -- ^ Thrown when index file has unsupported format. + + | DictionaryNotFound FilePath + -- ^ Thrown when dictionary file (.dict, .dict.dz) has unsupported format. + deriving (Eq, Show, Typeable) + +instance Exception StarDictException + + +-- | Type synonym to distinguish usage of paths. +type IfoFilePath = FilePath + +-- | Representation of .ifo file. +data IfoFile = IfoFile { + ifoMagicData :: ByteString -- ^ Corresponds to the first string in the file. + , ifoVersion :: String -- ^ Corresponds to version field. + , ifoBookName :: Text -- ^ Corresponds to bookname field. + , ifoWordCount :: Int -- ^ Corresponds to wordcount field. + , ifoIdxFileSize :: Int -- ^ Corresponds to idxfilesize field. + , ifoIdxOffsetBits :: Maybe Int -- ^ Corresponds to idxoffsetbits field. + , ifoSynWordCount :: Maybe Int -- ^ Corresponds to synwordcount field. + , ifoAuthor :: Maybe Text -- ^ Corresponds to author field. + , ifoEmail :: Maybe Text -- ^ Corresponds to email field. + , ifoWebsite :: Maybe Text -- ^ Corresponds to website field. + , ifoDescription :: Maybe Text -- ^ Corresponds to description field. + , ifoDate :: Maybe UTCTime -- ^ Corresponds to date field. + , ifoSameTypeSequence :: Maybe String -- ^ Corresponds to sametypesequence field. + , ifoDictType :: Maybe String + } deriving (Eq, Show, Generic) + +instance NFData IfoFile + +-- | Date format of 'ifoDate' in IfoFile. +ifoDateFormat :: String +ifoDateFormat = "%0Y.%m.%d" + +-- | Read .ifo file at the given path. +readIfoFile :: (MonadThrow m, MonadIO m) => FilePath -> m IfoFile +readIfoFile ifoPath = (liftIO . BS.readFile $ ifoPath) >>= parseContents where + parseContents contents = case (parse ifoFile contents) of + (Fail _ _ msg) -> throwM $ WrongIfoFormat ifoPath msg + (Done _ r) -> return r + + expect :: (Eq a, Show a) => String -> a -> [a] -> Parser () + expect name x xs = unless (x `elem` xs) . fail . concat $ [ + name, " must be ", fmts xs, " (", show x, " provided)" + ] where + fmt y = '\'':(show y) ++ "'" + + fmts = \case + [] -> "" + (y:[]) -> fmt y + ys -> (intercalate ", " . map fmt . init $ ys) ++ " or " ++ (fmt . last $ ys) + + justExpect :: (Eq a, Show a) => String -> Maybe a -> [a] -> Parser () + justExpect name mx xs = maybe (return ()) (\x -> expect name x xs) mx + + ifoFile :: Parser IfoFile + ifoFile = do + ifoMagicData <- magicData + expect "magic data" ifoMagicData ["StarDict's dict ifo file"] + + (_, ifoVersion) <- (id *** BSC8.unpack) <$> (endOfLine *> pair (Just "version")) + expect "version" ifoVersion ["2.4.2", "3.0.0"] + + ifoData <- Map.fromList <$> (endOfLine *> (many (pair Nothing) <* endOfLine)) + let get = flip Map.lookup ifoData + let require field = ( $ (get field)) $ maybe + (fail $ "required field " ++ BSC8.unpack field ++ " not found") (return) + + ifoBookName <- decodeUtf8 <$> require "bookname" + ifoWordCount <- read . BSC8.unpack <$> require "wordcount" + ifoIdxFileSize <- read . BSC8.unpack <$> require "idxfilesize" + + let ifoIdxOffsetBits = read . BSC8.unpack <$> get "idxoffsetbits" + justExpect "idxoffsetbits" ifoIdxOffsetBits [32, 64] + + let ifoSynWordCount = read . BSC8.unpack <$> get "synwordcount" + let ifoAuthor = decodeUtf8 <$> get "author" + let ifoEmail = decodeUtf8 <$> get "email" + let ifoWebsite = decodeUtf8 <$> get "website" + let ifoDescription = decodeUtf8 <$> get "description" + + let ifoDate = get "date" >>= parseTimeM False defaultTimeLocale ifoDateFormat . BSC8.unpack + + let ifoSameTypeSequence = BSC8.unpack <$> get "sametypesequence" + + let ifoDictType = BSC8.unpack <$> get "dicttype" + justExpect "dicttype" ifoDictType ["wordnet"] + + return IfoFile {..} + + + magicData :: Parser ByteString + magicData = BS.fromStrict <$> takeWhile (not . isEndOfLine) + + pair :: Maybe ByteString -> Parser (ByteString, ByteString) + pair = pair' . maybe + (takeWhile $ inClass "A-Za-z0-9-_") + (string . BS.toStrict) where + + pair' key = do + k <- BS.fromStrict <$> (skipSpace *> key) + _ <- skipSpace *> char '=' + v <- BS.fromStrict <$> (skipSpace *> takeWhile (not . isEndOfLine)) + return (k, v) + +-- | Generates .ifo file contents based on 'IfoFile' +renderIfoFile :: IfoFile -> Text +renderIfoFile IfoFile {..} = T.intercalate "\n" $ [ + decodeUtf8 ifoMagicData + , "version=" <> (T.pack ifoVersion) + , "bookname=" <> ifoBookName + , "wordcount=" <> (T.pack . show $ ifoWordCount) + , "idxfilesize=" <> (T.pack . show $ ifoIdxFileSize) + ] ++ catMaybes [ + (("idxoffsetbits=" <>) . T.pack . show) <$> ifoIdxOffsetBits + , (("synwordcount=" <>) . T.pack . show) <$> ifoSynWordCount + , ("author=" <>) <$> ifoAuthor + , ("email=" <>) <$> ifoEmail + , ("website=" <>) <$> ifoWebsite + , ("description=" <>) <$> ifoDescription + , (("date=" <>) . T.pack + . formatTime defaultTimeLocale ifoDateFormat) <$> ifoDate + , (("sametypesequence=" <>) . T.pack) <$> ifoSameTypeSequence + , (("dicttype=" <>) . T.pack) <$> ifoDictType + ] + +-- | Get 32-bit or 64-bit integer depending on description in the .ifo file. +getIndexNumber :: Maybe Int -> Get Int +getIndexNumber = \case + (Just 64) -> fromIntegral <$> getWord64be + _ -> fromIntegral <$> getWord32be + +-- | Put 32-bit or 64-bit integer depending on description in the .ifo file. +putIndexNumber :: Maybe Int -> (Int -> Builder) +putIndexNumber = \case + (Just 64) -> putWord64be . fromIntegral + _ -> putWord32be . fromIntegral + +-- | Representation of an .idx file entry. +type IndexEntry = (Text, (Int, Int)) + +-- | Given .ifo file name and list of extensions, returns first existing file with the same basename. +checkFiles :: IfoFilePath -> [FilePath] -> IO (Maybe FilePath) +checkFiles _ [] = return Nothing +checkFiles ifoPath (ext:exts) = let fn = ifoPath -<.> ext + in (doesFileExist fn) >>= \case + True -> return . Just $ fn + False -> checkFiles ifoPath exts + +-- | Given .ifo file name and two lists of extensions, returns first +-- existing file with with the same basename and extension from the first +-- list or (if such file doesn't exists) from the second list. +checkGZFiles + :: IfoFilePath + -> [FilePath] + -> [FilePath] + -> IO (Maybe (Either FilePath FilePath)) +checkGZFiles ifoPath exts exts' = (checkFiles ifoPath exts) >>= maybe + (fmap (Right <$>) (checkFiles ifoPath exts')) + (return . Just . Left) + + +-- | Read .idx (.idx.gz) file. +readIndexFile :: (MonadThrow m, MonadIO m) => IfoFilePath -> Get Int -> m [IndexEntry] +readIndexFile fn num = checkIndexFile fn >>= getIndexContents >>= mkIndex where + + checkIndexFile :: (MonadThrow m, MonadIO m) => IfoFilePath -> m (Either FilePath FilePath) + checkIndexFile ifoPath = (liftIO $ checkGZFiles ifoPath ["idx"] ["idx.gz"]) >>= \case + Nothing -> throwM $ IndexNotFound ifoPath + Just path -> return path + + getIndexContents :: (MonadIO m) + => Either FilePath FilePath -> m (FilePath, ByteString) + getIndexContents path = liftIO . fmap (fn',) . postprocess . BS.readFile $ fn' where + postprocess = either (const id) (const $ fmap GZip.decompress) path + fn' = either id id path + + mkIndex :: (MonadThrow m) => (FilePath, ByteString) -> m [IndexEntry] + mkIndex (fn', contents) = either + (\(_, _, err) -> throwM $ WrongIndexFormat fn' err) + (\(_, _, res) -> return $ res) + (runGetOrFail getIndexEntries contents) + + getIndexEntries :: Get [IndexEntry] + getIndexEntries = isEmpty >>= \case + True -> return [] + False -> liftA2 (:) getIndexEntry getIndexEntries + + getIndexEntry :: Get IndexEntry + getIndexEntry = (,) <$> (decodeUtf8 <$> getLazyByteStringNul) + <*> ((,) <$> num <*> num) + +-- | Generates .idx file contents based on 'Index'. +renderIndexFile :: [IndexEntry] -> (Int -> Builder) -> ByteString +renderIndexFile entries putNum = toLazyByteString $ buildIndex entries where + + buildIndex [] = empty + buildIndex (e:es) = putEntry e <> buildIndex es + + putEntry (entry, (offset, size)) = foldr1 (<>) [ + (fromLazyByteString . encodeUtf8 $ entry) + , singleton 0 + , putNum offset + , putNum size + ] + + +-- | Returns path of decompressed dictionary. +checkDataFile :: (MonadThrow m, MonadIO m) => IfoFilePath -> m FilePath +checkDataFile ifoPath = (liftIO $ checkGZFiles ifoPath ["dict"] ["dict.dz"]) >>= \case + Nothing -> throwM $ DictionaryNotFound ifoPath + Just (Left fn) -> return fn + Just (Right fn) -> liftIO $ do + fn' <- (joinPath . (:[(takeBaseName ifoPath) <.> "dict"])) <$> getTemporaryDirectory + GZip.decompress <$> (BS.readFile fn) >>= BS.writeFile fn' + return fn' + + +-- | Possible dictionary entry formats. +data DataEntry + = UTF8Text Text + | LocaleText Text + | Pango Text + | Phonetics Text + | XDXF Text + | CJK Text + | PowerWord Text + | MediaWiki Text + | HTML Text + | Resource [FilePath] + | WAVEAudio ByteString + | Picture ByteString + | Reserved ByteString + deriving (Eq, Show) + +-- | Parser for a list of elements. +getMany :: Get a -> Get [a] +getMany p = isEmpty >>= \case + True -> return [] + False -> liftA2 (:) p (getMany p) + +-- | Returns parser based on description in .ifo file. +mkDataParser :: Maybe String -> Get [DataEntry] +mkDataParser = maybe (getMany getGenericEntry) getSpecificEntries where + + getGenericEntry :: Get DataEntry + getGenericEntry = BSC8.head <$> getLazyByteString 1 + >>= getSpecificEntry getLazyByteStringNul + + getSpecificEntries :: [Char] -> Get [DataEntry] + getSpecificEntries cs = sequence $ zipWith getSpecificEntry ps cs where + ps :: [Get ByteString] + ps = reverse . take (length cs) $ getRemainingLazyByteString:(repeat getLazyByteStringNul) + + getSpecificEntry :: Get ByteString -> Char -> Get DataEntry + getSpecificEntry getData = \case + 'm' -> UTF8Text . decodeUtf8 <$> getData + 'l' -> LocaleText . decodeLatin1 <$> getData + 'g' -> Pango . decodeUtf8 <$> getData + 't' -> Phonetics . decodeUtf8 <$> getData + 'x' -> XDXF . decodeUtf8 <$> getData + 'y' -> CJK . decodeUtf8 <$> getData + 'k' -> PowerWord . decodeUtf8 <$> getData + 'w' -> MediaWiki . decodeUtf8 <$> getData + 'h' -> HTML . decodeUtf8 <$> getData + 'n' -> Resource . lines . T.unpack . decodeUtf8 <$> getData + 'r' -> Resource . lines . T.unpack . decodeUtf8 <$> getData + 'W' -> WAVEAudio <$> getData + 'P' -> Picture <$> getData + 'X' -> Reserved <$> getData + _ -> error "type not supported" + +-- | Type of function to transform dictionary entries to a text. +type Renderer = DataEntry -> Text + + +-- | Classtype for stardict dictionaries. +class (Dictionary d) => StarDict d where + getIfoFile :: d -> IfoFile + mkDictionary :: (MonadThrow m, MonadIO m) => Tagged d IfoFilePath -> Renderer -> m d diff --git a/src/NLP/Dictionary/StarDict/InMemory.hs b/src/NLP/Dictionary/StarDict/InMemory.hs --- a/src/NLP/Dictionary/StarDict/InMemory.hs +++ b/src/NLP/Dictionary/StarDict/InMemory.hs @@ -6,50 +6,45 @@ Stability: experimental = Description - In-memory version of 'NLP.Dictionary.StarDict'. + Implementation of an in-memory dictionary. + All the entries will be loaded in the beginning into RAM, thus + allowing faster access for the next queries. -} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} -module NLP.Dictionary.StarDict.InMemory ( - StarDict (..) - , mkDictionary - ) where +module NLP.Dictionary.StarDict.InMemory (tag) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Catch (MonadThrow) -import Data.Binary.Get (Get, getWord32be) +import Control.DeepSeq (NFData) +import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (ByteString) +import Data.Map.Strict (Map) import Data.Maybe (maybeToList) +import Data.Tagged (Tagged(..), untag) import Data.Text.Lazy (Text) import Data.Text.Lazy.Encoding (decodeUtf8) +import GHC.Generics (Generic) import NLP.Dictionary (Dictionary(..)) -import NLP.Dictionary.StarDict (IfoFile(..), IfoFilePath, readIfoFile, indexNumberParser) -import NLP.Dictionary.StarDict (Index, readIndexFile, checkDataFile, DataEntry(..), Renderer) -import NLP.Dictionary.StarDict (mkDataParser) +import NLP.Dictionary.StarDict.Common (IfoFile(..), IfoFilePath, readIfoFile, getIndexNumber, StarDict(..)) +import NLP.Dictionary.StarDict.Common (readIndexFile, checkDataFile, Renderer) import qualified Data.ByteString.Lazy as BS import qualified Data.Map.Strict as Map --- | Representation of dictionary. -data StarDict = StarDict { + +type Index = Map Text (Int, Int) + +data Implementation = Implementation { sdIfoFile :: IfoFile , sdIndex :: Index , sdData :: ByteString - , sdDataParser :: Get [DataEntry] , sdRender :: Renderer - } + } deriving Generic --- | Create dictionary. -mkDictionary :: (MonadThrow m, MonadIO m) => IfoFilePath -> Renderer -> m StarDict -mkDictionary ifoPath sdRender = do - sdIfoFile <- readIfoFile ifoPath - sdIndex <- readIndexFile ifoPath (indexNumberParser sdIfoFile) - sdData <- checkDataFile ifoPath >>= liftIO . BS.readFile - let sdDataParser = mkDataParser (ifoSameTypeSequence sdIfoFile) - return StarDict {..} +instance NFData Implementation -instance Dictionary StarDict where - getEntries str (StarDict {..}) = return extractEntries where +instance Dictionary Implementation where + getEntries str (Implementation {..}) = return extractEntries where extractEntries :: [Text] extractEntries = map extractEntry . maybeToList . Map.lookup str $ sdIndex @@ -58,3 +53,17 @@ extractEntry (offset, size) = decodeUtf8 . BS.take (fromIntegral size) . BS.drop (fromIntegral offset) $ sdData + +instance StarDict Implementation where + getIfoFile = sdIfoFile + + mkDictionary taggedIfoPath sdRender = do + let ifoPath = untag taggedIfoPath + sdIfoFile <- readIfoFile ifoPath + sdIndex <- Map.fromList <$> readIndexFile ifoPath (getIndexNumber . ifoIdxOffsetBits $ sdIfoFile) + sdData <- checkDataFile ifoPath >>= liftIO . BS.readFile + return Implementation {..} + +-- | Tag for ifoPath to distinct dictionary type. +tag :: IfoFilePath -> Tagged Implementation IfoFilePath +tag = Tagged diff --git a/src/NLP/Dictionary/StarDict/Regular.hs b/src/NLP/Dictionary/StarDict/Regular.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Dictionary/StarDict/Regular.hs @@ -0,0 +1,74 @@ +{-| + Module: NLP.Dictionary.StarDict.Regular + Copyright: (c) 2016 Al Zohali + License: BSD3 + Maintainer: Al Zohali + Stability: experimental + + = Description + Tools for StarDict dictionaries. + Every call of 'getEntries' will perform file reading operation to + retrieve requested data. For faster access see + 'NLP.Dictionary.StarDict.InMemory'. +-} + + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} + +module NLP.Dictionary.StarDict.Regular (tag) where + +import Prelude hiding (takeWhile) +import Data.Binary.Get (runGet) +import Data.Map.Strict (Map) +import Data.Maybe (maybeToList) +import Data.Text.Lazy (Text) +import System.IO (Handle, IOMode(..), SeekMode(..), withFile, hSeek) +import NLP.Dictionary (Dictionary(..)) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as T +import Control.DeepSeq (NFData(..)) +import GHC.Generics (Generic) +import NLP.Dictionary.StarDict.Common (StarDict(..), IfoFile(..), readIfoFile, readIndexFile, getIndexNumber, checkDataFile, mkDataParser, Renderer, IfoFilePath) +import Data.Tagged (Tagged(..), untag) + + +type Index = Map Text (Int, Int) + +data Implementation = Implementation { + sdIfoFile :: IfoFile + , sdIndex :: Index + , sdDataPath :: FilePath + , sdRender :: Renderer + } deriving Generic + +instance NFData Implementation + +instance Dictionary Implementation where + getEntries str (Implementation {..}) = withFile sdDataPath ReadMode extractEntries where + + extractEntries :: Handle -> IO [Text] + extractEntries h = mapM (extractEntry h) . maybeToList . Map.lookup str $ sdIndex + + extractEntry :: Handle -> (Int, Int) -> IO Text + extractEntry h (offset, size) = do + hSeek h AbsoluteSeek (fromIntegral offset) + T.concat . map sdRender . runGet (mkDataParser . ifoSameTypeSequence $ sdIfoFile) <$> BS.hGet h size + +instance StarDict Implementation where + getIfoFile = sdIfoFile + + mkDictionary taggedIfoPath sdRender = do + let ifoPath = untag taggedIfoPath + sdIfoFile <- readIfoFile ifoPath + sdIndex <- Map.fromList <$> readIndexFile ifoPath (getIndexNumber . ifoIdxOffsetBits $ sdIfoFile) + sdDataPath <- checkDataFile ifoPath + return Implementation {..} + +-- | Tag for ifoPath to distinct dictionary type. +tag :: IfoFilePath -> Tagged Implementation IfoFilePath +tag = Tagged diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs new file mode 100644 --- /dev/null +++ b/tests/Benchmark.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE BangPatterns #-} + +import Control.DeepSeq (NFData(..)) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class (MonadIO) +import Criterion (Benchmark, bench, nfIO, env) +import Criterion.Main (bgroup, defaultMain) +import Data.List (intercalate) +import NLP.Dictionary (Dictionary(..)) +import NLP.Dictionary.StarDict (StarDict(..)) +import NLP.Dictionary.StarDict.Common (IfoFilePath) +import System.Random (getStdGen) +import System.Random.Shuffle (shuffle') +import Utils (generateDictionary, generateStarDict, renderId) +import qualified NLP.Dictionary.StarDict.Regular as SDR +import qualified NLP.Dictionary.StarDict.InMemory as SDIM + + +data DictionaryWrapper = forall d. (NFData d, Dictionary d) => WrapDictionary d + +wrapDictionary :: (NFData d, Dictionary d) => d -> DictionaryWrapper +wrapDictionary = WrapDictionary + +instance Dictionary DictionaryWrapper where + getEntries name (WrapDictionary d) = getEntries name d + +instance NFData DictionaryWrapper where + rnf (WrapDictionary !_) = () + + +data DictionaryType + = Regular + | InMemory + deriving (Eq, Show, Enum, Bounded) + +mkWrappedDictionary :: (MonadIO m, MonadThrow m) + => DictionaryType + -> IfoFilePath + -> m DictionaryWrapper +mkWrappedDictionary Regular = \p -> wrapDictionary <$> mkDictionary (SDR.tag p) renderId +mkWrappedDictionary InMemory = \p -> wrapDictionary <$> mkDictionary (SDIM.tag p) renderId + + +around :: Int -> (Int, Int) +around x = let dx = min (x `div` 10) 1 in (x - dx, x + dx) + +mkName :: Int -> Int -> Int -> String +mkName dictionarySize textSize wordSize = intercalate "_" $ [ + show dictionarySize + , show textSize + , show wordSize + ] + + +benchLoading :: Int -> Int -> Int -> DictionaryType -> Benchmark +benchLoading dictionarySize textSize wordSize dictionaryType = env + (generateDictionary + dictionarySize + (around textSize) + (around wordSize) + >>= generateStarDict) + $ \starDictPath -> bench (mkName dictionarySize textSize wordSize) $ do + nfIO $ (mkWrappedDictionary dictionaryType starDictPath) + + +benchAccessing :: Int -> Int -> Int -> DictionaryType -> Benchmark +benchAccessing dictionarySize textSize wordSize dictionaryType = env + (do + dict <- generateDictionary + dictionarySize + (around textSize) + (around wordSize) + + sampleWords <- fmap (take 10) + . fmap (shuffle' (map fst dict) (length dict)) + $ getStdGen + + starDict <- generateStarDict dict >>= mkWrappedDictionary dictionaryType + + return (starDict, sampleWords)) + + $ \ ~(starDict, sampleWords) -> bench (mkName dictionarySize textSize wordSize) $ do + nfIO $ mapM (flip getEntries starDict) sampleWords + + +benchDictionaries :: ([DictionaryType -> Benchmark]) -> [Benchmark] +benchDictionaries bs = map + (\dt -> bgroup (show dt) (map ($ dt) bs)) + [minBound..maxBound] + + +main :: IO () +main = defaultMain [ + bgroup "Loading" . benchDictionaries $ [ + benchLoading 100 100 100 + , benchLoading 500 100 100 + , benchLoading 100 500 100 + , benchLoading 100 100 500 + ] + , bgroup "Accessing" . benchDictionaries $ [ + benchAccessing 100 100 100 + , benchAccessing 500 100 100 + , benchAccessing 100 500 100 + , benchAccessing 100 100 500 + ] + ] + diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +import NLP.Dictionary (getEntries) +import NLP.Dictionary.StarDict (StarDict(..)) +import Test.Hspec (Spec, hspec, describe, it, context, shouldBe) +import Utils (generateDictionary, generateStarDict, renderId) +import qualified NLP.Dictionary.StarDict.Regular as SDR + + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "RandomDictionary" randomDictionary + +randomDictionary :: Spec +randomDictionary = do + + let generateDictionaries = do + dictionary <- generateDictionary 10 (5, 15) (1, 10) + starDictPath <- generateStarDict dictionary + starDict <- mkDictionary (SDR.tag starDictPath) renderId + return (dictionary, starDict) + + context "when getting entries" $ do + it "matches every entry in the dictionary" $ do + (dictionary, starDict) <- generateDictionaries + mapM_ (\(name, entry) -> shouldBe [entry] =<< getEntries name starDict) dictionary + + it "doesn't match missing entry" $ do + (_, starDict) <- generateDictionaries + shouldBe [] =<< getEntries "# not found" starDict +