From 018c9838ed31571b699118ae75b1d62d5527fd77 Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 20 Nov 2013 00:45:33 +0000 Subject: [PATCH] Reduced clutter in monadic code + Eliminated vairous ad-hoc coersion functions between specific monads (IO, Err, IOE, Check) in favor of more general lifting functions (liftIO, liftErr). + Generalized many basic monadic operations from specific monads to arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad), thereby completely eliminating the need for lifting functions in lots of places. This can be considered a small step forward towards a cleaner compiler API and more malleable compiler code in general. --- src/compiler/GF.hs | 5 +- src/compiler/GF/Compile.hs | 49 ++++++++-------- src/compiler/GF/Compile/CheckGrammar.hs | 12 ++-- src/compiler/GF/Compile/GeneratePMCFG.hs | 12 ++-- src/compiler/GF/Compile/ReadFiles.hs | 54 +++++++++--------- src/compiler/GF/Compile/Rename.hs | 8 +-- src/compiler/GF/Compile/Tags.hs | 2 +- src/compiler/GF/Compile/TypeCheck/Concrete.hs | 28 +++++----- src/compiler/GF/Compile/Update.hs | 12 ++-- src/compiler/GF/Data/Operations.hs | 29 ++++++---- src/compiler/GF/Grammar/CF.hs | 12 ++-- src/compiler/GF/Grammar/Grammar.hs | 8 +-- src/compiler/GF/Grammar/Lockfield.hs | 4 +- src/compiler/GF/Grammar/Lookup.hs | 44 +++++++-------- src/compiler/GF/Grammar/Macros.hs | 22 ++++---- src/compiler/GF/Grammar/PatternMatch.hs | 18 +++--- src/compiler/GF/Infra/CheckM.hs | 12 ++-- src/compiler/GF/Infra/UseIO.hs | 56 +++++++------------ src/compiler/GFC.hs | 12 ++-- src/compiler/GFI.hs | 5 +- src/compiler/GFServer.hs | 6 +- 21 files changed, 196 insertions(+), 214 deletions(-) diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 04748b85b..68e43b6ca 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -12,7 +12,6 @@ import Data.Version import System.Directory import System.Environment (getArgs) import System.Exit -import System.IO import GF.System.Console (setConsoleEncoding) main :: IO () @@ -23,8 +22,8 @@ main = do Ok (opts,files) -> do curr_dir <- getCurrentDirectory lib_dir <- getLibraryDirectory opts mainOpts (fixRelativeLibPaths curr_dir lib_dir opts) files - Bad err -> do hPutStrLn stderr err - hPutStrLn stderr "You may want to try --help." + Bad err -> do ePutStrLn err + ePutStrLn "You may want to try --help." exitFailure mainOpts :: Options -> [FilePath] -> IO () diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 00eec6e30..e22ded71e 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -51,8 +51,8 @@ link opts cnc gr = do putPointE Normal opts "linking ... " $ do let abs = err (const cnc) id $ abstractOfConcrete gr cnc pgf <- mkCanon2pgf opts gr abs - probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) - ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK" + probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) + when (verbAtLeast opts Normal) $ putStrE "OK" return $ setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf @@ -73,14 +73,14 @@ compileSourceGrammar opts gr = do -- to output an intermediate stage intermOut :: Options -> Dump -> Doc -> IOE () intermOut opts d doc - | dump opts d = ioeIO (hPutStrLn stderr (render (text "\n\n--#" <+> text (show d) $$ doc))) + | dump opts d = ePutStrLn (render (text "\n\n--#" <+> text (show d) $$ doc)) | otherwise = return () warnOut opts warnings | null warnings = return () - | otherwise = ioeIO $ hPutStrLn stderr ws `catch` oops + | otherwise = liftIO $ ePutStrLn ws `catch` oops where - oops _ = hPutStrLn stderr "" -- prevent crash on character encoding problem + oops _ = ePutStrLn "" -- prevent crash on character encoding problem ws = if flag optVerbosity opts == Normal then '\n':warnings else warnings @@ -99,37 +99,37 @@ compileModule opts1 env file = do file <- getRealFile file opts0 <- getOptionsFromFile file curr_dir <- return $ dropFileName file - lib_dir <- ioeIO $ getLibraryDirectory (addOptions opts0 opts1) + lib_dir <- liftIO $ getLibraryDirectory (addOptions opts0 opts1) let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1 - ps0 <- ioeIO $ extendPathEnv opts + ps0 <- liftIO $ extendPathEnv opts let ps = nub (curr_dir : ps0) - ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ---- + liftIO $ putIfVerb opts $ "module search path:" +++ show ps ---- let (_,sgr,rfs) = env files <- getAllFiles opts ps rfs file - ioeIO $ putIfVerb opts $ "files to read:" +++ show files ---- + liftIO $ putIfVerb opts $ "files to read:" +++ show files ---- let names = map justModuleName files - ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ---- + liftIO $ putIfVerb opts $ "modules to include:" +++ show names ---- foldM (compileOne opts) (0,sgr,rfs) files where getRealFile file = do - exists <- ioeIO $ doesFileExist file + exists <- liftIO $ doesFileExist file if exists then return file else if isRelative file - then do lib_dir <- ioeIO $ getLibraryDirectory opts1 + then do lib_dir <- liftIO $ getLibraryDirectory opts1 let file1 = lib_dir file - exists <- ioeIO $ doesFileExist file1 + exists <- liftIO $ doesFileExist file1 if exists then return file1 - else ioeErr $ Bad (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1))) - else ioeErr $ Bad (render (text "File" <+> text file <+> text "does not exist.")) + else raise (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1))) + else raise (render (text "File" <+> text file <+> text "does not exist.")) compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv compileOne opts env@(_,srcgr,_) file = do let putpOpt v m act | verbAtLeast opts Verbose = putPointE Normal opts v act - | verbAtLeast opts Normal = ioeIO (putStrFlush m) >> act + | verbAtLeast opts Normal = putStrE m >> act | otherwise = putPointE Verbose opts v act let path = dropFileName file @@ -140,13 +140,14 @@ compileOne opts env@(_,srcgr,_) file = do -- for compiled gf, read the file and update environment -- also undo common subexp optimization, to enable normal computations ".gfo" -> do - sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (decodeModule file) + sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ liftIO (decodeModule file) let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts}) intermOut opts (Dump Source) (ppModule Internal sm0) let sm1 = unsubexpModule sm0 - (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1 + (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} + runCheck $ extendModule srcgr sm1 warnOut opts warnings if flag optTagsOnly opts @@ -158,14 +159,14 @@ compileOne opts env@(_,srcgr,_) file = do -- for gf source, do full compilation and generate code _ -> do - b1 <- ioeIO $ doesFileExist file + b1 <- liftIO $ doesFileExist file if not b1 then compileOne opts env $ (gf2gfo opts file) else do sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ getSourceModule opts file - enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00)))) + enc <- liftIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00)))) let sm = decodeStringsInModule enc sm00 intermOut opts (Dump Source) (ppModule Internal sm) @@ -215,8 +216,8 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do idump pass = intermOut opts (Dump pass) . ppModule Internal -- * Impedance matching - runPass = runPass' fst fst snd (ioeErr . runCheck) - runPass2 = runPass2e ioeErr + runPass = runPass' fst fst snd (liftErr . runCheck) + runPass2 = runPass2e liftErr runPass2' = runPass2e id id Canon runPass2e lift f = runPass' id f (const "") lift @@ -234,7 +235,7 @@ writeGFO opts file mo = do let mo1 = subexpModule mo mo2 = case mo1 of (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)}) - putPointE Normal opts (" write file" +++ file) $ ioeIO $ encodeModule file mo2 + putPointE Normal opts (" write file" +++ file) $ liftIO $ encodeModule file mo2 -- auxiliaries @@ -247,7 +248,7 @@ extendCompileEnvInt (_,gr,menv) k mfile mo = do menv2 <- case mfile of Just file -> do let (mod,imps) = importsOfModule mo - t <- ioeIO $ getModificationTime file + t <- liftIO $ getModificationTime file return $ Map.insert mod (t,imps) menv _ -> return menv return (k,prependModule gr mo,menv2) --- reverse later diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 967925275..568686f92 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -50,10 +50,10 @@ checkModule opts sgr mo@(m,mi) = do checkRestrictedInheritance sgr mo mo <- case mtype mi of MTConcrete a -> do let gr = prependModule sgr mo - abs <- checkErr $ lookupModule gr a + abs <- lookupModule gr a checkCompleteGrammar opts gr (a,abs) mo _ -> return mo - infoss <- checkErr $ topoSortJments2 mo + infoss <- topoSortJments2 mo foldM updateCheckInfos mo infoss where updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check @@ -246,7 +246,7 @@ checkInfo opts sgr (m,mo) c info = do ResOverload os tysts -> chIn NoLoc "overloading" $ do tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones - tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too + tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too tysts1 <- mapM (uncurry $ flip (checkLType gr [])) [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] --- this can only be a partial guarantee, since matching @@ -267,7 +267,7 @@ checkInfo opts sgr (m,mo) c info = do nest 2 (text "Happened in" <+> text cat <+> ppIdent c)) mkPar (f,co) = do - vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co + vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co return $ map (mkApp (QC (m,f))) vs checkUniq xss = case xss of @@ -317,13 +317,13 @@ linTypeOfType cnc m typ = do let vars = mkRecType varLabel $ replicate n typeStr symb = argIdent n cat i rec <- if n==0 then return val else - checkErr $ errIn (render (text "extending" $$ + errIn (render (text "extending" $$ nest 2 (ppTerm Unqualified 0 vars) $$ text "with" $$ nest 2 (ppTerm Unqualified 0 val))) $ plusRecType vars val return (Explicit,symb,rec) lookLin (_,c) = checks [ --- rather: update with defLinType ? - checkErr (lookupLincat cnc m c) >>= computeLType cnc [] + lookupLincat cnc m c >>= computeLType cnc [] ,return defLinType ] diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 457853150..059038b6c 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -23,10 +23,9 @@ import GF.Grammar.Predef import GF.Grammar.Lockfield (isLockLabel) import GF.Data.BacktrackM import GF.Data.Operations -import GF.Infra.UseIO (IOE) +import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn) import GF.Data.Utilities (updateNthM) --updateNth import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL) -import System.IO(hPutStr,hPutStrLn,stderr) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List @@ -39,7 +38,6 @@ import Data.Array.Unboxed --import Data.Char (isDigit) import Control.Monad import Control.Monad.Identity -import Control.Monad.Trans (liftIO) --import Control.Exception ---------------------------------------------------------------------- @@ -48,7 +46,7 @@ import Control.Monad.Trans (liftIO) generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule generatePMCFG opts sgr opath cmo@(cm,cmi) = do (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi) - when (verbAtLeast opts Verbose) $ liftIO $ hPutStrLn stderr "" + when (verbAtLeast opts Verbose) $ ePutStrLn "" return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) where cenv = resourceValues gr @@ -87,9 +85,9 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont !funs_cnt = e-s+1 in (prods_cnt,funs_cnt) - when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs))) + when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs))) seqs1 `seq` stats `seq` return () - when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr (" "++show stats) + when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats) return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg)) where (ctxt,res,_) = err bug typeForm (lookupFunType gr am id) @@ -128,7 +126,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc let pmcfg = getPMCFG pmcfgEnv2 - when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pcat)) + when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat)) seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg)) where addLindef lins (newCat', newArgs') env0 = diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs index de95cb30a..54abc7f48 100644 --- a/src/compiler/GF/Compile/ReadFiles.hs +++ b/src/compiler/GF/Compile/ReadFiles.hs @@ -35,8 +35,6 @@ import GF.Grammar.Grammar import GF.Grammar.Binary import Control.Monad ---import Data.Char ---import Data.List import Data.Maybe(isJust) import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map @@ -52,11 +50,11 @@ type ModEnv = Map.Map ModName (UTCTime,[ModName]) -- | Returns a list of all files to be compiled in topological order i.e. -- the low level (leaf) modules are first. -getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] +getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath] getAllFiles opts ps env file = do -- read module headers from all files recursively ds <- liftM reverse $ get [] [] (justModuleName file) - ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds] + liftIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds] return $ paths ds where -- construct list of paths to read @@ -71,12 +69,12 @@ getAllFiles opts ps env file = do -- | traverses the dependency graph and returns a topologicaly sorted -- list of ModuleInfo. An error is raised if there is circular dependency - get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles + {- get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles -> [ModuleInfo] -- ^ a list of already traversed modules -> ModName -- ^ the current module - -> IOE [ModuleInfo] -- ^ the final + -> IOE [ModuleInfo] -- ^ the final -} get trc ds name - | name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc + | name `elem` trc = raise $ "circular modules" +++ unwords trc | (not . null) [n | (n,_,_,_,_,_) <- ds, name == n] --- file already read = return ds | otherwise = do @@ -91,20 +89,20 @@ getAllFiles opts ps env file = do -- searches for module in the search path and if it is found -- returns 'ModuleInfo'. It fails if there is no such module - findModule :: ModName -> IOE ModuleInfo + --findModule :: ModName -> IOE ModuleInfo findModule name = do (file,gfTime,gfoTime) <- do - mb_gfFile <- ioeIO $ getFilePath ps (gfFile name) + mb_gfFile <- getFilePath ps (gfFile name) case mb_gfFile of - Just gfFile -> do gfTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfFile - mb_gfoTime <- ioeIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile)) + Just gfFile -> do gfTime <- liftIO $ toUTCTime `fmap` getModificationTime gfFile + mb_gfoTime <- liftIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile)) (\_->return Nothing) return (gfFile, Just gfTime, mb_gfoTime) - Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name) + Nothing -> do mb_gfoFile <- getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name) case mb_gfoFile of - Just gfoFile -> do gfoTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfoFile + Just gfoFile -> do gfoTime <- liftIO $ toUTCTime `fmap` getModificationTime gfoFile return (gfoFile, Nothing, Just gfoTime) - Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$ + Nothing -> raise (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$ text "searched in:" <+> vcat (map text ps))) @@ -114,21 +112,21 @@ getAllFiles opts ps env file = do (st,(mname,imps)) <- case st of CSEnv -> return (st, (name, maybe [] snd mb_envmod)) - CSRead -> do mb_mo <- ioeIO $ decodeModuleHeader ((if isGFO file then id else gf2gfo opts) file) + CSRead -> do mb_mo <- liftIO $ decodeModuleHeader ((if isGFO file then id else gf2gfo opts) file) case mb_mo of Just mo -> return (st,importsOfModule mo) Nothing - | isGFO file -> ioeErr $ Bad (file ++ " is compiled with different GF version and I can't find the source file") - | otherwise -> do s <- ioeIO $ BS.readFile file + | isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file") + | otherwise -> do s <- liftIO $ BS.readFile file case runP pModHeader s of - Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) + Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) Right mo -> return (CSComp,importsOfModule mo) - CSComp -> do s <- ioeIO $ BS.readFile file + CSComp -> do s <- liftIO $ BS.readFile file case runP pModHeader s of - Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) + Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) Right mo -> return (st,importsOfModule mo) - ioeErr $ testErr (mname == name) - ("module name" +++ mname +++ "differs from file name" +++ name) + testErr (mname == name) + ("module name" +++ mname +++ "differs from file name" +++ name) return (name,st,t,isJust gfTime,imps,dropFileName file) isGFO :: FilePath -> Bool @@ -212,16 +210,16 @@ importsOfModule (m,mi) = (modName m,depModInfo mi []) modName = showIdent -- | options can be passed to the compiler by comments in @--#@, in the main file -getOptionsFromFile :: FilePath -> IOE Options +getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options getOptionsFromFile file = do - s <- ioe $ catch (fmap Ok $ BS.readFile file) - (\_ -> return (Bad $ "File " ++ file ++ " does not exist")) + s <- handle (liftIO $ BS.readFile file) + (\_ -> raise $ "File " ++ file ++ " does not exist") let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls - ioeErr $ parseModuleOptions fs + liftErr $ parseModuleOptions fs -getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) -getFilePath paths file = get paths +getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath) +getFilePath paths file = liftIO $ get paths where get [] = return Nothing get (p:ps) = do diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 7effded1d..8821d99ca 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -45,7 +45,7 @@ import Text.PrettyPrint -- | this gives top-level access to renaming term input in the cc command renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term renameSourceTerm g m t = do - mi <- checkErr $ lookupModule g m + mi <- lookupModule g m status <- buildStatus g (m,mi) renameTerm status [] t @@ -72,12 +72,12 @@ renameIdentTerm' env@(act,imps) t0 = Cn c -> ident (\_ s -> checkError s) c Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 Q (m',c) -> do - m <- checkErr (lookupErr m' qualifs) + m <- lookupErr m' qualifs f <- lookupTree showIdent c m return $ f c QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 QC (m',c) -> do - m <- checkErr (lookupErr m' qualifs) + m <- lookupErr m' qualifs f <- lookupTree showIdent c m return $ f c _ -> return t0 @@ -127,7 +127,7 @@ buildStatus :: SourceGrammar -> SourceModule -> Check Status buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do let gr1 = prependModule gr mo exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m] - ops <- checkErr $ mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi) + ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi) let sts = map modInfo2status (exts++ops) return (if isModCnc mi then (emptyBinTree, reverse sts) -- the module itself does not define any names diff --git a/src/compiler/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs index 16391c61b..10be24f16 100644 --- a/src/compiler/GF/Compile/Tags.hs +++ b/src/compiler/GF/Compile/Tags.hs @@ -19,7 +19,7 @@ writeTags opts gr file mo = do let imports = getImports opts gr mo locals = getLocalTags [] mo txt = unlines ((Set.toList . Set.fromList) (imports++locals)) - putPointE Normal opts (" write file" +++ file) $ ioeIO $ writeFile file txt + putPointE Normal opts (" write file" +++ file) $ liftIO $ writeFile file txt getLocalTags x (m,mi) = [showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 67634d4f1..f13da4e01 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -23,7 +23,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t | isPredefConstant ty -> return ty ---- shouldn't be needed Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do - ty' <- checkErr (lookupResDef gr (m,ident)) + ty' <- lookupResDef gr (m,ident) if ty' == ty then return ty else comp g ty' --- is this necessary to test? Vr ident -> checkLookup ident g -- never needed to compute! @@ -50,7 +50,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t r' <- comp g r s' <- comp g s case (r',s') of - (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp g + (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g _ -> return $ ExtR r' s' RecType fs -> do @@ -59,7 +59,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t ELincat c t -> do t' <- comp g t - checkErr $ lockRecType c t' ---- locking to be removed AR 20/6/2009 + lockRecType c t' ---- locking to be removed AR 20/6/2009 _ | ty == typeTok -> return typeStr _ | isPredefConstant ty -> return ty @@ -76,9 +76,9 @@ inferLType gr g trm = case trm of Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) Q ident -> checks [ - termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g + termWith trm $ lookupResType gr ident >>= computeLType gr g , - checkErr (lookupResDef gr ident) >>= inferLType gr g + lookupResDef gr ident >>= inferLType gr g , checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm) ] @@ -88,9 +88,9 @@ inferLType gr g trm = case trm of Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) QC ident -> checks [ - termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g + termWith trm $ lookupResType gr ident >>= computeLType gr g , - checkErr (lookupResDef gr ident) >>= inferLType gr g + lookupResDef gr ident >>= inferLType gr g , checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) ] @@ -214,10 +214,10 @@ inferLType gr g trm = case trm of sT' <- computeLType gr g sT let trm' = ExtR r' s' - ---- trm' <- checkErr $ plusRecord r' s' + ---- trm' <- plusRecord r' s' case (rT', sT') of (RecType rs, RecType ss) -> do - rt <- checkErr $ plusRecType rT' sT' + rt <- plusRecType rT' sT' checkLType gr g trm' rt ---- return (trm', rt) _ | rT' == typeType && sT' == typeType -> return (trm', typeType) _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm) @@ -249,7 +249,7 @@ inferLType gr g trm = case trm of ELin c trm -> do (trm',ty) <- inferLType gr g trm - ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 + ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 return $ (ELin c trm', ty') _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm) @@ -289,7 +289,7 @@ inferLType gr g trm = case trm of _ -> False inferPatt p = case p of - PP (q,c) ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr (q,c)) + PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c)) PAs _ p -> inferPatt p PNeg p -> inferPatt p PAlt p q -> checks [inferPatt p, inferPatt q] @@ -423,7 +423,7 @@ checkLType gr g trm typ0 = do case allParamValues gr arg of Ok vs -> do let ps0 = map fst cs - ps <- checkErr $ testOvershadow ps0 vs + ps <- testOvershadow ps0 vs if null ps then return () else checkWarn (text "patterns never reached:" $$ @@ -511,7 +511,7 @@ checkLType gr g trm typ0 = do checkLType gr g (Let (x,(Just ty,def')) body) typ ELin c tr -> do - tr1 <- checkErr $ unlockRecord c tr + tr1 <- unlockRecord c tr checkLType gr g tr1 typ _ -> do @@ -547,7 +547,7 @@ pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context pattContext env g typ p = case p of PV x -> return [(Explicit,x,typ)] PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- checkErr $ lookupResType env (q,c) + t <- lookupResType env (q,c) let (cont,v) = typeFormCnc t checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) (length cont == length ps) diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 54adcac2c..094414648 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -55,7 +55,7 @@ extendModule gr (name,m) return (name,m') where extOne mo (n,cond) = do - m0 <- checkErr $ lookupModule gr n + m0 <- lookupModule gr n -- test that the module types match, and find out if the old is complete unless (sameMType (mtype m) (mtype mo)) @@ -93,7 +93,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) text "has open interfaces and must therefore be declared incomplete")) case mt of MTInstance (i0,mincl) -> do - m1 <- checkErr $ lookupModule gr i0 + m1 <- lookupModule gr i0 unless (isModRes m1) (checkError (text "interface expected instead of" <+> ppIdent i0)) js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi) @@ -101,7 +101,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) case extends mi of [] -> return mi{jments=js'} j0s -> do - m0s <- checkErr $ mapM (lookupModule gr) j0s + m0s <- mapM (lookupModule gr) j0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s let js2 = filterBinTree notInM0 js' return mi{jments=js2} @@ -114,7 +114,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) [i | i <- is, notElem i infs] unless (stat' == MSComplete || stat == MSIncomplete) (checkError (text "module" <+> ppIdent i <+> text "remains incomplete")) - ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- checkErr $ lookupModule gr ext + ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already [OQualif i j | (i,j) <- ops] ++ @@ -145,10 +145,10 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme Just j -> case unifyAnyInfo name i j of Ok k -> return $ updateTree (c,k) new Bad _ -> do (base,j) <- case j of - AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c) + AnyInd _ m -> lookupOrigInfo gr (m,c) _ -> return (base,j) (name,i) <- case i of - AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c) + AnyInd _ m -> lookupOrigInfo gr (m,c) _ -> return (name,i) checkError (text "cannot unify the information" $$ nest 4 (ppJudgement Qualified (c,i)) $$ diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 06e54775e..9c1dbbc5a 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -21,7 +21,7 @@ module GF.Data.Operations (-- * misc functions Err(..), err, maybeErr, testErr, errVal, errIn, lookupErr, mapPairListM, mapPairsM, pairM, - singleton, mapsErr, mapsErrTree, + singleton, --mapsErr, mapsErrTree, -- ** checking checkUnique, @@ -55,7 +55,8 @@ module GF.Data.Operations (-- * misc functions STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done, -- * error monad class - ErrorMonad(..), checkAgain, checks, allChecks, doUntil + ErrorMonad(..), checkAgain, checks, allChecks, doUntil, + liftErr ) where @@ -85,19 +86,19 @@ err d f e = case e of Bad s -> d s -- | add msg s to @Maybe@ failures -maybeErr :: String -> Maybe a -> Err a -maybeErr s = maybe (Bad s) Ok +maybeErr :: ErrorMonad m => String -> Maybe a -> m a +maybeErr s = maybe (raise s) return -testErr :: Bool -> String -> Err () -testErr cond msg = if cond then return () else Bad msg +testErr :: ErrorMonad m => Bool -> String -> m () +testErr cond msg = if cond then return () else raise msg errVal :: a -> Err a -> a errVal a = err (const a) id -errIn :: String -> Err a -> Err a -errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return +errIn :: ErrorMonad m => String -> m a -> m a +errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg)) -lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b +lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] @@ -313,6 +314,8 @@ stm = STM stmr :: (s -> (a,s)) -> STM s a stmr f = stm (\s -> return (f s)) +instance Functor (STM s) where fmap = liftM + instance Monad (STM s) where return a = STM (\s -> return (a,s)) STM c >>= f = STM (\s -> do @@ -332,7 +335,7 @@ writeSTM s = stmr (const ((),s)) done :: Monad m => m () done = return () -class Monad m => ErrorMonad m where +class (Functor m,Monad m) => ErrorMonad m where raise :: String -> m a handle :: m a -> (String -> m a) -> m a handle_ :: m a -> m a -> m a @@ -343,12 +346,14 @@ instance ErrorMonad Err where handle a@(Ok _) _ = a handle (Bad i) f = f i +liftErr e = err raise return e + instance ErrorMonad (STM s) where raise msg = STM (\s -> raise msg) handle (STM f) g = STM (\s -> (f s) `handle` (\e -> let STM g' = (g e) in g' s)) - +{- -- error recovery with multiple reporting AR 30/5/2008 mapsErr :: (a -> Err b) -> [a] -> Err [b] @@ -364,7 +369,7 @@ mapsErr f = seqs . map f where mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c) mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree - +-} -- | if the first check fails try another one checkAgain :: ErrorMonad m => m a -> m a -> m a diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs index fe76d7af8..a48238e42 100644 --- a/src/compiler/GF/Grammar/CF.hs +++ b/src/compiler/GF/Grammar/CF.hs @@ -28,14 +28,14 @@ import Data.Char import Data.List --import System.FilePath -getCF :: FilePath -> String -> Err SourceGrammar +getCF :: ErrorMonad m => FilePath -> String -> m SourceGrammar getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF --------------------- -- the parser ------- --------------------- -pCF :: String -> Err CF +pCF :: ErrorMonad m => String -> m CF pCF s = do rules <- mapM getCFRule $ filter isRule $ lines s return $ concat rules @@ -48,14 +48,14 @@ pCF s = do -- fun. C -> item1 item2 ... where unquoted items are treated as cats -- Actually would be nice to add profiles to this. -getCFRule :: String -> Err [CFRule] +getCFRule :: ErrorMonad m => String -> m [CFRule] getCFRule s = getcf (wrds s) where getcf ws = case ws of fun : cat : a : its | isArrow a -> - Ok [L NoLoc (init fun, (cat, map mkIt its))] + return [L NoLoc (init fun, (cat, map mkIt its))] cat : a : its | isArrow a -> - Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its] - _ -> Bad (" invalid rule:" +++ s) + return [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its] + _ -> raise (" invalid rule:" +++ s) isArrow a = elem a ["->", "::="] mkIt w = case w of ('"':w@(_:_)) -> Right (init w) diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 8db78a0f0..7400ff09b 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -195,17 +195,17 @@ mGrammar ms = MGrammar (Map.fromList ms) ms -- | we store the module type with the identifier -abstractOfConcrete :: SourceGrammar -> Ident -> Err Ident +abstractOfConcrete :: ErrorMonad m => SourceGrammar -> Ident -> m Ident abstractOfConcrete gr c = do n <- lookupModule gr c case mtype n of MTConcrete a -> return a - _ -> Bad $ render (text "expected concrete" <+> ppIdent c) + _ -> raise $ render (text "expected concrete" <+> ppIdent c) -lookupModule :: SourceGrammar -> Ident -> Err SourceModInfo +lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo lookupModule gr m = case Map.lookup m (moduleMap gr) of Just i -> return i - Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr))) + Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr))) isModAbs :: SourceModInfo -> Bool isModAbs m = diff --git a/src/compiler/GF/Grammar/Lockfield.hs b/src/compiler/GF/Grammar/Lockfield.hs index 5c2f5d0f0..53e58a3ad 100644 --- a/src/compiler/GF/Grammar/Lockfield.hs +++ b/src/compiler/GF/Grammar/Lockfield.hs @@ -20,9 +20,9 @@ import GF.Infra.Ident import GF.Grammar.Grammar import GF.Grammar.Macros -import GF.Data.Operations +import GF.Data.Operations(ErrorMonad,Err(..)) -lockRecType :: Ident -> Type -> Err Type +lockRecType :: ErrorMonad m => Ident -> Type -> m Type lockRecType c t@(RecType rs) = let lab = lockLabel c in return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"] diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 4076346a8..6bdf87a5c 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -50,19 +50,19 @@ lock c = lockRecType c -- return unlock c = unlockRecord c -- return -- to look up a constant etc in a search tree --- why here? AR 29/5/2008 -lookupIdent :: Ident -> BinTree Ident b -> Err b +lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b lookupIdent c t = case lookupTree showIdent c t of Ok v -> return v - Bad _ -> Bad ("unknown identifier" +++ showIdent c) + Bad _ -> raise ("unknown identifier" +++ showIdent c) -lookupIdentInfo :: SourceModInfo -> Ident -> Err Info +lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info lookupIdentInfo mo i = lookupIdent i (jments mo) -lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info +lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m -lookupResDef :: SourceGrammar -> QIdent -> Err Term +lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x) lookupResDefLoc gr (m,c) @@ -83,9 +83,9 @@ lookupResDefLoc gr (m,c) AnyInd _ n -> look n c ResParam _ _ -> return (noLoc (QC (m,c))) ResValue _ -> return (noLoc (QC (m,c))) - _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) + _ -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) -lookupResType :: SourceGrammar -> QIdent -> Err Type +lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type lookupResType gr (m,c) = do info <- lookupQIdentInfo gr (m,c) case info of @@ -99,9 +99,9 @@ lookupResType gr (m,c) = do AnyInd _ n -> lookupResType gr (n,c) ResParam _ _ -> return typePType ResValue (L _ t) -> return t - _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) + _ -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) -lookupOverload :: SourceGrammar -> QIdent -> Err [([Type],(Type,Term))] +lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))] lookupOverload gr (m,c) = do info <- lookupQIdentInfo gr (m,c) case info of @@ -112,10 +112,10 @@ lookupOverload gr (m,c) = do concat tss AnyInd _ n -> lookupOverload gr (n,c) - _ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation") + _ -> raise $ render (ppIdent c <+> text "is not an overloaded operation") -- | returns the original 'Info' and the module where it was found -lookupOrigInfo :: SourceGrammar -> QIdent -> Err (Ident,Info) +lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info) lookupOrigInfo gr (m,c) = do info <- lookupQIdentInfo gr (m,c) case info of @@ -127,14 +127,14 @@ allOrigInfos gr m = errVal [] $ do mo <- lookupModule gr m return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]] -lookupParamValues :: SourceGrammar -> QIdent -> Err [Term] +lookupParamValues :: ErrorMonad m => SourceGrammar -> QIdent -> m [Term] lookupParamValues gr c = do (_,info) <- lookupOrigInfo gr c case info of ResParam _ (Just pvs) -> return pvs - _ -> Bad $ render (ppQIdent Qualified c <+> text "has no parameter values defined") + _ -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined") -allParamValues :: SourceGrammar -> Type -> Err [Term] +allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term] allParamValues cnc ptyp = case ptyp of _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] @@ -148,12 +148,12 @@ allParamValues cnc ptyp = pvs <- allParamValues cnc pt vvs <- allParamValues cnc vt return [V pt ts | ts <- combinations (replicate (length pvs) vvs)] - _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) + _ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) where -- to normalize records and record types sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) -lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) +lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation]) lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do info <- lookupQIdentInfo gr (m,c) case info of @@ -161,32 +161,32 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) AnyInd _ n -> lookupAbsDef gr n c _ -> return (Nothing,Nothing) -lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type +lookupLincat :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? lookupLincat gr m c = do info <- lookupQIdentInfo gr (m,c) case info of CncCat (Just (L _ t)) _ _ _ _ -> return t AnyInd _ n -> lookupLincat gr n c - _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) + _ -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) -- | this is needed at compile time -lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type +lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type lookupFunType gr m c = do info <- lookupQIdentInfo gr (m,c) case info of AbsFun (Just (L _ t)) _ _ _ -> return t AnyInd _ n -> lookupFunType gr n c - _ -> Bad (render (text "cannot find type of" <+> ppIdent c)) + _ -> raise (render (text "cannot find type of" <+> ppIdent c)) -- | this is needed at compile time -lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context +lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context lookupCatContext gr m c = do info <- lookupQIdentInfo gr (m,c) case info of AbsCat (Just (L _ co)) -> return co AnyInd _ n -> lookupCatContext gr n c - _ -> Bad (render (text "unknown category" <+> ppIdent c)) + _ -> raise (render (text "unknown category" <+> ppIdent c)) -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index db17b4451..6798b22d0 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -262,22 +262,22 @@ mkWildCases = mkCases identW mkFunType :: [Type] -> Type -> Type mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod -plusRecType :: Type -> Type -> Err Type +--plusRecType :: Type -> Type -> Err Type plusRecType t1 t2 = case (t1, t2) of (RecType r1, RecType r2) -> case filter (`elem` (map fst r1)) (map fst r2) of [] -> return (RecType (r1 ++ r2)) - ls -> fail $ render (text "clashing labels" <+> hsep (map ppLabel ls)) - _ -> fail $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) + ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls)) + _ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) -plusRecord :: Term -> Term -> Err Term +--plusRecord :: Term -> Term -> Err Term plusRecord t1 t2 = case (t1,t2) of (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV - _ -> fail $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) + _ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) -- | default linearization type defLinType :: Type @@ -444,7 +444,7 @@ strsFromTerm t = case t of ] FV ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat - _ -> fail (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) + _ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg stringFromTerm :: Term -> String @@ -599,20 +599,20 @@ allDependencies ism b = AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co] _ -> [] -topoSortJments :: SourceModule -> Err [(Ident,Info)] +topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)] topoSortJments (m,mi) = do is <- either return - (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) + (\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) (topoTest (allDependencies (==m) (jments mi))) return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) -topoSortJments2 :: SourceModule -> Err [[(Ident,Info)]] +topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]] topoSortJments2 (m,mi) = do iss <- either return - (\cyc -> fail (render (text "circular definitions:" - <+> fsep (map ppIdent (head cyc))))) + (\cyc -> raise (render (text "circular definitions:" + <+> fsep (map ppIdent (head cyc))))) (topoTest2 (allDependencies (==m) (jments mi))) return [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss] diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs index 071deb709..81541b2a3 100644 --- a/src/compiler/GF/Grammar/PatternMatch.hs +++ b/src/compiler/GF/Grammar/PatternMatch.hs @@ -29,10 +29,10 @@ import Control.Monad import Text.PrettyPrint --import Debug.Trace -matchPattern :: [(Patt,rhs)] -> Term -> Err (rhs, Substitution) +matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution) matchPattern pts term = if not (isInConstantForm term) - then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) + then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) else do term' <- mkK term errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $ @@ -49,20 +49,20 @@ matchPattern pts term = K w -> return [w] C v w -> liftM2 (++) (getS v) (getS w) Empty -> return [] - _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) + _ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) -testOvershadow :: [Patt] -> [Term] -> Err [Patt] +testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt] testOvershadow pts vs = do let numpts = zip pts [0..] let cases = [(p,EInt i) | (p,i) <- numpts] ts <- mapM (liftM fst . matchPattern cases) vs return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] -findMatch :: [([Patt],rhs)] -> [Term] -> Err (rhs, Substitution) +findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution) findMatch cases terms = case cases of - [] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) + [] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) (patts,_):_ | length patts /= length terms -> - Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> + raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) (patts,val):cc -> case mapM tryMatch (zip patts terms) of Ok substs -> return (val, concat substs) @@ -116,7 +116,7 @@ tryMatch (p,t) = do (PNeg p',_) -> case tryMatch (p',t) of Bad _ -> return [] - _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p)) + _ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p)) (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s @@ -130,7 +130,7 @@ tryMatch (p,t) = do (PChar, ([],K [_], [])) -> return [] (PChars cs, ([],K [c], [])) | elem c cs -> return [] - _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) + _ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s --matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index 2f8a842e5..f1d4ebbde 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -15,7 +15,7 @@ module GF.Infra.CheckM (Check, CheckResult, Message, runCheck, checkError, checkCond, checkWarn, checkWarnings, checkAccumError, - checkErr, checkIn, checkMap, checkMapRecover, + {-checkErr,-} checkIn, checkMap, checkMapRecover, parallelCheck, accumulateError, commitCheck, ) where @@ -92,14 +92,14 @@ commitCheck c = list = vcat . reverse -- | Run an error check, report errors and warnings -runCheck :: Check a -> Err (a,String) +runCheck :: ErrorMonad m => Check a -> m (a,String) runCheck c = case unCheck c {-[]-} ([],[]) of - (([],ws),Success v) -> Ok (v,render (list ws)) + (([],ws),Success v) -> return (v,render (list ws)) (msgs ,Success v) -> bad msgs ((es,ws),Fail e) -> bad ((e:es),ws) where - bad (es,ws) = Bad (render $ list ws $$ list es) + bad (es,ws) = raise (render $ list ws $$ list es) list = vcat . reverse parallelCheck :: [Check a] -> Check [a] @@ -135,10 +135,6 @@ checkMapRecover f mp = do return (Map.fromAscList kx) -} -checkErr :: Err a -> Check a -checkErr (Ok x) = return x -checkErr (Bad err) = checkError (text err) - checkIn :: Doc -> Check a -> Check a checkIn msg c = Check $ \{-ctxt-} msgs0 -> case unCheck c {-ctxt-} ([],[]) of diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index d16440372..85f26eb33 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -13,7 +13,7 @@ -- (Description of the module) ----------------------------------------------------------------------------- -module GF.Infra.UseIO where +module GF.Infra.UseIO(module GF.Infra.UseIO,MonadIO(..),liftErr) where import Prelude hiding (catch) @@ -35,8 +35,8 @@ import Control.Monad import Control.Monad.Trans(MonadIO(..)) import Control.Exception(evaluate) -putShow' :: Show a => (c -> a) -> c -> IO () -putShow' f = putStrLn . show . length . show . f +--putShow' :: Show a => (c -> a) -> c -> IO () +--putShow' f = putStrLn . show . length . show . f putIfVerb :: Options -> String -> IO () putIfVerb opts msg = @@ -118,12 +118,6 @@ splitInModuleSearchPath s = case break isPathSep s of -- -putStrFlush :: String -> IO () -putStrFlush s = putStr s >> hFlush stdout - -putStrLnFlush :: String -> IO () -putStrLnFlush s = putStrLn s >> hFlush stdout - -- * IO monad with error; adapted from state monad newtype IOE a = IOE { appIOE :: IO (Err a) } @@ -131,14 +125,11 @@ newtype IOE a = IOE { appIOE :: IO (Err a) } ioe :: IO (Err a) -> IOE a ioe = IOE -ioeIO :: IO a -> IOE a -ioeIO io = ioe (io >>= return . return) +instance MonadIO IOE where liftIO io = ioe (io >>= return . return) -ioeErr :: Err a -> IOE a -ioeErr = ioe . return - -ioeErrIn :: String -> IOE a -> IOE a -ioeErrIn msg (IOE ioe) = IOE (fmap (errIn msg) ioe) +instance ErrorMonad IOE where + raise = ioe . return . Bad + handle m h = ioe $ err (appIOE . h) (return . Ok) =<< appIOE m instance Functor IOE where fmap = liftM @@ -146,22 +137,17 @@ instance Monad IOE where return a = ioe (return (return a)) IOE c >>= f = IOE $ do x <- c -- Err a - appIOE $ err ioeBad f x -- f :: a -> IOE a - fail = ioeBad - -instance MonadIO IOE where liftIO = ioeIO - -ioeBad :: String -> IOE a -ioeBad = ioe . return . Bad + appIOE $ err raise f x -- f :: a -> IOE a + fail = raise useIOE :: a -> IOE a -> IO a useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return -foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) +--foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) foldIOE f s xs = case xs of [] -> return (s,Nothing) x:xx -> do - ev <- ioeIO $ appIOE (f s x) + ev <- liftIO $ appIOE (f s x) case ev of Ok v -> foldIOE f v xx Bad m -> return $ (s, Just m) @@ -170,19 +156,19 @@ die :: String -> IO a die s = do hPutStrLn stderr s exitFailure -putStrLnE :: String -> IOE () -putStrLnE = ioeIO . putStrLnFlush +ePutStr, ePutStrLn, putStrE, putStrLnE :: MonadIO m => String -> m () +ePutStr s = liftIO $ hPutStr stderr s +ePutStrLn s = liftIO $ hPutStrLn stderr s +putStrLnE s = liftIO $ putStrLn s >> hFlush stdout +putStrE s = liftIO $ putStr s >> hFlush stdout -putStrE :: String -> IOE () -putStrE = ioeIO . putStrFlush - -putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a +putPointE :: MonadIO m => Verbosity -> Options -> String -> m a -> m a putPointE v opts msg act = do - when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg + when (verbAtLeast opts v) $ putStrE msg - t1 <- ioeIO $ getCPUTime - a <- act >>= ioeIO . evaluate - t2 <- ioeIO $ getCPUTime + t1 <- liftIO $ getCPUTime + a <- act >>= liftIO . evaluate + t2 <- liftIO $ getCPUTime if flag optShowCPUTime opts then do let msec = (t2 - t1) `div` 1000000000 diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index f75a39ab1..dd9f1771b 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -55,9 +55,9 @@ compileSourceFiles opts fs = compileCFFiles :: Options -> [FilePath] -> IOE () compileCFFiles opts fs = - do s <- ioeIO $ fmap unlines $ mapM readFile fs + do s <- liftIO $ fmap unlines $ mapM readFile fs let cnc = justModuleName (last fs) - gf <- ioeErr $ getCF cnc s + gf <- getCF cnc s gr <- compileSourceGrammar opts gf if flag optStopAfterPhase opts == Compile then return () @@ -76,7 +76,7 @@ unionPGFFiles opts fs = then putStrLnE $ "Refusing to overwrite " ++ pgfFile else writePGF opts pgf writeOutputs opts pgf - where readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ ioeIO $ readPGF f + where readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f writeOutputs :: Options -> PGF -> IOE () writeOutputs opts pgf = do @@ -93,7 +93,7 @@ writeByteCode opts pgf path = case flag optOutputDir opts of Nothing -> file Just dir -> dir file - in putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $ + in putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO $ bracket (openFile path WriteMode) (hClose) @@ -109,14 +109,14 @@ writeByteCode opts pgf writePGF :: Options -> PGF -> IOE () writePGF opts pgf = do let outfile = grammarName opts pgf <.> "pgf" - putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ encodeFile outfile pgf + putPointE Normal opts ("Writing " ++ outfile ++ "...") $ liftIO $ encodeFile outfile pgf grammarName :: Options -> PGF -> String grammarName opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts) writeOutput :: Options -> FilePath-> String -> IOE () writeOutput opts file str = - putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $ + putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO $ writeUTF8File path str where path = maybe id () (flag optOutputDir opts) file diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index 1a786a3d2..094b0c787 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -8,8 +8,7 @@ import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandE import GF.Command.Commands(flags,options) import GF.Command.Abstract import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.ErrM -import GF.Data.Operations (chunks,err) +import GF.Data.Operations (Err(..),chunks,err,raise) import GF.Grammar hiding (Ident,isPrefixOf) import GF.Grammar.Analyse import GF.Grammar.Parser (runP, pExp) @@ -326,7 +325,7 @@ printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e) checkComputeTerm = checkComputeTerm' False checkComputeTerm' new sgr t = do - mo <- maybe (Bad "no source grammar in scope") return $ greatestResource sgr + mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t inferLType sgr [] t t1 <- if new diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index 5b247806a..c28a99c5e 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -7,7 +7,7 @@ import Control.Monad(when) import Control.Monad.State(StateT(..),get,gets,put) import Control.Monad.Error(ErrorT(..),Error(..)) import System.Random(randomRIO) -import System.IO(stderr,hPutStrLn) +--import System.IO(stderr,hPutStrLn) import GF.System.Catch(try) import System.IO.Error(isAlreadyExistsError) import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory, @@ -33,7 +33,7 @@ import Text.JSON(encode,showJSON,makeObj) import System.Process(readProcessWithExitCode) import System.Exit(ExitCode(..)) import Codec.Binary.UTF8.String(decodeString,encodeString) -import GF.Infra.UseIO(readBinaryFile,writeBinaryFile) +import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn) import GF.Infra.SIO(captureSIO) import qualified PGFService as PS import qualified ExampleService as ES @@ -334,7 +334,7 @@ serveStaticFile' path = return (resp404 path) -- * Logging -logPutStrLn s = liftIO . hPutStrLn stderr $ s +logPutStrLn s = ePutStrLn s -- * JSONP output