mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
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 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."
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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 }
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user