forked from GitHub/gf-core
another attempt to get the paths handling right
This commit is contained in:
@@ -9,6 +9,7 @@ import GF.Infra.UseIO
|
|||||||
import Paths_gf
|
import Paths_gf
|
||||||
|
|
||||||
import Data.Version
|
import Data.Version
|
||||||
|
import System.Directory
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
@@ -25,7 +26,8 @@ main = do
|
|||||||
setConsoleOutputCP codepage
|
setConsoleOutputCP codepage
|
||||||
#endif
|
#endif
|
||||||
args <- getArgs
|
args <- getArgs
|
||||||
case parseOptions args of
|
cdir <- getCurrentDirectory
|
||||||
|
case parseOptions cdir args of
|
||||||
Ok (opts,files) -> mainOpts opts files
|
Ok (opts,files) -> mainOpts opts files
|
||||||
Bad err -> do hPutStrLn stderr err
|
Bad err -> do hPutStrLn stderr err
|
||||||
hPutStrLn stderr "You may want to try --help."
|
hPutStrLn stderr "You may want to try --help."
|
||||||
|
|||||||
@@ -205,7 +205,7 @@ getOptionsFromFile file = do
|
|||||||
(\_ -> return (Bad $ "File " ++ file ++ " does not exist"))
|
(\_ -> return (Bad $ "File " ++ file ++ " does not exist"))
|
||||||
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
|
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
|
||||||
fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
|
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 :: [FilePath] -> String -> IO (Maybe FilePath)
|
||||||
getFilePath paths file = get paths
|
getFilePath paths file = get paths
|
||||||
|
|||||||
@@ -82,7 +82,7 @@ instance Binary ModuleStatus where
|
|||||||
instance Binary Options where
|
instance Binary Options where
|
||||||
put = put . optionsGFO
|
put = put . optionsGFO
|
||||||
get = do opts <- get
|
get = do opts <- get
|
||||||
case parseModuleOptions ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of
|
case parseModuleOptions "." ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of
|
||||||
Ok x -> return x
|
Ok x -> return x
|
||||||
Bad msg -> fail msg
|
Bad msg -> fail msg
|
||||||
|
|
||||||
|
|||||||
@@ -276,7 +276,7 @@ TermDef
|
|||||||
|
|
||||||
FlagDef :: { Options }
|
FlagDef :: { Options }
|
||||||
FlagDef
|
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
|
Ok x -> return x
|
||||||
Bad msg -> failLoc $1 msg }
|
Bad msg -> failLoc $1 msg }
|
||||||
|
|
||||||
|
|||||||
@@ -186,18 +186,28 @@ instance Show Options where
|
|||||||
|
|
||||||
-- Option parsing
|
-- Option parsing
|
||||||
|
|
||||||
parseOptions :: [String] -> Err (Options, [FilePath])
|
parseOptions :: FilePath -- ^ if there are relative file paths they will be interpreted as relative to this path
|
||||||
parseOptions args
|
-> [String] -- ^ list of string arguments
|
||||||
| not (null errs) = errors errs
|
-> Err (Options, [FilePath])
|
||||||
| otherwise = do opts <- liftM concatOptions $ sequence optss
|
parseOptions root args
|
||||||
return (opts, files)
|
| not (null errs) = errors errs
|
||||||
where (optss, files, errs) = getOpt RequireOrder optDescr args
|
| 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 :: FilePath -- ^ if there are relative file paths they will be interpreted as relative to this path
|
||||||
parseModuleOptions args = do (opts,nonopts) <- parseOptions args
|
-> [String] -- ^ list of string arguments
|
||||||
if null nonopts
|
-> Err Options
|
||||||
then return opts
|
parseModuleOptions root args = do
|
||||||
else errors $ map ("Non-option among module options: " ++) nonopts
|
(opts,nonopts) <- parseOptions root args
|
||||||
|
if null nonopts
|
||||||
|
then return opts
|
||||||
|
else errors $ map ("Non-option among module options: " ++) nonopts
|
||||||
|
|
||||||
-- Showing options
|
-- Showing options
|
||||||
|
|
||||||
|
|||||||
@@ -65,20 +65,20 @@ getLibraryPath opts =
|
|||||||
(getEnv gfLibraryPath)
|
(getEnv gfLibraryPath)
|
||||||
(\ex -> getDataDir >>= \path -> return (path </> "lib"))
|
(\ex -> getDataDir >>= \path -> return (path </> "lib"))
|
||||||
|
|
||||||
getGrammarPath :: Options -> IO [FilePath]
|
getGrammarPath :: FilePath -> IO [FilePath]
|
||||||
getGrammarPath opts = do
|
getGrammarPath lib_path = do
|
||||||
let ss1 = flag optLibraryPath opts
|
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_path </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
|
||||||
ss2 <- catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return ["prelude","."]) -- e.g. GF_GRAMMAR_PATH
|
|
||||||
return (ss1 ++ ss2)
|
|
||||||
|
|
||||||
-- | extends the search path with the
|
-- | extends the search path with the
|
||||||
-- 'gfLibraryPath' and 'gfGrammarPathVar'
|
-- 'gfLibraryPath' and 'gfGrammarPathVar'
|
||||||
-- environment variables. Returns only existing paths.
|
-- environment variables. Returns only existing paths.
|
||||||
extendPathEnv :: Options -> FilePath -> IO [FilePath]
|
extendPathEnv :: Options -> FilePath -> IO [FilePath]
|
||||||
extendPathEnv opts fdir = do
|
extendPathEnv opts fdir = do
|
||||||
b <- getLibraryPath opts -- e.g. GF_LIB_PATH
|
opt_paths <- return $ flag optLibraryPath opts -- e.g. paths given as options
|
||||||
ss <- getGrammarPath opts -- e.g. GF_GRAMMAR_PATH
|
lib_path <- getLibraryPath opts -- e.g. GF_LIB_PATH
|
||||||
ps <- liftM (nub . concat) $ mapM allSubdirs $ [fdir </> s | s <- ss] ++ [b </> s | s <- ss]
|
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
|
mapM canonicalizePath ps
|
||||||
where
|
where
|
||||||
allSubdirs :: FilePath -> IO [FilePath]
|
allSubdirs :: FilePath -> IO [FilePath]
|
||||||
|
|||||||
@@ -34,6 +34,7 @@ import qualified Data.ByteString.Char8 as BS
|
|||||||
import qualified Text.ParserCombinators.ReadP as RP
|
import qualified Text.ParserCombinators.ReadP as RP
|
||||||
import System.Cmd
|
import System.Cmd
|
||||||
import System.CPUTime
|
import System.CPUTime
|
||||||
|
import System.Directory
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Version
|
import Data.Version
|
||||||
@@ -129,7 +130,8 @@ loop opts gfenv0 = do
|
|||||||
putStrLn "wrote graph in file _gfdepgraph.dot"
|
putStrLn "wrote graph in file _gfdepgraph.dot"
|
||||||
loopNewCPU gfenv
|
loopNewCPU gfenv
|
||||||
"i":args -> do
|
"i":args -> do
|
||||||
gfenv' <- case parseOptions args of
|
cdir <- getCurrentDirectory
|
||||||
|
gfenv' <- case parseOptions cdir args of
|
||||||
Ok (opts',files) ->
|
Ok (opts',files) ->
|
||||||
importInEnv gfenv (addOptions opts opts') files
|
importInEnv gfenv (addOptions opts opts') files
|
||||||
Bad err -> do
|
Bad err -> do
|
||||||
|
|||||||
Reference in New Issue
Block a user