packages feed

concraft-pl 0.6.0 → 0.7.0

raw patch · 8 files changed

+348/−130 lines, 8 filesdep ~concraftPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: concraft

API changes (from Hackage documentation)

- NLP.Concraft.Polish: tag' :: MacaPool -> Concraft -> Text -> IO [[Sent Tag]]
- NLP.Concraft.Polish: tagSent :: Concraft -> Sent Tag -> Sent Tag
- NLP.Concraft.Polish.Server: tag :: HostName -> PortID -> Text -> IO [Sent Tag]
- NLP.Concraft.Polish.Server: tag' :: HostName -> PortID -> Text -> IO [[Sent Tag]]
+ NLP.Concraft.Polish: macaPar :: MacaPool -> Text -> IO [Sent Tag]
+ NLP.Concraft.Polish: marginals :: Concraft -> Sent Tag -> Sent Tag
+ NLP.Concraft.Polish.Morphosyntax: select' :: Ord a => [a] -> a -> Seg a -> Seg a
+ NLP.Concraft.Polish.Morphosyntax: selectWMap :: Ord a => WMap a -> Seg a -> Seg a
+ NLP.Concraft.Polish.Request: Config :: Bool -> Config
+ NLP.Concraft.Polish.Request: Doc :: [[Sent Tag]] -> Long
+ NLP.Concraft.Polish.Request: Long :: Text -> Long
+ NLP.Concraft.Polish.Request: Par :: [Sent Tag] -> Short
+ NLP.Concraft.Polish.Request: Request :: t -> Config -> Request t
+ NLP.Concraft.Polish.Request: Short :: Text -> Short
+ NLP.Concraft.Polish.Request: data Long
+ NLP.Concraft.Polish.Request: data Request t
+ NLP.Concraft.Polish.Request: data Short
+ NLP.Concraft.Polish.Request: instance Binary Config
+ NLP.Concraft.Polish.Request: instance Binary Long
+ NLP.Concraft.Polish.Request: instance Binary Short
+ NLP.Concraft.Polish.Request: instance Binary t => Binary (Request t)
+ NLP.Concraft.Polish.Request: long :: (Request Short -> IO a) -> Request Long -> IO [a]
+ NLP.Concraft.Polish.Request: newtype Config
+ NLP.Concraft.Polish.Request: rqBody :: Request t -> t
+ NLP.Concraft.Polish.Request: rqConf :: Request t -> Config
+ NLP.Concraft.Polish.Request: short :: MacaPool -> Concraft -> Request Short -> IO [Sent Tag]
+ NLP.Concraft.Polish.Request: tagProbs :: Config -> Bool
+ NLP.Concraft.Polish.Server: submit :: HostName -> PortID -> Request Short -> IO [Sent Tag]
- NLP.Concraft.Polish: TrainConf :: Tagset -> SgdArgs -> Bool -> Bool -> Int -> Maybe Double -> R0T -> TrainConf
+ NLP.Concraft.Polish: TrainConf :: Tagset -> SgdArgs -> Bool -> Bool -> Int -> R0T -> TrainConf
- NLP.Concraft.Polish: prune :: TrainConf -> Maybe Double
+ NLP.Concraft.Polish: prune :: Double -> Concraft -> Concraft
- NLP.Concraft.Polish: tag :: MacaPool -> Concraft -> Text -> IO [Sent Tag]
+ NLP.Concraft.Polish: tag :: Concraft -> Sent Tag -> Sent Tag
- NLP.Concraft.Polish.Morphosyntax: Seg :: Word -> Map (Interp t) Bool -> Seg t
+ NLP.Concraft.Polish.Morphosyntax: Seg :: Word -> WMap (Interp t) -> Seg t
- NLP.Concraft.Polish.Morphosyntax: interps :: Seg t -> Map (Interp t) Bool
+ NLP.Concraft.Polish.Morphosyntax: interps :: Seg t -> WMap (Interp t)

Files

