GenI 0.22.0.1 → 0.24

raw patch · 48 files changed

+2998/−2074 lines, 48 filesdep +errorsdep +transformersdep −MaybeTdep −utf8-stringdep ~QuickCheckdep ~bytestringdep ~hsloggerPVP ok

version bump matches the API change (PVP)

Dependencies added: errors, transformers

Dependencies removed: MaybeT, utf8-string

Dependency ranges changed: QuickCheck, bytestring, hslogger, mtl, parsec, test-framework-hunit, test-framework-quickcheck2, time

API changes (from Hackage documentation)

Files

• GenI.cabal +25/−19
• INSTALL +0/−20
• NEWS +32/−0
• README +0/−27
• README.markdown +58/−0
• examples/artificial/lexicon +5/−0
• examples/artificial/suite +2/−0
• examples/artificial/suite-bad +3/−0
• examples/artificial/trees +10/−0
• examples/demo/trees +3/−3
• examples/promettre/trees +1/−1
• geni-test/NLP/GenI/Test.hs +15/−1
• src/Data/FullList.hs +2/−2
• src/Data/FullList/Internal.hs +5/−5
• src/NLP/GenI.hs +468/−385
• src/NLP/GenI/Automaton.hs +8/−8
• src/NLP/GenI/Builder.hs +178/−161
• src/NLP/GenI/Configuration.hs +88/−126
• src/NLP/GenI/Console.hs +153/−142
• src/NLP/GenI/Control.hs +51/−0
• src/NLP/GenI/ErrorIO.hs +18/−0
• src/NLP/GenI/FeatureStructure.hs +55/−25
• src/NLP/GenI/Flag.hs +112/−35
• src/NLP/GenI/General.hs +51/−29
• src/NLP/GenI/GeniShow.hs +8/−7
• src/NLP/GenI/GeniVal.hs +11/−7
• src/NLP/GenI/GeniVal/Internal.hs +164/−77
• src/NLP/GenI/LexicalSelection.hs +253/−181
• src/NLP/GenI/LexicalSelection/Types.hs +8/−8
• src/NLP/GenI/Lexicon.hs +7/−1
• src/NLP/GenI/Lexicon/Internal.hs +40/−30
• src/NLP/GenI/Main.hs +34/−30
• src/NLP/GenI/Morphology.hs +91/−42
• src/NLP/GenI/Morphology/Types.hs +12/−43
• src/NLP/GenI/OptimalityTheory.hs +17/−16
• src/NLP/GenI/Parser.hs +97/−85
• src/NLP/GenI/Polarity.hs +139/−111
• src/NLP/GenI/Polarity/Internal.hs +24/−24
• src/NLP/GenI/Polarity/Types.hs +11/−11
• src/NLP/GenI/Pretty.hs +30/−9
• src/NLP/GenI/Semantics.hs +121/−65
• src/NLP/GenI/Simple/SimpleBuilder.hs +394/−227
• src/NLP/GenI/Statistics.hs +12/−3
• src/NLP/GenI/Tag.hs +72/−66
• src/NLP/GenI/TestSuite.hs +13/−11
• src/NLP/GenI/TreeSchema.hs +79/−15
• src/NLP/GenI/Warning.hs +1/−1
• src/NLP/GenI/Warning/Internal.hs +17/−15

@@ -1,5 +1,5 @@ Name:           GenI-Version:        0.22.0.1+Version:        0.24 License:        GPL License-file:   LICENSE Author:         Carlos Areces and Eric Kow@@ -9,8 +9,8 @@ Homepage:       http://projects.haskell.org/GenI Maintainer:     geni-users@loria.fr Build-Type:     Simple-Cabal-Version: >=1.8-data-files: AUTHORS, INSTALL, README, NEWS, GenI.cabal,+Cabal-Version: >=1.14+data-files: AUTHORS, README.markdown, NEWS, GenI.cabal,             examples/artificial/lexicon,             examples/artificial/trees,             examples/artificial/suite,@@ -50,7 +50,7 @@  source-repository head   type:     darcs-  location: http://code.haskell.org/GenI+  location: http://hub.darcs.net/kowey/GenI  Flag static   Description: Build a static binary@@ -59,25 +59,25 @@ Library   Build-depends: base >= 4 && < 5                , binary >= 0.5.0.2-               , bytestring  == 0.9.*+               , bytestring                , cabal-macosx  >= 0.1.2 && < 0.3                , containers >= 0.1                , deepseq                , directory   > 1+               , errors                , filepath    == 1.*-               , hslogger == 1.1.*+               , hslogger                , json >= 0.4.3 && < 0.6-               , MaybeT == 0.1.*-               , mtl > 1.0 && < 2.1+               , mtl > 1.0                , old-locale                , ordered == 0.1.*-               , parsec >= 2 && < 3.2+               , parsec >= 2                , process > 1                , split >= 0.1.1 && < 0.2                , syb                , text-               , time >= 1.1 && < 1.3-               , utf8-string >= 0.3.5 && < 0.4+               , time >= 1.1+               , transformers                , yaml-light  == 0.1.*    if flag(static)@@ -87,7 +87,10 @@                 BoolExp,                 Data.FullList.Internal,                 Data.FullList,+                NLP.GenI.Configuration,                 NLP.GenI.Console,+                NLP.GenI.Control,+                NLP.GenI.ErrorIO,                 NLP.GenI.FeatureStructure,                 NLP.GenI.Flag,                 NLP.GenI.General,@@ -117,11 +120,11 @@                 NLP.GenI.Statistics,                 NLP.GenI.Builder,                 NLP.GenI.Simple.SimpleBuilder,-                NLP.GenI.Configuration,                 NLP.GenI   Other-Modules:                 Paths_GenI +  Default-language: Haskell2010   Hs-Source-Dirs: src   Ghc-options:    -Wall   Ghc-prof-options: -auto-all@@ -129,38 +132,41 @@ Executable     geni  Main-Is:        geni.hs  Hs-Source-Dirs: geni-+ Default-language: Haskell2010  Ghc-options:    -Wall -rtsopts  Ghc-prof-options: -auto-all  Build-Depends: base >= 4 && < 5               , GenI               , containers  >= 0.1               , directory   > 1+              , errors               , filepath    == 1.*               , yaml-light  == 0.1.*-              , hslogger    == 1.1.*+              , hslogger               , json        >= 0.4 && < 0.6-              , mtl         > 1.0 && < 2.1+              , mtl         > 1.0               , process     > 1               , split       == 0.1.*-              , utf8-string == 0.3.*  Test-Suite geni-test  Type:          exitcode-stdio-1.0  Main-Is:       MainTest.hs  Hs-Source-Dirs: geni-test+ Default-language: Haskell2010  Build-Depends:    GenI                  , base >= 4 && < 5                  , containers  >= 0.1+                 , errors                  , filepath   == 1.*                  , json                  , mtl                  , parsec >= 2 && < 3.2-                 , QuickCheck == 2.4.*+                 , QuickCheck                  , smallcheck                  , HUnit > 1 && < 1.3-                 , test-framework-hunit >= 0.2.4 && < 0.3-                 , test-framework-quickcheck2 >= 0.2.4 && < 0.3+                 , test-framework-hunit+                 , test-framework-quickcheck2                  , test-framework-smallcheck                  , test-framework > 0.3                  , text+                 , transformers

@@ -1,20 +0,0 @@-Requirements-------------- * Haskell Platform 2011.3.0.0--GUI requirements------------------Only needed if you want the graphical interface:- * wxWidgets 2.8- * wxHaskell- * Graphviz--Building GenI----------------1. obtain cabal-install-2. run: cabal install-3. if you want the graphical interface, try-    cabal install ./geni-gui-   but ONLY AFTER you succeed in installing the text version :-)--For more details, see http://projects.haskell.org/GenI

@@ -1,3 +1,35 @@+GenI 0.24, 18 Sep 2013+----------------------+Note that the changes between this release and 0.20 are considered to be under+the BSD3 license.  GenI overall remains dual-licensed under the GPL and any+commercial-use terms you may wish to negotiate with INRIA. Having secured the+rights to use GenI 0.20, you may freely use GenI 0.24 in a similar fashion.++CHANGES TO WATCH OUT FOR++* Server/GUI changes: Semantic input must be full input.+  - Before: `foo(x) bar(y z)`+  - After:  `semantics:[foo(x) bar(y z)]`+* Customisable semantics : now you can accept any arbitrary+  input for which you can define a mapping to a GenI-style test case+* API change: the custom semantics argument is mandatory+* More extensive documentation++GUI++* Visual distinction between explicit null adjunction constraints+  (marked NA) and constraints inserted by GenI (marked INA)+* Bugfixes (now retains show-feature state across debugger steps)+* More informative top/bot unification failure diagnostics in the+  trash++GENERAL++* New "guided realisation" optimisation (focus on one polarity+  path at a time)+* Fixed errors where top/bottom unification wasn't being done+* Builds with haskell-platform 2013.2.0.0+ GenI 0.22, 14 Apr 2012 ---------------------- Note that the changes between this release and 0.20 are considered to be under

@@ -1,27 +0,0 @@-Documentation---------------1. users manual: -     http://projects.haskell.org/GenI/manual-2. API:-     http://projects.haskell.org/GenI/api-doc--Installing GenI-----------------(tested on Linux, Windows, and MacOS X)--see INSTALL for details (should just be cabal install)--Development-------------The code style has evolved a lot.  Sorry for the inconsistency.-As of 2012-05-06, I'm trying to move to a published style guide-so I can stop thinking about it--  https://github.com/tibbe/haskell-style-guide--But the code will take a long time to catch up--Contact us!-------------Please let us know if you are using GenI; we'd like to hear about your-experiences, both positive and negative.

@@ -0,0 +1,58 @@+[![Build Status](https://secure.travis-ci.org/kowey/GenI.png)](http://travis-ci.org/kowey/GenI)++# Documentation++1. [homepage][homepage] and [wiki][wiki]+2. [manual][manual]+3. [API][API]++# Installing GenI++(tested on Linux, Windows, and MacOS X)++Install the basic version first++    cabal install++Try installing the graphical interface++    cabal install ./geni-gui++You may run into some trouble with wxHaskell.+Get in touch if that's the case.++# Development++* [Darcs (MAIN)][geni-darcs] or [Git (mirror)][geni-github]+* [Issue tracker][issues]++I accept Darcs patches and GitHub pull requests.+The Darcs repository might be a bit ahead of the Git one,+but I'll try to keep the mirror up to date.++## Style++Please follow [published style guide][style].+There is quite a bit of old code that does not follow this.+Sorry. I'm slowly working on transitioning it.++## Versions++* Stable version has even minor number  (eg. 0.22.x)+* Development version has odd minor number (eg 0.23.yyyymmdd)+  Sometimes with a datestamp for major API changes in between+* NEWS file will probably mention the next release (eg. 0.24)++# Contact us!++Please let us know if you are using GenI; we'd like to hear about your+experiences, both positive and negative.++[API]:          http://kowey.github.com/GenI/api-doc+[geni-darcs]:   http://hub.darcs.net/kowey/GenI+[geni-github]:  https://github.com/kowey/GenI+[homepage]:     http://kowey.github.com/GenI+[issues]:       https://github.com/kowey/GenI/issues+[manual]:       http://kowey.github.com/GenI/manual+[style]:        https://github.com/tibbe/haskell-style-guide+[wiki]:         https://kowey.github.com/GenI/wiki

@@ -62,3 +62,8 @@  disjunction disjunction(x y z) semantics:[disjunction()] variablecat variablecat(x y z) semantics:[variablecat()]++interface-unification interface-unification (!x:z y:y) semantics:[interface()]++trace-good tr-good () semantics:[trace()]+trace-bad  tr-bad  () semantics:[trace()]

@@ -32,3 +32,5 @@ preterminal semantics:[preterminal()] disjunction semantics:[disjunction()] variablecat semantics:[variablecat()]++trace-good semantics:[trace()[T1]]

@@ -11,3 +11,6 @@  tb-unification-na-bad semantics:[tb-unification-na(bad)] tb-unification-anchor-bad semantics:[tb-unification-anchor(bad)]++interface-unification semantics:[interface()]+trace-bad  semantics:[trace()[T2]]

@@ -148,3 +148,13 @@ variablecat(?X ?Y ?Z) initial X anchor [cat:_ x:?X y:?Y z:?Z foo:?X/x|y|z;?Z;a]![] +interface-unification(!x:x y:y) initial+X anchor [cat:x]![]++tr-good() initial+X anchor [cat:x]![]+trace:[T1]++tr-bad() initial+X anchor [cat:x]![cat:y]+trace:[T2]

@@ -127,9 +127,9 @@         n7[cat:sp idx:?Z ]![]         { n8[cat:prep]![]           {-            n9 type:lex "a"+            n9x type:lex "a"           }-          n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_+          n10x type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_             det:_ qu:_]          }       n9[cat:p]![]@@ -319,7 +319,7 @@       n7[cat:p idx:?E]![]       {         n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ]-          n9 anchor [cat:v idx:?E]![cat:p idx:?E]+          n9x anchor [cat:v idx:?E]![cat:p idx:?E]       }       n9[cat:p]![]       {n10[cat:prep]![]

@@ -281,7 +281,7 @@     n7[cat:p idx:?E]![]     {       n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X  qu:minus]-      n9 type:anchor [cat:v idx:?E]![cat:p idx:?E]+      n9x type:anchor [cat:v idx:?E]![cat:p idx:?E]     }     n9[cat:p]![]     {n10[cat:prep]![]

@@ -19,7 +19,9 @@  module NLP.GenI.Test where +import Control.Applicative import Data.List ( isPrefixOf )+import Data.Maybe import System.Environment ( getArgs )  import Test.Framework@@ -39,7 +41,10 @@ runTests = do     args <- filter (not . (`isPrefixOf` "--unit-tests")) `fmap` getArgs     funcSuite <- NLP.GenI.Regression.mkSuite-    flip defaultMainWithArgs args+    opts_ <- interpretArgsOrExit args+    let topts = fromMaybe emptyOptions (ropt_test_options opts_)+        opts  = opts_ { ropt_test_options = Just $ setMaxTests 25 topts }+    flip defaultMainWithOpts opts         [ NLP.GenI.Test.GeniVal.suite         , NLP.GenI.Test.Parser.suite         , NLP.GenI.Test.FeatureStructure.suite@@ -51,3 +56,12 @@         , NLP.GenI.Test.Simple.SimpleBuilder.suite         , funcSuite         ]++setMaxTests :: Int -> TestOptions -> TestOptions+setMaxTests m opts =+    case topt_maximum_generated_tests opts of+        Nothing -> opts { topt_maximum_generated_tests = Just m }+        Just _  -> opts++emptyOptions :: TestOptions+emptyOptions = TestOptions Nothing Nothing Nothing Nothing Nothing Nothing

@@ -10,5 +10,5 @@     Listable (..)     ) where -import Data.FullList.Internal-import Prelude hiding ( head, tail, (++) )+import           Data.FullList.Internal+import           Prelude                hiding (head, tail, (++))

@@ -5,12 +5,12 @@  module Data.FullList.Internal where -import Data.Binary-import Control.DeepSeq-import Prelude hiding (head, tail, (++))+import           Control.DeepSeq+import           Data.Binary+import           Data.Data+import           Data.List       (nub, sort)+import           Prelude         hiding (head, tail, (++)) import qualified Prelude-import Data.Data-import Data.List ( sort, nub )  newtype FullList a = FullList [a]  -- data constructor is not exported!   deriving (Eq, Ord, Show, Data, Typeable)

@@ -15,10 +15,12 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# 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@@ -31,7 +33,7 @@              LexicalSelector,               -- ** Running GenI-             runGeni,+             runGeni, simplifyResults, defaultCustomSem,              GeniResults(..),              GeniResult(..), isSuccess, GeniError(..), GeniSuccess(..),              GeniLexSel(..),@@ -54,66 +56,55 @@              ) where --import Control.Applicative ((<$>),(<*>))-import Control.DeepSeq-import Control.Exception-import Control.Monad.Error-import Data.Binary (Binary, decodeFile)-import Data.IORef (IORef, readIORef, modifyIORef)-import Data.List-import Data.Maybe (fromMaybe)-import Data.Monoid ( mappend, mempty )-import Data.Text ( Text )-import Data.Typeable (Typeable)-import System.CPUTime( getCPUTime )-import System.IO ( stderr )-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.IO as T+import           Control.Applicative       ((<$>), (<*>))+import           Control.DeepSeq+import           Control.Exception+import           Control.Monad.Error+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 Text.JSON-import qualified System.IO.UTF8 as UTF8+import           Data.FullList             (fromFL)+import           System.Log.Logger         (debugM)+import           Text.JSON -import NLP.GenI.Configuration-    ( Params, customMorph, customSelector-    , getFlagP, hasFlagP, hasOpt, Optimisation(NoConstraints)-    , MacrosFlg(..), LexiconFlg(..), TestSuiteFlg(..)-    , MorphInfoFlg(..), MorphCmdFlg(..)-    , RankingConstraintsFlg(..)-    , PartialFlg(..)-    , FromStdinFlg(..), VerboseModeFlg(..)-    , NoLoadTestSuiteFlg(..)-    , RootFeatureFlg(..)-    , TracesFlg(..)-    , grammarType-    , GrammarType(..)-    )-import NLP.GenI.General-    ( histogram, geniBug, snd3, first3, ePutStr, ePutStrLn, eFlush,-    -- mkLogname,-    )-import NLP.GenI.GeniVal-import NLP.GenI.LexicalSelection ( LexicalSelector, LexicalSelection(..), defaultLexicalSelector )-import NLP.GenI.Lexicon-import NLP.GenI.Morphology-import NLP.GenI.OptimalityTheory-import NLP.GenI.Parser (geniMacros, geniTagElems,-                    geniLexicon, geniTestSuite,-                    geniTestSuiteString, geniSemanticInput,-                    geniMorphInfo,-                    runParser,-                    ParseError,-                    )-import NLP.GenI.Pretty-import NLP.GenI.Semantics-import NLP.GenI.Statistics-import NLP.GenI.Tag ( TagElem, idname, tsemantics, ttrace, setTidnums )-import NLP.GenI.TestSuite ( TestCase(..) )-import NLP.GenI.TreeSchema-import NLP.GenI.Warning-import qualified NLP.GenI.Builder as B+import qualified NLP.GenI.Builder          as B+import           NLP.GenI.Configuration+import           NLP.GenI.ErrorIO+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@@ -138,10 +129,16 @@                                -- information from the semantics (you may                                -- instead be looking for                                -- 'NLP.GenI.Configuration.customMorph')-    , ranking  :: OtRanking -- ^ OT constraints    (optional)     , 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@@ -151,8 +148,8 @@     , gr = []     , le = []     , morphinf = const Nothing+    , customMorph = Nothing     , traces = []-    , ranking = []     }  -- --------------------------------------------------------------------@@ -164,70 +161,69 @@ --   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 -> IO() -loadEverything pstRef =-  do pst <- readIORef pstRef-     ---     let config   = pa pst-         isMissing f = not $ hasFlagP f config-     -- grammar type-         isNotPreanchored = grammarType config /= PreAnchored-         isNotPrecompiled = grammarType config /= 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 config 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 pstRef >> return ()-     -- the trace filter file-     loadTraces pstRef-     -- OT ranking-     loadRanking pstRef-+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)-               -> String -> Either ParseError x-  lSet         :: x -> ProgState -> ProgState-  lSummarise   :: x -> String+    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 ParseError x)-lParseFromFile f = lParse f `fmap` UTF8.readFile f+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 ParseError x -> IO x+throwOnParseError :: String -> Either Text x -> IO x throwOnParseError descr (Left err) = throwIO (BadInputException descr err) throwOnParseError _ (Right p)  = return p -data BadInputException = BadInputException String ParseError+data BadInputException = BadInputException String Text   deriving (Show, Typeable)  instance Exception BadInputException@@ -242,50 +238,55 @@           -> String           -> ProgStateRef           -> IO a-loadOrDie L flg descr pstRef =-  withFlagOrDie flg pstRef descr $ \f -> do-   v <- verbosity pstRef-   x <- withLoadStatus v f descr lParseFromFile-     >>= throwOnParseError descr-     >>= lSetState pstRef-   return x+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-               -> String -- ^ string to load+               -> Text   -- ^ string to load                -> IO a loadFromString pstRef descr s =-  throwOnParseError descr (lParse "" s) >>= lSetState pstRef+    throwOnParseError descr (lParse "" s) >>= lSetState pstRef  instance Loadable Lexicon where-  lParse f = fmap toLexicon . runParser geniLexicon () f-    where-     fixEntry  = finaliseVars "" -- 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"+    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 = runParser geniMacros () f-  lSet x p = p { gr = x }-  lSummarise x = show (length x) ++ " schemata"+    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 =-  withFlagOrDie MacrosFlg pstRef descr $ \f -> do-     v <- verbosity pstRef-     withLoadStatus v f descr (parseFromFileMaybeBinary lParseFromFile)-     >>= throwOnParseError "tree schemata"-     >>= lSetState pstRef+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"+    descr = "trees"+    parse = parseFromFileMaybeBinary lParseFromFile  -- | Load something, but only if we are configured to do so loadOptional :: forall f a . (Eq f, Typeable f, Loadable a)@@ -294,33 +295,36 @@              -> String              -> ProgStateRef              -> IO ()-loadOptional L flg descr pstRef =-  withFlagOrIgnore flg pstRef $ \f -> do-   v <- verbosity pstRef-   x <- withLoadStatus v f descr lParseFromFile-     >>= throwOnParseError descr-     >>= lSetState pstRef-   let _ = x :: a-   return () -- ignore+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) . runParser geniMorphInfo () f-  lSet (MorphFnL x) p = p { morphinf = x }-  lSummarise _ = "morphinfo"+    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 . T.pack+    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-  lSet r p = p { ranking = r }-  lSummarise _ = "ranking"+    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"@@ -331,11 +335,15 @@ loadRanking :: ProgStateRef -> IO () loadRanking = loadOptional (L :: L OtRanking) RankingConstraintsFlg "OT constraints" -resultToEither2 :: Result a -> Either ParseError a+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  -> runParser (fail e) () "" [] -- convoluted way to generate a Parsec error-    Right x -> Right x+    case resultToEither r of+        Left e  -> Left (T.pack e)+        Right x -> Right x  -- Target semantics --@@ -347,31 +355,38 @@ -- figuring out how to pretty-print things because we can assume the -- user will format it the way s/he wants. -newtype TestSuiteL = TestSuiteL [TestCase]+newtype TestSuiteL = TestSuiteL { fromTestSuiteL :: [TestCase SemInput] }  instance Loadable TestSuiteL where- lParse f s =-   case runParser geniTestSuite () f s of-     Left e     -> Left e-     Right sem  -> case runParser geniTestSuiteString () f s of-        Left e      -> Left e-        Right mStrs -> Right (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"+    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 :: ProgStateRef -> IO [TestCase]-loadTestSuite pstRef = do-  TestSuiteL xs <- loadOrDie (L :: L TestSuiteL) TestSuiteFlg "test suite" pstRef-  return xs+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 :: String -> Either ParseError SemInput-parseSemInput = fmap smooth . runParser geniSemanticInput () "semantics"+parseSemInput :: Text -> Either ParseError SemInput+parseSemInput =+    fmap smooth . runParser geniSemanticInput () "semantics"   where     smooth (s,r,l) = (sortSem s, sort r, l) @@ -379,56 +394,53 @@  withFlag :: forall f a . (Eq f, Typeable f)          => (FilePath -> f) -- ^ flag-         -> ProgStateRef+         -> ProgState          -> IO a               -- ^ null action          -> (FilePath -> IO a) -- ^ job          -> IO a-withFlag flag pstRef z job =- do config <- pa `fmap` readIORef pstRef-    case getFlagP flag config of-      Nothing -> z-      Just  x -> job x+withFlag flag pst z job =+    maybe z job $ getFlag flag (pa pst)  withFlagOrIgnore :: forall f . (Eq f, Typeable f)                  => (FilePath -> f) -- ^ flag-                 -> ProgStateRef+                 -> ProgState                  -> (FilePath -> IO ())                  -> IO ()-withFlagOrIgnore flag pstRef = withFlag flag pstRef (return ())+withFlagOrIgnore flag pst = withFlag flag pst (return ())  withFlagOrDie :: forall f a . (Eq f, Typeable f)               => (FilePath -> f) -- ^ flag-              -> ProgStateRef+              -> ProgState               -> String               -> (FilePath -> IO a)               -> IO a-withFlagOrDie flag pstRef description =-    withFlag flag pstRef (fail msg)+withFlagOrDie flag pst description =+    withFlag flag pst (fail msg)   where     msg = "Please specify a " ++ description ++ " file!" -withLoadStatus :: Loadable a-               => Bool                    -- ^ verbose+withLoadStatus :: Bool                 -- ^ verbose                -> FilePath             -- ^ file to load                -> String               -- ^ description-               -> (FilePath -> IO (Either ParseError a)) -- ^ parsing cmd-               -> IO (Either ParseError a)-withLoadStatus False f _ p = p f-withLoadStatus True  f d p = do-  ePutStr $ unwords [ "Loading",  d, f ++ "... " ]-  eFlush-  mx <- p f-  ePutStrLn $ either (const "ERROR") (\x -> lSummarise x ++ " loaded") mx-  return mx+               -> (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 ParseError a))+                         => (FilePath -> IO (Either Text a))                          -> FilePath-                         -> IO (Either ParseError a)+                         -> IO (Either Text a) parseFromFileMaybeBinary p f =- if (".genib" `isSuffixOf` f)-    then Right `fmap` decodeFile f-    else p f+    if takeExtension f == ".genib"+       then Right <$> decodeFile f+       else p f  -- -------------------------------------------------------------------- -- Surface realisation - entry point@@ -457,7 +469,7 @@   deriving (Ord, Eq)  data GeniSuccess = GeniSuccess-    { grLemmaSentence :: LemmaPlusSentence -- ^ “original” uninflected result +    { grLemmaSentence :: LemmaPlusSentence -- ^ “original” uninflected result     , grRealisations  :: [Text]            -- ^ results after morphology     , grResultType    :: ResultType     , grWarnings      :: [Text]            -- ^ warnings “local” to this particular@@ -481,12 +493,12 @@     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 +--   * Unpacks the builder results -- --   * Finalises the results (morphological generation) --@@ -494,33 +506,52 @@ --   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 :: ProgStateRef -> SemInput -> B.Builder st it Params -> IO (GeniResults,st)-runGeni pstRef semInput builder = do-     pst <- readIORef pstRef-     let config = pa pst-         run    = B.run builder-     -- step 1: lexical selection-     (initStuff, initWarns) <- initGeni pstRef semInput-     --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 config-     -- step 3: unpacking and-     -- step 4: post-processing-     results <- extractResults pstRef 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)+runGeni :: ProgState+        -> CustomSem sem+        -> B.Builder st it+        -> TestCase sem+        -> ErrorIO (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 Text (GeniResults, st) -> GeniResults+simplifyResults (Left t) = GeniResults+    { grResults        = [GError $ GeniError [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. --@@ -529,18 +560,22 @@ --   * Unpacks the builder results -- --   * Finalises the results (morphological generation)-extractResults :: ProgStateRef ->  B.Builder st it Params -> st -> IO [GeniResult]-extractResults pstRef builder finalSt = do-    config  <- pa <$> readIORef pstRef+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 && hasFlagP PartialFlg config+            if null uninflected && hasFlag PartialFlg pst                then (B.partial builder finalSt, PartialResult)                else (uninflected              , CompleteResult)         status = B.finished builder finalSt     -- step 4: post-processing-    finaliseResults pstRef (resultTy, status, rawResults)+    debugM logname $ "tree assembly status: " ++ prettyStr status+    finaliseResults pst newPa (resultTy, status, rawResults)  -- -------------------------------------------------------------------- -- Surface realisation - sub steps@@ -548,41 +583,44 @@  -- | 'initGeni' performs lexical selection and strips the input semantics of --   any morpohological literals-initGeni :: ProgStateRef -> SemInput -> IO (B.Input, GeniWarnings)-initGeni pstRef semInput_ = do-    pst <- readIORef pstRef-    let semInput = stripMorphStuff pst-                 . maybeRemoveConstraints pst-                 $ semInput_+--+--   See 'defaultCustomSem'+initGeni :: ProgState+         -> CustomSem sem+         -> sem+         -> ErrorIO (B.Input, GeniWarnings)+initGeni pst wrangler csem = do     -- lexical selection-    selection <- runLexSelection pstRef semInput-    -- strip morphological predicates-    let initStuff = B.Input +    selection <- runLexSelection pst wrangler csem+    liftIO $ debugM logname $+        "lexical selection returned " +++        (show . length $ lsAnchored selection) +++        " anchored trees"+    semInput <- liftEither $ fromCustomSemInput wrangler csem+    let initStuff = B.Input           { B.inSemInput = semInput           , B.inLex   = lsLexEntries selection-          , B.inCands = map (\c -> (c,-1)) (lsAnchored selection)+          , B.inCands = map (\c -> (c, emptyPolPaths)) (lsAnchored selection)           }     return (initStuff, lsWarnings selection)-  where-    stripMorphStuff pst = first3 (stripMorphSem (morphinf pst))-    -- disable constraints if the NoConstraintsFlg pessimisation is active-    maybeRemoveConstraints pst =-         if hasOpt NoConstraints (pa pst) then removeConstraints else id  -- | '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 :: ProgStateRef -> (ResultType, B.GenStatus, [B.Output]) -> IO [GeniResult]-finaliseResults pstRef (ty, status, os) = do-    pst <- readIORef pstRef+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 getFlagP MorphCmdFlg (pa pst) of-             Nothing  -> let morph = fromMaybe (map sansMorph) (customMorph (pa pst))-                         in  return (morph sentences)-             Just cmd -> map snd `fmap` inflectSentencesUsingCmd cmd sentences+    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 pst) os mss-        rank = rankResults (getTraces pst) grDerivation (ranking pst)+    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]]@@ -590,8 +628,11 @@                       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 pst (i,l,d) rs = GeniSuccess+  sansRanking (i,l,d) rs = GeniSuccess                { grLemmaSentence = l                , grRealisations = moRealisations rs                , grWarnings     = moWarnings rs@@ -613,8 +654,8 @@ showRealisations [] = "(none)" showRealisations xs = unlines . map sho . Map.toList . histogram $ xs   where-   sho (x,1) = x-   sho (x,c) = x ++ " (" ++ show c ++ " instances)"+    sho (x,1) = x+    sho (x,c) = x ++ " (" ++ show c ++ " instances)"  -- | No morphology! Pretend the lemma string is a sentence lemmaSentenceString :: GeniSuccess -> Text@@ -623,11 +664,11 @@ prettyResult :: ProgState -> GeniSuccess -> Text prettyResult pst nr =     T.intercalate "\n" . map showOne . grRealisations $ nr- where+  where     showOne str = pretty theRanking <> ". " <> str <> "\n" <> violations     violations  = prettyViolations tracesFn verbose (grViolations nr)     theRanking  = grRanking nr-    verbose  = hasFlagP VerboseModeFlg (pa pst)+    verbose  = hasFlag VerboseModeFlg pst     tracesFn = getTraces pst  -- | 'getTraces' is most likely useful for grammars produced by a@@ -637,11 +678,11 @@ --   details. getTraces :: ProgState -> Text -> [Text] getTraces pst tname =-  filt $ concat [ ptrace t | t <- gr pst, pidname t == readPidname tname ]+    filt $ concat [ ptrace t | t <- gr pst, pidname t == readPidname tname ]   where-   filt = case traces pst of-          []    -> id-          theTs -> filter (`elem` theTs)+    filt = case traces pst of+               []    -> id+               theTs -> filter (`elem` theTs)  -- | We assume the name was constructed by 'combineName' readPidname :: Text -> Text@@ -659,18 +700,21 @@ --   through the universal 'finaliseLexSelection'. -- --   Also hunts for some warning conditions-runLexSelection :: ProgStateRef -> SemInput -> IO LexicalSelection-runLexSelection pstRef (tsem,_,litConstrs) = do-    pst <- readIORef pstRef-    let config   = pa pst-        verbose  = hasFlagP VerboseModeFlg config+runLexSelection :: ProgState+                -> CustomSem sem -- ^ handler for custom semantics+                -> sem           -- ^ semantics+                -> ErrorIO LexicalSelection+runLexSelection pst wrangler csem = do+    let verbose  = hasFlag VerboseModeFlg pst+        selector = customSelector wrangler     -- perform lexical selection-    selector  <- getLexicalSelector pstRef-    selection <- selector (gr pst) (le pst) tsem+    selection <- liftIO $ selector (gr pst) (le pst) csem+    -- finalise selection+    sem@(tsem, _, _) <- liftEither $ fromCustomSemInput wrangler csem     let lexCand   = lsLexEntries selection-        candFinal = finaliseLexSelection (morphinf pst) tsem litConstrs (lsAnchored selection)+        candFinal = finaliseLexSelection (morphinf pst) sem (lsAnchored selection)     -- status-    when verbose $ T.hPutStrLn stderr . T.unlines $+    when verbose $ liftIO $ T.hPutStrLn stderr . T.unlines $         "Lexical items selected:"         :  map (indent . showLexeme . fromFL . iword) lexCand         ++ ["Trees anchored (family) :"]@@ -680,52 +724,70 @@                        [] -> []                        xs -> [NoLexSelection xs]     return $ selection { lsAnchored = candFinal-                       , lsWarnings = mkGeniWarnings semWarnings `mappend` lsWarnings selection+                       , lsWarnings = mkGeniWarnings semWarnings <> lsWarnings selection                        }   where     indent  x = ' ' `T.cons` x --- | Grab the lexical selector from the config, or return the standard GenI---   version if none is supplied-getLexicalSelector :: ProgStateRef -> IO LexicalSelector-getLexicalSelector pstRef = do-  config <- pa <$> readIORef pstRef-  case (customSelector config, grammarType config) of-    (Just s, _)            -> return s-    (Nothing, PreAnchored) -> mkPreAnchoredLexicalSelector pstRef-    (Nothing, _)           -> return defaultLexicalSelector+-- | 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)+    tsem \\ (nub $ concatMap tsemantics cands)  -- | Post-processes lexical selection results to things which---   GenI considers applicable to all situations:+--   GenI considers universal. No matter what custom+--   lexical selection mechanism you supply, these preflight+--   checks will run. -- --   * attaches morphological information to trees -----   * throws out elementary trees that violate trace constraints---     given by the user--- --   * filters out any elementary tree whose semantics contains --     things that are not in the input semantics-finaliseLexSelection :: MorphInputFn -> Sem -> [LitConstr] -> [TagElem] -> [TagElem]-finaliseLexSelection morph tsem litConstrs =-  setTidnums . considerCoherency . considerLc . considerMorph- where-   -- attach any morphological information to the candidates-   considerMorph = attachMorph morph tsem-   -- filter out candidates which do not fulfill the trace constraints-   matchesLc t = all (`elem` myTrace) constrs-         where constrs = concat [ cs | (l,cs) <- litConstrs, l `elem` mySem ]-               mySem   = tsemantics t-               myTrace = ttrace t-   considerLc = filter matchesLc-   -- filter out candidates whose semantics has bonus stuff which does-   -- not occur in the input semantics-   considerCoherency = filter (all (`elem` tsem) . tsemantics)+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@@ -734,104 +796,125 @@ newtype PreAnchoredL = PreAnchoredL [TagElem]  instance Loadable PreAnchoredL where-  lParse f = fmap PreAnchoredL-           . runParser geniTagElems () f-  lSet _ p = p -- this does not update prog state at all-  lSummarise (PreAnchoredL xs) = show (length xs) ++ " trees"+    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 :: ProgStateRef -> IO [TagElem]-readPreAnchored pstRef = do-  PreAnchoredL xs <- loadOrDie (L :: L PreAnchoredL)-                        MacrosFlg "preanchored trees" pstRef-  return xs+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 :: ProgStateRef -> IO LexicalSelector-mkPreAnchoredLexicalSelector pstRef = do-  xs <- readPreAnchored pstRef-  return (\_ _ _ -> return (LexicalSelection xs [] mempty))+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 (hasFlagP VerboseModeFlg . pa)+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+    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)-                             ]+    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 `fmap` 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) ]+    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"+    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)-                             ]+    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@@ -843,12 +926,12 @@  -- 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`@@ -857,16 +940,16 @@                   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

