From d258b727191083c84724e374d4201cca490e4e4c Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 5 Oct 2009 14:58:13 +0000 Subject: [PATCH] another attempt to get the paths handling right --- src/GF.hs | 4 +++- src/GF/Compile/ReadFiles.hs | 2 +- src/GF/Grammar/Binary.hs | 2 +- src/GF/Grammar/Parser.y | 2 +- src/GF/Infra/Option.hs | 32 +++++++++++++++++++++----------- src/GF/Infra/UseIO.hs | 16 ++++++++-------- src/GFI.hs | 4 +++- 7 files changed, 38 insertions(+), 24 deletions(-) diff --git a/src/GF.hs b/src/GF.hs index de288df10..451cff9f9 100644 --- a/src/GF.hs +++ b/src/GF.hs @@ -9,6 +9,7 @@ import GF.Infra.UseIO import Paths_gf import Data.Version +import System.Directory import System.Environment (getArgs) import System.Exit import System.IO @@ -25,7 +26,8 @@ main = do setConsoleOutputCP codepage #endif args <- getArgs - case parseOptions args of + cdir <- getCurrentDirectory + case parseOptions cdir args of Ok (opts,files) -> mainOpts opts files Bad err -> do hPutStrLn stderr err hPutStrLn stderr "You may want to try --help." diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs index b96d3127b..da06f2789 100644 --- a/src/GF/Compile/ReadFiles.hs +++ b/src/GF/Compile/ReadFiles.hs @@ -205,7 +205,7 @@ getOptionsFromFile file = do (\_ -> return (Bad $ "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 + ioeErr $ parseModuleOptions (dropFileName file) fs getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) getFilePath paths file = get paths diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs index e22e1dc87..142ca4063 100644 --- a/src/GF/Grammar/Binary.hs +++ b/src/GF/Grammar/Binary.hs @@ -82,7 +82,7 @@ instance Binary ModuleStatus where instance Binary Options where put = put . optionsGFO get = do opts <- get - case parseModuleOptions ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of + case parseModuleOptions "." ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of Ok x -> return x Bad msg -> fail msg diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y index 1c6b51e77..bb30e5075 100644 --- a/src/GF/Grammar/Parser.y +++ b/src/GF/Grammar/Parser.y @@ -276,7 +276,7 @@ TermDef FlagDef :: { Options } FlagDef - : Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of + : Posn Ident '=' Ident Posn {% case parseModuleOptions "." ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of Ok x -> return x Bad msg -> failLoc $1 msg } diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index fc5ddf87c..8c3d4d267 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -186,18 +186,28 @@ instance Show Options where -- Option parsing -parseOptions :: [String] -> Err (Options, [FilePath]) -parseOptions args - | not (null errs) = errors errs - | otherwise = do opts <- liftM concatOptions $ sequence optss - return (opts, files) - where (optss, files, errs) = getOpt RequireOrder optDescr args +parseOptions :: FilePath -- ^ if there are relative file paths they will be interpreted as relative to this path + -> [String] -- ^ list of string arguments + -> Err (Options, [FilePath]) +parseOptions root args + | not (null errs) = errors errs + | otherwise = do opts <- liftM concatOptions $ sequence optss + return (fixRelativeLibPaths opts, files) + where + (optss, files, errs) = getOpt RequireOrder optDescr args + + fixRelativeLibPaths (Options o) = Options (fixPathFlags . o) + where + fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=map (root ) path} -parseModuleOptions :: [String] -> Err Options -parseModuleOptions args = do (opts,nonopts) <- parseOptions args - if null nonopts - then return opts - else errors $ map ("Non-option among module options: " ++) nonopts +parseModuleOptions :: FilePath -- ^ if there are relative file paths they will be interpreted as relative to this path + -> [String] -- ^ list of string arguments + -> Err Options +parseModuleOptions root args = do + (opts,nonopts) <- parseOptions root args + if null nonopts + then return opts + else errors $ map ("Non-option among module options: " ++) nonopts -- Showing options diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs index f8389c672..687e5c212 100644 --- a/src/GF/Infra/UseIO.hs +++ b/src/GF/Infra/UseIO.hs @@ -65,20 +65,20 @@ getLibraryPath opts = (getEnv gfLibraryPath) (\ex -> getDataDir >>= \path -> return (path "lib")) -getGrammarPath :: Options -> IO [FilePath] -getGrammarPath opts = do - let ss1 = flag optLibraryPath opts - ss2 <- catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return ["prelude","."]) -- e.g. GF_GRAMMAR_PATH - return (ss1 ++ ss2) +getGrammarPath :: FilePath -> IO [FilePath] +getGrammarPath lib_path = do + catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_path "prelude"]) -- e.g. GF_GRAMMAR_PATH -- | extends the search path with the -- 'gfLibraryPath' and 'gfGrammarPathVar' -- environment variables. Returns only existing paths. extendPathEnv :: Options -> FilePath -> IO [FilePath] extendPathEnv opts fdir = do - b <- getLibraryPath opts -- e.g. GF_LIB_PATH - ss <- getGrammarPath opts -- e.g. GF_GRAMMAR_PATH - ps <- liftM (nub . concat) $ mapM allSubdirs $ [fdir s | s <- ss] ++ [b s | s <- ss] + opt_paths <- return $ flag optLibraryPath opts -- e.g. paths given as options + lib_path <- getLibraryPath opts -- e.g. GF_LIB_PATH + grm_paths <- getGrammarPath lib_path -- e.g. GF_GRAMMAR_PATH + let paths = opt_paths ++ [lib_path] ++ grm_paths + ps <- liftM (nub . concat) $ mapM allSubdirs paths mapM canonicalizePath ps where allSubdirs :: FilePath -> IO [FilePath] diff --git a/src/GFI.hs b/src/GFI.hs index 86f9614ed..edf4ada5f 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -34,6 +34,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Text.ParserCombinators.ReadP as RP import System.Cmd import System.CPUTime +import System.Directory import Control.Exception import Control.Monad import Data.Version @@ -129,7 +130,8 @@ loop opts gfenv0 = do putStrLn "wrote graph in file _gfdepgraph.dot" loopNewCPU gfenv "i":args -> do - gfenv' <- case parseOptions args of + cdir <- getCurrentDirectory + gfenv' <- case parseOptions cdir args of Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files Bad err -> do