diff --git a/hist-pl-lexicon.cabal b/hist-pl-lexicon.cabal --- a/hist-pl-lexicon.cabal +++ b/hist-pl-lexicon.cabal @@ -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 diff --git a/src/NLP/HistPL/Binary.hs b/src/NLP/HistPL/Binary.hs new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/Binary.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 diff --git a/src/NLP/HistPL/Binary/Util.hs b/src/NLP/HistPL/Binary/Util.hs new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/Binary/Util.hs @@ -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 diff --git a/src/NLP/HistPL/Dict.hs b/src/NLP/HistPL/Dict.hs deleted file mode 100644 --- a/src/NLP/HistPL/Dict.hs +++ /dev/null @@ -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 diff --git a/src/NLP/HistPL/LMF.hs b/src/NLP/HistPL/LMF.hs deleted file mode 100644 --- a/src/NLP/HistPL/LMF.hs +++ /dev/null @@ -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 diff --git a/src/NLP/HistPL/LMF/Parse.hs b/src/NLP/HistPL/LMF/Parse.hs deleted file mode 100644 --- a/src/NLP/HistPL/LMF/Parse.hs +++ /dev/null @@ -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 diff --git a/src/NLP/HistPL/LMF/Show.hs b/src/NLP/HistPL/LMF/Show.hs deleted file mode 100644 --- a/src/NLP/HistPL/LMF/Show.hs +++ /dev/null @@ -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 = - [ "" - , "" - , " " - , " " - , " " - , " " ] - -epilog :: [L.Builder] -epilog = - [ " " - , "" ] - --- | 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 = " L.fromText (lexId lx) <> "\">" - end = "" - 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 = "" - end = "" - body = concatMap (buildRepr "FormRepresentation") (repr base) - -buildForm :: WordForm -> [L.Builder] -buildForm form = - buildElem beg body end - where - beg = "" - end = "" - body = concatMap (buildRepr "FormRepresentation") (repr form) - -buildRelForm :: RelForm -> [L.Builder] -buildRelForm form = - buildElem beg body end - where - beg = " L.fromText (relTo form) <> "\">" - end = "" - body = concatMap (buildRepr "FormRepresentation") (repr form) - -buildComps :: [T.Text] -> [L.Builder] -buildComps [] = [] -buildComps xs = - buildElem beg body end - where - beg = "" - end = "" - body = map comp xs - comp x = " L.fromText x <> "\"/>" - -buildSyn :: SynBehaviour -> [L.Builder] -buildSyn syn = - buildElem beg body end - where - ids = mconcat . intersperse " " . map L.fromText $ synSenseIds syn - beg = " ids <> "\">" - end = "" - body = concatMap (buildRepr "TextRepresentation") (repr syn) - -buildSense :: Sense -> [L.Builder] -buildSense sense = - buildElem beg body end - where - beg = case senseId sense of - Just x -> " L.fromText x <> "\">" - Nothing -> "" - end = "" - 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 = "" - end = "" - body = concatMap (buildRepr "TextRepresentation") (repr def) - -buildCxt :: Context -> [L.Builder] -buildCxt cxt = - buildElem beg body end - where - beg = "" - end = "" - 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 = - " att <> "\" val=\"" <> L.fromText val <> "\"/>" 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 @@ -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) diff --git a/src/NLP/HistPL/Types.hs b/src/NLP/HistPL/Types.hs deleted file mode 100644 --- a/src/NLP/HistPL/Types.hs +++ /dev/null @@ -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