From c6ac4801ad271ac2b7c093ce77172930529a1fb1 Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 30 Apr 2009 05:13:55 +0000 Subject: [PATCH] upgrade to GHC 6.10.2 --- GF.cabal | 2 +- src/GF/Compile/GenerateFCFG.hs | 21 +++++++++++---------- src/GF/Compile/GeneratePMCFG.hs | 23 ++++++++++++----------- src/GF/System/UseSignal.hs | 8 ++++---- src/GFI.hs | 8 ++++---- src/PGF/Parsing/FCFG/Incremental.hs | 2 +- 6 files changed, 33 insertions(+), 31 deletions(-) diff --git a/GF.cabal b/GF.cabal index 8d86528b5..207c3944f 100644 --- a/GF.cabal +++ b/GF.cabal @@ -709,7 +709,7 @@ executable gf other-modules: GF.System.NoReadline if flag(interrupt) - ghc-options: -DUSE_INTERRUPT + cpp-options: -DUSE_INTERRUPT other-modules: GF.System.UseSignal else other-modules: GF.System.NoSignal diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs index a0f82218c..26fd2a4d9 100644 --- a/src/GF/Compile/GenerateFCFG.hs +++ b/src/GF/Compile/GenerateFCFG.hs @@ -104,7 +104,7 @@ convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv) srules = [ (XRule id args res (map findLinType args) (findLinType res) term) | (id, (ty,_)) <- abs_defs, let (args,res) = catSkeleton ty, - term <- Map.lookup id cnc_defs] + term <- maybeToList (Map.lookup id cnc_defs)] findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) @@ -198,15 +198,15 @@ convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = do projectHead lbl_path toks <- member (strs:[strs' | Alt strs' _ <- vars]) return ((lbl_path, map (Right . KS) toks ++ lin) : lins) -convertTerm cnc_defs selector (F id) lins = do term <- Map.lookup id cnc_defs - convertTerm cnc_defs selector term lins -convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do +convertTerm cnc_defs selector (F id) lins = case Map.lookup id cnc_defs of + Just term -> convertTerm cnc_defs selector term lins + Nothing -> mzero +convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do ss <- case t of R ss -> return ss - F f -> do - t <- Map.lookup f cnc_defs - case t of - R ss -> return ss + F f -> case Map.lookup f cnc_defs of + Just (R ss) -> return ss + _ -> mzero convertRec cnc_defs selector 0 [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins convertTerm cnc_defs selector x lins = error ("convertTerm ("++show x++")") @@ -255,8 +255,9 @@ evalTerm cnc_defs path (R record) = case path of evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel evalTerm cnc_defs (index:path) term evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path -evalTerm cnc_defs path (F id) = do term <- Map.lookup id cnc_defs - evalTerm cnc_defs path term +evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of + Just term -> evalTerm cnc_defs path term + Nothing -> mzero evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs index 0ae32d483..244ed68fe 100644 --- a/src/GF/Compile/GeneratePMCFG.hs +++ b/src/GF/Compile/GeneratePMCFG.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fbang-patterns -cpp #-} +{-# LANGUAGE BangPatterns, CPP #-} ---------------------------------------------------------------------- -- | -- Maintainer : Krasimir Angelov @@ -50,7 +50,7 @@ convert abs_defs cnc_defs cat_defs = xrules = [ (XRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | (id, (ty,_)) <- abs_defs, let (args,res) = typeSkeleton ty, - term <- Map.lookup id cnc_defs] + term <- maybeToList (Map.lookup id cnc_defs)] findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) @@ -139,15 +139,15 @@ convertTerm cnc_defs sel ctype (K (KS t)) ((lbl_path,lin) : lins) = return ((l convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) = do toks <- member (strs:[strs' | Alt strs' _ <- vars]) return ((lbl_path, map (FSymTok . KS) toks ++ lin) : lins) -convertTerm cnc_defs sel ctype (F id) lins = do term <- Map.lookup id cnc_defs - convertTerm cnc_defs sel ctype term lins -convertTerm cnc_defs sel ctype (W s t) ((lbl_path,lin) : lins) = do +convertTerm cnc_defs sel ctype (F id) lins = case Map.lookup id cnc_defs of + Just term -> convertTerm cnc_defs sel ctype term lins + Nothing -> mzero +convertTerm cnc_defs sel ctype (W s t) ((lbl_path,lin) : lins) = do ss <- case t of R ss -> return ss - F f -> do - t <- Map.lookup f cnc_defs - case t of - R ss -> return ss + F f -> case Map.lookup f cnc_defs of + Just (R ss) -> return ss + _ -> mzero convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins convertTerm cnc_defs sel ctype x lins = error ("convertTerm ("++show x++")") @@ -202,8 +202,9 @@ evalTerm cnc_defs path (R record) = case path of evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel evalTerm cnc_defs (index:path) term evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path -evalTerm cnc_defs path (F id) = do term <- Map.lookup id cnc_defs - evalTerm cnc_defs path term +evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of + Just term -> evalTerm cnc_defs path term + Nothing -> mzero evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") diff --git a/src/GF/System/UseSignal.hs b/src/GF/System/UseSignal.hs index 628f5888d..20c70a568 100644 --- a/src/GF/System/UseSignal.hs +++ b/src/GF/System/UseSignal.hs @@ -16,7 +16,7 @@ module GF.System.UseSignal where import Control.Concurrent (myThreadId, killThread) -import Control.Exception (Exception,catch) +import Control.Exception (SomeException,catch) import Prelude hiding (catch) import System.IO @@ -48,10 +48,10 @@ myIgnore = Ignore -- unsafeInterleaveIO etc.) the lazy computation will -- not be interruptible, as it will be performed -- after the signal handler has been removed. -runInterruptibly :: IO a -> IO (Either Exception a) +runInterruptibly :: IO a -> IO (Either SomeException a) runInterruptibly a = do t <- myThreadId - oldH <- myInstallHandler (myCatch (print "Seek and Destroy" >> killThread t)) + oldH <- myInstallHandler (myCatch (killThread t)) x <- p `catch` h myInstallHandler oldH return x @@ -66,7 +66,7 @@ runInterruptibly_ = fmap (either (const ()) id) . runInterruptibly -- | Run an action with SIGINT blocked. blockInterrupt :: IO a -> IO a blockInterrupt a = - do oldH <- myInstallHandler Ignore + do oldH <- myInstallHandler myIgnore x <- a myInstallHandler oldH return x diff --git a/src/GFI.hs b/src/GFI.hs index cdf8ddf52..a5f5d835a 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -cpp #-} +{-# LANGUAGE ScopedTypeVariables, CPP #-} module GFI (mainGFI,mainRunGFI) where import GF.Command.Interpreter @@ -190,7 +190,7 @@ importInEnv gfenv opts files tryGetLine = do res <- try getLine case res of - Left e -> return "q" + Left (e :: SomeException) -> return "q" Right l -> return l welcome = unlines [ @@ -251,7 +251,7 @@ wordCompletion gfenv line0 prefix0 p = Nothing -> ret ' ' [] Just state -> let compls = getCompletions state prefix in ret ' ' (map (encode gfenv) (Map.keys compls)) - Left _ -> ret ' ' [] + Left (_ :: SomeException) -> ret ' ' [] CmplOpt (Just (Command n _ _)) pref -> case Map.lookup n (commands cmdEnv) of Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg] @@ -265,7 +265,7 @@ wordCompletion gfenv line0 prefix0 p = -> do mb_abs <- try (evaluate (abstract pgf)) case mb_abs of Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name] - Left _ -> ret ' ' [] + Left (_ :: SomeException) -> ret ' ' [] _ -> ret ' ' [] where line = decode gfenv line0 diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs index bd95ec34e..2950c2776 100644 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ b/src/PGF/Parsing/FCFG/Incremental.hs @@ -141,7 +141,7 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac FSymTok tok -> let !acc' = fn tok (Active j (ppos+1) funid seqid args key0) acc in process mbt fn seqs funs items acc' chart FSymLit d r -> let !fid = args !! d - in case [t | set <- IntMap.lookup fid (forest chart), FConst _ t <- Set.toList set] of + in case [t | FConst _ t <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of (tok:_) -> let !acc' = fn (KS tok) (Active j (ppos+1) funid seqid args key0) acc in process mbt fn seqs funs items acc' chart [] -> case litCatMatch fid mbt of