- progName <- getProgName
- let usageString =
- "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
- args <- getArgs
- let (ghcArgs, ourArgs, unbalanced) = splitArgs args
- let (modes, filenames, errs) = getOpt Permute options ourArgs
- if unbalanced || errs /= [] || elem Help modes || filenames == []
- then do
- putStr $ unlines errs
- putStr $ usageInfo usageString options
- exitWith (ExitFailure 1)
- else return ()
- let mode = getMode (Append `delete` modes)
- let openFileMode = if elem Append modes
- then AppendMode
- else WriteMode
- GHC.init (Just "/usr/local/lib/ghc-6.5")
- GHC.defaultErrorHandler defaultDynFlags $ do
- session <- newSession JustTypecheck
- print "created a session"
- flags <- getSessionDynFlags session
- (pflags, _) <- parseDynamicFlags flags ghcArgs
- let flags = pflags { hscTarget = HscNothing }
- GHC.defaultCleanupHandler flags $ do
- flags <- initPackages flags
- setSessionDynFlags session flags
- setTargets session (map fileTarget filenames)
- print "set targets"
- success <- load session LoadAllTargets --- bring module graph up to date
- filedata <- case success of
- Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) }
- Succeeded -> do
- print "loaded all targets"
- graph <- getModuleGraph session
- print "got modules graph"
- graphData session graph
- if mode == BothTags || mode == CTags
- then do
- ctagsfile <- openFile "tags" openFileMode
- writectagsfile ctagsfile filedata
- hClose ctagsfile
- else return ()
- if mode == BothTags || mode == ETags
- then do
- etagsfile <- openFile "TAGS" openFileMode
- writeetagsfile etagsfile filedata
- hClose etagsfile
- else return ()
-
--- | getMode takes a list of modes and extract the mode with the
--- highest precedence. These are as follows: Both, CTags, ETags
--- The default case is Both.
-getMode :: [Mode] -> Mode
-getMode [] = BothTags
-getMode [x] = x
-getMode (x:xs) = max x (getMode xs)
-
+ progName <- getProgName
+ let usageString =
+ "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
+ args <- getArgs
+ let (ghcArgs', ourArgs, unbalanced) = splitArgs args
+ let (flags, filenames, errs) = getOpt Permute options ourArgs
+ let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
+
+ let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
+ [] -> ""
+ (x:_) -> x
+ mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
+ otherfiles
+ if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
+ then do
+ putStr $ unlines errs
+ putStr $ usageInfo usageString options
+ exitWith (ExitFailure 1)
+ else return ()
+
+ ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of
+ [distPref] -> do
+ cabalOpts <- flagsFromCabal distPref
+ return (ghcArgs' ++ cabalOpts)
+ [] ->
+ return ghcArgs'
+ _ -> error "Too many --use-cabal-config flags"
+ print ghcArgs
+
+ let modes = getMode flags
+ let openFileMode = if elem FlagAppend flags
+ then AppendMode
+ else WriteMode
+ ctags_hdl <- if CTags `elem` modes
+ then Just `liftM` openFile "tags" openFileMode
+ else return Nothing
+ etags_hdl <- if ETags `elem` modes
+ then Just `liftM` openFile "TAGS" openFileMode
+ else return Nothing
+
+ GHC.defaultErrorHandler defaultDynFlags $
+ runGhc (Just ghc_topdir) $ do
+ --liftIO $ print "starting up session"
+ dflags <- getSessionDynFlags
+ (pflags, unrec, warns) <- parseDynamicFlags dflags{ verbosity=1 }
+ (map noLoc ghcArgs)
+ unless (null unrec) $
+ liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec)
+ liftIO $ mapM_ putStrLn (map unLoc warns)
+ let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
+ -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0
+ -- Just m -> sizeUFM m)
+ setSessionDynFlags dflags2
+ --liftIO $ print (length pkgs)
+
+ GHC.defaultCleanupHandler dflags2 $ do
+
+ targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
+ mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
+
+----------------------------------------------
+---------- ARGUMENT PROCESSING --------------
+
+data Flag
+ = FlagETags
+ | FlagCTags
+ | FlagBoth
+ | FlagAppend
+ | FlagHelp
+ | FlagTopDir FilePath
+ | FlagUseCabalConfig FilePath
+ | FlagFilesFromCabal
+ deriving (Ord, Eq, Show)
+ -- ^Represents options passed to the program
+
+data Mode = ETags | CTags deriving Eq
+
+getMode :: [Flag] -> [Mode]
+getMode fs = go (concatMap modeLike fs)
+ where go [] = [ETags,CTags]
+ go [x] = [x]
+ go more = nub more
+
+ modeLike FlagETags = [ETags]
+ modeLike FlagCTags = [CTags]
+ modeLike FlagBoth = [ETags,CTags]
+ modeLike _ = []