GenI 0.24.3 → 0.25.0
raw patch · 20 files changed
+123/−135 lines, 20 filesdep −cabal-macosxdep −old-localedep ~HUnitdep ~basedep ~binary
Dependencies removed: cabal-macosx, old-locale
Dependency ranges changed: HUnit, base, binary, bytestring, containers, deepseq, directory, filepath, hslogger, json, mtl, parsec, process, syb, text, time, transformers, yaml-light
Files
- GenI.cabal +30/−34
- src/NLP/GenI.hs +13/−14
- src/NLP/GenI/Automaton.hs +3/−3
- src/NLP/GenI/Builder.hs +1/−1
- src/NLP/GenI/Configuration.hs +3/−3
- src/NLP/GenI/Console.hs +3/−4
- src/NLP/GenI/ErrorIO.hs +2/−9
- src/NLP/GenI/FeatureStructure.hs +5/−3
- src/NLP/GenI/General.hs +9/−15
- src/NLP/GenI/GeniVal.hs +0/−1
- src/NLP/GenI/GeniVal/Internal.hs +7/−8
- src/NLP/GenI/LexicalSelection.hs +8/−7
- src/NLP/GenI/Morphology.hs +3/−3
- src/NLP/GenI/Parser.hs +1/−1
- src/NLP/GenI/Polarity.hs +5/−6
- src/NLP/GenI/Polarity/Internal.hs +2/−4
- src/NLP/GenI/Semantics.hs +8/−7
- src/NLP/GenI/Simple/SimpleBuilder.hs +15/−7
- src/NLP/GenI/Statistics.hs +1/−1
- src/NLP/GenI/TreeSchema.hs +4/−4
GenI.cabal view
@@ -1,5 +1,5 @@ Name: GenI-Version: 0.24.3+Version: 0.25.0 License: GPL License-file: LICENSE Author: Carlos Areces and Eric Kow@@ -57,27 +57,24 @@ Default: False Library- Build-depends: base >= 4 && < 5- , binary >= 0.5.0.2- , bytestring- , cabal-macosx >= 0.1.2 && < 0.3- , containers >= 0.1- , deepseq- , directory > 1- , errors- , filepath == 1.*- , hslogger- , json >= 0.4.3 && < 0.6- , mtl > 1.0- , old-locale- , ordered == 0.1.*- , parsec >= 2- , process > 1- , syb- , text- , time >= 1.1- , transformers- , yaml-light == 0.1.*+ Build-depends: base == 4.9.*+ , binary == 0.8.*+ , bytestring == 0.10.*+ , containers == 0.5.*+ , deepseq == 1.4.*+ , directory == 1.2.*+ , filepath == 1.4.*+ , hslogger == 1.2.*+ , json == 0.9.*+ , mtl == 2.2.*+ , ordered == 0.1.*+ , parsec == 3.1.*+ , process == 1.4.*+ , syb == 0.6.*+ , text == 1.2.*+ , time == 1.6.*+ , transformers == 0.5.*+ , yaml-light == 0.1.* if flag(static) ghc-options: -static -optl-static@@ -136,15 +133,14 @@ Ghc-prof-options: -auto-all Build-Depends: base >= 4 && < 5 , GenI- , containers >= 0.1- , directory > 1- , errors- , filepath == 1.*- , yaml-light == 0.1.*+ , containers+ , directory+ , filepath+ , yaml-light , hslogger- , json >= 0.4 && < 0.6- , mtl > 1.0- , process > 1+ , json+ , mtl+ , process Test-Suite geni-test Type: exitcode-stdio-1.0@@ -153,15 +149,15 @@ Default-language: Haskell2010 Build-Depends: GenI , base >= 4 && < 5- , containers >= 0.1+ , containers , errors- , filepath == 1.*+ , filepath , json , mtl- , parsec >= 2 && < 3.2+ , parsec , QuickCheck , smallcheck- , HUnit > 1 && < 1.3+ , HUnit , test-framework-hunit , test-framework-quickcheck2 , test-framework-smallcheck
src/NLP/GenI.hs view
@@ -59,7 +59,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.DeepSeq import Control.Exception-import Control.Monad.Error+import Control.Monad.Except import Data.Binary (Binary, decodeFile) import qualified Data.ByteString as BS import Data.IORef (IORef, modifyIORef, readIORef)@@ -80,7 +80,6 @@ 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@@ -232,7 +231,7 @@ -- | Load something, exiting GenI if we have not been given the -- appropriate flag-loadOrDie :: forall f a . (Eq f, Typeable f, Loadable a)+loadOrDie :: forall f a . (Typeable f, Loadable a) => L a -> (FilePath -> f) -- ^ flag -> String@@ -289,7 +288,7 @@ parse = parseFromFileMaybeBinary lParseFromFile -- | Load something, but only if we are configured to do so-loadOptional :: forall f a . (Eq f, Typeable f, Loadable a)+loadOptional :: forall f a . (Typeable f, Loadable a) => L a -> (FilePath -> f) -- ^ flag -> String@@ -392,7 +391,7 @@ -- Helpers for loading files -withFlag :: forall f a . (Eq f, Typeable f)+withFlag :: forall f a . (Typeable f) => (FilePath -> f) -- ^ flag -> ProgState -> IO a -- ^ null action@@ -401,14 +400,14 @@ withFlag flag pst z job = maybe z job $ getFlag flag (pa pst) -withFlagOrIgnore :: forall f . (Eq f, Typeable f)+withFlagOrIgnore :: forall f . (Typeable f) => (FilePath -> f) -- ^ flag -> ProgState -> (FilePath -> IO ()) -> IO () withFlagOrIgnore flag pst = withFlag flag pst (return ()) -withFlagOrDie :: forall f a . (Eq f, Typeable f)+withFlagOrDie :: forall f a . (Typeable f) => (FilePath -> f) -- ^ flag -> ProgState -> String@@ -510,7 +509,7 @@ -> CustomSem sem -> B.Builder st it -> TestCase sem- -> ErrorIO (GeniResults,st)+ -> ExceptT String IO (GeniResults,st) runGeni pst selector builder tc = do -- step 1: lexical selection istuff <- initGeni pst selector semInput@@ -544,9 +543,9 @@ -- | @simplifyResults <$> runGenI...'@ for an easier time if you don't need the -- surface realiser state-simplifyResults :: Either Text (GeniResults, st) -> GeniResults+simplifyResults :: Either String (GeniResults, st) -> GeniResults simplifyResults (Left t) = GeniResults- { grResults = [GError $ GeniError [t]]+ { grResults = [GError $ GeniError [T.pack t]] , grGlobalWarnings = [] , grStatistics = emptyStats }@@ -588,7 +587,7 @@ initGeni :: ProgState -> CustomSem sem -> sem- -> ErrorIO (B.Input, GeniWarnings)+ -> ExceptT String IO (B.Input, GeniWarnings) initGeni pst wrangler csem = do -- lexical selection selection <- runLexSelection pst wrangler csem@@ -596,7 +595,7 @@ "lexical selection returned " ++ (show . length $ lsAnchored selection) ++ " anchored trees"- semInput <- liftEither $ fromCustomSemInput wrangler csem+ semInput <- either (throwError . T.unpack) return $ fromCustomSemInput wrangler csem let initStuff = B.Input { B.inSemInput = semInput , B.inLex = lsLexEntries selection@@ -703,14 +702,14 @@ runLexSelection :: ProgState -> CustomSem sem -- ^ handler for custom semantics -> sem -- ^ semantics- -> ErrorIO LexicalSelection+ -> ExceptT String IO LexicalSelection runLexSelection pst wrangler csem = do let verbose = hasFlag VerboseModeFlg pst selector = customSelector wrangler -- perform lexical selection selection <- liftIO $ selector (gr pst) (le pst) csem -- finalise selection- sem@(tsem, _, _) <- liftEither $ fromCustomSemInput wrangler csem+ sem@(tsem, _, _) <- either (throwError . T.unpack) return $ fromCustomSemInput wrangler csem let lexCand = lsLexEntries selection candFinal = finaliseLexSelection (morphinf pst) sem (lsAnchored selection) -- status
src/NLP/GenI/Automaton.hs view
@@ -76,7 +76,7 @@ lookupTrans aut st ab = Map.keys $ Map.filter (elem ab) subT where subT = Map.findWithDefault Map.empty st (transitions aut) -addTrans :: (Ord ab, Ord st) =>+addTrans :: (Ord st) => NFA st ab -> st -- ^ from state -> Maybe ab -- ^ transition@@ -95,7 +95,7 @@ -- -- We assume that the automaton does not have any loops -- in it.-automatonPaths :: (Ord st, Ord ab) => (NFA st ab) -> [[ab]]+automatonPaths :: (Ord st) => (NFA st ab) -> [[ab]] automatonPaths aut = concatMap combinations $ map (filter (not.null)) $ automatonPathSets aut -- | The set of all bundled paths. A bundled path is a sequence of@@ -115,7 +115,7 @@ -- -- * Each item in the inner list represents a transition -- between two given states-automatonPathSets :: (Ord st, Ord ab) => (NFA st ab) -> [[ [ab] ]]+automatonPathSets :: (Ord st) => (NFA st ab) -> [[ [ab] ]] automatonPathSets aut = helper (startSt aut) where transFor st = Map.toList `fmap` Map.lookup st (transitions aut)
src/NLP/GenI/Builder.hs view
@@ -337,7 +337,7 @@ -- | If the item meets some condition, use the first filter, otherwise -- use the second one.-condFilter :: (Monad s) => (a -> Bool)+condFilter :: (a -> Bool) -> DispatchFilter s a -> DispatchFilter s a -> DispatchFilter s a condFilter cond f1 f2 = \x -> if cond x then f1 x else f2 x
src/NLP/GenI/Configuration.hs view
@@ -65,7 +65,7 @@ import Data.Yaml.YamlLight import System.Console.GetOpt import System.Log.Formatter-import System.Log.Handler (LogHandler, setFormatter)+import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import System.Log.Logger @@ -160,14 +160,14 @@ => (() -> f) -> ArgDescr Flag noArg s = NoArg (Flag s ()) -reqArg :: forall f x . (Eq f, Typeable f, Eq x, Typeable x)+reqArg :: forall f x . (Eq f, Typeable f, Typeable x) => (x -> f) -- ^ flag -> (String -> x) -- ^ string reader for flag (probably |id| if already a String) -> String -- ^ description -> ArgDescr Flag reqArg s fn desc = ReqArg (\x -> Flag s (fn x)) desc -optArg :: forall f x . (Eq f, Typeable f, Eq x, Typeable x)+optArg :: forall f x . (Eq f, Typeable f, Typeable x) => (x -> f) -- ^ flag -> x -- ^ default value -> (String -> x) -- ^ string reader (as in @reqArg@)
src/NLP/GenI/Console.hs view
@@ -29,7 +29,7 @@ import Control.Applicative (pure, (<$>)) import Control.Monad-import Control.Monad.Trans.Error+import Control.Monad.Except import qualified Data.ByteString as B import Data.IORef (modifyIORef, readIORef) import Data.List (find, partition)@@ -38,13 +38,12 @@ 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.Time (defaultTimeLocale, formatTime, getCurrentTime, iso8601DateFormat) 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 System.Log.Logger@@ -217,7 +216,7 @@ csem = tcSem tc cstr = tcSemString tc helper builder = do- res <- simplifyResults <$> (runErrorT $ runGeni pst wrangler builder tc)+ res <- simplifyResults <$> (runExceptT $ runGeni pst wrangler builder tc) writeResults pst args wrangler cstr csem res return res
src/NLP/GenI/ErrorIO.hs view
@@ -4,15 +4,8 @@ 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+import Control.Monad.Except -liftEither :: (Error e, Monad m) => Either e a -> ErrorT e m a+liftEither :: (Monad m) => Either e a -> ExceptT e m a liftEither (Left e) = throwError e liftEither (Right x) = return x
src/NLP/GenI/FeatureStructure.hs view
@@ -104,14 +104,16 @@ -- Traversal -instance DescendGeniVal v => DescendGeniVal (AvPair v) where+instance {-# OVERLAPPING #-} DescendGeniVal v => DescendGeniVal (AvPair v) where descendGeniVal s (AvPair a v) = {-# SCC "descendGeniVal" #-} AvPair a (descendGeniVal s v) instance DescendGeniVal a => DescendGeniVal (String, a) where descendGeniVal s (n,v) = {-# SCC "descendGeniVal" #-} (n,descendGeniVal s v) -instance DescendGeniVal v => DescendGeniVal ([String], Flist v) where- descendGeniVal s (a,v) = {-# SCC "descendGeniVal" #-} (a, descendGeniVal s v)+-- we actually get this for free since the two-tuple Functor instance only+-- applies to the second element+-- instance DescendGeniVal v => DescendGeniVal ([String], Flist v) where+-- descendGeniVal s (a,v) = {-# SCC "descendGeniVal" #-} (a, descendGeniVal s v) instance Collectable a => Collectable (AvPair a) where collect (AvPair _ b) = collect b
src/NLP/GenI/General.hs view
@@ -61,6 +61,7 @@ BitVector(..), showBitVector, -- * Errors, logging and exceptions+ hush, geniBug, prettyException, mkLogname,@@ -70,7 +71,6 @@ 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)@@ -80,15 +80,13 @@ 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.Tree import Data.Typeable (Typeable, typeOf)-import Prelude hiding (catch)+import Prelude import System.IO (hFlush, hPutStr, hPutStrLn, stderr) import System.IO.Error (ioeGetErrorString, isUserError) import Control.DeepSeq-import Text.JSON -- ---------------------------------------------------------------------- -- IO@@ -108,12 +106,8 @@ -- Strings -- ---------------------------------------------------------------------- -instance Binary Text where- put = put . T.encodeUtf8- get = liftM T.decodeUtf8 get- isGeniIdentLetter :: Char -> Bool-isGeniIdentLetter x = isAlphaNum x || x `elem` "_'+-."+isGeniIdentLetter x = isAlphaNum x || x `elem` ("_'+-." :: [Char]) trim :: String -> String trim = reverse . (dropWhile isSpace) . reverse . (dropWhile isSpace)@@ -149,7 +143,7 @@ | T.any naughty x = quoteText x | otherwise = x where- naughty c = not (isGeniIdentLetter c) || c `elem` "_?/"+ naughty c = not (isGeniIdentLetter c) || c `elem` ("_?/" :: [Char]) quoteText :: Text -> Text quoteText t =@@ -283,7 +277,7 @@ f x >>= (\my -> case my of Nothing -> mapMaybeM f xs- Just y -> liftM (y:) (mapMaybeM f xs))+ Just y -> liftM (y:) (mapMaybeM f xs)) -- | Return the list, modifying only the first matching item. repList :: (a->Bool) -> (a->a) -> [a] -> [a]@@ -370,6 +364,10 @@ -- Errors, exceptions and logging -- ---------------------------------------------------------------------- +-- | Ignore error string+hush :: Either e a -> Maybe a+hush = either (const Nothing) Just+ -- | errors specifically in GenI, which is very likely NOT the user's fault. geniBug :: String -> a geniBug s = error $ "Bug in GenI!\n" ++ s ++@@ -423,7 +421,3 @@ -- ---------------------------------------------------------------------- -- JSON -- ------------------------------------------------------------------------instance JSON Text where- readJSON = fmap T.pack . readJSON- showJSON = showJSON . T.unpack
src/NLP/GenI/GeniVal.hs view
@@ -18,7 +18,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TemplateHaskell #-} -- | GenI values (variables, constants) module NLP.GenI.GeniVal
src/NLP/GenI/GeniVal/Internal.hs view
@@ -19,7 +19,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Gory details for 'NLP.GenI.GeniVal'@@ -28,7 +27,7 @@ import Control.Applicative ((<$>)) import Control.Arrow (first, second, (***)) import Control.DeepSeq-import Control.Monad.Error+import Control.Monad.Except import Data.Binary import Data.Generics (Data) import Data.List@@ -142,9 +141,9 @@ -- Unification and subsumption -- ---------------------------------------------------------------------- -class (MonadPlus m, MonadError Text m, Monad m, Functor m) => MonadUnify m where+class (MonadPlus m, MonadError String m, Functor m) => MonadUnify m where -instance MonadUnify (Either Text) where+instance MonadUnify (Either String) where -- | 'unify' performs unification on two lists of 'GeniVal'. If -- unification succeeds, it returns @Just (r,s)@ where @r@ is@@ -162,7 +161,7 @@ -- | @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)+unifyHelper :: (MonadError String m) => (GeniVal -> GeniVal -> UnificationResult) -> [GeniVal] -> [GeniVal]@@ -174,7 +173,7 @@ helper l1 [] = return (l1, Map.empty) helper (h1:t1) (h2:t2) = case f h1 h2 of- Failure -> throwError . T.unwords $+ Failure -> throwError . T.unpack . T.unwords $ [ "unification failure between" , pretty h1, "and" , pretty h2@@ -369,7 +368,7 @@ collect Nothing s = s collect (Just x) s = collect x s -instance (Collectable a => Collectable [a]) where+instance Collectable a => Collectable [a] where collect l s = foldr collect s l instance Collectable GeniVal where@@ -503,7 +502,7 @@ instance DescendGeniVal GeniVal where descendGeniVal f = f -instance (Functor f, DescendGeniVal a) => DescendGeniVal (f a) where+instance {-# OVERLAPPABLE #-} (Functor f, DescendGeniVal a) => DescendGeniVal (f a) where descendGeniVal = fmap . descendGeniVal instance NFData GeniVal where
src/NLP/GenI/LexicalSelection.hs view
@@ -29,17 +29,18 @@ import Data.Function (on) import Data.List import qualified Data.Map as Map+import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Tree (Tree (Node)) -import Control.Error import Data.FullList hiding (head, tail, (++)) import qualified Data.FullList as FL import NLP.GenI.FeatureStructure (AvPair (..), Flist, unifyFeat) import NLP.GenI.General (filterTree, geniBug,- histogram, repAllNode,+ histogram, hush,+ repAllNode, repNodeByNode) import NLP.GenI.GeniVal import NLP.GenI.LexicalSelection.Types@@ -285,7 +286,7 @@ then croak t "Parameter length mismatch" else case unify lp tp of Left msg ->- croak t ("Parameter unification error: " <> msg)+ croak t ("Parameter unification error: " <> T.pack msg) Right (ps2, subst) -> let t2 = (replace subst t) { params = ps2 } in return (replace subst l, t2)@@ -296,7 +297,7 @@ -- trace ("unify interface" ++ wt) $ case unifyFeat (ifn l) (pinterface e) of Left msg ->- croak e ("Interface unification error: " <> msg)+ croak e ("Interface unification error: " <> T.pack msg) Right (int2, fsubst) -> let e2 = (replace fsubst e) { pinterface = int2 } in return (replace fsubst l, e2)@@ -319,9 +320,9 @@ foldM enrichBy t2 namedE 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 }+ case unifyFeat [en] (pinterface tx) of+ Left _ -> lexTell (ifaceEnrichErr en) >> fail ""+ Right (i2, isubs) -> return $ (replace isubs tx) { pinterface = i2 } ifaceEnrichErr (AvPair loc _) = SchemaError [pidname t] (EnrichError (PeqInterface loc))
src/NLP/GenI/Morphology.hs view
@@ -46,7 +46,7 @@ import qualified Data.Text as T import Data.Tree import Data.Typeable-import Prelude hiding (catch)+import Prelude import System.Exit import System.IO import System.Process@@ -128,8 +128,8 @@ anchor = head $ filterTree fn tt where fn a = (ganchor a && gtype a == Lex) in case unifyFeat mfs (gup anchor) of- Left err -> error . T.unpack $- "Morphological unification failure on" <+> idname te <> ":" <+> err+ Left err -> error $+ "Morphological unification failure on " <> T.unpack (idname te) <> ":" <> err Right (unf,subst) -> let -- perform replacements te2 = replace subst te
src/NLP/GenI/Parser.hs view
@@ -423,7 +423,7 @@ -- return (T.Node node kids) -geniNode :: (Ord v, GeniValLike v) => Parser (GNode v)+geniNode :: (GeniValLike v) => Parser (GNode v) geniNode = do name <- identifier nodeType <- geniNodeAnnotation
src/NLP/GenI/Polarity.hs view
@@ -47,12 +47,11 @@ import qualified Data.IntSet as IntSet import Data.List import qualified Data.Map as Map+import Data.Maybe import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Control.Error- import NLP.GenI.Automaton import NLP.GenI.FeatureStructure (AvPair (..), FeatStruct, Flist, unifyFeat)@@ -68,7 +67,7 @@ emptyLiteral, sortSem) import NLP.GenI.Tag (TagElem (..), TagItem (..), setTidnums)-import NLP.GenI.TreeSchema (GNode, Ptype (Initial), gdown, gup,+import NLP.GenI.TreeSchema (Ptype (Initial), gdown, gup, root, rootUpd) -- ----------------------------------------------------------------------@@ -435,9 +434,9 @@ oldr = root oldt tfup = gup oldr --- in case hush (unifyFeat tfup idxfs) of- Nothing -> te- Just (gup2, sub) -> replace sub $ te { ttree = newt }+ in case unifyFeat tfup idxfs of+ Left _ -> te+ Right (gup2, sub) -> replace sub $ te { ttree = newt } where newt = rootUpd oldt $ oldr { gup = gup2 } -- ====================================================================
src/NLP/GenI/Polarity/Internal.hs view
@@ -18,7 +18,7 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.GenI.Polarity.Internal where -import Control.Applicative+import Data.Either import Data.List import qualified Data.Map as Map import qualified Data.Set as Set@@ -26,8 +26,6 @@ import qualified Data.Text as T import Data.Tree (flatten) -import Control.Error (isRight)- import Data.FullList hiding ((++)) import NLP.GenI.Automaton import NLP.GenI.FeatureStructure@@ -165,7 +163,7 @@ -- repeatedly check the automaton for state uniqueness during its -- construction, but it is essential that this check be done after -- construction-nubAut :: (Ord ab, Ord st) => NFA st ab -> NFA st ab+nubAut :: (Ord ab) => NFA st ab -> NFA st ab nubAut aut = aut { transitions = Map.map (\e -> Map.map nub e) (transitions aut)
src/NLP/GenI/Semantics.hs view
@@ -29,19 +29,18 @@ import Control.Applicative ((<$>)) import Control.Arrow (first, (&&&), (***)) import Control.DeepSeq-import Control.Monad.Error+import Control.Monad.Except 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.Maybe import Data.Text (Text) import qualified Data.Text as T -import Control.Error- import NLP.GenI.FeatureStructure-import NLP.GenI.General (histogram)+import NLP.GenI.General (histogram, hush) import NLP.GenI.GeniShow import NLP.GenI.GeniVal import NLP.GenI.Pretty@@ -140,7 +139,7 @@ -- Traversal -- ---------------------------------------------------------------------- -instance DescendGeniVal a => DescendGeniVal (Literal a) where+instance {-# OVERLAPPING #-} DescendGeniVal a => DescendGeniVal (Literal a) where descendGeniVal s (Literal h n lp) = Literal (descendGeniVal s h) (descendGeniVal s n) (descendGeniVal s lp)@@ -242,7 +241,8 @@ hpla2 = h2:p2:la2 (hpla, sub) <- hpla1 `allSubsume` hpla2 return (toLiteral hpla, sub)- else throwError $ pretty l1 <+> "does not subsume" <+> pretty l2 <+>+ else throwError $ T.unpack+ $ pretty l1 <+> "does not subsume" <+> pretty l2 <+> "because they don't have the same arity" where toLiteral (h:p:xs) = Literal h p xs@@ -288,7 +288,8 @@ hpla2 = h2:p2:la2 (hpla, sub) <- hpla1 `unify` hpla2 return (toLiteral hpla, sub)- else throwError $ pretty l1 <+> "does not unify with" <+> pretty l2 <+>+ else throwError $ T.unpack+ $ 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
src/NLP/GenI/Simple/SimpleBuilder.hs view
@@ -48,17 +48,17 @@ import Control.Monad.State.Strict (execStateT, get, gets, modify, put, runState) import Data.Bits+import Data.Either import Data.Generics (Data) import Data.List import qualified Data.Map as Map+import Data.Maybe import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Data.Tree import Data.Typeable (Typeable) -import Control.Error- import NLP.GenI.Automaton (NFA (..), addTrans) import NLP.GenI.Builder (DispatchFilter, FilterStatus (Filtered, NotFiltered),@@ -550,7 +550,7 @@ "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+ trashTb (n, msg, i) = trashTbUnificationError n (T.pack msg) i -- Completion @@ -694,7 +694,7 @@ -- do top/bottom unification on the node case unifyFeat t b of Left msg -> do- trashTbUnificationError gn msg item+ trashTbUnificationError gn (T.pack msg) item return [] Right (tb,s) -> do let item1 = constrainAdj gn tb item@@ -706,7 +706,7 @@ -- | Trash an item, marking it as failing due to top/bot unification -- error (and on what node) trashTbUnificationError :: NodeName- -> Text -- ^ failure msg+ -> Text -- ^ failure msg -> SimpleItem -> SimpleState () trashTbUnificationError gn msg item = do@@ -754,6 +754,7 @@ -- apply the substitutions res' = replace (appendSubst subst12 subst3) rawCombined return myRes+ where -- --------------- if twophase then finalRes2p else finalRes1p @@ -786,7 +787,7 @@ -- in the types. detectNa :: [SimpleItem] -- ^ aux trees -> SimpleItem -- ^ me- -> Either (NodeName, Text, SimpleItem) SimpleItem+ -> Either (NodeName, String, SimpleItem) SimpleItem detectNa rawAux i = helper naDetectNodes Map.empty [] where@@ -955,7 +956,7 @@ dpTbNaFailure :: SimpleDispatchFilter dpTbNaFailure item = case tbUnifyNaNodes (siNodes item) of- Left msg -> dpToTrash ("top-bottom unification failure in NA nodes: " <+> msg) item+ Left msg -> dpToTrash ("top-bottom unification failure in NA nodes: " <+> T.pack msg) item Right (ns2,s) -> return . NotFiltered . replace s $ item { siNodes = ns2 } -- | This is only used for the one-phase algorithm@@ -1102,3 +1103,10 @@ `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 -}++-- --------------------------------------------------------------------+-- Odds and ends+-- --------------------------------------------------------------------++hush :: Either e a -> Maybe a+hush = either (const Nothing) Just
src/NLP/GenI/Statistics.hs view
@@ -68,7 +68,7 @@ --------------------------- Monadic Statistics functions follow ------------------------------ -initialStatisticsStateFor :: (MonadState Statistics m) => (m a -> Statistics -> b) -> m a -> b+initialStatisticsStateFor :: (m a -> Statistics -> b) -> m a -> b initialStatisticsStateFor f = flip f emptyStats -- | Adds a metric at the beginning of the list
src/NLP/GenI/TreeSchema.hs view
@@ -16,7 +16,7 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverlappingInstances, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} @@ -86,7 +86,7 @@ data Ptype = Initial | Auxiliar deriving (Show, Eq, Data, Typeable) -instance DescendGeniVal v => DescendGeniVal (Ttree v) where+instance {-# OVERLAPPING #-} DescendGeniVal v => DescendGeniVal (Ttree v) where descendGeniVal s mt = mt { params = descendGeniVal s (params mt) , tree = descendGeniVal s (tree mt)@@ -106,7 +106,7 @@ instance DescendGeniVal a => DescendGeniVal (Map.Map k a) where descendGeniVal s = {-# SCC "descendGeniVal" #-} Map.map (descendGeniVal s) -instance (Collectable a => Collectable (Tree a)) where+instance Collectable a => Collectable (Tree a) where collect = collect.flatten -- Utility functions@@ -206,7 +206,7 @@ instance Collectable gv => Collectable (GNode gv) where collect n = (collect $ gdown n) . (collect $ gup n) -instance DescendGeniVal v => DescendGeniVal (GNode v) where+instance {-# OVERLAPPING #-} DescendGeniVal v => DescendGeniVal (GNode v) where descendGeniVal s gn = gn { gup = descendGeniVal s (gup gn) , gdown = descendGeniVal s (gdown gn) }