diff --git a/GenI.cabal b/GenI.cabal --- a/GenI.cabal +++ b/GenI.cabal @@ -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 diff --git a/src/NLP/GenI.hs b/src/NLP/GenI.hs --- a/src/NLP/GenI.hs +++ b/src/NLP/GenI.hs @@ -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 diff --git a/src/NLP/GenI/Automaton.hs b/src/NLP/GenI/Automaton.hs --- a/src/NLP/GenI/Automaton.hs +++ b/src/NLP/GenI/Automaton.hs @@ -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) diff --git a/src/NLP/GenI/Builder.hs b/src/NLP/GenI/Builder.hs --- a/src/NLP/GenI/Builder.hs +++ b/src/NLP/GenI/Builder.hs @@ -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 diff --git a/src/NLP/GenI/Configuration.hs b/src/NLP/GenI/Configuration.hs --- a/src/NLP/GenI/Configuration.hs +++ b/src/NLP/GenI/Configuration.hs @@ -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@) diff --git a/src/NLP/GenI/Console.hs b/src/NLP/GenI/Console.hs --- a/src/NLP/GenI/Console.hs +++ b/src/NLP/GenI/Console.hs @@ -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 diff --git a/src/NLP/GenI/ErrorIO.hs b/src/NLP/GenI/ErrorIO.hs --- a/src/NLP/GenI/ErrorIO.hs +++ b/src/NLP/GenI/ErrorIO.hs @@ -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 diff --git a/src/NLP/GenI/FeatureStructure.hs b/src/NLP/GenI/FeatureStructure.hs --- a/src/NLP/GenI/FeatureStructure.hs +++ b/src/NLP/GenI/FeatureStructure.hs @@ -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 diff --git a/src/NLP/GenI/General.hs b/src/NLP/GenI/General.hs --- a/src/NLP/GenI/General.hs +++ b/src/NLP/GenI/General.hs @@ -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 diff --git a/src/NLP/GenI/GeniVal.hs b/src/NLP/GenI/GeniVal.hs --- a/src/NLP/GenI/GeniVal.hs +++ b/src/NLP/GenI/GeniVal.hs @@ -18,7 +18,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TemplateHaskell #-} -- | GenI values (variables, constants) module NLP.GenI.GeniVal diff --git a/src/NLP/GenI/GeniVal/Internal.hs b/src/NLP/GenI/GeniVal/Internal.hs --- a/src/NLP/GenI/GeniVal/Internal.hs +++ b/src/NLP/GenI/GeniVal/Internal.hs @@ -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 diff --git a/src/NLP/GenI/LexicalSelection.hs b/src/NLP/GenI/LexicalSelection.hs --- a/src/NLP/GenI/LexicalSelection.hs +++ b/src/NLP/GenI/LexicalSelection.hs @@ -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)) diff --git a/src/NLP/GenI/Morphology.hs b/src/NLP/GenI/Morphology.hs --- a/src/NLP/GenI/Morphology.hs +++ b/src/NLP/GenI/Morphology.hs @@ -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 diff --git a/src/NLP/GenI/Parser.hs b/src/NLP/GenI/Parser.hs --- a/src/NLP/GenI/Parser.hs +++ b/src/NLP/GenI/Parser.hs @@ -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 diff --git a/src/NLP/GenI/Polarity.hs b/src/NLP/GenI/Polarity.hs --- a/src/NLP/GenI/Polarity.hs +++ b/src/NLP/GenI/Polarity.hs @@ -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 } -- ==================================================================== diff --git a/src/NLP/GenI/Polarity/Internal.hs b/src/NLP/GenI/Polarity/Internal.hs --- a/src/NLP/GenI/Polarity/Internal.hs +++ b/src/NLP/GenI/Polarity/Internal.hs @@ -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) diff --git a/src/NLP/GenI/Semantics.hs b/src/NLP/GenI/Semantics.hs --- a/src/NLP/GenI/Semantics.hs +++ b/src/NLP/GenI/Semantics.hs @@ -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 diff --git a/src/NLP/GenI/Simple/SimpleBuilder.hs b/src/NLP/GenI/Simple/SimpleBuilder.hs --- a/src/NLP/GenI/Simple/SimpleBuilder.hs +++ b/src/NLP/GenI/Simple/SimpleBuilder.hs @@ -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 diff --git a/src/NLP/GenI/Statistics.hs b/src/NLP/GenI/Statistics.hs --- a/src/NLP/GenI/Statistics.hs +++ b/src/NLP/GenI/Statistics.hs @@ -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 diff --git a/src/NLP/GenI/TreeSchema.hs b/src/NLP/GenI/TreeSchema.hs --- a/src/NLP/GenI/TreeSchema.hs +++ b/src/NLP/GenI/TreeSchema.hs @@ -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) }