diff --git a/hist-pl-lexicon.cabal b/hist-pl-lexicon.cabal --- a/hist-pl-lexicon.cabal +++ b/hist-pl-lexicon.cabal @@ -1,5 +1,5 @@ name: hist-pl-lexicon -version: 0.5.0 +version: 0.6.0 synopsis: A binary representation of the historical dictionary of Polish description: The library provides a binary representation of the historical @@ -28,10 +28,10 @@ , directory , filepath , transformers - , lazy-io >= 0.1 && < 0.2 - , dawg >= 0.9 && < 0.10 + , pipes >= 3.3 && < 3.4 + , dawg >= 0.10 && < 0.11 , hist-pl-types >= 0.1 && < 0.2 - , hist-pl-dawg >= 0.1 && < 0.2 + , hist-pl-dawg >= 0.2 && < 0.3 ghc-options: -Wall diff --git a/src/NLP/HistPL/Binary.hs b/src/NLP/HistPL/Binary.hs --- a/src/NLP/HistPL/Binary.hs +++ b/src/NLP/HistPL/Binary.hs @@ -9,10 +9,10 @@ import Prelude hiding (lookup) import Control.Applicative ((<$>)) +import Control.Proxy import System.FilePath (()) import Data.Binary (encodeFile, decodeFile) import qualified Data.Text as T -import qualified Control.Monad.LazyIO as LazyIO import NLP.HistPL.Types import NLP.HistPL.Binary.Util @@ -26,22 +26,21 @@ -- | Lookup entry with a given `lexID`. load :: FilePath -> T.Text -> IO LexEntry -load path i = tryLoad path i >>= - maybe (fail "load: failed to load the entry") return +load path i = decodeFile (path T.unpack i) -- | Lookup entry with a given `lexID`. tryLoad :: FilePath -> T.Text -> IO (Maybe LexEntry) -tryLoad path i = maybeErr $ decodeFile (path T.unpack i) +tryLoad path i = maybeErr $ load path i -- | Get a list of entry identifiers stored in the dictionary. -dictIDs :: FilePath -> IO [T.Text] -dictIDs path = map T.pack <$> loadContents path +dictIDs :: Proxy p => FilePath -> () -> Producer p T.Text IO () +dictIDs path () = runIdentityP $ do + xs <- map T.pack <$> lift (getUsefulContents path) + fromListS xs () -- | Load all lexical entries in a lazy manner. -loadAll :: FilePath -> IO [LexEntry] -loadAll path = do - ids <- dictIDs path - LazyIO.forM ids $ load path +loadAll :: Proxy p => FilePath -> () -> Producer p LexEntry IO () +loadAll path = dictIDs path >-> mapMD (load path) diff --git a/src/NLP/HistPL/Binary/Util.hs b/src/NLP/HistPL/Binary/Util.hs --- a/src/NLP/HistPL/Binary/Util.hs +++ b/src/NLP/HistPL/Binary/Util.hs @@ -2,7 +2,7 @@ module NLP.HistPL.Binary.Util -( loadContents +( getUsefulContents , emptyDirectory , maybeErr , maybeT @@ -18,15 +18,15 @@ -- | Load the directory contents. -loadContents :: FilePath -> IO [FilePath] -loadContents path = do - xs <- getDirectoryContents path - return [x | x <- xs, x /= ".", x /= ".."] +getUsefulContents :: FilePath -> IO [FilePath] +getUsefulContents + = fmap (filter (`notElem` [".", ".."])) + . getDirectoryContents -- | Check if the directory is empty. emptyDirectory :: FilePath -> IO Bool -emptyDirectory path = null <$> loadContents path +emptyDirectory path = null <$> getUsefulContents path maybeErr :: MonadIO m => IO a -> m (Maybe a) diff --git a/src/NLP/HistPL/Lexicon.hs b/src/NLP/HistPL/Lexicon.hs --- a/src/NLP/HistPL/Lexicon.hs +++ b/src/NLP/HistPL/Lexicon.hs @@ -12,7 +12,7 @@ > import qualified NLP.HistPL.Lexicon as H - Use `build` and `loadAll` functions to save/load + Use `save` and `load` functions to save/load the entire dictionary in/from a given directory. To search the dictionary, open the binary directory with an @@ -35,7 +35,7 @@ [["dufliwy"]] Finally, if you need to follow an ID pointer kept in one entry - as a reference to another one, use the `load'` or `tryLoad'` + as a reference to another one, use the `loadI` or `tryLoadI` functions. -} @@ -56,18 +56,21 @@ -- ** By Form , lookup , lookupMany +-- ** By Prefix +, nthSuffix +, withPrefix -- ** By Key , dictKeys -, tryLoad -, load +, tryLoadK +, loadK -- ** By ID , dictIDs -, tryLoad' -, load' +, tryLoadI +, loadI -- * Conversion -, build -, loadAll +, save +, load -- * Modules -- $modules @@ -75,23 +78,23 @@ ) where -import Prelude hiding (lookup) -import Control.Applicative ((<$>)) -import Control.Monad (unless, guard) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.Trans.Maybe (MaybeT (..)) -import qualified Control.Monad.LazyIO as LazyIO -import System.IO.Unsafe (unsafeInterleaveIO) -import System.FilePath (()) -import System.Directory +import Prelude hiding (lookup) +import Control.Applicative ((<$>)) +import Control.Arrow (first, second) +import Control.Monad (unless, guard) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.Proxy +import qualified Control.Proxy.Trans.State as S +import System.FilePath (()) +import System.Directory ( createDirectoryIfMissing, createDirectory, doesDirectoryExist ) -import Data.List (mapAccumL) -import Data.Binary (Binary, put, get, encodeFile, decodeFile) +import Data.List (foldl') +import Data.Binary (Binary, put, get, encodeFile, decodeFile) import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Data.DAWG.Dynamic as DD +import qualified Data.DAWG.Dynamic as DM import qualified NLP.HistPL.Binary as B import NLP.HistPL.Binary.Util @@ -160,24 +163,6 @@ -------------------------------------------------------- --- Computing keys --------------------------------------------------------- - - -getKey :: DD.DAWG Char Int -> LexEntry -> (DD.DAWG Char Int, Key) -getKey m x = - let main = proxy x - path = T.unpack main - num = maybe 0 id (DD.lookup path m) + 1 - key = D.Key main num - in (DD.insert path num m, key) - - -getKeys :: [LexEntry] -> [Key] -getKeys = snd . mapAccumL getKey DD.empty - - --------------------------------------------------------- -- Keys storage -------------------------------------------------------- @@ -204,16 +189,14 @@ B.save (path entryDir) x --- -- | Load entry from a disk by its key. --- loadEntry :: FilePath -> Key -> IO LexEntry --- loadEntry path key = tryLoadEntry path key >>= --- maybe (fail "load: failed to load the entry") return +-- | Load entry from a disk by its key. +loadEntry :: FilePath -> Key -> IO LexEntry +loadEntry path = B.load (path entryDir) <=< loadKey path -- | Load entry from a disk by its key. tryLoadEntry :: FilePath -> Key -> IO (Maybe LexEntry) -tryLoadEntry path key = maybeErr $ do - B.load (path entryDir) =<< loadKey path key +tryLoadEntry path = maybeErr . loadEntry path -------------------------------------------------------- @@ -232,7 +215,8 @@ } --- | Code of word form origin. +-- | Code of a word form origin. See the `save` function to +-- learn why do we provide this information. data Code = Orig -- ^ only from historical dictionary | Both -- ^ from both historical and another dictionary @@ -256,10 +240,11 @@ -- constitute a dictionary. tryOpen :: FilePath -> IO (Maybe HistPL) tryOpen path = runMaybeT $ do - formMap' <- maybeErrT $ decodeFile (path formFile) - doesExist <- liftIO $ doesDirectoryExist (path entryDir) + formMap <- maybeErrT $ decodeFile (path formFile) + -- doesExist <- liftIO $ doesDirectoryExist (path entryDir) + doesExist <- lift $ doesDirectoryExist (path entryDir) guard doesExist - return $ HistPL path formMap' + return $ HistPL path formMap -- | Open the binary dictionary residing in the given directory. @@ -271,49 +256,52 @@ -- | List of dictionary keys. -dictKeys :: HistPL -> IO [Key] -dictKeys hpl = map parseKey <$> loadContents (dictPath hpl keyDir) +dictKeys :: Proxy p => HistPL -> () -> Producer p Key IO () +dictKeys hpl () = runIdentityP $ do + let getPaths = getUsefulContents $ dictPath hpl keyDir + xs <- map parseKey <$> lift getPaths + fromListS xs () --- | Load lexical entry given its key. Return `Nothing` if there +-- | Load lexical entry given its key. Raise error if there -- is no entry with such a key. -tryLoad :: HistPL -> Key -> IO (Maybe LexEntry) -tryLoad hpl key = unsafeInterleaveIO $ tryLoadEntry (dictPath hpl) key +loadK :: HistPL -> Key -> IO LexEntry +loadK hpl = loadEntry (dictPath hpl) --- | Load lexical entry given its key. Raise error if there +-- | Load lexical entry given its key. Return `Nothing` if there -- is no entry with such a key. -load :: HistPL -> Key -> IO LexEntry -load hpl key = tryLoad hpl key >>= maybe - (fail $ "load: failed to open entry with the " ++ show key ++ " key") - return +tryLoadK :: HistPL -> Key -> IO (Maybe LexEntry) +tryLoadK hpl = tryLoadEntry (dictPath hpl) -- | List of dictionary IDs. -dictIDs :: HistPL -> IO [T.Text] -dictIDs hpl = map T.pack <$> loadContents (dictPath hpl entryDir) - - --- | Load lexical entry given its ID. Return `Nothing` if there --- is no entry with such ID. -tryLoad' :: HistPL -> T.Text -> IO (Maybe LexEntry) -tryLoad' hpl i = unsafeInterleaveIO $ B.tryLoad (dictPath hpl entryDir) i +dictIDs :: Proxy p => HistPL -> () -> Producer p T.Text IO () +dictIDs hpl () = runIdentityP $ do + let getPaths = getUsefulContents $ dictPath hpl entryDir + xs <- map T.pack <$> lift getPaths + fromListS xs () -- | Load lexical entry given its ID. Raise error if there -- is no entry with such a key. -load' :: HistPL -> T.Text -> IO LexEntry -load' hpl i = tryLoad' hpl i >>= maybe - (fail $ "load': failed to load entry with the " ++ T.unpack i ++ " ID") - return +loadI :: HistPL -> T.Text -> IO LexEntry +loadI hpl i = B.load (dictPath hpl entryDir) i +-- | Load lexical entry given its ID. Return `Nothing` if there +-- is no entry with such ID. +tryLoadI :: HistPL -> T.Text -> IO (Maybe LexEntry) +tryLoadI hpl i = B.tryLoad (dictPath hpl entryDir) i + + -- | Lookup the form in the dictionary. +-- The resultant list constitutes a map from entries to `Code`s. lookup :: HistPL -> T.Text -> IO [(LexEntry, Code)] lookup hpl x = do let lexSet = D.lookup x (formMap hpl) sequence - [ ( , code) <$> load hpl key + [ ( , code) <$> loadK hpl key | (key, code) <- getCode =<< M.assocs lexSet ] where getCode (key, val) = @@ -322,13 +310,14 @@ -- | Lookup a set of forms in the dictionary. +-- The resultant list constitutes a map from entries to `Code`s. lookupMany :: HistPL -> [T.Text] -> IO [(LexEntry, Code)] lookupMany hpl xs = do let keyMap = M.fromListWith min $ getCode =<< M.assocs =<< (flip D.lookup (formMap hpl) <$> xs) sequence - [ ( , code) <$> load hpl key + [ ( , code) <$> loadK hpl key | (key, code) <- M.toList keyMap ] where getCode (key, val) = @@ -336,6 +325,16 @@ | (base, code) <- M.toList (D.forms val) ] +-- | Get suffix of the `i`-th form starting with a given prefix. +nthSuffix :: HistPL -> T.Text -> Int -> Maybe T.Text +nthSuffix HistPL{..} x i = D.byIndex i (D.submap x formMap) + + +-- | Compute the number of entries with a given prefix. +withPrefix :: HistPL -> T.Text -> Int +withPrefix HistPL{..} x = D.size (D.submap x formMap) + + -------------------------------------------------------- -- Conversion -------------------------------------------------------- @@ -343,36 +342,63 @@ -- | Construct dictionary from a list of lexical entries and save it in -- the given directory. To each entry an additional set of forms can --- be assigned. -build :: FilePath -> [(LexEntry, S.Set T.Text)] -> IO (HistPL) -build binPath xs = do - createDirectoryIfMissing True binPath - emptyDirectory binPath >>= \empty -> unless empty $ do - error $ "build: directory " ++ binPath ++ " is not empty" - createDirectory $ binPath entryDir - createDirectory $ binPath keyDir - formMap' <- D.fromList . concat <$> - LazyIO.mapM saveBin (zip3 keys entries forms) - encodeFile (binPath formFile) formMap' - return $ HistPL binPath formMap' +-- be assigned. The stream of entry pairs should be terminated by the +-- `Nothing` value. +save :: Proxy p => FilePath -> () + -> Consumer p (Maybe (LexEntry, S.Set T.Text)) IO () +save binPath () = runIdentityP $ do + + -- Prepare directory for the dictionary. + lift $ do + createDirectoryIfMissing True binPath + emptyDirectory binPath >>= \empty -> unless empty $ do + error $ "save: directory " ++ binPath ++ " is not empty" + createDirectory $ binPath entryDir + createDirectory $ binPath keyDir + + formMap <- S.evalStateP s0 loop + lift $ encodeFile (binPath formFile) (D.weigh formMap) + where - (entries, forms) = unzip xs - keys = getKeys entries - saveBin (key, lexEntry, otherForms) = do - saveEntry binPath key lexEntry + + loop = request () >>= \x -> case x of + Nothing -> D.freeze . fst <$> S.get + Just (entry, forms) -> do + key <- getKey entry + saveBin key entry forms + loop + + -- Empty, initial state. The first state component represents the + -- `formMap` initializer. The second component is used to compute + -- keys for individual entries. + s0 = (D.empty, DM.empty) + + -- Compute key of the entry. + getKey entry = do + km <- snd <$> S.get + let main = proxy entry + path = T.unpack main + num = maybe 0 id (DM.lookup path km) + (1 :: Int) + key = D.Key main num + S.modify $ second $ DM.insert path num + return key + + -- Save binary entry on a disk and update the map of forms. + saveBin key entry otherForms = do + lift $ saveEntry binPath key entry let D.Key{..} = key - histForms = S.fromList (Util.allForms lexEntry) + histForms = S.fromList (Util.allForms entry) onlyHist = S.difference histForms otherForms onlyOther = S.difference otherForms histForms both = S.intersection histForms otherForms list c s = [(y, uid, (), path, c) | y <- S.toList s] - return $ list Orig onlyHist ++ list Copy onlyOther ++ list Both both + xs = list Orig onlyHist + ++ list Copy onlyOther + ++ list Both both + -- TODO: Make it strict! + S.modify $ first $ flip (foldl' (flip D.insert)) xs --- | Load all lexical entries in a lazy manner. -loadAll :: HistPL -> IO [(Key, LexEntry)] -loadAll hpl = do - keys <- dictKeys hpl - LazyIO.forM keys $ \key -> do - entry <- load hpl key - return (key, entry) +-- | A producer of all dictionary entries. +load :: Proxy p => HistPL -> () -> Producer p (Key, LexEntry) IO () +load hpl = dictKeys hpl >-> mapMD (\x -> (x, ) <$> loadK hpl x)