@@ -42,20 +42,20 @@     numStates, numTransitions ) where -import qualified Data.Map as Map-import Data.Maybe (catMaybes)+import qualified Data.Map         as Map+import           Data.Maybe       (catMaybes) -import NLP.GenI.General (combinations)+import           NLP.GenI.General (combinations)   -- | Note: you can define the final state either by setting 'isFinalSt' --   to @Just f@ where @f@ is some function or by putting them in --   'finalStList'-data NFA st ab = NFA +data NFA st ab = NFA   { startSt     :: st   , isFinalSt   :: Maybe (st -> Bool) -- ^ 'finalSt' will use this if defined   , finalStList :: [st]   -- ^ can be ignored if 'isFinalSt' is defined-  -- +  --   , transitions :: Map.Map st (Map.Map st [Maybe ab])                 -- ^ there can be more than one transition between any two states                 --   and a transition could be the empty symbol@@ -74,7 +74,7 @@ --   to via @a@. lookupTrans :: (Ord ab, Ord st) => NFA st ab -> st -> (Maybe ab) -> [st] lookupTrans aut st ab = Map.keys $ Map.filter (elem ab) subT-  where subT = Map.findWithDefault Map.empty st (transitions aut) +  where subT = Map.findWithDefault Map.empty st (transitions aut)  addTrans :: (Ord ab, Ord st) =>             NFA st ab@@ -82,10 +82,10 @@          -> Maybe ab  -- ^ transition          -> st        -- ^ to state          -> NFA st ab-addTrans aut st1 ab st2 = +addTrans aut st1 ab st2 =   aut { transitions = Map.insert st1 newSubT oldT }   where oldT     = transitions aut-        oldSubT  = Map.findWithDefault Map.empty st1 oldT +        oldSubT  = Map.findWithDefault Map.empty st1 oldT         newSubT  = Map.insertWith (++) st2 [ab] oldSubT  -- | Returns all possible paths through an automaton from the

@@ -15,8 +15,9 @@ -- 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 MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings     #-}  {-| The heavy lifting of GenI, the whole chart/agenda mechanism, can be@@ -42,78 +43,72 @@ ) where -import Control.Monad.State.Strict-import Data.Bits ( (.&.), (.|.), bit )-import Data.List ( delete, sort, nub )-import Data.Maybe ( mapMaybe, fromMaybe, maybeToList )-import Data.Tree ( flatten )-import Prelude hiding ( init )-import Data.Text ( Text )-import qualified Data.Map as Map-import qualified Data.Text as T--import Control.DeepSeq+import           Control.Monad.State.Strict+import           Data.Bits                  (bit, (.&.), (.|.))+import           Data.List                  (delete, nub, sort)+import qualified Data.Map                   as Map+import           Data.Maybe                 (fromMaybe, mapMaybe, maybeToList)+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Data.Tree                  (flatten)+import           Prelude                    hiding (init) -import Data.Generics ( Data )-import Data.Typeable ( Typeable )+import           Control.DeepSeq+import           Data.Generics              (Data)+import           Data.Typeable              (Typeable) -import NLP.GenI.Automaton (NFA, automatonPaths, automatonPathSets, numStates, numTransitions)-import NLP.GenI.Configuration-  ( getListFlagP, getFlagP, modifyFlagP, Params,-    DetectPolaritiesFlg(..),-    MetricsFlg(..),-    RootFeatureFlg(..),-    Optimisation(..), hasOpt,-  )-import NLP.GenI.FeatureStructure ( Flist, sortFlist, mkFeatStruct )-import NLP.GenI.General ( BitVector, snd3, thd3, geniBug )-import NLP.GenI.GeniVal ( GeniVal, DescendGeniVal(..), Collectable(collect), finaliseVarsById )-import NLP.GenI.Lexicon ( LexEntry )-import NLP.GenI.Morphology.Types-import NLP.GenI.Polarity  (PolResult(..), buildAutomaton, detectPolPaths)-import NLP.GenI.Pretty-import NLP.GenI.Semantics ( SemInput, Sem, Literal )-import NLP.GenI.Statistics (Statistics, incrIntMetric,-                   Metric(IntMetric), updateMetrics,-                   queryMetrics, queryIntMetric,-                   addMetric, emptyStats,-                   )-import NLP.GenI.Tag-    ( TagElem(idname,tsemantics,ttree), setTidnums-    , TagDerivation, dsChild, dsParent-    )-import NLP.GenI.TreeSchema ( GNode(..), GType(Subs, Foot) )+import           NLP.GenI.Automaton         (NFA, automatonPathSets,+                                             automatonPaths, numStates,+                                             numTransitions)+import           NLP.GenI.FeatureStructure  (Flist, mkFeatStruct, sortFlist)+import           NLP.GenI.Flag+import           NLP.GenI.General           (BitVector, geniBug, snd3, thd3)+import           NLP.GenI.GeniVal           (Collectable (collect),+                                             DescendGeniVal (..), GeniVal,+                                             finaliseVarsById)+import           NLP.GenI.Lexicon           (LexEntry)+import           NLP.GenI.Morphology.Types+import           NLP.GenI.Polarity          (PolResult (..), buildAutomaton,+                                             PolPathSet, detectPolPaths)+import           NLP.GenI.Pretty+import           NLP.GenI.Semantics         (Literal, Sem, SemInput)+import           NLP.GenI.Statistics        (Metric (IntMetric), Statistics,+                                             addMetric, emptyStats,+                                             incrIntMetric, queryIntMetric,+                                             queryMetrics, updateMetrics)+import           NLP.GenI.Tag               (TagDerivation,+                                             TagElem (idname, tsemantics, ttree),+                                             dsChild, dsParent, setTidnums)+import           NLP.GenI.TreeSchema        (GNode (..), GType (Subs, Foot))  data GenStatus = Finished                | Active                | Error Text -data Builder st it pa = Builder-  { init     :: Input -> pa -> (st, Statistics)-             -- ^ initialise the machine from the semantics and lexical selection -  , step     :: BuilderState st () -- ^ run a realisation step-  , stepAll  :: BuilderState st () -- ^ run all realisations steps until completion-  ---  , finished :: st -> GenStatus    -- ^ determine if realisation is finished-  , unpack   :: st -> [Output]     -- ^ unpack chart results into a list of sentences-  , partial  :: st -> [Output]-  }+data Builder st it = Builder+    { init     :: Input -> [Flag] -> (st, Statistics)+               -- ^ initialise the machine from the semantics and lexical selection+    , step     :: BuilderState st () -- ^ run a realisation step+    , stepAll  :: BuilderState st () -- ^ run all realisations steps until completion+    --+    , finished :: st -> GenStatus    -- ^ determine if realisation is finished+    , unpack   :: st -> [Output]     -- ^ unpack chart results into a list of sentences+    , partial  :: st -> [Output]+    }  type Output = (Integer, LemmaPlusSentence, TagDerivation) --- | To simplify interaction with the backend, we provide a single data---   structure which represents all the inputs a backend could take.--data Input = -  Input { inSemInput :: SemInput-        , inLex      :: [LexEntry] -- ^ for the debugger-        , inCands    :: [(TagElem, BitVector)]   -- ^ tag tree-        }+-- | 'Input' represents the set of inputs a backend could take+data Input = Input+    { inSemInput :: SemInput+    , inLex      :: [LexEntry] -- ^ for the debugger+    , inCands    :: [(TagElem, PolPathSet)]   -- ^ tag tree+    }  -- Uninflected words and sentences  -- | A SentenceAut represents a set of sentences in the form of an automaton.---   The labels of the automaton are the words of the sentence.  But note! +--   The labels of the automaton are the words of the sentence.  But note! --   “word“ in the sentence is in fact a tuple (lemma, inflectional feature --   structures).  Normally, the states are defined as integers, with the --   only requirement being that each one, naturally enough, is unique.@@ -122,10 +117,12 @@ data UninflectedDisjunction = UninflectedDisjunction [Text] (Flist GeniVal) deriving (Data, Typeable)  instance DescendGeniVal UninflectedDisjunction where-  descendGeniVal s (UninflectedDisjunction a v) = {-# SCC "descendGeniVal" #-} UninflectedDisjunction a (descendGeniVal s v)+    descendGeniVal s (UninflectedDisjunction a v) =+        {-# SCC "descendGeniVal" #-}+        UninflectedDisjunction a (descendGeniVal s v)  instance Collectable UninflectedDisjunction where-  collect (UninflectedDisjunction _ b) = collect b+    collect (UninflectedDisjunction _ b) = collect b  -- BuilderState @@ -149,37 +146,38 @@ -- alpha conversion so that unification does not do the wrong thing when two trees -- have the same variables. -preInit :: Input -> Params -> (Input, PolResult)-preInit input config =- let (cand,_) = unzip $ inCands input-     seminput = inSemInput input-     ---     extraPol = Map.empty-     polsToDetect = fromMaybe (error "there should be a default for --detect-pols")-                  $ getFlagP DetectPolaritiesFlg config-     rootFeat = mkFeatStruct $ getListFlagP RootFeatureFlg config-     -- do any optimisations-     isPol = hasOpt Polarised config-     -- polarity optimisation (if enabled)-     autstuff = buildAutomaton polsToDetect rootFeat extraPol seminput cand-     autpaths = map concat . automatonPathSets . prFinal $ autstuff-     combosPol = if isPol then autpaths else [considerHasSem cand]-     considerHasSem = filter (not . null . tsemantics)-     -- polarity automaton construction uses the zero literal semantic-     -- items, but it may be safer to filter them out now if we are not-     -- using it-     -- chart sharing optimisation-     (cands2, pathIds) = unzip $ detectPolPaths combosPol-     ---     fixate ts ps = zip (map finaliseVarsById $ setTidnums ts) ps-     input2 = input { inCands    = fixate cands2 pathIds-                    , inSemInput = (prSem autstuff, snd3 seminput, thd3 seminput) }-     -- note: autstuff is only useful for the graphical debugger-  in (input2, autstuff)+preInit :: Input -> [Flag] -> (Input, PolResult)+preInit input flags_ =+    -- note: autstuff is only useful for the graphical debugger+    (input2, autstuff)+  where+    (cand,_) = unzip $ inCands input+    seminput = inSemInput input+    --+    extraPol = Map.empty+    polsToDetect = fromMaybe (error "there should be a default for --detect-pols")+                 $ getFlag DetectPolaritiesFlg flags_+    rootFeat = mkFeatStruct $ getListFlag RootFeatureFlg flags_+    -- do any optimisations+    isPol = hasOpt Polarised flags_+    -- polarity optimisation (if enabled)+    autstuff = buildAutomaton polsToDetect rootFeat extraPol seminput cand+    autpaths = map concat . automatonPathSets . prFinal $ autstuff+    combosPol = if isPol then autpaths else [considerHasSem cand]+    considerHasSem = filter (not . null . tsemantics)+    -- polarity automaton construction uses the zero literal semantic+    -- items, but it may be safer to filter them out now if we are not+    -- using it+    -- chart sharing optimisation+    (cands2, pathIds) = unzip $ detectPolPaths combosPol+    --+    fixate ts ps = zip (map finaliseVarsById $ setTidnums ts) ps+    input2 = input { inCands    = fixate cands2 pathIds+                   , inSemInput = (prSem autstuff, snd3 seminput, thd3 seminput) }  -- | Equivalent to 'id' unless the input contains an empty or uninstatiated --   semantics-unlessEmptySem :: Input -> Params -> a -> a+unlessEmptySem :: Input -> [Flag] -> a -> a unlessEmptySem input _     | null semanticsErr = id     | otherwise         = error semanticsErr@@ -232,48 +230,54 @@ --    * lex_foot_nodes  - total number of foot nodes in lexically selected trees -- --    * plex_...        - same as the lex_ equivalent, but after polarity filtering-run :: Builder st it Params -> Input -> Params -> (st, Statistics)-run builder input config_ =-  let -- 0 normalise the config-      config = modifyFlagP RootFeatureFlg sortFlist config_-      -- 1 run the setup stuff-      (input2, autstuff) = preInit input config-      auts = map snd3 (prIntermediate autstuff)-      -- 2 call the init stuff-      (iSt, iStats) = init builder input2 config-      -- 2b extra statistics-      autpaths = map concat . automatonPathSets . prFinal $ autstuff-      countsFor ts = (length ts, length nodes, length sn, length an)-        where nodes = concatMap (flatten.ttree) ts-              sn = [ n | n <- nodes, gtype n == Subs  ]-              an = [ n | n <- nodes, gtype n == Foot  ]-      (tsem,_,_) = inSemInput input-      cands = nub . map fst $ inCands input-      cands2 = nub . concatMap concat . automatonPathSets . prFinal $ autstuff-      countUp = do incrCounter "sem_literals"  $ length tsem-                   ---                   incrCounter "lex_subst_nodes" snl-                   incrCounter "lex_foot_nodes"  anl-                   incrCounter "lex_nodes"        nl-                   incrCounter "lex_trees"        tl-                   -- node count after polarities are taken into account-                   incrCounter "plex_subst_nodes" snl2-                   incrCounter "plex_foot_nodes"  anl2-                   incrCounter "plex_nodes"        nl2-                   incrCounter "plex_trees"        tl2-                where (tl , nl , snl , anl ) = countsFor cands-                      (tl2, nl2, snl2, anl2) = countsFor cands2-      -- 3 step through the whole thing-      stepAll_ = do countUp-                    incrCounter "pol_used_bundles" $ length autpaths-                    incrCounter "pol_used_paths"   $ length . automatonPaths . prFinal   $ autstuff-                    incrCounter "pol_seed_paths"   $ length . automatonPaths . prInitial $ autstuff-                    incrCounter "pol_total_states" $ sum $ map numStates auts-                    incrCounter "pol_total_trans"  $ sum $ map numTransitions auts-                    incrCounter "pol_max_states"   $ maximum $ map numStates auts-                    incrCounter "pol_max_trans"    $ maximum $ map numTransitions auts-                    stepAll builder-  in runState (execStateT stepAll_ iSt) iStats+run :: Builder st it -> Input -> [Flag] -> (st, Statistics)+run builder input flgs_ =+    runState (execStateT stepAll_ iSt) iStats+  where+    -- 0 normalise the config+    flgs = modifyFlag RootFeatureFlg sortFlist flgs_+    -- 1 run the setup stuff+    (input2, autstuff) = preInit input flgs+    auts = map snd3 (prIntermediate autstuff)+    -- 2 call the init stuff+    (iSt, iStats) = init builder input2 flgs+    -- 2b extra statistics+    autpaths = map concat . automatonPathSets . prFinal $ autstuff+    countsFor ts =+        (length ts, length nodes, length sn, length an)+      where+        nodes = concatMap (flatten.ttree) ts+        sn = [ n | n <- nodes, gtype n == Subs  ]+        an = [ n | n <- nodes, gtype n == Foot  ]+    (tsem,_,_) = inSemInput input+    cands = nub . map fst $ inCands input+    cands2 = nub . concatMap concat . automatonPathSets . prFinal $ autstuff+    countUp = do+        incrCounter "sem_literals"  $ length tsem+        --+        incrCounter "lex_subst_nodes" snl+        incrCounter "lex_foot_nodes"  anl+        incrCounter "lex_nodes"        nl+        incrCounter "lex_trees"        tl+        -- node count after polarities are taken into account+        incrCounter "plex_subst_nodes" snl2+        incrCounter "plex_foot_nodes"  anl2+        incrCounter "plex_nodes"        nl2+        incrCounter "plex_trees"        tl2+      where+        (tl , nl , snl , anl ) = countsFor cands+        (tl2, nl2, snl2, anl2) = countsFor cands2+    -- 3 step through the whole thing+    stepAll_ = do+        countUp+        incrCounter "pol_used_bundles" $ length autpaths+        incrCounter "pol_used_paths"   $ length . automatonPaths . prFinal   $ autstuff+        incrCounter "pol_seed_paths"   $ length . automatonPaths . prInitial $ autstuff+        incrCounter "pol_total_states" $ sum $ map numStates auts+        incrCounter "pol_total_trans"  $ sum $ map numTransitions auts+        incrCounter "pol_max_states"   $ maximum $ map numStates auts+        incrCounter "pol_max_trans"    $ maximum $ map numTransitions auts+        stepAll builder  -- ---------------------------------------------------------------------- -- Semantics and bit vectors@@ -285,33 +289,35 @@ -- the resulting map can then be used to construct a bit vector -- representation of the semantics defineSemanticBits :: Sem -> SemBitMap-defineSemanticBits sem = Map.fromList $ zip sem bits+defineSemanticBits sem =+    Map.fromList $ zip sem bits   where-   bits = map bit [0..] -- 0001, 0010, 0100...+    bits = map bit [0..] -- 0001, 0010, 0100...  semToBitVector :: SemBitMap -> Sem -> BitVector-semToBitVector bmap sem = foldr (.|.) 0 $ map doLookup sem-  where doLookup p =-         case Map.lookup p bmap of-         Nothing -> geniBug $ "predicate " ++ prettyStr p ++ " not found in semanticBit map"-         Just b  -> b+semToBitVector bmap sem =+    foldr (.|.) 0 $ map doLookup sem+  where+    doLookup p = fromMaybe (geniBug (oops p)) (Map.lookup p bmap)+    oops p     = "predicate " ++ prettyStr p ++ " not found in semanticBit map"  bitVectorToSem :: SemBitMap -> BitVector -> Sem bitVectorToSem bmap vector =-  mapMaybe tryKey $ Map.toList bmap-  where tryKey (p,k) = if (k .&. vector == k) then Just p else Nothing+    mapMaybe tryKey $ Map.toList bmap+  where+    tryKey (p,k) = if (k .&. vector == k) then Just p else Nothing  -- ---------------------------------------------------------------------- -- Generate step -- ----------------------------------------------------------------------  -- | Default implementation for the 'stepAll' function in 'Builder'-defaultStepAll :: Builder st it pa -> BuilderState st ()-defaultStepAll b =- do s <- get+defaultStepAll :: Builder st it -> BuilderState st ()+defaultStepAll b = do+    s <- get     case finished b s of-      Active -> step b >> defaultStepAll b-      _      -> return ()+        Active -> step b >> defaultStepAll b+        _      -> return ()  -- | Dispatching consists of assigning a chart item to the right part of the --   chart (agenda, trash, results list, etc).  This is implemented as a@@ -323,10 +329,11 @@  -- | Sequence two dispatch filters. (>-->) :: (Monad s) => DispatchFilter s a -> DispatchFilter s a -> DispatchFilter s a-f >--> f2 = \x -> f x >>= next- where-  next y@Filtered = return y-  next (NotFiltered x2) = f2 x2+f >--> f2 =+     \x -> f x >>= next+  where+     next y@Filtered = return y+     next (NotFiltered x2) = f2 x2  -- | If the item meets some condition, use the first filter, otherwise --   use the second one.@@ -347,20 +354,21 @@  queryCounter :: String -> Statistics -> Maybe Int queryCounter key s =-  case queryMetrics (queryIntMetric key) s of-  []  -> Nothing-  [c] -> Just c-  _   -> geniBug $ "More than one instance of the metric: " ++ key+    case queryMetrics (queryIntMetric key) s of+        []  -> Nothing+        [c] -> Just c+        _   -> geniBug $ "More than one instance of the metric: " ++ key  -- Command line configuration -initStats :: Params -> Statistics-initStats pa =- let mdefault ms = if "default" `elem` ms then defaultMetricNames else []-     identifyMs :: [String] -> [Metric]-     identifyMs ms = map namedMetric $ mdefault ms ++ delete "default" ms-     metrics = identifyMs $ fromMaybe [] $ getFlagP MetricsFlg pa- in execState (mapM_ addMetric metrics) emptyStats+initStats :: [Flag] -> Statistics+initStats flags_ =+    execState (mapM_ addMetric metrics) emptyStats+  where+    mdefault ms = if "default" `elem` ms then defaultMetricNames else []+    identifyMs :: [String] -> [Metric]+    identifyMs ms = map namedMetric $ mdefault ms ++ delete "default" ms+    metrics = identifyMs $ fromMaybe [] $ getFlag MetricsFlg flags_  namedMetric :: String -> Metric -- the default case is that it's an int metric@@ -383,6 +391,15 @@ gen_time = "gen_time"  -- ----------------------------------------------------------------------+-- pretty printing+-- ----------------------------------------------------------------------++instance Pretty GenStatus where+    pretty Finished  = "finished"+    pretty Active    = "in progress"+    pretty (Error x) = "error:" <+> x++-- ---------------------------------------------------------------------- -- strictly API-ish bits -- ---------------------------------------------------------------------- @@ -397,7 +414,7 @@  -- GENERATED START - + instance NFData Input where         rnf (Input x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () 

@@ -17,12 +17,12 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE ViewPatterns              #-} module NLP.GenI.Configuration-    ( Params(..)+    ( module NLP.GenI.Control, getBuilderType, getRanking     --     , mainBuilderTypes-    , getFlagP, getListFlagP, modifyFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt     , emptyParams, defineParams     , treatArgs, treatArgsWithParams, usage, basicSections, optionsSections     , processInstructions@@ -42,103 +42,63 @@     ) where -import Control.Applicative ( (<$>), pure )-import Control.Arrow ( first )-import Control.Monad ( liftM )-import Data.Char ( toLower, isSpace )-import Data.List  ( find, intersperse, nubBy )-import Data.Maybe ( fromMaybe, isNothing, fromJust )-import Data.Maybe ( listToMaybe, mapMaybe )-import Data.String ( IsString(..) )-import Data.Text ( Text )-import Data.Typeable ( Typeable )-import System.Directory ( getAppUserDataDirectory, doesFileExist )-import System.Environment ( getProgName )-import System.FilePath-import System.IO ( stderr )-import Text.ParserCombinators.Parsec ( runParser, CharParser )-import qualified Data.ByteString.Char8 as BC-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.IO as T+import           Control.Applicative       (pure, (<$>))+import           Control.Arrow             (first)+import           Control.Monad+import qualified Data.ByteString.Char8     as BC+import           Data.Char                 (isSpace, toLower)+import           Data.List                 (find, intersperse, nubBy)+import qualified Data.Map                  as Map+import           Data.Maybe                (fromJust, fromMaybe, isNothing)+import           Data.Maybe                (listToMaybe, mapMaybe)+import           Data.String               (IsString (..))+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import qualified Data.Text.IO              as T+import           Data.Typeable             (Typeable)+import           System.Directory          (doesFileExist,+                                            getAppUserDataDirectory)+import           System.Environment        (getProgName)+import           System.FilePath+import           System.IO                 (stderr) -import Data.Yaml.YamlLight-import System.Console.GetOpt-import System.Log.Formatter-import System.Log.Handler ( LogHandler, setFormatter )-import System.Log.Handler.Simple-import System.Log.Logger+import           Data.Yaml.YamlLight+import           System.Console.GetOpt+import           System.Log.Formatter+import           System.Log.Handler        (LogHandler, setFormatter)+import           System.Log.Handler.Simple+import           System.Log.Logger -import NLP.GenI.Flag-import NLP.GenI.General ( geniBug, fst3, snd3 )-import NLP.GenI.Parser ( geniFeats, tillEof )-import NLP.GenI.Morphology.Types ( MorphRealiser )-import NLP.GenI.Pretty-import NLP.GenI.Polarity.Types ( readPolarityAttrs )-import NLP.GenI.LexicalSelection ( LexicalSelector )+import           NLP.GenI.Control+import           NLP.GenI.Flag+import           NLP.GenI.General          (fst3, geniBug, snd3)+import           NLP.GenI.OptimalityTheory+import           NLP.GenI.Parser           (Parser, geniFeats, runParser,+                                            tillEof)+import           NLP.GenI.Polarity.Types   (readPolarityAttrs)+import           NLP.GenI.Pretty  -- -------------------------------------------------------------------- -- Params -- -------------------------------------------------------------------- --- | Holds the specification for how Geni should be run, its input---   files, etc.  This is the stuff that would normally be found in---   the configuration file.-data Params = Params-    { grammarType    :: GrammarType-    , builderType    :: BuilderType-    -- | Can still be overridden with a morph command mind you-    , customMorph    :: Maybe MorphRealiser-    -- | Lexical selection function-    --   (if you set this you may want to add 'PreAnchored' to the config)-    , customSelector :: Maybe LexicalSelector-    , geniFlags      :: [Flag]-    }--{--instance Show Params where-    show p = unlines-        [ unwords [ "GenI config :", show (grammarType p), show (builderType p), morph ]-        , unwords $ "GenI flags  :" : map show (geniFlags p)-        ]-      where-        morph = "custom morph:" ++ show (isJust (customMorph p))--}- -- | The default parameters configuration emptyParams :: Params emptyParams = Params-    { builderType    = SimpleBuilder-    , grammarType    = GeniHand-    , customMorph    = Nothing-    , customSelector = Nothing+    { builderType    = Nothing+    , morphFlags     = emptyFlags     , geniFlags      = emptyFlags+    , ranking        = Nothing     } -hasOpt :: Optimisation -> Params -> Bool-hasOpt o p = maybe False (elem o) $ getFlagP OptimisationsFlg p--hasFlagP    :: (Typeable f, Typeable x) => (x -> f) -> Params -> Bool-hasFlagP f      = hasFlag f . geniFlags--deleteFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Params-deleteFlagP f p = p { geniFlags = deleteFlag f (geniFlags p) }--modifyFlagP :: (Eq f, Typeable f, Typeable x)-            => (x -> f) -> (x -> x) -> Params -> Params-modifyFlagP f m p = p { geniFlags = modifyFlag f m (geniFlags p) }--setFlagP    :: (Eq f, Typeable f, Typeable x)-            => (x -> f) -> x -> Params -> Params-setFlagP f v p  = p { geniFlags = setFlag f v (geniFlags p) }+getBuilderType :: Params -> BuilderType+getBuilderType = fromMaybe defaultBuilderType . builderType -getFlagP    :: (Typeable f, Typeable x)-            => (x -> f) -> Params -> Maybe x-getFlagP f = getFlag f . geniFlags+defaultBuilderType :: BuilderType+defaultBuilderType = SimpleBuilder -getListFlagP :: (Typeable f, Typeable x)-             => ([x] -> f) -> Params -> [x]-getListFlagP f = fromMaybe [] . getFlagP f+getRanking :: Params -> OtRanking+getRanking = fromMaybe [] . ranking  emptyFlags :: [Flag] emptyFlags =@@ -247,23 +207,22 @@  defineParams :: [Flag] -> Params -> Params defineParams flgs prms =-  (\p -> foldr setDefault p $ geniFlags prms)-  . (mergeFlagsP OptimisationsFlg)-  . (mergeFlagsP MetricsFlg)-  $ prms-    { geniFlags     = flgs-    , builderType   = fromFlags builderType BuilderFlg flgs-    , grammarType   = fromFlags grammarType GrammarTypeFlg flgs-    }- where-  setDefault (Flag f v) p =-    if hasFlagP f p then p else setFlagP f v p-  mergeFlagsP f p =-    if hasFlagP f p-    then setFlagP f (concat $ getAllFlags f flgs) p-    else p-  fromFlags default_ t fs =-    fromMaybe (default_ prms) (getFlag t fs)+    (\p -> foldr setDefault p $ geniFlags prms)+    . (mergeFlags OptimisationsFlg)+    . (mergeFlags MetricsFlg)+    $ prms+        { geniFlags     = flgs+        , builderType   = fromFlags builderType BuilderFlg flgs+        }+  where+    setDefault (Flag f v) p =+        if hasFlag f p then p else setFlag f v p+    mergeFlags f p =+        if hasFlag f p+            then setFlag f (concat $ getAllFlags f flgs) p+            else p+    fromFlags default_ t fs =+        getFlag t fs `mplus` default_ prms  -- -------------------------------------------------------------------- -- Basic options@@ -377,10 +336,10 @@ defaultPolarityAttrs :: String defaultPolarityAttrs = "cat" -exampleRootFeat :: String+exampleRootFeat :: Text exampleRootFeat = "[cat:s inv:- mode:ind|subj wh:-]" -defaultRootFeat :: String+defaultRootFeat :: Text defaultRootFeat = "[cat:_]"  optionsForOptimisation :: [OptDescr Flag]@@ -398,7 +357,7 @@ rootFeatureOption :: OptDescr Flag rootFeatureOption =   Option ['r'] ["rootfeat"]-         (reqArg RootFeatureFlg readRF "FEATURE")+         (reqArg RootFeatureFlg (readRF . T.pack) "FEATURE")          ("root features 'FEATURE' (eg. "           ++ prettyStr exampleRF ++ ", default: "           ++ prettyStr defaultRF ++ ")")@@ -409,9 +368,10 @@  coreOptimisationCodes :: [(Optimisation,String,String)] coreOptimisationCodes =- [ (Polarised        , "p",      "polarity filtering")- , (NoConstraints    , "nc",     "disable semantic constraints (anti-optimisation!)")- ]+    [ (Polarised,     "p",  "polarity filtering")+    , (Guided,        "gr", "guided realisation")+    , (NoConstraints, "nc", "disable semantic constraints (pessimisation!)")+    ]  optimisationCodes :: [(Optimisation,String,String)] optimisationCodes =@@ -422,7 +382,7 @@  where equivalentTo os = "equivalent to '" ++ (unwords $ map showOptCode os) ++ "'"  polOpts, adjOpts :: [Optimisation]-polOpts = [Polarised]+polOpts = [Polarised, Guided] adjOpts = []  -- ---------------------------------------------------------------------@@ -482,11 +442,11 @@   liftM fst3 $ find (\x -> snd3 x == code) optimisationCodes  -- | TODO: This is a horrible and abusive use of 'error'-parseFlagWithParsec :: String -> CharParser () b -> String -> b+parseFlagWithParsec :: String -> Parser b -> Text -> b parseFlagWithParsec description p str =- case runParser (tillEof p) () "" str of- Left  err -> error $ "Couldn't parse " ++ description ++ " because " ++ show err- Right res -> res+    case runParser (tillEof p) () "" str of+        Left  err -> error $ "Couldn't parse " ++ description ++ " because " ++ show err+        Right res -> res  -- -------------------------------------------------------------------- -- Builders@@ -547,7 +507,7 @@   [ testSuiteOption   , fromStdinOption   , Option []    ["testcase"]-      (reqArg (TestCaseFlg . T.pack) id "STRING")+      (reqArg TestCaseFlg T.pack "STRING")       "run test case STRING"   , Option []    ["timeout"] (reqArg TimeoutFlg read "SECONDS")       "time out after SECONDS seconds"@@ -593,25 +553,27 @@ --     a subset from the instructions processInstructions :: Params -> IO Params processInstructions config = do-    instructions <- case getFlagP InstructionsFileFlg config of+    instructions <- case getFlag InstructionsFileFlg config of                       Nothing -> return fakeInstructions                       Just f  -> instructionsFile `fmap` T.readFile f-    let updateInstructions = setFlagP TestInstructionsFlg instructions+    let updateInstructions = setFlag TestInstructionsFlg instructions         -- we have to set a test suite in case the user only supplies         -- an instructions argument so that NLP.GenI.loadEverything         -- knows that the user has given us a suite to load         updateTestSuite p =-          if hasFlagP TestSuiteFlg p then p-             else case (fst `fmap` listToMaybe instructions) of-                   Just s  -> setFlagP TestSuiteFlg s p-                   Nothing -> p+            if hasFlag TestSuiteFlg p+                then p+                else case listToMaybe instructions of+                    Just (s,_) -> setFlag TestSuiteFlg s p+                    Nothing    -> p     return . updateTestSuite . updateInstructions $ config   where     fakeInstructions :: [Instruction]     fakeInstructions =-         let cases = singleton <$> getFlagP TestCaseFlg config-             mkInstr xs = singleton (xs, cases)-         in maybe [] mkInstr $ getFlagP TestSuiteFlg config+        maybe [] mkInstr $ getFlag TestSuiteFlg config+      where+        cases      = singleton <$> getFlag TestCaseFlg config+        mkInstr xs = singleton (xs, cases)  instructionsFile :: Text -> [Instruction] instructionsFile =@@ -631,7 +593,7 @@   geniCfgDir <- getAppUserDataDirectory "geni"   let globalCfg = geniCfgDir </> "config.yaml"   hasCfg <- doesFileExist globalCfg-  if hasCfg then Just `fmap` parseYamlFile globalCfg +  if hasCfg then Just `fmap` parseYamlFile globalCfg             else return Nothing  data LoggerConfig = LoggerConfig { lcName      :: String@@ -659,7 +621,7 @@ setLoggers y = do     -- it seems we need to explicitly create the root logger     -- we set this to the lowest priority because we want the user to-    -- be able to set the priority on their loggers as low as they want +    -- be able to set the priority on their loggers as low as they want     updateGlobalLogger "" $ setLevel DEBUG                           . setHandlers noHandlers     mapM_ setGeniHandler $ fromMaybe [globalDefault] (loggerConfig y)@@ -705,7 +667,7 @@                   >>= mapM unMap                   >>= mapM readOne  where-   readOne :: Map.Map YamlLight YamlLight -> Maybe LoggerConfig +   readOne :: Map.Map YamlLight YamlLight -> Maybe LoggerConfig    readOne m = do      let name = fromMaybe "NLP.GenI" (get Just "name" m)      return $ updater "level"   m (\x l -> l { lcPriority = x })

@@ -19,65 +19,56 @@ --   test suites.  {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE PatternGuards      #-} module NLP.GenI.Console ( consoleGeni, loadNextSuite ) where -import Control.Applicative ( pure, (<$>) )-import Control.Monad-import Data.IORef(readIORef, modifyIORef)-import Data.List ( find, partition )-import Data.Maybe ( fromMaybe, isJust )-import Data.Text ( Text )-import Data.Time ( getCurrentTime, formatTime )-import Data.Typeable-import System.Log.Logger-import System.Locale ( defaultTimeLocale, iso8601DateFormat )-import System.Directory( createDirectoryIfMissing, getTemporaryDirectory )-import System.Exit ( exitWith, exitFailure, ExitCode(..) )-import System.FilePath ( (</>), takeFileName )-import System.IO ( stderr )-import System.Timeout ( timeout )-import qualified Data.ByteString as B-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Encoding as T-+import           Control.Applicative           (pure, (<$>))+import           Control.Monad+import           Control.Monad.Trans.Error+import qualified Data.ByteString               as B+import           Data.IORef                    (modifyIORef, readIORef)+import           Data.List                     (find, partition)+import           Data.Maybe+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           Data.Time                     (formatTime, getCurrentTime)+import           Data.Typeable+import           System.Directory+import           System.Exit+import           System.FilePath               (takeFileName, (</>))+import           System.IO                     (stderr)+import           System.Locale+import           System.Timeout                (timeout) -import NLP.GenI.General-  ( ePutStr, ePutStrLn,-  )-import NLP.GenI-import NLP.GenI.Configuration-  ( Params-  , BatchDirFlg(..), DumpDerivationFlg(..), EarlyDeathFlg(..)-  , MetricsFlg(..), RankingConstraintsFlg(..)-  , TestCaseFlg(..), TestSuiteFlg(..), TestInstructionsFlg(..)-  , FromStdinFlg(..), OutputFileFlg(..), StatsFileFlg(..)-  , TimeoutFlg(..),  VerboseModeFlg(..)-  , hasFlagP, getListFlagP, getFlagP, setFlagP-  , builderType , BuilderType(..)-  )-import NLP.GenI.General ( mkLogname )-import NLP.GenI.Pretty-import NLP.GenI.Semantics ( SemInput )-import NLP.GenI.Simple.SimpleBuilder-import NLP.GenI.TestSuite ( TestCase(..) )+import           System.Log.Logger+import           Text.JSON+import           Text.JSON.Pretty              (pp_value, render) -import Text.JSON-import Text.JSON.Pretty ( render, pp_value )+import           NLP.GenI+import           NLP.GenI.Configuration+import           NLP.GenI.General              (ePutStr, ePutStrLn)+import           NLP.GenI.General              (mkLogname)+import           NLP.GenI.GeniShow+import           NLP.GenI.LexicalSelection+import           NLP.GenI.Pretty+import           NLP.GenI.Simple.SimpleBuilder+import           NLP.GenI.TestSuite            (TestCase (..)) -consoleGeni :: ProgStateRef -> IO()-consoleGeni pstRef = do+consoleGeni :: ProgStateRef -> CustomSem sem -> IO()+consoleGeni pstRef wrangler = do     config <- pa <$> readIORef pstRef-    loadEverything pstRef-    let job | hasFlagP FromStdinFlg config           = runStdinTestCase pstRef-            | hasFlagP BatchDirFlg config            = runInstructions pstRef -- even if there is a testcase-            | Just tc <- getFlagP TestCaseFlg config = runSpecificTestCase pstRef tc-            | otherwise                              = runInstructions pstRef-    case getFlagP TimeoutFlg config of-      Nothing -> job-      Just t  -> withGeniTimeOut t job+    loadEverything pstRef wrangler+    pst <- readIORef pstRef+    let job | hasFlag FromStdinFlg config           = runStdinTestCase pst wrangler+            | hasFlag BatchDirFlg config            = runInstructions  pstRef wrangler -- even if there is a testcase+            | Just tc <- getFlag TestCaseFlg config = runSpecificTestCase pst wrangler tc+            | otherwise                             = runInstructions  pstRef wrangler+    case getFlag TimeoutFlg config of+        Nothing -> job+        Just t  -> withGeniTimeOut t job  withGeniTimeOut :: Int -- ^ seconds                 -> IO ()@@ -91,76 +82,81 @@           exitWith (ExitFailure 2)  -- | Run GenI without reading any test suites, just grab semantics from stdin-runStdinTestCase :: ProgStateRef -> IO ()-runStdinTestCase pstRef = do-    config   <- pa <$> readIORef pstRef-    mSemInput <- parseSemInput <$> getContents-    case mSemInput of-      Left err ->-           fail $ "I didn't understand the semantics you gave me: " ++ show err-      Right semInput ->-           runOnSemInput pstRef (runAsStandalone config) semInput >> return ()+runStdinTestCase :: ProgState -> CustomSem sem -> IO ()+runStdinTestCase pst wrangler = do+    let config = pa pst+    cstr      <- T.getContents+    case customSemParser wrangler cstr of+        Left err ->+            fail $ "I didn't understand the semantics you gave me: " ++ show err+        Right tc ->+            runOnSemInput pst (runAsStandalone config) wrangler tc >> return ()  -- | Run a test case with the specified name-runSpecificTestCase :: ProgStateRef -> Text -> IO ()-runSpecificTestCase pstRef cname = do-    config <- pa <$> readIORef pstRef-    fullsuite <- loadTestSuite pstRef+runSpecificTestCase :: ProgState -> CustomSem sem -> Text -> IO ()+runSpecificTestCase pst wrangler cname = do+    let config = pa pst+    fullsuite <- loadTestSuite pst wrangler     case find (\x -> tcName x == cname) fullsuite  of-        Nothing -> fail ("No such test case: " ++ T.unpack cname)-        Just s  -> runOnSemInput pstRef (runAsStandalone config) (tcSem s) >> return ()+        Nothing ->+            fail $ "No such test case: " ++ T.unpack cname+        Just tc ->+            runOnSemInput pst (runAsStandalone config) wrangler tc >> return ()  -- | Runs the tests specified in our instructions list. --   We assume that the grammar and lexicon are already --   loaded into the monadic state. --   If batch processing is enabled, save the results to the batch output --   directory with one subdirectory per suite and per case within that suite.-runInstructions :: ProgStateRef -> IO ()-runInstructions pstRef =-  do pst <- readIORef pstRef-     let config = pa pst-     batchDir <- case getFlagP BatchDirFlg config of-                   Nothing  -> do-                     t   <- getTemporaryDirectory-                     utc <- fmtTime <$> getCurrentTime-                     return (t </> "geni-" ++ utc)-                   Just bdir -> return bdir-     runBatch batchDir-     unless (hasFlagP BatchDirFlg config) $ do-       ePutStr $ unlines [ ""-                         , "Results saved to directory " ++ batchDir-                         , "To save results in a different directory, use the --batchdir flag"-                         ]+runInstructions :: ProgStateRef -> CustomSem sem -> IO ()+runInstructions pstRef wrangler = do+    pst <- readIORef pstRef+    batchDir <- case getFlag BatchDirFlg pst of+        Nothing  -> do+            t   <- getTemporaryDirectory+            utc <- fmtTime <$> getCurrentTime+            return (t </> "geni-" ++ utc)+        Just bdir -> return bdir+    runBatch batchDir+    unless (hasFlag BatchDirFlg pst) $ ePutStr. unlines $+        [ ""+        , "Results saved to directory " ++ batchDir+        , "To save results in a different directory, use the --batchdir flag"+        ]   where-  fmtTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M"))-  runBatch bdir = do-      config <- pa <$> readIORef pstRef-      mapM_ (runSuite bdir) $-          getListFlagP TestInstructionsFlg config-  runSuite bdir next@(file, _) =-    do suite  <- loadNextSuite pstRef next-       -- we assume the that the suites have unique filenames-       let bsubdir = bdir </> takeFileName file-       createDirectoryIfMissing True bsubdir-       if any (T.null . tcName) suite-          then    fail $ "Can't do batch processing. The test suite " ++ file ++ " has cases with no name."-          else do ePutStrLn "Batch processing mode"-                  mapM_ (runCase bsubdir) suite-  runCase bdir (TestCase { tcName = n, tcSem = s }) =-   do config <- pa `fmap` readIORef pstRef-      let verbose = hasFlagP VerboseModeFlg config-          earlyDeath = hasFlagP EarlyDeathFlg config-      when verbose $-        ePutStrLn "======================================================"-      gresults <- runOnSemInput pstRef (PartOfSuite n bdir) s-      let res = grResults gresults-          (goodres, badres) = partition isSuccess (grResults gresults)-      T.hPutStrLn stderr $-          " " <> n <+> "-" <+> pretty (length goodres) <+> "results" <+>-          parens (pretty (length badres))-      when (null res && earlyDeath) $ do-          T.hPutStrLn stderr $ "Exiting early because test case" <+> n <+> "failed."-          exitFailure+    fmtTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M"))+    runBatch bdir = do+        pst <- readIORef pstRef+        let instructions = getListFlag TestInstructionsFlg pst+        mapM_ (runSuite bdir) instructions+    runSuite bdir next@(file, _) = do+        suite  <- loadNextSuite pstRef wrangler next+        -- we assume the that the suites have unique filenames+        let bsubdir = bdir </> takeFileName file+        createDirectoryIfMissing True bsubdir+        if any (T.null . tcName) suite+            then fail $+                "Can't do batch processing. The test suite " ++ file ++ " has cases with no name."+            else do+                ePutStrLn "Batch processing mode"+                mapM_ (runCase bsubdir) suite+    runCase bdir tc = do+        pst <- readIORef pstRef+        let verbose    = hasFlag VerboseModeFlg pst+            earlyDeath = hasFlag EarlyDeathFlg  pst+        when verbose $+            ePutStrLn "======================================================"+        gresults <- runOnSemInput pst (PartOfSuite (tcName tc) bdir) wrangler tc+        let res = grResults gresults+        T.hPutStrLn stderr $ summary tc gresults+        when (null res && earlyDeath) $ do+            T.hPutStrLn stderr $ "Exiting early because test case" <+> tcName tc <+> "failed."+            exitFailure+    summary tc gresults =+        " " <> tcName tc <+> "-" <+> pretty (length goodres) <+> "results" <+>+        (if null badres then "" else parens (pretty (length badres) <+> "failures"))+      where+        (goodres, badres) = partition isSuccess (grResults gresults)  -- | Used in processing instructions files. Each instruction consists of a --   suite file and a list of test case names from that file@@ -169,15 +165,18 @@ --   how testsuite, testcase, and instructions are expected to interact -- --   (Exported for use by regression testing code)-loadNextSuite :: ProgStateRef -> (FilePath, Maybe [Text]) -> IO [TestCase]-loadNextSuite pstRef (file, mtcs) = do+loadNextSuite :: ProgStateRef+              -> CustomSem sem+              -> (FilePath, Maybe [Text])+              -> IO [TestCase sem]+loadNextSuite pstRef wrangler (file, mtcs) = do     debugM logname $ "Loading next test suite: " ++ file     debugM logname $ "Test case filter: " ++ maybe "none" (\xs -> show (length xs) ++ " items") mtcs-    modifyIORef pstRef $ \p -> p { pa = setFlagP TestSuiteFlg file (pa p) } -- yucky statefulness! :-(-    config <- pa `fmap` readIORef pstRef-    let mspecific = getFlagP TestCaseFlg config+    modifyIORef pstRef (setFlag TestSuiteFlg file) -- yucky statefulness! :-(+    pst <- readIORef pstRef+    let mspecific = getFlag TestCaseFlg pst     debugM logname . T.unpack $ "Test case to pick out:" <+> fromMaybe "none"  mspecific-    fullsuite <- loadTestSuite pstRef+    fullsuite <- loadTestSuite pst wrangler     return (filterSuite mtcs mspecific fullsuite)   where     filterSuite _         (Just c) suite = filter (\t -> tcName t == c) suite@@ -189,34 +188,42 @@  runAsStandalone :: Params -> RunAs runAsStandalone config =-    Standalone (fromMaybe "" $ getFlagP OutputFileFlg config)-               (fromMaybe "" $ getFlagP StatsFileFlg config)+    Standalone (fromMaybe "" $ getFlag OutputFileFlg config)+               (fromMaybe "" $ getFlag StatsFileFlg config)  -- | Runs a case in the test suite.  If the user does not specify any test --   cases, we run the first one.  If the user specifies a non-existing --   test case we raise an error.-runOnSemInput :: ProgStateRef+runOnSemInput :: ProgState               -> RunAs-              -> SemInput+              -> CustomSem sem+              -> TestCase  sem               -> IO GeniResults-runOnSemInput pstRef args semInput = do-    pst <- readIORef pstRef-    case builderType (pa pst) of-             SimpleBuilder         -> helper pst simpleBuilder_2p-             SimpleOnePhaseBuilder -> helper pst simpleBuilder_1p+runOnSemInput pst args wrangler tc = do+    case getBuilderType (pa pst) of+             SimpleBuilder         -> helper simpleBuilder_2p+             SimpleOnePhaseBuilder -> helper simpleBuilder_1p   where-    helper pst builder = do-         (res,_) <- runGeni pstRef semInput builder-         writeResults pst args semInput res+    csem = tcSem tc+    cstr = tcSemString tc+    helper builder = do+         res <- simplifyResults <$> (runErrorT $ runGeni pst wrangler builder tc)+         writeResults pst args wrangler cstr csem res          return res  -- | Not just the global warnings but the ones local to each response too allWarnings :: GeniResults -> [Text]-allWarnings res = concat $ grGlobalWarnings res-                         : [ grWarnings s | GSuccess s <- grResults res ]+allWarnings res = concat+    $ grGlobalWarnings res+    : [ grWarnings s | GSuccess s <- grResults res ] -writeResults :: ProgState -> RunAs -> SemInput -> GeniResults -> IO ()-writeResults pst args semInput gresults = do+writeResults :: ProgState+             -> RunAs+             -> CustomSem sem+             -> Text -- ^ raw text representation+             -> sem+             -> GeniResults -> IO ()+writeResults pst args wrangler cstr csem gresults = do     -- create output directory as needed     case args of         PartOfSuite n f -> createDirectoryIfMissing True (f </> T.unpack n)@@ -226,25 +233,29 @@        then writeResponses $ ppJSON results        else writeResponses $ T.unlines . concatMap (fromResult formatResponses) $ results     -- print out statistical data (if available)-    when (isJust $ getFlagP MetricsFlg config) $+    when (isJust $ getFlag MetricsFlg pst) $        writeStats (ppJSON stats)     -- print any warnings we picked up along the way     unless (null warnings) $ do        T.hPutStrLn stderr $ "Warnings:\n" <> formatWarnings warnings        writeBatchFile "warnings" $ T.unlines warnings     -- other outputs when run in batch mode-    writeBatchFile "semantics"  $ pretty semInput+    writeBatchFile "raw-semantics" cstr+    writeBatchFile "custom-semantics" $+         customRenderSem wrangler csem+    writeBatchFile "semantics"  $+         either ("ERROR:" <+>) geniShowText $+         fromCustomSemInput wrangler csem     writeBatchFile "derivations"$ ppJSON results   where     results     = grResults    gresults     warnings    = allWarnings  gresults     stats       = grStatistics gresults-    config      = pa pst-    dump        = hasFlagP DumpDerivationFlg config+    dump        = hasFlag DumpDerivationFlg pst     -- do we print ranking information and all that other jazz?-    formatResponses = if hasFlagP RankingConstraintsFlg config-                         then pure . prettyResult pst-                         else grRealisations+    formatResponses = if isNothing (ranking (pa pst))+                         then grRealisations+                         else pure . prettyResult pst     formatWarnings = T.unlines . map (" - " <>)     --     writeBatchFile key = case args of

@@ -0,0 +1,51 @@+-- GenI surface realiser+-- Copyright (C) 2013 Eric Kow (Computational Linguistics Ltd)+--+-- 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.++module NLP.GenI.Control where++import           Control.Monad++import           NLP.GenI.Flag+import           NLP.GenI.OptimalityTheory++-- | Inputs that go around a single testcase/input+data Params = Params+    { builderType :: Maybe BuilderType+      -- | Custom morph realiser may define a custom set of flags+      --   that it accepts+    , morphFlags  :: [Flag]+    , geniFlags   :: [Flag]+      -- | OT constraints (optional, uses global if unset)+    , ranking     :: Maybe OtRanking+    }+++-- | Note that this affects the geniFlags; we assume the morph flags+--   are not our business+instance HasFlags Params where+    flags       = geniFlags+    onFlags f p = p { geniFlags = f (geniFlags p) }++updateParams :: Params -- ^ new+             -> Params -- ^ old+             -> Params+updateParams new old = old+    { builderType = builderType new `mplus` builderType old+    , morphFlags  = updateFlags (morphFlags new) (morphFlags old)+    , geniFlags   = updateFlags (geniFlags  new) (geniFlags  old)+    , ranking     = ranking new `mplus` ranking old+    }

@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- This module is public domain as far as I'm concerned++module NLP.GenI.ErrorIO where++import           Control.Monad.Trans.Error+import           Data.Text                 (Text)+import qualified Data.Text                 as T++type ErrorIO = ErrorT Text IO++instance Error Text where+    strMsg = T.pack++liftEither :: (Error e, Monad m) => Either e a -> ErrorT e m a+liftEither (Left e)  = throwError e+liftEither (Right x) = return x

@@ -16,44 +16,65 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeSynonymInstances  #-}++-- | Feature structures in GenI can be seen as a simple mapping from+--   attributes to values (no fancy recursion).+--+--   From an implementation standpoint, we do truck around lists of+--   'AvPair' quite a bit which unfortunately means we don't+--   guarantee things like uniqueness of attributes.  We may phase+--   this out over time in favour of 'FeatStruct' module NLP.GenI.FeatureStructure where -import Data.Binary-import Data.Function (on)-import Data.Generics (Data)-import Data.List (sortBy)-import qualified Data.Map as Map-import Data.Typeable (Typeable)-import Data.Text ( Text )-import qualified Data.Text as T+import           Control.DeepSeq+import           Data.Binary+import           Data.Function     (on)+import           Data.Generics     (Data)+import           Data.List         (sortBy)+import qualified Data.Map          as Map+import           Data.Text         (Text)+import qualified Data.Text         as T+import           Data.Typeable     (Typeable) -import NLP.GenI.GeniShow-import NLP.GenI.GeniVal-import NLP.GenI.General ( geniBug )-import NLP.GenI.Pretty+import           NLP.GenI.General  (geniBug)+import           NLP.GenI.GeniShow+import           NLP.GenI.GeniVal+import           NLP.GenI.Pretty -import Control.DeepSeq  -- ---------------------------------------------------------------------- -- Core types -- ---------------------------------------------------------------------- +-- | A list of attribute-value pairs. It's not a great idea to represent+--   feature structures with this because it allows for duplicates in the+--   attributes. But maybe sometimes you really do mean a list. type Flist a  = [AvPair a]++-- | An attribute-value pair, the typical use being+--   @AvPair GeniVal@ or if you have something even simpler+--   @AvPair Text@ data AvPair a = AvPair { avAtt :: Text                        , avVal :: a }   deriving (Ord, Eq, Data, Typeable) --- experimental, alternative representation of Flist--- which guarantees uniqueness of keys+-- | Experimental, alternative representation of Flist+--   which guarantees uniqueness of keys type FeatStruct a = Map.Map Text a +-- | A feature structure with no pairs emptyFeatStruct :: FeatStruct a emptyFeatStruct = Map.empty -mkFeatStruct :: Flist GeniVal -> FeatStruct GeniVal +-- | Convert an 'Flist' to a proper 'FeatStruct'+--   Unsafely assumes the keys are unique+mkFeatStruct :: Flist GeniVal -> FeatStruct GeniVal mkFeatStruct fs = Map.fromListWith oops . map fromPair $ fs   where    fromPair (AvPair a v) = (a,v)@@ -61,6 +82,7 @@      "I've allowed a feature structure with multiple versions of a key"      ++ " to sneak through: " ++ prettyStr fs +-- | Convert an 'FeatStruct' to a simpler to process 'Flist' fromFeatStruct :: FeatStruct a -> Flist a fromFeatStruct = sortFlist . map (uncurry AvPair) . Map.toList @@ -102,10 +124,10 @@ instance Pretty (AvPair GeniVal) where     pretty = geniShowText -instance GeniShow (Flist GeniVal) where+instance GeniShow gv => GeniShow (Flist gv) where     geniShowText = squares . T.unwords . map geniShowText -instance GeniShow (AvPair GeniVal) where+instance GeniShow gv => GeniShow (AvPair gv) where     geniShowText (AvPair a v) = a `T.append` ":" `T.append` geniShowText v  {-@@ -127,7 +149,8 @@ -- --   The features are allowed to have different sets of attributes, --   beacuse we use 'alignFeat' to realign them.-unifyFeat :: Monad m => Flist GeniVal -> Flist GeniVal -> m (Flist GeniVal, Subst)+unifyFeat :: MonadUnify m+          => Flist GeniVal -> Flist GeniVal -> m (Flist GeniVal, Subst) unifyFeat f1 f2 =   {-# SCC "unification" #-}   let (att, val1, val2) = unzip3 $ alignFeat f1 f2@@ -143,6 +166,7 @@ alignFeat :: Flist GeniVal -> Flist GeniVal -> [(Text,GeniVal,GeniVal)] alignFeat f1 f2 = alignFeatH f1 f2 [] +-- | Helper for 'alignFeat'; ignore alignFeatH :: Flist GeniVal -> Flist GeniVal -> [(Text,GeniVal,GeniVal)] -> [(Text,GeniVal,GeniVal)] alignFeatH [] [] acc = reverse acc alignFeatH [] (AvPair f v :x) acc = alignFeatH [] x ((f,mkGAnon,v) : acc)@@ -157,10 +181,16 @@ -- Fancy disjunction -- -------------------------------------------------------------------- -crushAvPair :: AvPair [GeniVal] -> Maybe (AvPair GeniVal)+-- | Flatten a fancy disjunction attribute-value pair+--+--   See 'crushOne' for details+crushAvPair :: AvPair SchemaVal -> Maybe (AvPair GeniVal) crushAvPair (AvPair a v) = AvPair a `fmap` crushOne v -crushFlist :: Flist [GeniVal] -> Maybe (Flist GeniVal)+-- | Flatten a fancy-disjunction feature structure+--+--   See 'crushOne' for details+crushFlist :: Flist SchemaVal -> Maybe (Flist GeniVal) crushFlist = mapM crushAvPair  {-!@@ -180,7 +210,7 @@                x2 <- get                return (AvPair x1 x2) - + instance (NFData a) => NFData (AvPair a) where         rnf (AvPair x1 x2) = rnf x1 `seq` rnf x2 `seq` () -- GENERATED STOP

@@ -1,29 +1,37 @@+{-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances         #-} -- GenI surface realiser -- Copyright (C) 2009 Eric Kow -- -- This module can be treated as public domain -module NLP.GenI.Flag where---- This module exists purely for the purpose of making it more convenient--- to modify the flag set in GenI (by eliminating the need to explicitly--- export the types for individual flags).  To add a flag:+-- | Internal representation of GenI configuration options, typically+--   passed in through the command line or via the GUI. -----  1. add a type here---  2. write the help text in NLP.GenI.Configuration---  3. add the getopt stuff and find a section for the flag+--   We don't yet use the record based approach, or something like+--   cmdargs because our use case involves+--+--   * sharing lots of options between different programs+--     (batch processing, gui, server)+--+--   * supporting library users who want to build GenI-like applications+--     that share a good chunk of our flag set, and add configuration+--     options of their own.+--+--   What we have is fairly clunky, but it seems to be quite+--   flexible for that need.+module NLP.GenI.Flag where -import Data.List ( find )-import qualified Data.Set as Set-import Data.Maybe ( catMaybes, fromJust )-import Data.Text ( Text )-import Data.Typeable+import           Data.List                 (find)+import           Data.Maybe                (catMaybes, fromJust, fromMaybe)+import qualified Data.Set                  as Set+import           Data.Text                 (Text)+import           Data.Typeable -import NLP.GenI.FeatureStructure ( Flist )-import NLP.GenI.GeniVal ( GeniVal )-import NLP.GenI.Polarity.Types+import           NLP.GenI.FeatureStructure (Flist)+import           NLP.GenI.GeniVal          (GeniVal)+import           NLP.GenI.Polarity.Types  -- ---------------------------------------------------------------------- -- configuration stuff@@ -31,26 +39,50 @@ -- to avoid an import cycle (sigh) -- ---------------------------------------------------------------------- -data Optimisation = PolOpts-                  | AdjOpts-                  | Polarised-                  | NoConstraints+-- | Requested optimisations+--+--   At the time of this writing (2012-08-21), this is fairly sparse as+--   a lot of proposed optimisations have just been absorbed into GenI+--   as mandatory things.+data Optimisation = PolOpts       -- ^ all polarity-related   optimisations+                  | AdjOpts       -- ^ all adjunction-related optimisations+                  | Polarised     -- ^ polarity filtering+                  | NoConstraints -- ^ ignore literal constraints (pessimisation?)+                  | Guided        -- ^ guided realisation (needs polarity filtering)   deriving (Show,Eq,Typeable) +-- | A test suite and any test cases within that we want to pick out type Instruction = (FilePath, Maybe [Text]) +-- | The tree assembly algorithm we want to use data BuilderType = SimpleBuilder | SimpleOnePhaseBuilder      deriving (Eq, Typeable) +-- | What kind of elementary trees we're getting.  The typical use case is+--   to provide tree schemata with 'GeniHand' (which then get anchored into+--   the lexicon to give us elmentary trees).  You can also have precompiled+--   trees hardcoded into your GenI-like program, or read preanchored+--   elementary trees from somewhere else. data GrammarType = GeniHand    -- ^ geni's text format                  | PreCompiled -- ^ built into geni, no parsing needed                  | PreAnchored -- ^ lexical selection already done      deriving (Show, Eq, Typeable) +defaultGrammarType :: GrammarType+defaultGrammarType = GeniHand++getGrammarType :: [Flag] -> GrammarType+getGrammarType = fromMaybe defaultGrammarType . getFlag GrammarTypeFlg+ instance Show BuilderType where   show SimpleBuilder         = "simple-2p"   show SimpleOnePhaseBuilder = "simple-1p" ++-- |+hasOpt :: Optimisation -> [Flag] -> Bool+hasOpt o p = maybe False (elem o) $ getFlag OptimisationsFlg p+ -- ---------------------------------------------------------------------- -- flag core -- ----------------------------------------------------------------------@@ -66,6 +98,14 @@ data Flag = forall f x . (Eq f, Typeable f, Typeable x) =>      Flag (x -> f) x deriving (Typeable) +class HasFlags x where+    flags   :: x -> [Flag]+    onFlags :: ([Flag] -> [Flag]) -> x -> x++instance HasFlags [Flag] where+    flags     = id+    onFlags f = f+ {- instance Show Flag where  show (Flag f x) = "Flag " ++ show (f x)@@ -80,27 +120,64 @@ isFlag :: (Typeable f, Typeable x) => (x -> f) -> Flag -> Bool isFlag f1 (Flag f2 _) = typeOf f1 == typeOf f2 -hasFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> Bool-hasFlag = any . isFlag+hasFlag :: (Typeable f, Typeable x, HasFlags flags) => (x -> f) -> flags -> Bool+hasFlag f = any (isFlag f) . flags -deleteFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> [Flag]-deleteFlag f = filter (not.(isFlag f))+deleteFlag :: (Typeable f, Typeable x, HasFlags flags) => (x -> f) -> flags -> flags+deleteFlag f fs =+    onFlags (const good) fs+  where+    good     = filter innocent (flags fs)+    innocent = not . isFlag f  -- | This only has an effect if the flag is set-modifyFlag :: (Eq f, Typeable f, Typeable x) => (x -> f) -> (x -> x) -> [Flag] -> [Flag]+modifyFlag :: (Eq f, Typeable f, Typeable x, HasFlags flags)+           => (x -> f) -- ^ flag constructor+           -> (x -> x)+           -> flags+           -> flags modifyFlag f m fs =-  case getFlag f fs of-    Nothing -> fs-    Just v  -> setFlag f (m v) fs+    case getFlag f (flags fs) of+        Nothing -> fs+        Just v  -> onFlags (setFlag f (m v)) fs -setFlag :: (Eq f, Typeable f, Typeable x) => (x -> f) -> x -> [Flag] -> [Flag]-setFlag f v fs = (Flag f v) : tl where tl = deleteFlag f fs+setFlag :: (Eq f, Typeable f, Typeable x, HasFlags flags)+        => (x -> f)+        -> x+        -> flags+        -> flags+setFlag f v =+    onFlags setf+  where+    setf fs = (Flag f v) : tl where tl = deleteFlag f fs -getFlag :: (Typeable f, Typeable x)  => (x -> f) -> [Flag] -> Maybe x-getFlag f fs = do (Flag _ v) <- find (isFlag f) fs ; cast v+getFlag :: (Typeable f, Typeable x, HasFlags flags)+        => (x -> f)+        -> flags+        -> Maybe x+getFlag f fs = do (Flag _ v) <- find (isFlag f) (flags fs) ; cast v -getAllFlags :: (Typeable f, Typeable x)  => (x -> f) -> [Flag] -> [x]-getAllFlags f fs = catMaybes [ cast v | flg@(Flag _ v) <- fs, isFlag f flg ]+getAllFlags :: (Typeable f, Typeable x, HasFlags flags)+            => (x -> f) -> flags -> [x]+getAllFlags f fs = catMaybes [ cast v | flg@(Flag _ v) <- flags fs, isFlag f flg ]++getListFlag :: (Typeable f, Typeable x, HasFlags flags)+            => ([x] -> f) -> flags -> [x]+getListFlag f = fromMaybe [] . getFlag f . flags++-- | @updateFlags new old@ takes the flags from @new@ plus any from @old@ that+--   aren't mentioned in it+updateFlags :: (HasFlags flags)+            => flags  -- ^ new+            -> flags -- ^ old+            -> flags+updateFlags new_ old_ =+    onFlags (const updated) old_+  where+    updated = foldr update old new+    old = flags old_+    new = flags new_+    update (Flag f v) fs = setFlag f v fs  -- ---------------------------------------------------------------------- -- Below are just the individual flags, which unfortunately have to be

@@ -21,8 +21,11 @@ --   libraries, or the Haskell platform ones, or on hackage.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module NLP.GenI.General (         -- * IO         ePutStr, ePutStrLn, eFlush,@@ -32,7 +35,7 @@         trim,         toUpperHead, toLowerHead,         toAlphaNum,-        quoteString, quoteText,+        quoteString, quoteText, maybeQuoteText,         clumpBy,         -- * Triples         first3, second3, third3,@@ -55,7 +58,7 @@         Interval,         (!+!), ival, showInterval,         -- * Bit vectors-        BitVector,+        BitVector(..),         showBitVector,         -- * Errors, logging and exceptions         geniBug,@@ -64,25 +67,29 @@         )         where -import Control.Arrow (first)-import Control.Exception (IOException)-import Control.Monad (liftM)-import Data.Bits (shiftR, (.&.))-import Data.Char (isAlphaNum, isDigit, isSpace, toUpper, toLower)-import Data.Function ( on )-import Data.List (foldl', intersect, inits, intersperse, groupBy, sortBy)-import Data.Typeable ( typeOf, Typeable )-import Data.Tree-import System.IO (hPutStrLn, hPutStr, hFlush, stderr)-import System.IO.Error (isUserError, ioeGetErrorString)-import qualified Data.Map as Map-import Prelude hiding ( catch )-import Data.Text ( Text )-import qualified Data.Text as T+import           Control.Arrow      (first)+import           Control.Exception  (IOException)+import           Control.Monad      (liftM)+import           Data.Binary+import           Data.Bits          (shiftR, (.&.), Bits)+import           Data.Char          (isAlphaNum, isDigit, isSpace, toLower,+                                     toUpper)+import           Data.Function      (on)+import           Data.List          (foldl', groupBy, inits, intersect,+                                     intersperse, sortBy)+import qualified Data.Map           as Map+import           Data.Text          (Text)+import qualified Data.Text          as T import qualified Data.Text.Encoding as T-import Data.Binary-import Text.JSON+import           Data.Tree+import           Data.Typeable      (Typeable, typeOf)+import           Prelude            hiding (catch)+import           System.IO          (hFlush, hPutStr, hPutStrLn, stderr)+import           System.IO.Error    (ioeGetErrorString, isUserError) +import           Control.DeepSeq+import           Text.JSON+ -- ---------------------------------------------------------------------- -- IO -- ----------------------------------------------------------------------@@ -109,7 +116,7 @@ isGeniIdentLetter x = isAlphaNum x || x `elem` "_'+-."  trim :: String -> String-trim = reverse . (dropWhile isSpace) . reverse . (dropWhile isSpace) +trim = reverse . (dropWhile isSpace) . reverse . (dropWhile isSpace)  -- | Drop all characters up to and including the one in question dropTillIncluding :: Char -> String -> String@@ -132,6 +139,18 @@    helper '\\' = [ '\\', '\\' ]    helper x    = [ x ] +-- | 'quoteText' but only if it contains characters that are not+--   used in GenI identifiers+maybeQuoteText :: Text -> Text+maybeQuoteText x+    | T.null x        = quoteText ""+    | "-" `T.isPrefixOf` x = quoteText x -- could be interpreted as+    | "+" `T.isPrefixOf` x = quoteText x -- semantic polarities+    | T.any naughty x = quoteText x+    | otherwise       = x+  where+    naughty c = not (isGeniIdentLetter c) || c `elem` "_?/"+ quoteText :: Text -> Text quoteText t =     q `T.append` escape t `T.append` q@@ -232,7 +251,7 @@ --   items by some property they have in common. The difference is that the --   property is used as a key to a Map that you can lookup. groupByFM :: (Ord b) => (a -> b) -> [a] -> (Map.Map b [a])-groupByFM fn list = +groupByFM fn list =   let addfn  x acc key = insertToListMap key x acc       helper acc x = addfn x acc (fn x)   in foldl' helper Map.empty list@@ -354,7 +373,7 @@ -- | errors specifically in GenI, which is very likely NOT the user's fault. geniBug :: String -> a geniBug s = error $ "Bug in GenI!\n" ++ s ++-                    "\nPlease file a report on http://trac.haskell.org/GenI/newticket"+                    "\nPlease file a report on http://github.com/kowey/GenI"  -- stolen from Darcs prettyException :: IOException -> String@@ -383,20 +402,23 @@ showInterval (x,y) =  let sign i = if i > 0 then "+" else ""      --- in if (x==y) -    then (sign x) ++ (show x) + in if (x==y)+    then (sign x) ++ (show x)     else show (x,y)  -- ---------------------------------------------------------------------- -- Bit vectors -- ---------------------------------------------------------------------- -type BitVector = Integer+newtype BitVector = BitVector Integer+  deriving (Eq, Bits, Num, NFData)  -- | displays a bit vector, using a minimum number of bits showBitVector :: Int -> BitVector -> String-showBitVector min_ 0 = replicate min_ '0'-showBitVector min_ x = showBitVector (min_ - 1) (shiftR x 1) ++ (show $ x .&. 1)+showBitVector min_ (BitVector 0) =+    replicate min_ '0'+showBitVector min_ (BitVector x) =+    showBitVector (min_ - 1) (BitVector (shiftR x 1)) ++ (show $ x .&. 1)  -- ---------------------------------------------------------------------- -- JSON

@@ -16,16 +16,17 @@ --  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.  -- This module provides specialised functions for visualising tree data.-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeSynonymInstances #-} module NLP.GenI.GeniShow where -import Data.Text ( Text )-import Data.Tree-import qualified Data.Text as T-import NLP.GenI.Pretty+import           Data.Text       (Text)+import qualified Data.Text       as T+import           Data.Tree+import           NLP.GenI.Pretty  -- | GenI format; should round-trip with 'NLP.GenI.Parser' by rights --

@@ -16,15 +16,19 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE OverlappingInstances, FlexibleInstances, TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TemplateHaskell      #-}+-- | GenI values (variables, constants) module NLP.GenI.GeniVal   ( -- * GeniVal     GeniVal, gLabel, gConstraints   , mkGConst, mkGConstNone, mkGVar, mkGVarNone, mkGAnon     -- ** queries and manipulation-  , isVar, isAnon, isConst, singletonVal-  , crushOne+  , isAnon, singletonVal+    -- ** fancy disjunction+  , SchemaVal(..), crushOne     -- * Unification and subsumption     --     -- ** Finalisation@@ -32,9 +36,9 @@     -- Before you do any unification/subsumption, you should finalise all     -- the variables in all the objects (a one time alpha-conversion type     -- thing)-  , finaliseVars, finaliseVarsById+  , finaliseVars, finaliseVarsById, anonymiseSingletons     -- ** Unification-  , unify, UnificationResult(..), Subst, appendSubst+  , MonadUnify, unify, UnificationResult(..), Subst, appendSubst     -- ** subsumption   , subsumeOne, allSubsume @@ -43,4 +47,4 @@   , replace, replaceList   ) where -import NLP.GenI.GeniVal.Internal+import           NLP.GenI.GeniVal.Internal

@@ -16,37 +16,52 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE OverlappingInstances, FlexibleInstances, TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ViewPatterns         #-}+-- | Gory details for 'NLP.GenI.GeniVal' module NLP.GenI.GeniVal.Internal where --- import Debug.Trace -- for test stuff-import Control.Arrow (first, (***))-import Control.Monad (liftM)-import Data.Binary-import Data.List-import Data.Maybe (fromMaybe, isNothing, isJust)-import Data.Generics (Data)-import Data.Typeable (Typeable)-import qualified Data.Map as Map--import Data.Text ( Text )-import qualified Data.Text as T+import           Control.Applicative ((<$>))+import           Control.Arrow       (first, second, (***))+import           Control.DeepSeq+import           Control.Monad.Error+import           Data.Binary+import           Data.Generics       (Data)+import           Data.List+import qualified Data.Map            as Map+import           Data.Maybe          (fromMaybe, isNothing)+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Data.Typeable       (Typeable) -import Control.DeepSeq+import           Data.FullList       (FullList, Listable (..), fromFL, sortNub)+import           NLP.GenI.ErrorIO    ()+import           NLP.GenI.General    (buckets, geniBug, maybeQuoteText)+import           NLP.GenI.GeniShow+import           NLP.GenI.Pretty -import Data.FullList ( FullList, fromFL, Listable(..), sortNub )-import NLP.GenI.General (geniBug, quoteText, isGeniIdentLetter)-import NLP.GenI.GeniShow-import NLP.GenI.Pretty+-- import Debug.Trace -- for test stuff --- | constant : no label, just constraints---   variable : label, with or without constraints---   anonymous : no label, no constraints-data GeniVal = GeniVal { gLabel       :: Maybe Text-                       , gConstraints :: Maybe (FullList Text)-                       }+-- | * constant : no label, just constraints+--+--   * variable : label, with or without constraints+--+--   * anonymous : no label, no constraints+data GeniVal = GeniVal+    { -- | Optional label (@?X@ would have @Just "X"@)+      gLabel       :: Maybe Text+    , -- | Optional values/constraints+      --   Must have at least one if at all+      --+      --   Though it may seem a bit redudant, this is not quite the same+      --   as having '[Text]' because @Nothing@ means no constraints;+      --   whereas @Just []@ (impossible here) would mean bottom.+      gConstraints :: Maybe (FullList Text)+    }   deriving (Eq,Ord, Data, Typeable)  -- | 'mkGConst' @x :! []@ creates a single constant.  'mkGConst' @x :! xs@@@ -58,15 +73,21 @@  where   cs = sortNub cs_ +-- | Create a singleton constant (no disjunction here) mkGConstNone :: Text -> GeniVal mkGConstNone x = mkGConst (x !: []) -mkGVar :: Text -> Maybe (FullList Text) -> GeniVal+-- | Create a variable+mkGVar :: Text                  -- ^ label+       -> Maybe (FullList Text) -- ^ constraints+       -> GeniVal mkGVar x mxs  = GeniVal (Just x) (sortNub `fmap` mxs) +-- | Create a variable with no constraints mkGVarNone :: Text -> GeniVal mkGVarNone x  = mkGVar x Nothing +-- | Create an anonymous value mkGAnon :: GeniVal mkGAnon       = GeniVal Nothing Nothing @@ -88,26 +109,16 @@                 showLabel l `T.append` "/" `T.append` showConstraints cs       where         showLabel l = '?' `T.cons` l-        showConstraints = T.intercalate "|" . map maybeQuote . fromFL -- FIXME push down-        maybeQuote x | T.null x        = quoteText ""-                     | "-" `T.isPrefixOf` x = quoteText x -- could be interpreted as-                     | "+" `T.isPrefixOf` x = quoteText x -- semantic polarities-                     | T.any naughty x = quoteText x-                     | otherwise       = x-        naughty x = not (isGeniIdentLetter x) || x `elem` "_?/"--isConst :: GeniVal -> Bool-isConst = isNothing . gLabel+        showConstraints = T.intercalate "|" . map maybeQuoteText . fromFL -- FIXME push down +-- | If @v@ has exactly one value/constraint, returns it singletonVal :: GeniVal -> Maybe Text singletonVal v =  case fmap fromFL (gConstraints v) of     Just [o] -> Just o     _        -> Nothing -isVar :: GeniVal -> Bool-isVar = isJust . gConstraints-+-- | An anonymous 'GeniVal' (@_@ or @?_@) has no labels/constraints isAnon :: GeniVal -> Bool isAnon (GeniVal Nothing Nothing) = True isAnon _     = False@@ -116,8 +127,11 @@ -- Helper types -- ---------------------------------------------------------------------- +-- | A variable substitution map.+--   GenI unification works by rewriting variables type Subst = Map.Map Text GeniVal +-- | For debugging prettySubst :: Subst -> Text prettySubst =     T.unwords . map sho . Map.toList@@ -128,20 +142,27 @@ -- Unification and subsumption -- ---------------------------------------------------------------------- +class (MonadPlus m, MonadError Text m, Monad m, Functor m) => MonadUnify m where++instance MonadUnify (Either Text) where+ -- | 'unify' performs unification on two lists of 'GeniVal'.  If --   unification succeeds, it returns @Just (r,s)@ where @r@ is --   the result of unification and \verb!s! is a list of substitutions that --   this unification results in.-unify :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)+unify :: MonadUnify m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) unify = unifyHelper unifyOne  -- | @l1 `allSubsume` l2@ returns the result of @l1 `unify` l2@ if --   doing a simultaneous traversal of both lists, each item in --   @l1@ subsumes the corresponding item in @l2@-allSubsume :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)+allSubsume :: MonadUnify m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) allSubsume = unifyHelper subsumeOne -unifyHelper :: Monad m+-- | @unifyHelper unf gs1 gs2@ zips two lists with some unification function.+--+--   It's meant to serve as a helper to 'unify' and 'allSubsume'+unifyHelper :: (MonadError Text m, Monad m)             => (GeniVal -> GeniVal -> UnificationResult)             -> [GeniVal]             -> [GeniVal]@@ -153,7 +174,7 @@   helper l1 [] = return (l1, Map.empty)   helper (h1:t1) (h2:t2) =     case f h1 h2 of-    Failure -> fail . T.unpack . T.unwords $+    Failure -> throwError . T.unwords $                    [ "unification failure between"                    , pretty h1, "and"                    , pretty h2@@ -213,10 +234,13 @@ -- TODO: would continuation passing style make this more efficient? -- ---------------------------------------------------------------------- -data UnificationResult = SuccessSans GeniVal-                       | SuccessRep  Text GeniVal-                       | SuccessRep2 Text Text GeniVal-                       | Failure+-- | Unification can either…+data UnificationResult =+      SuccessSans GeniVal      -- ^ succeed for free (no substitutions),+    | SuccessRep  Text GeniVal -- ^ succeed with a one-way substitution,+    | SuccessRep2 Text Text GeniVal -- ^ succeed w both vars needing substitution+                                    --   (constraint intersection),+    | Failure                       -- ^ or fail  -- | See source code for details --@@ -257,6 +281,11 @@         , prettyStr g2         ] +-- | @intersectConstraints (Just cs1) (Just cs2)@ returns the intersection of+--   @cs1@ and @cs2@ if non-empty (or 'Nothing' if there's nothing in common)+--+--   If any of the arguments is unconstrained (@Nothing@), we simply return+--   the other. intersectConstraints :: Eq a => Maybe (FullList a) -> Maybe (FullList a) -> Maybe (Maybe (FullList a)) intersectConstraints Nothing cs = Just cs intersectConstraints cs Nothing = Just cs@@ -280,13 +309,15 @@ subsumeOne g1@(GeniVal _ Nothing) g2 = unifyOne g1 g2  -- ------------------------------------------------------------------------- Variable substitution+-- * Variable substitution -- ---------------------------------------------------------------------- +-- | Apply variable substitutions replace :: DescendGeniVal a => Subst -> a -> a replace m | Map.null m = id replace m = descendGeniVal (replaceMapG m) +-- | Apply a single variable substitution replaceOne :: DescendGeniVal a => (Text, GeniVal) -> a -> a replaceOne = descendGeniVal . replaceOneG @@ -297,18 +328,23 @@   where    update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m +-- | Core implementation for 'replace'+--   For use by the Uniplate-esq 'descendGeniVal' replaceMapG :: Subst -> GeniVal -> GeniVal replaceMapG m v@(GeniVal (Just v_) _) = Map.findWithDefault v v_ m replaceMapG _ v = v +-- | Core implementation for 'replaceOne'+--   For use by the Uniplate-esq 'descendGeniVal' replaceOneG :: (Text, GeniVal) -> GeniVal -> GeniVal replaceOneG (s1, s2) (GeniVal (Just v_) _) | v_ == s1 = s2 replaceOneG _ v = v  -- ------------------------------------------------------------------------- Variable collection and renaming+-- * Variable collection and renaming -- ---------------------------------------------------------------------- +-- | A variable label and its constraints type CollectedVar = (Text, Maybe (FullList Text))  -- | A 'Collectable' is something which can return its variables as a@@ -325,6 +361,8 @@ --   around for a good bit, until either some use for it creeps up, or I find --   a more general notion that I can transform this into. class Collectable a where+  -- | @collect x m@ increments our count for any variables in @x@+  --   (adds not-yet-seen variables as needed)   collect :: a -> Map.Map CollectedVar Int -> Map.Map CollectedVar Int  instance Collectable a => Collectable (Maybe a) where@@ -343,7 +381,7 @@ --   Note that the only use I have for this so far (20 dec 2005) --  is in alpha-conversion. class Idable a where-  idOf :: a -> Integer+  idOf :: a -> Integer -- ^ the unique id  -- | Anonymise any variable that occurs only once in the object anonymiseSingletons :: (Collectable a, DescendGeniVal a) => a -> a@@ -355,7 +393,7 @@          . Map.fromListWith (+) . map (first fst) . Map.toList          $ collect x Map.empty --- 'finaliseVarsById' appends a unique suffix to all variables in+-- | 'finaliseVarsById' appends a unique suffix to all variables in -- an object.  This avoids us having to alpha convert all the time -- and relies on the assumption finding that a unique suffix is -- possible.@@ -367,35 +405,70 @@ --   * (if suffix is non-null) appends a suffix to all variable names --     to ensure global uniqueness -----   * anonymises any singleton variables--------   * intersects constraints for for all variables within the same----     object+--   * intersects constraints for for all variables within the same+--     object finaliseVars :: (Collectable a, DescendGeniVal a) => Text -> a -> a finaliseVars suffix x = {-# SCC "finaliseVars" #-}-  replace subst (anonymiseSingletons x)- where-   subst :: Subst-   subst = Map.mapWithKey convert vars-   vars  = Map.fromListWithKey isect $ Map.keys (collect x Map.empty)-   -- TODO: ugh: this is maybe not ideal: if a variable has impossible-   -- constraints (eg. ?X/cat cannot unify with ?X/dog, but it can-   -- unify with ?X/cat vs ?X/dog|cat => ?X/cat), we hardcode it to a-   -- value that should not be able to unify with anything-   isect k xi yi =-      fromMaybe (Just (impossibleC k)) $ intersectConstraints xi yi-   convert v = GeniVal (Just (v `T.append` suffix))-   impossibleC v =  ("ERROR_impossible_constraints_" `T.append` v `T.append` suffix)-                 !: []+    replace subst x+  where+    subst :: Subst+    subst = Map.mapWithKey convert vars+    vars  = Map.fromList+          $ map (second isect) . buckets fst+          $ Map.keys (collect x Map.empty)+    -- TODO: ugh: this is maybe not ideal: if a variable has impossible+    -- constraints (eg. ?X/cat cannot unify with ?X/dog, but it can+    -- unify with ?X/cat vs ?X/dog|cat => ?X/cat), we hardcode it to a+    -- value that should not be able to unify with anything+    isect :: [CollectedVar] -> Maybe (FullList Text)+    isect (map snd -> xs) =+       fromMaybe (Just (impossibleC xs)) $+          foldM intersectConstraints Nothing xs+    convert v = GeniVal (Just (v `T.append` suffix))+    -- try to generate something uniquely identifying for constraint+    -- clashes+    --+    impossibleC xs = (!: []) $ T.intercalate "_" $+        "ERROR_conflicting_constraints"+        : concatMap (maybe [] fromFL) xs ++ [suffix]  -- ------------------------------------------------------------------------- Fancy disjunction+-- * Fancy disjunction -- ---------------------------------------------------------------------- -crushOne :: [GeniVal] -> Maybe GeniVal-crushOne []   = Nothing-crushOne [gs] = Just gs-crushOne gs   =+-- | A schema value is a disjunction of GenI values.  It allows us to express+--   “fancy” disjunctions in tree schemata, ie. disjunctions over variables+--   and not just atoms (@?X;?Y@).+--+--   Our rule is that that when a tree schema is instantiated, any fancy+--   disjunctions must be “crushed” into a single 'GeniVal' lest it be+--   rejected (see 'crushOne')+--+--   Note that this is still not recursive; we don't have disjunction over+--   schema values, nor can schema values refer to schema values.  It just+--   allows us to express the idea that in tree schemata, you can have+--   either variable @?X@ or @?Y@.+newtype SchemaVal = SchemaVal [GeniVal]+  deriving (Eq, Ord)++instance Collectable SchemaVal where+    collect (SchemaVal xs) = collect xs++instance DescendGeniVal SchemaVal where+    descendGeniVal f (SchemaVal xs) = SchemaVal (descendGeniVal f xs)++instance GeniShow SchemaVal where+    geniShowText (SchemaVal xs) = T.intercalate ";" (map geniShowText xs)++-- | Convert a fancy disjunction (allowing disjunction over variables) value+--   into a plain old atomic disjunction. The idea is to support a limited+--   notion of fancy disjunction by requiring that there be a single point+--   where this disjunction can be converted into a plain old variable.+--   Note that we currently convert these to constants only.+crushOne :: SchemaVal -> Maybe GeniVal+crushOne (SchemaVal [])   = Nothing+crushOne (SchemaVal [gs]) = Just gs+crushOne (SchemaVal gs)   =   if any isNothing gcs      then Nothing      else case concat [ fromFL c | Just c <- gcs ] of@@ -404,14 +477,21 @@   where    gcs = map gConstraints gs -crushList :: [[GeniVal]] -> Maybe [GeniVal]+-- | Convert a list of fancy disjunctions+crushList :: [SchemaVal] -> Maybe [GeniVal] crushList = mapM crushOne  -- ------------------------------------------------------------------------- Genericity+-- * Genericity -- ---------------------------------------------------------------------- +-- | A structure that can be traversed with a 'GeniVal'-replacing+--   function (typical use case: substitution after unification)+--+--   Approach suggested by Neil Mitchell after I found that Uniplate+--   seemed to hurt GenI performance a bit. class DescendGeniVal a where+  -- | @descendGeniVal f x@ applies @f@ to all 'GeniVal' in @x@   descendGeniVal :: (GeniVal -> GeniVal) -> a -> a  instance DescendGeniVal GeniVal where@@ -423,6 +503,13 @@ instance NFData GeniVal where   rnf (GeniVal x y) = rnf x `seq` rnf y +instance NFData SchemaVal where+    rnf (SchemaVal x) = rnf x+ instance Binary GeniVal where   put (GeniVal a b) = put a >> put b   get = get >>= \a -> get >>= \b -> return (GeniVal a b)++instance Binary SchemaVal where+    put (SchemaVal x) = put x+    get = SchemaVal <$> get

@@ -17,73 +17,102 @@  -- | This module performs the core of lexical selection and anchoring. {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}+ module NLP.GenI.LexicalSelection-where+  where -import Control.Applicative ( (<$>) )-import Control.Arrow ((***))-import Control.Monad.Maybe-import Control.Monad.Writer-import Data.Function ( on )-import Data.List-import qualified Data.Map as Map-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)-import Data.Tree (Tree(Node))-import qualified Data.Text as T-import Data.Text ( Text )+import           Control.Applicative             ((<$>))+import           Control.Arrow                   ((***))+import           Control.Monad.Trans.Maybe+import           Control.Monad.Writer+import           Data.Function                   (on)+import           Data.List+import qualified Data.Map                        as Map+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Data.Tree                       (Tree (Node)) -import Data.FullList hiding ( head, tail, (++) )-import qualified Data.FullList as FL+import           Control.Error+import           Data.FullList                   hiding (head, tail, (++))+import qualified Data.FullList                   as FL -import NLP.GenI.FeatureStructure (Flist, AvPair(..), unifyFeat)-import NLP.GenI.General-    ( filterTree, repAllNode, histogram, geniBug, repNodeByNode,-    )-import NLP.GenI.GeniVal( unify, GeniVal(gConstraints), isConst, Subst, replace, finaliseVars )-import NLP.GenI.LexicalSelection.Types-import NLP.GenI.Lexicon ( LexEntry(..), Lexicon, )-import NLP.GenI.Semantics ( subsumeSem, unifySem, Sem )-import NLP.GenI.Tag ( TagElem(..), idname )-import NLP.GenI.TreeSchema ( Ttree(..), SchemaTree, SchemaNode, Macros-                           , crushTreeGNode-                           , setAnchor, setLexeme, tree-                           , GNode(..), GType(..)-                           )-import NLP.GenI.Warning+import           NLP.GenI.FeatureStructure       (AvPair (..), Flist, unifyFeat)+import           NLP.GenI.General                (filterTree, geniBug,+                                                  histogram, repAllNode,+                                                  repNodeByNode)+import           NLP.GenI.GeniVal+import           NLP.GenI.LexicalSelection.Types+import           NLP.GenI.Lexicon                (LexEntry (..), Lexicon)+import           NLP.GenI.Semantics              (LitConstr, Sem, SemInput,+                                                  subsumeSem, unifySem)+import           NLP.GenI.Tag                    (TagElem (..), idname)+import           NLP.GenI.TestSuite+import           NLP.GenI.TreeSchema             (GNode (..), GType (..),+                                                  AdjunctionConstraint(..),+                                                  Macros, SchemaTree,+                                                  Ttree (..), crushTreeGNode,+                                                  setAnchor, setLexeme, tree)+import           NLP.GenI.Warning  -- ---------------------------------------------------------------------- -- * Lexical selection algorithms -- ----------------------------------------------------------------------+-- | This aims to support users who want to do lexical selection+--   directly from an input other than GenI style flat semantics.+--+--   The requirement here is for you to provide some means of+--   converting the custom semantics to a GenI semantics+data CustomSem sem = CustomSem+    { -- | Conversion from custom semantics to GenI semantic input+      fromCustomSemInput :: sem  -> Either Text SemInput+      -- | Lexical selection function+    , customSelector     :: LexicalSelector sem+    , customSemParser    :: Text -> Either Text (TestCase sem)+      -- | List of named inputs intended to act as a substitute for+      --   test suites+      --   ('FilePath' argument is for reporting error messages only)+    , customSuiteParser  :: FilePath -> Text -> Either Text [TestCase sem]+    , customRenderSem    :: sem -> Text+    }  -- | See 'NLP.GenI.Configuration' if you want to use GenI with a custom --   lexical selection function.-type LexicalSelector = Macros -> Lexicon -> Sem -> IO LexicalSelection+type LexicalSelector sem = Macros -> Lexicon -> sem -> IO LexicalSelection  -- | The result of the lexical selection process data LexicalSelection = LexicalSelection-      { -- | the main result: a set of elementary trees (ie. anchored trees)-        lsAnchored   :: [TagElem]-        -- | if available, lexical entries that were used to produce anchored-        --   trees (useful for identifying anchoring failure)-      , lsLexEntries :: [LexEntry]-        -- | HINT: use 'Data.Monoid.mempty' to initialise to empty-      , lsWarnings   :: GeniWarnings-      }+    { -- | the main result: a set of elementary trees (ie. anchored trees)+      lsAnchored   :: [TagElem]+      -- | if available, lexical entries that were used to produce anchored+      --   trees (useful for identifying anchoring failure)+    , lsLexEntries :: [LexEntry]+      -- | HINT: use 'Data.Monoid.mempty' to initialise to empty+    , lsWarnings   :: GeniWarnings+    }  -- | Performs standard GenI lexical selection as described in --   <http://projects.haskell.org/GenI/manual/lexical-selection.html> -- --   This is just 'defaultLexicalSelection' lifted into IO-defaultLexicalSelector :: Macros -> Lexicon -> Sem -> IO LexicalSelection+defaultLexicalSelector :: Macros -> Lexicon -> SemInput -> IO LexicalSelection defaultLexicalSelector g l t = return (defaultLexicalSelection g l t)  -- | Helper for 'defaultLexicalSelector' --   (Standard GenI lexical selection is actually pure) -----   This is just 'defaultLexicalChoice' and 'defaultAnchoring'-defaultLexicalSelection :: Macros -> Lexicon -> Sem -> LexicalSelection-defaultLexicalSelection grammar lexicon tsem =-  defaultAnchoring grammar (defaultLexicalChoice lexicon tsem) tsem+--   This is just+--+--   * 'defaultLexicalChoice'+--+--   * 'defaultAnchoring'+--+--   * 'defaultPostProcessing'+defaultLexicalSelection :: Macros -> Lexicon -> SemInput -> LexicalSelection+defaultLexicalSelection grammar lexicon sem =+    defaultPostProcessing sem $+    defaultAnchoring      sem grammar $+    defaultLexicalChoice lexicon sem  -- | @missingLexEntries ts lexs@ returns any of the lexical candidates --   @lexs@ that were apparently not anchored succesfully.@@ -95,9 +124,10 @@ --   because it's possible for the trees to add semantics through --   unification. missingLexEntries :: [TagElem] -> [LexEntry] -> [LexEntry]-missingLexEntries cands = filter treeless- where-  treeless l = isNothing $ find (\t -> tsemantics t == isemantics l) cands+missingLexEntries cands =+    filter treeless+  where+    treeless l = isNothing $ find (\t -> tsemantics t == isemantics l) cands  -- ---------------------------------------------------------------------- -- * Selecting candidate lemmas@@ -105,41 +135,47 @@  -- | Select and returns the set of entries from the lexicon whose semantics --   subsumes the input semantics.-defaultLexicalChoice :: Lexicon -> Sem -> [LexEntry]-defaultLexicalChoice slex tsem = chooseCandI tsem slex+defaultLexicalChoice :: Lexicon -> SemInput -> [LexEntry]+defaultLexicalChoice slex (tsem,_,_) = chooseCandI tsem slex  -- | 'chooseCandI' @sem l@ attempts to unify the semantics of @l@ with @sem@ --   If this succeeds, we use return the result(s); if it fails, we reject --   @l@ as a lexical selection candidate. chooseCandI :: Sem -> [LexEntry] -> [LexEntry] chooseCandI tsem cand =-  let replaceLex i (sem,sub) =+    nub $ concatMap helper cand+  where+    replaceLex i (sem,sub) =         (replace sub i) { isemantics = sem }-      ---      helper :: LexEntry -> [LexEntry]-      helper l = if null sem then [l]-                 else map (replaceLex l) psubsem-        where psubsem = sem `subsumeSem` tsem-              sem = isemantics l-      ---  in nub $ concatMap helper cand+    --+    helper :: LexEntry -> [LexEntry]+    helper l =+        if null sem+            then [l]+            else map (replaceLex l) psubsem+      where+        psubsem = sem `subsumeSem` tsem+        sem = isemantics l  -- | `mergeSynonyms' is a factorisation technique that uses --   atomic disjunction to merge all synonyms into a single lexical --   entry.  Two lexical entries are considered synonyms if their --   semantics match and they point to the same tree families.--- +-- --  FIXME: 2006-10-11 - note that this is no longer being used, --  because it breaks the case where two lexical entries differ --  only by their use of path equations.  Perhaps it's worthwhile --  just to add a check that the path equations match exactly. mergeSynonyms :: [LexEntry] -> [LexEntry] mergeSynonyms lexEntry =-  let mergeFn l1 l2 = l1 { iword = (FL.++) (iword l1) (iword l2) }-      keyFn l = (ifamname l, isemantics l)-      synMap = foldr helper Map.empty lexEntry-        where helper x acc = Map.insertWith mergeFn (keyFn x) x acc-  in Map.elems synMap+    Map.elems synMap+  where+    mergeFn l1 l2 = l1 { iword = (FL.++) (iword l1) (iword l2) }+    keyFn l = (ifamname l, isemantics l)+    synMap  =+        foldr helper Map.empty lexEntry+      where+        helper x acc = Map.insertWith mergeFn (keyFn x) x acc  -- -------------------------------------------------------------------- -- * Anchoring@@ -149,6 +185,9 @@ --   and also failure via Maybe type LexCombine a = MaybeT (Writer [LexCombineError]) a +runLexCombine :: LexCombine a -> (Maybe a, [LexCombineError])+runLexCombine = runWriter . runMaybeT+ -- | Note an anchoring error lexTell :: LexCombineError -> LexCombine () lexTell x = lift (tell [x])@@ -160,26 +199,26 @@ -- --   This function may be useful if you are implementing your own lexical selection --   functions, and you want GenI to take over after you've given it a @[LexEntry]@-defaultAnchoring :: Macros -> [LexEntry] -> Sem -> LexicalSelection-defaultAnchoring grammar lexCands tsem =-  LexicalSelection { lsAnchored   = cands-                   , lsLexEntries = lexCands-                   , lsWarnings   = mconcat [ lexWarnings, coanchorWarnings, errs ]-                   }- where-  combinations  = map (combineList tsem grammar) lexCands-  cands         = concatMap snd combinations-  errs          = mkGeniWarnings . concat $ zipWith mkWarnings lexCands (map fst combinations)-  mkWarnings l  = map (LexWarning [l] . LexCombineOneSchemaFailed)-  coanchorWarnings = mkGeniWarnings $ do -- list monad-    l     <- lexCands-    let xs = filter (\p -> pfamily p == ifamname l) grammar-    (c,n) <- Map.toList . histogram $ concatMap (missingCoanchors l) xs-    return (LexWarning [l] (MissingCoanchors c n))-  lexWarnings = mkGeniWarnings $ case missingLexEntries cands lexCands of-                  [] -> []-                  xs -> [LexWarning xs LexCombineAllSchemataFailed]-+defaultAnchoring :: SemInput -> Macros -> [LexEntry] -> LexicalSelection+defaultAnchoring (tsem,_,_) grammar lexCands = LexicalSelection+    { lsAnchored   = cands+    , lsLexEntries = lexCands+    , lsWarnings   = mconcat [ lexWarnings, coanchorWarnings, errs ]+    }+  where+    combinations  = map (combineList tsem grammar) lexCands+    cands         = concatMap snd combinations+    errs          = mkGeniWarnings . concat $ zipWith mkWarnings lexCands (map fst combinations)+    mkWarnings l  = map (LexWarning [l] . LexCombineOneSchemaFailed)+    coanchorWarnings = mkGeniWarnings $ do -- list monad+        l     <- lexCands+        let xs = filter (\p -> pfamily p == ifamname l) grammar+        (c,n) <- Map.toList . histogram $ concatMap (missingCoanchors l) xs+        return (LexWarning [l] (MissingCoanchors c n))+    lexWarnings = mkGeniWarnings $+        case missingLexEntries cands lexCands of+            [] -> []+            xs -> [LexWarning xs LexCombineAllSchemataFailed]  -- ---------------------------------------------------------------------- -- ** Combination@@ -190,20 +229,20 @@ combineList :: Sem -> Macros -> LexEntry             -> ([LexCombineError],[TagElem]) -- ^ any warnings, plus the results combineList tsem gram lexitem =-  case [ t | t <- gram, pfamily t == tn ] of-       []   -> ([FamilyNotFoundError tn],[])-       macs -> squish . swap . unzip $ map (\m -> runWriter . runMaybeT $ combineOne tsem lexitem m) macs+    case [ t | t <- gram, pfamily t == tn ] of+        []   -> ([FamilyNotFoundError tn],[])+        macs -> squish . swap . unzip $ map (\m -> runLexCombine $ combineOne tsem lexitem m) macs   where-   tn = ifamname lexitem-   swap (x,y) = (y,x)-   squish = (compressLexCombineErrors . concat) *** (concat . catMaybes)+    tn = ifamname lexitem+    swap (x,y) = (y,x)+    squish = (compressLexCombineErrors . concat) *** (concat . catMaybes)  -- | Combine a single tree with its lexical item to form a bonafide TagElem. --   This process can fail, however, because of filtering or enrichement combineOne :: Sem -> LexEntry -> SchemaTree -> LexCombine [TagElem]-combineOne tsem lexRaw eRaw = -- Maybe monad- -- trace ("\n" ++ (show wt)) $- do let l1 = finaliseVars "-l" lexRaw+combineOne tsem lexRaw eRaw = do -- Maybe monad+    -- trace ("\n" ++ (show wt)) $+    let l1 = finaliseVars "-l" lexRaw         e1 = finaliseVars "-t" eRaw     (l,e) <- unifyParamsWithWarning (l1,e1)              >>= unifyInterfaceUsing iinterface@@ -229,38 +268,40 @@               , ttrace      = ptrace e               }     semUnifications <- case unifySem (isemantics l) (fromMaybe [] $ psemantics e) of-                         [] -> do lexTell (SchemaError [pidname e] (StringError "could not unify lemma and schema semantics"))-                                  fail ""-                         xs -> return xs-    return $ concatMap (finaliseSemantics template) semUnifications- where-  croak t msg = do-      lexTell (SchemaError [pidname t] (StringError msg))-      fail ""-  finaliseSemantics template (sem,sub) =-    do (sem2,sub2) <- sem `subsumeSem` replace sub tsem-       return $ replace sub2 $ template { tsemantics = sem2 }-  unifyParamsWithWarning (l,t) =-   -- trace ("unify params " ++ wt) $-   let lp = iparams l+                           [] -> croak e "could not unify lemma and schema semantics"+                           xs -> return xs+    return $ concatMap (anonymiseSingletons . finaliseSemantics template) semUnifications+  where+    croak :: SchemaTree -> Text -> LexCombine a+    croak t msg = do+        lexTell (SchemaError [pidname t] (StringError msg))+        mzero+    finaliseSemantics template (sem,sub) = do+        let template2 = replace sub template+        (sem2,sub2) <- sem `subsumeSem` replace sub tsem+        return $ replace sub2 $ template2 { tsemantics = sem2 }+    unifyParamsWithWarning (l,t) =+        if length lp /= length tp+            then croak t "Parameter length mismatch"+            else case unify lp tp of+                     Left msg           ->+                         croak t ("Parameter unification error: " <> msg)+                     Right (ps2, subst) ->+                         let t2 = (replace subst t) { params = ps2 }+                         in return (replace subst l, t2)+     where+       lp = iparams l        tp = params t-   in if length lp /= length tp-      then croak t "Parameter length mismatch"-      else case unify lp tp of-             Nothing -> croak t "Parameter unification error"-             Just (ps2, subst) -> return (replace subst l, t2)-                                  where t2 = (replace subst t) { params = ps2 }-  unifyInterfaceUsing ifn (l,e) =-    -- trace ("unify interface" ++ wt) $-    case unifyFeat (ifn l) (pinterface e) of-    Nothing             -> croak e "Interface unification error"-    Just (int2, fsubst) -> return (replace fsubst l, e2)-                           where e2 = (replace fsubst e) { pinterface = int2 }-  ---  enrichWithWarning (l,e) =-    -- trace ("enrich" ++ wt) $-    do e2 <- enrich l e-       return (l,e2)+    unifyInterfaceUsing ifn (l,e) =+        -- trace ("unify interface" ++ wt) $+        case unifyFeat (ifn l) (pinterface e) of+            Left msg             ->+                 croak e ("Interface unification error: " <> msg)+            Right (int2, fsubst) ->+                 let e2 = (replace fsubst e) { pinterface = int2 }+                 in  return (replace fsubst l, e2)+    --+    enrichWithWarning (l,e) = (l,) <$>  enrich l e  -- ---------------------------------------------------------------------- -- ** Enrichment@@ -269,20 +310,20 @@ -- | See <http://projects.haskell.org/manual/lexical-selection> --   on enrichement enrich :: LexEntry -> SchemaTree -> LexCombine SchemaTree-enrich l t =- do -- separate into interface/anchor/named+enrich l t = do+    -- separate into interface/anchor/named     (intE, namedE) <- lift $ lexEquations l     -- enrich the interface and everything else     t2 <- foldM enrichInterface t intE     -- enrich everything else     foldM enrichBy t2 namedE- where-  enrichInterface tx en =-    case unifyFeat [en] (pinterface tx) of-      Nothing -> lexTell (ifaceEnrichErr en) >> fail ""-      Just (i2, isubs) -> return $ (replace isubs tx) { pinterface = i2 }-  ifaceEnrichErr (AvPair loc _) =-       SchemaError [pidname t] (EnrichError (PeqInterface loc))+  where+    enrichInterface tx en =+        case hush (unifyFeat [en] (pinterface tx)) of+            Nothing -> lexTell (ifaceEnrichErr en) >> fail ""+            Just (i2, isubs) -> return $ (replace isubs tx) { pinterface = i2 }+    ifaceEnrichErr (AvPair loc _) =+        SchemaError [pidname t] (EnrichError (PeqInterface loc))  -- *** 'enrich' helpers @@ -291,33 +332,34 @@          -> PathEqPair          -> LexCombine SchemaTree enrichBy t eq@(eqLhs, _) =-  case maybeEnrichBy t eq of-    Nothing -> lexTell enrichErr >> return t-    Just (t2,_) -> return t2- where-  enrichErr = SchemaError [pidname t] (EnrichError (PeqJust eqLhs))+    case maybeEnrichBy t eq of+        Nothing     -> lexTell enrichErr >> return t+        Just (t2,_) -> return t2+  where+    enrichErr = SchemaError [pidname t] (EnrichError (PeqJust eqLhs))  -- | Helper for 'enrichBy' maybeEnrichBy :: SchemaTree               -> PathEqPair               -> Maybe (SchemaTree, Subst) maybeEnrichBy t (eqLhs, eqVal) = do-  node <- seekCoanchor eqLhs t-  case eqLhs of-    PeqFeat _ eqTop eqAtt -> do-      let (get, set) = case eqTop of-                         Top     -> (gup,   \n x -> n { gup = x })-                         Bottom  -> (gdown, \n x -> n { gdown = x})-      (fs, sub) <- enrichFeat (AvPair eqAtt eqVal) (get node)-      let t2 = fixNode (set node fs) (replace sub t)-      return (t2, sub)-    PeqLex _ -> do-       vs <- gConstraints eqVal-       let node2 = node { glexeme = FL.fromFL vs }-           t2    = fixNode node2 t-       return (t2, Map.empty)- where-  fixNode n mt = mt { tree = repNodeByNode (matchNodeName eqLhs) n (tree mt) }+    node <- seekCoanchor eqLhs t+    case eqLhs of+        PeqFeat _ eqTop eqAtt -> do+            let (get, set) = case eqTop of+                               Top     -> (gup,   \n x -> n { gup = x })+                               Bottom  -> (gdown, \n x -> n { gdown = x})+            (fs, sub) <- hush $ enrichFeat (AvPair eqAtt eqVal) (get node)+            let t2 = fixNode (set node fs) (replace sub t)+            return (t2, sub)+        PeqLex _ -> do+             vs <- gConstraints eqVal+             let node2 = node { glexeme = FL.fromFL vs }+                 t2    = fixNode node2 t+             return (t2, Map.empty)+  where+    fixNode n mt =+        mt { tree = repNodeByNode (matchNodeName eqLhs) n (tree mt) }  -- | @enrichFeat av fs@ attempts to unify @av@ with @fs@ --@@ -326,48 +368,52 @@ --   'SchemaTree' which allows non-atomic disjunctions of @GeniVal@ --   which have to be flatten down to at most atomic disjunctions once --   lexical selection is complete.-enrichFeat :: AvPair GeniVal -> Flist [GeniVal] -> Maybe (Flist [GeniVal], Subst)+enrichFeat :: MonadUnify m+           => AvPair GeniVal+           -> Flist SchemaVal+           -> m (Flist SchemaVal, Subst) enrichFeat (AvPair a v) fs =-  case span (\x -> avAtt x < a) fs of-    (before,here:after) | avMatch here ->-      do let (AvPair _ fv) = here-         (v2,sub) <- unify fv (replicate (length fv) v)-         let av2 = AvPair a v2-             fs2 = replace sub before ++ (av2 : replace sub after)-         return (fs2, sub)-    (before,after) ->-      let av2 = AvPair a [v]-          fs2 = before ++ (av2 : after) in  Just (fs2, Map.empty)+    case span (\x -> avAtt x < a) fs of+        (before,here:after) | avMatch here -> do+             let (AvPair _ (SchemaVal fv)) = here+             (v2,sub) <- unify fv (replicate (length fv) v)+             let av2 = AvPair a (SchemaVal v2)+                 fs2 = replace sub before ++ (av2 : replace sub after)+             return (fs2, sub)+        (before,after) -> do+             let av2 = AvPair a (SchemaVal [v])+                 fs2 = before ++ (av2 : after)+             return (fs2, Map.empty)   where-   avMatch (AvPair fa _) = fa == a+    avMatch (AvPair fa _) = fa == a  -- | @missingCoanchors l t@ returns the list of coanchor node names from @l@ --   that were not found in @t@ missingCoanchors :: LexEntry -> SchemaTree -> [Text] missingCoanchors lexEntry t =-   [ name eqLhs | eqLhs <- nubBy ((==) `on` name) equations, missing eqLhs ]- where-   equations = map fst . snd . fst . runWriter $ lexEquations lexEntry-   name (PeqFeat n _ _) = n-   name (PeqLex  n)     = n-   missing eqLhs = isNothing (seekCoanchor eqLhs t)+    [ name eqLhs | eqLhs <- nubBy ((==) `on` name) equations, missing eqLhs ]+  where+    equations = map fst . snd . fst . runWriter $ lexEquations lexEntry+    name (PeqFeat n _ _) = n+    name (PeqLex  n)     = n+    missing eqLhs = isNothing (seekCoanchor eqLhs t)  -- | Split a lex entry's path equations into interface enrichement equations --   or (co-)anchor modifiers lexEquations :: LexEntry -> Writer [LexCombineError] ([AvPair GeniVal],[PathEqPair]) lexEquations =-  fmap myPartition . mapM parseAv . iequations+    fmap myPartition . mapM parseAv . iequations   where-   myPartition xs = ( [ AvPair a v | (PeqInterface a, v) <- xs ]-                    , [ (n,v)      | (PeqJust n, v)      <- xs ] )-   parseAv (AvPair a v) = fmap (\a2 -> (a2,v)) (parsePathEq a)+    myPartition xs = ( [ AvPair a v | (PeqInterface a, v) <- xs ]+                     , [ (n,v)      | (PeqJust n, v)      <- xs ] )+    parseAv (AvPair a v) = fmap (\a2 -> (a2,v)) (parsePathEq a)  -- | @seekCoanchor lhs t@ returns @Just node@ if @t@ contains exactly one --   node that can be identified by @lhs@, @Nothing@ if it contains none. -- --   It crashes if there is more than one such node, because this should --   have been caught earlier by GenI.-seekCoanchor :: NodePathEqLhs -> SchemaTree -> Maybe SchemaNode+seekCoanchor :: NodePathEqLhs -> SchemaTree -> Maybe (GNode SchemaVal) seekCoanchor eqLhs t =    case filterTree (matchNodeName eqLhs) (tree t) of         [a] -> Just a@@ -381,13 +427,13 @@             ]  -- | @matchNodeName lhs n@ is @True@ if the @lhs@ refers to the node @n@-matchNodeName :: NodePathEqLhs -> SchemaNode -> Bool+matchNodeName :: NodePathEqLhs -> GNode SchemaVal -> Bool matchNodeName (PeqFeat n _ _) = matchNodeNameHelper n matchNodeName (PeqLex n)      = matchNodeNameHelper n  -- | @matchNodeNameHelper@ recognises “anchor“ by convention; otherwise, --   it does a name match-matchNodeNameHelper :: Text -> SchemaNode -> Bool+matchNodeNameHelper :: Text -> GNode SchemaVal -> Bool matchNodeNameHelper "anchor" = ganchor matchNodeNameHelper n        = (== n) . gnname @@ -404,7 +450,7 @@     filt (Node a []) = gtype a == Subs && (isJust. lemAnchor) a     filt _           = False     fn (Node x k) = setLexeme (lemAnchorMaybeFake x) $-        Node (x { gtype = Other, gaconstr = False }) k+        Node (x { gtype = Other, gaconstr = MaybeAdj }) k     --     lemAnchorMaybeFake :: GNode GeniVal -> [Text]     lemAnchorMaybeFake n =@@ -412,8 +458,8 @@     lemAnchor :: GNode GeniVal -> Maybe [Text]     lemAnchor n =         case [ v | AvPair a v <- gup n, a == _lemanchor ] of-            [l] | isConst l -> fromFL <$> gConstraints l-            _               -> Nothing+            [l] -> fromFL <$> gConstraints l+            _   -> Nothing  -- | The name of the lemanchor attribute (by convention; see source) _lemanchor :: Text@@ -423,3 +469,29 @@ --   a tree named @n@ setOrigin :: Text -> Tree (GNode v) -> Tree (GNode v) setOrigin t = fmap (\g -> g { gorigin = t })++-- ----------------------------------------------------------------------+-- * Post-processing+-- ----------------------------------------------------------------------++-- | Standard post-processing/filtering steps that can take place+--   after lexical selection.  Right now, this only consists of+--   paraphrase selection+defaultPostProcessing :: SemInput -> LexicalSelection -> LexicalSelection+defaultPostProcessing (_,_,lc) sel = sel+    { lsAnchored = preselectParaphrases lc (lsAnchored sel) }++-- ----------------------------------------------------------------------+-- ** Paraphrase selection+-- ----------------------------------------------------------------------++-- | Rule out lexical selection results that violate trace constraints+preselectParaphrases :: [LitConstr] -> [TagElem] -> [TagElem]+preselectParaphrases litContrs = filter (respectsConstraints litContrs)++-- | 'True' if the tree fulfills the supplied trace constraints+respectsConstraints :: [LitConstr] -> TagElem -> Bool+respectsConstraints lc t =+    all (`elem` ttrace t) constrs+  where+    constrs = concat [ cs | (l,cs) <- lc, l `elem` tsemantics t ]

@@ -19,15 +19,15 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.GenI.LexicalSelection.Types where -import Control.Monad.Writer-import Data.List-import Data.Poset-import Data.Text ( Text )-import qualified Data.Map as Map-import qualified Data.Text as T+import           Control.Monad.Writer+import           Data.List+import qualified Data.Map             as Map+import           Data.Poset+import           Data.Text            (Text)+import qualified Data.Text            as T -import NLP.GenI.GeniVal-import NLP.GenI.Pretty+import           NLP.GenI.GeniVal+import           NLP.GenI.Pretty  -- | Left hand side of a path equation data PathEqLhs = PeqInterface   Text

@@ -15,6 +15,12 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. +-- | Lexical entries+--+--   As a factorisation technique, LTAG grammars are commonly separated into+--   tree schemata (see 'NLP.GenI.TreeSchema') and lexical entries.  The+--   grammar is what you get by “anchoring” each lexical entry to the relevant+--   tree schemata. module NLP.GenI.Lexicon (    Lexicon,    -- anything but the constructor@@ -24,4 +30,4 @@    PolValue, fromLexSem, fromLexLiteral, ) where -import NLP.GenI.Lexicon.Internal+import           NLP.GenI.Lexicon.Internal

@@ -15,44 +15,50 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+-- | Internals of lexical entry manipulation module NLP.GenI.Lexicon.Internal where  -- import Debug.Trace -- for test stuff-import Data.Binary-import Data.FullList-import Data.Function-import Data.List ( sortBy )-import Data.Generics (Data)-import Data.Text ( Text )-import Data.Typeable (Typeable)-import qualified Data.Text as T+import           Data.Binary+import           Data.FullList+import           Data.Function+import           Data.Generics             (Data)+import           Data.List                 (sortBy)+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Typeable             (Typeable) -import NLP.GenI.FeatureStructure-import NLP.GenI.GeniShow-import NLP.GenI.GeniVal-import NLP.GenI.Pretty-import NLP.GenI.Semantics-import NLP.GenI.Polarity.Types (SemPols)+import           NLP.GenI.FeatureStructure+import           NLP.GenI.GeniShow+import           NLP.GenI.GeniVal+import           NLP.GenI.Polarity.Types   (SemPols)+import           NLP.GenI.Pretty+import           NLP.GenI.Semantics -import Control.DeepSeq+import           Control.DeepSeq  --instance Show (IO()) where --  show _ = "" +-- | Collection of lexical entries type Lexicon = [LexEntry]++-- | Lexical entry data LexEntry = LexEntry-    { -- normally just a singleton, useful for merging synonyms-      iword       :: FullList Text-    , ifamname    :: Text-    , iparams     :: [GeniVal]-    , iinterface  :: Flist GeniVal-    , ifilters    :: Flist GeniVal-    , iequations  :: Flist GeniVal-    , isemantics  :: Sem-    , isempols    :: [SemPols] }+    { iword      :: FullList Text -- ^ normally just a singleton,+                                   --   useful for merging synonyms+    , ifamname   :: Text          -- ^ tree family to anchor to+    , iparams    :: [GeniVal]     -- ^ parameters (deprecrated; use the interface)+    , iinterface :: Flist GeniVal -- ^ features to unify with tree schema interface+    , ifilters   :: Flist GeniVal -- ^ features to pick out family members we want+    , iequations :: Flist GeniVal -- ^ path equations+    , isemantics :: Sem           -- ^ lexical semantics+    , isempols   :: [SemPols]     -- ^ polarities (must be same length as 'isemantics')+    }   deriving (Eq, Data, Typeable)  -- | See also 'mkFullLexEntry'@@ -119,6 +125,10 @@ --   on polarity filtering for more details type PolValue = (GeniVal, Int) +-- | Separate an input lexical semantics into the actual semantics+--   and the semantic polarity entries (which aren't used very much+--   in practice, being a sort of experimental feature to solve an+--   obscure-ish technical problem) fromLexSem :: [Literal PolValue] -> (Sem, [SemPols]) fromLexSem = unzip . map fromLexLiteral @@ -147,7 +157,7 @@         , geniKeyword "filters"   $ geniShowText (ifilters l)         , geniKeyword "semantics" $ geniShowText (isemantics l)         ]-      where +      where         paramT = parens . T.unwords . concat $             [ map geniShowText (iparams l)             , ["!"]@@ -171,7 +181,7 @@  -- GENERATED START - + instance Binary LexEntry where         put (LexEntry x1 x2 x3 x4 x5 x6 x7 x8)           = do put x1@@ -193,7 +203,7 @@                x8 <- get                return (LexEntry x1 x2 x3 x4 x5 x6 x7 x8) - + instance NFData LexEntry where         rnf (LexEntry x1 x2 x3 x4 x5 x6 x7 x8)           = rnf x1 `seq`

@@ -18,41 +18,45 @@ {-# LANGUAGE CPP #-} module NLP.GenI.Main where -import Control.Applicative ((<$>))-import Data.IORef(newIORef)-import Data.Typeable( Typeable )-import Data.Version ( showVersion )-import System.Environment(getArgs, getProgName)+import           Control.Applicative       ((<$>))+import           Data.IORef                (newIORef)+import           Data.Typeable             (Typeable)+import           Data.Version              (showVersion)+import           System.Environment        (getArgs, getProgName) -import Paths_GenI ( version )+import           Paths_GenI                (version) -import NLP.GenI.Console(consoleGeni)-import NLP.GenI.Configuration (treatArgs, optionsForStandardGenI, processInstructions,-                               usage, optionsSections, Params,-                               hasFlagP, DisableGuiFlg(..),-                               HelpFlg(..), VersionFlg(..),-                               readGlobalConfig, setLoggers-                              )-import NLP.GenI.Configuration(setFlagP)-import NLP.GenI ( ProgState(..), emptyProgState )+import           NLP.GenI                  (ProgState (..), defaultCustomSem,+                                            emptyProgState)+import           NLP.GenI.Flag+import           NLP.GenI.Configuration    (Params,+                                            optionsForStandardGenI,+                                            optionsSections,+                                            processInstructions,+                                            readGlobalConfig,+                                            setLoggers, treatArgs, usage)+import           NLP.GenI.Console          (consoleGeni)+import           NLP.GenI.LexicalSelection (CustomSem (..))  main :: IO () main = do-  args  <- getArgs-  confArgs <- forceGuiFlag <$> (processInstructions =<< treatArgs optionsForStandardGenI args)-  mainWithState (emptyProgState confArgs)+    args  <- getArgs+    confArgs <- forceGuiFlag <$> (processInstructions =<< treatArgs optionsForStandardGenI args)+    let pst = emptyProgState confArgs+    wrangler <- defaultCustomSem pst+    mainWithState pst wrangler -mainWithState :: ProgState -> IO ()-mainWithState pst = do-  pname <- getProgName-  maybe (return ()) setLoggers =<< readGlobalConfig-  pstRef <- newIORef pst-  let has :: (Typeable f, Typeable x) => (x -> f) -> Bool-      has = flip hasFlagP (pa pst)-  case () of-   _ | has HelpFlg               -> putStrLn (usage optionsSections pname)-     | has VersionFlg            -> putStrLn (pname ++ " " ++ showVersion version)-     | otherwise                 -> consoleGeni pstRef+mainWithState :: ProgState -> CustomSem sem -> IO ()+mainWithState pst wrangler = do+    maybe (return ()) setLoggers =<< readGlobalConfig+    pname <- getProgName+    let has :: (Typeable f, Typeable x) => (x -> f) -> Bool+        has = flip hasFlag pst+    pstRef <- newIORef pst+    case () of+        _ | has HelpFlg               -> putStrLn (usage optionsSections pname)+          | has VersionFlg            -> putStrLn (pname ++ " " ++ showVersion version)+          | otherwise                 -> consoleGeni pstRef wrangler  forceGuiFlag :: Params -> Params-forceGuiFlag = setFlagP DisableGuiFlg ()+forceGuiFlag = setFlag DisableGuiFlg ()

@@ -24,7 +24,9 @@ or on hackage. -} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-} module NLP.GenI.Morphology  (  module NLP.GenI.Morphology.Types@@ -34,31 +36,35 @@  , inflectSentencesUsingCmd, sansMorph  ) where -import Control.Concurrent (forkIO)-import Control.Exception (catch, bracket, evaluate, IOException)-import Data.Maybe (isNothing)-import Data.Text ( Text )-import Data.Tree-import Data.Typeable-import System.Exit-import System.IO-import System.Process-import Prelude hiding (catch)-import qualified Data.Map as Map-import qualified Data.Text as T+import           Control.Applicative+import           Control.Concurrent        (forkIO)+import           Control.Exception         (IOException, bracket, catch,+                                            evaluate)+import qualified Data.Map                  as Map+import           Data.Maybe                (fromMaybe, isNothing)+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Tree+import           Data.Typeable+import           Prelude                   hiding (catch)+import           System.Exit+import           System.IO+import           System.Process -import System.Log.Logger-import Text.JSON-import Text.JSON.Pretty+import           System.Log.Logger+import           Text.JSON+import qualified Text.JSON                 as J+import           Text.JSON.Pretty          hiding ((<+>), (<>)) -import NLP.GenI.FeatureStructure-import NLP.GenI.GeniVal ( mkGAnon, GeniVal, replace )-import NLP.GenI.General-import NLP.GenI.Morphology.Types-import NLP.GenI.Pretty-import NLP.GenI.Semantics ( Literal(..), Sem )-import NLP.GenI.Tag-import NLP.GenI.TreeSchema ( GNode(..), GType(..) )+import           NLP.GenI.FeatureStructure+import           NLP.GenI.General+import           NLP.GenI.GeniVal          (GeniVal, mkGAnon, replace)+import           NLP.GenI.Morphology.Types+import           NLP.GenI.Parser+import           NLP.GenI.Pretty+import           NLP.GenI.Semantics        (Literal (..), Sem)+import           NLP.GenI.Tag+import           NLP.GenI.TreeSchema       (GNode (..), GType (..))  -- ---------------------------------------------------------------------- -- Morphological input@@ -78,7 +84,7 @@ --   morphological literals -- it associates literals with morphological stuff; --   if it returns 'Nothing', then it is non-morphological stripMorphSem :: MorphInputFn -> Sem -> Sem-stripMorphSem morphfn tsem = +stripMorphSem morphfn tsem =   [ l | l <- tsem, (isNothing.morphfn) l ]  -- | 'attachMorph' @morphfn sem cands@ does the bulk of the morphological@@ -89,54 +95,61 @@ --   literal if its semantics contains at least one literal whose first index --   is the same as the first index of the morphological literal. attachMorph :: MorphInputFn -> Sem -> [TagElem] -> [TagElem]-attachMorph morphfn sem cands = +attachMorph morphfn sem cands =   let -- relevance of a tree wrt to an index       relTree i = not.null.relfilt.tsemantics-        where relfilt = filter (relLit i)  +        where relfilt = filter (relLit i)       relLit i l = case lArgs l of                      []    -> False                      (x:_) -> x == i       -- perform the attachment for a tree if it is relevant       attachHelper :: GeniVal -> Flist GeniVal -> TagElem -> TagElem-      attachHelper i mfs t = -        if relTree i t then attachMorphHelper mfs t else t +      attachHelper i mfs t =+        if relTree i t then attachMorphHelper mfs t else t       -- perform all attachments for a literal       attach :: Literal GeniVal -> [TagElem] -> [TagElem]-      attach l cs = -        case morphfn l of +      attach l cs =+        case morphfn l of           Nothing  -> cs           Just mfs -> map (attachHelper i mfs) cs         where i = case lArgs l of                     []    -> mkGAnon                     (x:_) -> x-  in foldr attach cands sem +  in foldr attach cands sem  -- | Actually unify the morphological features into the anchor node -----   FIXME: we'll need to make sure this still works as promised +--   FIXME: we'll need to make sure this still works as promised --   when we implement co-anchors. attachMorphHelper :: Flist GeniVal -> TagElem -> TagElem-attachMorphHelper mfs te = +attachMorphHelper mfs te =   let -- unification with anchor-      tt     = ttree te +      tt     = ttree te       anchor = head $ filterTree fn tt                where fn a = (ganchor a && gtype a == Lex)   in case unifyFeat mfs (gup anchor) of-     Nothing -> error ("Morphological unification failure on " ++ T.unpack (idname te))-     Just (unf,subst) ->+     Left err -> error . T.unpack $+       "Morphological unification failure on" <+> idname te <> ":" <+> err+     Right (unf,subst) ->       let -- perform replacements-          te2 = replace subst te +          te2 = replace subst te           tt2 = ttree te2           -- replace the anchor with the unification results-          newgdown = replace subst (gdown anchor) +          newgdown = replace subst (gdown anchor)           newa = anchor { gup = unf, gdown = newgdown }       in te2 { ttree = setMorphAnchor newa tt2 } +-- | @setMorphAnchor n t@ replaces the anchor node of a tree with @n@+--+--   We assume the tree has exactly one anchor node.  If it has none,+--   this explodes; if it has more than one, they all get replaced. setMorphAnchor :: GNode GeniVal -> Tree (GNode GeniVal) -> Tree (GNode GeniVal) setMorphAnchor n t =-  let filt (Node a _) = (gtype a == Lex && ganchor a)-      fn (Node _ l)   = Node n l-  in (head.fst) $ listRepNode fn filt [t]+    fromMaybe (error oops) $ repNode fn filt t+  where+    filt (Node a _) = gtype a == Lex && ganchor a+    fn (Node _ l)   = Node n l+    oops = "NLP.GenI.Morphology.setMorphAnchor did not anticipate failure was possible"  -- ---------------------------------------------------------------------- -- Morphological realisation@@ -161,7 +174,7 @@  where   hCloseSloppy h = hClose h `catch` \err -> let _ = err :: IOException in warningM logname (show err)   doit = bracket-   (do debugM logname $ "Starting morph generator: " ++ morphcmd +   (do debugM logname $ "Starting morph generator: " ++ morphcmd        runInteractiveCommand morphcmd)    (\(inh,outh,errh,_) -> do       debugM logname $ "Closing output handles from morph generator"@@ -205,6 +218,42 @@   fallback err = do     errorM logname err     return $ map (\x -> (x, sansMorph x)) sentences++-- ---------------------------------------------------------------------+-- parsers+-- ---------------------------------------------------------------------++instance JSON MorphOutput where+    readJSON j =+        case fromJSObject `fmap` readJSON j of+            J.Error _ -> MorphOutput [] <$> readJSON j+            J.Ok jo   -> do+                let field x = maybe (fail $ "Could not find: " ++ x) readJSON+                            $ lookup x jo+                    warnings = maybe (return []) readJSON (lookup "warnings" jo)+                MorphOutput <$> warnings+                             <*> field "realisations"+    showJSON _ = error "Don't know how to render MorphOutput"++instance JSON LemmaPlus where+    readJSON j = do+        jo <- fromJSObject `fmap` readJSON j+        let field x = maybe (fail $ "Could not find: " ++ x) readJSON+                    $ lookup x jo+            tfield = fmap T.pack . field+        LemmaPlus <$> field "lemma"+                  <*> (parsecToJSON "lemma-features" geniFeats =<<+                       tfield "lemma-features")+    showJSON (LemmaPlus l fs) = JSObject . toJSObject $+         [ ("lemma"         , showJSON l)+         , ("lemma-features", showJSON $ prettyStr fs)+         ]++parsecToJSON :: Monad m => String -> Parser b -> Text -> m b+parsecToJSON description p str =+    case runParser p () "" str of+        Left  err -> fail $ "Couldn't parse " ++ description ++ " because " ++ show err+        Right res -> return res  -- ---------------------------------------------------------------------- -- odds and ends

@@ -1,5 +1,7 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-} -- GenI surface realiser -- Copyright (C) 2005 Carlos Areces and Eric Kow --@@ -19,16 +21,13 @@  module NLP.GenI.Morphology.Types where -import Control.Applicative ((<$>),(<*>))-import Control.DeepSeq-import Data.Text ( Text )+import           Control.DeepSeq+import           Data.Text                 (Text) -import NLP.GenI.GeniVal ( GeniVal )-import NLP.GenI.FeatureStructure ( Flist )-import NLP.GenI.Parser ( geniFeats, Parser, runParser )-import NLP.GenI.Pretty-import NLP.GenI.Semantics-import Text.JSON+import           NLP.GenI.FeatureStructure (Flist)+import           NLP.GenI.Flag+import           NLP.GenI.GeniVal          (GeniVal)+import           NLP.GenI.Semantics  -- ---------------------------------------------------------------------- -- morph input@@ -40,25 +39,13 @@ -- morph output -- ---------------------------------------------------------------------- -type MorphRealiser = [LemmaPlusSentence] -> [MorphOutput]+type MorphRealiser = [Flag] -> [LemmaPlusSentence] -> [MorphOutput]  data MorphOutput = MorphOutput { moWarnings     :: [Text]                                , moRealisations :: [Text]                                }   deriving (Ord, Eq) -instance JSON MorphOutput where- readJSON j =-   case fromJSObject `fmap` readJSON j of-     Error _ -> MorphOutput [] <$> readJSON j-     Ok jo   -> do-       let field x = maybe (fail $ "Could not find: " ++ x) readJSON-                   $ lookup x jo-           warnings = maybe (return []) readJSON (lookup "warnings" jo)-       MorphOutput <$> warnings-                   <*> field "realisations"- showJSON _ = error "Don't know how to render MorphOutput"- -- | A lemma plus its morphological features data LemmaPlus = LemmaPlus     { lpLemma :: Text@@ -69,24 +56,6 @@ -- | A sentence composed of 'LemmaPlus' instead of plain old words type LemmaPlusSentence = [LemmaPlus] -instance JSON LemmaPlus where- readJSON j =-    do jo <- fromJSObject `fmap` readJSON j-       let field x = maybe (fail $ "Could not find: " ++ x) readJSON-                   $ lookup x jo-       LemmaPlus <$> field "lemma"-                 <*> (parsecToJSON "lemma-features" geniFeats =<< field "lemma-features")- showJSON (LemmaPlus l fs) =-     JSObject . toJSObject $ [ ("lemma", showJSON l)-                             , ("lemma-features", showJSON $ prettyStr fs)-                             ]--parsecToJSON :: Monad m => String -> Parser b -> String -> m b-parsecToJSON description p str =- case runParser p () "" str of-   Left  err -> fail $ "Couldn't parse " ++ description ++ " because " ++ show err-   Right res -> return res- {-! deriving instance NFData MorphOutput deriving instance NFData LemmaPlus@@ -94,11 +63,11 @@  -- GENERATED START - + instance NFData MorphOutput where         rnf (MorphOutput x1 x2) = rnf x1 `seq` rnf x2 `seq` () - + instance NFData LemmaPlus where         rnf (LemmaPlus x1 x2) = rnf x1 `seq` rnf x2 `seq` () -- GENERATED STOP

@@ -27,20 +27,21 @@    )  where -import Control.Applicative ( (<$>), (<*>) )-import Control.Arrow ( first )-import Data.Function (on)-import Data.Char ( isSpace )-import Data.List (nub, partition, sort, sortBy, groupBy, (\\), unfoldr )-import Data.Text ( Text )-import qualified Data.Text as T-import Text.JSON+import           Control.Applicative ((<$>), (<*>))+import           Control.Arrow       (first)+import           Data.Char           (isSpace)+import           Data.Function       (on)+import           Data.List           (groupBy, nub, partition, sort, sortBy,+                                      unfoldr, (\\))+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Text.JSON -import NLP.GenI.Pretty-import NLP.GenI.TreeSchema ( Macros, ptrace )-import qualified NLP.GenI.Builder as B+import qualified NLP.GenI.Builder    as B+import           NLP.GenI.Pretty+import           NLP.GenI.TreeSchema (Macros, ptrace) -import Control.DeepSeq+import           Control.DeepSeq  data OtConstraint = PositiveC Text -- ^ the trace must appear                   | NegativeC Text -- ^ the trace must NOT appear@@ -303,7 +304,7 @@   where     f t = if T.null t then Nothing else Just (splitAtBefore len t) -splitAtBefore :: Int -- ^ wrap after these many characters +splitAtBefore :: Int -- ^ wrap after these many characters               -> Text               -> (Text, Text) splitAtBefore len xs@@ -327,15 +328,15 @@  -- GENERATED START - + instance NFData OtViolation where         rnf (OtViolation x1 x2) = rnf x1 `seq` rnf x2 `seq` () - + instance NFData RankedOtConstraint where         rnf (RankedOtConstraint x1 x2) = rnf x1 `seq` rnf x2 `seq` () - + instance NFData OtConstraint where         rnf (PositiveC x1) = rnf x1 `seq` ()         rnf (NegativeC x1) = rnf x1 `seq` ()

@@ -15,14 +15,14 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module NLP.GenI.Parser (   -- * Test suites   geniTestSuite, geniSemanticInput, geniTestSuiteString,   geniDerivations,-  toSemInputString,   -- * Trees   geniMacros, geniTagElems,   -- * Lexicon and morph@@ -34,41 +34,44 @@   --   parseFromFile, -- UTF-8 version   module Text.Parsec,-  module Text.Parsec.String,+  module Text.Parsec.Text, ) where  -import Control.Applicative ( (<*>), (<$>), (*>), (<*) )-import Control.Monad (liftM, when)-import Data.Text ( Text )-import Text.Parsec-import Text.Parsec.String hiding ( parseFromFile ) -- TODO: replace with Text.Parsec.Text-import Text.Parsec.Language (emptyDef)-import Text.Parsec.Token (TokenParser,-    LanguageDef,-    commentLine, commentStart, commentEnd, opLetter,-    reservedOpNames, reservedNames, identLetter, identStart, -    makeTokenParser)-import qualified Data.Map  as Map-import qualified Data.Text as T-import qualified Data.Tree as T-import qualified System.IO.UTF8 as UTF8---import qualified Text.Parsec.Expr  as P-import qualified Text.Parsec.Token as P--import NLP.GenI.FeatureStructure ( Flist, AvPair(..), sortFlist )-import NLP.GenI.General (isGeniIdentLetter)-import NLP.GenI.GeniShow ( GeniShow(..), geniKeyword )-import NLP.GenI.GeniVal ( GeniVal, mkGConst, mkGConstNone, mkGVar, mkGAnon, isAnon )-import NLP.GenI.Lexicon ( fromLexSem, mkFullLexEntry, LexEntry(..) )-import NLP.GenI.Pretty ( above )-import NLP.GenI.Semantics ( Literal(..), Sem, sortSem, LitConstr, SemInput )-import NLP.GenI.Tag (TagElem(..), setTidnums)-import NLP.GenI.TestSuite ( TestCase(..) )-import NLP.GenI.TreeSchema (SchemaTree, Ttree(..), Ptype(..), GNode(..), GType(..) )+import           Control.Applicative       ((*>), (<$>), (<*), (<*>), pure)+import           Control.Monad             (liftM, when)+import qualified Data.ByteString           as B+import           Data.Functor.Identity     (Identity)+import qualified Data.Map                  as Map+import           Data.Monoid               ((<>))+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import qualified Data.Text.Encoding        as T+import qualified Data.Tree                 as T+import           Text.Parsec+import           Text.Parsec.Text+import           Text.Parsec.Token         (GenLanguageDef (..),+                                            makeTokenParser)+import qualified Text.Parsec.Token         as P  -- import BoolExp-import Data.FullList ( FullList, Listable(..) )+import           Data.FullList             (FullList, Listable (..))+import           NLP.GenI.FeatureStructure (AvPair (..), Flist, sortFlist)+import           NLP.GenI.General          (isGeniIdentLetter)+import           NLP.GenI.GeniShow         (GeniShow (..), geniKeyword)+import           NLP.GenI.GeniVal          (GeniVal, SchemaVal (..), isAnon,+                                            mkGAnon, mkGConst, mkGConstNone,+                                            mkGVar)+import           NLP.GenI.Lexicon          (LexEntry (..), fromLexSem,+                                            mkFullLexEntry)+import           NLP.GenI.Pretty           (above)+import           NLP.GenI.Semantics        (LitConstr, Literal (..), Sem,+                                            SemInput, sortSem)+import           NLP.GenI.Tag              (TagElem (..), setTidnums)+import           NLP.GenI.TestSuite        (TestCase (..))+import           NLP.GenI.TreeSchema       (GNode (..), GType (..), Ptype (..),+                                            AdjunctionConstraint(..),+                                            SchemaTree, Ttree (..))   -- General notes@@ -92,22 +95,27 @@  -- Lexer -geniLanguageDef :: LanguageDef ()-geniLanguageDef = emptyDef-         { commentLine = "%"-         , commentStart = "/*"-         , commentEnd = "*/"-         , opLetter = oneOf ""-         , reservedOpNames = [""]-         , reservedNames =-             [ SEMANTICS , SENTENCE, OUTPUT, IDXCONSTRAINTS, TRACE-             , ANCHOR , SUBST , FOOT , LEX , TYPE , ACONSTR-             , INITIAL , AUXILIARY-             , BEGIN , END ]-         , identLetter = identStuff-         , identStart  = identStuff-         }-  where identStuff = satisfy isGeniIdentLetter+geniLanguageDef :: P.GenLanguageDef Text () Identity+geniLanguageDef = LanguageDef+    { commentLine  = "%"+    , commentStart = "/*"+    , commentEnd   = "*/"+    , nestedComments = True+    , opStart  = opLetter geniLanguageDef+    , opLetter = oneOf ""+    , reservedOpNames = []+    , reservedNames =+          [ SEMANTICS , SENTENCE, OUTPUT, IDXCONSTRAINTS, TRACE+          , ANCHOR , SUBST , FOOT , LEX , TYPE , ACONSTR+          , INITIAL , AUXILIARY+          , BEGIN , END+          ]+    , identLetter = identStuff+    , identStart  = identStuff+    , caseSensitive  = True+    }+  where+    identStuff = satisfy isGeniIdentLetter  geniValue :: Parser GeniVal geniValue =   ((try $ anonymous) <?> "_ or ?_")@@ -135,10 +143,10 @@     (x:xs) <- atom `sepBy1` (symbol "|")     return (x !: xs)   where-    atom = looseIdentifier <|> stringLiteral+    atom = looseFlexiIdentifier -geniFancyDisjunction :: Parser [GeniVal]-geniFancyDisjunction = geniValue `sepBy1` symbol ";"+geniFancyDisjunction :: Parser SchemaVal+geniFancyDisjunction = SchemaVal <$> geniValue `sepBy1` symbol ";"  class GeniValLike v where   geniValueLike :: Parser v@@ -146,7 +154,7 @@ instance GeniValLike GeniVal where   geniValueLike = geniValue -instance GeniValLike [GeniVal] where+instance GeniValLike SchemaVal where   geniValueLike = geniFancyDisjunction  -- We make no attempt to check for / guarantee uniqueness here@@ -211,8 +219,15 @@     keywordSemantics     s <- squaresString     whiteSpace-    optional geniIdxConstraints-    return s+    xs <- option [] geniIdxConstraints+    return (spitBack s xs)+  where+    -- this is a bit embarassing+    spitBack semStr idxC =+        geniKeyword SEMANTICS semStr `above` r+      where+        r | null idxC = ""+          | otherwise = geniKeyword IDXCONSTRAINTS (geniShowText idxC)  geniIdxConstraints :: Parser (Flist GeniVal) geniIdxConstraints = keyword IDXCONSTRAINTS >> geniFeats@@ -232,31 +247,18 @@ -}  squaresString :: Parser Text-squaresString = do-    char '['-    s <- (T.concat <$> many inSq) <|> squaresString-    char ']'-    return $ "[" `T.append` s `T.append` "]"+squaresString =+    between (char '[') (char ']') $ do+       xs <- many1 (nonSq <|> squaresString)+       return $ "[" <> T.concat xs <> "]"   where-    inSq :: Parser Text-    inSq = T.pack <$> many1 (noneOf "[]")+    nonSq :: Parser Text+    nonSq = T.pack <$> many1 (noneOf "[]")  -- the output end of things -- displaying preformatted semantic input -data SemInputString = SemInputString Text (Flist GeniVal)--instance GeniShow SemInputString where-    geniShowText (SemInputString semStr idxC) =-        geniKeyword SEMANTICS semStr `above` r-      where-        r | null idxC = ""-          | otherwise = geniKeyword IDXCONSTRAINTS (geniShowText idxC)--toSemInputString :: SemInput -> Text -> SemInputString-toSemInputString (_,lc,_) s = SemInputString s lc--geniTestSuite :: Parser [TestCase]+geniTestSuite :: Parser [TestCase SemInput] geniTestSuite =   tillEof (many geniTestCase) @@ -270,12 +272,13 @@ geniDerivations :: Parser [TestCaseOutput] geniDerivations = tillEof $ many geniOutput -geniTestCase :: Parser TestCase+geniTestCase :: Parser (TestCase SemInput) geniTestCase =-     TestCase <$> (option "" (identifier <?> "a test case name"))+     TestCase <$> (option "" (flexiIdentifier <?> "a test case name"))               <*> lookAhead geniSemanticInputString               <*> geniSemanticInput               <*> many geniSentence+              <*> pure Nothing  -- note that the keyword is NOT optional type TestCaseOutput = (Text, Map.Map (Text,Text) [Text])@@ -312,7 +315,7 @@ --   (for gui) geniTestCaseString :: Parser Text geniTestCaseString = do-    option "" (identifier <?> "a test case name")+    option "" (flexiIdentifier <?> "a test case name")     geniSemanticInputString <* (many geniSentence >> many geniOutput)  -- ----------------------------------------------------------------------@@ -425,12 +428,12 @@     name      <- identifier     nodeType  <- geniNodeAnnotation     lex_   <- if nodeType == AnnoLexeme-                 then ((stringLiteral <|> identifier) `sepBy` symbol "|") <?> "some lexemes"+                 then (flexiIdentifier `sepBy` symbol "|") <?> "some lexemes"                  else return []     constr <- case nodeType of                   AnnoDefault -> adjConstraintParser                   AnnoAnchor  -> adjConstraintParser-                  _           -> return True+                  _           -> return ExplicitNoAdj -- maybe InferredNoAdj instead?     -- features only obligatory for non-lex nodes     (top,bot) <- if nodeType == AnnoLexeme                     then option ([],[]) $ try topbotParser@@ -445,7 +448,8 @@                 , gorigin  = ""                 }   where-    adjConstraintParser = option False $ reserved ACONSTR >> char ':' >> symbol "noadj" >> return True+    adjConstraintParser = option MaybeAdj $+        reserved ACONSTR >> char ':' >> symbol "noadj" >> return ExplicitNoAdj     topbotParser = do         top <- geniFeats <?> "top features"         symbol "!"@@ -570,7 +574,7 @@ -- language def helpers -- ---------------------------------------------------------------------- -lexer :: TokenParser ()+lexer :: P.GenTokenParser Text () Identity lexer  = makeTokenParser geniLanguageDef  whiteSpace :: Parser ()@@ -579,6 +583,10 @@ identifier :: Parser Text identifier = decode <$> P.identifier lexer +-- | Like 'identifier', but also accepts string literals+flexiIdentifier :: Parser Text+flexiIdentifier = stringLiteral <|> identifier+ -- stolen from Parsec code (ident) -- | Like 'identifier' but allows for reserved words too looseIdentifier :: Parser Text@@ -590,6 +598,10 @@         ; cs <- many (identLetter geniLanguageDef)         ; return (c:cs) } <?> "identifier" +-- | Accepts: identifiers, bare reserved words, and string literals+looseFlexiIdentifier :: Parser Text+looseFlexiIdentifier = looseIdentifier <|> stringLiteral+ colon :: Parser Text colon = decode <$> P.colon lexer @@ -627,7 +639,7 @@  -- stolen from Parsec and adapted to use UTF-8 input parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)-parseFromFile p fname-    = do{ input <- UTF8.readFile fname-        ; return (parse p fname input)-        }+parseFromFile p fname = do+    { input <- T.decodeUtf8 <$> B.readFile fname+    ; return (parse p fname input)+    }

