diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 diff --git a/concraft-pl.cabal b/concraft-pl.cabal --- a/concraft-pl.cabal +++ b/concraft-pl.cabal @@ -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: diff --git a/src/NLP/Concraft/Polish.hs b/src/NLP/Concraft/Polish.hs --- a/src/NLP/Concraft/Polish.hs +++ b/src/NLP/Concraft/Polish.hs @@ -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 diff --git a/src/NLP/Concraft/Polish/Format/Plain.hs b/src/NLP/Concraft/Polish/Format/Plain.hs --- a/src/NLP/Concraft/Polish/Format/Plain.hs +++ b/src/NLP/Concraft/Polish/Format/Plain.hs @@ -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" diff --git a/src/NLP/Concraft/Polish/Morphosyntax.hs b/src/NLP/Concraft/Polish/Morphosyntax.hs --- a/src/NLP/Concraft/Polish/Morphosyntax.hs +++ b/src/NLP/Concraft/Polish/Morphosyntax.hs @@ -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. diff --git a/src/NLP/Concraft/Polish/Request.hs b/src/NLP/Concraft/Polish/Request.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Polish/Request.hs @@ -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} diff --git a/src/NLP/Concraft/Polish/Server.hs b/src/NLP/Concraft/Polish/Server.hs --- a/src/NLP/Concraft/Polish/Server.hs +++ b/src/NLP/Concraft/Polish/Server.hs @@ -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 ------------------------------------------------- diff --git a/tools/concraft-pl.hs b/tools/concraft-pl.hs --- a/tools/concraft-pl.hs +++ b/tools/concraft-pl.hs @@ -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})