hist-pl-lexicon 0.5.0 → 0.6.0

raw patch · 4 files changed

+142/−117 lines, 4 filesdep +pipesdep −lazy-iodep ~dawgdep ~hist-pl-dawgPVP ok

version bump matches the API change (PVP)

Dependencies added: pipes

Dependencies removed: lazy-io

Dependency ranges changed: dawg, hist-pl-dawg

API changes (from Hackage documentation)

Files

• hist-pl-lexicon.cabal +4/−4
• src/NLP/HistPL/Binary.hs +9/−10
• src/NLP/HistPL/Binary/Util.hs +6/−6
• src/NLP/HistPL/Lexicon.hs +123/−97

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

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

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

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