-- GenI surface realiser -- Copyright (C) 2011 Eric Kow (on behalf of SRI) -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License -- as published by the Free Software Foundation; either version 2 -- of the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. {-# LANGUAGE OverloadedStrings #-} 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 ) -- | This exists because we want the 'Monoid' instance, providing a -- GenI-specific notion of appending which merges instances of the -- same error 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 = -- | A warning that should be repeated for each lexical entry affected LexWarning [LexEntry] LexWarning -- | A single custom warning | CustomLexWarning Text -- | Literals which did not receive any lexical selection | NoLexSelection [Literal GeniVal] -- | Warnings from the morphological realiser | MorphWarning [Text] deriving (Eq) data LexWarning = LexCombineAllSchemataFailed | LexCombineOneSchemaFailed LexCombineError | MissingCoanchors Text Int deriving (Eq) -- | Sort, treating non-comporable items as equal 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 -- 1. LexWarning leq (LexWarning _ w1) (LexWarning _ w2) = leq w1 w2 leq (LexWarning _ _) _ = True -- 2. CustomLexWarning leq (CustomLexWarning _) (LexWarning _ _) = False leq (CustomLexWarning w1) (CustomLexWarning w2) = leq w1 w2 leq (CustomLexWarning _) _ = True -- 3. NoLexSelection leq (NoLexSelection _) (LexWarning _ _) = False leq (NoLexSelection _) (CustomLexWarning _) = False leq (NoLexSelection _) (NoLexSelection _) = True leq (NoLexSelection _) _ = True -- 4. MorphWarning leq (MorphWarning _) (LexWarning _ _) = False leq (MorphWarning _) (CustomLexWarning _) = False leq (MorphWarning _) (NoLexSelection _) = False leq (MorphWarning w1) (MorphWarning w2) = leq w1 w2 instance Poset LexWarning where -- 1. LexCombineOneSchemaFailed leq (LexCombineOneSchemaFailed l1) (LexCombineOneSchemaFailed l2) = leq l1 l2 leq (LexCombineOneSchemaFailed _) _ = True -- 2. LexCombineAllSchemataFailed leq LexCombineAllSchemataFailed (LexCombineOneSchemaFailed _) = False leq LexCombineAllSchemataFailed _ = True -- 3. MissingCoanchors 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 -- | A warning may be displayed over several lines 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 -- list monad 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 -- word and all families associated with that word type WordFamilyCount = Map.Map (FullList Text, Text) Int toWfCount :: [LexEntry] -> WordFamilyCount toWfCount = histogram . map toWf where toWf i = (iword i, ifamname i)