packages feed

hist-pl-lexicon (empty) → 0.3.0

raw patch · 11 files changed

+984/−0 lines, 11 filesdep +basedep +binarydep +containerssetup-changed

Dependencies added: base, binary, containers, dawg, directory, filepath, mtl, polysoup, text, text-binary, transformers

Files

+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ hist-pl-lexicon.cabal view
@@ -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
+ src/NLP/HistPL.hs view
@@ -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
+ src/NLP/HistPL/LMF.hs view
@@ -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
+ src/NLP/HistPL/LMF/Parse.hs view
@@ -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
+ src/NLP/HistPL/LMF/Show.hs view
@@ -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 =+    [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+    , "<LexicalResource dtdVersion=\"16\">"+    , "  <GlobalInformation>"+    , "    <feat att=\"languageCoding\" val=\"ISO 639-6\"/>"+    , "  </GlobalInformation>"+    , "  <Lexicon>" ]++epilog :: [L.Builder]+epilog =+    [ "  </Lexicon>"+    , "</LexicalResource>" ]++-- | Show the entire dictionary as a lazy text in the LMF format.+showLMF :: [LexEntry] -> L.Text+showLMF =+    L.toLazyText . mconcat . map (<> "\n") . embed . concatMap buildLexEntry+    where embed body = prolog ++ map (ident.ident) body ++ epilog++-- | Show lexical entry using the LMF format.+showLexEntry :: LexEntry -> L.Text+showLexEntry =+    L.toLazyText . mconcat . map (<> "\n") . buildLexEntry++buildElem :: L.Builder -> [L.Builder] -> L.Builder -> [L.Builder]+buildElem beg body end = beg : map ident body ++ [end] ++-- | Each output line is represented as a builder. We use separate builders+-- for separate lines because we want to easilly indent the output text.+buildLexEntry :: LexEntry -> [L.Builder]+buildLexEntry lx =+    buildElem beg body end+  where+    beg = "<LexicalEntry id=\"" <> L.fromText (lexId lx) <> "\">"+    end = "</LexicalEntry>"+    body+        =  map (buildFeat "lineRef") (maybeToList $ lineRef lx)+        ++ map (buildFeat "status") (maybeToList $ status lx)+        ++ map (buildFeat "partOfSpeech") (pos lx)+        ++ buildLemma (lemma lx)+        ++ concatMap buildForm (forms lx)+        ++ concatMap buildRelForm (related lx)+        ++ buildComps (components lx)+        ++ concatMap buildSyn (syntactic lx)+        ++ concatMap buildSense (senses lx)++buildLemma :: Lemma -> [L.Builder]+buildLemma base =+    buildElem beg body end+  where+    beg = "<Lemma>"+    end = "</Lemma>"+    body = concatMap (buildRepr "FormRepresentation") (repr base)++buildForm :: WordForm -> [L.Builder]+buildForm form =+    buildElem beg body end+  where+    beg = "<WordForm>"+    end = "</WordForm>"+    body = concatMap (buildRepr "FormRepresentation") (repr form)++buildRelForm :: RelForm -> [L.Builder]+buildRelForm form =+    buildElem beg body end+  where+    beg = "<RelatedForm targets=\"" <> L.fromText (relTo form) <> "\">"+    end = "</RelatedForm>"+    body = concatMap (buildRepr "FormRepresentation") (repr form)++buildComps :: [T.Text] -> [L.Builder]+buildComps [] = []+buildComps xs =+    buildElem beg body end+  where+    beg = "<ListOfComponents>"+    end = "</ListOfComponents>"+    body = map comp xs+    comp x = "<Component entry=\"" <> L.fromText x <> "\"/>"++buildSyn :: SynBehaviour -> [L.Builder]+buildSyn syn =+    buildElem beg body end+  where+    ids = mconcat . intersperse " " . map L.fromText $ synSenseIds syn+    beg = "<SyntacticBehaviour senses=\"" <> ids <> "\">"+    end = "</SyntacticBehaviour>"+    body = concatMap (buildRepr "TextRepresentation") (repr syn)++buildSense :: Sense -> [L.Builder]+buildSense sense =+    buildElem beg body end+  where+    beg = case senseId sense of+        Just x  -> "<Sense id=\"" <> L.fromText x <> "\">"+        Nothing -> "<Sense>"+    end = "</Sense>"+    body+        =  map (buildFeat "style") (style sense)+        ++ concatMap buildDef (defs sense)+        ++ concatMap buildCxt (cxts sense)++buildDef :: Definition -> [L.Builder]+buildDef def =+    buildElem beg body end+  where+    beg = "<Definition>"+    end = "</Definition>"+    body = concatMap (buildRepr "TextRepresentation") (repr def)++buildCxt :: Context -> [L.Builder]+buildCxt cxt =+    buildElem beg body end+  where+    beg = "<Context>"+    end = "</Context>"+    body = concatMap (buildRepr "TextRepresentation") (repr cxt)++buildRepr :: L.Builder -> Repr -> [L.Builder]+buildRepr tag rp =+    buildElem beg body end+  where+    beg = "<"  <> tag <> ">"+    end = "</" <> tag <> ">"+    body =+        [ buildFeat "writtenForm" . escapeXml $ writtenForm rp+        , buildFeat "language" (language rp) ] ++ source+    source = case sourceID rp of+        Just x  -> [buildFeat "sourceID" x]+        Nothing -> []++buildFeat :: L.Builder -> T.Text -> L.Builder+buildFeat att val =+    "<feat att=\"" <> att <> "\" val=\"" <> L.fromText val <> "\"/>"
+ src/NLP/HistPL/Types.hs view
@@ -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
+ src/NLP/HistPL/Util.hs view
@@ -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) }
+ tools/hist-pl-binarize.hs view
@@ -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
+ tools/hist-pl-show.hs view
@@ -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)