@@ -23,12 +23,19 @@                 PolAut, PolState(PolSt), AutDebug, PolResult(..),                 buildAutomaton, +                -- * Polarity paths+                PolPathSet, detectPolPaths, hasSharedPolPaths,+                polPathsToList,+                singletonPolPath,+                emptyPolPaths, polPathsNull,+                intersectPolPaths, unionPolPaths,+                 -- * Inner stuff (exported for debugging?)                 makePolAut,                 fixPronouns,-                detectSansIdx, suggestPolFeatures, detectPols, detectPolPaths,+                detectSansIdx, suggestPolFeatures, detectPols,                 declareIdxConstraints, detectIdxConstraints,-                prettyPolPaths, prettyPolPaths',+                prettyPolPaths,                  -- re-exported from Automaton                 automatonPaths, finalSt,@@ -36,29 +43,34 @@                 ) where -import Data.Bits-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.List-import Data.Maybe (isNothing, isJust)-import Data.Text (Text)-import qualified Data.Text as T+import           Data.IntSet                (IntSet)+import qualified Data.IntSet                as IntSet+import           Data.List+import qualified Data.Map                   as Map+import qualified Data.Set                   as Set+import           Data.Text                  (Text)+import qualified Data.Text                  as T -import NLP.GenI.Automaton-import NLP.GenI.FeatureStructure ( Flist, AvPair(..), FeatStruct, unifyFeat )-import NLP.GenI.General-    ( BitVector, isEmptyIntersect, thd3, Interval, ival, (!+!)-    )-import NLP.GenI.GeniVal ( GeniVal(gConstraints), mkGAnon, isAnon, replace )-import NLP.GenI.Polarity.Internal-import NLP.GenI.Polarity.Types-import NLP.GenI.Pretty-import NLP.GenI.Semantics ( Literal(..), SemInput, Sem, emptyLiteral-                          , sortSem-                          )-import NLP.GenI.Tag ( TagElem(..), TagItem(..), setTidnums )-import NLP.GenI.TreeSchema ( Ptype(Initial), GNode, root, gup, gdown, rootUpd)+import           Control.Error +import           NLP.GenI.Automaton+import           NLP.GenI.FeatureStructure  (AvPair (..), FeatStruct, Flist,+                                             unifyFeat)+import           NLP.GenI.General           (Interval,+                                             isEmptyIntersect, ival, thd3,+                                             (!+!))+import           NLP.GenI.GeniVal           (GeniVal (gConstraints), isAnon,+                                             mkGAnon, replace)+import           NLP.GenI.Polarity.Internal+import           NLP.GenI.Polarity.Types+import           NLP.GenI.Pretty+import           NLP.GenI.Semantics         (Literal (..), Sem, SemInput,+                                             emptyLiteral, sortSem)+import           NLP.GenI.Tag               (TagElem (..), TagItem (..),+                                             setTidnums)+import           NLP.GenI.TreeSchema        (GNode, Ptype (Initial), gdown, gup,+                                             root, rootUpd)+ -- ---------------------------------------------------------------------- -- Interface -- ----------------------------------------------------------------------@@ -90,7 +102,7 @@                          r  = detect . tinterface $ t       candRest  = map constrain candRaw       inputRest = declareIdxConstraints tres-      -- polarity detection +      -- polarity detection       cand1   = map (detectPols polarityAttrs) candRest       extras1 = Map.unionsWith (!+!) [ extrapol, inputRest, rcatPol ]       ks1     = polarityKeys cand1 Map.empty@@ -108,11 +120,11 @@      (tsem, cands') = fixPronouns (tsemRaw,candsRaw)      cands = setTidnums cands'      -- sorted semantics (for more efficient construction)-     sortedsem = sortSemByFreq tsem cands +     sortedsem = sortSemByFreq tsem cands      -- the seed automaton-     smap = buildColumns cands sortedsem +     smap = buildColumns cands sortedsem      seed = buildSeedAut smap  sortedsem-     -- building and remembering the automata +     -- building and remembering the automata      build k xs = (k,aut,prune aut):xs        where aut   = buildPolAut k initK (thd3 $ head xs)              initK = Map.findWithDefault (ival 0) k extraPol@@ -133,11 +145,11 @@ buildColumns :: (TagItem t) => [t]              -> Sem              -> Map.Map (Literal GeniVal) [t]-buildColumns cands [] = +buildColumns cands [] =   Map.singleton emptyLiteral e   where e = filter (null.tgSemantics) cands -buildColumns cands (l:ls) = +buildColumns cands (l:ls) =   let matchfn t = l `elem` tgSemantics t       (match, cands2) = partition matchfn cands       next = buildColumns cands2 ls@@ -148,12 +160,12 @@ -- ----------------------------------------------------------------------  buildSeedAut :: SemMap -> Sem -> PolAut-buildSeedAut cands tsem = +buildSeedAut cands tsem =   let start = polstart []       hasZero (x,y) = x <= 0 && y >= 0-      isFinal (PolSt c _ pols) = +      isFinal (PolSt c _ pols) =         c == length tsem && all hasZero pols-      initAut = NFA +      initAut = NFA         { startSt = start         , isFinalSt = Just isFinal         , finalStList = []@@ -162,10 +174,10 @@   in nubAut $ buildSeedAut' cands tsem 1 initAut  -- for each literal...-buildSeedAut' :: SemMap -> Sem -> Int -> PolAut -> PolAut -buildSeedAut' _ [] _ aut = aut -buildSeedAut' cands (l:ls) i aut = -  let -- previously created candidates +buildSeedAut' :: SemMap -> Sem -> Int -> PolAut -> PolAut+buildSeedAut' _ [] _ aut = aut+buildSeedAut' cands (l:ls) i aut =+  let -- previously created candidates       prev   = head $ states aut       -- candidates that match the target semantics       tcands = Map.findWithDefault [] l cands@@ -190,16 +202,16 @@       -- do not overlap the extra baggage semantics       tcand = [ Just t | t <- cs               , isEmptyIntersect ex1 (tsemantics t) ]-      -- add the transitions out of the current state +      -- add the transitions out of the current state       addT tr (a,n) = (addTrans a st tr st2, st2:n)-        where +        where          st2 = PolSt i (delete l $ ex1 ++ ex2) []-         ex2 = case tr of -               Nothing  -> [] +         ex2 = case tr of+               Nothing  -> []                Just tr_ -> tsemantics tr_-  in if (l `elem` ex1) +  in if (l `elem` ex1)      then addT Nothing (aut,prev)-     else foldr addT   (aut,prev) tcand +     else foldr addT   (aut,prev) tcand  -- ---------------------------------------------------------------------- -- Construction@@ -210,12 +222,12 @@   let concatPol p (PolSt pr b pol) = PolSt pr b (p:pol)       newStart = concatPol initK $ startSt skelAut       ---      initAut  = skelAut +      initAut  = skelAut         { startSt = newStart         , states  = [[newStart]]         , transitions = Map.empty }-      -- cand' = observe "candidate map" cand -  in nubAut $ buildPolAut' k (transitions skelAut) initAut +      -- cand' = observe "candidate map" cand+  in nubAut $ buildPolAut' k (transitions skelAut) initAut  {- Our helper function looks at a single state in the skeleton automaton@@ -226,14 +238,14 @@ are looking at a different polarity key, so that whereas two candidates automaton may transition to the same state in the old automaton, their polarity effects for the new key will make them diverge in the new-automaton.  +automaton. -}  buildPolAut' :: PolarityKey -> PolTransFn -> PolAut -> PolAut -- for each literal... (this is implicit in the automaton state grouping)-buildPolAut' fk skeleton aut = -  let -- previously created candidates -      prev = head $ states aut +buildPolAut' fk skeleton aut =+  let -- previously created candidates+      prev = head $ states aut       -- create the next batch of states       fn st ap            = buildPolAutHelper fk skeleton st ap       (newAut,newStates)  = foldr fn (aut,Set.empty) prev@@ -246,7 +258,7 @@ -- given a previously created state... buildPolAutHelper :: PolarityKey -> PolTransFn -> PolState -> (PolAut,Set.Set PolState) -> (PolAut,Set.Set PolState) buildPolAutHelper fk skeleton st (aut,prev) =-  let -- reconstruct the skeleton state used to build st +  let -- reconstruct the skeleton state used to build st       PolSt pr ex (po1:skelpo1) = st       skelSt = PolSt pr ex skelpo1       -- for each transition out of the current state@@ -261,12 +273,12 @@       --       newSt :: Maybe TagElem -> PolState -> PolState       newSt t skel2 = PolSt pr2 ex2 (po2:skelPo2)-        where -         PolSt pr2 ex2 skelPo2 = skel2 +        where+         PolSt pr2 ex2 skelPo2 = skel2          po2 = po1 !+! Map.findWithDefault (ival 0) fk pol-         pol = case t of Nothing -> Map.empty +         pol = case t of Nothing -> Map.empty                          Just t2 -> tpolarities t2-  in result +  in result  -- ---------------------------------------------------------------------- -- Pruning@@ -284,27 +296,27 @@ list of states to process. -} prune :: PolAut -> PolAut-prune aut = +prune aut =   let theStates   = states aut       final       = finalSt aut-      -- (remember that states is a list of lists) -      lastStates  = head theStates -      nextStates  = tail theStates +      -- (remember that states is a list of lists)+      lastStates  = head theStates+      nextStates  = tail theStates       nonFinal    = (lastStates \\ final)       -- the helper function will rebuild the state list       firstAut    = aut { states = [] }-      pruned      = prune' (nonFinal:nextStates) firstAut +      pruned      = prune' (nonFinal:nextStates) firstAut       -- re-add the final state!       statesPruned = states pruned       headPruned   = head statesPruned       tailPruned   = tail statesPruned-  in if (null theStates) +  in if (null theStates)      then aut-     else pruned { states = (headPruned ++ final) : tailPruned } +     else pruned { states = (headPruned ++ final) : tailPruned }  prune' :: [[PolState]] -> PolAut -> PolAut prune' [] oldAut = oldAut { states = reverse $ states oldAut }-prune' (sts:next) oldAut = +prune' (sts:next) oldAut =   let -- calculate the blacklist       oldT  = transitions oldAut       oldSt = states oldAut@@ -322,49 +334,49 @@       newSts = sts \\ blacklist       newAut = oldAut { transitions = newT,                         states = newSts : oldSt }-      {- +      {-       -- debugging code       debugstr  = "blacklist: [\n" ++ debugstr' ++ "]"       debugstr' = concat $ intersperse "\n" $ map showSt blacklist       showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po-      showPr (_,pr,_) = pr ++ " " +      showPr (_,pr,_) = pr ++ " "       showPo po = concat $ intersperse "," $ map show po       showEx ex = if (null ex) then "" else (showSem ex)       -}       -- recursive step   in if null blacklist      then oldAut { states = (reverse oldSt) ++ (sts:next) }-     else prune' next newAut +     else prune' next newAut  -- ==================================================================== -- Zero-literal semantics -- ==================================================================== -type PredLite = (String,[GeniVal]) -- handle is head of arg list +type PredLite = (String,[GeniVal]) -- handle is head of arg list type SemWeightMap = Map.Map PredLite SemPols  -- | Returns a modified input semantics and lexical selection in which pronouns --   are properly accounted for. fixPronouns :: (Sem,[TagElem]) -> (Sem,[TagElem])-fixPronouns (tsem,cands) = +fixPronouns (tsem,cands) =   let -- part 1 (for each literal get smallest charge for each idx)       getpols :: TagElem -> [ (PredLite,SemPols) ]       getpols x = zip [ (prettyStr p, h:as) | Literal h p as <- tsemantics x ] (tsempols x)       sempols :: [ (PredLite,SemPols) ]       sempols = concatMap getpols cands-      usagemap :: SemWeightMap +      usagemap :: SemWeightMap       usagemap = Map.fromListWith (zipWith min) sempols       -- part 2 (cancel sem polarities)-      chargemap :: Map.Map GeniVal Int -- index to charge +      chargemap :: Map.Map GeniVal Int -- index to charge       chargemap =  Map.fromListWith (+) $ concatMap clump $ Map.toList usagemap         where clump ((_,is),ps) = zip is ps       -- part 3 (adding extra semantics)-      indices = concatMap fn (Map.toList chargemap) +      indices = concatMap fn (Map.toList chargemap)         where fn (i,c) = replicate (negate c) i-      -- the extra columns +      -- the extra columns       extraSem = map indexLiteral indices       tsem2    = sortSem (tsem ++ extraSem)-      -- zero-literal semantic items to realise the extra columns +      -- zero-literal semantic items to realise the extra columns       zlit = filter (null.tsemantics) cands       cands2 = (cands \\ zlit) ++ concatMap fn indices         where fn i = map (tweak i) zlit@@ -397,12 +409,12 @@  -- | 'assignIndex' is a useful way to restrict the behaviour of -- null semantic items like pronouns using the information generated by--- the index counting mechanism.  The problem with null semantic items +-- the index counting mechanism.  The problem with null semantic items -- is that their indices are not set, which means that they could--- potentially combine with any other tree.  To make things more +-- potentially combine with any other tree.  To make things more -- efficient, we can set the index of these items and thus reduce the--- number of spurious combinations.  --- +-- number of spurious combinations.+-- -- Notes -- -- * These combinations could produce false results if the@@ -412,18 +424,18 @@ --   *her* book“. -- -- * This function works by FS unification on the root node of the---   tree with the *[idx:i]*.  If unification is not possible, +--   tree with the *[idx:i]*.  If unification is not possible, --   we simply return the tree as is. -- -- * This function renames the tree by appending the index to its name-assignIndex :: GeniVal -> TagElem -> TagElem +assignIndex :: GeniVal -> TagElem -> TagElem assignIndex i te =   let idxfs = [ AvPair __idx__ i ]       oldt  = ttree te       oldr  = root oldt       tfup  = gup oldr       ---  in case unifyFeat tfup idxfs of+  in case hush (unifyFeat tfup idxfs) of      Nothing          -> te      Just (gup2, sub) -> replace sub $ te { ttree = newt }        where newt = rootUpd oldt $ oldr { gup = gup2 }@@ -432,7 +444,7 @@ -- Further optimisations -- ==================================================================== --- Index constraints +-- Index constraints -- ----------------- detectIdxConstraints :: Flist GeniVal -> Flist GeniVal -> PolMap detectIdxConstraints cs interface =@@ -485,58 +497,74 @@ -- Chart sharing -- ------------- +type PolPathSet = IntSet+type PolPathMap = Map.Map TagElem IntSet+ -- | Given a list of paths (i.e. a list of list of trees) --   return a list of trees such that each tree is annotated with the paths it --   belongs to.-detectPolPaths :: [[TagElem]] -> [(TagElem,BitVector)]-detectPolPaths paths = -  let pathFM     = detectPolPaths' Map.empty 0 paths-      lookupTr k = Map.findWithDefault 0 k pathFM-  in map (\k -> (k, lookupTr k)) $ Map.keys pathFM+detectPolPaths :: [[TagElem]] -> [(TagElem,PolPathSet)]+detectPolPaths paths =+    Map.toList pathFM+  where+    (pathFM, _) = foldl' addPath (Map.empty, 1) paths+    -- insert all trees from this path+    addPath :: (PolPathMap, Int) -> [TagElem] -> (PolPathMap, Int)+    addPath (accFM, counter) path =+        (foldl' ins accFM path, counter + 1)+      where+        myBit    = singletonPolPath counter -- eg. 000100+        ins m t  = Map.insertWith (IntSet.union) t myBit m -type PolPathMap = Map.Map TagElem BitVector-detectPolPaths' :: PolPathMap -> Int -> [[TagElem]] -> PolPathMap  +emptyPolPaths :: PolPathSet+emptyPolPaths = IntSet.empty -detectPolPaths' accFM _ [] = accFM-detectPolPaths' accFM counter (path:ps) = -  let currentBits = shiftL 1 counter -- shift counter times the 1 bit-      fn f []     = f-      fn f (t:ts) = fn (Map.insertWith (.|.) t currentBits f) ts -      newFM       = fn accFM path-  in detectPolPaths' newFM (counter+1) ps+polPathsNull :: PolPathSet -> Bool+polPathsNull = IntSet.null +polPathsToList :: PolPathSet -> [Int]+polPathsToList = IntSet.toAscList++unionPolPaths :: PolPathSet -> PolPathSet -> PolPathSet+unionPolPaths = IntSet.union++intersectPolPaths :: PolPathSet -> PolPathSet -> PolPathSet+intersectPolPaths = IntSet.intersection++hasSharedPolPaths :: PolPathSet -> PolPathSet -> Bool+hasSharedPolPaths x y = not . polPathsNull $+    x `intersectPolPaths` y+ -- | Render the list of polarity automaton paths as a string-prettyPolPaths :: BitVector -> Text+prettyPolPaths :: PolPathSet -> Text prettyPolPaths paths =     T.intercalate ", " $ map pretty pathlist   where-    pathlist = prettyPolPaths' paths 1+    pathlist = IntSet.toAscList paths -prettyPolPaths' :: BitVector -> Int -> [Int] -prettyPolPaths' 0 _ = []-prettyPolPaths' bv counter = -  if b then (counter:next) else next-  where b = testBit bv 0-        next = prettyPolPaths' (shiftR bv 1) (counter + 1)+-- | A (trivially) packed representation of the singleton+--   set containing a single polarity path+singletonPolPath :: Int -> PolPathSet+singletonPolPath = IntSet.singleton  -- Semantic sorting -- ----------------  sortSemByFreq :: Sem -> [TagElem] -> Sem-sortSemByFreq tsem cands = -  let counts = map lenfn tsem -      lenfn l = length $ filter fn cands +sortSemByFreq tsem cands =+  let counts = map lenfn tsem+      lenfn l = length $ filter fn cands                 where fn x = l `elem` (tsemantics x)       -- note: we introduce an extra hack to push       -- index-counted extra columns to the end; just for UI reasons-      sortfn a b +      sortfn a b         | isX a && isX b = compare (snd a) (snd b)         | isX a          = GT         | isX b          = LT         | otherwise      = compare (snd a) (snd b)-        where isX = isExtraCol.fst -      sorted = sortBy sortfn $ zip tsem counts -  in (fst.unzip) sorted +        where isX = isExtraCol.fst+      sorted = sortBy sortfn $ zip tsem counts+  in (fst.unzip) sorted  -- ---------------------------------------------------------------------- -- Types@@ -545,7 +573,7 @@ -- Polarity NFA  data PolState = PolSt Int [Literal GeniVal] [(Int,Int)]-                -- ^ position in the input semantics, extra semantics, +                -- ^ position in the input semantics, extra semantics,                 --   polarity interval      deriving (Eq) type PolTrans = TagElem@@ -557,7 +585,7 @@ -- showPred pr ++ " " ++ showSem ex ++ show po  instance Ord PolState where-  compare (PolSt pr1 ex1 po1) (PolSt pr2 ex2 po2) = +  compare (PolSt pr1 ex1 po1) (PolSt pr2 ex2 po2) =     let prC   = compare pr1 pr2         expoC = compare (ex1,po1) (ex2,po2)     in if (prC == EQ) then expoC else prC

