GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

upgrade to GHC 6.10.2

Browse Source
This commit is contained in:
krasimir
2009-04-30 05:13:55 +00:00
parent c14a899ab4
commit c6ac4801ad
6 changed files with 33 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
GF.cabal
View File

@@ -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

21
src/GF/Compile/GenerateFCFG.hs
View File

@@ -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

23
src/GF/Compile/GeneratePMCFG.hs
View File

@@ -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++")")

8
src/GF/System/UseSignal.hs
View File

@@ -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

8
src/GFI.hs
View File

@@ -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

2
src/PGF/Parsing/FCFG/Incremental.hs
View File

@@ -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