dictionaries 0.1.0.1 → 0.2.0

raw patch · 7 files changed

+705/−359 lines, 7 filesdep +QuickCheckdep +criteriondep +deepseqdep ~basedep ~bytestringdep ~containersnew-component:exe:benchPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, criterion, deepseq, dictionaries, hspec, random, random-shuffle, tagged

Dependency ranges changed: base, bytestring, containers, directory, exceptions, filepath, text, time, transformers

API changes (from Hackage documentation)

Files

• dictionaries.cabal +68/−1
• src/NLP/Dictionary/StarDict.hs +15/−333
• src/NLP/Dictionary/StarDict/Common.hs +371/−0
• src/NLP/Dictionary/StarDict/InMemory.hs +34/−25
• src/NLP/Dictionary/StarDict/Regular.hs +74/−0
• tests/Benchmark.hs +109/−0
• tests/Test.hs +34/−0

@@ -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+

@@ -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)

@@ -0,0 +1,371 @@+{-|+  Module:      NLP.Dictionary.StarDict.Common+  Copyright:   (c) 2016 Al Zohali+  License:     BSD3+  Maintainer:  Al Zohali <zohl@fmap.me>+  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

@@ -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

@@ -0,0 +1,74 @@+{-|+  Module:      NLP.Dictionary.StarDict.Regular+  Copyright:   (c) 2016 Al Zohali+  License:     BSD3+  Maintainer:  Al Zohali <zohl@fmap.me>+  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

@@ -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+      ]+  ]+

@@ -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+