diff --git a/hist-pl.cabal b/hist-pl.cabal --- a/hist-pl.cabal +++ b/hist-pl.cabal @@ -1,5 +1,5 @@ name: hist-pl -version: 0.1.0 +version: 0.2.0 synopsis: Umbrella package for the historical dictionary of Polish description: The package provides a tool for creating and searching the @@ -19,8 +19,11 @@ hs-source-dirs: src exposed-modules: NLP.HistPL.Analyse build-depends: base >= 4 && < 5 + , containers , text + , aeson >= 0.6 && < 0.7 , hist-pl-lexicon >= 0.4 && < 0.5 + , hist-pl-transliter >= 0.1 && < 0.2 , morfeusz >= 0.4 && < 0.5 executable hist-pl @@ -29,6 +32,8 @@ build-depends: base >= 4 && < 5 , containers , cmdargs + , bytestring + , aeson-pretty >= 0.7 && < 0.8 , polimorf >= 0.7.1 && < 0.8 , hist-pl-lexicon >= 0.4 && < 0.5 , hist-pl-fusion >= 0.4 && < 0.5 diff --git a/src/NLP/HistPL/Analyse.hs b/src/NLP/HistPL/Analyse.hs --- a/src/NLP/HistPL/Analyse.hs +++ b/src/NLP/HistPL/Analyse.hs @@ -7,32 +7,44 @@ module NLP.HistPL.Analyse -( Token (..) +( +-- * Tokenization + Token (..) , Other (..) , tokenize -, anaText +, rmHyphen +-- * Analysis , anaWord , mapL -, showAna +-- * JSON +, JConf (..) +, ShowCont (..) +, defaultJConf +, jsonAna ) where -import Control.Applicative ((<$>), (<*>), pure) -import Data.Maybe (fromJust) -import Data.Monoid (Monoid, mappend, mconcat) -import Data.Ord (comparing) -import Data.List (sortBy, intersperse) +import Control.Applicative ((<$>), (<*>), pure) +import Data.Maybe (fromJust) +import Data.Monoid (Monoid, mappend, mconcat) +import Data.Ord (comparing) +import Data.List (sortBy, intersperse) import qualified Data.Map as M import qualified Data.Char as C import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as L +import Data.Aeson import qualified NLP.Morfeusz as R import qualified NLP.HistPL.Lexicon as H +----------------------------------------------------- +-- Basic types +----------------------------------------------------- + -- | A token is an element of the analysis result. data Token = Token { -- | Orthographic form. @@ -53,8 +65,18 @@ deriving (Show) +----------------------------------------------------- +-- Tokenization +----------------------------------------------------- + + +-- | Remove all instances of the \"-\\n\" string. +rmHyphen :: L.Text -> L.Text +rmHyphen = L.concat . L.splitOn "-\n" + + -- | Perform simple tokenization -- spaces and punctuation --- are treated as token ending markers. +-- characters are treated as token ending markers. tokenize :: T.Text -> [Either T.Text Other] tokenize = map mkElem . T.groupBy cmp @@ -69,12 +91,12 @@ | otherwise = Left x --- | Analyse the text. -anaText :: H.HistPL -> T.Text -> IO [Either Token Other] -anaText hpl = mapL (anaWord hpl) . tokenize - - --- | Map the monadic function over left elements. +----------------------------------------------------- +-- Analysis +----------------------------------------------------- + + +-- | Map the monadic function over the left elements of the input list. mapL :: (Functor m, Monad m) => (a -> m a') -> [Either a b] -> m [Either a' b] mapL f = let g (Left x) = Left <$> f x @@ -90,91 +112,93 @@ return $ Token x _hist _cont --- -- | Analyse the word with respect to the historical dictionary. --- anaHist :: Hist -> T.Text -> IO [(H.Code, H.LexEntry)] --- anaHist hd word = sequence --- [ (,) <$> follow (H.Key base uid) <*> pure code --- | (H.LexKey{..}, H.LexElem{..}) <- M.assocs keys --- , (base, code) <- M.assocs forms ] --- where --- -- Identify lexical entry with the given key. --- follow = fmap (H.lexEntry . fromJust) . H.withKey (histPL hd) --- -- Analyse both the original form and the lowercased form. --- keys = M.unionWith (right (M.unionWith min)) --- (ana word) --- (ana (T.toLower word)) --- right f (H.LexElem x y) (H.LexElem _ y') = H.LexElem x (f y y') --- ana = flip H.lookup (fused hd) - - -- | Analyse word using the Morfeusz analyser for contemporary Polish. anaCont :: T.Text -> [[R.Interp]] anaCont = map R.interps . head . R.paths . R.analyse False --- | Show analysed text. -showAna :: [Either Token Other] -> L.Text -showAna = L.toLazyText . mconcat . newlineSep . buildAna +----------------------------------------------------- +-- JSON +----------------------------------------------------- -buildAna :: [Either Token Other] -> [L.Builder] -buildAna xs = "sent:" : - map indent (concatMap (either buildTok buildOther) xs) +-- | When contemporary interpretations should be shown. +data ShowCont + = NoShowCont + | ShowCont + | ForceShowCont + deriving (Show, Eq, Ord) --- | List of Text builders for the token. Individual lines are represented --- by different builders. -buildTok :: Token -> [L.Builder] -buildTok tok - = buildHead tok - : map (indent . buildHist) histInterps - -- ++ concatMap buildCont (cont tok) - where - histInterps = sortBy (comparing snd) (hist tok) +-- | JSON serialization configuration. Depending on the configuration, +-- different parts of the result will be converted to a JSON format. +data JConf = JConf + { showCont :: ShowCont } + deriving (Show, Eq, Ord) -buildHead :: Token -> L.Builder -buildHead tok = "word: " <> L.fromText (orth tok) +-- | Default JSON serialization configuration. +defaultJConf :: JConf +defaultJConf = JConf + { showCont = ShowCont } --- | Build a list of historical interpretations. -buildHist :: (H.LexEntry, H.Code) -> L.Builder -buildHist (entry, code) - = "hist: " <> buildID (H.lexId entry, code) - <> " " <> buildPos - <> ": " <> commaRepr (H.lemma entry) --- <> " " <> "tags: " - where - buildID (id', cd') = "[" <> L.fromText id' <> ", " <> buildCode cd' <> "]" - buildPos = case H.pos entry of - [] -> "-" - xs -> mconcat . commaSep . map L.fromText $ xs - buildCode code' = case code' of - H.Orig -> "orig" - H.Both -> "both" - H.Copy -> "copy" +-- | Build JSON value from a list of analysed sentences. +jsonAna :: JConf -> [Either Token Other] -> Value +jsonAna jc = toJSON . map (jsonSent jc) -buildOther :: Other -> [L.Builder] -buildOther (Space _) = [""] -buildOther (Pun t) = ["pun: " <> L.fromText t] +-- | JSON representation of a sentence. +jsonSent :: JConf -> Either Token Other -> Value +jsonSent jc = either (jsonTok jc) (jsonOther jc) -commaRepr :: H.HasRepr t => t -> L.Builder -commaRepr = mconcat . commaSep . map L.fromText . H.text +-- | JSON represesentation of other segment. +jsonOther :: JConf -> Other -> Value +jsonOther _ (Space _) = toJSON ("space" :: T.Text) +jsonOther _ (Pun t) = toJSON $ "pun: " `T.append` t -(<>) :: Monoid m => m -> m -> m -(<>) = mappend +-- | JSON represesentation of a token. +jsonTok :: JConf -> Token -> Value +jsonTok jc tok = object $ + [ "orth" .= orth tok + , "hist" .= map (jsonHist jc) (hist tok) ] ++ + maybeCont + where + maybeCont + | null (hist tok) && showCont jc /= NoShowCont = [contElem] + | showCont jc == ForceShowCont = [contElem] + | otherwise = [] + contElem = "cont" .= jsonCont jc (cont tok) + +-- | JSON represesentation of a historical interpretation. +jsonHist :: JConf -> (H.LexEntry, H.Code) -> Value +jsonHist jc (entry, code) = object + [ "id" .= jsonID (H.lexId entry, code) + , "pos" .= map toJSON (H.pos entry) + , "base" .= map toJSON (H.text $ H.lemma entry) ] + where + jsonID (id', cd') = toJSON (toJSON id', jsonCode cd') + jsonCode code' = toJSON $ case code' of + H.Orig -> "orig" :: T.Text + H.Both -> "both" + H.Copy -> "copy" -indent :: L.Builder -> L.Builder -indent = (" " <>) +-- | JSON represesentation of a contemporary interpretation. +jsonCont :: JConf -> [[R.Interp]] -> Value +jsonCont _ = toJSON . map (map jsonI) where + jsonI x = object + [ "base" .= R.base x + , "msd" .= R.msd x ] -commaSep :: [L.Builder] -> [L.Builder] -commaSep = intersperse ", " +----------------------------------------------------- +-- Utils +----------------------------------------------------- -newlineSep :: [L.Builder] -> [L.Builder] -newlineSep = intersperse "\n" + +(<>) :: Monoid m => m -> m -> m +(<>) = mappend diff --git a/tools/hist-pl.hs b/tools/hist-pl.hs --- a/tools/hist-pl.hs +++ b/tools/hist-pl.hs @@ -9,8 +9,12 @@ import System.Console.CmdArgs import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.IO as L +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.Aeson as Aeson import qualified Data.PoliMorf as P import qualified NLP.HistPL.LMF as LMF @@ -19,6 +23,8 @@ import qualified NLP.HistPL.Fusion as F import qualified NLP.HistPL.Analyse as A +import qualified NLP.HistPL.Transliter.Impact as I + import Paths_hist_pl (version) import Data.Version (showVersion) @@ -28,9 +34,9 @@ --------------------------------------- --- | A description of the Concraft-pl tool -concraftDesc :: String -concraftDesc = "HistPL " ++ showVersion version +-- | A description of the hist-pl tool +histDesc :: String +histDesc = "HistPL " ++ showVersion version data HistPL @@ -41,7 +47,11 @@ | Print { binPath :: FilePath } | Analyse - { binPath :: FilePath } + { binPath :: FilePath + , transFlag :: Bool + , rmHypFlag :: Bool + , compact :: Bool + , printCont :: Int } deriving (Data, Typeable, Show) @@ -59,13 +69,23 @@ anaMode :: HistPL anaMode = Analyse - { binPath = def &= typ "HistPL-Binary" &= argPos 0 } + { binPath = def &= typ "HistPL-Binary" &= argPos 0 + , transFlag = False &= (help . unwords) + [ "Perform pre-transliteration using the set of rules prepared for" + , "IMPACT documents." ] + , rmHypFlag = False &= (help . unwords) + [ "Remove all instances of the \"-\\n\" string." + , "Useful with IMPACT documents." ] + , compact = False &= help "Compact JSON output" + , printCont = 1 &= (help . unwords) + [ "Printing contemporary interpretations:" + , "0 -- never, 1 -- when no hist (default), 2 -- always" ] } argModes :: Mode (CmdArgs HistPL) argModes = cmdArgsMode $ modes [createMode, printMode, anaMode] - &= summary concraftDesc + &= summary histDesc &= program "hist-pl" @@ -104,7 +124,21 @@ exec Analyse{..} = do hpl <- H.open binPath - xs <- L.lines <$> L.getContents - forM_ xs $ L.putStrLn <=< onLine hpl + xs <- L.lines . rmHyp <$> L.getContents + forM_ xs $ BC.putStrLn <=< onLine hpl where - onLine hpl x = A.showAna <$> A.anaText hpl (L.toStrict x) + rmHyp | rmHypFlag = A.rmHyphen + | otherwise = id + onLine hpl + = fmap (encode . A.jsonAna A.defaultJConf) + . A.mapL (A.anaWord hpl . trans) + . A.tokenize . L.toStrict + trans | transFlag = T.pack . I.transliter I.impactRules . T.unpack + | otherwise = id + encode | compact = Aeson.encode + | otherwise = Aeson.encodePretty + jsonConf = A.defaultJConf + { A.showCont = case printCont of + 0 -> A.NoShowCont + 2 -> A.ForceShowCont + _ -> A.ShowCont }