packages feed

hist-pl-lmf (empty) → 0.1.0

raw patch · 6 files changed

+403/−0 lines, 6 filesdep +basedep +hist-pl-typesdep +polysoupsetup-changed

Dependencies added: base, hist-pl-types, polysoup, text

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-lmf.cabal view
@@ -0,0 +1,34 @@+name:               hist-pl-lmf+version:            0.1.0+synopsis:           LMF parsing for the historical dictionary of Polish+description:+    The library provides a Lexical Markup Framework (LMF) parsing+    utilities which allow to translate the original LMF representation+    of the historical dictionary of Polish to data structures defined+    in the hist-pl-types library.+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/lmf+build-type:         Simple++library+  hs-source-dirs:   src+  exposed-modules:    NLP.HistPL.LMF+                    , NLP.HistPL.LMF.Parse+                    , NLP.HistPL.LMF.Show+  build-depends:      base >= 4 && < 5 +                    , text+                    , polysoup >= 0.1 && < 0.2+                    , hist-pl-types >= 0.1 && < 0.2++  ghc-options: -Wall++source-repository head+    type: git+    location: https://github.com/kawu/hist-pl.git
+ 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 <> "\"/>"