@@ -18,29 +18,29 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.GenI.Polarity.Internal where -import Control.Applicative-import Data.List-import Data.Maybe (isJust)-import Data.Text (Text)-import Data.Tree (flatten)-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as T+import           Control.Applicative+import           Data.List+import qualified Data.Map                  as Map+import qualified Data.Set                  as Set+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Tree                 (flatten) -import Data.FullList hiding ( (++) )-import NLP.GenI.Automaton-import NLP.GenI.FeatureStructure-import NLP.GenI.General-import NLP.GenI.GeniVal-import NLP.GenI.Polarity.Types-import NLP.GenI.Pretty-import NLP.GenI.Semantics (Literal)-import NLP.GenI.Tag ( TagElem(..), TagItem(..) )-import NLP.GenI.TreeSchema-    ( Ptype(Initial)-    , GNode, root, gup, gdown, gtype, GType(Subs),-    )+import           Control.Error             (isRight) +import           Data.FullList             hiding ((++))+import           NLP.GenI.Automaton+import           NLP.GenI.FeatureStructure+import           NLP.GenI.General+import           NLP.GenI.GeniVal+import           NLP.GenI.Polarity.Types+import           NLP.GenI.Pretty+import           NLP.GenI.Semantics        (Literal)+import           NLP.GenI.Tag              (TagElem (..), TagItem (..))+import           NLP.GenI.TreeSchema       (GNode, GType (Subs),+                                            Ptype (Initial), gdown, gtype, gup,+                                            root)+ data PolarityDetectionResult = PD_UserError String                              | PD_Nothing                              | PD_Just [ (PolarityKey, Interval) ]@@ -52,7 +52,7 @@  -- | Given a description of what the root feature should unify with --   return a -1 polarity for all relevant polarity keys. This allows---   us to compensate for the root node of any derived tree. +--   us to compensate for the root node of any derived tree. detectRootCompensation :: Set.Set PolarityAttr -> FeatStruct GeniVal -> PolMap detectRootCompensation polarityAttrs rootFeat =   Map.fromListWith (!+!) . pdResults@@ -98,7 +98,7 @@                   `T.append` cat                   `T.append` " in:"                   `T.append` pretty filterFl-    Just v -> if isJust (unify [mkGConstNone cat] [v])+    Just v -> if isRight (unify [mkGConstNone cat] [v])               then detectPolarity i (SimplePolarityAttr att) emptyFeatStruct fl               else PD_Nothing detectPolarity i (SimplePolarityAttr att) _ fl =@@ -155,7 +155,7 @@ -- ----------------------------------------------------------------------  -- duplicates are a matter of course-addPols :: [(PolarityKey,Interval)] -> PolMap -> PolMap +addPols :: [(PolarityKey,Interval)] -> PolMap -> PolMap addPols pols m = foldr f m pols  where   f (p,c) = Map.insertWith (!+!) p c

