polh-lexicon 0.1.0 → 0.2

raw patch · 14 files changed

+823/−708 lines, 14 filesdep +dawgPVP ok

version bump matches the API change (PVP)

Dependencies added: dawg

API changes (from Hackage documentation)

Files

• NLP/Polh/Binary.hs +0/−179
• NLP/Polh/LMF.hs +0/−9
• NLP/Polh/LMF/Parse.hs +0/−160
• NLP/Polh/LMF/Show.hs +0/−170
• NLP/Polh/Types.hs +0/−157
• NLP/Polh/Util.hs +0/−24
• polh-lexicon.cabal +15/−6
• src/NLP/Polh/Binary.hs +285/−0
• src/NLP/Polh/LMF.hs +9/−0
• src/NLP/Polh/LMF/Parse.hs +160/−0
• src/NLP/Polh/LMF/Show.hs +170/−0
• src/NLP/Polh/Types.hs +157/−0
• src/NLP/Polh/Util.hs +24/−0
• tools/polh-show.hs +3/−3

@@ -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)

@@ -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

@@ -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

@@ -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 =-    [ "<?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.-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 = "<LexicalEntry id=\"" <> L.fromText (lexId lx) <> "\">"-    end = "</LexicalEntry>"-    body-        =  map (buildFeat "lineRef") (maybeToList $ lineRef lx)-        ++ map (buildFeat "status") (maybeToList $ status lx)-        ++ map (buildFeat "partOfSpeech") (pos lx)-        ++ buildLemma (lemma lx)-        ++ concatMap buildForm (forms lx)-        ++ concatMap buildRelForm (related lx)-        ++ buildComps (components lx)-        ++ concatMap buildSyn (syntactic lx)-        ++ concatMap buildSense (senses lx)--buildLemma :: Lemma -> [L.Builder]-buildLemma base =-    buildElem beg body end-  where-    beg = "<Lemma>"-    end = "</Lemma>"-    body = concatMap (buildRepr "FormRepresentation") (repr base)--buildForm :: WordForm -> [L.Builder]-buildForm form =-    buildElem beg body end-  where-    beg = "<WordForm>"-    end = "</WordForm>"-    body = concatMap (buildRepr "FormRepresentation") (repr form)--buildRelForm :: RelForm -> [L.Builder]-buildRelForm form =-    buildElem beg body end-  where-    beg = "<RelatedForm targets=\"" <> L.fromText (relTo form) <> "\">"-    end = "</RelatedForm>"-    body = concatMap (buildRepr "FormRepresentation") (repr form)--buildComps :: [T.Text] -> [L.Builder]-buildComps [] = []-buildComps xs =-    buildElem beg body end-  where-    beg = "<ListOfComponents>"-    end = "</ListOfComponents>"-    body = map comp xs-    comp x = "<Component entry=\"" <> L.fromText x <> "\"/>"--buildSyn :: SynBehaviour -> [L.Builder]-buildSyn syn =-    buildElem beg body end-  where-    ids = mconcat . intersperse " " . map L.fromText $ synSenseIds syn-    beg = "<SyntacticBehaviour senses=\"" <> ids <> "\">"-    end = "</SyntacticBehaviour>"-    body = concatMap (buildRepr "TextRepresentation") (repr syn)--buildSense :: Sense -> [L.Builder]-buildSense sense =-    buildElem beg body end-  where-    beg = case senseId sense of-        Just x  -> "<Sense id=\"" <> L.fromText x <> "\">"-        Nothing -> "<Sense>"-    end = "</Sense>"-    body-        =  map (buildFeat "style") (style sense)-        ++ concatMap buildDef (defs sense)-        ++ concatMap buildCxt (cxts sense)--buildDef :: Definition -> [L.Builder]-buildDef def =-    buildElem beg body end-  where-    beg = "<Definition>"-    end = "</Definition>"-    body = concatMap (buildRepr "TextRepresentation") (repr def)--buildCxt :: Context -> [L.Builder]-buildCxt cxt =-    buildElem beg body end-  where-    beg = "<Context>"-    end = "</Context>"-    body = concatMap (buildRepr "TextRepresentation") (repr cxt)--buildRepr :: L.Builder -> Repr -> [L.Builder]-buildRepr tag rp =-    buildElem beg body end-  where-    beg = "<"  <> tag <> ">"-    end = "</" <> tag <> ">"-    body =-        [ buildFeat "writtenForm" . escapeXml $ writtenForm rp-        , buildFeat "language" (language rp) ] ++ source-    source = case sourceID rp of-        Just x  -> [buildFeat "sourceID" x]-        Nothing -> []--buildFeat :: L.Builder -> T.Text -> L.Builder-buildFeat att val =-    "<feat att=\"" <> att <> "\" val=\"" <> L.fromText val <> "\"/>"

@@ -1,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]

@@ -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) }

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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 =+    [ "<?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.+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 = "<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 <> "\"/>"

@@ -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]

@@ -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) }

@@ -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)