From c8d2ed96fd2df20491ee24fc6d8b97da4c36319e Mon Sep 17 00:00:00 2001 From: hallgren Date: Thu, 21 Nov 2013 15:01:04 +0000 Subject: [PATCH] Some more monadic lifting changes --- src/compiler/GF/Compile.hs | 10 +++++----- src/compiler/GF/Compile/ReadFiles.hs | 6 +++--- src/compiler/GF/Infra/Option.hs | 18 ++++++++++-------- src/compiler/GF/Infra/UseIO.hs | 25 ++++++++++++------------- 4 files changed, 30 insertions(+), 29 deletions(-) diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index e22ded71e..92c2ac415 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -98,17 +98,17 @@ compileModule :: Options -- ^ Options from program command line and shell comman compileModule opts1 env file = do file <- getRealFile file opts0 <- getOptionsFromFile file - curr_dir <- return $ dropFileName file + let curr_dir = dropFileName file lib_dir <- liftIO $ getLibraryDirectory (addOptions opts0 opts1) let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1 - ps0 <- liftIO $ extendPathEnv opts + ps0 <- extendPathEnv opts let ps = nub (curr_dir : ps0) - liftIO $ putIfVerb opts $ "module search path:" +++ show ps ---- + putIfVerb opts $ "module search path:" +++ show ps ---- let (_,sgr,rfs) = env files <- getAllFiles opts ps rfs file - liftIO $ putIfVerb opts $ "files to read:" +++ show files ---- + putIfVerb opts $ "files to read:" +++ show files ---- let names = map justModuleName files - liftIO $ putIfVerb opts $ "modules to include:" +++ show names ---- + putIfVerb opts $ "modules to include:" +++ show names ---- foldM (compileOne opts) (0,sgr,rfs) files where getRealFile file = do diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs index 54abc7f48..5e65dcba6 100644 --- a/src/compiler/GF/Compile/ReadFiles.hs +++ b/src/compiler/GF/Compile/ReadFiles.hs @@ -212,11 +212,11 @@ importsOfModule (m,mi) = (modName m,depModInfo mi []) -- | options can be passed to the compiler by comments in @--#@, in the main file getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options getOptionsFromFile file = do - s <- handle (liftIO $ BS.readFile file) - (\_ -> raise $ "File " ++ file ++ " does not exist") + s <- either (\_ -> raise $ "File " ++ file ++ " does not exist") return =<< + liftIO (try $ BS.readFile file) let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls - liftErr $ parseModuleOptions fs + parseModuleOptions fs getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath) getFilePath paths file = liftIO $ get paths diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 1236e729c..115665419 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -38,7 +38,7 @@ import GF.Grammar.Predef import System.FilePath --import System.IO -import GF.Data.ErrM +import GF.Data.Operations(Err,ErrorMonad(..),liftErr) import Data.Set (Set) import qualified Data.Set as Set @@ -68,8 +68,8 @@ helpMessage = usageInfo usageHeader optDescr -- FIXME: do we really want multi-line errors? -errors :: [String] -> Err a -errors = fail . unlines +errors :: ErrorMonad err => [String] -> err a +errors = raise . unlines -- Types @@ -185,17 +185,19 @@ instance Show Options where -- Option parsing -parseOptions :: [String] -- ^ list of string arguments - -> Err (Options, [FilePath]) +parseOptions :: ErrorMonad err => + [String] -- ^ list of string arguments + -> err (Options, [FilePath]) parseOptions args | not (null errs) = errors errs - | otherwise = do opts <- liftM concatOptions $ sequence optss + | otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss) return (opts, files) where (optss, files, errs) = getOpt RequireOrder optDescr args -parseModuleOptions :: [String] -- ^ list of string arguments - -> Err Options +parseModuleOptions :: ErrorMonad err => + [String] -- ^ list of string arguments + -> err Options parseModuleOptions args = do (opts,nonopts) <- parseOptions args if null nonopts diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index 85f26eb33..0af26efa7 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -38,21 +38,21 @@ import Control.Exception(evaluate) --putShow' :: Show a => (c -> a) -> c -> IO () --putShow' f = putStrLn . show . length . show . f -putIfVerb :: Options -> String -> IO () +putIfVerb :: MonadIO io => Options -> String -> io () putIfVerb opts msg = - when (verbAtLeast opts Verbose) $ putStrLn msg + when (verbAtLeast opts Verbose) $ liftIO $ putStrLn msg -putIfVerbW :: Options -> String -> IO () +putIfVerbW :: MonadIO io => Options -> String -> io () putIfVerbW opts msg = - when (verbAtLeast opts Verbose) $ putStr (' ' : msg) - + when (verbAtLeast opts Verbose) $ liftIO $ putStr (' ' : msg) +{- errOptIO :: Options -> a -> Err a -> IO a errOptIO os e m = case m of Ok x -> return x Bad k -> do putIfVerb os k return e - +-} type FileName = String type InitPath = String type FullPath = String @@ -60,13 +60,12 @@ type FullPath = String gfLibraryPath = "GF_LIB_PATH" gfGrammarPathVar = "GF_GRAMMAR_PATH" -getLibraryDirectory :: Options -> IO FilePath +getLibraryDirectory :: MonadIO io => Options -> io FilePath getLibraryDirectory opts = case flag optGFLibPath opts of Just path -> return path - Nothing -> catch - (getEnv gfLibraryPath) - (\ex -> getDataDir >>= \path -> return (path "lib")) + Nothing -> liftIO $ catch (getEnv gfLibraryPath) + (\ex -> fmap ( "lib") getDataDir) getGrammarPath :: FilePath -> IO [FilePath] getGrammarPath lib_dir = do @@ -76,9 +75,9 @@ getGrammarPath lib_dir = do -- | extends the search path with the -- 'gfLibraryPath' and 'gfGrammarPathVar' -- environment variables. Returns only existing paths. -extendPathEnv :: Options -> IO [FilePath] -extendPathEnv opts = do - opt_path <- return $ flag optLibraryPath opts -- e.g. paths given as options +extendPathEnv :: MonadIO io => Options -> io [FilePath] +extendPathEnv opts = liftIO $ do + let opt_path = flag optLibraryPath opts -- e.g. paths given as options lib_dir <- getLibraryDirectory opts -- e.g. GF_LIB_PATH grm_path <- getGrammarPath lib_dir -- e.g. GF_GRAMMAR_PATH let paths = opt_path ++ [lib_dir] ++ grm_path