@@ -15,21 +15,21 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TemplateHaskell    #-}  module NLP.GenI.Polarity.Types where -import qualified Data.Set as Set-import Data.Generics ( Data )-import Data.Typeable ( Typeable )-import Data.Text ( Text )-import qualified Data.Text as T+import           Data.Generics   (Data)+import qualified Data.Set        as Set+import           Data.Text       (Text)+import qualified Data.Text       as T+import           Data.Typeable   (Typeable) -import Control.DeepSeq+import           Control.DeepSeq -import NLP.GenI.Pretty+import           NLP.GenI.Pretty  data PolarityKey = PolarityKeyAv   Text Text                  | PolarityKeyStr  Text@@ -71,13 +71,13 @@ !-} -- GENERATED START - + instance NFData PolarityKey where         rnf (PolarityKeyAv x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PolarityKeyStr x1 )  = rnf x1 `seq` ()         rnf (PolarityKeyVar x1 )  = rnf x1 `seq` () - + instance NFData PolarityAttr where         rnf (SimplePolarityAttr x1) = rnf x1 `seq` ()         rnf (RestrictedPolarityAttr x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -15,15 +15,22 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeSynonymInstances #-}  -- | This is not a proper pretty printer. I aim is to replace this with a --   (de-facto) standard library if one should appear-module NLP.GenI.Pretty where+module NLP.GenI.Pretty+   ( Pretty(..)+   , (<>), (<+>), above+   , between, parens, squares+   , squeezed, prettyCount+   ) where -import Data.Text ( Text )-import qualified Data.Text as T+import           Data.Monoid ((<>))+import           Data.Text   (Text)+import qualified Data.Text   as T  -- | An alternative 'Show' instance (the idea being that we --   should reserve 'Show' for outputting actual Haskell)@@ -39,25 +46,27 @@ instance Pretty String where    prettyStr a = a +instance Pretty Text where+   pretty a = a+ instance Pretty Int where    prettyStr a = show a  instance Pretty Integer where    prettyStr a = show a +-- | @between l r t == l <> t <> r@ between :: Text -> Text -> Text -> Text between l r x = l `T.append` x `T.append` r +-- | @parens t@ puts @t@ between parentheses (@()@) parens :: Text -> Text parens = between "(" ")" +-- | @squares t@ puts @t@ between square brackets (@[]@) squares :: Text -> Text squares = between "[" "]" --- | Identical to 'T.append'-(<>) :: Text -> Text -> Text-t1 <> t2 = t1 `T.append` t2- -- | Separated by space unless one of them is empty (in which case just --   the non-empty one) (<+>) :: Text -> Text -> Text@@ -74,6 +83,18 @@ above t1 t2 | T.null t1 = t2             | T.null t2 = t1             | otherwise = t1 `T.append` "\n" `T.append` t2++-- | Puts list items on the same line if they are smaller than a certain width+--   otherwise, puts a newline in between them+squeezed :: Int -> [Text] -> Text+squeezed _ []  = ""+squeezed _ [x] = x+squeezed w (x1:x2:xs) =+    if long x1 || long x2+       then x1 `above` x2 `above` squeezed w xs+       else x1 <+> squeezed w (x2:xs)+  where+    long x = T.length x > w  -- | --

