GenI-0.25.0: src/NLP/GenI.hs
-- GenI surface realiser
-- Copyright (C) 2005 Carlos Areces and Eric Kow
--
-- 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 DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | This is the interface between the front and backends of the generator. The GUI
-- and the console interface both talk to this module, and in turn, this module
-- talks to the input file parsers and the surface realisation engine.
module NLP.GenI (
-- * Main interface
-- ** Program state and configuration
ProgState(..), ProgStateRef, emptyProgState,
LexicalSelector,
-- ** Running GenI
runGeni, simplifyResults, defaultCustomSem,
GeniResults(..),
GeniResult(..), isSuccess, GeniError(..), GeniSuccess(..),
GeniLexSel(..),
ResultType(..),
-- * Helpers
initGeni, extractResults,
lemmaSentenceString, prettyResult,
showRealisations, histogram,
getTraces,
-- ** Loading things
loadEverything,
Loadable(..),
loadLexicon,
loadGeniMacros,
loadTestSuite, parseSemInput,
loadRanking, BadInputException(..),
loadFromString,
)
where
import Control.Applicative ((<$>), (<*>))
import Control.DeepSeq
import Control.Exception
import Control.Monad.Except
import Data.Binary (Binary, decodeFile)
import qualified Data.ByteString as BS
import Data.IORef (IORef, modifyIORef, readIORef)
import Data.List
import qualified Data.Map as Map
import Data.Monoid (mempty, (<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import System.CPUTime (getCPUTime)
import System.FilePath (takeExtension)
import System.IO (stderr)
import Data.FullList (fromFL)
import System.Log.Logger (debugM)
import Text.JSON
import qualified NLP.GenI.Builder as B
import NLP.GenI.Configuration
import NLP.GenI.General (eFlush, ePutStr, ePutStrLn, first3,
geniBug, histogram, mkLogname, snd3)
import NLP.GenI.GeniShow
import NLP.GenI.GeniVal
import NLP.GenI.LexicalSelection (CustomSem (..),
LexicalSelection (..),
LexicalSelector,
defaultLexicalSelector)
import NLP.GenI.Lexicon
import NLP.GenI.Morphology
import NLP.GenI.OptimalityTheory
import NLP.GenI.Parser (ParseError, geniLexicon, geniMacros,
geniMorphInfo, geniSemanticInput,
geniTagElems, geniTestSuite,
geniTestSuiteString, runParser)
import NLP.GenI.Polarity (emptyPolPaths)
import NLP.GenI.Pretty hiding ((<>))
import NLP.GenI.Semantics
import NLP.GenI.Statistics
import NLP.GenI.Tag (TagElem, idname, setTidnums,
tsemantics)
import NLP.GenI.TestSuite (TestCase (..))
import NLP.GenI.TreeSchema
import NLP.GenI.Warning
-- -- DEBUG
-- import Control.Monad.Writer
-- import NLP.GenI.Lexicon
-- import NLP.GenI.LexicalSelection
-- import NLP.GenI.FeatureStructures
-- --------------------------------------------------------------------
-- ProgState
-- --------------------------------------------------------------------
-- | The program state consists of its configuration options and abstract,
-- cleaned up representations of all the data it's had to load into memory
-- (tree schemata files, lexicon files, etc). The intention is for the
-- state to stay static until the next time something triggers some file
-- loading.
data ProgState = ProgState
{ pa :: Params -- ^ the current configuration
, gr :: Macros -- ^ tree schemata
, le :: Lexicon -- ^ lexical entries
, morphinf :: MorphInputFn -- ^ function to extract morphological
-- information from the semantics (you may
-- instead be looking for
-- 'NLP.GenI.Configuration.customMorph')
, traces :: [Text] -- ^ simplified traces (optional)
, customMorph :: Maybe MorphRealiser
}
-- | Note that this affects the geniFlags; we assume the morph flags
-- are not our business
instance HasFlags ProgState where
flags = flags . pa
onFlags f p = p { pa = onFlags f (pa p) }
type ProgStateRef = IORef ProgState
-- | The program state when you start GenI for the very first time
emptyProgState :: Params -> ProgState
emptyProgState args = ProgState
{ pa = args
, gr = []
, le = []
, morphinf = const Nothing
, customMorph = Nothing
, traces = []
}
-- --------------------------------------------------------------------
-- Interface
-- Loading and parsing
-- --------------------------------------------------------------------
-- | We have one master function that loads all the files GenI is expected to
-- use. This just calls the sub-loaders below, some of which are exported
-- for use by the graphical interface. The master function also makes sure
-- to complain intelligently if some of the required files are missing.
loadEverything :: ProgStateRef -> CustomSem sem -> IO()
loadEverything pstRef wrangler = do
pst <- readIORef pstRef
--
let isMissing f = not $ hasFlag f pst
-- grammar type
grammarType = getGrammarType (flags pst)
isNotPreanchored = grammarType /= PreAnchored
isNotPrecompiled = grammarType /= PreCompiled
useTestSuite = isMissing FromStdinFlg
&& isMissing NoLoadTestSuiteFlg
-- display
let errormsg =
concat $ intersperse ", " [ msg | (con, msg) <- errorlst, con ]
errorlst =
[ (isMissing RootFeatureFlg,
"a root feature [empty feature is fine if you are not using polarity filtering]")
, (isNotPrecompiled && isMissing MacrosFlg,
"a tree file")
, (isNotPreanchored && isMissing LexiconFlg,
"a lexicon file")
, (useTestSuite && isMissing TestSuiteFlg,
"a test suite") ]
unless (null errormsg) $ fail ("Please specify: " ++ errormsg)
-- we only have to read in grammars from the simple format
case grammarType of
PreAnchored -> return ()
PreCompiled -> return ()
_ -> loadGeniMacros pstRef >> return ()
-- we don't have to read in the lexicon if it's already pre-anchored
when isNotPreanchored $ loadLexicon pstRef >> return ()
-- in any case, we have to...
loadMorphInfo pstRef
when useTestSuite $ loadTestSuite pst wrangler >> return ()
-- the trace filter file
loadTraces pstRef
-- OT ranking
loadRanking pstRef
-- | The file loading functions all work the same way: we load the file,
-- and try to parse it. If this doesn't work, we just fail in IO, and
-- GenI dies. If we succeed, we update the program state passed in as
-- an IORef.
class Loadable x where
lParse :: FilePath -- ^ source (optional)
-> Text -> Either Text x
lSet :: x -> ProgState -> ProgState
lSummarise :: x -> String
-- | Note that here we assume the input consists of UTF-8 encoded file
lParseFromFile :: Loadable x => FilePath -> IO (Either Text x)
lParseFromFile f = lParse f . T.decodeUtf8 <$> BS.readFile f
-- | Returns the input too (convenient for type checking)
lSetState :: Loadable x => ProgStateRef -> x -> IO x
lSetState pstRef x = modifyIORef pstRef (lSet x) >> return x
-- to be phased out
throwOnParseError :: String -> Either Text x -> IO x
throwOnParseError descr (Left err) = throwIO (BadInputException descr err)
throwOnParseError _ (Right p) = return p
data BadInputException = BadInputException String Text
deriving (Show, Typeable)
instance Exception BadInputException
data L a = Loadable a => L
-- | Load something, exiting GenI if we have not been given the
-- appropriate flag
loadOrDie :: forall f a . (Typeable f, Loadable a)
=> L a
-> (FilePath -> f) -- ^ flag
-> String
-> ProgStateRef
-> IO a
loadOrDie L flg descr pstRef = do
pst <- readIORef pstRef
withFlagOrDie flg pst descr $ \f -> do
v <- verbosity pstRef
x <- withLoadStatus v f descr lSummarise lParseFromFile
>>= throwOnParseError descr
>>= lSetState pstRef
return x
-- | Load something from a string rather than a file
loadFromString :: Loadable a => ProgStateRef
-> String -- ^ description
-> Text -- ^ string to load
-> IO a
loadFromString pstRef descr s =
throwOnParseError descr (lParse "" s) >>= lSetState pstRef
instance Loadable Lexicon where
lParse f =
fmap toLexicon . fromParsec . runParser geniLexicon () f
where
fixEntry = finaliseVars ""
. anonymiseSingletons -- anonymise singletons for performance
. sorter
toLexicon = map fixEntry
sorter l = l { isemantics = (sortByAmbiguity . isemantics) l }
lSet x p = p { le = x }
lSummarise x = show (length x) ++ " lemmas"
instance Loadable Macros where
lParse f = fromParsec . runParser geniMacros () f
lSet x p = p { gr = x }
lSummarise x = show (length x) ++ " schemata"
loadLexicon :: ProgStateRef -> IO Lexicon
loadLexicon = loadOrDie (L :: L Lexicon) LexiconFlg "lexicon"
-- | The macros are stored as a hashing function in the monad.
loadGeniMacros :: ProgStateRef -> IO Macros
loadGeniMacros pstRef = do
pst <- readIORef pstRef
withFlagOrDie MacrosFlg pst descr $ \f -> do
v <- verbosity pstRef
withLoadStatus v f descr lSummarise parse
>>= throwOnParseError "tree schemata"
>>= lSetState pstRef
where
descr = "trees"
parse = parseFromFileMaybeBinary lParseFromFile
-- | Load something, but only if we are configured to do so
loadOptional :: forall f a . (Typeable f, Loadable a)
=> L a
-> (FilePath -> f) -- ^ flag
-> String
-> ProgStateRef
-> IO ()
loadOptional L flg descr pstRef = do
pst <- readIORef pstRef
withFlagOrIgnore flg pst $ \f -> do
v <- verbosity pstRef
x <- withLoadStatus v f descr lSummarise lParseFromFile
>>= throwOnParseError descr
>>= lSetState pstRef
let _ = x :: a
return () -- ignore
newtype MorphFnL = MorphFnL MorphInputFn
instance Loadable MorphFnL where
lParse f = fmap (MorphFnL . readMorph)
. fromParsec
. runParser geniMorphInfo () f
lSet (MorphFnL x) p = p { morphinf = x }
lSummarise _ = "morphinfo"
newtype TracesL = TracesL [Text]
instance Loadable TracesL where
lParse _ = Right . TracesL . T.lines
lSet (TracesL xs) p = p { traces = xs }
lSummarise (TracesL xs) = show (length xs) ++ " traces"
instance Loadable OtRanking where
lParse _ = resultToEither2 . decode . T.unpack
lSet r p = p { pa = (pa p) { ranking = Just r } }
lSummarise _ = "ranking"
loadMorphInfo :: ProgStateRef -> IO ()
loadMorphInfo = loadOptional (L :: L MorphFnL) MorphInfoFlg "morphological info"
loadTraces :: ProgStateRef -> IO ()
loadTraces = loadOptional (L :: L TracesL) TracesFlg "traces"
loadRanking :: ProgStateRef -> IO ()
loadRanking = loadOptional (L :: L OtRanking) RankingConstraintsFlg "OT constraints"
fromParsec :: Either ParseError a -> Either Text a
fromParsec (Left err) = Left . T.pack $ show err
fromParsec (Right a) = Right a
resultToEither2 :: Result a -> Either Text a
resultToEither2 r =
case resultToEither r of
Left e -> Left (T.pack e)
Right x -> Right x
-- Target semantics
--
-- Reading in the target semantics (or test suite) is a little more
-- complicated. It follows the same general schema as above, except
-- that we parse the file twice: once for our internal representation,
-- and once to get a string representation of each test case. The
-- string representation is for the graphical interface; it avoids us
-- figuring out how to pretty-print things because we can assume the
-- user will format it the way s/he wants.
newtype TestSuiteL = TestSuiteL { fromTestSuiteL :: [TestCase SemInput] }
instance Loadable TestSuiteL where
lParse f s = fromParsec $ do
sem <- runParser geniTestSuite () f s
mStrs <- runParser geniTestSuiteString () f s
return $ TestSuiteL (zipWith cleanup sem mStrs)
where
cleanup tc str = tc
{ tcSem = first3 sortSem (tcSem tc)
, tcSemString = str
}
--
lSet (TestSuiteL _) p = p
lSummarise (TestSuiteL x) = show (length x) ++ " cases"
-- |
loadTestSuite :: ProgState -> CustomSem sem -> IO [TestCase sem]
loadTestSuite pst wrangler = do
withFlagOrDie flg pst descr $ \f ->
withLoadStatus v f descr summary pfile
>>= throwOnParseError descr
where
v = hasFlag VerboseModeFlg pst
pfile f = customSuiteParser wrangler f <$> readFileUtf8 f
flg = TestSuiteFlg
descr = "test suite"
summary xs = show (length xs) ++ " test cases"
parseSemInput :: Text -> Either ParseError SemInput
parseSemInput =
fmap smooth . runParser geniSemanticInput () "semantics"
where
smooth (s,r,l) = (sortSem s, sort r, l)
-- Helpers for loading files
withFlag :: forall f a . (Typeable f)
=> (FilePath -> f) -- ^ flag
-> ProgState
-> IO a -- ^ null action
-> (FilePath -> IO a) -- ^ job
-> IO a
withFlag flag pst z job =
maybe z job $ getFlag flag (pa pst)
withFlagOrIgnore :: forall f . (Typeable f)
=> (FilePath -> f) -- ^ flag
-> ProgState
-> (FilePath -> IO ())
-> IO ()
withFlagOrIgnore flag pst = withFlag flag pst (return ())
withFlagOrDie :: forall f a . (Typeable f)
=> (FilePath -> f) -- ^ flag
-> ProgState
-> String
-> (FilePath -> IO a)
-> IO a
withFlagOrDie flag pst description =
withFlag flag pst (fail msg)
where
msg = "Please specify a " ++ description ++ " file!"
withLoadStatus :: Bool -- ^ verbose
-> FilePath -- ^ file to load
-> String -- ^ description
-> (a -> String) -- ^ summary
-> (FilePath -> IO (Either Text a)) -- ^ parsing cmd
-> IO (Either Text a)
withLoadStatus False f _ _ p = p f
withLoadStatus True f d summarise p = do
ePutStr $ unwords [ "Loading", d, f ++ "... " ]
eFlush
mx <- p f
ePutStrLn $ either (const "ERROR") (\x -> summarise x ++ " loaded") mx
return mx
parseFromFileMaybeBinary :: Binary a
=> (FilePath -> IO (Either Text a))
-> FilePath
-> IO (Either Text a)
parseFromFileMaybeBinary p f =
if takeExtension f == ".genib"
then Right <$> decodeFile f
else p f
-- --------------------------------------------------------------------
-- Surface realisation - entry point
-- --------------------------------------------------------------------
-- | 'GeniResults' is the outcome of running GenI on a single input semantics.
-- Each distinct result is returned as a single 'GeniResult' (NB: a single
-- result may expand into multiple strings through morphological
-- post-processing),
data GeniResults = GeniResults
{ grResults :: [GeniResult] -- ^ one per chart item
, grGlobalWarnings :: [Text] -- ^ usually from lexical selection
, grStatistics :: Statistics -- ^ things like number of chart items
-- to help study efficiency
}
data GeniResult = GError GeniError
| GSuccess GeniSuccess
deriving (Ord, Eq)
isSuccess :: GeniResult -> Bool
isSuccess (GSuccess _) = True
isSuccess (GError _) = False
data GeniError = GeniError [Text]
deriving (Ord, Eq)
data GeniSuccess = GeniSuccess
{ grLemmaSentence :: LemmaPlusSentence -- ^ “original” uninflected result
, grRealisations :: [Text] -- ^ results after morphology
, grResultType :: ResultType
, grWarnings :: [Text] -- ^ warnings “local” to this particular
-- item, cf. 'grGlobalWarnings'
, grDerivation :: B.TagDerivation -- ^ derivation tree behind the result
, grOrigin :: Integer -- ^ normally a chart item id
, grLexSelection :: [GeniLexSel] -- ^ the lexical selection behind
-- this result (info only)
, grRanking :: Int -- ^ see 'NLP.GenI.OptimalityTheory'
, grViolations :: [OtViolation] -- ^ which OT constraints were violated
} deriving (Ord, Eq)
data GeniLexSel = GeniLexSel
{ nlTree :: Text
, nlTrace :: [Text]
} deriving (Ord, Eq)
data ResultType = CompleteResult | PartialResult deriving (Ord, Eq)
instance Pretty GeniError where
pretty (GeniError xs) = T.intercalate "\n" $ map ("Error:" <+>) xs
-- | Entry point! (the most useful function to know here)
--
-- * Initialises the realiser (lexical selection, among other things),
--
-- * Runs the builder (the surface realisation engine proper)
--
-- * Unpacks the builder results
--
-- * Finalises the results (morphological generation)
--
-- In addition to the results, this returns a generator state. The latter is
-- is mostly useful for debugging via the graphical interface.
-- Note that we assumes that you have already loaded in your grammar and
-- parsed your input semantics.
runGeni :: ProgState
-> CustomSem sem
-> B.Builder st it
-> TestCase sem
-> ExceptT String IO (GeniResults,st)
runGeni pst selector builder tc = do
-- step 1: lexical selection
istuff <- initGeni pst selector semInput
-- steps 2 to 4
liftIO $ runBuilder istuff
where
iflags = flags $ case tcParams tc of
Nothing -> pa pst
Just new -> updateParams new (pa pst)
semInput = tcSem tc
runBuilder (initStuff, initWarns) = do
let run = B.run builder
--force evaluation before measuring start time to avoid including grammar/lexicon parsing.
start <- rnf initStuff `seq` getCPUTime
-- step 2: chart generation
let (finalSt, stats) = run initStuff iflags
-- step 3: unpacking and
-- step 4: post-processing
results <- extractResults pst (tcParams tc) builder finalSt
--force evaluation before measuring end time to account for all the work that should be done.
end <- rnf results `seq` getCPUTime
let elapsedTime = picosToMillis $! end - start
diff = round (elapsedTime :: Double) :: Int
stats2 = updateMetrics (incrIntMetric "gen_time" (fromIntegral diff) ) stats
gresults = GeniResults { grResults = results
, grStatistics = stats2
, grGlobalWarnings = map showWarnings (fromGeniWarnings initWarns)
}
return (gresults, finalSt)
showWarnings = T.intercalate "\n" . showGeniWarning
-- | @simplifyResults <$> runGenI...'@ for an easier time if you don't need the
-- surface realiser state
simplifyResults :: Either String (GeniResults, st) -> GeniResults
simplifyResults (Left t) = GeniResults
{ grResults = [GError $ GeniError [T.pack t]]
, grGlobalWarnings = []
, grStatistics = emptyStats
}
simplifyResults (Right (r,_)) = r
-- | This is a helper to 'runGenI'. It's mainly useful if you are building
-- interactive GenI debugging tools.
--
-- Given a builder state,
--
-- * Unpacks the builder results
--
-- * Finalises the results (morphological generation)
extractResults :: ProgState
-> Maybe Params -- ^ test-case-specific parameters
-> B.Builder st it
-> st
-> IO [GeniResult]
extractResults pst newPa builder finalSt = do
-- step 3: unpacking
let uninflected = B.unpack builder finalSt
(rawResults, resultTy) =
if null uninflected && hasFlag PartialFlg pst
then (B.partial builder finalSt, PartialResult)
else (uninflected , CompleteResult)
status = B.finished builder finalSt
-- step 4: post-processing
debugM logname $ "tree assembly status: " ++ prettyStr status
finaliseResults pst newPa (resultTy, status, rawResults)
-- --------------------------------------------------------------------
-- Surface realisation - sub steps
-- --------------------------------------------------------------------
-- | 'initGeni' performs lexical selection and strips the input semantics of
-- any morpohological literals
--
-- See 'defaultCustomSem'
initGeni :: ProgState
-> CustomSem sem
-> sem
-> ExceptT String IO (B.Input, GeniWarnings)
initGeni pst wrangler csem = do
-- lexical selection
selection <- runLexSelection pst wrangler csem
liftIO $ debugM logname $
"lexical selection returned " ++
(show . length $ lsAnchored selection) ++
" anchored trees"
semInput <- either (throwError . T.unpack) return $ fromCustomSemInput wrangler csem
let initStuff = B.Input
{ B.inSemInput = semInput
, B.inLex = lsLexEntries selection
, B.inCands = map (\c -> (c, emptyPolPaths)) (lsAnchored selection)
}
return (initStuff, lsWarnings selection)
-- | 'finaliseResults' does any post-processing steps that we want to integrate
-- into mainline GenI. So far, this consists of morphological realisation and
-- OT ranking
finaliseResults :: ProgState
-> Maybe Params -- ^ test-case-specific parameters
-> (ResultType, B.GenStatus, [B.Output])
-> IO [GeniResult]
finaliseResults pst newPa (ty, status, os) = do
debugM logname $ "finalising " ++ show (length sentences) ++ " results"
-- morph TODO: make this a bit safer
mss <- case (getFlag MorphCmdFlg pst, customMorph pst) of
(Just cmd, _) -> map snd <$> inflectSentencesUsingCmd cmd sentences
(_, Just morph) -> return $ morph (morphFlags config) sentences
(Nothing, Nothing) -> return $ map sansMorph sentences
-- OT ranking
let unranked = zipWith sansRanking os mss
rank = rankResults (getTraces pst) grDerivation (getRanking config)
successes = map addRanking (rank unranked)
failures = case status of
B.Error str -> [GeniError [str]]
B.Finished -> []
B.Active -> []
return (map GError failures ++ map GSuccess successes)
where
config = case newPa of
Nothing -> pa pst
Just pa2 -> updateParams pa2 (pa pst)
sentences = map snd3 os
sansRanking (i,l,d) rs = GeniSuccess
{ grLemmaSentence = l
, grRealisations = moRealisations rs
, grWarnings = moWarnings rs
, grDerivation = d
, grLexSelection = map (\x -> GeniLexSel x (getTraces pst x)) (B.lexicalSelection d)
, grRanking = -1
, grViolations = []
, grResultType = ty
, grOrigin = i
}
addRanking (i,res,vs) = res { grViolations = vs, grRanking = i }
-- --------------------------------------------------------------------
-- Displaying results
-- --------------------------------------------------------------------
-- | Show the sentences produced by the generator, in a relatively compact form
showRealisations :: [String] -> String
showRealisations [] = "(none)"
showRealisations xs = unlines . map sho . Map.toList . histogram $ xs
where
sho (x,1) = x
sho (x,c) = x ++ " (" ++ show c ++ " instances)"
-- | No morphology! Pretend the lemma string is a sentence
lemmaSentenceString :: GeniSuccess -> Text
lemmaSentenceString = T.unwords . map lpLemma . grLemmaSentence
prettyResult :: ProgState -> GeniSuccess -> Text
prettyResult pst nr =
T.intercalate "\n" . map showOne . grRealisations $ nr
where
showOne str = pretty theRanking <> ". " <> str <> "\n" <> violations
violations = prettyViolations tracesFn verbose (grViolations nr)
theRanking = grRanking nr
verbose = hasFlag VerboseModeFlg pst
tracesFn = getTraces pst
-- | 'getTraces' is most likely useful for grammars produced by a
-- metagrammar system. Given a tree name, we retrieve the ``trace''
-- information from the grammar for all trees that have this name. We
-- assume the tree name was constructed by GenI; see the source code for
-- details.
getTraces :: ProgState -> Text -> [Text]
getTraces pst tname =
filt $ concat [ ptrace t | t <- gr pst, pidname t == readPidname tname ]
where
filt = case traces pst of
[] -> id
theTs -> filter (`elem` theTs)
-- | We assume the name was constructed by 'combineName'
readPidname :: Text -> Text
readPidname n =
case T.splitOn ":" n of
(_:_:p:_) -> p
_ -> geniBug "NLP.GenI.readPidname or combineName are broken"
-- --------------------------------------------------------------------
-- Lexical selection
-- --------------------------------------------------------------------
-- | Runs the lexical selection (be it the standard GenI version or
-- a custom function supplied by a user) and runs the results
-- through the universal 'finaliseLexSelection'.
--
-- Also hunts for some warning conditions
runLexSelection :: ProgState
-> CustomSem sem -- ^ handler for custom semantics
-> sem -- ^ semantics
-> ExceptT String IO LexicalSelection
runLexSelection pst wrangler csem = do
let verbose = hasFlag VerboseModeFlg pst
selector = customSelector wrangler
-- perform lexical selection
selection <- liftIO $ selector (gr pst) (le pst) csem
-- finalise selection
sem@(tsem, _, _) <- either (throwError . T.unpack) return $ fromCustomSemInput wrangler csem
let lexCand = lsLexEntries selection
candFinal = finaliseLexSelection (morphinf pst) sem (lsAnchored selection)
-- status
when verbose $ liftIO $ T.hPutStrLn stderr . T.unlines $
"Lexical items selected:"
: map (indent . showLexeme . fromFL . iword) lexCand
++ ["Trees anchored (family) :"]
++ map (indent . idname) candFinal
-- warnings
let semWarnings = case missingLiterals candFinal tsem of
[] -> []
xs -> [NoLexSelection xs]
return $ selection { lsAnchored = candFinal
, lsWarnings = mkGeniWarnings semWarnings <> lsWarnings selection
}
where
indent x = ' ' `T.cons` x
-- | Standard GenI semantics and lexical selection algorithm
-- (with optional "preanchored" mode)
defaultCustomSem :: ProgState -> IO (CustomSem SemInput)
defaultCustomSem pst = mkDefaultCustomSem pst <$>
case grammarType of
PreAnchored -> mkPreAnchoredLexicalSelector pst
_ -> return defaultLexicalSelector
where
grammarType = getGrammarType $ geniFlags . pa $ pst
mkDefaultCustomSem :: ProgState
-> LexicalSelector SemInput
-> CustomSem SemInput
mkDefaultCustomSem pst selector = CustomSem
{ fromCustomSemInput = Right
, customSelector = \t l s -> selector t l (tweakSem s)
, customRenderSem = geniShowText
, customSemParser = \t ->
trivialTestCase t <$> (fromParsec . parseSemInput) t
, customSuiteParser = \f -> fmap fromTestSuiteL . lParse f
}
where
trivialTestCase t s = TestCase
{ tcName = "(sem)"
, tcSemString = t
, tcSem = s
, tcExpected = []
, tcParams = Nothing
}
tweakSem = stripMorphStuff . maybeRemoveConstraints
stripMorphStuff = first3 (stripMorphSem (morphinf pst))
-- disable constraints if the NoConstraintsFlg pessimisation is active
maybeRemoveConstraints =
if hasOpt NoConstraints (geniFlags (pa pst)) then removeConstraints else id
-- | @missingLiterals ts sem@ returns any literals in @sem@ that do not
-- appear in any of the @ts@ trees
missingLiterals :: [TagElem] -> [Literal GeniVal] -> [Literal GeniVal]
missingLiterals cands tsem =
tsem \\ (nub $ concatMap tsemantics cands)
-- | Post-processes lexical selection results to things which
-- GenI considers universal. No matter what custom
-- lexical selection mechanism you supply, these preflight
-- checks will run.
--
-- * attaches morphological information to trees
--
-- * filters out any elementary tree whose semantics contains
-- things that are not in the input semantics
finaliseLexSelection :: MorphInputFn -> SemInput -> [TagElem] -> [TagElem]
finaliseLexSelection morph (tsem,_,_) =
setTidnums . considerCoherency . considerMorph
where
-- attach any morphological information to the candidates
considerMorph = attachMorph morph tsem
-- filter out candidates whose semantics has bonus stuff which does
-- not occur in the input semantics
considerCoherency = filter (all (`elem` tsem) . tsemantics)
-- --------------------------------------------------------------------
-- Pre-selection and pre-anchoring
-- --------------------------------------------------------------------
newtype PreAnchoredL = PreAnchoredL [TagElem]
instance Loadable PreAnchoredL where
lParse f = fmap PreAnchoredL
. fromParsec
. runParser geniTagElems () f
lSet _ p = p -- this does not update prog state at all
lSummarise (PreAnchoredL xs) = show (length xs) ++ " trees"
readPreAnchored :: ProgState -> IO [TagElem]
readPreAnchored pst = withFlagOrDie flg pst descr $ \f -> do
x <- withLoadStatus v f descr lSummarise lParseFromFile
>>= throwOnParseError descr
let PreAnchoredL xs = x
return xs
where
v = hasFlag VerboseModeFlg pst
flg = MacrosFlg
descr = "preanchored trees"
mkPreAnchoredLexicalSelector :: ProgState -> IO (LexicalSelector SemInput)
mkPreAnchoredLexicalSelector pst = do
xs <- readPreAnchored pst
return (\_ _ _ -> return (LexicalSelection xs [] mempty))
-- --------------------------------------------------------------------
-- Boring utility code
-- --------------------------------------------------------------------
readFileUtf8 :: FilePath -> IO Text
readFileUtf8 f = T.decodeUtf8 <$> BS.readFile f
verbosity :: ProgStateRef -> IO Bool
verbosity = fmap (hasFlag VerboseModeFlg)
. readIORef
instance JSON GeniResults where
readJSON j = do
jo <- fromJSObject `fmap` readJSON j
let field x = maybe (fail $ "Could not find: " ++ x) readJSON
$ lookup x jo
GeniResults <$> field "results"
<*> field "warnings"
<*> field "statistics"
showJSON x = JSObject . toJSObject $
[ ("results", showJSONs $ grResults x)
, ("warnings", showJSONs $ grGlobalWarnings x)
, ("statistics", showJSON $ grStatistics x)
]
instance JSON GeniResult where
readJSON j =
case readJSON j of
Ok s -> Ok (GSuccess s)
Error _ -> GError `fmap` readJSON j
showJSON (GSuccess x) = showJSON x
showJSON (GError x) = showJSON x
instance JSON GeniSuccess where
readJSON j = do
jo <- fromJSObject `fmap` readJSON j
let field x = maybe (fail $ "Could not find: " ++ x) readJSON
$ lookup x jo
GeniSuccess <$> field "raw"
<*> field "realisations"
<*> field "result-type"
<*> field "warnings"
<*> field "derivation"
<*> field "chart-item"
<*> field "lexical-selection"
<*> field "ranking"
<*> field "violations"
showJSON nr = JSObject . toJSObject $
[ ("raw" , showJSON $ grLemmaSentence nr)
, ("realisations" , showJSONs $ grRealisations nr)
, ("derivation" , showJSONs $ grDerivation nr)
, ("lexical-selection", showJSONs $ grLexSelection nr)
, ("ranking" , showJSON $ grRanking nr)
, ("violations" , showJSONs $ grViolations nr)
, ("result-type" , showJSON $ grResultType nr)
, ("chart-item" , showJSON $ grOrigin nr)
, ("warnings" , showJSONs $ grWarnings nr)
]
instance JSON GeniError where
readJSON j = do
jo <- fromJSObject <$> readJSON j
let field x = maybe (fail $ "Could not find: " ++ x) readJSON
$ lookup x jo
GeniError <$> field "errors"
showJSON (GeniError xs) =
JSObject . toJSObject $ [ ("errors", showJSON xs) ]
instance JSON ResultType where
readJSON j = do
js <- fromJSString `fmap` readJSON j
case js of
"partial" -> return PartialResult
"complete" -> return CompleteResult
ty -> fail $ "unknown result type: " ++ ty
showJSON CompleteResult = JSString $ toJSString "complete"
showJSON PartialResult = JSString $ toJSString "partial"
instance JSON GeniLexSel where
readJSON j = do
jo <- fromJSObject `fmap` readJSON j
let field x = maybe (fail $ "Could not find: " ++ x) readJSON
$ lookup x jo
GeniLexSel <$> field "lex-item"
<*> field "trace"
showJSON x = JSObject . toJSObject $
[ ("lex-item", showJSON $ nlTree x)
, ("trace", showJSONs $ nlTrace x)
]
-- Converts picoseconds to milliseconds.
picosToMillis :: Integer -> Double
picosToMillis t = realToFrac t / (10^(9 :: Int))
data MNAME = MNAME deriving Typeable
logname :: String
logname = mkLogname MNAME
{-!
deriving instance NFData GeniResult
deriving instance NFData GeniSuccess
deriving instance NFData GeniError
deriving instance NFData ResultType
deriving instance NFData GeniLexSel
!-}
-- GENERATED START
instance NFData GeniResult where
rnf (GError x1) = rnf x1 `seq` ()
rnf (GSuccess x1) = rnf x1 `seq` ()
instance NFData GeniSuccess where
rnf (GeniSuccess x1 x2 x3 x4 x5 x6 x7 x8 x9)
= rnf x1 `seq`
rnf x2 `seq`
rnf x3 `seq`
rnf x4 `seq`
rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()
instance NFData GeniError where
rnf (GeniError x1) = rnf x1 `seq` ()
instance NFData ResultType where
rnf CompleteResult = ()
rnf PartialResult = ()
instance NFData GeniLexSel where
rnf (GeniLexSel x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
-- GENERATED STOP