X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghctags%2FGhcTags.hs;h=5fcdc82773cd6c390b90842efe9cffaf3b9bdaa2;hp=fe5cd64114f953dc3b9c38de2e69f0c5b072392c;hb=86a846d837d303694b57f68140a01c2c0940dc27;hpb=2e6bfe90491d5ab2ea58b4b1e60debd4738be643 diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index fe5cd64..5fcdc82 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/GhcTags.hs @@ -31,10 +31,12 @@ placateGhc = defaultErrorHandler defaultDynFlags $ do main :: IO () main = do progName <- getProgName + let usageString = + "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]" args <- getArgs - let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]" - let (modes, filenames, errs) = getOpt Permute options args - if errs /= [] || elem Help modes || filenames == [] + 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 @@ -49,11 +51,21 @@ main = do session <- newSession JustTypecheck print "created a session" flags <- getSessionDynFlags session - (flags, _) <- parseDynamicFlags flags ["-package", "ghc"] + (pflags, _) <- parseDynamicFlags flags ghcArgs + let flags = pflags { hscTarget = HscNothing } GHC.defaultCleanupHandler flags $ do flags <- initPackages flags setSessionDynFlags session flags - filedata <- mapM (findthings session) filenames + 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 @@ -76,6 +88,13 @@ getMode [x] = x getMode (x:xs) = max x (getMode xs) +splitArgs :: [String] -> ([String], [String], Bool) +-- pull out arguments between -- for GHC +splitArgs args = split [] [] False args + where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args + split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args + split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal) + data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show) options :: [OptDescr Mode] @@ -94,29 +113,12 @@ type FileName = String type ThingName = String --- The position of a token or definition -data Pos = Pos - FileName -- file name - Int -- line number - Int -- token number - String -- string that makes up that line - deriving Show - -srcLocToPos :: SrcLoc -> Pos -srcLocToPos loc = - Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus" - -- A definition we have found -data FoundThing = FoundThing ThingName Pos - deriving Show +data FoundThing = FoundThing ModuleName ThingName SrcLoc -- Data we have obtained from a file data FileData = FileData FileName [FoundThing] -data Token = Token String Pos - deriving Show - - -- stuff for dealing with ctags output format writectagsfile :: Handle -> [FileData] -> IO () @@ -128,8 +130,10 @@ getfoundthings :: FileData -> [FoundThing] getfoundthings (FileData filename things) = things dumpthing :: FoundThing -> String -dumpthing (FoundThing name (Pos filename line _ _)) = +dumpthing (FoundThing modname name loc) = name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1) + where line = srcLocLine loc + filename = unpackFS $ srcLocFile loc -- stuff for dealing with etags output format @@ -146,10 +150,11 @@ e_dumpfiledata (FileData filename things) = thingslength = length thingsdump e_dumpthing :: FoundThing -> String -e_dumpthing (FoundThing name (Pos filename line token fullline)) = - ---- (concat $ take (token + 1) $ spacedwords fullline) - name - ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n" +e_dumpthing (FoundThing modname name loc) = + tagline name ++ tagline (moduleNameString modname ++ "." ++ name) + where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n" + line = srcLocLine loc + -- like "words", but keeping the whitespace, and so letting us build @@ -173,85 +178,61 @@ modsummary graph n = modname :: ModSummary -> ModuleName modname summary = moduleName $ ms_mod $ summary -findthings :: Session -> FileName -> IO FileData -findthings session filename = do - setTargets session [Target (TargetFile filename Nothing) Nothing] - print "set targets" - success <- load session LoadAllTargets --- bring module graph up to date - case success of - Failed -> do { print "load failed"; return emptyFileData } - Succeeded -> - do print "loaded all targets" - graph <- getModuleGraph session - print "got modules graph" - case modsummary graph filename of - Nothing -> panic "loaded a module from a file but then could not find its summary" - Just ms -> do - mod <- checkModule session (modname ms) - print "got the module" - case mod of - Nothing -> return emptyFileData - Just m -> case renamedSource m of - Nothing -> return emptyFileData - Just s -> return $ fileData filename s - where emptyFileData = FileData filename [] - - -fileData :: FileName -> RenamedSource -> FileData -fileData filename (group, imports, lie) = +fileTarget :: FileName -> Target +fileTarget filename = Target (TargetFile filename Nothing) Nothing + +graphData :: Session -> ModuleGraph -> IO [FileData] +graphData session graph = + mapM foundthings graph + where foundthings ms = + let filename = msHsFilePath ms + modname = moduleName $ ms_mod ms + in do mod <- checkModule session modname + return $ maybe (FileData filename []) id $ do + m <- mod + s <- renamedSource m + return $ fileData filename modname s + +fileData :: FileName -> ModuleName -> RenamedSource -> FileData +fileData filename modname (group, imports, lie) = -- lie is related to type checking and so is irrelevant -- imports contains import declarations and no definitions - FileData filename (boundValues group) - -boundValues :: HsGroup Name -> [FoundThing] -boundValues group = - case hs_valds group of - ValBindsOut nest sigs -> - [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ] - -posOfLocated :: Located a -> Pos -posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs - -boundThings :: LHsBind Name -> [FoundThing] -boundThings lbinding = - let thing id = FoundThing (getOccString $ unLoc id) (posOfLocated id) + FileData filename (boundValues modname group) + +boundValues :: ModuleName -> HsGroup Name -> [FoundThing] +boundValues mod group = + let vals = case hs_valds group of + ValBindsOut nest sigs -> + [ x | (_rec, binds) <- nest, bind <- bagToList binds, + x <- boundThings mod bind ] + tys = concat $ map tyBound (hs_tyclds group) + where tyBound ltcd = case unLoc ltcd of + ForeignType { tcdLName = n } -> [found n] + TyData { tcdLName = tycon, tcdCons = cons } -> + dataNames tycon cons + TySynonym { tcdLName = n } -> [found n] + ClassDecl { tcdLName = n } -> [found n] + fors = concat $ map forBound (hs_fords group) + where forBound lford = case unLoc lford of + ForeignImport n _ _ -> [found n] + ForeignExport { } -> [] + in vals ++ tys ++ fors + where dataNames tycon cons = found tycon : map conName cons + conName td = found $ con_name $ unLoc td + found = foundOfLName mod + +startOfLocated :: Located a -> SrcLoc +startOfLocated lHs = srcSpanStart $ getLoc lHs + +foundOfLName :: ModuleName -> Located Name -> FoundThing +foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id) + +boundThings :: ModuleName -> LHsBind Name -> [FoundThing] +boundThings modname lbinding = + let thing = foundOfLName modname in case unLoc lbinding of FunBind { fun_id = id } -> [thing id] - PatBind { pat_lhs = lhs } -> patBoundIds lhs --- VarBind { var_id = id } -> [thing id] - _ -> [] - - -patBoundIds :: a -> b -patBoundIds _ = panic "not on your life" - --- actually pick up definitions - -findstuff :: [Token] -> [FoundThing] -findstuff ((Token "data" _):(Token name pos):xs) = - FoundThing name pos : (getcons xs) ++ (findstuff xs) -findstuff ((Token "newtype" _):(Token name pos):xs) = - FoundThing name pos : findstuff xs -findstuff ((Token "type" _):(Token name pos):xs) = - FoundThing name pos : findstuff xs -findstuff ((Token name pos):(Token "::" _):xs) = - FoundThing name pos : findstuff xs -findstuff (x:xs) = findstuff xs -findstuff [] = [] - - --- get the constructor definitions, knowing that a datatype has just started - -getcons :: [Token] -> [FoundThing] -getcons ((Token "=" _):(Token name pos):xs) = - FoundThing name pos : getcons2 xs -getcons (x:xs) = getcons xs -getcons [] = [] - - -getcons2 ((Token "=" _):xs) = [] -getcons2 ((Token "|" _):(Token name pos):xs) = - FoundThing name pos : getcons2 xs -getcons2 (x:xs) = getcons2 xs -getcons2 [] = [] + PatBind { pat_lhs = lhs } -> panic "Pattern at top level" + VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] + AbsBinds { } -> [] -- nothing interesting in a type abstraction