@@ -15,35 +15,48 @@ -- 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 TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeSynonymInstances  #-} {-# OPTIONS_GHC -fno-warn-orphans #-}++-- | We use a flat semantics in GenI (bag of literals). module NLP.GenI.Semantics where -import Control.Arrow ( first, (***), (&&&) )-import Control.Applicative ( (<$>) )-import Control.DeepSeq-import Data.Binary-import Data.Function ( on )-import Data.Data-import Data.List ( nub, sortBy, delete, insert )-import Data.Maybe ( isNothing, isJust, mapMaybe, fromMaybe )-import qualified Data.Map as Map-import Data.Text ( Text )-import qualified Data.Text as T+import           Control.Applicative       ((<$>))+import           Control.Arrow             (first, (&&&), (***))+import           Control.DeepSeq+import           Control.Monad.Error+import           Data.Binary+import           Data.Data+import           Data.Function             (on)+import           Data.List                 (delete, insert, nub, sortBy)+import qualified Data.Map                  as Map+import           Data.Text                 (Text)+import qualified Data.Text                 as T -import NLP.GenI.FeatureStructure-import NLP.GenI.GeniShow-import NLP.GenI.General ( histogram )-import NLP.GenI.GeniVal-import NLP.GenI.Pretty+import           Control.Error --- handle, predicate, parameters+import           NLP.GenI.FeatureStructure+import           NLP.GenI.General          (histogram)+import           NLP.GenI.GeniShow+import           NLP.GenI.GeniVal+import           NLP.GenI.Pretty++-- | A single semantic literal containing its handle, predicate, and arguments+--+--   This can be paramaterised on the kinds of variables it uses, for example,+--   'GeniVal' for a semantics that you might still want to do unification on+--   or 'Text' if it's supposed to be ground. data Literal gv = Literal-    { lHandle    :: gv+    { -- | the handle can be seen as a special kind of argument; stored separately+      lHandle    :: gv+      -- |     , lPredicate :: gv+      -- |     , lArgs      :: [gv]     }  deriving (Eq, Data, Typeable)@@ -54,41 +67,61 @@       -- treat the handle as an argument       tucked l = (lPredicate l, lHandle l : lArgs l) +-- | A semantics is just a set of literals. type Sem = [Literal GeniVal]++-- | A literal and any constraints associated with it (semantic input) type LitConstr = (Literal GeniVal, [Text])++-- | Semantics, index constraints, literal constraints+--+--   The intention here is that for @(sem, icons, lcons)@+--   @all (`elem` sem) lcons@ type SemInput  = (Sem,Flist GeniVal,[LitConstr])  instance Collectable a => Collectable (Literal a) where   collect (Literal a b c) = collect a . collect b . collect c +-- | An empty literal, not sure you should really be using this emptyLiteral :: Literal GeniVal emptyLiteral = Literal mkGAnon mkGAnon [] --- Utility functions+-- ----------------------------------------------------------------------+-- * Utility functions+-- ---------------------------------------------------------------------- +-- | Strip any index or literal constraints from an input.+--   Use with care. removeConstraints :: SemInput -> SemInput removeConstraints (x, _, _) = (x, [], []) --- | default sorting for a semantics+-- | Default sorting for a semantics sortSem :: Ord a => [Literal a] -> [Literal a] sortSem = sortBy compareOnLiteral +-- | Default comparison for a literal compareOnLiteral :: Ord a => Literal a -> Literal a -> Ordering compareOnLiteral = compare --- sort primarily putting the ones with the most constants first+-- | Sort primarily putting the ones with the most constants first -- and secondarily by the number of instances a predicate occurs -- (if plain string; atomic disjunction/vars treated as infinite) sortByAmbiguity :: Sem -> Sem-sortByAmbiguity sem = sortBy (flip compare `on` criteria) sem- where-   criteria  = (constants &&& ambiguity) -- this is reverse sorting-                                         -- so high numbers come first-   ambiguity l = fromMaybe 0 $ do -- Maybe-                   p <- boringLiteral l-                   negate <$> Map.lookup p (literalCount sem)+sortByAmbiguity sem =+    sortBy (flip compare `on` criteria) sem+  where+    criteria  = (constants &&& ambiguity) -- this is reverse sorting+                                          -- so high numbers come first+    ambiguity l = fromMaybe 0 $ do -- Maybe+        p <- boringLiteral l+        negate <$> Map.lookup p (literalCount sem)+    literalCount = histogram . mapMaybe boringLiteral+    boringLiteral = singletonVal . lPredicate +-- | Anything that we would want to count the number constants in+--   (as opposed to variables) class HasConstants a where+  -- | Number of constants   constants :: a -> Int  instance HasConstants GeniVal where@@ -103,22 +136,18 @@ instance HasConstants (Literal GeniVal) where   constants (Literal h p args) = constants (h:p:args) -literalCount :: [Literal GeniVal] -> Map.Map Text Int-literalCount = histogram . mapMaybe boringLiteral--boringLiteral :: Literal GeniVal -> Maybe Text-boringLiteral = singletonVal . lPredicate-    -- predicate with a straightfoward constant value-    -- exactly one constraint-+-- ---------------------------------------------------------------------- -- Traversal+-- ----------------------------------------------------------------------  instance DescendGeniVal a => DescendGeniVal (Literal a) where   descendGeniVal s (Literal h n lp) = Literal (descendGeniVal s h)                                               (descendGeniVal s n)                                               (descendGeniVal s lp) +-- ---------------------------------------------------------------------- -- Pretty printing+-- ----------------------------------------------------------------------  instance Pretty Sem where    pretty = geniShowText@@ -141,27 +170,42 @@     pretty = geniShowText  instance GeniShow SemInput where-    geniShowText (sem,icons,lcons) = T.intercalate "\n" . concat $+    geniShowText = displaySemInput (T.unwords . map geniShowText)++instance GeniShow LitConstr where+    geniShowText (sem, []) = geniShowText sem+    geniShowText (sem, cs) = geniShowText sem <> squares (T.unwords cs)++-- | Helper for displaying or pretty printing a semantic input+--+--   This gives you a bit of control over how each literal is+--   displayed+displaySemInput :: ([LitConstr] -> Text) -> SemInput -> Text+displaySemInput dispLits (sem, icons, lcons) =+    -- CAREFUL: if you're modifying this, note that geniShowText+    -- can be affected+    T.intercalate "\n" . concat $         [ [semStuff]         , [ idxStuff | not (null icons) ]         ]       where         semStuff = geniKeyword "semantics"-                 . squares . T.unwords+                 . squares . dispLits                  $ map withConstraints sem         idxStuff = geniKeyword "idxconstraints"                  . squares                  $ geniShowText icons         withConstraints lit =-            case concat [ cs | (p,cs) <- lcons, p == lit ] of-                [] -> geniShowText lit-                cs -> geniShowText lit `T.append` (squares . T.unwords $ cs)+            (lit, concat [ cs | (p,cs) <- lcons, p == lit ]) +-- | Is a handle generated by GenI. GenI lets you write literals without+--   a handle; in these cases a unique handle is generated and hidden+--   from the UI. isInternalHandle :: Text -> Bool isInternalHandle = ("genihandle" `T.isPrefixOf`)  -- ------------------------------------------------------------------------- Subsumption+-- * Subsumption -- ----------------------------------------------------------------------  -- | @x `subsumeSem` y@ returns all the possible ways to unify@@ -172,38 +216,45 @@ subsumeSem x y =   map (first sortSem) $ subsumeSemH x y +-- | Helper for 'subsumeSem' traversal subsumeSemH :: Sem -> Sem -> [(Sem,Subst)] subsumeSemH [] [] = [ ([], Map.empty) ] subsumeSemH _ []  = error "subsumeSemH: got longer list in front" subsumeSemH []     _  = [ ([], Map.empty) ] subsumeSemH (x:xs) ys = nub $- do let attempts = zip ys $ map (subsumeLiteral x) ys+ do let attempts = zip ys $ map (hush . subsumeLiteral x) ys     (y, Just (x2, subst)) <- attempts     let next_xs = replace subst xs         next_ys = replace subst $ delete y ys         prepend = insert x2 *** appendSubst subst     prepend `fmap` subsumeSemH next_xs next_ys --- | @p1 `subsumeLiteral` p2@... FIXME-subsumeLiteral :: Literal GeniVal -> Literal GeniVal -> Maybe (Literal GeniVal, Subst)-subsumeLiteral (Literal h1 p1 la1) (Literal h2 p2 la2) =+-- | @p1 `subsumeLiteral` p2@ is the unification of @p1@ and @p2@ if+--   both literals have the same arity, and the handles, predicates,+--   and arguments in @p1@ all subsume their counterparts in @p2@+subsumeLiteral :: MonadUnify m+               => Literal GeniVal+               -> Literal GeniVal+               -> m (Literal GeniVal, Subst)+subsumeLiteral l1@(Literal h1 p1 la1) l2@(Literal h2 p2 la2) =   if length la1 == length la2   then do let hpla1 = h1:p1:la1               hpla2 = h2:p2:la2           (hpla, sub) <- hpla1 `allSubsume` hpla2           return (toLiteral hpla, sub)-  else Nothing+  else throwError $ pretty l1 <+> "does not subsume" <+> pretty l2 <+>+                    "because they don't have the same arity"  where   toLiteral (h:p:xs) = Literal h p xs   toLiteral _ = error "subsumeLiteral.toLiteral"  -- ------------------------------------------------------------------------- Unification+-- * Unification -- ---------------------------------------------------------------------- --- We return the list of minimal ways to unify two semantics.--- By minimal, I mean that any literals that are not the product of a--- succesful unification really do not unify with anything else.+-- | Return the list of minimal ways to unify two semantics, ie.+-- where any literals that are not the product of a succesful unification+-- really do not unify with anything else. unifySem :: Sem -> Sem -> [(Sem,Subst)] unifySem xs ys =  map (first sortSem) $@@ -211,13 +262,13 @@     then unifySemH xs ys     else unifySemH ys xs --- list monad for Prolog-style backtracking.+-- | Helper traversal for 'unifySem' unifySemH :: Sem -> Sem -> [(Sem,Subst)] unifySemH [] [] = return ([], Map.empty) unifySemH [] xs = return (xs, Map.empty) unifySemH xs [] = error $ "unifySem: shorter list should always be in front: " ++ prettyStr xs-unifySemH (x:xs) ys = nub $ do- let attempts = zip ys $ map (unifyLiteral x) ys+unifySemH (x:xs) ys = nub $ do -- list monad for Prolog-style backtracking.+ let attempts = zip ys $ map (hush . unifyLiteral x) ys  if all (isNothing . snd) attempts     then first (x:) `fmap` unifySemH xs ys -- only include x unmolested if no unification succeeds     else do (y, Just (x2, subst)) <- attempts@@ -226,14 +277,19 @@                 prepend = insert x2 *** appendSubst subst             prepend `fmap` unifySemH next_xs next_ys -unifyLiteral :: Literal GeniVal -> Literal GeniVal -> Maybe (Literal GeniVal, Subst)-unifyLiteral (Literal h1 p1 la1) (Literal h2 p2 la2) =+-- | Two literals unify if they have the same arity, and their+--   handles, predicates, and arguments also unify+unifyLiteral :: MonadUnify m+             => Literal GeniVal+             -> Literal GeniVal -> m (Literal GeniVal, Subst)+unifyLiteral l1@(Literal h1 p1 la1) l2@(Literal h2 p2 la2) =   if length la1 == length la2   then do let hpla1 = h1:p1:la1               hpla2 = h2:p2:la2           (hpla, sub) <- hpla1 `unify` hpla2           return (toLiteral hpla, sub)-  else Nothing+  else throwError $ pretty l1 <+> "does not unify with" <+> pretty l2 <+>+                    "because they don't have the same arity"  where   toLiteral (h:p:xs) = Literal h p xs   toLiteral _ = error "unifyLiteral.toLiteral"@@ -243,17 +299,17 @@ -- ----------------------------------------------------------------------  {-!-deriving instance NFData Literal -deriving instance Binary Literal +deriving instance NFData Literal+deriving instance Binary Literal !-}  -- GENERATED START - + instance NFData g => NFData (Literal g) where         rnf (Literal x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - + instance Binary g => Binary (Literal g) where         put (Literal x1 x2 x3)           = do put x1

