diff --git a/gf.cabal b/gf.cabal index 4cbc24a96..ae1d73774 100644 --- a/gf.cabal +++ b/gf.cabal @@ -108,7 +108,9 @@ executable gf process, pretty, mtl, - haskeline + haskeline, + parallel + ghc-options: -threaded if flag(server) build-depends: httpd-shed, network, silently, utf8-string, json, cgi cpp-options: -DSERVER_MODE diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index f7af80327..5988a20c8 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -56,11 +56,9 @@ checkModule opts mos mo@(m,mi) = do infoss <- checkErr $ topoSortJments2 mo foldM updateCheckInfos mo infoss where - updateCheckInfos mo0 = commitCheck . foldM updateCheckInfo mo0 - - updateCheckInfo mo@(m,mi) (i,info) = do - info <- accumulateError (checkInfo opts mos mo i) info - return (m,mi{jments=updateTree (i,info) (jments mi)}) + updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check + where check (i,info) = fmap ((,) i) (checkInfo opts mos mo i info) + update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)}) -- check if restricted inheritance modules are still coherent -- i.e. that the defs of remaining names don't depend on omitted names diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index 339e63a2b..b998f7508 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -16,7 +16,7 @@ module GF.Infra.CheckM (Check, CheckResult, Message, runCheck, checkError, checkCond, checkWarn, checkWarnings, checkAccumError, checkErr, checkIn, checkMap, checkMapRecover, - accumulateError, commitCheck + parallelCheck, accumulateError, commitCheck, ) where import GF.Data.Operations @@ -26,6 +26,8 @@ import GF.Grammar.Printer import qualified Data.Map as Map import Text.PrettyPrint +import Control.Parallel.Strategies(parList,rseq,using) +import Control.Monad(liftM) type Message = Doc type Error = Message @@ -38,6 +40,8 @@ data CheckResult a = Fail Error | Success a newtype Check a = Check {unCheck :: {-Context ->-} Accumulate NonFatal (CheckResult a)} +instance Functor Check where fmap = liftM + instance Monad Check where return x = Check $ \{-ctxt-} ws -> (ws,Success x) f >>= g = Check $ \{-ctxt-} ws -> @@ -98,14 +102,28 @@ runCheck c = bad (es,ws) = Bad (render $ list ws $$ list es) list = vcat . reverse +parallelCheck :: [Check a] -> Check [a] +parallelCheck cs = + Check $ \ {-ctxt-} (es0,ws0) -> + let os = [unCheck c {-[]-} ([],[])|c<-cs] `using` parList rseq + (msgs1,crs) = unzip os + (ess,wss) = unzip msgs1 + rs = [r | Success r<-crs] + fs = [f | Fail f<-crs] + msgs = (concat ess++es0,concat wss++ws0) + in if null fs + then (msgs,Success rs) + else (msgs,Fail (vcat $ reverse fs)) + checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b) checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v return (k,v)) (Map.toList map) return (Map.fromAscList xs) checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b) -checkMapRecover f mp = commitCheck (checkMap f' mp) - where f' key info = accumulateError (f key) info +checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList + where f' (k,v) = fmap ((,)k) (f k v) + {- checkMapRecover f mp = do let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)