changelog view
@@ -1,5 +1,11 @@ -*-change-log-*- +0.7.0	Nov 2013+	* Output guessing results for unknown words +	* Allow "--noana" option in the client/server mode+	* Add option to output marginal probabilities+	* Add separate mode for model pruning+ 0.6.0	Nov 2013 	* Output wordform instead of "None" as a lemma for unknown words 
concraft-pl.cabal view
@@ -1,5 +1,5 @@ name:               concraft-pl-version:            0.6.0+version:            0.7.0 synopsis:           Morphological tagger for Polish description:     A morphological tagger for Polish based on the concraft library.@@ -23,7 +23,7 @@      build-depends:         base >= 4 && < 5-      , concraft                >= 0.8.2    && < 0.9+      , concraft                >= 0.9      && < 0.10       , tagset-positional       >= 0.3      && < 0.4       , sgd                     >= 0.3.3    && < 0.4       , containers              >= 0.4      && < 0.6@@ -42,6 +42,7 @@         NLP.Concraft.Polish       , NLP.Concraft.Polish.Maca       , NLP.Concraft.Polish.Morphosyntax+      , NLP.Concraft.Polish.Request       , NLP.Concraft.Polish.Server      other-modules:
src/NLP/Concraft/Polish.hs view
@@ -11,22 +11,28 @@  -- * Tagging , tag-, tag'-, tagSent+, marginals +-- * Analysis+, macaPar+ -- * Training , TrainConf (..) , train++-- * Pruning+, C.prune++-- -- * Analysis+-- , anaSent+-- , reAnaPar ) where  -import qualified Control.Monad.LazyIO as LazyIO import           Control.Applicative ((<$>))-import qualified Data.List.Split as Split-import qualified Data.Char as Char-import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Set as S+ import qualified Data.Tagset.Positional as P import qualified Numeric.SGD as SGD @@ -36,6 +42,7 @@ import qualified NLP.Concraft.Guess as G import qualified NLP.Concraft.Disamb as D import qualified NLP.Concraft as C+-- import qualified NLP.Concraft.Analysis as A  import           NLP.Concraft.Polish.Morphosyntax hiding (tag) import           NLP.Concraft.Polish.Maca@@ -83,31 +90,32 @@ -------------------------------------------------  --- | Perform morphological tagging on the input text.-tag :: MacaPool -> C.Concraft -> T.Text -> IO [Sent Tag]-tag pool concraft inp = map (tagSent concraft) <$> macaPar pool inp----- | An alernative tagging function which interprets--- empty lines as paragraph ending markers.--- The function uses lazy IO so it can be used to--- analyse large chunks of data.-tag' :: MacaPool -> C.Concraft -> L.Text -> IO [[Sent Tag]]-tag' pool concraft-    = LazyIO.mapM (tag pool concraft . L.toStrict)-    . map L.unlines-    . Split.splitWhen-        (L.all Char.isSpace)-    . L.lines+-- | Tag the analysed sentence.+tag :: C.Concraft -> Sent Tag -> Sent Tag+tag concraft sent =+    [ select' gs t seg+    | (seg, gs, t) <- zip3 sent gss ts ]+  where+    tagset = C.tagset concraft+    packed = packSent tagset sent+    tagged = C.tag concraft packed+    gss    = map (map showTag . S.toList . fst) tagged+    ts     = map (showTag . snd) tagged+    showTag = P.showTag tagset  --- | Tag an already analysed sentence.-tagSent :: C.Concraft -> Sent Tag -> Sent Tag-tagSent concraft sent =-    let tagset = C.tagset concraft-        packed = packSent tagset sent-        tags   = map (P.showTag tagset) (C.tag concraft packed)-    in  map (uncurry select) (zip tags sent)+-- | Tag the sentence with marginal probabilities.+marginals :: C.Concraft -> Sent Tag -> Sent Tag+marginals concraft sent+    = map (uncurry selectWMap)+    $ zip wmaps sent+  where+    tagset = C.tagset concraft+    packed = packSent tagset sent+    wmaps  = map+        (X.mapWMap showTag)+        (C.marginals concraft packed)+    showTag = P.showTag tagset   -------------------------------------------------@@ -115,6 +123,7 @@ -------------------------------------------------  +-- | Training configuration. data TrainConf = TrainConf {     -- | Tagset.       tagset    :: P.Tagset@@ -126,8 +135,6 @@     , onDisk    :: Bool     -- | Numer of guessed tags for each word.     , guessNum  :: Int-    -- | Disamb model pruning parameter.-    , prune     :: Maybe Double     -- | `G.r0T` parameter.     , r0        :: G.R0T } @@ -142,7 +149,7 @@ train TrainConf{..} train0 eval0 = do      pool <- newMacaPool 1-    let ana = fmap (packSent tagset . concat) . macaPar pool . L.toStrict+    let ana = anaSent tagset pool         train1 = map (packSentO tagset) <$> train0         eval1  = map (packSentO tagset) <$> eval0 @@ -152,10 +159,29 @@    where -    guessConf  = G.TrainConf guessSchemaDefault sgdArgs onDisk r0-    disambConf = D.TrainConf tiersDefault disambSchemaDefault-        sgdArgs onDisk prune-     doReana ana   = C.reAnaTrain tagset ana guessNum guessConf disambConf     noReana tr ev = C.train tagset guessNum guessConf disambConf          (map X.segs <$> tr) (map X.segs <$> ev)++    guessConf  = G.TrainConf guessSchemaDefault sgdArgs onDisk r0+    disambConf = D.TrainConf tiersDefault disambSchemaDefault sgdArgs onDisk+++-------------------------------------------------+-- Re-analysis+-------------------------------------------------+++-- | Analyse the given sentence with Maca.+-- anaSent :: MacaPool -> L.Text -> IO (Sent Tag)+anaSent :: P.Tagset -> MacaPool -> L.Text -> IO (X.Sent Word P.Tag)+anaSent tagset pool+    = fmap (packSent tagset . concat)+    . macaPar pool . L.toStrict+++-- -- | Reanalyse the input paragraph (lazy IO).+-- reAnaPar :: P.Tagset -> [SentO Tag] -> IO [Sent Tag]+-- reAnaPar tagset inp = do+--     pool <- newMacaPool 1+--     A.reAnaPar tagset (anaSent pool) inp
src/NLP/Concraft/Polish/Format/Plain.hs view
@@ -14,6 +14,7 @@ , parseSent  -- * Printing+, ShowCfg (..) , showPlain , showPara , showSent@@ -28,7 +29,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as L+import qualified Data.Text.Lazy.Read as R+import           Text.Printf (printf) +import qualified NLP.Concraft.Morphosyntax as X import           NLP.Concraft.Polish.Morphosyntax  -- | Parse the text in the plain format.@@ -69,18 +73,22 @@     (_orth, _space) = parseHeader (head xs)     ys          = map parseInterp (tail xs)     _known      = not (Nothing `elem` ys)-    _interps    = M.fromListWith max (catMaybes ys)+    -- _interps    = M.fromListWith max (catMaybes ys)+    _interps    = X.mkWMap $ catMaybes ys -parseInterp :: L.Text -> Maybe (Interp Tag, Bool)+parseInterp :: L.Text -> Maybe (Interp Tag, Double) parseInterp =     doIt . tail . L.splitOn "\t"   where     doIt [form, tag]         | tag == ign    = Nothing         | otherwise     = Just $-            (mkInterp form tag, False)-    doIt [form, tag, "disamb"] = Just $-        (mkInterp form tag, True)+            (mkInterp form tag, 0)+    doIt [form, tag, "disamb"] =+        Just (mkInterp form tag, 1)+    doIt [form, tag, weight] = case R.double weight of+        Left er -> error $ "parseInterp (weight):" ++ show er+        Right w -> Just (mkInterp form tag, fst w)     doIt xs = error $ "parseInterp: " ++ show xs     mkInterp form tag = Interp (L.toStrict form) (L.toStrict tag) @@ -102,41 +110,51 @@ -- Printing ----------- +-- | Printing configuration.+data ShowCfg = ShowCfg {+    -- | Print weights instead of 'disamb' tags.+      showWsCfg :: Bool }+ -- | Show the plain data.-showPlain :: [[Sent Tag]] -> L.Text-showPlain =-    L.intercalate "\n" . map showPara+showPlain :: ShowCfg ->[[Sent Tag]] -> L.Text+showPlain cfg =+    L.intercalate "\n" . map (showPara cfg)  -- | Show the paragraph.-showPara :: [Sent Tag] -> L.Text-showPara = L.toLazyText . mconcat  . map (\xs -> buildSent xs <> "\n")+showPara :: ShowCfg -> [Sent Tag] -> L.Text+showPara cfg = L.toLazyText . mconcat . map (\xs -> buildSent cfg xs <> "\n")  -- | Show the sentence.-showSent :: Sent Tag -> L.Text-showSent xs = L.toLazyText $ buildSent xs+showSent :: ShowCfg -> Sent Tag -> L.Text+showSent cfg xs = L.toLazyText $ buildSent cfg xs -buildSent :: Sent Tag -> L.Builder-buildSent = mconcat . map buildWord+buildSent :: ShowCfg -> Sent Tag -> L.Builder+buildSent cfg = mconcat . map (buildWord cfg) -buildWord :: Seg Tag -> L.Builder-buildWord Seg{..}+buildWord :: ShowCfg -> Seg Tag -> L.Builder+buildWord cfg Seg{..}     =  L.fromText orth  <> "\t"     <> buildSpace space <> "\n"     <> buildKnown orth known-    <> buildInterps (M.toList interps)+    <> buildInterps cfg interps     where Word{..} = word -buildInterps :: [(Interp Tag, Bool)] -> L.Builder-buildInterps interps = mconcat+buildInterps :: ShowCfg -> X.WMap (Interp Tag) -> L.Builder+buildInterps ShowCfg{..} interps = mconcat     [ "\t" <> buildBase interp <>-      "\t" <> buildTag  interp <>-      if dmb-        then "\tdisamb\n"-        else "\n"-    | (interp, dmb) <- interps ]+      "\t" <> buildTag interp  <> buildDmb dmb+    | (interp, dmb) <- M.toList (X.unWMap interps) ]   where     buildTag  = L.fromText . tag     buildBase = L.fromText . base+    buildDmb  = case showWsCfg of+        True    -> \x -> between "\t" "\n"+            $ L.fromString+            $ printf "%.3f" x+        False   -> \x -> if x > 0+            then "\tdisamb\n"+            else "\n"+    between x y z = x <> z <> y  buildSpace :: Space -> L.Builder buildSpace None     = "none"
src/NLP/Concraft/Polish/Morphosyntax.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}   -- | Morphosyntax data layer in Polish.@@ -16,6 +17,8 @@ , Interp (..) , Space (..) , select+, select'+, selectWMap  -- * Sentence , Sent@@ -36,6 +39,7 @@ import           Data.Aeson import           Data.Binary (Binary, put, get, putWord8, getWord8) import qualified Data.Aeson as Aeson+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@@ -59,7 +63,7 @@     -- | Interpretations of the token, each interpretation annotated     -- with a /disamb/ Boolean value (if 'True', the interpretation     -- is correct within the context).-    , interps   :: M.Map (Interp t) Bool }+    , interps   :: X.WMap (Interp t) }     deriving (Show, Eq, Ord)  @@ -76,7 +80,6 @@     deriving (Show, Eq, Ord)  - instance X.Word Word where     orth = orth     oov = not.known@@ -150,29 +153,31 @@     parseJSON _ = error "parseJSON [Space]"  --- | Select one interpretation.+-- | Select one chosen interpretation. select :: Ord a => a -> Seg a -> Seg a-select x = selectWMap (X.mkWMap [(x, 1)])+select = select' []  +-- | Select multiple interpretations and one chosen interpretation.+select' :: Ord a => [a] -> a -> Seg a -> Seg a+select' ys x = selectWMap . X.mkWMap $ (x, 1) : map (,0) ys++ -- | Select interpretations. selectWMap :: Ord a => X.WMap a -> Seg a -> Seg a selectWMap wMap seg =     seg { interps = newInterps }   where-    wSet = M.fromList . map (first tag) . M.toList . interps-    asDmb x = if x > 0-        then True-        else False-    newInterps = M.fromList $+    wSet = S.fromList . map tag . M.keys . X.unWMap . interps $ seg+    newInterps = X.mkWMap $         [ case M.lookup (tag interp) (X.unWMap wMap) of-            Just x  -> (interp, asDmb x)-            Nothing -> (interp, False)-        | interp <- M.keys (interps seg) ]+            Just x  -> (interp, x)+            Nothing -> (interp, 0)+        | interp <- (M.keys . X.unWMap) (interps seg) ]             ++ catMaybes-        [ if tag `M.member` wSet seg+        [ if tag `S.member` wSet             then Nothing-            else Just (Interp lemma tag, asDmb x)+            else Just (Interp lemma tag, x)         | let lemma = orth $ word seg   -- Default base form         , (tag, x) <- M.toList (X.unWMap wMap) ] @@ -218,9 +223,12 @@  -- | Convert a segment to a segment from a core library. packSeg_ :: Ord a => Seg a -> X.Seg Word a-packSeg_ Seg{..} = X.Seg word $ X.mkWMap-    [ (tag x, if disamb then 1 else 0)-    | (x, disamb) <- M.toList interps ]+packSeg_ Seg{..}+    = X.Seg word+    $ X.mkWMap+    $ map (first tag)+    $ M.toList+    $ X.unWMap interps   -- | Convert a segment to a segment from a core library.
+ src/NLP/Concraft/Polish/Request.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+++module NLP.Concraft.Polish.Request+(+-- * Request +  Request (..)+, Config (..)+-- ** Short+, Short (..)+, short+-- ** Long+, Long (..)+, long+) where+++import           Control.Applicative ((<$>), (<*>))+import qualified Control.Monad.LazyIO as LazyIO+import qualified Data.Char as Char+import qualified Data.List.Split as Split+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Binary as B++import           NLP.Concraft.Polish+import           NLP.Concraft.Polish.Maca+import           NLP.Concraft.Polish.Morphosyntax hiding (tag)+++-------------------------------------------------+-- Configuration+-------------------------------------------------+++-- | A request with configuration.+data Request t = Request {+    -- | The actuall request.+      rqBody    :: t+    -- | Request configuration.+    , rqConf    :: Config }+++instance B.Binary t => B.Binary (Request t)  where+    put Request{..} = B.put rqBody >> B.put rqConf+    get = Request <$> B.get <*> B.get+++-- | Tagging configuration.+newtype Config = Config {+    -- | Tag with marginal probabilities.+      tagProbs  :: Bool+    } deriving (B.Binary)+++-------------------------------------------------+-- Short request+-------------------------------------------------+++-- | A short request.+data Short+    = Short T.Text+    | Par [Sent Tag]+++instance B.Binary Short where+    put (Short x) = B.putWord8 0 >> B.put x+    put (Par x)   = B.putWord8 1 >> B.put x+    get = B.getWord8 >>= \x -> case x of+        0   -> Short <$> B.get+        _   -> Par   <$> B.get+++-- | Process the short request.+short :: MacaPool -> Concraft -> Request Short -> IO [Sent Tag]+short pool concraft Request{..} = case rqBody of+    Short x -> map (tagit concraft) <$> macaPar pool x+    Par x   -> return $ map (tagit concraft) x+  where+    tagit = if tagProbs rqConf then marginals else tag+++-------------------------------------------------+-- Long request+-------------------------------------------------+++-- | A request to parse a long text.+data Long+    = Long L.Text+    | Doc [[Sent Tag]]+++instance B.Binary Long where+    put (Long x) = B.putWord8 0 >> B.put x+    put (Doc x)  = B.putWord8 1 >> B.put x+    get = B.getWord8 >>= \x -> case x of+        0   -> Long <$> B.get+        _   -> Doc  <$> B.get+++-- | Process the long request given the processor for the+-- short request. +long :: (Request Short -> IO a) -> Request Long -> IO [a]+long handler Request{..} = case rqBody of+    Long inp ->+          LazyIO.mapM f . map L.unlines+        . Split.splitWhen (L.all Char.isSpace)+        . L.lines $ inp+    Doc inp -> LazyIO.mapM g inp+  where+    f x = handler . r $ Short $ L.toStrict x+    g x = handler . r $ Par x+    r x = Request {rqBody = x, rqConf = rqConf}
src/NLP/Concraft/Polish/Server.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}   module NLP.Concraft.Polish.Server@@ -7,8 +8,7 @@   runConcraftServer  -- * Client-, tag-, tag'+, submit ) where  @@ -16,18 +16,14 @@ import           Control.Monad (forever, void) import           Control.Concurrent (forkIO) import           System.IO (Handle, hFlush)-import qualified Control.Monad.LazyIO as LazyIO import qualified Network as N-import qualified Data.Char as Char-import qualified Data.List.Split as Split import qualified Data.Binary as B import qualified Data.ByteString.Lazy as BS-import qualified Data.Text as T-import qualified Data.Text.Lazy as L  import           NLP.Concraft.Polish.Morphosyntax hiding (tag) import           NLP.Concraft.Polish.Maca import qualified NLP.Concraft.Polish as C+import qualified NLP.Concraft.Polish.Request as R   -------------------------------------------------@@ -42,6 +38,7 @@     forever $ sockHandler pool concraft sock  +-- | Read and process short requests from the socket. sockHandler :: MacaPool -> C.Concraft -> N.Socket -> IO () sockHandler pool concraft sock = do     (handle, _, _) <- N.accept sock@@ -50,7 +47,7 @@         -- putStrLn "Waiting for input..."         inp <- recvMsg handle         -- putStr "> " >> T.putStrLn inp-        out <- C.tag pool concraft inp+        out <- R.short pool concraft inp         -- putStr "No. of sentences: " >> print (length out)         sendMsg handle out @@ -60,9 +57,9 @@ -------------------------------------------------  --- | Perform morphological tagging on the input text.-tag :: N.HostName -> N.PortID -> T.Text -> IO [Sent Tag]-tag host port inp = do+-- | Submit the given request.+submit :: N.HostName -> N.PortID -> R.Request R.Short -> IO [Sent Tag]+submit host port inp = do     handle <- N.connectTo host port     -- putStrLn "Connection established"     -- putStr "Send request: " >> T.putStrLn inp@@ -70,21 +67,8 @@     recvMsg handle  --- | An alernative tagging function which interprets--- empty lines as paragraph ending markers.--- The function uses lazy IO so it can be used to--- analyse large chunks of data.-tag' :: N.HostName -> N.PortID -> L.Text -> IO [[Sent Tag]]-tag' host port-    = LazyIO.mapM (tag host port . L.toStrict)-    . map L.unlines-    . Split.splitWhen-        (L.all Char.isSpace)-    . L.lines-- ---------------------------------------------------- Messages+-- Communication -------------------------------------------------  
tools/concraft-pl.hs view
@@ -19,6 +19,7 @@  import qualified NLP.Concraft.Polish.Maca as Maca import qualified NLP.Concraft.Polish as C+import qualified NLP.Concraft.Polish.Request as R import qualified NLP.Concraft.Polish.Server as S import qualified NLP.Concraft.Polish.Morphosyntax as X import qualified NLP.Concraft.Polish.Format.Plain as P@@ -37,7 +38,7 @@ ---------------------------------------  --- | Data formats. +-- | Data formats. data Format = Plain deriving (Data, Typeable, Show)  @@ -60,20 +61,22 @@     , gain0         :: Double     , tau           :: Double     , disk          :: Bool-    , prune         :: Maybe Double     , outModel      :: FilePath     , guessNum      :: Int     , r0            :: Guess.R0T }   | Tag     { inModel       :: FilePath     , noAna         :: Bool-    , format        :: Format }+    , format        :: Format+    , marginals     :: Bool }     -- , guessNum      :: Int }   | Server     { inModel       :: FilePath     , port          :: Int }   | Client-    { format        :: Format+    { noAna         :: Bool+    , format        :: Format+    , marginals     :: Bool     , host          :: String     , port          :: Int }   | Compare@@ -81,6 +84,12 @@     , refPath       :: FilePath     , otherPath     :: FilePath     , format        :: Format }+  | Prune+    { inModel       :: FilePath+    , outModel      :: FilePath+    , threshold     :: Double }+--   | ReAna+--     { format	    :: Format }   deriving (Data, Typeable, Show)  @@ -98,7 +107,6 @@     , gain0 = 1.0 &= help "Initial gain parameter"     , tau = 5.0 &= help "Initial tau parameter"     , disk = False &= help "Store SGD dataset on disk"-    , prune = Nothing &= help "Disambiguation model pruning parameter"     , outModel = def &= typFile &= help "Output Model file"     , guessNum = 10 &= help "Number of guessed tags for each unknown word"     , r0 = Guess.OovChosen &= help "R0 construction method" }@@ -106,9 +114,10 @@  tagMode :: Concraft tagMode = Tag-    { inModel   = def &= argPos 0 &= typ "MODEL-FILE"-    , noAna     = False &= help "Do not analyse input text"-    , format    = enum [Plain &= help "Plain input format"] }+    { inModel  = def &= argPos 0 &= typ "MODEL-FILE"+    , noAna    = False &= help "Do not analyse input text"+    , format   = enum [Plain &= help "Plain format"]+    , marginals = False &= help "Tag with marginal probabilities" }     -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" }  @@ -120,9 +129,11 @@  clientMode :: Concraft clientMode = Client-    { port   = portDefault &= help "Port number"-    , host   = "localhost" &= help "Server host name"-    , format = enum [Plain &= help "Plain output format"] }+    { noAna   = False &= help "Do not perform reanalysis"+    , port    = portDefault &= help "Port number"+    , host    = "localhost" &= help "Server host name"+    , format  = enum [Plain &= help "Plain output format"]+    , marginals = False &= help "Tag with marginal probabilities" }   compareMode :: Concraft@@ -130,12 +141,25 @@     { refPath   = def &= argPos 1 &= typ "REFERENCE-FILE"     , otherPath = def &= argPos 2 &= typ "OTHER-FILE"     , tagsetPath = def &= typFile &= help "Tagset definition file"-    , format  = enum [Plain &= help "Plain input format"] }+    , format  = enum [Plain &= help "Plain format"] }  +pruneMode :: Concraft+pruneMode = Prune+    { inModel   = def &= argPos 0 &= typ "INPUT-MODEL"+    , outModel  = def &= argPos 1 &= typ "OUTPUT-MODEL"+    , threshold = 0.05 &=+        help "Remove disambiguation features below the threshold" }+++-- reAnaMode :: Concraft+-- reAnaMode = ReAna+--     { format    = enum [Plain &= help "Plain format"] }++ argModes :: Mode (CmdArgs Concraft) argModes = cmdArgsMode $ modes-    [trainMode, tagMode, serverMode, clientMode, compareMode]+    [trainMode, tagMode, serverMode, clientMode, compareMode, pruneMode]     &= summary concraftDesc     &= program "concraft-pl" @@ -176,20 +200,26 @@         , reana     = not noAna         , onDisk    = disk         , guessNum  = guessNum-        , prune     = prune         , r0        = r0 }   exec Tag{..} = do-    cnft <- C.loadModel inModel+    cft <- C.loadModel inModel     pool <- Maca.newMacaPool numCapabilities-    inp  <- L.getContents-    out  <- if not noAna-        then C.tag' pool cnft inp-        else return $-           let out = parseText format inp-           in  map (map (C.tagSent cnft)) out-    L.putStr $ showData format out+    inp <- L.getContents+    out <- R.long (R.short pool cft) $ rq $ if noAna+        then R.Doc $ parseText format inp+        else R.Long inp+    L.putStr $ showData showCfg out+  where+    rq x = R.Request+        { R.rqBody = x+        , R.rqConf = rqConf }+    rqConf = R.Config+        { R.tagProbs = marginals }+    showCfg = ShowCfg+        { formatCfg = format+        , showWsCfg = marginals }   exec Server{..} = do@@ -204,8 +234,20 @@  exec Client{..} = do     let portNum = N.PortNumber $ fromIntegral port-    out <- S.tag' host portNum =<< L.getContents-    L.putStr $ showData format out+    inp <- L.getContents+    out <- R.long (S.submit host portNum) $ rq $ if noAna+        then R.Doc $ parseText format inp+        else R.Long inp+    L.putStr $ showData showCfg out+  where+    rq x = R.Request+        { R.rqBody = x+        , R.rqConf = rqConf }+    rqConf = R.Config+        { R.tagProbs = marginals }+    showCfg = ShowCfg+        { formatCfg = format+        , showWsCfg = marginals }   exec Compare{..} = do@@ -222,6 +264,16 @@     putStrLn $ "Weak accuracy lower bound: " ++ show (Acc.accuracy s)  +exec Prune{..} = do+    cft <- C.loadModel inModel+    C.saveModel outModel $ C.prune threshold cft+++-- exec ReAna{..} = do+--     inp  <- parseText format <$> L.getContents+--     out  <- showData format <$> ++ --------------------------------------- -- Reading files ---------------------------------------@@ -272,5 +324,12 @@ ---------------------------------------  -showData :: Format -> [[X.Sent X.Tag]] -> L.Text-showData Plain = P.showPlain+data ShowCfg = ShowCfg {+    -- | The format used.+      formatCfg :: Format+    -- | Show weights?+    , showWsCfg :: Bool }+++showData :: ShowCfg -> [[X.Sent X.Tag]] -> L.Text+showData ShowCfg{..} = P.showPlain (P.ShowCfg {P.showWsCfg = showWsCfg})