@@ -16,8 +16,11 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, LiberalTypeSynonyms, DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LiberalTypeSynonyms   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-} module NLP.GenI.Simple.SimpleBuilder (    -- Types    Agenda, AuxAgenda, Chart, SimpleStatus, SimpleState,@@ -39,51 +42,63 @@    ) where -import Control.Arrow (first)-import Control.Monad (when, unless, liftM2)-import Control.Monad.State.Strict (get, put, modify, gets, runState, execStateT)-import Data.Bits-import Data.Generics ( Data )-import Data.List (partition, foldl', sortBy, unfoldr )-import Data.Maybe (isJust, isNothing, mapMaybe, fromMaybe)-import Data.Ord (comparing)-import Data.Text ( Text )-import Data.Tree-import qualified Data.Map as Map-import qualified Data.Text as T+import           Control.Applicative        ((<$>))+import           Control.Arrow              (first)+import           Control.Monad              (liftM2, unless, when)+import           Control.Monad.State.Strict (execStateT, get, gets, modify, put,+                                             runState)+import           Data.Bits+import           Data.Generics              (Data)+import           Data.List+import qualified Data.Map                   as Map+import           Data.Ord                   (comparing)+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Data.Tree+import           Data.Typeable              (Typeable) -import NLP.GenI.Automaton ( automatonPaths, NFA(..), addTrans )-import NLP.GenI.Builder ( incrCounter, num_iterations, num_comparisons-                        , chart_size, SemBitMap, defineSemanticBits, semToBitVector, bitVectorToSem-                        , DispatchFilter, (>-->), condFilter, FilterStatus(Filtered, NotFiltered)-                        , GenStatus(..),-                        )-import NLP.GenI.Configuration-import NLP.GenI.FeatureStructure ( unifyFeat, Flist )-import NLP.GenI.General ( BitVector, mapMaybeM, mapTree', geniBug, preTerminals, repList )-import NLP.GenI.GeniVal ( GeniVal, replace, DescendGeniVal(..), Subst, appendSubst )-import NLP.GenI.Morphology.Types ( LemmaPlus(..) )-import NLP.GenI.Pretty-import NLP.GenI.Semantics ( sortSem, Sem )-import NLP.GenI.Statistics (Statistics)-import NLP.GenI.Tag-    ( TagElem, TagSite(..), getLexeme, toTagSite-    , tidnum, idname, ttree, ttype, tsemantics-    , detectSites, TagDerivation, DerivationStep(..)-    , plugTree, spliceTree-    , ts_rootFeatureMismatch, ts_synIncomplete, ts_semIncomplete-    , ts_tbUnificationFailure-    )-import NLP.GenI.TreeSchema-    ( Ptype(Initial), GNode(..), NodeName, gnnameIs-    , GType(Other), root, foot )-import qualified NLP.GenI.Builder as B+import           Control.Error +import           NLP.GenI.Automaton         (NFA (..), addTrans)+import           NLP.GenI.Builder           (DispatchFilter,+                                             FilterStatus (Filtered, NotFiltered),+                                             GenStatus (..), SemBitMap,+                                             bitVectorToSem, chart_size,+                                             condFilter, defineSemanticBits,+                                             incrCounter, num_comparisons,+                                             num_iterations, semToBitVector,+                                             (>-->))+import qualified NLP.GenI.Builder           as B+import           NLP.GenI.FeatureStructure  (Flist, unifyFeat)+import           NLP.GenI.Flag+import           NLP.GenI.General           (BitVector, geniBug, mapMaybeM,+                                             mapTree', preTerminals, repList)+import           NLP.GenI.GeniVal+import           NLP.GenI.Morphology.Types  (LemmaPlus (..))+import           NLP.GenI.Polarity+import           NLP.GenI.Pretty+import           NLP.GenI.Semantics         (Sem, sortSem)+import           NLP.GenI.Statistics        (Statistics)+import           NLP.GenI.Tag               (DerivationStep (..), TagDerivation,+                                             TagElem, TagSite (..), detectSites,+                                             getLexeme, idname, plugTree,+                                             spliceTree, tidnum, toTagSite,+                                             ts_rootFeatureMismatch,+                                             ts_semIncomplete, ts_synIncomplete,+                                             ts_tbUnificationFailure,+                                             tsemantics, ttree, ttype)+import           NLP.GenI.TreeSchema        (GNode (..), GType (Other),+                                             AdjunctionConstraint(..),+                                             isAdjConstrained,+                                             addInferredAdjConstraint,+                                             NodeName, Ptype (Initial), foot,+                                             gnnameIs, root)+ -- -------------------------------------------------------------------- -- The Builder interface -- -------------------------------------------------------------------- -type SimpleBuilder = B.Builder SimpleStatus SimpleItem Params+type SimpleBuilder = B.Builder SimpleStatus SimpleItem simpleBuilder_2p, simpleBuilder_1p :: SimpleBuilder simpleBuilder_2p = simpleBuilder True simpleBuilder_1p = simpleBuilder False@@ -104,6 +119,14 @@ -- Key types -- -------------------------------------------------------------------- +data AgendaStrategy =+      LifoAgenda   -- ^ last-in-first-out+    | GrLifoAgenda -- ^ guided realisation++agendaStrategy :: [Flag] -> AgendaStrategy+agendaStrategy config =+    if hasOpt Guided config then GrLifoAgenda else LifoAgenda+ type Agenda = [SimpleItem] type AuxAgenda  = [SimpleItem] type Chart  = [SimpleItem]@@ -120,17 +143,18 @@ type SimpleState a = B.BuilderState SimpleStatus a  data SimpleStatus = S-  { theAgenda    :: Agenda+  { theAgenda     :: Agenda   , theHoldingPen :: AuxAgenda-  , theChart     :: Chart-  , theTrash   :: Trash-  , theResults :: [SimpleItem]-  , tsem       :: BitVector-  , step       :: GenerationPhase-  , gencounter :: Integer-  , genconfig  :: Params+  , theChart      :: Chart+  , theTrash      :: Trash+  , theResults    :: [SimpleItem]+  , tsem          :: BitVector+  , step          :: GenerationPhase+  , gencounter    :: Integer+  , genconfig     :: [Flag]   -- we keep a SemBitMap strictly to help display the semantics-  , semBitMap  :: SemBitMap+  , semBitMap     :: SemBitMap+  , grPaths       :: [Int] -- ^ guided realisation: polarity paths to explore   }   -- deriving Show @@ -144,8 +168,13 @@  addToAgenda :: SimpleItem -> SimpleState () addToAgenda te = do-  te2 <- assignNewId te-  modify $ \s -> s{theAgenda = te2 : theAgenda s }+    strat <- gets (agendaStrategy . genconfig)+    te2   <- assignNewId te+    modify $ \s -> s { theAgenda = add strat te2 (theAgenda s) }+  where+    addLifo x a      = x : a+    add LifoAgenda   = addLifo+    add GrLifoAgenda = addLifo  updateAgenda :: Agenda -> SimpleState () updateAgenda a =@@ -162,13 +191,13 @@                    }   incrCounter chart_size 1 -addToTrash :: SimpleItem -> String -> SimpleState ()-addToTrash te err = do-  disableGui <- gets (hasFlagP DisableGuiFlg . genconfig)+addToTrash :: SimpleItem -> Text -> SimpleState ()+addToTrash te msg = do+  disableGui <- gets (hasFlag DisableGuiFlg . genconfig)   unless disableGui $     modify $ \s -> s { theTrash = te2 : theTrash s }   where-    te2 = modifyGuiStuff (\g -> g { siDiagnostic = err : siDiagnostic g }) te+    te2 = modifyGuiStuff (\g -> g { siDiagnostic = msg : siDiagnostic g }) te  addToResults :: SimpleItem -> SimpleState () addToResults te =@@ -179,25 +208,25 @@ -- ----------------------------------------------------------------------  data SimpleItem = SimpleItem- { siId        :: ChartId+ { siId         :: ChartId  --  , siSubstnodes :: [NodeName]  , siAdjnodes   :: [NodeName]  --- , siSemantics :: BitVector- , siPolpaths  :: BitVector+ , siSemantics  :: BitVector+ , siPolpaths   :: PolPathSet  -- for generation sans semantics  -- , siAdjlist :: [(String,Integer)] -- (node name, auxiliary tree id)- , siNodes   :: [GNode GeniVal]    -- ^ actually a set- , siDerived :: Tree Text- , siRoot_    :: NodeName- , siFoot_    :: Maybe NodeName+ , siNodes      :: [GNode GeniVal]    -- ^ actually a set+ , siDerived    :: Tree Text+ , siRoot_      :: NodeName+ , siFoot_      :: Maybe NodeName  --- , siPendingTb :: [NodeName] -- only for one-phase+ , siPendingTb  :: [NodeName] -- only for one-phase  -- how was this item produced?  , siDerivation :: TagDerivation  -- for the debugger only- , siGuiStuff :: SimpleGuiItem+ , siGuiStuff   :: SimpleGuiItem  } -- deriving (Show)  @@ -219,11 +248,11 @@  -- | Things whose only use is within the graphical debugger data SimpleGuiItem = SimpleGuiItem- { siHighlight :: [Text] -- ^ nodes to highlight+ { siHighlight  :: [Text] -- ^ nodes to highlight  -- if there are things wrong with this item, what?- , siDiagnostic :: [String]- , siFullSem :: Sem- , siIdname  :: Text+ , siDiagnostic :: [Text]+ , siFullSem    :: Sem+ , siIdname     :: Text  } deriving (Data, Typeable)  emptySimpleGuiItem :: SimpleGuiItem@@ -266,59 +295,92 @@ -- --------------------------------------------------------------------  -- | Creates an initial SimpleStatus.-initSimpleBuilder ::  Bool -> B.Input -> Params -> (SimpleStatus, Statistics)-initSimpleBuilder twophase input config =-  let disableGui = hasFlagP DisableGuiFlg config-      cands   = map (initSimpleItem disableGui bmap) $ B.inCands input-      (sem,_,_) = B.inSemInput input-      bmap    = defineSemanticBits sem-      -- FIXME: I don't know if this matters for one-phase-      -- because of on-the-fly tb unification (in 2p), we-      -- need an initial tb step that only addresses the-      -- nodes with null adjunction constraints-      simpleDp = if twophase then simpleDispatch_2p else simpleDispatch_1p-      initialDp = dpTbNaFailure >--> dpTbFailure >--> simpleDp-      ---      initS = S{ theAgenda    = []-               , theHoldingPen = []-               , theChart     = []-               , theTrash     = []-               , theResults   = []-               , semBitMap = bmap-               , tsem      = semToBitVector bmap sem-               , step     =  SubstitutionPhase-               , gencounter = 0-               , genconfig  = config }-      ---  in B.unlessEmptySem input config $-     runState (execStateT (mapM initialDp cands) initS) (B.initStats config)+initSimpleBuilder :: Bool    -- ^ use two phase algorithm+                  -> B.Input -- ^ input items+                  -> [Flag]  -- ^ GenI options+                  -> (SimpleStatus, Statistics)+initSimpleBuilder twophase input flags_ =+    B.unlessEmptySem input flags_ $+        runState (execStateT allocateAll initS) initStats+  where+    disableGui  = hasFlag DisableGuiFlg flags_+    cands       = map (initSimpleItem disableGui bmap)+                $ B.inCands input+    (sem,_,_)   = B.inSemInput input+    bmap        = defineSemanticBits sem+    --+    allocateAll = mapM initialDp cands+    -- FIXME: I don't know if this matters for one-phase+    -- because of on-the-fly tb unification (in 2p), we+    -- need an initial tb step that only addresses the+    -- nodes with null adjunction constraints+    simpleDp  = if twophase then simpleDispatch_2p+                            else simpleDispatch_1p+    initialDp = dpTbNaFailure >--> dpTbFailure >--> simpleDp+    --+    initS = S+        { theAgenda     = []+        , theHoldingPen = []+        , theChart      = []+        , theTrash      = []+        , theResults    = []+        , semBitMap     = bmap+        , tsem          = semToBitVector bmap sem+        , step          = SubstitutionPhase+        , gencounter    = 0+        , genconfig     = flags_+        , grPaths       = initGrPaths cands+        }+    initStats = B.initStats flags_ +-- | Initial paths for guided realisation+initGrPaths :: [SimpleItem] -> [Int]+initGrPaths [] = []+initGrPaths xs =+    polPathsToList $ foldl' expand emptyPolPaths xs+  where+    expand st x = st `unionPolPaths` siPolpaths x  initSimpleItem :: Bool -- ^ disable gui-               -> SemBitMap -> (TagElem, BitVector) -> SimpleItem-initSimpleItem disableGui bmap (teRaw,pp) =- let (te,tlite) = renameNodesWithTidnum teRaw in- case detectSites (ttree te) of- (snodes,anodes,nullAdjNodes) -> SimpleItem-  { siId        = tidnum te-  , siSemantics = semToBitVector bmap (tsemantics te)-  , siSubstnodes = snodes-  , siAdjnodes   = anodes-  , siPolpaths  = pp-  -- for generation sans semantics-  -- , siAdjlist = []-  , siNodes = flatten.ttree $ te-  , siDerived = tlite-  , siRoot_ = gnname . root $ theTree-  , siFoot_ = if ttype te == Initial then Nothing else Just . gnname . foot $ theTree-  , siDerivation = [ InitStep (gorigin . root $ theTree) ]-  -- note: see comment in initSimpleBuilder re: tb unification-  , siPendingTb = nullAdjNodes-  ---  , siGuiStuff = if disableGui then emptySimpleGuiItem else initSimpleGuiItem te-  }-  where theTree = ttree te+               -> SemBitMap+               -> (TagElem, PolPathSet)+               -> SimpleItem+initSimpleItem disableGui bmap (teRaw,pp) = SimpleItem+    { siId         = tidnum te+    , siSemantics  = semToBitVector bmap (tsemantics te)+    , siSubstnodes = snodes+    , siAdjnodes   = anodes+    , siPolpaths   = pp+    -- for generation sans semantics+    -- , siAdjlist = []+    , siNodes   = flatten tr+    , siDerived = tlite+    , siRoot_   = gnname (root tr)+    , siFoot_   = if ttype te == Initial+                      then Nothing+                      else Just . gnname $ foot tr+    , siDerivation = [ InitStep (gorigin (root tr)) ]+    -- note: see comment in initSimpleBuilder re: tb unification+    , siPendingTb = nullAdjNodes+    --+    , siGuiStuff = if disableGui+                      then emptySimpleGuiItem+                      else initSimpleGuiItem te+    }+  where+    (te,tlite) = renameNodesWithTidnum teRaw+    tr         = ttree te+    (snodes,anodes,nullAdjNodes) = detectSites tr +-- | Mark these nodes as non-adjunction+markNonAdjunctionSites :: SimpleItem -> SimpleItem+markNonAdjunctionSites g =+    g { siNodes = map mark (siNodes g) }+  where+    mark n = if gnname n `elem` siAdjnodes g+                 then n+                 else addInferredAdjConstraint n+ initSimpleGuiItem :: TagElem -> SimpleGuiItem initSimpleGuiItem te = SimpleGuiItem  { siHighlight = []@@ -389,57 +451,108 @@      mapM_ simpleDispatch_2p_adjphase res      when (adjdone given) $ trashIt given --- Helpers for the generateSteps- trashIt :: SimpleItem -> SimpleState ()-trashIt item =- do disableGui <- gets (hasFlagP DisableGuiFlg . genconfig)+trashIt item = do+    disableGui <- gets (hasFlag DisableGuiFlg . genconfig)     unless disableGui $ do+        { missing <- missingSem item+        ; let reason = if null missing+                          then "unknown reason!"+                          else ts_semIncomplete missing+        ; addToTrash item reason+        }++missingSem :: SimpleItem -> SimpleState Sem+missingSem item = do     s <- get-    let bmap = semBitMap s-        itemSem = siSemantics item+    let bmap     = semBitMap s         inputSem = tsem s-        reason = if inputSem == itemSem-                    then "unknown reason!"-                    else ts_semIncomplete $ bitVectorToSem bmap $ inputSem `xor` itemSem-    addToTrash item reason+        itemSem  = siSemantics item+    return $ bitVectorToSem bmap $ inputSem `xor` itemSem  -- | Arbitrarily selects and removes an element from the agenda and --   returns it. selectGiven :: SimpleState SimpleItem selectGiven = do-  agenda <- gets theAgenda-  case agenda of-   [] -> geniBug "null agenda in selectGiven"-   (a:atail) -> updateAgenda atail >> return a+    agenda <- gets theAgenda+    strat  <- gets (agendaStrategy . genconfig)+    case strat of+        LifoAgenda   -> selectLifo   agenda+        GrLifoAgenda -> selectGuided agenda +-- | Last-in-first-out selection from the agenda+selectLifo :: Agenda -> SimpleState SimpleItem+selectLifo []       = geniBug "null agenda in selectGiven"+selectLifo (a:as)   = updateAgenda as >> return a++-- | Guided realisation variant on selection+selectGuided :: Agenda -> SimpleState SimpleItem+selectGuided agenda =+    loop+  where+    loop = do+        p <- singletonPolPath <$> currentPath+        -- this partitioning isn't strictly necessary, as we only+        -- need to select one item, but perhaps from a UI point of+        -- view, it makes it easier to see what the surface realiser+        -- is doing+        case partition (hasPath p) agenda of+            ([],_) -> do+                advancePaths+                loop+            (a:as1, as2) -> do+                updateAgenda (as1 ++ as2)+                return a+    hasPath p = hasSharedPolPaths p . siPolpaths+    currentPath = do+        paths <- gets grPaths+        case paths of+            []     -> geniBug "out of polarity paths in selectGuided [1]"+            (p:_)  -> return p+    advancePaths = do+        paths <- gets grPaths+        case paths of+            []     -> geniBug "out of polarity paths in selectGuided [2]"+            (_:ps) -> modify $ \s -> s { grPaths = ps }+ -- Switching phases  switchToAux :: SimpleState () switchToAux = do-  st <- get-  let oldAuxTrees = theHoldingPen st-      -- You might be wondering why we ignore the auxiliary trees in the-      -- chart; this is because all the syntactically complete auxiliary-      -- trees have already been filtered away by calls to classifyNew-      initialT  = filter siInitial (theChart st)-      (compT1, incompT1) = partition (null.siSubstnodes) initialT-      (auxTrees, compT2) =-        ( mapMaybe (detectNa oldAuxTrees) oldAuxTrees-        , mapMaybe (detectNa auxTrees) compT1 )-      (compT3, incompT3) = semfilter (tsem st) auxTrees compT2-      ---      compT = compT3-  put st{ theAgenda = []-        , theHoldingPen = []-        , theChart = auxTrees-        , step = AdjunctionPhase }-  mapM_ simpleDispatch_2p_adjphase compT-  -- toss the syntactically incomplete stuff in the trash-  mapM_ (\t -> addToTrash t ts_synIncomplete) incompT1-  mapM_ (\t -> addToTrash t "sem-filtered") incompT3+    st <- get+    let oldAuxTrees = theHoldingPen st+        -- You might be wondering why we ignore the auxiliary trees in the+        -- chart; this is because all the syntactically complete auxiliary+        -- trees have already been filtered away by calls to classifyNew+        (auxTrees, incompAux) = mapEither (detectNa oldAuxTrees) oldAuxTrees+        initialT  = filter siInitial (theChart st)+        (compT1, incompT1) = partition (null.siSubstnodes) initialT+        (compT2, incompT2) = mapEither (detectNa auxTrees) compT1+        (compT3, incompT3) = semfilter (tsem st) auxTrees compT2+        --+        compT = compT3+    put st{ theAgenda     = []+          , theHoldingPen = []+          , theChart      = auxTrees+          , step          = AdjunctionPhase+          }+    mapM_ simpleDispatch_2p_adjphase compT+    -- toss the syntactically incomplete stuff in the trash+    mapM_ (\t -> addToTrash t ts_synIncomplete) incompT1+    mapM_ trashTb incompAux+    mapM_ trashTb incompT2+    mapM_ (\t -> addToTrash t =<< ts_semFiltered <$> missingSem t) incompT3+    modify $ \s -> s+        { grPaths = initGrPaths (theAgenda s)+        }+  where+    ts_semFiltered sem =+        "Sem-filtered, MISSING:" <+> squeezed 72 (map pretty sem)+    -- passing on the left, failures on right+    mapEither f = (\ (x,y) -> (y,x)) . partitionEithers . map f+    trashTb (n, msg, i) = trashTbUnificationError n msg i --- Completion+  -- Completion  finished :: Bool -> SimpleStatus -> GenStatus finished twophase st@@ -448,10 +561,10 @@   | atMaxSteps   = B.Error $ "Max steps exceeded" <+> parens (pretty maxSteps)   | otherwise    = B.Active  where-  reallyDone   = null (theAgenda st) && (not twophase || isAdjunctionPhase (step st)) -  atMaxResults = maybeIf (<= fromIntegral (length (theResults st))) $ getFlagP MaxResultsFlg (genconfig st)+  reallyDone   = null (theAgenda st) && (not twophase || isAdjunctionPhase (step st))+  atMaxResults = maybeIf (<= fromIntegral (length (theResults st))) $ getFlag MaxResultsFlg (genconfig st)   atMaxSteps   = maybeIf (<  gencounter st) mMaxSteps-  mMaxSteps    = getFlagP MaxStepsFlg (genconfig st)+  mMaxSteps    = getFlag MaxStepsFlg (genconfig st)   maxSteps     = fromMaybe (error "get maxsteps") mMaxSteps   maybeIf bf = maybe False bf @@ -459,14 +572,20 @@  semfilter :: BitVector -> [SimpleItem] -> [SimpleItem] -> ([SimpleItem], [SimpleItem]) semfilter inputsem auxs initial =-  let auxsem x = foldl' (.|.) 0 [ siSemantics a | a <- auxs, siPolpaths a .&. siPolpaths x /= 0 ]-      -- lite, here, means sans auxiliary semantics-      notjunk x = (siSemantics x) .&. inputsemLite == inputsemLite-                  where inputsemLite = inputsem `xor` (auxsem x)-      -- note that we can't just compare against siSemantics because-      -- that would exclude trees that have stuff in the aux semantics-      -- which would be overzealous-  in partition notjunk initial+    partition notjunk initial+  where+    auxsem x =+        foldl' (.|.) 0 [ siSemantics a | a <- auxs, goodPath a ]+      where+        goodPath a = hasSharedPolPaths (siPolpaths x) (siPolpaths a)+    -- lite, here, means sans auxiliary semantics+    notjunk x =+        siSemantics x .&. inputsemLite == inputsemLite+      where+        inputsemLite = inputsem `xor` auxsem x+        -- note that we can't just compare against siSemantics because+        -- that would exclude trees that have stuff in the aux semantics+        -- which would be overzealous  -- -------------------------------------------------------------------- -- Substitution@@ -503,9 +622,9 @@        do -- Maybe monad           let (TagSite n  fu fd nOrigin) = toTagSite (lookupOrBug "iapplySubst" item2 shead)               (TagSite rn ru rd rOrigin) = siRoot item1-          (newU, subst1) <- unifyFeat ru fu-          (newD, subst2) <- unifyFeat (replace subst1 rd)-                                      (replace subst1 fd)+          (newU, subst1) <- hush $ unifyFeat ru fu+          (newD, subst2) <- hush $ unifyFeat (replace subst1 rd)+                                             (replace subst1 fd)           let subst = appendSubst subst1 subst2               -- gui stuff               newRoot g = g { gup = newU, gdown = newD, gtype = Other }@@ -569,21 +688,31 @@  -- | Ignore the next adjunction node sansAdjunction2p item | closed item =- case siAdjnodes item of- [] -> return []- (ahead : atail) -> do-  let (TagSite gn t b _) = toTagSite (lookupOrBug "sansAdjunction2p" item ahead)-  -- do top/bottom unification on the node-  case unifyFeat t b of-   Nothing ->-     do addToTrash (modifyGuiStuff (\g -> g { siHighlight = [gn] }) item)-                   ts_tbUnificationFailure-        return []-   Just (tb,s) ->-     let item1 = constrainAdj gn tb item-     in return $! [replace s $! item1 { siAdjnodes = atail }]+    case siAdjnodes item of+        []              -> return []+        (ahead : atail) -> do+            -- do top/bottom unification on the node+            case unifyFeat t b of+                Left msg -> do+                    trashTbUnificationError gn msg item+                    return []+                Right (tb,s) -> do+                    let item1 = constrainAdj gn tb item+                    return $! [replace s $! item1 { siAdjnodes = atail }]+          where+            (TagSite gn t b _) = toTagSite (lookupOrBug "sansAdjunction2p" item ahead) sansAdjunction2p _ = return [] +-- | Trash an item, marking it as failing due to top/bot unification+--   error (and on what node)+trashTbUnificationError :: NodeName+                        -> Text     -- ^ failure msg+                        -> SimpleItem+                        -> SimpleState ()+trashTbUnificationError gn msg item = do+    addToTrash (modifyGuiStuff (\g -> g { siHighlight = [gn] }) item)+               (ts_tbUnificationFailure msg)+ iapplyAdjNode :: Bool -> SimpleItem -> SimpleItem -> Maybe SimpleItem iapplyAdjNode twophase aItem pItem = {-# SCC "iapplyAdjNode" #-}  case siAdjnodes pItem of@@ -619,7 +748,7 @@       finalRes1p = return $ replace subst12 rawCombined       finalRes2p =        do -- tb on the former foot-          tbRes <- unifyFeat (tsUp anf) (tsDown anf)+          tbRes <- hush $ unifyFeat (tsUp anf) (tsDown anf)           let (anf_tb, subst3) = tbRes               myRes = constrainAdj an_name anf_tb res'           -- apply the substitutions@@ -636,8 +765,8 @@   -- let's go!   let r = siRoot aItem -- auxiliary tree, eh?   f <- siFoot aItem -- should really be an error if fails-  (anr_up',  subst1)  <- unifyFeat (tsUp r) (tsUp pSite)-  (anf_down, subst2)  <- unifyFeat (replace subst1 $ tsDown f) (replace subst1 $ tsDown pSite)+  (anr_up',  subst1)  <- hush $ unifyFeat (tsUp r) (tsUp pSite)+  (anf_down, subst2)  <- hush $ unifyFeat (replace subst1 $ tsDown f) (replace subst1 $ tsDown pSite)   let -- combined substitution list and success condition       subst12 = appendSubst subst1 subst2       anr = replace subst12 $ r { tsUp = anr_up' } --  resulting node based on the root node of the aux tree@@ -647,23 +776,49 @@ testCanAdjoin :: SimpleItem -> TagSite -> Maybe (TagSite, TagSite, Subst) testCanAdjoin = canAdjoin +-- | Given a tree, identify nodes that cannot take adjunction and+--   do top-bottom unification on them.  Hopefully this will allow+--   us to detect top-bottom unification failures early on.+--+--   Note: no need to propagate substitutions outside of this+--   because items are assumed to be self-contained. This sort+--   of thing (what is self-contained) should really be reflected+--   in the types. detectNa :: [SimpleItem] -- ^ aux trees          -> SimpleItem   -- ^ me-         -> Maybe SimpleItem-detectNa rawAux i = helper (map look (siAdjnodes i)) Map.empty []- where-  look = toTagSite . lookupOrBug "detectNa" i-  compatAux = filterCompatible i rawAux-  helper []     s acc = Just $ replace s $ i { siAdjnodes = acc }-  helper (t:ts) s acc =-    let hasAdj = any isJust $ map (\a -> canAdjoin a t) compatAux-    in case (snd `fmap` unifyFeat (tsUp t) (tsDown t)) of-        Just s2 -> if hasAdj-                   then helper ts s (tsName t : acc)-                   else helper (replace s2 ts) (appendSubst s s2) acc-        Nothing -> if hasAdj-                   then helper ts s (tsName t : acc)-                   else Nothing+         -> Either (NodeName, Text, SimpleItem) SimpleItem+detectNa rawAux i =+    helper naDetectNodes Map.empty []+  where+    -- nodes to look for noadj constraints on+    naDetectNodes = map look $+        if aux i+            then delete (siRoot_ i) (siAdjnodes i)+            else siAdjnodes i+      where+        look = lookupOrBug "detectNa" i+    -- accumulator keeps tracks of nodes we want to delete+    helper [] s acc = Right $+        markNonAdjunctionSites $+        replace s $ i { siAdjnodes = siAdjnodes i \\ names+                      , siNodes    = acc ++ filter (\x -> gnname x `notElem` names) (siNodes i)+                      }+      where+        names = map gnname acc+    helper (n:ns) s acc = next $+        case unifyTb n of+            Left msg       -> Left (gnname n, msg, i)+            Right (t2, s2) -> helper (replace s2 ns) (appendSubst s s2) (tbUnified t2 : acc)+      where+        tbUnified t2 =+            n { gup = t2, gdown = [] }+        next adjfree =+            if any couldAdjoinHere compatAux+                then helper ns s acc+                else adjfree+        couldAdjoinHere a = isJust (canAdjoin a (toTagSite n))+    compatAux = filterCompatible i rawAux+    unifyTb t = unifyFeat (gup t) (gdown t)  -- -------------------------------------------------------------------- -- Helper functions for operations@@ -681,23 +836,22 @@ lookupChart given = gets (filterCompatible given . theChart)  filterCompatible :: SimpleItem -> [SimpleItem] -> [SimpleItem]-filterCompatible given chart =-  [ i | i <- chart-      -- should be on the same polarity path (chart sharing)-      , (siPolpaths i) .&. gpaths /= 0-      -- semantics should not be overlapping-      && (siSemantics i .&. gsem ) == 0-  ]- where-  gpaths = siPolpaths given-  gsem   = siSemantics given+filterCompatible given =+    filter (\i -> goodPolarities i && goodSemantics i)+  where+    goodPolarities   =+        hasSharedPolPaths gpols . siPolpaths+    goodSemantics i  =+        siSemantics i .&. gsem  == 0+    gpols  = siPolpaths given+    gsem   = siSemantics given  -- | Helper function for when chart operations succeed. combineSimpleItems :: [NodeName] -- ^ nodes to highlight                    -> SimpleItem -> SimpleItem -> SimpleItem combineSimpleItems hi item1 item2 = {-# SCC "combineSimpleItems" #-}   item2 { siSemantics = siSemantics item1 .|. siSemantics item2-        , siPolpaths  = siPolpaths  item1 .&. siPolpaths  item2+        , siPolpaths  = siPolpaths  item1 `intersectPolPaths` siPolpaths  item2         , siGuiStuff  = combineSimpleGuiItems hi (siGuiStuff item1) (siGuiStuff item2)         , siNodes     = siNodes item1 ++ siNodes item2         }@@ -710,10 +864,19 @@        , siHighlight = hi        } -constrainAdj :: Text -> Flist GeniVal -> SimpleItem -> SimpleItem+-- | Mark this nodes as non-adjunction+constrainAdj :: Text          -- ^ node name+             -> Flist GeniVal -- ^ new top feature+             -> SimpleItem+             -> SimpleItem constrainAdj gn newT g =-  g { siNodes = repList (gnnameIs gn) fixIt (siNodes g) }-  where fixIt n = n { gup = newT, gdown = [], gaconstr = True }+    g { siNodes = repList (gnnameIs gn) fixIt (siNodes g) }+  where+    fixIt n = n+       { gup      = newT+       , gdown    = []+       , gaconstr = InferredNoAdj+       }  -- Derivation trees @@ -762,10 +925,11 @@  dpAux, dpToAgenda :: SimpleDispatchFilter dpTbFailure, dpToResults :: SimpleDispatchFilter-dpToTrash :: String -> SimpleDispatchFilter  dpToAgenda x  = addToAgenda x  >> return Filtered dpToResults x = addToResults x >> return Filtered++dpToTrash :: Text -> SimpleDispatchFilter dpToTrash m x = addToTrash x m >> return Filtered  dpAux item =@@ -790,9 +954,9 @@  dpTbNaFailure :: SimpleDispatchFilter dpTbNaFailure item =- case tbUnifyNaNodes (siNodes item) of-   Nothing      -> dpToTrash ("top-bottom unification failure in NA nodes") item-   Just (ns2,s) -> return . NotFiltered . replace s $ item { siNodes = ns2 }+    case tbUnifyNaNodes (siNodes item) of+        Left msg      -> dpToTrash ("top-bottom unification failure in NA nodes: " <+> msg) item+        Right (ns2,s) -> return . NotFiltered . replace s $ item { siNodes = ns2 }  -- | This is only used for the one-phase algorithm dpTbFailure item =@@ -803,9 +967,9 @@ dpRootFeatFailure :: SimpleDispatchFilter dpRootFeatFailure item =  do config <- gets genconfig-    let rootFeat = getListFlagP RootFeatureFlg config+    let rootFeat = getListFlag RootFeatureFlg config         (TagSite _ top _ _) = siRoot item-    case unifyFeat rootFeat top of+    case hush $ unifyFeat rootFeat top of       Nothing ->         dpToTrash (ts_rootFeatureMismatch rootFeat) item       Just (_, s) ->@@ -815,15 +979,18 @@ -- Top and bottom unification -- -------------------------------------------------------------------- -tbUnifyNaNodes :: [GNode GeniVal] -> Maybe ([GNode GeniVal], Subst)-tbUnifyNaNodes [] = Just ([], Map.empty)+tbUnifyNaNodes :: MonadUnify m+               => [GNode GeniVal] -> m ([GNode GeniVal], Subst)+tbUnifyNaNodes [] = return ([], Map.empty) tbUnifyNaNodes (n:ns) =- if gaconstr n-    then do (ud, sub) <- unifyFeat (gup n) (gdown n)+    if isAdjConstrained n+        then do+            (ud, sub) <- unifyFeat (gup n) (gdown n)             let n2 = n { gup = ud, gdown = [] }             (ns2, sub2) <- tbUnifyNaNodes (replace sub ns)             return (n2:ns2, sub `appendSubst` sub2)-    else first (n:) `fmap` tbUnifyNaNodes ns+        else+            first (n:) <$> tbUnifyNaNodes ns  type TbEither = Either Text Subst tbUnifyTree :: SimpleItem -> Bool@@ -840,7 +1007,7 @@   case replace pending rawSite of   (TagSite name up down _) ->     -- check top/bottom unification on this node-    case unifyFeat up down of+    case hush (unifyFeat up down) of     -- stop all future iterations     Nothing -> Left name     -- apply any new substutions to the whole tree@@ -863,7 +1030,7 @@ unpackResult item =   let look = lookupOrBug "unpackResult" item       toUninflectedDisjunction (pt,t) =-        --B.UninflectedDisjunction (getLexeme (look t)) (gup (look pt)) +        --B.UninflectedDisjunction (getLexeme (look t)) (gup (look pt))         B.UninflectedDisjunction (getLexeme (look t))                                  (gup . look $ if emptyFeatureStr (look t) then pt else t) @@ -918,7 +1085,7 @@ coverage :: BitVector -> SimpleItem -> Int coverage sem it = countBits (sem .&. siSemantics it) -countBits :: Bits a => a -> Int+countBits :: (Num a, Bits a) => a -> Int countBits 0  = 0 countBits bs = if testBit bs 0 then 1 + next else next   where next = countBits (shiftR bs 1)

@@ -41,6 +41,7 @@     incrIntMetric, queryIntMetric, ) where +import Control.Applicative ( (<$>) ) import Control.Monad.State import Data.Maybe (mapMaybe) import Text.JSON@@ -97,13 +98,21 @@ --------------------------- JSON Output ------------------------------  instance JSON Statistics where- readJSON _j =-    error "can't read GenI statistics from JSON yet; sorry"- showJSON = JSObject . toJSObject . map metricToJSON . metrics+    readJSON (JSObject j) = do+        Stat <$> mapM jsonToMetric (fromJSObject j)+    readJSON j = fail $+        "Expected a JSON object, but got " ++ show j ++ " instead" +    showJSON = JSObject . toJSObject . map metricToJSON . metrics+ -- not quite showJSON here metricToJSON :: Metric -> (String, JSValue) metricToJSON (IntMetric s i) = (s, showJSON i)++jsonToMetric :: (String, JSValue) -> Result Metric+jsonToMetric (s, i) = IntMetric s <$> readJSON i++--------------------------- DeepSeq ------------------------------  {-! deriving instance NFData Statistics