msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

hopefully the last revision of the relative paths handling algorithm

Browse Source
This commit is contained in:
krasimir
2009-10-06 10:27:34 +00:00
parent 332dbf7b9b
commit cbcdae9148
8 changed files with 43 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
src/GF.hs
View File

@@ -26,9 +26,10 @@ main = do
setConsoleOutputCP codepage
#endif
args <- getArgs
cdir <- getCurrentDirectory
case parseOptions cdir args of
Ok (opts,files) -> mainOpts opts files
case parseOptions args of
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."
exitFailure

16
src/GF/Compile.hs
View File

@@ -114,9 +114,11 @@ compileModule :: Options -- ^ Options from program command line and shell comman
compileModule opts1 env file = do
file <- getRealFile file
opts0 <- getOptionsFromFile file
let opts = addOptions opts0 opts1
let fdir = dropFileName file
ps <- ioeIO $ extendPathEnv opts fdir
curr_dir <- return $ dropFileName file
lib_dir <- ioeIO $ getLibraryDirectory (addOptions opts0 opts1)
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
ps0 <- ioeIO $ extendPathEnv opts
let ps = nub (curr_dir : ps0)
ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ----
let (_,sgr,rfs) = env
files <- getAllFiles opts ps rfs file
@@ -125,13 +127,13 @@ compileModule opts1 env file = do
ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ----
foldM (compileOne opts) (0,sgr,rfs) files
where
getRealFile file1 = do
exists <- ioeIO $ doesFileExist file1
getRealFile file = do
exists <- ioeIO $ doesFileExist file
if exists
then return file
else if isRelative file
then do libpath <- ioeIO $ getLibraryPath opts1
let file1 = libpath </> file
then do lib_dir <- ioeIO $ getLibraryDirectory opts1
let file1 = lib_dir </> file
exists <- ioeIO $ doesFileExist file1
if exists
then return file1

2
src/GF/Compile/ReadFiles.hs
View File

@@ -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 (dropFileName file) fs
ioeErr $ parseModuleOptions fs
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
getFilePath paths file = get paths

2
src/GF/Grammar/Binary.hs
View File

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

2
src/GF/Grammar/Parser.y
View File

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

24
src/GF/Infra/Option.hs
View File

@@ -7,7 +7,7 @@ module GF.Infra.Option
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Printer(..), Recomp(..), BuildParser(..),
-- * Option parsing
parseOptions, parseModuleOptions,
parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- * Option pretty-printing
optionsGFO,
optionsPGF,
@@ -186,29 +186,27 @@ instance Show Options where
-- Option parsing
parseOptions :: FilePath -- ^ if there are relative file paths they will be interpreted as relative to this path
-> [String] -- ^ list of string arguments
parseOptions :: [String] -- ^ list of string arguments
-> Err (Options, [FilePath])
parseOptions root args
parseOptions args
| not (null errs) = errors errs
| otherwise = do opts <- liftM concatOptions $ sequence optss
return (fixRelativeLibPaths opts, files)
return (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 :: FilePath -- ^ if there are relative file paths they will be interpreted as relative to this path
-> [String] -- ^ list of string arguments
parseModuleOptions :: [String] -- ^ list of string arguments
-> Err Options
parseModuleOptions root args = do
(opts,nonopts) <- parseOptions root args
parseModuleOptions args = do
(opts,nonopts) <- parseOptions args
if null nonopts
then return opts
else errors $ map ("Non-option among module options: " ++) nonopts
fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
where
fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
-- Showing options
-- | Pretty-print the options that are preserved in .gfo files.

22
src/GF/Infra/UseIO.hs
View File

@@ -57,8 +57,8 @@ type FullPath = String
gfLibraryPath = "GF_LIB_PATH"
gfGrammarPathVar = "GF_GRAMMAR_PATH"
getLibraryPath :: Options -> IO FilePath
getLibraryPath opts =
getLibraryDirectory :: Options -> IO FilePath
getLibraryDirectory opts =
case flag optGFLibPath opts of
Just path -> return path
Nothing -> catch
@@ -66,19 +66,19 @@ getLibraryPath opts =
(\ex -> getDataDir >>= \path -> return (path </> "lib"))
getGrammarPath :: FilePath -> IO [FilePath]
getGrammarPath lib_path = do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_path </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
getGrammarPath lib_dir = do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_dir </> "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
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
extendPathEnv :: Options -> IO [FilePath]
extendPathEnv opts = do
opt_path <- return $ 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
ps <- liftM concat $ mapM allSubdirs paths
mapM canonicalizePath ps
where
allSubdirs :: FilePath -> IO [FilePath]

9
src/GFI.hs
View File

@@ -130,10 +130,11 @@ loop opts gfenv0 = do
putStrLn "wrote graph in file _gfdepgraph.dot"
loopNewCPU gfenv
"i":args -> do
cdir <- getCurrentDirectory
gfenv' <- case parseOptions cdir args of
Ok (opts',files) ->
importInEnv gfenv (addOptions opts opts') files
gfenv' <- case parseOptions args of
Ok (opts',files) -> do
curr_dir <- getCurrentDirectory
lib_dir <- getLibraryDirectory (addOptions opts opts')
importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
Bad err -> do
putStrLn $ "Command parse error: " ++ err
return gfenv