module NLP.GenI.Warning.Internal where
import Data.FullList ( FullList, fromFL )
import Data.List
import Data.Monoid ( Monoid, mconcat, mappend, mempty )
import Data.Text ( Text )
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Poset
import NLP.GenI.General ( histogram )
import NLP.GenI.GeniVal ( GeniVal )
import NLP.GenI.LexicalSelection.Types ( LexCombineError, showLexCombineError )
import NLP.GenI.Lexicon ( LexEntry(..) )
import NLP.GenI.Pretty
import NLP.GenI.Semantics ( Literal )
import NLP.GenI.TreeSchema ( showLexeme )
newtype GeniWarnings = GeniWarnings { fromGeniWarnings :: [GeniWarning] }
mkGeniWarnings :: [GeniWarning] -> GeniWarnings
mkGeniWarnings = mconcat . map (\x -> GeniWarnings [x])
instance Monoid GeniWarnings where
mempty = GeniWarnings []
mappend (GeniWarnings g1) (GeniWarnings g2) = GeniWarnings (foldr appendWarning g2 g1)
data GeniWarning =
LexWarning [LexEntry] LexWarning
| CustomLexWarning Text
| NoLexSelection [Literal GeniVal]
| MorphWarning [Text]
deriving (Eq)
data LexWarning = LexCombineAllSchemataFailed
| LexCombineOneSchemaFailed LexCombineError
| MissingCoanchors Text Int
deriving (Eq)
posort :: Poset a => [a] -> [a]
posort = sortBy (flip fromPosetCmp)
where
fromPosetCmp x1 x2 = case posetCmp x1 x2 of
Comp o -> o
NComp -> EQ
instance Poset GeniWarning where
leq (LexWarning _ w1) (LexWarning _ w2) = leq w1 w2
leq (LexWarning _ _) _ = True
leq (CustomLexWarning _) (LexWarning _ _) = False
leq (CustomLexWarning w1) (CustomLexWarning w2) = leq w1 w2
leq (CustomLexWarning _) _ = True
leq (NoLexSelection _) (LexWarning _ _) = False
leq (NoLexSelection _) (CustomLexWarning _) = False
leq (NoLexSelection _) (NoLexSelection _) = True
leq (NoLexSelection _) _ = True
leq (MorphWarning _) (LexWarning _ _) = False
leq (MorphWarning _) (CustomLexWarning _) = False
leq (MorphWarning _) (NoLexSelection _) = False
leq (MorphWarning w1) (MorphWarning w2) = leq w1 w2
instance Poset LexWarning where
leq (LexCombineOneSchemaFailed l1) (LexCombineOneSchemaFailed l2) = leq l1 l2
leq (LexCombineOneSchemaFailed _) _ = True
leq LexCombineAllSchemataFailed (LexCombineOneSchemaFailed _) = False
leq LexCombineAllSchemataFailed _ = True
leq (MissingCoanchors _ n1) (MissingCoanchors _ n2) = leq n1 n2
leq (MissingCoanchors _ _) (LexCombineOneSchemaFailed _) = False
leq (MissingCoanchors _ _) LexCombineAllSchemataFailed = False
sortWarnings :: GeniWarnings -> GeniWarnings
sortWarnings (GeniWarnings ws) = GeniWarnings (posort ws)
appendWarning :: GeniWarning -> [GeniWarning] -> [GeniWarning]
appendWarning w0 [] = [w0]
appendWarning w0 (w:ws) = case mergeWarning w0 w of
Just w1 -> w1 : ws
Nothing -> w : appendWarning w0 ws
mergeWarning :: GeniWarning -> GeniWarning -> Maybe GeniWarning
mergeWarning (LexWarning ls1 w1) (LexWarning ls2 w2) | w1 == w2 = Just (LexWarning (ls1 ++ ls2) w1)
mergeWarning _ _ = Nothing
showGeniWarning :: GeniWarning -> [Text]
showGeniWarning (NoLexSelection ps) =
[ "No lexical entries for literals:" <+> T.unwords (map pretty ps) ]
showGeniWarning (CustomLexWarning w) = [w]
showGeniWarning (LexWarning ls wa) = do
wf <- Map.toList (toWfCount ls)
return (msg <> ":" <+> prettyCount showWithFam "lemmas" wf <> suffix)
where
(msg, suffix) = showLexWarning wa
showLexWarning LexCombineAllSchemataFailed =
("Lexically selected but anchoring failed for *all* instances of", "")
showLexWarning (LexCombineOneSchemaFailed lc) =
showLexCombineError lc
showLexWarning (MissingCoanchors co n) =
(T.unwords [ "Expected co-anchor", co
, "is missing from", T.pack (show n), "schemata"
]
, "")
showWithFam (w, f) = showLexeme (fromFL w) <+> parens f
showGeniWarning (MorphWarning ws) = map ("Morph:" <+>) ws
type WordFamilyCount = Map.Map (FullList Text, Text) Int
toWfCount :: [LexEntry] -> WordFamilyCount
toWfCount = histogram . map toWf
where
toWf i = (iword i, ifamname i)