hist-pl-lexicon 0.3.1 → 0.4.0

raw patch · 6 files changed

+571/−397 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hist-pl-lexicon.cabal +14/−13
• src/NLP/HistPL.hs +0/−366
• src/NLP/HistPL/Dict.hs +209/−0
• src/NLP/HistPL/Lexicon.hs +348/−0
• tools/hist-pl-binarize.hs +0/−7
• tools/hist-pl-show.hs +0/−11

@@ -1,5 +1,5 @@ name:               hist-pl-lexicon-version:            0.3.1+version:            0.4.0 synopsis:           A binary representation of the historical dictionary of Polish description:     The library provides a binary representation of the historical@@ -20,11 +20,12 @@ library   hs-source-dirs:   src   exposed-modules:    NLP.HistPL.Types-                      NLP.HistPL.LMF-                      NLP.HistPL.LMF.Parse-                      NLP.HistPL.LMF.Show-                      NLP.HistPL.Util-                      NLP.HistPL+                    , NLP.HistPL.LMF+                    , NLP.HistPL.LMF.Parse+                    , NLP.HistPL.LMF.Show+                    , NLP.HistPL.Util+                    , NLP.HistPL.Dict+                    , NLP.HistPL.Lexicon   build-depends:      base >= 4 && < 5                      , containers                     , directory@@ -43,10 +44,10 @@     type: git     location: https://github.com/kawu/hist-pl.git -executable hist-pl-binarize-  hs-source-dirs: src, tools-  main-is: hist-pl-binarize.hs--executable hist-pl-show-  hs-source-dirs: src, tools-  main-is: hist-pl-show.hs+-- executable hist-pl-binarize+--   hs-source-dirs: src, tools+--   main-is: hist-pl-binarize.hs+-- +-- executable hist-pl-show+--   hs-source-dirs: src, tools+--   main-is: hist-pl-show.hs

