packages feed

concraft-pl 0.7.4 → 2.0.1

raw patch · 13 files changed

+2040/−201 lines, 13 filesdep +concraft-pldep +crf-chain1-constraineddep +crf-chain2-tiersdep ~aesondep ~binarydep ~bytestringsetup-changed

Dependencies added: concraft-pl, crf-chain1-constrained, crf-chain2-tiers, dhall, filepath, http-types, lens, pedestrian-dag, scotty, vector, wreq

Dependency ranges changed: aeson, binary, bytestring, concraft, containers, process, sgd, tagset-positional, text, transformers

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
changelog view
@@ -1,5 +1,16 @@ -*-change-log-*- +2.0.1   Jul 2018+        * External configuration of disambiguation tiers++2.0.0   Jul 2018+        * Support Morfeusz DAGs+        * Use the Morfeusz format+        * Drop dependency on Maca++0.7.5	Aug 2016+	* Start using `stack` to avoid dependency problems+ 0.7.4	Nov 2014 	* Ignore non-printable characters for compatibility with Maca
concraft-pl.cabal view
@@ -1,12 +1,12 @@ name:               concraft-pl-version:            0.7.4+version:            2.0.1 synopsis:           Morphological tagger for Polish description:     A morphological tagger for Polish based on the concraft library. license:            BSD3 license-file:       LICENSE-cabal-version:      >= 1.6-copyright:          Copyright (c) 2013 Jakub Waszczuk+cabal-version:      >= 1.10+copyright:          Copyright (c) 2012-2018 Jakub Waszczuk, IPI PAN author:             Jakub Waszczuk maintainer:         waszczuk.kuba@gmail.com stability:          experimental@@ -19,24 +19,34 @@ data-files: config/nkjp-tagset.cfg  library+    default-language:+        Haskell2010     hs-source-dirs: src-     build-depends:         base >= 4 && < 5-      , concraft                >= 0.9      && < 0.10+      , concraft                >= 0.11     && < 0.12+      , pedestrian-dag          >= 0.2      && < 0.3+      , crf-chain1-constrained  >= 0.4      && < 0.5+      , crf-chain2-tiers        >= 0.3      && < 0.4       , tagset-positional       >= 0.3      && < 0.4-      , sgd                     >= 0.3.3    && < 0.4+      , sgd                     >= 0.4      && < 0.5       , containers              >= 0.4      && < 0.6       , bytestring              >= 0.9      && < 0.11       , text                    >= 0.11     && < 1.3-      , aeson                   >= 0.6      && < 0.9-      , binary                  >= 0.5      && < 0.8-      , process                 >= 1.1      && < 1.3+      , aeson                   >= 0.6      && < 1.3+      , binary                  >= 0.5      && < 0.9+      , process                 >= 1.1      && < 1.7       , mtl                     >= 2.0      && < 2.3-      , transformers            >= 0.2      && < 0.5+      , transformers            >= 0.2      && < 0.6       , network                 >= 2.3      && < 2.7       , lazy-io                 >= 0.1      && < 0.2       , split                   >= 0.2      && < 0.3+      , scotty                  >= 0.11     && < 0.12+      , http-types              >= 0.9      && < 0.13+      , wreq                    >= 0.5      && < 0.6+      , lens                    >= 4.15     && < 4.17+      , dhall                   >= 1.11     && < 1.12+      , vector                  >= 0.11     && < 0.13      exposed-modules:         NLP.Concraft.Polish@@ -45,6 +55,16 @@       , NLP.Concraft.Polish.Request       , NLP.Concraft.Polish.Server +      -- , NLP.Concraft.Polish.DAG+      -- , NLP.Concraft.Polish.DAG2+      , NLP.Concraft.Polish.DAGSeg+      , NLP.Concraft.Polish.DAG.Morphosyntax+      , NLP.Concraft.Polish.DAG.Format.Base+      , NLP.Concraft.Polish.DAG.Server++      , NLP.Concraft.Polish.DAG.Config+      , NLP.Concraft.Polish.DAG.Config.Disamb+     other-modules:         NLP.Concraft.Polish.Format.Plain @@ -55,8 +75,22 @@     location: https://github.com/kawu/concraft-pl.git  executable concraft-pl+    default-language:+        Haskell2010     build-depends:-        cmdargs                 >= 0.10     && < 0.11-    hs-source-dirs: src, tools+        concraft-pl+      , concraft+      , tagset-positional+      , text+      , bytestring+      , sgd+      , pedestrian-dag+      , crf-chain1-constrained+      , containers+      , base                    >= 4        && < 5+      , cmdargs                 >= 0.10     && < 0.11+      , dhall                   >= 1.11     && < 1.12+      , filepath                >= 1.3      && < 1.5+    hs-source-dirs: tools     main-is: concraft-pl.hs     ghc-options: -Wall -O2 -threaded -rtsopts
src/NLP/Concraft/Polish.hs view
@@ -29,6 +29,7 @@ ) where  +import           Prelude hiding (Word) import           Control.Applicative ((<$>)) import qualified Data.Text.Lazy as L import qualified Data.Set as S@@ -79,8 +80,8 @@ tiersDefault =     [tier1, tier2]   where-    tier1 = D.Tier True $ S.fromList ["cas", "per"]-    tier2 = D.Tier False $ S.fromList+    tier1 = D.Tier True False $ S.fromList ["cas", "per"]+    tier2 = D.Tier False False $ S.fromList         [ "nmb", "gnd", "deg", "asp" , "ngt", "acm"         , "acn", "ppr", "agg", "vlc", "dot" ]
+ src/NLP/Concraft/Polish/DAG/Config.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric #-}+++module NLP.Concraft.Polish.DAG.Config+  ( Config(..)+  ) where+++import           Dhall+import qualified Data.Aeson as JSON++import qualified NLP.Concraft.Polish.DAG.Config.Disamb as D+++-- | Tagging configuration (everything apart tagset).+data Config = Config+  { disambCfg :: D.DisambCfg+  -- , guessCfg :: G.GuessCfg+  } deriving (Generic, Show)+++instance Interpret Config++instance JSON.FromJSON Config+instance JSON.ToJSON Config where+  toEncoding = JSON.genericToEncoding JSON.defaultOptions
+ src/NLP/Concraft/Polish/DAG/Config/Disamb.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveGeneric #-}+++module NLP.Concraft.Polish.DAG.Config.Disamb+  ( DisambCfg (..)+  , TierCfg (..)+  , Set(..)+  ) where+++import qualified Data.Set as S+import qualified Data.Vector as V+import qualified Data.Text as T++import           Dhall+import qualified Data.Aeson as JSON+++-- | Disamb module configuration.+data DisambCfg = DisambCfg+  { tiersCfg :: [TierCfg]+  } deriving (Generic, Show, Eq, Ord)+++-- | Disamb tiers configuration.+data TierCfg = TierCfg+  { withPos :: Bool+  , withEos :: Bool+  , withAtts :: Set T.Text+  } deriving (Generic, Show, Eq, Ord)+++instance Interpret DisambCfg++instance JSON.FromJSON DisambCfg+instance JSON.ToJSON DisambCfg where+  toEncoding = JSON.genericToEncoding JSON.defaultOptions+++instance Interpret TierCfg++instance JSON.FromJSON TierCfg+instance JSON.ToJSON TierCfg where+  toEncoding = JSON.genericToEncoding JSON.defaultOptions+++------------------------------+-- Set+------------------------------+++newtype Set a = Set {unSet :: S.Set a}+  deriving (Generic, Show, Eq, Ord)++instance (Ord a, Interpret a) => Interpret (Set a) where+    autoWith = fmap+      (fmap $ Set . S.fromList . V.toList)+      autoWith++instance (Ord a, JSON.FromJSON a) => JSON.FromJSON (Set a)+instance JSON.ToJSON a => JSON.ToJSON (Set a) where+  toEncoding = JSON.genericToEncoding JSON.defaultOptions
+ src/NLP/Concraft/Polish/DAG/Format/Base.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+++module NLP.Concraft.Polish.DAG.Format.Base+(+-- * Printing+  ShowCfg (..)+, ProbType (..)+, showSent+, showData++-- * Parsing+, parseData+, parseSent+) where+++import           Prelude hiding (Word)+import           Data.Monoid (mconcat, mappend)+import qualified Data.Map as M+import           Data.List (intersperse, groupBy)+import           Data.Maybe (listToMaybe)+import           Data.String (IsString)+import           Data.Data (Data)+import           Data.Typeable (Typeable)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as L+import           Text.Printf (printf)+import           Text.Read (readMaybe)++import qualified Data.DAG as DAG+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG++import qualified NLP.Concraft.DAG.Morphosyntax as X+-- import qualified NLP.Concraft.Polish.DAG2 as C+-- import           NLP.Concraft.Polish.DAG2 (AnnoSent(..))+import qualified NLP.Concraft.Polish.DAGSeg as C+import           NLP.Concraft.Polish.DAGSeg (AnnoSent(..))+import qualified NLP.Concraft.Polish.Morphosyntax as I++import           NLP.Concraft.Polish.DAG.Morphosyntax hiding (tag, Tag)+import qualified NLP.Concraft.Polish.DAG.Morphosyntax as PolX+++-----------------------------+-- Base+-----------------------------+++type Tag = PolX.Interp PolX.Tag+++-----------------------------+-- Showing+-----------------------------+++-- | Printing configuration.+data ShowCfg = ShowCfg+--   { suppressProbs :: Bool+--     -- ^ Do not show any probabilities+  { probType  :: ProbType+    -- ^ Which type of probabilities to show (unless suppressed)+  , numericDisamb :: Bool+    -- ^ Print disamb markers as numerical values instead of probability values+  }+++-- | Type of probabilities.+data ProbType+  = Marginals+    -- ^ Marginals of the disambiguation model+  | MaxProbs+    -- ^ Max probabilities of the disambiguation model+  | GuessedMarginals+    -- ^ Marginals of the guessing model+  deriving (Show, Eq, Ord, Enum, Typeable, Data)+-- Above, deriving Typeable and Data so that it can be easily parsed+-- for the command-line tool.+++-- mkProbType :: ProbType -> Disamb.ProbType+-- mkProbType Marginals = Disamb.Marginals+-- mkProbType MaxProbs = Disamb.MaxProbs+++-- | Show entire data.+showData :: ShowCfg -> [[AnnoSent]] -> L.Text+showData cfg+  = flip L.append "\n"+  . L.toLazyText+  . mconcat+  . intersperse "\n"+  . map (buildSents cfg)++-- | Show the given sentence.+showSent :: ShowCfg -> [AnnoSent] -> L.Text+showSent cfg = L.toLazyText . buildSents cfg++buildSents :: ShowCfg -> [AnnoSent] -> L.Builder+buildSents cfg =+  finalize . map (buildSent cfg)+  where+    -- finalize = (`mappend` "\n") . mconcat . intersperse "\n"+    finalize = mconcat++buildSent :: ShowCfg -> AnnoSent -> L.Builder+buildSent showCfg AnnoSent{..} = finalize $ do+  let dag = guessSent+  edgeID <- DAG.dagEdges dag+  let tailNode = DAG.begsWith edgeID dag+      headNode = DAG.endsWith edgeID dag+      X.Seg{..} = DAG.edgeLabel edgeID dag+  interp <- map Just (M.toList (X.unWMap tags)) +++            if known word then [] else [Nothing]+  return $ case interp of+    Just (interp@Interp{..}, weight) -> buildInterp+      showCfg tailNode headNode word interp+      (case probType showCfg of+          Marginals ->+            tagWeightIn edgeID interp marginals+          MaxProbs ->+            tagWeightIn edgeID interp maxProbs+          GuessedMarginals ->+            weight)+      (tagLabelIn False edgeID interp disambs)+    -- below, the case when the word is unknown+    Nothing ->+      let interp = Interp+            { base = "none"+            , tag = ign+            , commonness = Nothing+            , qualifier = Nothing+            , metaInfo = Nothing+            , eos = False }+      in  buildInterp showCfg tailNode headNode word interp 0 False+  where+    finalize = (`mappend` "\n") . mconcat . intersperse "\n"+    tagWeightIn = tagLabelIn 0+    tagLabelIn def i x anno+      = maybe def (tagLabel def x) (DAG.maybeEdgeLabel i anno)+    tagLabel def x = maybe def id . M.lookup x+++buildInterp+  :: ShowCfg+  -> DAG.NodeID  -- ^ Tail node+  -> DAG.NodeID  -- ^ Head node+  -> Word        -- ^ Word+  -> Interp PolX.Tag+  -> Double+  -> Bool+  -> L.Builder+buildInterp ShowCfg{..} tailNode headNode word Interp{..} weight disamb =+  mconcat $ intersperse "\t" $+  [ buildNode tailNode+  , buildNode headNode+  , L.fromText $ orth word+  , L.fromText $ if known word then base else orth word+  , L.fromText tag+  , buildMayText commonness+  , buildMayText qualifier+  , if numericDisamb+    then buildDisamb disamb+    else buildWeight weight+  , buildMayText metaInfo+  , if eos then "eos" else ""+  ] +++  if numericDisamb then [] else [buildDisamb disamb]+  where+    buildNode (DAG.NodeID i) = L.fromString (show i)+    buildWeight = L.fromString . printf "%.4f"+    buildDisamb True  = if numericDisamb then "1.0000" else "disamb"+    buildDisamb False = if numericDisamb then "0.0000" else ""+    -- buildDmb = between "\t" "\n" . L.fromString . printf "%.3f"+    -- between x y z = x <> z <> y+    buildMayText Nothing = ""+    buildMayText (Just x) = L.fromText x+++-----------------------------+-- Parsing+-----------------------------+++-- | Parse the text in the DAG format.+parseData :: L.Text -> [Sent Tag]+parseData =+  map parseSent . filter realSent . L.splitOn "\n\n"+  where+    realSent = not . L.null+++-- | Parse sentence in the DAG format.+parseSent :: L.Text -> Sent Tag+parseSent = fromRows . parseRows+++data Row = Row+  { tailNode   :: Int+  , headNode   :: Int+  , orthForm   :: T.Text+  , baseForm   :: T.Text+  , theTag     :: PolX.Tag+  , commonness :: Maybe T.Text+  , qualifier  :: Maybe T.Text+  , tagProb    :: Double+  , metaInfo   :: Maybe T.Text+  , eos        :: Bool+  }+++fromRows :: [Row] -> Sent Tag+fromRows =+  -- DAG.fromList' I.None . zip (repeat I.None) . getEdges+  DAG.mapN (const I.None) . DAG.fromEdgesUnsafe . getEdges+  where+    getEdges = map mkEdge . groupBy theSameEdge+    theSameEdge r1 r2+      =  tailNode r1 == tailNode r2+      && headNode r1 == headNode r2+    mkEdge [] = error "Format.Base.fromRows: empty list"+    mkEdge rows@(row0:_) = DAG.Edge+      { DAG.tailNode = DAG.NodeID $ tailNode row0+      , DAG.headNode = DAG.NodeID $ headNode row0+      , DAG.edLabel = edge }+      where+        edge = X.Seg+          { word = newWord+          , tags = newTags }+        newWord = Word+          { orth = orthForm row0+          , known = not $ ign `elem` map theTag rows }+        newTags = X.mkWMap+          [ (interp, tagProb)+          | Row{..} <- rows+          , not $ theTag == ign+          , let interp = Interp+                  { base = baseForm+                  , tag = theTag+                  , commonness = commonness+                  , qualifier = qualifier+                  , metaInfo = metaInfo+                  , eos = eos }+          ]+++parseRows :: L.Text -> [Row]+parseRows = map parseRow . L.splitOn "\n"+++parseRow :: L.Text -> Row+parseRow =+  doit . L.splitOn "\t"+  where+    doit (tlNode : hdNode : otForm : bsForm : tag :+          comm : qual : prob : meta : eos : _) = Row+      { tailNode = readTyp "tail node" $ L.unpack tlNode+      , headNode = readTyp "head node" $ L.unpack hdNode+      , orthForm = L.toStrict otForm+      , baseForm = L.toStrict bsForm+      , theTag   = L.toStrict tag+      , commonness = nullIfEmpty comm+      , qualifier = nullIfEmpty qual+      , tagProb  = readTyp "probability value" $ L.unpack prob+      , metaInfo = nullIfEmpty meta+      , eos = case eos of+          "eos" -> True+          _ -> False+      }+    doit _ = error "parseRow: unexpected number of row cells"+    nullIfEmpty x = case x of+      "" -> Nothing+      _  -> Just (L.toStrict x)+++-----------+-- Utils+-----------+++-- -- | An infix synonym for 'mappend'.+-- (<>) :: Monoid m => m -> m -> m+-- (<>) = mappend+-- {-# INLINE (<>) #-}+++readTyp :: (Read a) => String -> String -> a+readTyp typ x =+  case readMaybe x of+    Just x -> x+    Nothing -> error $+      "unable to parse \"" ++ x ++ "\" to a " ++ typ+--       "Unable to parse <" ++ typ ++ ">" +++--       " (string=" ++ x ++ ")"+++-- | Tag which indicates unknown words.+ign :: IsString a => a+ign = "ign"+{-# INLINE ign #-}
+ src/NLP/Concraft/Polish/DAG/Morphosyntax.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+++-- | DAG-aware morphosyntax data layer in Polish.+++module NLP.Concraft.Polish.DAG.Morphosyntax+(+-- * Tag+  Tag++-- * Edge+-- , Edge (..)+, Word (..)+, Interp (..)+, voidInterp+, Space (..)+-- , select+-- , select'+, selectWMap+, selectAnno++-- * Sentence+, Sent+, SentO (..)+, restore+, restore'+, withOrig++-- * Conversion+, packSent+, packSentO+-- , packSeg++-- -- ** From simple sentence+-- , fromList+) where+++import           Prelude hiding (Word)+import           Control.Applicative ((<$>), (<*>))+-- import           Control.Arrow (first)+import           Control.Monad (guard)+import           Data.Binary (Binary, put, get, putWord8, getWord8)+import           Data.Aeson+import qualified Data.Aeson as Aeson+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import           Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Tagset.Positional as P++import           Data.DAG (DAG)+import qualified Data.DAG as DAG+-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG++-- import qualified NLP.Concraft.DAG2 as C+import qualified NLP.Concraft.DAG.Morphosyntax as X+import qualified NLP.Concraft.DAG.Segmentation as Seg+import qualified NLP.Concraft.Polish.Morphosyntax as R+import           NLP.Concraft.Polish.Morphosyntax (Space(..))+++--------------------------------+-- Basics+--------------------------------+++-- | A textual representation of a morphosyntactic tag.+type Tag = T.Text+++--------------------------------+-- Interp+--------------------------------+++-- | A morphosyntactic interpretation.+data Interp t = Interp+    { base  :: T.Text+      -- ^ The base form (lemma)+    , tag   :: t+      -- ^ The (morphosyntactic) tag+    , commonness :: Maybe T.Text+    , qualifier  :: Maybe T.Text+    , metaInfo   :: Maybe T.Text+    , eos        :: Bool+      -- ^ The remaining four are ignored for the moment, but we plan to rely on+      -- them later on.+    } deriving (Show, Eq, Ord)+++-- | An almost empty interpretation, with only the `tag` actually specified.+voidInterp :: t -> Interp t+voidInterp x = Interp+  { base = "none"+  , tag = x+  , commonness = Nothing+  , qualifier = Nothing+  , metaInfo = Nothing+  , eos = False+  }+++instance (Ord t, Binary t) => Binary (Interp t) where+    put Interp{..} = do+      put base+      put tag+      put commonness+      put qualifier+      put metaInfo+      put eos+    get = Interp <$> get <*> get <*> get <*> get <*> get <*> get+++--------------------------------+-- Edge+--------------------------------+++-- -- | An edge consists of a word and a set of morphosyntactic interpretations.+-- data Edge t = Edge+--     { word      :: Word+--     -- | Interpretations of the word, each interpretation annotated+--     -- with a /disamb/ Boolean value (if 'True', the interpretation+--     -- is correct within the context).+--     , interps   :: X.WMap (Interp t) }+--     deriving (Show, Eq, Ord)+--+-- instance (Ord t, Binary t) => Binary (Edge t) where+--     put Edge{..} = put word >> put interps+--     get = Edge <$> get <*> get+--+-- instance X.Word (Edge t) where+--     orth = X.orth . word+--     oov = X.oov . word+++--------------------------------+-- Word+--------------------------------+++-- | A word.+data Word = Word+    { orth      :: T.Text+    -- , space     :: Space+    , known     :: Bool }+    deriving (Show, Eq, Ord)++instance X.Word Word where+    orth = orth+    oov = not.known++instance Binary Word where+    -- put Word{..} = put orth >> put space >> put known+    put Word{..} = put orth >> put known+    -- get = Word <$> get <*> get <*> get+    get = Word <$> get <*> get++instance ToJSON Word where+    toJSON Word{..} = object+        [ "orth"  .= orth+        , "known" .= known ]++instance FromJSON Word where+    parseJSON (Object v) = Word+        <$> v .: "orth"+        <*> v .: "known"+    parseJSON _ = error "parseJSON [Word]"+++---------------------------------------------------------------------------------+-- Selection+--+-- (Honestly, I don't remember what is this one about...)+--+-- Update: maybe related to the fact that base forms have to be handled somehow?+---------------------------------------------------------------------------------+++-- -- | Select one chosen interpretation.+-- select :: Ord a => a -> Edge a -> Edge a+-- select = select' []+--+--+-- -- | Select multiple interpretations and one chosen interpretation.+-- select' :: Ord a => [a] -> a -> Edge a -> Edge a+-- select' ys x = selectWMap . X.mkWMap $ (x, 1) : map (,0) ys+++-- | Select interpretations.+selectAnno :: Ord a => M.Map (Interp a) Double -> X.Seg Word (Interp a) -> X.Seg Word (Interp a)+selectAnno = selectWMap . X.fromMap+++-- | Select interpretations.+selectWMap :: Ord a => X.WMap (Interp a) -> X.Seg Word (Interp a) -> X.Seg Word (Interp a)+selectWMap wMap seg = seg {X.tags = wMap}+--     seg { X.tags = newTags }+--   where+--     wSet = S.fromList . map tag . M.keys . X.unWMap . X.tags $ seg+--     newTags = X.mkWMap $+--         -- [ case M.lookup (tag interp) (X.unWMap wMap) of+--         [ case M.lookup interp (X.unWMap wMap) of+--             Just x  -> (interp, x)+--             Nothing -> (interp, 0)+--         | interp <- (M.keys . X.unWMap) (X.tags seg) ]+--             ++ catMaybes+--         [ if interp `S.member` wSet+--             then Nothing+--             else Just (interp, x)+--         | (interp, x) <- M.toList (X.unWMap wMap)+-- --         | let lemma = orth $ X.word seg   -- Default base form+-- --         , (tag, x) <- M.toList (X.unWMap wMap)+-- --         , let interp = Interp+-- --                 { base = lemma+-- --                 , tag = tag+-- --                 , commonness = Nothing+-- --                 , qualifier = Nothing+-- --                 , metaInfo = Nothing+-- --                 , eos = False }+--         ]+++--------------------------------+-- Sentence+--------------------------------+++-- | A sentence.+-- type Sent t = DAG Space (Edge t)+type Sent t = DAG Space (X.Seg Word t)+++-- | A sentence with its original textual representation.+data SentO t = SentO+    { sent  :: Sent t+    , orig  :: L.Text }+++-- | Restore textual representation of a sentence. The function is not very+-- accurate, it could be improved if we enriched the representation of spaces.+restore :: Sent t -> L.Text+restore =+    let edgeStr = orth . X.word+        spaceStr None    = ""+        spaceStr Space   = " "+        spaceStr NewLine = "\n"+    in  L.fromChunks . map (either spaceStr edgeStr) . pickPath+++-- | Use `restore` to translate `Sent` to a `SentO`.+withOrig :: Sent t -> SentO t+withOrig s = SentO+    { sent = s+    , orig = restore s }+++-- | A version of `restore` which places a space on each node.+restore' :: Sent t -> L.Text+restore' =+    let edgeStr = orth . X.word+        spaceStr = const " "+    in  L.fromChunks . map (either spaceStr edgeStr) . tail . pickPath+++--------------------------------+-- Utils+--------------------------------+++-- | Pick any path from the given DAG. The result is a list+-- of interleaved node and edge labels.+pickPath :: (X.Word b) => DAG a b -> [Either a b]+pickPath dag =+  fstNodeVal path : concatMap getVals path+  where+    -- Take the value on the first node on the path+    fstNodeVal = \case+      edgeID : _ ->+        Left $ DAG.nodeLabel (DAG.begsWith edgeID dag) dag+      [] -> error "Morphosyntax.pickPath: empty path"+    -- Select a shortest path in the DAG; thanks to edges being topologically+    -- sorted, this should give us the list of edge IDs in an appropriate order.+    path = S.toList $ Seg.findPath Seg.Min dag+    -- Get the labels of the nodes and labels+    getVals edgeID =+      let+        nodeID = DAG.endsWith edgeID dag+      in+        [ Right $ DAG.edgeLabel edgeID dag+        , Left  $ DAG.nodeLabel nodeID dag ]+++---------------------------+-- Conversion+---------------------------+++-- -- | Convert a segment to a segment from the core library.+-- packSeg :: Ord a => X.Seg Word a -> X.Seg Word a+-- packSeg = id+-- -- packSeg Edge{..}+-- --     = X.Seg word+-- --     $ X.mkWMap+-- --     $ map (first tag)+-- --     $ M.toList+-- --     $ X.unWMap interps+++-- | Convert a sentence to a sentence from the core library.+packSent :: Ord a => Sent a -> X.Sent Word a+packSent+  = DAG.mapN (const ())+  -- . fmap packSeg+++-- | Convert a sentence to a sentence from the core library.+-- packSentO :: P.Tagset -> SentO Tag -> X.SentO Word P.Tag+packSentO :: Ord a => SentO a -> X.SentO Word a+packSentO s = X.SentO+    { segs = packSent (sent s)+    , orig = orig s }+++---------------------------+-- From simple sentence+---------------------------+++-- fromWord :: R.Word -> (Space, Word)+-- fromWord R.Word{..} = (space, Word {orth=orth, known=known})+--+--+-- fromSeg :: (Ord t) => R.Seg t -> (Space, Edge t)+-- fromSeg R.Seg{..} =+--   (space, edge)+--   where+--     edge = Edge {word = newWord, interps = updateInterps interps}+--     (space, newWord) = fromWord word+--     -- updateInterps = X.mkWMap . map (first fromInterp) . X.unWMap+--     updateInterps = X.mapWMap fromInterp+--+--+-- fromInterp :: R.Interp t -> Interp t+-- fromInterp R.Interp{..} = Interp+--   { base = base+--   , tag = tag+--   , commonness = Nothing+--   , qualifier = Nothing+--   , metaInfo = Nothing+--   , eos = False }+--+--+-- -- | Create a DAG-based sentence from a list-based sentence.+-- fromList :: Ord t => R.Sent t -> Sent t+-- fromList = DAG.fromList' None . map fromSeg
+ src/NLP/Concraft/Polish/DAG/Server.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DuplicateRecordFields #-}+++-- | Concraft (DAG) web server.+++module NLP.Concraft.Polish.DAG.Server+  (+    -- * Types+    ServerCfg(..)+  , ClientCfg(..)+  , Request(..)+  , Answer(..)++    -- * Server+  , runServer++    -- * Client+  , sendRequest+  ) where+++import           Control.Monad.IO.Class (liftIO)++import           GHC.Generics++import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import           Network.HTTP.Types (badRequest400)+import qualified Web.Scotty as W+import qualified Data.Aeson as A+import           Data.Aeson ((.=))+import qualified Network.Wreq as Wreq+import           Control.Lens ((^?))++import qualified NLP.Concraft.Polish.DAGSeg as Pol+import qualified NLP.Concraft.Polish.DAG.Format.Base as DB+++---------------------------------------+-- Types+---------------------------------------+++type Concraft = Pol.Concraft Pol.Tag+++data Request = Request+  { dag :: T.Text+  } deriving (Generic)++instance A.FromJSON Request+instance A.ToJSON Request+++data Answer = Answer+  { dag :: T.Text+  } deriving (Generic)++instance A.ToJSON Answer+instance A.FromJSON Answer+++data ServerCfg = ServerCfg+  { concraft :: Concraft+  , annoCfg :: Pol.AnnoConf+  , showCfg :: DB.ShowCfg+  }+++---------------------------------------+-- Server+---------------------------------------+++serverApp :: ServerCfg -> W.ScottyM ()+serverApp env = do+  W.post "/parse" $ parse env+  W.post "/parse" parseFailure+++parse :: ServerCfg -> W.ActionM ()+parse ServerCfg{..} =  flip W.rescue (const W.next) $ do+  Request{..} <- W.jsonData+  let inp = DB.parseData (L.fromStrict dag)+      out = Pol.annoAll annoCfg concraft <$> inp+      dagStr = DB.showData showCfg out+      ans = Answer { dag = L.toStrict dagStr }+  -- W.json $ A.object [ "dag" .= dagStr ]+  W.json $ A.toJSON ans+++parseFailure :: W.ActionM ()+parseFailure = do+  W.json $ A.object+    [ "error" .= ("Invalid request" :: T.Text) ]+  W.status badRequest400+++runServer+  :: ServerCfg+  -> Int -- ^ Port+  -> IO ()+runServer env port = W.scotty port (serverApp env)+++---------------------------------------+-- Client+---------------------------------------+++data ClientCfg = ClientCfg+  { serverAddr :: String+  }+++sendRequest+  :: ClientCfg+  -> Request+  -> IO (Maybe Answer)+sendRequest ClientCfg{..} req = do+  let json = A.toJSON req+  r <- Wreq.post serverAddr json+  let result = A.decode =<< r ^? Wreq.responseBody+  return result
+ src/NLP/Concraft/Polish/DAGSeg.hs view
@@ -0,0 +1,612 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+++-- | DAG-based model for morphosyntactic tagging.+++module NLP.Concraft.Polish.DAGSeg+(++-- * Types+  Tag (..)+-- ** Simplification+, simplify4gsr+, simplify4dmb++-- ** Model+, C.Concraft+, C.saveModel+, C.loadModel++-- * Tagging+, guess+-- , disamb+-- , disamb'+-- , tag+-- , tag'+-- ** High level+, AnnoSent (..)+, AnnoConf (..)+, annoAll++-- * Training+, TrainConf (..)+-- , DisambTiersCfg (..)+, train++-- * Pruning+-- , C.prune+) where+++import           Prelude hiding (Word)+import           Control.Applicative ((<$>))+import           Control.Arrow (first)+import           Control.Monad (guard)+import           Data.Maybe (listToMaybe)+import qualified Data.Text.Lazy as L+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import           Data.Data (Data)+import           Data.Typeable (Typeable)++import qualified Data.Tagset.Positional as P+import qualified Numeric.SGD.Momentum as SGD++import qualified Data.DAG as DAG++import qualified NLP.Concraft.DAG.Morphosyntax as X+import qualified NLP.Concraft.DAG.Morphosyntax.Ambiguous as XA+import qualified NLP.Concraft.DAG.Schema as S+import           NLP.Concraft.DAG.Schema (SchemaConf(..), entry, entryWith)+import qualified NLP.Concraft.DAG.Guess as G+import qualified NLP.Concraft.DAG.DisambSeg as D+import qualified NLP.Concraft.DAG.Segmentation as Seg+import qualified NLP.Concraft.DAGSeg as C++import           NLP.Concraft.Polish.DAG.Morphosyntax hiding (tag, Tag)+import qualified NLP.Concraft.Polish.DAG.Morphosyntax as PolX+import qualified NLP.Concraft.Polish.DAG.Config as Cfg+import qualified NLP.Concraft.Polish.DAG.Config.Disamb as Cfg++-- import Debug.Trace (trace)+++-------------------------------------------------+-- Default configuration+-------------------------------------------------+++-- | Default configuration for the guessing observation schema.+guessSchemaDefault :: SchemaConf+guessSchemaDefault = S.nullConf+    { lowPrefixesC  = entryWith [1, 2]      [0]+    , lowSuffixesC  = entryWith [1, 2]      [0]+    , knownC        = entry                 [0]+    , begPackedC    = entry                 [0]+    }+++-- | Default configuration for the segmentation observation schema.+segmentSchemaDefault :: SchemaConf+segmentSchemaDefault = S.nullConf+    { lowPrefixesC  = entryWith [1, 2]      [-1, 0, 1]+    , begPackedC    = entry                 [-1, 0, 1] }+    -- NOTE: The current configuration works quite well for segmentation.+    -- Adding orthographic forms was not a good idea, at least not on a small+    -- training dataset.+++-- -- | Default configuration for the guessing observation schema.+-- disambSchemaDefault :: SchemaConf+-- disambSchemaDefault = S.nullConf+--     { lowPrefixesC  = entryWith [1, 2]      [-1, 0, 1]+--     , begPackedC    = entry                 [-1, 0, 1] }+++-- -- | Default configuration for the guessing observation schema.+-- disambSchemaDefault :: SchemaConf+-- disambSchemaDefault = S.nullConf+--     { orthC         = entry                   [-2, -1, 0, 1, 2]+--     -- { lowOrthC      = entry                   [-2, -1, 0, 1, 2]+--     , lowPrefixesC  = entryWith [1, 2, 3]     [-2, -1, 0, 1, 2]+--     , lowSuffixesC  = entryWith [1, 2, 3]     [-2, -1, 0, 1, 2]+--     , begPackedC    = entry                   [-2, -1, 0, 1, 2] }+++-- | Default configuration for the disambiguation observation schema.+disambSchemaDefault :: SchemaConf+disambSchemaDefault = S.nullConf+    { lowOrthC      = entry                         [-2, -1, 0, 1]+    , lowPrefixesC  = oov $ entryWith [1, 2, 3]     [0]+    , lowSuffixesC  = oov $ entryWith [1, 2, 3]     [0]+    , begPackedC    = oov $ entry                   [0] }+  where+    oov (Just body) = Just $ body { S.oovOnly = True }+    oov Nothing     = Nothing+++-- | Default tiered tagging configuration for the segmentation model.+tiersSegment :: [D.Tier]+tiersSegment =+    [tier]+  where+    tier = D.Tier+      { D.withPos = True+      , D.withEos = True+      , D.withAtts = S.fromList []+      }+++-------------------------------------------------+-- Tagging Tiers+-------------------------------------------------+++-- -- | Configuration of disambiguation tiers.+-- data DisambTiersCfg+--   = TiersDefault+--   | TiersGndCasSeparately+--   deriving (Data, Typeable, Show, Eq, Ord)+--+--+-- -- | Tiered tagging configuration for the disambiguation model.+-- tiersDisamb :: DisambTiersCfg -> [D.Tier]+-- tiersDisamb cfg = case cfg of+--   TiersDefault -> tiersDisambDefault+--   TiersGndCasSeparately -> tiersDisambGndCasSeparately+--+--+-- -- | Default tiered tagging configuration for the disambiguation model.+-- tiersDisambDefault :: [D.Tier]+-- tiersDisambDefault =+--     [tier1, tier2]+--   where+--     tier1 = D.Tier True False $ S.fromList+--       ["cas", "per"]+--     tier2 = D.Tier False False $ S.fromList+--       [ "nmb", "gnd", "deg", "asp" , "ngt", "acm"+--       , "acn", "ppr", "agg", "vlc", "dot"+--       , "sbg", "col"+--       ]+--+-- -- | Separate tier with gender and case values.+-- tiersDisambGndCasSeparately :: [D.Tier]+-- tiersDisambGndCasSeparately =+--     [tier1, tier2, tier3]+--   where+--     tier1 = D.Tier True False $ S.fromList+--       [ "per" ]+--     tier2 = D.Tier False False $ S.fromList+--       [ "nmb", "deg", "asp" , "ngt", "acm"+--       , "acn", "ppr", "agg", "vlc", "dot"+--       , "sbg", "col"+--       ]+--     tier3 = D.Tier False False $ S.fromList+--       [ "cas", "gnd"+--       ]+++tiersDisamb :: Cfg.Config -> [D.Tier]+tiersDisamb Cfg.Config{..} = do+  Cfg.TierCfg{..} <- Cfg.tiersCfg disambCfg+  return $ D.Tier+    { D.withPos = withPos+    , D.withEos = withEos+    , D.withAtts = Cfg.unSet withAtts+    }+++-------------------------------------------------+-- Tagging+-------------------------------------------------+++-- type Tag = PolX.Tag+type Tag = PolX.Interp PolX.Tag+++-- | Tag the sentence with guessing marginal probabilities.+guess :: C.Concraft Tag -> Sent Tag -> Sent Tag+guess = tagWith (C.guessMarginals . C.guesser)+++-- | Tag the sentence with disambiguation marginal probabilities.+disamb :: C.Concraft Tag -> Sent Tag -> Sent Tag+disamb = tagWith (C.disambMarginals . C.disamb)+++-- | Tag the sentence with disambiguation probabilities.+disamb' :: C.Concraft Tag -> D.ProbType -> Sent Tag -> Sent Tag+disamb' crf typ = tagWith (C.disambProbs typ . C.disamb) crf+++-- | Perform guessing -> trimming -> disambiguation.+tag+  :: Int+  -- ^ Trimming parameter+  -> C.Concraft Tag+  -> Sent Tag+  -> Sent Tag+tag = tagWith . C.tag+++-- -- | Perform guessing -> trimming -> disambiguation.+-- tag'+--   :: Int+--   -- ^ Trimming parameter+--   -> D.ProbType+--   -> C.Concraft+--   -> Sent Tag+--   -> Sent Tag+-- tag' k probTyp = tagWith (C.tag' k probTyp)+++-- | Tag with the help of a lower-level annotation function.+tagWith+  -- :: (C.Concraft Tag -> X.Sent Word P.Tag -> C.Anno P.Tag Double)+  :: (C.Concraft Tag -> X.Sent Word Tag -> C.Anno Tag Double)+  -> C.Concraft Tag -> Sent Tag -> Sent Tag+tagWith annoFun concraft sent+  = fmap select+  $ DAG.zipE sent annoSent+  where+    select (edge, anno) = selectAnno anno edge+    annoSent = annoWith annoFun concraft sent+++-- | Annotate with the help of a lower-level annotation function.+annoWith+  :: (C.Concraft Tag -> X.Sent Word Tag -> C.Anno Tag a)+  -> C.Concraft Tag -> Sent Tag -> C.Anno Tag a+annoWith anno concraft =+  anno concraft . packSent+++-- | Tranform each tag into two tags, one with EOS(end-of-sentence)=True, one+-- with EOS=False. The idea behind this transformation is that, at some point,+-- we may want to tag with an EOS-aware model, with no EOS-related information+-- coming from the previous tagging stages.+--+-- NOTE: this procedure does not apply to OOV words. The motivation: it seems+-- highly unlikely that any OOV word can mark a sentence end.+--+-- NOTE: this procedure does not apply to segmentation-ambiguous words either.+-- Allowing the tagger to cut on such words might cause losing DAG edges.+addEosMarkers+  :: DAG.DAG a Bool+  -> DAG.EdgeID+  -> X.Seg Word Tag+  -> X.Seg Word Tag+addEosMarkers ambiDag edgeID seg+  | X.oov seg = seg+  | DAG.edgeLabel edgeID ambiDag = seg+  | otherwise = seg {X.tags = newTags (X.tags seg)}+  where+    newTags tagMap = X.mkWMap $ concat+      [ multiply interp p+      | (interp, p) <- M.toList (X.unWMap tagMap) ]+    multiply interp p+      | eos interp == True =+          [ (interp {eos=True}, p)+          , (interp {eos=False}, 0) ]+      | otherwise =+          [ (interp {eos=True}, 0)+          , (interp {eos=False}, p) ]+++-- | Decide if the word should be marked as eos or not.+resolveEOS+  :: Double+     -- ^ 0.5 means that the probability of the tag being EOS is twice as high+     -- as that of not being EOS. 1.0 means that EOS will be marked only if its+     -- 100% probable.+  -> X.Seg Word Tag+  -> X.Seg Word Tag+resolveEOS minProp seg+  | isEos     = seg {X.tags = markEos}+  | otherwise = seg {X.tags = markNoEos}+  where+    tagMap = X.tags seg+    -- Determine the weights of the most probable EOS-marked and non-marked tags+    withEosW = maxWeightWith ((==True) . PolX.eos) tagMap+    withNoEosW = maxWeightWith ((==False) . PolX.eos) tagMap+    -- Should the segment be marked as EOS?+    isEos = case (withEosW, withNoEosW) of+      (Just eosW, Just noEosW) ->+        eosW / (eosW + noEosW) >= minProp+      (Just _, Nothing) -> True+      _ -> False+    -- Mark the segment as EOS or not+    markEos = X.mkWMap+      [ (interp {PolX.eos=True}, p)+      | (interp, p) <- M.toList (X.unWMap tagMap) ]+    markNoEos = X.mkWMap+      [ (interp {PolX.eos=False}, p)+      | (interp, p) <- M.toList (X.unWMap tagMap) ]+++-- | Determine the weight of the most probable interpretation which satisfies+-- the given predicate.+maxWeightWith :: (Tag -> Bool) -> X.WMap Tag -> Maybe Double+maxWeightWith pred tagMap = mayMaximum+  [ p+  | (interp, p) <- M.toList (X.unWMap tagMap)+  , pred interp ]+  where+    mayMaximum [] = Nothing+    mayMaximum xs = Just $ maximum xs+++-- | Try to segment the sentence based on the EOS markers.+-- segment :: X.Sent Word Tag -> [X.Sent Word Tag]+segment :: DAG.DAG a (X.Seg Word Tag) -> [DAG.DAG a (X.Seg Word Tag)]+segment sent =++  -- (\xs -> trace ("splits: " ++ show (length xs)) xs) $+  -- go (trace ("splitPoints: " ++ show splitPoints) splitPoints) sent+  go splitPoints sent++  where++    splitPoints = (S.toList . S.fromList)+      [ DAG.endsWith edgeID sent+      | edgeID <- DAG.dagEdges sent+      , interp <- M.keys . X.unWMap . X.tags . DAG.edgeLabel edgeID $ sent+      , PolX.eos interp ]++    go (splitPoint:rest) dag =+      case split splitPoint dag of+        Just (left, right) -> left : go rest right+        Nothing -> go rest dag+    go [] dag = [dag]++    split point dag = do+      (x, y) <- DAG.splitTmp point dag+      let empty = null . DAG.dagEdges+      guard . not . empty $ x+      guard . not . empty $ y+      return (x, y)+++-------------------------------------------------+-- High-level Tagging+-------------------------------------------------+++-- -- | Configuration related to frequency-based path picking.+-- data PickFreqConf = PickFreqConf+--   { pickFreqMap :: Maybe (M.Map T.Text (Int, Int))+--     -- ^ A map which assigns (chosen, not chosen) counts to the invidiaul+--     -- orthographic forms.+--   , smoothingParam :: Double+--     -- ^ A naive smoothing related parameter, which should be adddd to each+--     -- count in `pickFreqMap`.+--   }+++-- | Annotation config.+data AnnoConf = AnnoConf+  { trimParam :: Int+    -- ^ How many morphosyntactic tags should be kept for OOV words+  , pickPath :: Maybe Seg.PathTyp+    -- ^ Which path picking method should be used. The function takes the+  }+++-- | Annotated sentence.+data AnnoSent = AnnoSent+  { guessSent :: Sent Tag+  -- ^ The sentence after guessing and segmentation+  -- (TODO: and annotated with marginal probabilities?)+  , disambs   :: C.Anno Tag Bool+  -- ^ Disambiguation markers+  , marginals :: C.Anno Tag Double+  -- ^ Marginal probabilities according to the disambiguation model+  , maxProbs  :: C.Anno Tag Double+  -- ^ Maximal probabilities according to the disambiguation model+  }+++-- | Annotate all possibly interesting information.+annoAll+--   :: Int+--   -- ^ Trimming parameter+  :: AnnoConf+  -> C.Concraft Tag+  -> Sent Tag+  -> [AnnoSent]+-- annoAll k concraft sent0 =+annoAll AnnoConf{..} concraft sent00 =++  map annoOne _guessSent1++  where++    -- See whether the shortest path should be computed first+    sent0 =+      case pickPath of+        Just typ -> Seg.pickPath typ sent00+        Nothing -> sent00++    -- We add EOS markers only after guessing, because the possible tags are not+    -- yet determined for the OOV words.+    ambiDag = XA.identifyAmbiguousSegments sent0+    _guessSent0 = DAG.mapE (addEosMarkers ambiDag) $+      tagWith (C.guess trimParam . C.guesser) concraft sent0+    -- Resolve EOS tags based on the segmentation model+    _guessSent1 = segment . fmap (resolveEOS 0.5) $+      tagWith (C.disambProbs D.MaxProbs . C.segmenter) concraft _guessSent0++    annoOne _guessSent = AnnoSent+      { guessSent = _guessSent+      , disambs   = _disambs+      , marginals = _marginals+      , maxProbs  = _maxProbs+      }+      where+        _marginals =+          annoWith (C.disambProbs D.Marginals . C.disamb) concraft _guessSent+        _maxProbs  =+          annoWith (C.disambProbs D.MaxProbs . C.disamb) concraft _guessSent+        _disambs   =+          C.disambPath (optimal _maxProbs) _maxProbs+          where optimal = maybe [] id . listToMaybe . C.findOptimalPaths+++-------------------------------------------------+-- Training+-------------------------------------------------+++-- | Training configuration.+data TrainConf = TrainConf {+    -- | Tagset.+      tagset    :: P.Tagset+    -- | SGD parameters.+    , sgdArgs   :: SGD.SgdArgs+    -- | Store SGD dataset on disk.+    , onDisk    :: Bool+    -- | Numer of guessed tags for each word.+    , guessNum  :: Int+    -- | `G.r0T` parameter.+    , r0        :: G.R0T+    -- | `G.zeroProbLabel` parameter+    , zeroProbLabel :: Tag+    -- | Extract only visible features for the guesser+    , guessOnlyVisible :: Bool+    -- | Global configuration+    , globalConfig :: Cfg.Config+    -- -- | Disambiguation tiers configuration+    -- , disambTiersCfg :: DisambTiersCfg+    }+++-- | Train concraft model.+-- TODO: It should be possible to supply the two training procedures with+-- different SGD arguments.+train+    :: TrainConf+    -> IO [Sent Tag]      -- ^ Training data+    -> IO [Sent Tag]      -- ^ Evaluation data+    -> IO (C.Concraft Tag)+train TrainConf{..} train0 eval0 = do+  let trainR'IO = map packSent <$> train0+      evalR'IO  = map packSent <$> eval0++  putStr $ concat+    [ "Batch size for the "+    , "guessing and sentence segmentation models = "+    ]+  -- average number of sentences per paragraph+  averageParSize <- average . map (fromIntegral . length . segment) <$> trainR'IO+  let parBatchSize = ceiling $ fromIntegral (SGD.batchSize sgdArgs) / averageParSize+  print parBatchSize++  putStrLn "\n===== Train guessing model ====="+  guesser <- G.train (guessConf parBatchSize) trainR'IO evalR'IO+  let guess = C.guessSent guessNum guesser+      prepSent dag =+        let ambiDag = XA.identifyAmbiguousSegments dag+        in  DAG.mapE (addEosMarkers ambiDag) (guess dag)+      trainG'IO = map prepSent <$> trainR'IO+      evalG'IO  = map prepSent <$> evalR'IO++  putStrLn "\n===== Train sentence segmentation model ====="+  segmenter <- D.train (segmentConf parBatchSize) trainG'IO evalG'IO+  let prepSent = segment . fmap (resolveEOS 0.5)+      trainS'IO = concatMap prepSent <$> trainG'IO+      evalS'IO  = concatMap prepSent <$> evalG'IO++  putStrLn "\n===== Train disambiguation model ====="+  disamb <- D.train disambConf trainS'IO evalS'IO++  return $ C.Concraft tagset guessNum guesser segmenter disamb++  where++    guessConf batchSize = G.TrainConf+      guessSchemaDefault+      (sgdArgs {SGD.batchSize = batchSize})+      onDisk r0 zeroProbLabel+      (simplify4gsr tagset) strip4gsr+      guessOnlyVisible+    strip4gsr interp = PolX.voidInterp (PolX.tag interp)++    segmentConf batchSize = D.TrainConf+      tiersSegment segmentSchemaDefault+      (sgdArgs {SGD.batchSize = batchSize})+      onDisk+      (simplify4dmb tagset)++    disambConf = D.TrainConf+      -- (tiersDisamb disambTiersCfg)+      (tiersDisamb globalConfig)+      disambSchemaDefault sgdArgs onDisk+      (simplify4dmb tagset)+++-- | Simplify the tag for the sake of the disambiguation model.+simplify4dmb :: P.Tagset -> PolX.Interp PolX.Tag -> D.Tag+simplify4dmb tagset PolX.Interp{..} = D.Tag+  { D.posiTag = P.parseTag tagset tag+  , D.hasEos = eos }+++-- | Simplify the tag for the sake of the guessing model.+-- TODO: it is also used in the evaluation script, which assumes that+-- `simplify4gsr` simplifies to a positional tag. The name of the function+-- should reflect this, perhaps, or there should be two separate functions: one+-- dedicated to guesser, one dedicated to evaluation (and other more generic+-- things).+simplify4gsr :: P.Tagset -> PolX.Interp PolX.Tag -> P.Tag+simplify4gsr tagset PolX.Interp{..} = P.parseTag tagset tag+++-- -- | Train the `Concraft` model.+-- -- No reanalysis of the input data will be performed.+-- --+-- -- The `FromJSON` and `ToJSON` instances are used to store processed+-- -- input data in temporary files on a disk.+-- train+--     :: (X.Word w, Ord t)+--     => P.Tagset             -- ^ A morphosyntactic tagset to which `P.Tag`s+--                             --   of the training and evaluation input data+--                             --   must correspond.+--     -> Int                  -- ^ How many tags is the guessing model supposed+--                             --   to produce for a given OOV word?  It will be+--                             --   used (see `G.guessSent`) on both training and+--                             --   evaluation input data prior to the training+--                             --   of the disambiguation model.+--     -> G.TrainConf t P.Tag  -- ^ Training configuration for the guessing model.+--     -> D.TrainConf t        -- ^ Training configuration for the+--                             --   disambiguation model.+--     -> IO [Sent w t]    -- ^ Training dataset.  This IO action will be+--                             --   executed a couple of times, so consider using+--                             --   lazy IO if your dataset is big.+--     -> IO [Sent w t]    -- ^ Evaluation dataset IO action.  Consider using+--                             --   lazy IO if your dataset is big.+--     -> IO (Concraft t)+-- train tagset guessNum guessConf disambConf trainR'IO evalR'IO = do+--   Temp.withTempDirectory "." ".guessed" $ \tmpDir -> do+--   let temp = withTemp tagset tmpDir+--+--   putStrLn "\n===== Train guessing model ====="+--   guesser <- G.train guessConf trainR'IO evalR'IO+--   let guess = guessSent guessNum guesser+--   trainG  <- map guess <$> trainR'IO+--   evalG   <- map guess <$> evalR'IO+--+--   temp "train" trainG $ \trainG'IO -> do+--   temp "eval"  evalG  $ \evalG'IO  -> do+--+--   putStrLn "\n===== Train disambiguation model ====="+--   disamb <- D.train disambConf trainG'IO evalG'IO+--   return $ Concraft tagset guessNum guesser disamb+++-- | Compute an average of the list.+average :: [Double] -> Double+average xs = sum xs / fromIntegral (length xs)
src/NLP/Concraft/Polish/Maca.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}   -- | The module provides interface for the Maca analysis tool.
src/NLP/Concraft/Polish/Morphosyntax.hs view
@@ -7,11 +7,11 @@   module NLP.Concraft.Polish.Morphosyntax-( +( -- * Tag   Tag --- * Segment +-- * Segment , Seg (..) , Word (..) , Interp (..)@@ -33,6 +33,7 @@ ) where  +import           Prelude hiding (Word) import           Control.Applicative ((<$>), (<*>)) import           Control.Arrow (first) import           Data.Maybe (catMaybes)@@ -58,7 +59,7 @@   -- | A segment consists of a word and a set of morphosyntactic interpretations.-data Seg t = Seg +data Seg t = Seg     { word      :: Word     -- | Interpretations of the token, each interpretation annotated     -- with a /disamb/ Boolean value (if 'True', the interpretation@@ -70,8 +71,8 @@ instance (Ord t, Binary t) => Binary (Seg t) where     put Seg{..} = put word >> put interps     get = Seg <$> get <*> get-     + -- | A word. data Word = Word     { orth      :: T.Text@@ -103,7 +104,7 @@ instance Binary Word where     put Word{..} = put orth >> put space >> put known     get = Word <$> get <*> get <*> get-    +  -- | A morphosyntactic interpretation. data Interp t = Interp
tools/concraft-pl.hs view
@@ -1,60 +1,73 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE LambdaCase #-}   import           Control.Applicative ((<$>))-import           Control.Monad (unless)+import           Control.Monad (unless, forM_)+import           System.FilePath (isAbsolute, (</>)) import           System.Console.CmdArgs-import           System.IO (hFlush, stdout)-import qualified Network as N-import qualified Numeric.SGD as SGD+-- import           System.IO (hFlush, stdout)+import qualified Numeric.SGD.Momentum as SGD+import           Data.String (fromString)+import qualified Data.Text as T+import qualified Data.Text.IO as T import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L+-- import qualified Data.Text.Lazy.IO as L+import qualified Data.Text.Lazy.Encoding as L+import qualified Data.ByteString.Lazy as BL import           Data.Tagset.Positional (parseTagset)-import           GHC.Conc (numCapabilities)+import qualified Data.Tagset.Positional as P+import qualified Data.Map.Strict as M+import qualified Data.Set as S -import qualified NLP.Concraft.Morphosyntax.Accuracy as Acc-import qualified NLP.Concraft.Guess as Guess+import qualified Dhall as Dhall -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+import qualified Data.DAG as DAG -import           Paths_concraft_pl (version, getDataFileName)-import           Data.Version (showVersion)+import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Codec as CRF.Codec+import qualified Data.CRF.Chain1.Constrained.DAG.Train as CRF.Train +import qualified NLP.Concraft.DAG.Guess as Guess+import qualified NLP.Concraft.DAG.Schema as Schema+-- import qualified NLP.Concraft.DAG.Disamb as Disamb --- | Default port number.-portDefault :: Int-portDefault = 10089 +-- import qualified NLP.Concraft.DAG2 as C+-- import qualified NLP.Concraft.Polish.DAG2 as P+import qualified NLP.Concraft.DAGSeg as C+import qualified NLP.Concraft.DAG.Morphosyntax as X+import qualified NLP.Concraft.DAG.Morphosyntax.Accuracy as Acc+import qualified NLP.Concraft.DAG.Segmentation as Seg+import qualified NLP.Concraft.Polish.DAG.Morphosyntax as PX+import qualified NLP.Concraft.Polish.DAGSeg as Pol+import qualified NLP.Concraft.Polish.DAG.Format.Base as DB+import qualified NLP.Concraft.Polish.DAG.Server as Server +-- import qualified NLP.Concraft.Polish.Request as R++import           Paths_concraft_pl (version, getDataFileName)+import           Data.Version (showVersion)++ --------------------------------------- -- Command line options ---------------------------------------  --- | Data formats.-data Format = Plain deriving (Data, Typeable, Show)----- | A description of the Concraft-pl tool+-- | A description of the Concraft-pl tool. concraftDesc :: String concraftDesc = "Concraft-pl " ++ showVersion version   data Concraft   = Train-    { trainPath	    :: FilePath+    { trainPath     :: FilePath     , evalPath      :: Maybe FilePath-    , format        :: Format     , tagsetPath    :: Maybe FilePath-    , noAna         :: Bool-    -- , discardHidden :: Bool     , iterNum       :: Double     , batchSize     :: Int     , regVar        :: Double@@ -63,33 +76,66 @@     , disk          :: Bool     , outModel      :: FilePath     , guessNum      :: Int-    , r0            :: Guess.R0T }+    , r0            :: Guess.R0T+    , zeroProbLabel :: String+    , visibleOnly   :: Bool+    -- , disambTiers   :: Pol.DisambTiersCfg+    , config        :: FilePath+    }   | Tag     { inModel       :: FilePath-    , noAna         :: Bool-    , format        :: Format-    , marginals     :: Bool }-    -- , guessNum      :: Int }+    -- , marginals     :: Bool+    , inFile        :: Maybe FilePath+    , outFile       :: Maybe FilePath+    , probType      :: DB.ProbType+    -- , suppressProbs :: Bool+    , mayGuessNum   :: Maybe Int+    , freqPath      :: Maybe FilePath+    , freqSmoothing :: Double+    , shortestPath  :: Bool+    , longestPath   :: Bool+    , numericDisamb :: Bool+    }   | Server     { inModel       :: FilePath-    , port          :: Int }+    , probType      :: DB.ProbType+    , mayGuessNum   :: Maybe Int+    , numericDisamb :: Bool+    , port          :: Int+    }   | Client-    { noAna         :: Bool-    , format        :: Format-    , marginals     :: Bool-    , host          :: String-    , port          :: Int }-  | Compare-    { tagsetPath    :: Maybe FilePath-    , refPath       :: FilePath-    , otherPath     :: FilePath-    , format        :: Format }-  | Prune-    { inModel       :: FilePath-    , outModel      :: FilePath-    , threshold     :: Double }---   | ReAna---     { format	    :: Format }+    { serverAddr    :: String+    , inFile        :: Maybe FilePath+    , outFile       :: Maybe FilePath+    , batchSize     :: Int+    }+  | Eval+    { justTagsetPath :: FilePath+    , goldPath       :: FilePath+    , taggPath       :: FilePath+    , onlyOov        :: Bool+    , onlyAmb        :: Bool+    , onlyEos        :: Bool+    , expandTags     :: Bool+    , ignoreTags     :: Bool+    , heedEos        :: Bool+    , weak           :: Bool+    , discardProb0   :: Bool+    , verbose        :: Bool+    }+  | Check+    { justTagsetPath :: FilePath+    , dagPath        :: FilePath+    }+  | Freqs+    { dagPath        :: FilePath+    -- , justTagsetPath :: FilePath+    -- , outPath        :: FilePath+    }+  | Ambi+    { dagPath        :: FilePath+    , onlyChosen     :: Bool+    }   deriving (Data, Typeable, Show)  @@ -98,68 +144,113 @@     { trainPath = def &= argPos 1 &= typ "TRAIN-FILE"     , evalPath = def &= typFile &= help "Evaluation file"     , tagsetPath = def &= typFile &= help "Tagset definition file"-    , format = enum [Plain &= help "Plain format"]-    , noAna = False &= help "Do not perform reanalysis"+    , config = def &= typFile &= help "Global configuration file"     -- , discardHidden = False &= help "Discard hidden features"     , iterNum = 20 &= help "Number of SGD iterations"-    , batchSize = 50 &= help "Batch size"-    , regVar = 10.0 &= help "Regularization variance"-    , gain0 = 1.0 &= help "Initial gain parameter"-    , tau = 5.0 &= help "Initial tau parameter"+    , batchSize = 50 &= help+      "Batch size (the number of dataset elements taken in a single SGD update)"+    , regVar = 10.0 &=+      help "Regularization variance (the higher variance, the higher penalty for large params)"+    , gain0 = 0.25 &= help+      "Initial gain parameter (gain is used to scale the gradient before parameter update)"+      -- The value `0.25` makes sense given that SGD momentum is used+    , tau = 5.0 &= help+      "Initial tau parameter (after how many passes over the full dataset the gain is halved)"     , disk = False &= help "Store SGD dataset on disk"     , 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" }+    , r0 = Guess.OovChosen &= help "R0 construction method"+    , zeroProbLabel = "xxx" &= help "Zero probability label"+    , visibleOnly = False &= help "Extract only visible features for the guesser"+    -- , disambTiers = Pol.TiersDefault &= help "Dismabiguation tiers configuration"+    }   tagMode :: Concraft tagMode = Tag     { 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" }+    -- , noAna    = False &= help "Do not analyse input text"+    -- , marginals = False &= help "Tag with marginal probabilities" }+    , inFile  = def &= typFile &= help "Input file (stdin by default)"+    , outFile = def &= typFile &= help "Output file (stdout by default)"+    , probType = DB.Marginals &= help "Type of probabilities"+    -- , suppressProbs = False &= help "Do not show probabilities"+    , freqPath = def &= typFile &= help "File with chosen/not-chosen counts"+    , freqSmoothing = 1.0 &= help+      "Smoothing parameter for frequency-based path selection"+    , shortestPath = False &= help+      "Select shortest paths prior to parsing (can serve as a segmentation baseline)"+    , longestPath = False &= help+      "Select longest paths prior to parsing (mutually exclusive with shortestPath)"+    , mayGuessNum = def &= help "Number of guessed tags for each unknown word"+    , numericDisamb = False &= help+      "Print disamb markers as numerical values in the probability column"+    }   serverMode :: Concraft serverMode = Server-    { inModel = def &= argPos 0 &= typ "MODEL-FILE"-    , port    = portDefault &= help "Port number" }+    { inModel  = def &= argPos 0 &= typ "MODEL-FILE"+    , probType = DB.Marginals &= help "Type of probabilities"+    , mayGuessNum = def &= help "Number of guessed tags for each unknown word"+    , numericDisamb = False &= help+      "Print disamb markers as numerical values in the probability column"+    , port = 3000 &= help "Server port"+    }   clientMode :: Concraft clientMode = Client-    { 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" }+    { serverAddr = "http://localhost:3000/parse" &= help "Server address"+    , inFile  = def &= typFile &= help "Input file (stdin by default)"+    , outFile = def &= typFile &= help "Output file (stdout by default)"+    , batchSize = 10 &= help "Sent graphs in batches of the given size"+    }  -compareMode :: Concraft-compareMode = Compare-    { 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 format"] }+evalMode :: Concraft+evalMode = Eval+    { justTagsetPath = def &= typ "TAGSET-FILE"  &= argPos 0+    , goldPath = def &= typ "GOLD-FILE" &= argPos 1+    , taggPath = def &= typ "TAGGED-FILE" &= argPos 2+    , onlyOov  = False &= help "Only OOV edges"+    , onlyAmb  = False &= help "Only segmentation-ambiguous edges"+    , onlyEos = False &= help "Only EOS edges"+    , expandTags = False &= help "Expand tags"+    , ignoreTags = False &= help "Ignore tags (compute segmentation-level accurracy)"+    , heedEos = False &= help "Pay attention to EOS markers (ignored by default)"+    , weak = False &= help "Compute weak accuracy rather than strong"+    , discardProb0 = False &= help "Discard sentences with near 0 probability"+    , verbose = False &= help "Print information about compared elements"+    }  -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" }+checkMode :: Concraft+checkMode = Check+    { justTagsetPath = def &= typ "TAGSET-FILE"  &= argPos 0+    , dagPath= def &= typ "DAG-FILE" &= argPos 1+    }  --- reAnaMode :: Concraft--- reAnaMode = ReAna---     { format    = enum [Plain &= help "Plain format"] }+freqsMode :: Concraft+freqsMode = Freqs+    { dagPath = def &= typ "DAG-FILE" &= argPos 1+    -- , justTagsetPath = def &= typ "TAGSET-FILE"  &= argPos 0+    -- , outPath = def &= typ "FREQ-FILE" &= help "Output file to store counts"+    }  +ambiMode :: Concraft+ambiMode = Ambi+    { dagPath = def &= typ "DAG-FILE" &= argPos 1+    , onlyChosen = False &= help "Take only the chose tokens into account"+    }++ argModes :: Mode (CmdArgs Concraft) argModes = cmdArgsMode $ modes-    [trainMode, tagMode, serverMode, clientMode, compareMode, pruneMode]+    [ trainMode, tagMode, serverMode, clientMode+    , evalMode, checkMode, freqsMode, ambiMode ]     &= summary concraftDesc     &= program "concraft-pl" @@ -181,155 +272,362 @@         Nothing -> getDataFileName "config/nkjp-tagset.cfg"         Just x  -> return x     tagset <- parseTagset tagsetPath' <$> readFile tagsetPath'-    let train0 = parseFileO  format trainPath-    let eval0  = parseFileO' format evalPath-    concraft <- C.train (trainConf tagset) train0 eval0++    -- Dhall configuration+    let configPath =+          if isAbsolute config+          then config+          else "./" </> config+    dhall <- Dhall.detailed+      (Dhall.input Dhall.auto $ fromString configPath)++    -- let zeroProbLab = P.parseTag taset zeroProbLabel+    let zeroProbLab = PX.Interp+          { PX.base = "none"+          , PX.tag = T.pack zeroProbLabel+          , PX.commonness = Nothing+          , PX.qualifier = Nothing+          , PX.metaInfo = Nothing+          , PX.eos = False }+        train0 = DB.parseData <$> readFileUtf8 trainPath+        eval0  = case evalPath of+          Nothing -> return []+          Just ph -> DB.parseData <$> readFileUtf8 ph+    -- putStrLn $ "\nRegularization variance: " ++ show regVar+    concraft <- Pol.train (trainConf dhall tagset zeroProbLab) train0 eval0     unless (null outModel) $ do         putStrLn $ "\nSaving model in " ++ outModel ++ "..."-        C.saveModel outModel concraft+        Pol.saveModel outModel concraft   where     sgdArgs = SGD.SgdArgs         { SGD.batchSize = batchSize         , SGD.regVar = regVar         , SGD.iterNum = iterNum         , SGD.gain0 = gain0-        , SGD.tau = tau }-    trainConf tagset = C.TrainConf-        { tagset    = tagset +        , SGD.tau = tau+        }+    trainConf dhall tagset zeroLab = Pol.TrainConf+        { tagset    = tagset         , sgdArgs   = sgdArgs-        , reana     = not noAna+        -- , reana     = not noAna         , onDisk    = disk         , guessNum  = guessNum-        , r0        = r0 }+        , r0        = r0+        , zeroProbLabel = zeroLab+        , guessOnlyVisible = visibleOnly+        -- , disambTiersCfg = disambTiers+        , globalConfig = dhall+        }   exec Tag{..} = do-    cft <- C.loadModel inModel-    pool <- Maca.newMacaPool numCapabilities-    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 }+  -- crf <- Pol.loadModel P.parseTag inModel+  crf <- Pol.loadModel Pol.simplify4gsr Pol.simplify4dmb inModel+  -- inp <- DB.parseData <$> L.getContents+  inp <- DB.parseData <$> case inFile of+    Nothing -> getContentsUtf8+    Just path -> readFileUtf8 path+  pathSelection <-+    case (shortestPath, longestPath, freqPath) of+      (True, _, _) -> return $ Just Seg.Min+      (_, True, _) -> return $ Just Seg.Max+      (_, _, Just freqPath) -> do+        freqMap <- loadFreqMap freqPath+        let conf = Seg.FreqConf+              { Seg.pickFreqMap = freqMap+              , Seg.smoothingParam = freqSmoothing+              }+        return . Just $ Seg.Freq conf+      _         -> return Nothing+  let guessNum = case mayGuessNum of+        Nothing -> C.guessNum crf+        Just k  -> k+      cfg = Pol.AnnoConf+        { trimParam = guessNum+        , pickPath = pathSelection+        }+      out = Pol.annoAll cfg crf <$> inp+      showCfg = DB.ShowCfg+        -- { suppressProbs = suppressProbs+        { probType = probType+        , numericDisamb = numericDisamb }+  case outFile of+    Nothing -> putStrUtf8 $ DB.showData showCfg out+    Just path -> writeFileUtf8 path $ DB.showData showCfg out   exec Server{..} = do-    putStr "Loading model..." >> hFlush stdout-    concraft <- C.loadModel inModel-    putStrLn " done"-    pool <- Maca.newMacaPool numCapabilities-    let portNum = N.PortNumber $ fromIntegral port-    putStrLn $ "Listening on port " ++ show port-    S.runConcraftServer pool concraft portNum+  crf <- Pol.loadModel Pol.simplify4gsr Pol.simplify4dmb inModel+  let guessNum = case mayGuessNum of+        Nothing -> C.guessNum crf+        Just k  -> k+      cfg = Pol.AnnoConf+        { trimParam = guessNum+        , pickPath = Nothing+        }+      showCfg = DB.ShowCfg+        { probType = probType+        , numericDisamb = numericDisamb+        }+      serverCfg = Server.ServerCfg+        { concraft = crf+        , annoCfg = cfg+        , showCfg = showCfg+        }+  Server.runServer serverCfg port   exec Client{..} = do-    let portNum = N.PortNumber $ fromIntegral port-    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 }+  -- clear the file, if specified (stdout otherwise)+  case outFile of+    Nothing -> return ()+    Just path -> writeFileUtf8 path ""+  inpAll <- case inFile of+    Nothing -> getContentsUtf8+    Just path -> readFileUtf8 path+  let inputs+        = map (L.intercalate "\n\n")+        . group batchSize+        $ filter+          (not . L.null)+          (L.splitOn "\n\n" inpAll)+  forM_ (map L.toStrict inputs) $ \inp -> do+    let req = Server.Request {dag = inp}+        cfg = Server.ClientCfg {serverAddr=serverAddr}+    Server.sendRequest cfg req >>= \case+      Nothing -> putStrLn "<< NO RESPONSE >>"+      Just Server.Answer{..} -> case outFile of+        Nothing -> putStrUtf8 (L.fromStrict dag)+        Just path -> appendFileUtf8 path (L.fromStrict dag)  -exec Compare{..} = do-    tagsetPath' <- case tagsetPath of-        Nothing -> getDataFileName "config/nkjp-tagset.cfg" -        Just x  -> return x-    tagset <- parseTagset tagsetPath' <$> readFile tagsetPath'-    let convert = map (X.packSeg tagset) . concat-    xs <- convert <$> parseFile format refPath-    ys <- convert <$> parseFile format otherPath-    let s = Acc.weakLB tagset xs ys-    putStrLn $ "Number of segments in reference file: " ++ show (Acc.gold s)-    putStrLn $ "Number of correct tags: " ++ show (Acc.good s)-    putStrLn $ "Weak accuracy lower bound: " ++ show (Acc.accuracy s)+exec Eval{..} = do+  tagset <- parseTagset justTagsetPath <$> readFile justTagsetPath+  let simplify = fmap $ \seg ->+        let simplify4eval interp =+              ( P.parseTag tagset $ PX.tag interp+              , PX.eos interp && heedEos )+            newTags = X.mapWMap simplify4eval (X.tags seg)+        in  seg {X.tags = newTags}+      process = PX.packSent . simplify+      fromFile = fmap (map process . DB.parseData) . readFileUtf8 +  putStrLn $ concat+    [ "Note that in this evaluation lemmas "+    , "are *not* taken into account."+    ] -exec Prune{..} = do-    cft <- C.loadModel inModel-    C.saveModel outModel $ C.prune threshold cft+  let cfg = Acc.AccCfg+        { Acc.onlyOov = onlyOov+        , Acc.onlyAmb = onlyAmb+        , Acc.onlyMarkedWith =+            if onlyEos+            then S.singleton True+            else S.empty+        , Acc.accTagset = tagset+        , Acc.expandTag = expandTags+        , Acc.ignoreTag = ignoreTags+        , Acc.weakAcc = weak+        , Acc.discardProb0 = discardProb0+        , Acc.verbose = verbose+        }+  stats <- Acc.collect cfg+    <$> fromFile goldPath+    <*> fromFile taggPath+  putStr "Precision: " >> print (Acc.precision stats)+  putStr "Recall: " >> print (Acc.recall stats)+  putStr "Accuracy: " >> print (Acc.accuracy stats)  --- exec ReAna{..} = do---     inp  <- parseText format <$> L.getContents---     out  <- showData format <$> +exec Check{..} = do+  tagset <- parseTagset justTagsetPath <$> readFile justTagsetPath+  dags <- DB.parseData <$> readFileUtf8 dagPath+  forM_ dags $ \dag -> do+    if (not $ DAG.isOK dag) then do+      putStrLn "Incorrectly structured graph:"+      showDAG dag+    else if (not $ DAG.isDAG dag) then do+      putStrLn "Graph with cycles:"+      showDAG dag+    else case verifyProb tagset dag of+      Nothing -> return ()+      Just p -> do+        putStr "Probability equal to "+        putStr (show p)+        putStrLn ":"+        showDAG dag+  where+    showDAG dag =+      forM_ (DAG.dagEdges dag) $ \edgeID -> do+        let from = DAG.begsWith edgeID dag+            to = DAG.endsWith edgeID dag+            val = DAG.edgeLabel edgeID dag+        putStr (show $ DAG.unNodeID from)+        putStr ", "+        putStr (show $ DAG.unNodeID to)+        putStr " => "+        T.putStrLn (PX.orth $ X.word val)+    verifyProb tagset dag =+      let schema = Schema.fromConf Schema.nullConf+          rawData = Guess.schemed (Pol.simplify4gsr tagset) schema [PX.packSent dag]+          [encDag] = CRF.Codec.encodeDataL (CRF.Codec.mkCodec rawData) rawData+          p = CRF.Train.dagProb encDag+          eps = 1e-9+      in  if p >= 1 - eps && p <= 1 + eps+          then Nothing+          else Just p  ------------------------------------------- Reading files----------------------------------------+exec Freqs{..} = do+  -- tagset <- parseTagset justTagsetPath <$> readFile justTagsetPath+  dags <- DB.parseData <$> readFileUtf8 dagPath+  let freqMap = Seg.computeFreqs $ map PX.packSent dags+  printFreqMap freqMap  -parseFileO' :: Format -> Maybe FilePath -> IO [X.SentO X.Tag]-parseFileO' format path = case path of-    Nothing -> return []-    Just pt -> parseFileO format pt+exec Ambi{..} = do+  dags <- DB.parseData <$> readFileUtf8 dagPath+  let stats = Seg.computeAmbiStats cfg $ map PX.packSent dags+  print stats+  where+    cfg = Seg.AmbiCfg+      { Seg.onlyChosen = onlyChosen+      }  -parseFileO :: Format -> FilePath -> IO [X.SentO X.Tag]-parseFileO format path = parseParaO format <$> L.readFile path+---------------------------------------+-- Frequency map+---------------------------------------  -parseFile :: Format -> FilePath -> IO [X.Sent X.Tag]-parseFile format path = parsePara format <$> L.readFile path+printFreqMap+  :: M.Map T.Text (Int, Int)+  -> IO ()+printFreqMap freqMap =+  forM_ (M.toList freqMap) $ \(orth, (chosen, notChosen)) -> do+    T.putStr $ T.replace "\t" " " orth+    T.putStr "\t"+    putStr $ show chosen+    T.putStr "\t"+    putStrLn $ show notChosen  +loadFreqMap+  :: FilePath+  -> IO (M.Map T.Text (Int, Int))+loadFreqMap filePath = do+  M.fromList . map readPair . T.lines <$> T.readFile filePath+  where+    readPair line =+      case T.splitOn "\t" line of+        [orth, chosen, notChosen] ->+          (orth, (readInt chosen, readInt notChosen))+        _ -> error $ "loadFreqMap: line incorrectly formatted: " ++ T.unpack line+    readInt = read . T.unpack++ ------------------------------------------ Parsing text+-- UTF8 ---------------------------------------  --- parseTextO :: Format -> L.Text -> [[X.SentO X.Tag]]--- parseTextO format = map (map X.withOrig) . parseText format+readFileUtf8 :: FilePath -> IO L.Text+readFileUtf8 path = L.decodeUtf8 <$> BL.readFile path  -parseParaO :: Format -> L.Text -> [X.SentO X.Tag]-parseParaO format = map X.withOrig . parsePara format+writeFileUtf8 :: FilePath -> L.Text -> IO ()+writeFileUtf8 path = BL.writeFile path . L.encodeUtf8  ------------------------------------------- Parsing (format dependent)----------------------------------------+appendFileUtf8 :: FilePath -> L.Text -> IO ()+appendFileUtf8 path = BL.appendFile path . L.encodeUtf8  -parseText :: Format -> L.Text -> [[X.Sent X.Tag]]-parseText Plain = P.parsePlain+getContentsUtf8 :: IO L.Text+getContentsUtf8 = L.decodeUtf8 <$> BL.getContents  -parsePara :: Format -> L.Text -> [X.Sent X.Tag]-parsePara Plain = P.parsePara+putStrUtf8 :: L.Text -> IO ()+putStrUtf8 = BL.putStr . L.encodeUtf8   ------------------------------------------ Showing (format dependent)+-- Utils ---------------------------------------  -data ShowCfg = ShowCfg {-    -- | The format used.-      formatCfg :: Format-    -- | Show weights?-    , showWsCfg :: Bool }+-- | Group the input list into the groups of X.+group :: Int -> [a] -> [[a]]+group n =+  doit n []+  where+    doit k acc (x:xs)+      | k > 0 =+          doit (k-1) (x:acc) xs+      | otherwise =+          reverse acc : doit n [] (x:xs)+    doit _ acc []+      | null acc  = []+      | otherwise = [reverse acc]  -showData :: ShowCfg -> [[X.Sent X.Tag]] -> L.Text-showData ShowCfg{..} = P.showPlain (P.ShowCfg {P.showWsCfg = showWsCfg})+-- ---------------------------------------+-- -- Reading files+-- ---------------------------------------+--+-- -- TODO: make everything work on DAG input/output.+--+-- parseFileO' :: Format -> Maybe FilePath -> IO [X.SentO X.Tag]+-- parseFileO' format path = case path of+--     Nothing -> return []+--     Just pt -> parseFileO format pt+--+--+-- parseFileO :: Format -> FilePath -> IO [X.SentO X.Tag]+-- parseFileO format path = parseParaO format <$> L.readFile path+--+--+-- parseFile :: Format -> FilePath -> IO [X.Sent X.Tag]+-- parseFile format path = parsePara format <$> L.readFile path+--+--+-- ---------------------------------------+-- -- Parsing text+-- ---------------------------------------+--+--+-- -- parseTextO :: Format -> L.Text -> [[X.SentO X.Tag]]+-- -- parseTextO format = map (map X.withOrig) . parseText format+--+--+-- parseParaO :: Format -> L.Text -> [X.SentO X.Tag]+-- parseParaO format = map X.withOrig . parsePara format+--+--+-- ---------------------------------------+-- -- Parsing (format dependent)+-- ---------------------------------------+--+--+-- parseText :: Format -> L.Text -> [[X.Sent X.Tag]]+-- parseText Plain = P.parsePlain+--+--+-- parsePara :: Format -> L.Text -> [X.Sent X.Tag]+-- parsePara Plain = P.parsePara+--+--+-- ---------------------------------------+-- -- Showing (format dependent)+-- ---------------------------------------+--+--+-- 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})