diff --git a/NLP/Polh/Binary.hs b/NLP/Polh/Binary.hs deleted file mode 100644 --- a/NLP/Polh/Binary.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | The module provides functions for working with the binary --- representation of the historical dictionary of Polish. --- The dictionary is stored on a disk but we assume that it --- doesn't change throughtout the program session so that we --- can provide the pure interface for dictionary reading --- and searching. - -module NLP.Polh.Binary -( savePolh -, loadPolh - -, PolhM -, runPolh -, index -, withKey -, lookup -) where - -import Prelude hiding (lookup) -import Control.Exception (try, SomeException) -import Control.Monad (when, guard) -import Control.Applicative ((<$>)) -import Control.Monad.Reader (ReaderT (..), ask, lift) -import Control.Monad.Trans.Maybe (MaybeT (..)) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) -import System.FilePath (()) -import System.Directory ( getDirectoryContents, createDirectoryIfMissing - , createDirectory, doesDirectoryExist ) -import Data.Maybe (catMaybes) -import Data.Monoid (mappend, mconcat) -import Data.Binary (encodeFile, decodeFile) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T - -import NLP.Polh.Types -import qualified NLP.Polh.Util as Util - --- | 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 (lexical entry ID). -type Key = T.Text - --- | 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 lexical entry on the disk. -saveLexEntry :: FilePath -> LexEntry -> IO () -saveLexEntry path x = - let lexPath = T.unpack . lexId - in encodeFile (path lexPath x) x - --- | Save the polh dictionary in the empty directory. -savePolh :: FilePath -> Polh -> IO () -savePolh path xs = do - createDirectoryIfMissing True path - isEmpty <- emptyDirectory path - when (not isEmpty) $ do - error $ "savePolh: directory " ++ path ++ " is not empty" - let lexPath = path entryDir - createDirectory lexPath - formMap' <- mconcat <$> mapM (saveLex lexPath) xs - encodeFile (path formMapFile) formMap' - where - saveLex lexPath x = do - saveLexEntry lexPath x - return $ lexMap x - lexMap lexEntry = M.fromListWith mappend - [ (x, S.singleton key) - | x <- Util.allForms lexEntry ] - where - key = lexId lexEntry - -maybeErr :: IO a -> IO (Maybe a) -maybeErr io = do - r <- 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 :: IO a -> MaybeT IO a -maybeErrT io = do - r <- lift (maybeErr io) - maybeT r - --- | Load lexical entry from disk by its key. -loadLexEntry :: FilePath -> Key -> IO (Maybe LexEntry) -loadLexEntry path key = do - maybeErr $ decodeFile (path T.unpack key) - --- | Binary dictionary data kept in program memory. -data MemData = MemData - { polhPath :: FilePath - , formMap :: M.Map T.Text (S.Set Key) } - --- | A PolhM monad is a wrapper over the Polish historical --- dictionary in a binary form. -newtype PolhM a = PolhM (ReaderT MemData IO a) - deriving (Functor, Monad) - --- | Path to directory with entries. -entryPath :: MemData -> FilePath -entryPath = ( entryDir) . polhPath - --- | List of dictionary keys. -index :: PolhM [Key] -index = PolhM $ do - path <- entryPath <$> ask - map T.pack <$> lift (loadContents path) - --- | Extract lexical entry with the given ID. -withKey :: Key -> PolhM (Maybe LexEntry) -withKey key = PolhM $ do - path <- entryPath <$> ask - lift . unsafeInterleaveIO $ loadLexEntry path key - --- | Lookup the form in the dictionary. -lookup :: T.Text -> PolhM [LexEntry] -lookup x = do - fm <- PolhM $ formMap <$> ask - keys <- return $ case M.lookup x fm of - Nothing -> [] - Just xs -> S.toList xs - catMaybes <$> mapM withKey keys - --- | Execute the Polh monad against the binary Polh representation --- located in the given directory. Return Nothing if the directory --- doesnt' exist or if it doesn't look like a Polh dictionary. --- We assume that the binary representation doesn't change so we --- can provide the pure interface. -runPolh :: FilePath -> PolhM a -> Maybe a -runPolh path (PolhM m) = unsafePerformIO . runMaybeT $ do - formMap' <- maybeErrT $ decodeFile (path formMapFile) - doesExist <- lift $ doesDirectoryExist (path entryDir) - guard doesExist - lift $ runReaderT m (MemData path formMap') - --- | Load dictionary from a disk in a lazy manner. Return 'Nothing' --- if the path doesn't correspond to a binary representation of the --- dictionary. -loadPolh :: FilePath -> Maybe Polh -loadPolh path = runPolh path $ do - keys <- index - catMaybes <$> mapM withKey keys - --- We don't provide update functionality since we want only the pure --- iterface to be visible. It greatly simplifies the implementation. --- --- updateLexEntry :: FilePath -> Key -> (LexEntry -> LexEntry) -> IO LexEntry --- updateLexEntry path lexKey f = do --- lexEntry <- loadLexEntry path lexKey --- let lexEntry' = f lexEntry --- saveLexEntry path lexEntry' --- return lexEntry' --- --- updateLexEntry_ :: FilePath -> Key -> (LexEntry -> LexEntry) -> IO () --- updateLexEntry_ path lexKey f = do --- lexEntry <- loadLexEntry path lexKey --- saveLexEntry path (f lexEntry) diff --git a/NLP/Polh/LMF.hs b/NLP/Polh/LMF.hs deleted file mode 100644 --- a/NLP/Polh/LMF.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | Re-export modules from the LMF hierarchy. - -module NLP.Polh.LMF -( module NLP.Polh.LMF.Parse -, module NLP.Polh.LMF.Show -) where - -import NLP.Polh.LMF.Parse -import NLP.Polh.LMF.Show diff --git a/NLP/Polh/LMF/Parse.hs b/NLP/Polh/LMF/Parse.hs deleted file mode 100644 --- a/NLP/Polh/LMF/Parse.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | The module provides parsing utilities for the LMF dictionary. - -module NLP.Polh.LMF.Parse -( readPolh -, parsePolh -, 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.Polh.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. -readPolh :: FilePath -> IO Polh -readPolh = fmap parsePolh . L.readFile - --- | Parse the entire dictionary in the LMF format. -parsePolh :: L.Text -> Polh -parsePolh = parseXml lmfP - --- | Parse the lexical entry LMF representation -parseLexEntry :: L.Text -> LexEntry -parseLexEntry = parseXml lexEntryP diff --git a/NLP/Polh/LMF/Show.hs b/NLP/Polh/LMF/Show.hs deleted file mode 100644 --- a/NLP/Polh/LMF/Show.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Printing utilities for the LMF dictionary format. - -module NLP.Polh.LMF.Show -( showPolh -, 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.Polh.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. -showPolh :: Polh -> L.Text -showPolh = - 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/NLP/Polh/Types.hs b/NLP/Polh/Types.hs deleted file mode 100644 --- a/NLP/Polh/Types.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | The module provides types for dictionary representation. - -module NLP.Polh.Types -( Repr (..) -, HasRepr (..) -, text -, WordForm (..) -, Lemma (..) -, RelForm (..) -, Definition (..) -, Context (..) -, SynBehaviour (..) -, Sense (..) -, LexEntry (..) -, Polh -) 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 - --- | A polh dictionary is a list of lexical entries. -type Polh = [LexEntry] diff --git a/NLP/Polh/Util.hs b/NLP/Polh/Util.hs deleted file mode 100644 --- a/NLP/Polh/Util.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | Some utility functions for working with the dictionary. - -module NLP.Polh.Util -( allForms -, hasForm -, addForm -) where - -import qualified Data.Text as T -import NLP.Polh.Types - --- | All format (base form + other forms) of the lexeme. -allForms :: LexEntry -> [T.Text] -allForms lx - = text (lemma lx) - ++ concatMap text (forms lx) - --- | Does lexeme take the given form? -hasForm :: LexEntry -> T.Text -> Bool -hasForm lx x = x `elem` allForms lx - --- | Add new word form to the lexeme description. -addForm :: WordForm -> LexEntry -> LexEntry -addForm x lx = lx { forms = (x : forms lx) } diff --git a/polh-lexicon.cabal b/polh-lexicon.cabal --- a/polh-lexicon.cabal +++ b/polh-lexicon.cabal @@ -1,8 +1,11 @@ name: polh-lexicon -version: 0.1.0 -synopsis: Interface to a historical dictionary of Polish +version: 0.2 +synopsis: A library for manipulating the historical dictionary of Polish description: - Interface to a historical dictionary of Polish. + 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. license: BSD3 license-file: LICENSE cabal-version: >= 1.6 @@ -11,10 +14,11 @@ maintainer: waszczuk.kuba@gmail.com stability: experimental category: Natural Language Processing -homepage: https://github.com/kawu/synat +homepage: https://github.com/kawu/polh/lexicon build-type: Simple library + hs-source-dirs: src exposed-modules: NLP.Polh.Types NLP.Polh.LMF NLP.Polh.LMF.Parse @@ -29,15 +33,20 @@ , binary , text-binary >= 0.1 && < 0.2 , polysoup >= 0.1 && < 0.2 + , dawg >= 0.9 && < 0.10 , transformers , mtl ghc-options: -Wall +source-repository head + type: git + location: https://github.com/kawu/polh.git + executable polh-binarize - hs-source-dirs: ., tools + hs-source-dirs: src, tools main-is: polh-binarize.hs executable polh-show - hs-source-dirs: ., tools + hs-source-dirs: src, tools main-is: polh-show.hs diff --git a/src/NLP/Polh/Binary.hs b/src/NLP/Polh/Binary.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Polh/Binary.hs @@ -0,0 +1,285 @@ +{-# 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. + +module NLP.Polh.Binary +( BinEntry (..) +, Key (..) +, Rule (..) +, proxyForm +, binKey +, between +, apply + +, savePolh +, loadPolh + +, PolhT +, runPolhT +, PolhM +, runPolh +, index +, withKey +, lookup +) where + +import Prelude hiding (lookup) +import Control.Exception (try, SomeException) +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Monad (when, guard) +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Reader (ReaderT (..), ask, 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.Polh.Types +import qualified NLP.Polh.Util as Util + +-- | 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. + entry :: 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 entry >> 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 entry) 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 polh dictionary in the empty directory. +savePolh :: FilePath -> Polh -> IO () +savePolh path xs = do + createDirectoryIfMissing True path + isEmpty <- emptyDirectory path + when (not isEmpty) $ do + error $ "savePolh: 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 (entry binEntry) ] + where + key = binKey binEntry + +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) + +-- | 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 dictionary data kept in program memory. +data MemData = MemData + { polhPath :: FilePath + , formMap :: DAWG (S.Set Rule) } + +-- | A Polh monad transformer. +newtype PolhT m a = PolhT (ReaderT MemData m a) + deriving (Functor, Applicative, Monad, MonadTrans, MonadIO) + +-- | A Polh monad is a Polh monad transformer over the hidden IO monad. +type PolhM a = PolhT IO a + +-- | Path to directory with entries. +entryPath :: MemData -> FilePath +entryPath = ( entryDir) . polhPath + +-- | List of dictionary keys. +index :: (Applicative m, MonadIO m) => PolhT m [Key] +index = PolhT $ do + path <- entryPath <$> ask + map parseKey <$> liftIO (loadContents path) + +-- | Extract lexical entry with the given key. +withKey :: (Applicative m, MonadIO m) => Key -> PolhT m (Maybe BinEntry) +withKey key = PolhT $ do + path <- entryPath <$> ask + liftIO . unsafeInterleaveIO $ loadLexEntry path key + +-- | Lookup the form in the dictionary. +lookup :: (Applicative m, MonadIO m) => T.Text -> PolhT m [BinEntry] +lookup x = do + fm <- PolhT $ formMap <$> ask + keys <- return $ case D.lookup (T.unpack x) fm of + Nothing -> [] + Just xs -> map (flip apply x) (S.toList xs) + catMaybes <$> mapM withKey keys + +-- | Execute the Polh monad against the binary Polh representation +-- located in the given directory. Return Nothing if the directory +-- doesnt' exist or if it doesn't look like a Polh dictionary. +runPolh :: FilePath -> PolhM a -> IO (Maybe a) +runPolh path polh = runPolhT path polh + +-- | Execute the Polh monad transformer against the binary Polh representation +-- located in the given directory. Return Nothing if the directory doesnt' +-- exist or if it doesn't look like a Polh dictionary. +runPolhT :: MonadIO m => FilePath -> PolhT m a -> m (Maybe a) +runPolhT path (PolhT r) = runMaybeT $ do + formMap' <- maybeErrT $ decodeFile (path formMapFile) + doesExist <- liftIO $ doesDirectoryExist (path entryDir) + guard doesExist + lift $ runReaderT r (MemData path formMap') + +-- | Load dictionary from a disk in a lazy manner. Return 'Nothing' +-- if the path doesn't correspond to a binary representation of the +-- dictionary. +loadPolh :: FilePath -> IO (Maybe [BinEntry]) +loadPolh path = runPolhT path $ do + keys <- index + catMaybes <$> mapM withKey keys + +-- We don't provide update functionality since we want only the pure +-- iterface to be visible. It greatly simplifies the implementation. +-- +-- updateLexEntry :: FilePath -> Key -> (LexEntry -> LexEntry) -> IO LexEntry +-- updateLexEntry path lexKey f = do +-- lexEntry <- loadLexEntry path lexKey +-- let lexEntry' = f lexEntry +-- saveLexEntry path lexEntry' +-- return lexEntry' +-- +-- updateLexEntry_ :: FilePath -> Key -> (LexEntry -> LexEntry) -> IO () +-- updateLexEntry_ path lexKey f = do +-- lexEntry <- loadLexEntry path lexKey +-- saveLexEntry path (f lexEntry) diff --git a/src/NLP/Polh/LMF.hs b/src/NLP/Polh/LMF.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Polh/LMF.hs @@ -0,0 +1,9 @@ +-- | Re-export modules from the LMF hierarchy. + +module NLP.Polh.LMF +( module NLP.Polh.LMF.Parse +, module NLP.Polh.LMF.Show +) where + +import NLP.Polh.LMF.Parse +import NLP.Polh.LMF.Show diff --git a/src/NLP/Polh/LMF/Parse.hs b/src/NLP/Polh/LMF/Parse.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Polh/LMF/Parse.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The module provides parsing utilities for the LMF dictionary. + +module NLP.Polh.LMF.Parse +( readPolh +, parsePolh +, 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.Polh.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. +readPolh :: FilePath -> IO Polh +readPolh = fmap parsePolh . L.readFile + +-- | Parse the entire dictionary in the LMF format. +parsePolh :: L.Text -> Polh +parsePolh = parseXml lmfP + +-- | Parse the lexical entry LMF representation +parseLexEntry :: L.Text -> LexEntry +parseLexEntry = parseXml lexEntryP diff --git a/src/NLP/Polh/LMF/Show.hs b/src/NLP/Polh/LMF/Show.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Polh/LMF/Show.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Printing utilities for the LMF dictionary format. + +module NLP.Polh.LMF.Show +( showPolh +, 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.Polh.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. +showPolh :: Polh -> L.Text +showPolh = + 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/Polh/Types.hs b/src/NLP/Polh/Types.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Polh/Types.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | The module provides types for dictionary representation. + +module NLP.Polh.Types +( Repr (..) +, HasRepr (..) +, text +, WordForm (..) +, Lemma (..) +, RelForm (..) +, Definition (..) +, Context (..) +, SynBehaviour (..) +, Sense (..) +, LexEntry (..) +, Polh +) 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 + +-- | A polh dictionary is a list of lexical entries. +type Polh = [LexEntry] diff --git a/src/NLP/Polh/Util.hs b/src/NLP/Polh/Util.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Polh/Util.hs @@ -0,0 +1,24 @@ +-- | Some utility functions for working with the dictionary. + +module NLP.Polh.Util +( allForms +, hasForm +, addForm +) where + +import qualified Data.Text as T +import NLP.Polh.Types + +-- | All format (base form + other forms) of the lexeme. +allForms :: LexEntry -> [T.Text] +allForms lx + = text (lemma lx) + ++ concatMap text (forms lx) + +-- | Does lexeme take the given form? +hasForm :: LexEntry -> T.Text -> Bool +hasForm lx x = x `elem` allForms lx + +-- | Add new word form to the lexeme description. +addForm :: WordForm -> LexEntry -> LexEntry +addForm x lx = lx { forms = (x : forms lx) } diff --git a/tools/polh-show.hs b/tools/polh-show.hs --- a/tools/polh-show.hs +++ b/tools/polh-show.hs @@ -2,10 +2,10 @@ import qualified Data.Text.Lazy.IO as L import NLP.Polh.LMF (showPolh) -import NLP.Polh.Binary (loadPolh) +import NLP.Polh.Binary (loadPolh, entry) main = do [binPath] <- getArgs - case loadPolh binPath of + loadPolh binPath >>= \x -> case x of Nothing -> error "Not a dictionary" - Just ph -> L.putStr (showPolh ph) + Just ph -> L.putStr (showPolh $ map entry ph)