upgrade to GHC 6.10.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