diff --git a/Language/Haskell/GhcImportedFrom.hs b/Language/Haskell/GhcImportedFrom.hs --- a/Language/Haskell/GhcImportedFrom.hs +++ b/Language/Haskell/GhcImportedFrom.hs @@ -140,7 +140,7 @@ parseHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String parseHaskellModuleName = do c <- TP.upper - cs <- TP.many (TP.choice [TP.lower, TP.upper]) + cs <- TP.many (TP.choice [TP.lower, TP.upper, TP.char '_', TP.digit]) return (c:cs) parseDottedHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String @@ -246,6 +246,8 @@ GhcMonad.liftIO $ putStrLn $ "getSummary, setting dynamic flags..." (allGhcOpts, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts + GhcMonad.liftIO $ putStrLn $ "getSummary, allGhcOpts: " ++ show allGhcOpts + -- Load the target file (e.g. "Muddle.hs"). GhcMonad.liftIO $ putStrLn $ "getSummary, loading the target file..." target <- guessTarget targetFile Nothing @@ -782,6 +784,9 @@ setCurrentDirectory workDir let targetFile = currentDir _targetFile + + putStrLn $ "currentDir: " ++ currentDir + putStrLn $ "workDir: " ++ workDir putStrLn $ "targetFile: " ++ targetFile putStrLn $ "targetModule: " ++ targetModule diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +2014-07-05 v0.2.0.6 + +* Use optparse-applicative for argument parsing. +* Allow digits and underscores in module names. + 2014-06-01 v0.2.0.5 * Version bound on ghc-mod. diff --git a/ghc-imported-from.cabal b/ghc-imported-from.cabal --- a/ghc-imported-from.cabal +++ b/ghc-imported-from.cabal @@ -1,5 +1,5 @@ name: ghc-imported-from -version: 0.2.0.5 +version: 0.2.0.6 synopsis: Find the Haddock documentation for a symbol. description: Given a Haskell module and symbol, determine the URL to the Haddock documentation for that symbol. @@ -39,6 +39,7 @@ , mtl , transformers , parsec + , optparse-applicative if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17 else @@ -74,6 +75,7 @@ , mtl , transformers , parsec + , optparse-applicative , hspec if impl(ghc < 7.7) @@ -106,6 +108,7 @@ , mtl , transformers , parsec + , optparse-applicative , hspec if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,116 +1,32 @@ -{-# LANGUAGE DeriveDataTypeable #-} - ---module Main where +module Main where import Language.Haskell.GhcImportedFrom - -import Data.List -import Data.Maybe -import Data.Version ( showVersion ) -import System.Environment - -import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) -import System.Console.GetOpt -import System.Exit - -import Control.Exception -import Data.Typeable - -import Control.Monad (forM_) import Control.Monad.Writer - -import Paths_ghc_imported_from - --- FIXME adapt these to ghc-imported-from -data GHCImportedFromError = SafeList - | TooManyArguments String - | NoSuchCommand String - | CmdArg [String] - | FileNotExist String deriving (Show, Typeable) - -instance Exception GHCImportedFromError - -ghcOptHelp :: String -ghcOptHelp = " [--ghc-option GHC_opt1 --ghc-option GHC_opt2 ...] " - -ghcPkgOptHelp :: String -ghcPkgOptHelp = " [--ghc-pkg-option ghc_pkg_opt1 --ghc-pkg-option ghc_pkg_opt2 ...] " - -usage :: String -usage = "ghc-imported-from version " ++ showVersion version ++ "\n" - ++ "Usage:\n" - ++ "\t ghc-imported-from haddock-url" ++ ghcOptHelp ++ ghcPkgOptHelp ++ " \n" - ++ "\t ghc-imported-from help\n" - ++ "\nExample: ghc-imported-from haddock-url src/Main.hs Main getArgs 160 13\n" +import Options.Applicative -parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) -parseArgs spec argv - = case getOpt Permute spec argv of - (o,n,[] ) -> (foldr id defaultOptions o, n) - (_,_,errs) -> throw (CmdArg errs) +data CmdOptions = CmdOptions { cmdGhcOptions :: [String] + , cmdGhcPkgOptions :: [String] + , cmdHaskellFile :: FilePath + , cmdModuleName :: String + , cmdSymbol :: String + , cmdLineNr :: Int + , cmdColNr :: Int + } deriving Show -argspec :: [OptDescr (Options -> Options)] -argspec = [ Option "g" ["ghc-options"] - (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghc-options") - "GHC options" - , Option "p" ["ghc-pkg-options"] - (ReqArg (\g opts -> opts { ghcPkgOpts = g : ghcPkgOpts opts }) "ghc-pkg-options") - "ghc-pkg options" - -- , Option "b" ["boundary"] - -- (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") - -- "specify line separator (default is Nul string)" - ] +parserOptions :: Parser CmdOptions +parserOptions = CmdOptions + <$> (many $ strOption ( long "ghc-options" <> help "GHC options" )) + <*> (many $ strOption ( long "ghc-pkg-options" <> help "ghc-pkg options" )) + <*> argument str (metavar "") + <*> argument str (metavar "") + <*> argument str (metavar "") + <*> argument auto (metavar "") + <*> argument auto (metavar "") main :: IO () -main = flip catches handlers $ do --- #if __GLASGOW_HASKELL__ >= 611 - hSetEncoding stdout utf8 --- #endif - args <- getArgs - let (opt,cmdArg) = parseArgs argspec args - - -- print opt - -- print cmdArg - - let cmdArg0 = cmdArg !. 0 - cmdArg1 = cmdArg !. 1 - cmdArg2 = cmdArg !. 2 - cmdArg3 = cmdArg !. 3 - cmdArg4 = cmdArg !. 4 - cmdArg5 = cmdArg !. 5 - remainingArgs = tail cmdArg - nArgs n f = if length remainingArgs == n - then f - else throw (TooManyArguments cmdArg0) - - res <- case cmdArg0 of - "haddock-url" -> nArgs 5 $ haddockUrl opt cmdArg1 cmdArg2 cmdArg3 (read cmdArg4) (read cmdArg5) - "help" -> return $ usageInfo usage argspec - cmd -> throw (NoSuchCommand cmd) - putStr res - - where - handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] - handleThenExit handler = \e -> handler e >> exitFailure - handler1 :: ErrorCall -> IO () - handler1 = print -- for debug - handler2 :: GHCImportedFromError -> IO () - handler2 SafeList = printUsage - handler2 (TooManyArguments cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments" - printUsage - handler2 (NoSuchCommand cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" - printUsage - handler2 (CmdArg errs) = do - mapM_ (hPutStr stderr) errs - printUsage - handler2 (FileNotExist file) = do - hPutStrLn stderr $ "\"" ++ file ++ "\" not found" - printUsage - printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec - - xs !. idx - | length xs <= idx = throw SafeList - | otherwise = xs !! idx - +main = do + (CmdOptions gOpts gpkgOpts hfile mname sym line col) <- execParser opts + haddockUrl (Options gOpts gpkgOpts (LineSeparator "\0")) hfile mname sym line col >>= putStr + where + opts = info (helper <*> parserOptions) + (fullDesc <> header "ghc-imported-from - find the haddock url for a symbol in a Haskell file.\n\nExample: ghc-imported-from src/Main.hs Main getArgs 160 13\n")