hist-pl 0.1.0 → 0.2.0

raw patch · 3 files changed

+151/−88 lines, 3 filesdep +aesondep +aeson-prettydep +bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, aeson-pretty, bytestring, hist-pl-transliter

API changes (from Hackage documentation)

Files

• hist-pl.cabal +6/−1
• src/NLP/HistPL/Analyse.hs +102/−78
• tools/hist-pl.hs +43/−9

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

@@ -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 _) = ["<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

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