@@ -1,366 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} ---{-|-    The module provides functions for working with the binary-    representation of the historical dictionary of Polish.--    It is intended to be imported qualified, to avoid name-    clashes with Prelude functions, e.g. --    > import qualified NLP.HistPL as H-   -    Use `save` and `load` functions to save/load-    the entire dictionary in/from a given directory.  They are-    particularly useful when you want to convert the @LMF@ dictionary-    to a binary format (see "NLP.HistPL.LMF" module).-   -    To search the dictionary, open the binary directory with an-    `open` function.  For example, during a @GHCi@ session:--    >>> hpl <- H.open "srpsdp.bin"-   -    Set the OverloadedStrings extension for convenience:--    >>> :set -XOverloadedStrings-   -    To search the dictionary use the `lookup` function, e.g.--    >>> entries <- H.lookup hpl "dufliwego"--    You can use functions defined in the "NLP.HistPL.Types" module-    to query the entries for a particular feature, e.g.--    >>> map (H.text . H.lemma) entries-    [["dufliwy"]]--}---module NLP.HistPL-(--- * Entries-  BinEntry (..)-, Key (..)-, proxyForm-, binKey---- * Rules-, Rule (..)-, between-, apply---- * Dictionary-, HistPL--- ** Open-, tryOpen-, open--- ** Query-, lookup-, lookupBin-, getIndex-, withKey---- * Conversion--- ** Save-, save--- ** Load-, load---- * Modules--- $modules-, module NLP.HistPL.Types-) where---import Prelude hiding (lookup)-import Control.Exception (try, SomeException)-import Control.Applicative (Applicative, (<$>), (<*>))-import Control.Monad (when, guard)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Monad.Reader (lift)-import Control.Monad.Trans.Maybe (MaybeT (..))-import System.IO.Unsafe (unsafeInterleaveIO)-import System.FilePath ((</>))-import System.Directory ( getDirectoryContents, createDirectoryIfMissing-                        , createDirectory, doesDirectoryExist )-import Data.Maybe (catMaybes)-import Data.List (mapAccumL)-import Data.Binary (Binary, get, put, encodeFile, decodeFile)-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.DAWG.Dynamic as DD-import qualified Data.DAWG.Static as D--import NLP.HistPL.Types-import qualified NLP.HistPL.Util as Util--{- $modules-    "NLP.HistPL.Types" module exports hierarchy of data types-    stored in the binary dictionary.--}----- | Static DAWG version.-type DAWG a  = D.DAWG Char () a----- | Path to entries in the binary dictionary.-entryDir :: String-entryDir = "entries"----- | Path to key map in the binary dictionary.-formMapFile :: String-formMapFile = "forms.bin"----- | Entry in the binary dictionary consists of the lexical--- entry and corresponding unique identifier.-data BinEntry = BinEntry {-    -- | Lexical entry.-      lexEntry  :: LexEntry-    -- | Unique identifier among lexical entries with the same first form-    -- (see 'Key' data type).-    , uid       :: Int }-    deriving (Show, Eq, Ord)---instance Binary BinEntry where-    put BinEntry{..} = put lexEntry >> put uid-    get = BinEntry <$> get <*> get----- | A dictionary key which uniquely identifies the lexical entry.-data Key = Key {-    -- | First form (presumably lemma) of the lexical entry.-      keyForm   :: T.Text-    -- | Unique identifier among lexical entries with the same 'keyForm'.-    , keyUid    :: Int }-    deriving (Show, Eq, Ord)----- | Form representing the lexical entry.-proxyForm :: LexEntry -> T.Text-proxyForm entry = case Util.allForms entry of-    (x:_)   -> x-    []      -> error "proxyForm: entry with no forms"----- | Key assigned to the binary entry.-binKey :: BinEntry -> Key-binKey BinEntry{..} = Key (proxyForm lexEntry) uid----- | Convert the key to the path where binary representation of the entry--- is stored.-showKey :: Key -> String-showKey Key{..} = (T.unpack . T.concat) [T.pack (show keyUid), "-", keyForm]----- | Parse the key.-parseKey :: String -> Key-parseKey x =-    let (uid'S, (_:form'S)) = break (=='-') x-    in  Key (T.pack form'S) (read uid'S)----- | Load the directory contents.-loadContents :: FilePath -> IO [FilePath]-loadContents path = do-    xs <- getDirectoryContents path-    return [x | x <- xs, x /= ".", x /= ".."]----- | Check if the directory is empty.-emptyDirectory :: FilePath -> IO Bool-emptyDirectory path = null <$> loadContents path----- | Save the binary entry on the disk.-saveLexEntry :: FilePath -> BinEntry -> IO ()-saveLexEntry path x =-    let binPath = showKey . binKey-    in  encodeFile (path </> binPath x) x---withUid :: DD.DAWG Char Int -> LexEntry -> (DD.DAWG Char Int, BinEntry)-withUid m x =-    let path = T.unpack (proxyForm x)-        num  = maybe 0 id (DD.lookup path m) + 1-    in  (DD.insert path num m, BinEntry x num)---withUids :: [LexEntry] -> [BinEntry]-withUids = snd . mapAccumL withUid DD.empty---mapIO'Lazy :: (a -> IO b) -> [a] -> IO [b]-mapIO'Lazy f (x:xs) = (:) <$> f x <*> unsafeInterleaveIO (mapIO'Lazy f xs)-mapIO'Lazy _ []     = return []----- | Save the HistPL dictionary in the empty directory.-save :: FilePath -> [LexEntry] -> IO ()-save path xs = do-    createDirectoryIfMissing True path-    isEmpty <- emptyDirectory path-    when (not isEmpty) $ do-        error $ "save: directory " ++ path ++ " is not empty"-    let lexPath = path </> entryDir-    createDirectory lexPath-    formMap' <- D.fromListWith S.union . concat-        <$> mapIO'Lazy (saveLex lexPath) (withUids xs)-    encodeFile (path </> formMapFile) formMap'-  where-    saveLex lexPath x = do-        saveLexEntry lexPath x-        return $ rules x-    rules binEntry =-        [ ( T.unpack x-          , S.singleton (between x key) )-        | x <- Util.allForms (lexEntry binEntry) ]-      where-        key = binKey binEntry----- | Load dictionary from a disk in a lazy manner.  Return 'Nothing'--- if the path doesn't correspond to a binary representation of the--- dictionary. -load :: FilePath -> IO (Maybe [BinEntry])-load path = runMaybeT $ do-    hpl  <- MaybeT $ tryOpen path-    lift $ do-        keys <- getIndex hpl-        catMaybes <$> mapM (withKey hpl) keys---maybeErr :: MonadIO m => IO a -> m (Maybe a)-maybeErr io = do-    r <- liftIO (try io)-    case r of-        Left (_e :: SomeException)  -> return Nothing-        Right x                     -> return (Just x)---maybeT :: Monad m => Maybe a -> MaybeT m a-maybeT = MaybeT . return-{-# INLINE maybeT #-}---maybeErrT :: MonadIO m => IO a -> MaybeT m a-maybeErrT io = do-    r <- liftIO (maybeErr io)-    maybeT r----- | Load lexical entry from disk by its key.-loadLexEntry :: FilePath -> Key -> IO (Maybe BinEntry)-loadLexEntry path key = do-    maybeErr $ decodeFile (path </> showKey key)-------------------------------------------------------------- Rules-------------------------------------------------------------- | A rule for translating a form into a binary dictionary key.-data Rule = Rule {-    -- | Number of characters to cut from the end of the form.-      cut       :: !Int-    -- | A suffix to paste.-    , suffix    :: !T.Text-    -- | Unique identifier of the entry.-    , ruleUid   :: !Int }-    deriving (Show, Eq, Ord)---instance Binary Rule where-    put Rule{..} = put cut >> put suffix >> put ruleUid-    get = Rule <$> get <*> get <*> get----- | Apply the rule.-apply :: Rule -> T.Text -> Key-apply r x =-    let y = T.take (T.length x - cut r) x `T.append` suffix r-    in  Key y (ruleUid r)----- | Make a rule which translates between the string and the key.-between :: T.Text -> Key -> Rule-between source dest =-    let k = lcp source (keyForm dest)-    in  Rule (T.length source - k) (T.drop k (keyForm dest)) (keyUid dest)-  where-    lcp a b = case T.commonPrefixes a b of-        Just (c, _, _)  -> T.length c-        Nothing         -> 0-------------------------------------------------------------- Binary interface-------------------------------------------------------------- | A binary dictionary handle.-data HistPL = HistPL {-    -- | A path to the binary dictionary.-      dictPath  :: FilePath-    -- | A map with lexicon forms.-    , formMap   :: DAWG (S.Set Rule)-    }----- | Path to directory with entries.-entryPath :: HistPL -> FilePath-entryPath = (</> entryDir) . dictPath----- | Open the binary dictionary residing in the given directory.--- Return Nothing if the directory doesn't exist or if it doesn't--- constitute a dictionary.-tryOpen :: FilePath -> IO (Maybe HistPL)-tryOpen path = runMaybeT $ do-    formMap'    <- maybeErrT $ decodeFile (path </> formMapFile)-    doesExist   <- liftIO $ doesDirectoryExist (path </> entryDir)-    guard doesExist -    return $ HistPL path formMap'----- | Open the binary dictionary residing in the given directory.--- Raise an error if the directory doesn't exist or if it doesn't--- constitute a dictionary.-open :: FilePath -> IO HistPL-open path = tryOpen path >>=-    maybe (fail "Failed to open the dictionary") return----- | List of dictionary keys.-getIndex :: HistPL -> IO [Key]-getIndex hpl = map parseKey <$> loadContents (entryPath hpl)----- | Extract lexical entry with a given key.-withKey :: HistPL -> Key -> IO (Maybe BinEntry)-withKey hpl key =  unsafeInterleaveIO $ loadLexEntry (entryPath hpl) key----- | Lookup the form in the dictionary.-lookup :: HistPL -> T.Text -> IO [LexEntry]-lookup hpl = fmap (map lexEntry) . lookupBin hpl----- | Lookup the form in the dictionary.  Similar to `lookup`, but--- returns the `BinEntry` which can be used to determine place of--- the entry in the dictionary storage.-lookupBin :: HistPL -> T.Text -> IO [BinEntry]-lookupBin hpl x = do-    let keys = case D.lookup (T.unpack x) (formMap hpl) of-            Nothing -> []-            Just xs -> map (flip apply x) (S.toList xs)-    catMaybes <$> mapM (withKey hpl) keys

@@ -0,0 +1,209 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+++-- | A `D.DAWG`-based dictionary.+++module NLP.HistPL.Dict+(+-- * Rule+  Rule (..)+, apply+, between++-- * Dictionary+, Dict+-- ** Entry+, Lex (..)+, Key (..)+, Val (..)+, Node+-- ** Entry set+, LexSet+, mkLexSet+, unLexSet+-- , encode+, decode+-- ** Query+, lookup+-- ** Conversion+, fromList+, toList+, entries+, revDict+) where+++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first)+import Data.Binary (Binary, get, put)+import Data.Text.Binary ()+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.DAWG.Static as D+++------------------------------------------------------------------------+-- Rule+------------------------------------------------------------------------+++-- | A rule for translating a form into another form.+data Rule = Rule {+    -- | Number of characters to cut from the end of the form.+      cut       :: !Int+    -- | A suffix to paste.+    , suffix    :: !T.Text+    } deriving (Show, Eq, Ord)+++instance Binary Rule where+    put Rule{..} = put cut >> put suffix+    get = Rule <$> get <*> get+++-- | Apply the rule.+apply :: Rule -> T.Text -> T.Text+apply r x = T.take (T.length x - cut r) x `T.append` suffix r+++-- | Determine a rule which translates between two strings.+between :: T.Text -> T.Text -> Rule+between source dest =+    let k = lcp source dest+    in  Rule (T.length source - k) (T.drop k dest)+  where+    lcp a b = case T.commonPrefixes a b of+        Just (c, _, _)  -> T.length c+        Nothing         -> 0+++------------------------------------------------------------------------+-- Entry componenets (key and value)+------------------------------------------------------------------------+++-- | A key of a dictionary entry.+data Key i = Key {+    -- | A path of the entry, i.e. DAWG key.+      path  :: T.Text+    -- | Unique identifier among entries with the same `path`.+    , uid   :: i }+    deriving (Show, Eq, Ord)+++-- | A value of the entry.+data Val a w b = Val {+    -- | Additional information assigned to the entry.+      info  :: a+    -- | A map of forms with additional info of type @b@ assigned.+    -- Invariant: in case of a reverse dictionary (from word forms+    -- to base forms) this map should contain exactly one element+    -- (a base form and a corresonding info).+    , forms :: M.Map w b }+    deriving (Show, Eq, Ord)+++instance (Ord w, Binary a, Binary w, Binary b) => Binary (Val a w b) where+    put Val{..} = put info >> put forms+    get = Val <$> get <*> get+++-- | A dictionary entry consists of a `Key` and a `Val`ue.+data Lex i a b = Lex {+    -- | Entry key.+      lexKey :: Key i+    -- | Entry value.+    , lexVal :: Val a T.Text b }+    deriving (Show, Eq, Ord)+++-- | A set of dictionary entries.+type LexSet i a b = M.Map (Key i) (Val a T.Text b)+++-- | Make lexical set from a list of entries.+mkLexSet :: Ord i => [Lex i a b] -> LexSet i a b+mkLexSet = M.fromList . map ((,) <$> lexKey <*> lexVal)+++-- | List lexical entries.+unLexSet :: LexSet i a b -> [Lex i a b]+unLexSet = map (uncurry Lex) . M.toList+++-- | Actual values stored in automaton states contain+-- all entry information but `path`.+type Node i a b = M.Map i (Val a Rule b)+++-- | Map function over entry word forms.+mapW :: Ord w' => (w -> w') -> Val a w b -> Val a w' b+mapW f v =+    let g = M.fromList . map (first f) . M.toList+    in  v { forms = g (forms v) }+++-- | Encode dictionary value given `path`.+++-- | Decode dictionary value given `path`.+decode :: Ord i => T.Text -> Node i a b -> LexSet i a b+decode x n = M.fromList+    [ (Key x i, mapW (flip apply x) val)+    | (i, val) <- M.toList n ]+++-- | Transform entry into a list.+toListE :: Lex i a b -> [(T.Text, i, a, T.Text, b)]+toListE (Lex Key{..} Val{..}) =+    [ (path, uid, info, form, y)+    | (form, y) <- M.assocs forms ]+++------------------------------------------------------------------------+++-- | A dictionary parametrized over ID @i@, with info @a@ for every+-- (key, i) pair and info @b@ for every (key, i, apply rule key) triple.+type Dict i a b = D.DAWG Char () (Node i a b)+++-- | Lookup the key in the dictionary.+lookup :: Ord i => T.Text -> Dict i a b -> LexSet i a b+lookup x dict = decode x $ case D.lookup (T.unpack x) dict of+    Just m  -> m+    Nothing -> M.empty+++-- | List dictionary lexical entries.+entries :: Ord i => Dict i a b -> [Lex i a b]+entries = concatMap f . D.assocs where+    f (key, val) = unLexSet $ decode (T.pack key) val+++-- | Make dictionary from a list of (key, ID, entry info, form,+-- entry\/form info) tuples.+fromList :: (Ord i, Ord a, Ord b) => [(T.Text, i, a, T.Text, b)] -> Dict i a b+fromList xs = D.fromListWith union $+    [ ( T.unpack x+      , M.singleton i (Val a (M.singleton (between x y) b)) )+    | (x, i, a, y, b) <- xs ]+  where+    union = M.unionWith $ both const M.union+    both f g (Val x y) (Val x' y') = Val (f x x') (g y y')+++-- | Transform dictionary back into the list of (key, ID, key\/ID info, elem,+-- key\/ID\/elem info) tuples.+toList :: (Ord i, Ord a, Ord b) => Dict i a b -> [(T.Text, i, a, T.Text, b)]+toList = concatMap toListE . entries+++-- | Reverse the dictionary.+revDict :: (Ord i, Ord a, Ord b) => Dict i a b -> Dict i a b+revDict = +    let swap (base, i, x, form, y) = (form, i, x, base, y)+    in  fromList . map swap . toList

@@ -0,0 +1,348 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +++{-|+    The module provides functions for working with the binary+    representation of the historical dictionary of Polish.++    It is intended to be imported qualified, to avoid name+    clashes with Prelude functions, e.g. ++    > import qualified NLP.HistPL.Lexicon as H+   +    Use `save` and `load` functions to save/load+    the entire dictionary in/from a given directory.  They are+    particularly useful when you want to convert the @LMF@ dictionary+    to a binary format (see "NLP.HistPL.LMF" module).+   +    To search the dictionary, open the binary directory with an+    `open` function.  For example, during a @GHCi@ session:++    >>> hpl <- H.open "srpsdp.bin"+   +    Set the OverloadedStrings extension for convenience:++    >>> :set -XOverloadedStrings+   +    To search the dictionary use the `lookup` function, e.g.++    >>> entries <- H.lookup hpl "dufliwego"++    You can use functions defined in the "NLP.HistPL.Types" module+    to query the entries for a particular feature, e.g.++    >>> map (H.text . H.lemma) entries+    [["dufliwy"]]+-}+++module NLP.HistPL.Lexicon+(+-- * Dictionary+  HistPL+, Code (..)+-- ** Key+, Key+, UID+-- ** Open+, tryOpen+, open+-- ** Query+, lookup+, lookupMany+, getIndex+, tryWithKey+, withKey++-- * Conversion+-- ** Save+, save+-- ** Load+, load++-- * Modules+-- $modules+, module NLP.HistPL.Types+) where+++import Prelude hiding (lookup)+import Control.Exception (try, SomeException)+import Control.Applicative (Applicative, (<$>), (<*>))+import Control.Monad (when, guard)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.Trans.Maybe (MaybeT (..))+import System.IO.Unsafe (unsafeInterleaveIO)+import System.FilePath ((</>))+import System.Directory ( getDirectoryContents, createDirectoryIfMissing+                        , createDirectory, doesDirectoryExist )+import Data.List (mapAccumL)+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.DAWG.Dynamic as DD++import qualified NLP.HistPL.Dict as D+import           NLP.HistPL.Types+import qualified NLP.HistPL.Util as Util+++{- $modules+    "NLP.HistPL.Types" module exports hierarchy of data types+    stored in the binary dictionary.+-}+++-- | Path to entries in the binary dictionary.+entryDir :: String+entryDir = "entries"+++-- | Path to key map in the binary dictionary.+formMapFile :: String+formMapFile = "forms.bin"+++-- | A dictionary key which uniquely identifies the lexical entry.+type Key = D.Key UID+++-- | A unique identifier among entries with the same `keyForm`.+type UID = Int+++-- | Form representing the lexical entry.+proxy :: LexEntry -> T.Text+proxy entry = case Util.allForms entry of+    (x:_)   -> x+    []      -> error "proxy: entry with no forms"+++-- | Convert the key to the path where binary representation of the entry+-- is stored.+showKey :: Key -> String+showKey D.Key{..} = (T.unpack . T.concat) [T.pack (show uid), "-", path]+++-- | Parse the key.+parseKey :: String -> Key+parseKey x =+    let (uid'S, (_:form'S)) = break (=='-') x+    in  D.Key (T.pack form'S) (read uid'S)+++-- | Load the directory contents.+loadContents :: FilePath -> IO [FilePath]+loadContents path = do+    xs <- getDirectoryContents path+    return [x | x <- xs, x /= ".", x /= ".."]+++-- | Check if the directory is empty.+emptyDirectory :: FilePath -> IO Bool+emptyDirectory path = null <$> loadContents path+++-- | Save entry on a disk under the given key.+saveEntry :: FilePath -> Key -> LexEntry -> IO ()+saveEntry path x y = encodeFile (path </> showKey x) y+++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+++mapIO'Lazy :: (a -> IO b) -> [a] -> IO [b]+mapIO'Lazy f (x:xs) = (:) <$> f x <*> unsafeInterleaveIO (mapIO'Lazy f xs)+mapIO'Lazy _ []     = return []+++forIO'Lazy :: [a] -> (a -> IO b) -> IO [b]+forIO'Lazy = flip mapIO'Lazy+++maybeErr :: MonadIO m => IO a -> m (Maybe a)+maybeErr io = do+    r <- liftIO (try io)+    case r of+        Left (_e :: SomeException)  -> return Nothing+        Right x                     -> return (Just x)+++maybeT :: Monad m => Maybe a -> MaybeT m a+maybeT = MaybeT . return+{-# INLINE maybeT #-}+++maybeErrT :: MonadIO m => IO a -> MaybeT m a+maybeErrT io = do+    r <- liftIO (maybeErr io)+    maybeT r+++-- | Load lexical entry from disk by its key.+loadEntry :: FilePath -> Key -> IO (Maybe LexEntry)+loadEntry path key = do+    maybeErr $ decodeFile (path </> showKey key)+++--------------------------------------------------------+-- Binary interface+--------------------------------------------------------+++-- | A binary dictionary holds additional info of type @a@+-- for every entry and additional info of type @b@ for every+-- word form.+data HistPL = HistPL {+    -- | A path to the binary dictionary.+      dictPath  :: FilePath+    -- | A dictionary with lexicon forms.+    , formMap   :: D.Dict UID () Code+    }+++-- | Code of word form origin.+data Code+    = Orig  -- ^ only from historical dictionary+    | Both  -- ^ from both historical and another dictionary+    | Copy  -- ^ only from another dictionary+    deriving (Show, Eq, Ord)+++instance Binary Code where+    put Orig = put '1'+    put Copy = put '2'+    put Both = put '3'+    get = get >>= \x -> return $ case x of+        '1' -> Orig+        '2' -> Copy+        '3' -> Both+        c   -> error $ "get: invalid Code value '" ++ [c] ++ "'"+++-- | Path to directory with entries.+entryPath :: HistPL -> FilePath+entryPath = (</> entryDir) . dictPath+++-- | Open the binary dictionary residing in the given directory.+-- Return Nothing if the directory doesn't exist or if it doesn't+-- constitute a dictionary.+tryOpen :: FilePath -> IO (Maybe HistPL)+tryOpen path = runMaybeT $ do+    formMap'  <- maybeErrT $ decodeFile (path </> formMapFile)+    doesExist <- liftIO $ doesDirectoryExist (path </> entryDir)+    guard doesExist +    return $ HistPL path formMap'+++-- | Open the binary dictionary residing in the given directory.+-- Raise an error if the directory doesn't exist or if it doesn't+-- constitute a dictionary.+open :: FilePath -> IO HistPL+open path = tryOpen path >>=+    maybe (fail "Failed to open the dictionary") return+++-- | List of dictionary keys.+getIndex :: HistPL -> IO [Key]+getIndex hpl = map parseKey <$> loadContents (entryPath hpl)+++-- | Extract lexical entry with a given key.  Return `Nothing` if there+-- is no entry with such a key.+tryWithKey :: HistPL -> Key -> IO (Maybe LexEntry)+tryWithKey hpl key = unsafeInterleaveIO $ loadEntry (entryPath hpl) key+++-- | Extract lexical entry with a given key.  Raise error if there+-- is no entry with such a key.+withKey :: HistPL -> Key -> IO LexEntry+withKey hpl key = tryWithKey hpl key >>= maybe+    (fail $ "Failed to open entry with the " ++ show key ++ " key") return+++-- | Lookup the form in the dictionary.+lookup :: HistPL -> T.Text -> IO [(LexEntry, Code)]+lookup hpl x = do+    let lexSet = D.lookup x (formMap hpl)+    sequence+        [ (   , code) <$> withKey hpl key+        | (key, code) <- getCode =<< M.assocs lexSet ]+  where+    getCode (key, val) =+        [ (key { D.path = base }, code)+        | (base, code) <- M.toList (D.forms val) ]+        ++-- | Lookup a set of forms in the dictionary.+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) <$> withKey hpl key+        | (key, code) <- M.toList keyMap ]+  where+    getCode (key, val) =+        [ (key { D.path = base }, code)+        | (base, code) <- M.toList (D.forms val) ]+++--------------------------------------------------------+-- Conversion+--------------------------------------------------------+++-- | 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.  +save :: FilePath -> [(LexEntry, S.Set T.Text)] -> IO (HistPL)+save binPath xs = do+    createDirectoryIfMissing True binPath+    isEmpty <- emptyDirectory binPath+    when (not isEmpty) $ do+        error $ "save: directory " ++ binPath ++ " is not empty"+    let lexPath = binPath </> entryDir+    createDirectory lexPath+    formMap' <- D.fromList . concat <$>+        mapIO'Lazy (saveBin lexPath) (zip3 keys entries forms)+    encodeFile (binPath </> formMapFile) formMap'+    return $ HistPL binPath formMap'+  where+    (entries, forms) = unzip xs+    keys = getKeys entries+    saveBin lexPath (key, lexEntry, otherForms) = do+        saveEntry lexPath key lexEntry+        let D.Key{..} = key+            histForms = S.fromList (Util.allForms lexEntry)+            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+++-- | Load all lexical entries in a lazy manner.+load :: HistPL -> IO [(Key, LexEntry)]+load hpl = do+    keys <- getIndex hpl+    forIO'Lazy keys $ \key -> do+        entry <- withKey hpl key+        return (key, entry)

@@ -1,7 +0,0 @@-import           System.Environment (getArgs)-import           NLP.HistPL.LMF (readLMF)-import qualified NLP.HistPL as H--main = do-    [lmfPath, binPath] <- getArgs-    H.save binPath =<< readLMF lmfPath

@@ -1,11 +0,0 @@-import           System.Environment (getArgs)-import qualified Data.Text.Lazy.IO as L--import           NLP.HistPL.LMF (showLMF)-import qualified NLP.HistPL as H--main = do-    [binPath] <- getArgs-    H.load binPath >>= \x -> case x of-        Nothing -> error "Not a dictionary"-        Just pl -> L.putStr (showLMF $ map H.lexEntry pl)