hist-pl-lexicon 0.4.0 → 0.5.0

raw patch · 9 files changed

+232/−823 lines, 9 filesdep +hist-pl-dawgdep +hist-pl-typesdep +lazy-iodep −mtldep −polysoupdep −text-binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: hist-pl-dawg, hist-pl-types, lazy-io

Dependencies removed: mtl, polysoup, text-binary

API changes (from Hackage documentation)

Files

• hist-pl-lexicon.cabal +11/−24
• src/NLP/HistPL/Binary.hs +47/−0
• src/NLP/HistPL/Binary/Util.hs +48/−0
• src/NLP/HistPL/Dict.hs +0/−209
• src/NLP/HistPL/LMF.hs +0/−9
• src/NLP/HistPL/LMF/Parse.hs +0/−160
• src/NLP/HistPL/LMF/Show.hs +0/−170
• src/NLP/HistPL/Lexicon.hs +126/−96
• src/NLP/HistPL/Types.hs +0/−155

@@ -1,11 +1,9 @@ name:               hist-pl-lexicon-version:            0.4.0+version:            0.5.0 synopsis:           A binary representation of the historical dictionary of Polish description:     The library provides a binary representation of the historical-    dictionary of Polish and language markup format (LMF) parsing-    utilities which allow to translate the original LMF representation-    of the dictionary to the binary form.+    dictionary of Polish. license:            BSD3 license-file:       LICENSE cabal-version:      >= 1.6@@ -19,35 +17,24 @@  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.Dict+  exposed-modules:    NLP.HistPL.Util                     , NLP.HistPL.Lexicon+  other-modules:      NLP.HistPL.Binary+                    , NLP.HistPL.Binary.Util   build-depends:      base >= 4 && < 5                      , containers+                    , binary+                    , text                     , directory                     , filepath-                    , text-                    , binary-                    , text-binary >= 0.1 && < 0.2-                    , polysoup >= 0.1 && < 0.2-                    , dawg >= 0.9 && < 0.10                     , transformers-                    , mtl+                    , lazy-io >= 0.1 && < 0.2+                    , dawg >= 0.9 && < 0.10+                    , hist-pl-types >= 0.1 && < 0.2+                    , hist-pl-dawg >= 0.1 && < 0.2    ghc-options: -Wall  source-repository head     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

@@ -0,0 +1,47 @@+module NLP.HistPL.Binary+( save+, load+, tryLoad+, dictIDs+, loadAll+) where+++import           Prelude hiding (lookup)+import           Control.Applicative ((<$>))+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+++-- | Save entry in the given directory (the actual entry path+-- is determined on the basis of the `lexID`).+save :: FilePath -> LexEntry -> IO ()+save path x = encodeFile (path </> T.unpack (lexID x)) x+++-- | 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+++-- | Lookup entry with a given `lexID`.+tryLoad :: FilePath -> T.Text -> IO (Maybe LexEntry)+tryLoad path i = maybeErr $ decodeFile (path </> T.unpack i)+++-- | Get a list of entry identifiers stored in the dictionary.+dictIDs :: FilePath -> IO [T.Text]+dictIDs path = map T.pack <$> loadContents path+++-- | Load all lexical entries in a lazy manner.+loadAll :: FilePath -> IO [LexEntry]+loadAll path = do+    ids <- dictIDs path+    LazyIO.forM ids $ load path

@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-} +++module NLP.HistPL.Binary.Util+( loadContents+, emptyDirectory+, maybeErr+, maybeT+, maybeErrT+) where+++import           Control.Applicative ((<$>))+import           Control.Monad.IO.Class (liftIO, MonadIO)+import           Control.Exception (try, SomeException)+import           Control.Monad.Trans.Maybe (MaybeT (..))+import           System.Directory (getDirectoryContents)+++-- | 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+++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

