diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,32 +1,39 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} module Main where +import Options.Applicative import qualified Language.Haskell.Exts.Annotated as L -import System.Console.CmdArgs -import System.IO (hPutStrLn, stderr, stdout, IOMode(..), openFile, hClose) -import qualified Data.Map as Map +import System.IO +import GHC.IO.Handle (HandlePosition) +import qualified Data.Map.Strict as Map import qualified Language.Preprocessor.Cpphs as CPP -import Control.Monad (forM) +import Control.Exception (ErrorCall(..), catch, evaluate) +import System.Exit (exitFailure) +import Control.Monad +import qualified Data.Array.Unboxed as A import Data.List (sort) import Data.Maybe (fromMaybe) -import System.FilePath.Posix (takeFileName) +import Data.List.Split (endBy) type Database = Map.Map String (L.Module L.SrcSpanInfo) +type LineInfo = Map.Map FilePath (A.Array Int (HandlePosition, String)) -data Defn = Defn FilePath Int -- file, line +data Defn = Defn FilePath Int Int -- file, line, end col deriving Show localDecls :: L.Module L.SrcSpanInfo -> Map.Map String Defn localDecls (L.Module _ _ _ _ decls) = Map.fromList $ concatMap extract decls where - extract (L.TypeDecl _ head _) = extractDeclHead head - extract (L.TypeFamDecl _ head _) = extractDeclHead head - extract (L.DataDecl _ _ _ head decls _) = extractDeclHead head ++ concatMap extractQualConDecl decls - extract (L.GDataDecl _ _ _ head _ decls _) = extractDeclHead head ++ concatMap extractGadtDecl decls - extract (L.DataFamDecl _ _ head _) = extractDeclHead head - extract (L.ClassDecl _ _ head _ clsdecls) = extractDeclHead head ++ concatMap extractClassDecl (fromMaybe [] clsdecls) + extract (L.TypeDecl _ hd _) = extractDeclHead hd + extract (L.TypeFamDecl _ hd _) = extractDeclHead hd + extract (L.DataDecl _ _ _ hd decls' _) = + extractDeclHead hd ++ concatMap extractQualConDecl decls' + extract (L.GDataDecl _ _ _ hd _ decls' _) = + extractDeclHead hd ++ concatMap extractGadtDecl decls' + extract (L.DataFamDecl _ _ hd _) = extractDeclHead hd + extract (L.ClassDecl _ _ hd _ clsdecls) = + extractDeclHead hd ++ concatMap extractClassDecl (fromMaybe [] clsdecls) extract (L.TypeSig _ names _) = concatMap extractName names extract (L.FunBind _ (L.Match _ name _ _ _ : _)) = extractName name extract (L.FunBind _ (L.InfixMatch _ _ name _ _ _ : _)) = extractName name @@ -50,8 +57,10 @@ extractPat (L.PBangPat _ pat) = extractPat pat extractPat _ = [] - extractQualConDecl (L.QualConDecl _ _ _ (L.ConDecl _ name _)) = extractName name - extractQualConDecl (L.QualConDecl _ _ _ (L.RecDecl _ name fields)) = extractName name ++ concatMap extractFieldDecl fields + extractQualConDecl (L.QualConDecl _ _ _ (L.ConDecl _ name _)) = + extractName name + extractQualConDecl (L.QualConDecl _ _ _ (L.RecDecl _ name fields)) = + extractName name ++ concatMap extractFieldDecl fields extractQualConDecl _ = [] extractFieldDecl (L.FieldDecl _ names _) = concatMap extractName names @@ -59,234 +68,332 @@ extractGadtDecl (L.GadtDecl _ name _ _) = extractName name extractClassDecl (L.ClsDecl _ decl) = extract decl - extractClassDecl (L.ClsDataFam _ _ head _) = extractDeclHead head - extractClassDecl (L.ClsTyFam _ head _) = extractDeclHead head + extractClassDecl (L.ClsDataFam _ _ hd _) = extractDeclHead hd + extractClassDecl (L.ClsTyFam _ hd _) = extractDeclHead hd extractClassDecl _ = [] extractName (L.Ident loc name) = [(name, getLoc loc)] - extractName (L.Symbol _ _) = [] -- no symbols for now + extractName (L.Symbol loc name) = [(name, getLoc loc)] localDecls _ = Map.empty getLoc :: L.SrcSpanInfo -> Defn -getLoc (L.SrcSpanInfo (L.SrcSpan file line _ _ _) _) = Defn file line +getLoc (L.SrcSpanInfo (L.SrcSpan file line _ _ ecol) _) = + Defn file line ecol thingMembers :: L.Module L.SrcSpanInfo -> String -> [String] thingMembers (L.Module _ _ _ _ decls) name = concatMap extract decls - where - extract (L.DataDecl _ _ _ head condecls _) | nameOfHead head == Just name = concatMap getQualConDecl condecls - extract (L.GDataDecl _ _ _ head _ condecls _) | nameOfHead head == Just name = concatMap getGadtDecl condecls - extract (L.ClassDecl _ _ head _ (Just classdecls)) | nameOfHead head == Just name = concatMap getClassDecl classdecls + where + extract (L.DataDecl _ _ _ hd condecls _) + | nameOfHead hd == Just name = concatMap getQualConDecl condecls + extract (L.GDataDecl _ _ _ hd _ condecls _) + | nameOfHead hd == Just name = concatMap getGadtDecl condecls + extract (L.ClassDecl _ _ hd _ (Just classdecls)) + | nameOfHead hd == Just name = concatMap getClassDecl classdecls extract _ = [] - getQualConDecl (L.QualConDecl _ _ _ (L.ConDecl _ (L.Ident _ name) _)) = [name] - getQualConDecl (L.QualConDecl _ _ _ (L.RecDecl _ (L.Ident _ name) fields)) = name : concatMap getField fields + getQualConDecl (L.QualConDecl _ _ _ (L.ConDecl _ (L.Ident _ name') _)) = + [name'] + getQualConDecl (L.QualConDecl _ _ _ (L.RecDecl _ (L.Ident _ name') flds)) = + name' : concatMap getField flds getQualConDecl _ = [] - getGadtDecl (L.GadtDecl _ name _ _) = getName name - + getGadtDecl (L.GadtDecl _ name' _ _) = getName name' + getField (L.FieldDecl _ names _) = concatMap getName names - getClassDecl (L.ClsDecl _ (L.FunBind _ (L.Match _ name _ _ _ : _))) = getName name - getClassDecl (L.ClsDecl _ (L.PatBind _ (L.PVar _ name) _ _)) = getName name + getClassDecl (L.ClsDecl _ (L.FunBind _ (L.Match _ name' _ _ _ : _))) = + getName name' + getClassDecl (L.ClsDecl _ (L.PatBind _ (L.PVar _ name') _ _)) = + getName name' getClassDecl _ = [] - getName (L.Ident _ name) = [name] + getName (L.Ident _ name') = [name'] getName _ = [] - nameOfHead (L.DHead _ (L.Ident _ name)) = Just name - nameOfHead (L.DHInfix _ _ (L.Ident _ name)) = Just name + nameOfHead (L.DHead _ (L.Ident _ name')) = Just name' + nameOfHead (L.DHInfix _ _ (L.Ident _ name')) = Just name' nameOfHead (L.DHParen _ h) = nameOfHead h nameOfHead _ = Nothing thingMembers _ _ = [] modExports :: Database -> String -> Map.Map String Defn -modExports db modname = - case Map.lookup modname db of - Nothing -> Map.empty - Just mod -> Map.filterWithKey (\k _ -> exported mod k) (localDecls mod) +modExports db modname = case Map.lookup modname db of + Nothing -> Map.empty + Just mod' -> Map.filterWithKey (\k _ -> exported mod' k) (localDecls mod') exported :: L.Module L.SrcSpanInfo -> String -> Bool -exported mod@(L.Module _ (Just (L.ModuleHead _ _ _ (Just (L.ExportSpecList _ specs)))) _ _ _) name = any (matchesSpec name) specs - where - matchesSpec name (L.EVar _ _ (L.UnQual _ (L.Ident _ name'))) = name == name' - matchesSpec name (L.EAbs _ (L.UnQual _ (L.Ident _ name'))) = name == name' - matchesSpec name (L.EThingAll _ (L.UnQual _ (L.Ident _ name'))) = name == name' || (name `elem` thingMembers mod name') - matchesSpec name (L.EThingWith _ (L.UnQual _ (L.Ident _ name')) cnames) = name == name' || any (matchesCName name) cnames - matchesSpec _ (L.EModuleContents _ (L.ModuleName _ _)) = False -- XXX wrong, moduleScope handles it though +exported mod'@(L.Module _ + (Just (L.ModuleHead _ _ _ + (Just (L.ExportSpecList _ specs)))) _ _ _) name = + any (matchesSpec name) specs + where + matchesSpec nm (L.EVar _ _ (L.UnQual _ (L.Ident _ name'))) = nm == name' + matchesSpec nm (L.EAbs _ (L.UnQual _ (L.Ident _ name'))) = nm == name' + matchesSpec nm (L.EThingAll _ (L.UnQual _ (L.Ident _ name'))) = + nm == name' || (nm `elem` thingMembers mod' name') + matchesSpec nm (L.EThingWith _ (L.UnQual _ (L.Ident _ name')) cnames) = + nm == name' || any (matchesCName nm) cnames + -- XXX this is wrong, moduleScope handles it though + matchesSpec _ (L.EModuleContents _ (L.ModuleName _ _)) = False matchesSpec _ _ = False - - matchesCName name (L.VarName _ (L.Ident _ name')) = name == name' - matchesCName name (L.ConName _ (L.Ident _ name')) = name == name' + + matchesCName nm (L.VarName _ (L.Ident _ name')) = nm == name' + matchesCName nm (L.ConName _ (L.Ident _ name')) = nm == name' matchesCName _ _ = False exported _ _ = True moduleScope :: Database -> L.Module L.SrcSpanInfo -> Map.Map String Defn -moduleScope db mod@(L.Module _ modhead _ imports _) = Map.unions $ moduleItself : localDecls mod : map extractImport imports +moduleScope db mod'@(L.Module _ modhead _ imports _) = + Map.unions $ moduleItself : localDecls mod' : map extractImport imports where - - moduleItself = moduleDecl modhead `Map.union` enclosingFilename mod + moduleItself = moduleDecl modhead - moduleDecl (Just (L.ModuleHead l (L.ModuleName _ name) _ _)) = Map.singleton name (getLoc l) - moduleDecl _ = Map.empty + moduleDecl (Just (L.ModuleHead l (L.ModuleName _ name) _ _)) = + Map.singleton name (getLoc l) + moduleDecl _ = Map.empty - enclosingFilename (L.Module l _ _ _ _) = Map.singleton (filename l) (getLoc l) - enclosingFilename _ = Map.empty + extractImport decl@(L.ImportDecl { L.importModule = L.ModuleName _ name + , L.importSpecs = spec + }) = + let extraExports + | Just (L.ModuleHead _ _ _ + (Just (L.ExportSpecList _ especs))) <- modhead = + Map.unions [ modExports db modname | + L.EModuleContents _ (L.ModuleName _ modname) + <- especs ] + | otherwise = Map.empty in - filename (L.SrcSpanInfo (L.SrcSpan file _ _ _ _) _) = takeFileName file - - extractImport decl@(L.ImportDecl { L.importModule = L.ModuleName _ name, L.importSpecs = spec }) = - Map.unions [ - if L.importQualified decl then Map.empty else names, - Map.mapKeys ((name ++ ".") ++) names, - case L.importAs decl of - Nothing -> Map.empty - Just (L.ModuleName _ name') -> Map.mapKeys ((name' ++ ".") ++) names, - extraExports - ] - + Map.unions [ + if L.importQualified decl + then Map.empty + else names + , Map.mapKeys ((name ++ ".") ++) names + , case L.importAs decl of + Nothing -> Map.empty + Just (L.ModuleName _ name') -> + Map.mapKeys ((name' ++ ".") ++) names + , extraExports + ] where - names | Just (L.ImportSpecList _ True specs) <- spec = normalExports `Map.difference` (Map.fromList (map (flip (,) ()) (concatMap specName specs))) - | Just (L.ImportSpecList _ False specs) <- spec = Map.filterWithKey (\k _ -> k `elem` concatMap specName specs) normalExports - | otherwise = normalExports - - normalExports = modExports db name + names | Just (L.ImportSpecList _ True specs) <- spec = + let s = map (flip (,) ()) (concatMap specName specs) in + normalExports `Map.difference` Map.fromList s + | Just (L.ImportSpecList _ False specs) <- spec = + let f k _ = k `elem` concatMap specName specs in + Map.filterWithKey f normalExports + | otherwise = normalExports - specName (L.IVar _ _ (L.Ident _ name)) = [name] - specName (L.IAbs _ (L.Ident _ name)) = [name] - specName (L.IThingAll _ (L.Ident _ name)) = [name] -- XXX incorrect, need its member names - specName (L.IThingWith _ (L.Ident _ name) cnames) = name : concatMap cname cnames - specName _ = [] + normalExports = modExports db name - cname (L.VarName _ (L.Ident _ name)) = [name] - cname (L.ConName _ (L.Ident _ name)) = [name] - cname _ = [] + specName (L.IVar _ _ (L.Ident _ name')) = [name'] + specName (L.IAbs _ (L.Ident _ name')) = [name'] + -- XXX incorrect, need its member names + specName (L.IThingAll _ (L.Ident _ name')) = [name'] + specName (L.IThingWith _ (L.Ident _ name') cnames) = + name' : concatMap cname cnames + specName _ = [] - extraExports | Just (L.ModuleHead _ _ _ (Just (L.ExportSpecList _ especs))) <- modhead = - Map.unions [ modExports db modname | L.EModuleContents _ (L.ModuleName _ modname) <- especs ] - | otherwise = Map.empty + cname (L.VarName _ (L.Ident _ name')) = [name'] + cname (L.ConName _ (L.Ident _ name')) = [name'] + cname _ = [] moduleScope _ _ = Map.empty -makeTag :: FilePath -> (String, Defn) -> String -makeTag refFile (name, Defn file line) = name ++ "\t" ++ file ++ "\t" ++ show line ++ ";\"\t" ++ "file:" ++ refFile +makeVimTags :: FilePath -> Map.Map String Defn -> LineInfo -> IO [String] +makeVimTags refFile m _ = pure $ map (makeTag refFile) (Map.assocs m) + where + makeTag refFile' (name, Defn file line _) = + name ++ "\t" ++ file ++ "\t" ++ show line ++ ";\"\t" ++ "file:" ++ + refFile' -makeTags :: FilePath -> Map.Map String Defn -> [String] -makeTags refFile = map (makeTag refFile) . Map.assocs +makeEmacsTags :: FilePath -> Map.Map String Defn -> LineInfo -> IO [String] +makeEmacsTags refFile m li = do + tags <- mapM (makeTag refFile) (Map.assocs m) + let tagsLen = show (sum $ map length tags) + return $ "\x0c":(refFile ++ "," ++ tagsLen):tags + where + makeTag _ (name, Defn file line ecol) = do + ms <- catch (evaluate $ li Map.! file) $ \(ErrorCall _) -> do + hPutStrLn stderr $ "hothasktags: couldn't find '" ++ file ++ "'" + exitFailure + let linenum = show line + (offset, leader) = + let x = ms A.! (line - 1) in + (show $ fst x, take (ecol - 1) $ snd x) + return $ leader ++ "\x7f" ++ name ++ "\x01" ++ linenum ++ "," ++ offset haskellSource :: [L.Extension] -> HotHasktags -> FilePath -> IO String haskellSource exts conf file = do contents <- readFile file let needsCpp = not . null $ - [ () - | Just (_language, extsFile) <- [L.readExtensions contents], - L.EnableExtension L.CPP <- extsFile ] - ++ [ () | L.EnableExtension L.CPP <- exts ] - if not needsCpp - then return contents - else do - cppOpts <- either recoverCppOptFail return - (CPP.parseOptions (hh_cpphs conf)) - CPP.runCpphs (addOpts cppOpts) file contents - where + [ () | Just (_language, extsFile) <- [L.readExtensions contents], + L.EnableExtension L.CPP <- extsFile ] + ++ [ () | L.EnableExtension L.CPP <- exts ] + if not needsCpp then return contents else do + cppOpts <- either recoverCppOptFail return + (CPP.parseOptions (hhCpphs conf)) + CPP.runCpphs (addOpts cppOpts) file contents + where addOpts defOpts = defOpts { CPP.boolopts = (CPP.boolopts defOpts) { CPP.hashline = False }, - CPP.defines = map splitDefines (hh_define conf) ++ CPP.defines defOpts, - CPP.includes = hh_include conf ++ CPP.includes defOpts } + CPP.defines = map splitDefines (hhDefine conf) ++ + CPP.defines defOpts, + CPP.includes = hhInclude conf ++ CPP.includes defOpts } recoverCppOptFail err = do hPutStrLn stderr $ "cpphs parse error arguments:" ++ err return CPP.defaultCpphsOptions - splitDefines :: String -> (String,String) - splitDefines s = let (a,b) = break (=='=') s - in (a, case drop 1 b of - [] -> "1" - b' -> b') - - + splitDefines s = let (a,b) = break (=='=') s in + (a, case drop 1 b of + [] -> "1" + b' -> b') + makeDatabase :: [L.Extension] -> HotHasktags -> IO Database -makeDatabase exts conf = do - fmap (Map.fromList . concat) . forM (hh_files conf) $ \file -> do +makeDatabase exts conf = + fmap (Map.fromList . concat) . forM (hhFiles conf) $ \file -> do result <- L.parseFileContentsWithMode (mode file) `fmap` haskellSource exts conf file case result of - L.ParseOk mod@(L.Module _ (Just (L.ModuleHead _ (L.ModuleName _ name) _ _)) _ _ _) -> do - return [(name, mod)] - L.ParseFailed loc str -> do - hPutStrLn stderr $ "Parse error: " ++ show loc ++ ": " ++ str - return [] - _ -> do + L.ParseOk mod'@(L.Module _ moduleHead _ _ _) -> + return [(moduleName moduleHead, mod')] + L.ParseFailed loc str' -> do + hPutStrLn stderr $ "Parse error: " ++ show loc ++ ": " ++ str' return [] - where - mode filename = L.ParseMode { - L.parseFilename = filename, - L.extensions = exts, - L.ignoreLanguagePragmas = False, - L.ignoreLinePragmas = False, - L.fixities = Nothing, - L.baseLanguage = L.Haskell2010 + _ -> return [] + where + moduleName (Just (L.ModuleHead _ (L.ModuleName _ name) _ _)) = name + -- for files without a module decl, i.e. implicit Main + moduleName Nothing = "" + + mode filename = L.ParseMode + { L.parseFilename = filename + , L.extensions = exts + , L.ignoreLanguagePragmas = False + , L.ignoreLinePragmas = False + , L.fixities = Nothing + , L.baseLanguage = L.Haskell2010 } moduleFile :: L.Module L.SrcSpanInfo -> FilePath moduleFile (L.Module (L.SrcSpanInfo (L.SrcSpan file _ _ _ _) _) _ _ _ _) = file -moduleFile _ = error "Wtf is an XmlPage/XmlHybrid?" +-- these could be converted with sModule; see Language.Haskell.Exts.Simplify +moduleFile _ = error "Sorry, XmlPage/XmlHybrid modules are not supported" -data HotHasktags = HotHasktags { - hh_files, hh_language, hh_define, hh_include, hh_output, hh_cpphs :: [String] } - deriving (Data,Typeable,Show) +data TagsType = VimTags | EmacsTags deriving (Eq) -defaultHotHasktags :: HotHasktags -defaultHotHasktags = HotHasktags { - hh_files = [] - &= args - &= typ "FILE", - hh_language = [] - &= help "Additional language extensions to use when parsing a file. \ - \LANGUAGE pragmas are currently obeyed. Always includes at least \ - \MultiParamTypeClasses ExistentialQuantification \ - \and FlexibleContexts" - &= name "X", - hh_define = [] - &= name "D" - &= help "Define for cpphs. -Dx is a shortcut for the flags -c -Dx", - hh_include = [] - &= name "I" - &= typ "DIR" - &= help "Add a directory to where cpphs looks for .h includes. Note that \ - \paths are currently interpreted as relative to the directory \ - \containing the source file \ - \-Ifoo is a shortcut for -c -Ifoo", - hh_output = [] - &= name "output" &= name "O" - &= explicit - &= typ "FILE" - &= help "Name of output file. Default is to write to stdout", - hh_cpphs = [] - &= name "cpp" &= name "c" - &= explicit - &= help "Pass the next argument as an option for cpphs. For example:\n\ - \`hothasktags -c --strip -XCPP foo.hs'\ - \ see `cpphs --help`"} +data HotHasktags = HotHasktags + { hhLanguage, hhDefine, hhInclude, hhCpphs :: [String] + , hhOutput :: Maybe FilePath + , hhTagstype :: TagsType + , hhSplitOnNUL :: Bool + , hhFiles :: [FilePath] + } +optParser :: Parser HotHasktags +optParser = HotHasktags + <$> many (strOption + ( short 'X' + <> long "hh-language" + <> metavar "ITEM" + <> help "Additional language extensions to use when parsing a file. \ + \LANGUAGE pragmas are currently obeyed. Always includes at \ + \least MultiParamTypeClasses, ExistentialQuantification, \ + \and FlexibleContexts" )) + <*> many (strOption + ( short 'D' + <> long "hh-define" + <> metavar "ITEM" + <> help "Define for cpphs. -Dx is a shortcut for the flags -c -Dx" )) + <*> many (strOption + ( short 'I' + <> long "hh-include" + <> metavar "DIR" + <> help "Add a directory to where cpphs looks for .h includes. Note \ + \that paths are currently interpreted as relative to the \ + \directory containing the source file.\n\ + \-Ifoo is a shortcut for -c -Ifoo" )) + <*> many (strOption + ( short 'c' + <> long "cpp" + <> metavar "ITEM" + <> help "Pass the next argument as an option for cpphs. For example:\n\ + \`hothasktags -c --strip -XCPP foo.hs'" )) + <*> optional (strOption + ( short 'O' + <> long "output" + <> metavar "FILE" + <> help "Name of output file. Default is to write to stdout" )) + <*> flag VimTags EmacsTags + ( short 'e' + <> help "Emit Emacs tags" ) + <*> switch + ( short '0' + <> long "null" + <> help "Split stdin on NUL instead of newline" ) + <*> many (argument str (metavar "FILE")) + +linePositions :: Handle -> IO (Int, [(HandlePosition, String)]) +linePositions h = go 1 [] + where + go lineno acc = do + pos <- hTell h + ln <- hGetLine h + atEOF <- hIsEOF h + let res = (pos, ln):acc + if atEOF then return (lineno, reverse res) else go (lineno + 1) res + +emacsLineInfo :: [FilePath] -> IO LineInfo +emacsLineInfo files = do + filesContents <- forM files $ \f -> withFile f ReadMode linePositions + return $ Map.fromList + [(path, A.array (0, numLines - 1) (zip [0..] ls)) + | (path, (numLines, ls)) <- zip files filesContents] + +stdinFileList :: Bool -> IO [FilePath] +stdinFileList onNull = liftM splitter getContents + where + splitter = if onNull then endBy "\0" else lines + main :: IO () main = do - conf <- cmdArgs defaultHotHasktags - let exts = map L.classifyExtension $ hh_language conf ++ - words "MultiParamTypeClasses ExistentialQuantification FlexibleContexts" + let opts = info (helper <*> optParser) + ( fullDesc + <> progDesc "The hothasktags program" ) + conf <- execParser opts + let exts = map L.classifyExtension $ hhLanguage conf ++ + ["MultiParamTypeClasses", "ExistentialQuantification", + "FlexibleContexts"] case unwords [ ext | L.UnknownExtension ext <- exts ] of [] -> return () unknown -> hPutStrLn stderr $ "Unknown extensions on command line: " ++ unknown - database <- makeDatabase exts conf - let tags = sort $ concatMap (\mod -> makeTags (moduleFile mod) (moduleScope database mod)) (Map.elems database) - handle <- case (hh_output conf) of - [] -> return stdout - file:_ -> openFile file WriteMode + conf' <- case hhFiles conf of + [] -> liftM (\x -> conf { hhFiles = x }) + $ stdinFileList (hhSplitOnNUL conf) + _ -> return conf + lineInfo <- if hhTagstype conf' == EmacsTags + then emacsLineInfo $ hhFiles conf' + else return Map.empty + database <- makeDatabase exts conf' + let (fMakeTags, fSort) = if hhTagstype conf' == EmacsTags + then (makeEmacsTags, id) + else (makeVimTags, sort) + makeTags x = fMakeTags (moduleFile x) + (moduleScope database x) + lineInfo + ts <- do + ts <- mapM makeTags $ Map.elems database + return (fSort $ concat ts) - mapM_ (hPutStrLn handle) tags + handle <- case hhOutput conf' of + Nothing -> return stdout + Just file -> openFile file WriteMode - case (hh_output conf) of - [] -> return () - _ -> hClose handle + mapM_ (hPutStrLn handle) ts + + case hhOutput conf' of + Nothing -> return () + _ -> hClose handle diff --git a/hothasktags.cabal b/hothasktags.cabal --- a/hothasktags.cabal +++ b/hothasktags.cabal @@ -1,5 +1,5 @@ name: hothasktags -version: 0.3.3 +version: 0.3.4 cabal-version: >= 1.6 build-type: Simple author: Luke Palmer @@ -26,8 +26,6 @@ > find . | egrep '\.hs$' | xargs hothasktags > tags . will index all the hs files under the current directory. - . - hothasktags does not work with the emacs tag file format. Sorry. homepage: http://github.com/luqui/hothasktags source-repository head type: git @@ -35,10 +33,12 @@ executable hothasktags build-depends: base == 4.*, + array, containers, filepath, haskell-src-exts >= 1.14, cpphs >= 1.11 && < 1.20, - cmdargs + optparse-applicative, + split main-is: Main.hs ghc-options: -W