diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2012, IPI PAN +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/hist-pl-lexicon.cabal b/hist-pl-lexicon.cabal new file mode 100644 --- /dev/null +++ b/hist-pl-lexicon.cabal @@ -0,0 +1,52 @@ +name: hist-pl-lexicon +version: 0.3.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. +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.6 +copyright: Copyright (c) 2012 IPI PAN +author: Jakub Waszczuk +maintainer: waszczuk.kuba@gmail.com +stability: experimental +category: Natural Language Processing +homepage: https://github.com/kawu/hist-pl/tree/master/lexicon +build-type: Simple + +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 + build-depends: base >= 4 && < 5 + , containers + , directory + , filepath + , text + , 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/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.hs b/src/NLP/HistPL.hs new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + + +{-| + The module provides functions for working with the binary + representation of the historical dictionary of Polish. + + It is intended to be imported qualified, to avoid name + clashes with Prelude functions, e.g. + + > import qualified NLP.HistPL as H + + Use `save` and `load` functions to save/load + the entire dictionary in/from a given directory. They are + particularly useful when you want to convert the @LMF@ dictionary + to a binary format (see "NLP.HistPL.LMF" module). + + To search the dictionary, open the binary directory with an + `open` function. For example, during a @GHCi@ session: + + >>> hpl <- H.open "srpsdp.bin" + + Set the OverloadedStrings extension for convenience: + + >>> :set -XOverloadedStrings + + To search the dictionary use the `lookup` function, e.g. + + >>> entries <- H.lookup hpl "dufliwego" + + You can use functions defined in the "NLP.HistPL.Types" module + to query the entries for a particular feature, e.g. + + >>> map (H.text . H.lemma) entries + [["dufliwy"]] +-} + + +module NLP.HistPL +( +-- * Entries + BinEntry (..) +, Key (..) +, proxyForm +, binKey + +-- * Rules +, Rule (..) +, between +, apply + +-- * Dictionary +, HistPL +-- ** Open +, tryOpen +, open +-- ** Query +, lookup +, lookupBin +, getIndex +, withKey + +-- * Conversion +-- ** Save +, save +-- ** Load +, load + +-- * Modules +-- $modules +, module NLP.HistPL.Types +) where + + +import Prelude hiding (lookup) +import Control.Exception (try, SomeException) +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Monad (when, guard) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Reader (lift) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.FilePath (()) +import System.Directory ( getDirectoryContents, createDirectoryIfMissing + , createDirectory, doesDirectoryExist ) +import Data.Maybe (catMaybes) +import Data.List (mapAccumL) +import Data.Binary (Binary, get, put, encodeFile, decodeFile) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.DAWG.Dynamic as DD +import qualified Data.DAWG.Static as D + +import NLP.HistPL.Types +import qualified NLP.HistPL.Util as Util + +{- $modules + "NLP.HistPL.Types" module exports hierarchy of data types + stored in the binary dictionary. +-} + + +-- | Static DAWG version. +type DAWG a = D.DAWG Char () a + + +-- | Path to entries in the binary dictionary. +entryDir :: String +entryDir = "entries" + + +-- | Path to key map in the binary dictionary. +formMapFile :: String +formMapFile = "forms.bin" + + +-- | Entry in the binary dictionary consists of the lexical +-- entry and corresponding unique identifier. +data BinEntry = BinEntry { + -- | Lexical entry. + lexEntry :: LexEntry + -- | Unique identifier among lexical entries with the same first form + -- (see 'Key' data type). + , uid :: Int } + deriving (Show, Eq, Ord) + + +instance Binary BinEntry where + put BinEntry{..} = put lexEntry >> put uid + get = BinEntry <$> get <*> get + + +-- | A dictionary key which uniquely identifies the lexical entry. +data Key = Key { + -- | First form (presumably lemma) of the lexical entry. + keyForm :: T.Text + -- | Unique identifier among lexical entries with the same 'keyForm'. + , keyUid :: Int } + deriving (Show, Eq, Ord) + + +-- | Form representing the lexical entry. +proxyForm :: LexEntry -> T.Text +proxyForm entry = case Util.allForms entry of + (x:_) -> x + [] -> error "proxyForm: entry with no forms" + + +-- | Key assigned to the binary entry. +binKey :: BinEntry -> Key +binKey BinEntry{..} = Key (proxyForm lexEntry) uid + + +-- | Convert the key to the path where binary representation of the entry +-- is stored. +showKey :: Key -> String +showKey Key{..} = (T.unpack . T.concat) [T.pack (show keyUid), "-", keyForm] + + +-- | Parse the key. +parseKey :: String -> Key +parseKey x = + let (uid'S, (_:form'S)) = break (=='-') x + in Key (T.pack form'S) (read uid'S) + + +-- | Load the directory contents. +loadContents :: FilePath -> IO [FilePath] +loadContents path = do + xs <- getDirectoryContents path + return [x | x <- xs, x /= ".", x /= ".."] + + +-- | Check if the directory is empty. +emptyDirectory :: FilePath -> IO Bool +emptyDirectory path = null <$> loadContents path + + +-- | Save the binary entry on the disk. +saveLexEntry :: FilePath -> BinEntry -> IO () +saveLexEntry path x = + let binPath = showKey . binKey + in encodeFile (path binPath x) x + + +withUid :: DD.DAWG Char Int -> LexEntry -> (DD.DAWG Char Int, BinEntry) +withUid m x = + let path = T.unpack (proxyForm x) + num = maybe 0 id (DD.lookup path m) + 1 + in (DD.insert path num m, BinEntry x num) + + +withUids :: [LexEntry] -> [BinEntry] +withUids = snd . mapAccumL withUid DD.empty + + +mapIO'Lazy :: (a -> IO b) -> [a] -> IO [b] +mapIO'Lazy f (x:xs) = (:) <$> f x <*> unsafeInterleaveIO (mapIO'Lazy f xs) +mapIO'Lazy _ [] = return [] + + +-- | Save the HistPL dictionary in the empty directory. +save :: FilePath -> [LexEntry] -> IO () +save path xs = do + createDirectoryIfMissing True path + isEmpty <- emptyDirectory path + when (not isEmpty) $ do + error $ "save: directory " ++ path ++ " is not empty" + let lexPath = path entryDir + createDirectory lexPath + formMap' <- D.fromListWith S.union . concat + <$> mapIO'Lazy (saveLex lexPath) (withUids xs) + encodeFile (path formMapFile) formMap' + where + saveLex lexPath x = do + saveLexEntry lexPath x + return $ rules x + rules binEntry = + [ ( T.unpack x + , S.singleton (between x key) ) + | x <- Util.allForms (lexEntry binEntry) ] + where + key = binKey binEntry + + +-- | Load dictionary from a disk in a lazy manner. Return 'Nothing' +-- if the path doesn't correspond to a binary representation of the +-- dictionary. +load :: FilePath -> IO (Maybe [BinEntry]) +load path = runMaybeT $ do + hpl <- MaybeT $ tryOpen path + lift $ do + keys <- getIndex hpl + catMaybes <$> mapM (withKey hpl) keys + + +maybeErr :: MonadIO m => IO a -> m (Maybe a) +maybeErr io = do + r <- liftIO (try io) + case r of + Left (_e :: SomeException) -> return Nothing + Right x -> return (Just x) + + +maybeT :: Monad m => Maybe a -> MaybeT m a +maybeT = MaybeT . return +{-# INLINE maybeT #-} + + +maybeErrT :: MonadIO m => IO a -> MaybeT m a +maybeErrT io = do + r <- liftIO (maybeErr io) + maybeT r + + +-- | Load lexical entry from disk by its key. +loadLexEntry :: FilePath -> Key -> IO (Maybe BinEntry) +loadLexEntry path key = do + maybeErr $ decodeFile (path showKey key) + + +-------------------------------------------------------- +-- Rules +-------------------------------------------------------- + + +-- | A rule for translating a form into a binary dictionary key. +data Rule = Rule { + -- | Number of characters to cut from the end of the form. + cut :: !Int + -- | A suffix to paste. + , suffix :: !T.Text + -- | Unique identifier of the entry. + , ruleUid :: !Int } + deriving (Show, Eq, Ord) + + +instance Binary Rule where + put Rule{..} = put cut >> put suffix >> put ruleUid + get = Rule <$> get <*> get <*> get + + +-- | Apply the rule. +apply :: Rule -> T.Text -> Key +apply r x = + let y = T.take (T.length x - cut r) x `T.append` suffix r + in Key y (ruleUid r) + + +-- | Make a rule which translates between the string and the key. +between :: T.Text -> Key -> Rule +between source dest = + let k = lcp source (keyForm dest) + in Rule (T.length source - k) (T.drop k (keyForm dest)) (keyUid dest) + where + lcp a b = case T.commonPrefixes a b of + Just (c, _, _) -> T.length c + Nothing -> 0 + + +-------------------------------------------------------- +-- Binary interface +-------------------------------------------------------- + + +-- | A binary dictionary handle. +data HistPL = HistPL { + -- | A path to the binary dictionary. + dictPath :: FilePath + -- | A map with lexicon forms. + , formMap :: DAWG (S.Set Rule) + } + + +-- | Path to directory with entries. +entryPath :: HistPL -> FilePath +entryPath = ( entryDir) . dictPath + + +-- | Open the binary dictionary residing in the given directory. +-- Return Nothing if the directory doesn't exist or if it doesn't +-- constitute a dictionary. +tryOpen :: FilePath -> IO (Maybe HistPL) +tryOpen path = runMaybeT $ do + formMap' <- maybeErrT $ decodeFile (path formMapFile) + doesExist <- liftIO $ doesDirectoryExist (path entryDir) + guard doesExist + return $ HistPL path formMap' + + +-- | Open the binary dictionary residing in the given directory. +-- Raise an error if the directory doesn't exist or if it doesn't +-- constitute a dictionary. +open :: FilePath -> IO HistPL +open path = tryOpen path >>= + maybe (fail "Failed to open the dictionary") return + + +-- | List of dictionary keys. +getIndex :: HistPL -> IO [Key] +getIndex hpl = map parseKey <$> loadContents (entryPath hpl) + + +-- | Extract lexical entry with a given key. +withKey :: HistPL -> Key -> IO (Maybe BinEntry) +withKey hpl key = unsafeInterleaveIO $ loadLexEntry (entryPath hpl) key + + +-- | Lookup the form in the dictionary. +lookup :: HistPL -> T.Text -> IO [LexEntry] +lookup hpl = fmap (map lexEntry) . lookupBin hpl + + +-- | Lookup the form in the dictionary. Similar to `lookup`, but +-- returns the `BinEntry` which can be used to determine place of +-- the entry in the dictionary storage. +lookupBin :: HistPL -> T.Text -> IO [BinEntry] +lookupBin hpl x = do + let keys = case D.lookup (T.unpack x) (formMap hpl) of + Nothing -> [] + Just xs -> map (flip apply x) (S.toList xs) + catMaybes <$> mapM (withKey hpl) keys diff --git a/src/NLP/HistPL/LMF.hs b/src/NLP/HistPL/LMF.hs new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/LMF.hs @@ -0,0 +1,9 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/LMF/Parse.hs @@ -0,0 +1,160 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/LMF/Show.hs @@ -0,0 +1,170 @@ +{-# 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/Types.hs b/src/NLP/HistPL/Types.hs new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/Types.hs @@ -0,0 +1,155 @@ +{-# 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 diff --git a/src/NLP/HistPL/Util.hs b/src/NLP/HistPL/Util.hs new file mode 100644 --- /dev/null +++ b/src/NLP/HistPL/Util.hs @@ -0,0 +1,24 @@ +-- | Some utility functions for working with the dictionary. + +module NLP.HistPL.Util +( allForms +, hasForm +, addForm +) where + +import qualified Data.Text as T +import NLP.HistPL.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/hist-pl-binarize.hs b/tools/hist-pl-binarize.hs new file mode 100644 --- /dev/null +++ b/tools/hist-pl-binarize.hs @@ -0,0 +1,7 @@ +import System.Environment (getArgs) +import NLP.HistPL.LMF (readLMF) +import qualified NLP.HistPL as H + +main = do + [lmfPath, binPath] <- getArgs + H.save binPath =<< readLMF lmfPath diff --git a/tools/hist-pl-show.hs b/tools/hist-pl-show.hs new file mode 100644 --- /dev/null +++ b/tools/hist-pl-show.hs @@ -0,0 +1,11 @@ +import System.Environment (getArgs) +import qualified Data.Text.Lazy.IO as L + +import NLP.HistPL.LMF (showLMF) +import qualified NLP.HistPL as H + +main = do + [binPath] <- getArgs + H.load binPath >>= \x -> case x of + Nothing -> error "Not a dictionary" + Just pl -> L.putStr (showLMF $ map H.lexEntry pl)