@@ -1,209 +0,0 @@-{-# 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

@@ -1,9 +0,0 @@--- | Re-export modules from the LMF hierarchy.--module NLP.HistPL.LMF-( module NLP.HistPL.LMF.Parse-, module NLP.HistPL.LMF.Show-) where--import NLP.HistPL.LMF.Parse-import NLP.HistPL.LMF.Show

@@ -1,160 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | The module provides parsing utilities for the LMF dictionary.--module NLP.HistPL.LMF.Parse-( readLMF-, parseLMF-, parseLexEntry-) where--import Control.Monad (join)-import Data.Maybe (mapMaybe, listToMaybe)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L-import qualified Text.XML.PolySoup as Soup-import Text.XML.PolySoup hiding (XmlParser, Parser, join)--import NLP.HistPL.Types--import Debug.Trace (trace)--type Parser a = Soup.XmlParser L.Text a--lmfP :: Parser [LexEntry]-lmfP = true //> lexEntryP--lexEntryP :: Parser LexEntry-lexEntryP = tag "LexicalEntry" *> getAttr "id" >^>-  \lexId' -> collTags >>=-  \tags   -> return $-    let with p = tagsParseXml (findAll p) tags-    in  LexEntry-        { lexId         = L.toStrict lexId'-        , lineRef       = listToMaybe $ with lineRefP-        , status        = listToMaybe $ with statusP-        , pos           = with posP-        , lemma         = first "lemmaP" (with lemmaP)-        , forms         = with formP-        , components    = join (with compoP)-        , syntactic     = with synP-        , senses        = with senseP-        , related       = with relP }-    -first :: Show a => String -> [a] -> a-first _   [x] = x-first src []  = error $ src ++ ": null xs"-first src xs  = error $ src ++ ": xs == " ++ show xs--posP :: Parser T.Text-posP = featP "partOfSpeech"--lineRefP :: Parser T.Text-lineRefP = featP "lineRef"--statusP :: Parser T.Text-statusP = featP "status"--lemmaP :: Parser Lemma-lemmaP = Lemma <$> (tag "Lemma" /> reprP)--formP :: Parser WordForm-formP = WordForm <$> (tag "WordForm" /> reprP)--compoP :: Parser [T.Text]-compoP = map L.toStrict <$> (tag "ListOfComponents" /> cut (getAttr "entry"))--relP :: Parser RelForm-relP = tag "RelatedForm" *> getAttr "targets" >^> \relTo' -> do-    rs <- many reprP-    return $ RelForm-        { relRepr = rs-        , relTo   = L.toStrict relTo' }--otherP :: Parser ()-otherP = tagOpenName >^> \name ->-    warning ("tag " ++ L.unpack name ++ " ignored") ignore--warning :: String -> Parser a -> Parser a-warning msg x = trace ("WARNING: " ++ msg) x--grave :: String -> Parser a -> Parser a-grave msg x = trace ("ERROR: " ++ msg) x--grave' :: String -> a -> Parser a-grave' msg x = grave msg (return x)--synP :: Parser SynBehaviour-synP = tag "SyntacticBehaviour" *> getAttr "senses" >^> \senses' -> do-    repr' <- reprBodyP-    let senseIds = T.words (L.toStrict senses')-    return (SynBehaviour [repr'] senseIds)--data SenseContent-    = SenseDef Definition-    | SenseStyle T.Text-    | SenseCxt Context-    | SenseOther ()--senseStyle :: SenseContent -> Maybe T.Text-senseStyle (SenseStyle x) = Just x-senseStyle _              = Nothing--senseDef :: SenseContent -> Maybe Definition-senseDef (SenseDef def) = Just def-senseDef _              = Nothing--senseCxt :: SenseContent -> Maybe Context-senseCxt (SenseCxt cxt) = Just cxt-senseCxt _              = Nothing--senseP :: Parser Sense-senseP = tag "Sense" *> maybeAttr "id" >^> \senseId' -> do-    xs <- many $ oneOf-        [ SenseDef      <$> defP-        , SenseStyle    <$> styleP-        , SenseCxt      <$> cxtP-        , SenseOther    <$> otherP ]-    let styl' = mapMaybe senseStyle xs-    let defs' = mapMaybe senseDef xs-    let cxts' = mapMaybe senseCxt xs-    return $ Sense-        { senseId = L.toStrict <$> senseId'-        , style = styl'-        , defs  = defs'-        , cxts  = cxts' }--defP :: Parser Definition-defP = Definition <$> (tag "Definition" /> reprP)--cxtP :: Parser Context-cxtP = Context <$> (tag "Context" /> reprP)--styleP :: Parser T.Text-styleP = featP "style"--reprP :: Parser Repr-reprP = tag "FormRepresentation" <|> tag "TextRepresentation" ^> reprBodyP--reprBodyP :: Parser Repr-reprBodyP = Repr-    <$> featP "writtenForm"-    <*> (featP "language" <|> grave' "language not specified" "polh")-    <*> (optional $ featP "sourceID")--featP :: L.Text -> Parser T.Text-featP att = L.toStrict <$>-    cut (tag "feat" *> hasAttr "att" att *> getAttr "val")---- | Read the dictionary from the LMF file.-readLMF :: FilePath -> IO [LexEntry]-readLMF = fmap parseLMF . L.readFile---- | Parse the entire dictionary in the LMF format.-parseLMF :: L.Text -> [LexEntry]-parseLMF = parseXml lmfP---- | Parse the lexical entry LMF representation-parseLexEntry :: L.Text -> LexEntry-parseLexEntry = parseXml lexEntryP

@@ -1,170 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Printing utilities for the LMF dictionary format.--module NLP.HistPL.LMF.Show-( showLMF-, showLexEntry-) where--import Data.Monoid (Monoid, mappend, mconcat)-import Data.List (intersperse)-import Data.Maybe (maybeToList)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as L-import Text.XML.PolySoup (escapeXml)--import NLP.HistPL.Types---- | An infix synonym for 'mappend'.-{-# INLINE (<>) #-}-(<>) :: Monoid m => m -> m -> m-(<>) = mappend---- | Indentation parameter.-indentSize :: Int-indentSize = 2--identPref :: L.Builder-identPref = L.fromLazyText (L.replicate (fromIntegral indentSize) " ")--{-# INLINE ident #-}-ident :: L.Builder -> L.Builder-ident = (identPref <>)--prolog :: [L.Builder]-prolog =-    [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"-    , "<LexicalResource dtdVersion=\"16\">"-    , "  <GlobalInformation>"-    , "    <feat att=\"languageCoding\" val=\"ISO 639-6\"/>"-    , "  </GlobalInformation>"-    , "  <Lexicon>" ]--epilog :: [L.Builder]-epilog =-    [ "  </Lexicon>"-    , "</LexicalResource>" ]---- | Show the entire dictionary as a lazy text in the LMF format.-showLMF :: [LexEntry] -> L.Text-showLMF =-    L.toLazyText . mconcat . map (<> "\n") . embed . concatMap buildLexEntry-    where embed body = prolog ++ map (ident.ident) body ++ epilog---- | Show lexical entry using the LMF format.-showLexEntry :: LexEntry -> L.Text-showLexEntry =-    L.toLazyText . mconcat . map (<> "\n") . buildLexEntry--buildElem :: L.Builder -> [L.Builder] -> L.Builder -> [L.Builder]-buildElem beg body end = beg : map ident body ++ [end] ---- | Each output line is represented as a builder. We use separate builders--- for separate lines because we want to easilly indent the output text.-buildLexEntry :: LexEntry -> [L.Builder]-buildLexEntry lx =-    buildElem beg body end-  where-    beg = "<LexicalEntry id=\"" <> L.fromText (lexId lx) <> "\">"-    end = "</LexicalEntry>"-    body-        =  map (buildFeat "lineRef") (maybeToList $ lineRef lx)-        ++ map (buildFeat "status") (maybeToList $ status lx)-        ++ map (buildFeat "partOfSpeech") (pos lx)-        ++ buildLemma (lemma lx)-        ++ concatMap buildForm (forms lx)-        ++ concatMap buildRelForm (related lx)-        ++ buildComps (components lx)-        ++ concatMap buildSyn (syntactic lx)-        ++ concatMap buildSense (senses lx)--buildLemma :: Lemma -> [L.Builder]-buildLemma base =-    buildElem beg body end-  where-    beg = "<Lemma>"-    end = "</Lemma>"-    body = concatMap (buildRepr "FormRepresentation") (repr base)--buildForm :: WordForm -> [L.Builder]-buildForm form =-    buildElem beg body end-  where-    beg = "<WordForm>"-    end = "</WordForm>"-    body = concatMap (buildRepr "FormRepresentation") (repr form)--buildRelForm :: RelForm -> [L.Builder]-buildRelForm form =-    buildElem beg body end-  where-    beg = "<RelatedForm targets=\"" <> L.fromText (relTo form) <> "\">"-    end = "</RelatedForm>"-    body = concatMap (buildRepr "FormRepresentation") (repr form)--buildComps :: [T.Text] -> [L.Builder]-buildComps [] = []-buildComps xs =-    buildElem beg body end-  where-    beg = "<ListOfComponents>"-    end = "</ListOfComponents>"-    body = map comp xs-    comp x = "<Component entry=\"" <> L.fromText x <> "\"/>"--buildSyn :: SynBehaviour -> [L.Builder]-buildSyn syn =-    buildElem beg body end-  where-    ids = mconcat . intersperse " " . map L.fromText $ synSenseIds syn-    beg = "<SyntacticBehaviour senses=\"" <> ids <> "\">"-    end = "</SyntacticBehaviour>"-    body = concatMap (buildRepr "TextRepresentation") (repr syn)--buildSense :: Sense -> [L.Builder]-buildSense sense =-    buildElem beg body end-  where-    beg = case senseId sense of-        Just x  -> "<Sense id=\"" <> L.fromText x <> "\">"-        Nothing -> "<Sense>"-    end = "</Sense>"-    body-        =  map (buildFeat "style") (style sense)-        ++ concatMap buildDef (defs sense)-        ++ concatMap buildCxt (cxts sense)--buildDef :: Definition -> [L.Builder]-buildDef def =-    buildElem beg body end-  where-    beg = "<Definition>"-    end = "</Definition>"-    body = concatMap (buildRepr "TextRepresentation") (repr def)--buildCxt :: Context -> [L.Builder]-buildCxt cxt =-    buildElem beg body end-  where-    beg = "<Context>"-    end = "</Context>"-    body = concatMap (buildRepr "TextRepresentation") (repr cxt)--buildRepr :: L.Builder -> Repr -> [L.Builder]-buildRepr tag rp =-    buildElem beg body end-  where-    beg = "<"  <> tag <> ">"-    end = "</" <> tag <> ">"-    body =-        [ buildFeat "writtenForm" . escapeXml $ writtenForm rp-        , buildFeat "language" (language rp) ] ++ source-    source = case sourceID rp of-        Just x  -> [buildFeat "sourceID" x]-        Nothing -> []--buildFeat :: L.Builder -> T.Text -> L.Builder-buildFeat att val =-    "<feat att=\"" <> att <> "\" val=\"" <> L.fromText val <> "\"/>"

@@ -1,7 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-}  {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-}  {-# LANGUAGE TupleSections #-}   @@ -14,10 +12,8 @@      > 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).+    Use `build` and `loadAll` functions to save/load+    the entire dictionary in/from a given directory.         To search the dictionary, open the binary directory with an     `open` function.  For example, during a @GHCi@ session:@@ -37,6 +33,10 @@      >>> map (H.text . H.lemma) entries     [["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'`+    functions. -}  @@ -51,18 +51,23 @@ -- ** Open , tryOpen , open--- ** Query++-- * Query+-- ** By Form , lookup , lookupMany-, getIndex-, tryWithKey-, withKey+-- ** By Key+, dictKeys+, tryLoad+, load+-- ** By ID+, dictIDs+, tryLoad'+, load'  -- * Conversion--- ** Save-, save--- ** Load-, load+, build+, loadAll  -- * Modules -- $modules@@ -71,23 +76,26 @@   import Prelude hiding (lookup)-import Control.Exception (try, SomeException)-import Control.Applicative (Applicative, (<$>), (<*>))-import Control.Monad (when, guard)+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 ( getDirectoryContents, createDirectoryIfMissing-                        , createDirectory, doesDirectoryExist )+import System.Directory+    ( 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.Text.IO as T import qualified Data.DAWG.Dynamic as DD -import qualified NLP.HistPL.Dict as D+import qualified NLP.HistPL.Binary as B+import           NLP.HistPL.Binary.Util+import qualified NLP.HistPL.DAWG as D import           NLP.HistPL.Types import qualified NLP.HistPL.Util as Util @@ -98,16 +106,31 @@ -}  +--------------------------------------------------------+-- Subdirectories+--------------------------------------------------------++ -- | Path to entries in the binary dictionary. entryDir :: String entryDir = "entries"  +-- | Path to keys in the binary dictionary.+keyDir :: String+keyDir = "keys"++ -- | Path to key map in the binary dictionary.-formMapFile :: String-formMapFile = "forms.bin"+formFile :: String+formFile = "forms.bin"  +--------------------------------------------------------+-- Key+--------------------------------------------------------++ -- | A dictionary key which uniquely identifies the lexical entry. type Key = D.Key UID @@ -116,7 +139,7 @@ type UID = Int  --- | Form representing the lexical entry.+-- | The ''main form'' of the lexical entry. proxy :: LexEntry -> T.Text proxy entry = case Util.allForms entry of     (x:_)   -> x@@ -136,21 +159,9 @@     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+--------------------------------------------------------+-- Computing keys+--------------------------------------------------------   getKey :: DD.DAWG Char Int -> LexEntry -> (DD.DAWG Char Int, Key)@@ -166,42 +177,47 @@ 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 []+--------------------------------------------------------+-- Keys storage+--------------------------------------------------------  -forIO'Lazy :: [a] -> (a -> IO b) -> IO [b]-forIO'Lazy = flip mapIO'Lazy+-- | Save (key, lexID) pair in the keys component of the binary dictionary.+saveKey :: FilePath -> Key -> T.Text -> IO ()+saveKey path key i = T.writeFile (path </> keyDir </> showKey key) i  -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)+-- | Load lexID given the corresponding key.+loadKey :: FilePath -> Key -> IO T.Text+loadKey path key = T.readFile (path </> keyDir </> showKey key)  -maybeT :: Monad m => Maybe a -> MaybeT m a-maybeT = MaybeT . return-{-# INLINE maybeT #-}+--------------------------------------------------------+-- Entry storage+--------------------------------------------------------  -maybeErrT :: MonadIO m => IO a -> MaybeT m a-maybeErrT io = do-    r <- liftIO (maybeErr io)-    maybeT r+-- | Save entry in the binary dictionary.+saveEntry :: FilePath -> Key -> LexEntry -> IO ()+saveEntry path key x = do+    saveKey path key (lexID x)+    B.save (path </> entryDir) x  --- | Load lexical entry from disk by its key.-loadEntry :: FilePath -> Key -> IO (Maybe LexEntry)-loadEntry path key = do-    maybeErr $ decodeFile (path </> showKey key)+-- -- | 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.+tryLoadEntry :: FilePath -> Key -> IO (Maybe LexEntry)+tryLoadEntry path key = maybeErr $ do+    B.load (path </> entryDir) =<< loadKey path key++ ----------------------------------------------------------- Binary interface+-- Binary dictionary --------------------------------------------------------  @@ -212,7 +228,7 @@     -- | A path to the binary dictionary.       dictPath  :: FilePath     -- | A dictionary with lexicon forms.-    , formMap   :: D.Dict UID () Code+    , formMap   :: D.DAWG UID () Code     }  @@ -235,17 +251,12 @@         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)+    formMap'  <- maybeErrT $ decodeFile (path </> formFile)     doesExist <- liftIO $ doesDirectoryExist (path </> entryDir)     guard doesExist      return $ HistPL path formMap'@@ -260,29 +271,49 @@   -- | List of dictionary keys.-getIndex :: HistPL -> IO [Key]-getIndex hpl = map parseKey <$> loadContents (entryPath hpl)+dictKeys :: HistPL -> IO [Key]+dictKeys hpl = map parseKey <$> loadContents (dictPath hpl </> keyDir)  --- | Extract lexical entry with a given key.  Return `Nothing` if there+-- | Load lexical entry given its 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+tryLoad :: HistPL -> Key -> IO (Maybe LexEntry)+tryLoad hpl key = unsafeInterleaveIO $ tryLoadEntry (dictPath hpl) key  --- | Extract lexical entry with a given key.  Raise error if there+-- | Load lexical entry given its 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+load :: HistPL -> Key -> IO LexEntry+load hpl key = tryLoad hpl key >>= maybe+    (fail $ "load: failed to open entry with the " ++ show key ++ " key")+    return  +-- | 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+++-- | 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++ -- | 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+        [ (   , code) <$> load hpl key         | (key, code) <- getCode =<< M.assocs lexSet ]   where     getCode (key, val) =@@ -297,7 +328,7 @@             getCode =<< M.assocs =<<             (flip D.lookup (formMap hpl) <$> xs)     sequence-        [ (   , code) <$> withKey hpl key+        [ (   , code) <$> load hpl key         | (key, code) <- M.toList keyMap ]   where     getCode (key, val) =@@ -313,23 +344,22 @@ -- | 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+build :: FilePath -> [(LexEntry, S.Set T.Text)] -> IO (HistPL)+build 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+    emptyDirectory binPath >>= \empty -> unless empty $ do+        error $ "build: directory " ++ binPath ++ " is not empty"+    createDirectory $ binPath </> entryDir+    createDirectory $ binPath </> keyDir     formMap' <- D.fromList . concat <$>-        mapIO'Lazy (saveBin lexPath) (zip3 keys entries forms)-    encodeFile (binPath </> formMapFile) formMap'+        LazyIO.mapM saveBin (zip3 keys entries forms)+    encodeFile (binPath </> formFile) formMap'     return $ HistPL binPath formMap'   where     (entries, forms) = unzip xs     keys = getKeys entries-    saveBin lexPath (key, lexEntry, otherForms) = do-        saveEntry lexPath key lexEntry+    saveBin (key, lexEntry, otherForms) = do+        saveEntry binPath key lexEntry         let D.Key{..} = key             histForms = S.fromList (Util.allForms lexEntry)             onlyHist  = S.difference histForms otherForms@@ -340,9 +370,9 @@   -- | 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+loadAll :: HistPL -> IO [(Key, LexEntry)]+loadAll hpl = do+    keys <- dictKeys hpl+    LazyIO.forM keys $ \key -> do+        entry <- load hpl key         return (key, entry)

@@ -1,155 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}---- | A data type hierarchy provided by this module mirrors--- the hierarchy of structures kept in the original, LMF--- representation of the historical dictionary of Polish.--module NLP.HistPL.Types-( Repr (..)-, HasRepr (..)-, text-, WordForm (..)-, Lemma (..)-, RelForm (..)-, Definition (..)-, Context (..)-, SynBehaviour (..)-, Sense (..)-, LexEntry (..)-) where--import Control.Applicative ((<$>), (<*>))-import qualified Data.Text as T-import Data.Text.Binary ()-import Data.Binary (Binary, put, get)---- | Form or text representation.-data Repr = Repr-    { writtenForm :: T.Text-    , language    :: T.Text-    , sourceID    :: Maybe T.Text }-    deriving (Show, Read, Eq, Ord)--instance Binary Repr where-    put Repr{..} = do-        put writtenForm-        put language-        put sourceID-    get = Repr <$> get <*> get <*> get---- | A class of objects with a written representation.-class HasRepr t where-    repr :: t -> [Repr]--instance HasRepr [Repr] where-    repr = id---- | Get textual representations of an object.-text :: HasRepr t => t -> [T.Text]-text = map writtenForm . repr-{-# INLINE text #-}---- | A word form.-newtype WordForm = WordForm [Repr]-    deriving (Show, Read, Eq, Ord, Binary, HasRepr)---- | A related form.-data RelForm = RelForm-    { relRepr   :: [Repr]-    , relTo     :: T.Text }-    deriving (Show, Read, Eq, Ord)--instance Binary RelForm where-    put RelForm{..} = do-        put relRepr-        put relTo-    get = RelForm <$> get <*> get--instance HasRepr RelForm where-    repr = relRepr---- | A lemma (base) form.-newtype Lemma = Lemma [Repr]-    deriving (Show, Read, Eq, Ord, Binary, HasRepr)---- | A definition of the lexeme sense.-newtype Definition = Definition [Repr]-    deriving (Show, Read, Eq, Ord, Binary, HasRepr)---- | A context in which a given sense is illustrated.-newtype Context = Context [Repr]-    deriving (Show, Read, Eq, Ord, Binary, HasRepr)---- | A description of a syntactic behaviour.-data SynBehaviour = SynBehaviour-    { synRepr     :: [Repr]-    , synSenseIds :: [T.Text] }-    deriving (Show, Read, Eq, Ord)--instance HasRepr SynBehaviour where-    repr = synRepr--instance Binary SynBehaviour where-    put SynBehaviour{..} = do-        put synRepr-        put synSenseIds-    get = SynBehaviour <$> get <*> get---- | A potential sense of a given lexeme.-data Sense = Sense-    { senseId   :: Maybe T.Text-    , style     :: [T.Text]-    , defs      :: [Definition]-    , cxts      :: [Context] }-    deriving (Show, Read, Eq, Ord)--instance Binary Sense where-    put Sense{..} = do-        put senseId-        put style-        put defs-        put cxts-    get = Sense <$> get <*> get <*> get <*> get---- | A description of a lexeme.-data LexEntry = LexEntry {-    -- | An ID of the lexical entry.-      lexId         :: T.Text-    -- | A line reference number.  Provisional field.-    , lineRef       :: Maybe T.Text-    -- | A status of the lexeme.  Provisional field.-    , status        :: Maybe T.Text-    -- | Potential parts of speech.-    , pos           :: [T.Text]-    -- | A base form.-    , lemma         :: Lemma-    -- | Word forms of the lexeme.-    , forms         :: [WordForm]-    -- | A list of components (only when the entry represent-    -- a compound lexeme).-    , components    :: [T.Text]-    -- | A list of potential syntactic behaviours of the lexeme.-    , syntactic     :: [SynBehaviour]-    -- | A list of potential semantic descriptions.-    , senses        :: [Sense]-    -- | Forma related to the lexeme.-    , related       :: [RelForm] }-    deriving (Show, Read, Eq, Ord)--instance Binary LexEntry where-    put LexEntry{..} = do-        put lexId-        put lineRef-        put status-        put pos-        put lemma-        put forms-        put components-        put syntactic-        put senses-        put related-    get = LexEntry <$> get <*> get <*> get <*> get <*> get-                   <*> get <*> get <*> get <*> get <*> get