module Hasktags (
FileData,
generate,
findWithCache,
findThings,
findThingsInBS,
Mode(..),
getMode,
getOutFile,
dirToFiles
) where
import Tags
( FileData(..),
FoundThing(..),
FoundThingType(FTConsAccessor, FTFuncTypeDef, FTClass, FTType,
FTCons, FTNewtype, FTData, FTDataGADT, FTModule, FTFuncImpl),
Pos(..),
FileName,
mywords,
writectagsfile,
writeetagsfile )
import qualified Data.ByteString.Char8 as BS
( ByteString, unpack, readFile )
import qualified Data.ByteString.UTF8 as BS8 ( fromString )
import Data.Char ( isSpace )
import Data.List ( tails, nubBy, isSuffixOf, isPrefixOf )
import Data.Maybe ( maybeToList )
import System.IO
( IOMode(WriteMode, AppendMode),
Handle,
hGetContents,
stdout,
stdin,
openFile,
hClose )
import System.Directory
( getModificationTime,
getDirectoryContents,
doesFileExist,
doesDirectoryExist,
isSymbolicLink )
import Text.JSON.Generic ( encodeJSON, decodeJSON )
import Control.Monad ( when )
import DebugShow ( trace_ )
import System.FilePath ( (</>) )
getMode :: [Mode] -> Mode
getMode [] = BothTags
getMode xs = maximum xs
getOutFile :: String -> IOMode -> [Mode] -> IO Handle
getOutFile _ _ (OutRedir "-" : _) = return stdout
getOutFile _ openMode (OutRedir f : _) = openFile f openMode
getOutFile name openMode (_:xs) = getOutFile name openMode xs
getOutFile defaultName openMode [] = openFile
defaultName
openMode
data Mode = ExtendedCtag
| IgnoreCloseImpl
| ETags
| CTags
| BothTags
| Append
| OutRedir String
| CacheFiles
| FollowDirectorySymLinks
| Help
| HsSuffixes [String]
| AbsolutePath
deriving (Ord, Eq, Show)
data Token = Token String Pos
| NewLine Int
deriving (Eq)
instance Show Token where
show (Token t (Pos _ _l _ _) ) = " " ++ t ++ " "
show (NewLine i) = "NewLine " ++ show i
tokenString :: Token -> String
tokenString (Token s _) = s
tokenString (NewLine _) = "\n"
isNewLine :: Maybe Int -> Token -> Bool
isNewLine Nothing (NewLine _) = True
isNewLine (Just c) (NewLine c') = c == c'
isNewLine _ _ = False
trimNewlines :: [Token] -> [Token]
trimNewlines = filter (not . isNewLine Nothing)
generate :: [Mode] -> [FileName] -> IO ()
generate modes filenames = do
let mode = getMode (filter ( `elem` [BothTags, CTags, ETags] ) modes)
openFileMode = if Append `elem` modes
then AppendMode
else WriteMode
filedata <- mapM (findWithCache (CacheFiles `elem` modes)
(IgnoreCloseImpl `elem` modes))
filenames
when (mode == CTags)
(do ctagsfile <- getOutFile "tags" openFileMode modes
writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata
hClose ctagsfile)
when (mode == ETags)
(do etagsfile <- getOutFile "TAGS" openFileMode modes
writeetagsfile etagsfile filedata
hClose etagsfile)
when (mode == BothTags)
(do etagsfile <- getOutFile "TAGS" openFileMode modes
writeetagsfile etagsfile filedata
ctagsfile <- getOutFile "ctags" openFileMode modes
writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata
hClose etagsfile
hClose ctagsfile)
findWithCache :: Bool -> Bool -> FileName -> IO FileData
findWithCache cache ignoreCloseImpl filename = do
cacheExists <- if cache then doesFileExist cacheFilename else return False
if cacheExists
then do fileModified <- getModificationTime filename
cacheModified <- getModificationTime cacheFilename
if cacheModified > fileModified
then do bytes <- BS.readFile cacheFilename
return (decodeJSON (BS.unpack bytes))
else findAndCache
else findAndCache
where cacheFilename = filenameToTagsName filename
filenameToTagsName = (++"tags") . reverse . dropWhile (/='.') . reverse
findAndCache = do
filedata <- findThings ignoreCloseImpl filename
when cache (writeFile cacheFilename (encodeJSON filedata))
return filedata
utf8_to_char8_hack :: String -> String
utf8_to_char8_hack = BS.unpack . BS8.fromString
findThings :: Bool -> FileName -> IO FileData
findThings ignoreCloseImpl filename =
fmap (findThingsInBS ignoreCloseImpl filename) $ BS.readFile filename
findThingsInBS :: Bool -> String -> BS.ByteString -> FileData
findThingsInBS ignoreCloseImpl filename bs = do
let aslines = lines $ BS.unpack bs
let stripNonHaskellLines = let
emptyLine = all (all isSpace . tokenString)
. filter (not . isNewLine Nothing)
cppLine (_nl:t:_) = ("#" `isPrefixOf`) $ tokenString t
cppLine _ = False
in filter (not . emptyLine) . filter (not . cppLine)
let debugStep m = (\s -> trace_ (m ++ " result") s s)
let (isLiterate, slines) =
debugStep "fromLiterate"
$ fromLiterate filename
$ zip aslines [0..]
let
(fileLines, numbers)
= unzip slines
let tokenLines =
debugStep "stripNonHaskellLines" $ stripNonHaskellLines
$ debugStep "stripslcomments" $ stripslcomments
$ debugStep "splitByNL" $ splitByNL Nothing
$ debugStep "stripblockcomments pipe" $ stripblockcomments
$ concat
$ zipWith3 (withline filename)
(map
(filter (not . all isSpace) . mywords False)
fileLines)
fileLines
numbers
let topLevelIndent = debugStep "top level indent" $ getTopLevelIndent isLiterate tokenLines
let sections = map tail
$ filter (not . null)
$ splitByNL (Just (topLevelIndent) )
$ concat (trace_ "tokenLines" tokenLines tokenLines)
let filterAdjacentFuncImpl = nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _))
(FoundThing t2 n2 (Pos f2 _ _ _))
-> f1 == f2
&& n1 == n2
&& t1 == FTFuncImpl
&& t2 == FTFuncImpl )
let iCI = if ignoreCloseImpl
then nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _))
(FoundThing _ n2 (Pos f2 l2 _ _))
-> f1 == f2
&& n1 == n2
&& ((<= 7) $ abs $ l2 l1))
else id
let things = iCI $ filterAdjacentFuncImpl $ concatMap findstuff $ map (\s -> trace_ "section in findThingsInBS" s s) sections
let
uniqueModuleName (FoundThing FTModule moduleName _)
= not
$ any (\(FoundThing thingType thingName _)
-> thingType /= FTModule && thingName == moduleName) things
uniqueModuleName _ = True
FileData filename $ filter uniqueModuleName things
withline :: FileName -> [String] -> String -> Int -> [Token]
withline filename sourceWords fullline i =
let countSpaces (' ':xs) = 1 + countSpaces xs
countSpaces ('\t':xs) = 8 + countSpaces xs
countSpaces _ = 0
in NewLine (countSpaces fullline)
: zipWith (\w t -> Token w (Pos filename i t fullline)) sourceWords [1 ..]
stripslcomments :: [[Token]] -> [[Token]]
stripslcomments = let f (NewLine _ : Token "--" _ : _) = False
f _ = True
in filter f
stripblockcomments :: [Token] -> [Token]
stripblockcomments (Token "{-" pos : xs) =
trace_ "{- found at " (show pos) $
afterblockcomend xs
stripblockcomments (x:xs) = x:stripblockcomments xs
stripblockcomments [] = []
afterblockcomend :: [Token] -> [Token]
afterblockcomend (t@(Token _ pos):xs)
| contains "-}" (tokenString t) =
trace_ "-} found at " (show pos) $
stripblockcomments xs
| otherwise = afterblockcomend xs
afterblockcomend [] = []
afterblockcomend (_:xs) = afterblockcomend xs
contains :: Eq a => [a] -> [a] -> Bool
contains sub = any (isPrefixOf sub) . tails
findstuff :: [Token] -> [FoundThing]
findstuff (Token "module" _ : Token name pos : _) =
trace_ "module" pos $
[FoundThing FTModule name pos]
findstuff tokens@(Token "data" _ : Token name pos : xs)
| any ( (== "where"). tokenString ) xs
=
trace_ "findstuff data b1" tokens $
FoundThing FTDataGADT name pos
: getcons2 xs ++ fromWhereOn xs
| otherwise
=
trace_ "findstuff data otherwise" tokens $
FoundThing FTData name pos
: getcons FTData (trimNewlines xs)
findstuff tokens@(Token "newtype" _ : ts@(Token name pos : _)) =
trace_ "findstuff newtype" tokens $
FoundThing FTNewtype name pos
: getcons FTCons (trimNewlines ts)
findstuff tokens@(Token "type" _ : Token name pos : xs) =
trace_ "findstuff type" tokens $
FoundThing FTType name pos : findstuff xs
findstuff tokens@(Token "class" _ : xs) =
trace_ "findstuff class" tokens $
case (break ((== "where").tokenString) xs) of
(ys, []) ->
trace_ "findstuff class b1 " ys $
maybeToList $ className ys
(ys, r) ->
trace_ "findstuff class b2 " (ys, r) $
(maybeToList $ className ys)
++ (maybe [] (:fromWhereOn r) $ className xs)
where isParenOpen (Token "(" _) = True
isParenOpen _ = False
className lst
= case (head
. dropWhile isParenOpen
. reverse
. takeWhile ((not . (`elem` ["=>", utf8_to_char8_hack "⇒"])) . tokenString)
. reverse) lst of
(Token name p) -> Just $ FoundThing FTClass name p
_ -> Nothing
findstuff xs =
trace_ "findstuff rest " xs $
findFunc xs ++ findFuncTypeDefs [] xs
findFuncTypeDefs :: [Token] -> [Token] -> [FoundThing]
findFuncTypeDefs found (t@(Token _ _): Token "," _ :xs) =
findFuncTypeDefs (t : found) xs
findFuncTypeDefs found (t@(Token _ _): Token "::" _ :_) =
map (\(Token name p) -> FoundThing FTFuncTypeDef name p) (t:found)
findFuncTypeDefs found (Token "(" _ :xs) =
case break myBreakF xs of
(inner@(Token _ p : _), _:xs') ->
let merged = Token ( concatMap (\(Token x _) -> x) inner ) p
in findFuncTypeDefs found $ merged : xs'
_ -> []
where myBreakF (Token ")" _) = True
myBreakF _ = False
findFuncTypeDefs _ _ = []
fromWhereOn :: [Token] -> [FoundThing]
fromWhereOn [] = []
fromWhereOn [_] = []
fromWhereOn (_: xs@(NewLine _ : _)) =
concatMap (findstuff . tail')
$ splitByNL (Just ( minimum
. (10000:)
. map (\(NewLine i) -> i)
. filter (isNewLine Nothing) $ xs)) xs
fromWhereOn (_:xw) = findstuff xw
findFunc :: [Token] -> [FoundThing]
findFunc x = case findInfix x of
a@(_:_) -> a
_ -> findF x
findInfix :: [Token] -> [FoundThing]
findInfix x
= case dropWhile
((/= "`"). tokenString)
(takeWhile ( (/= "=") . tokenString) x) of
_ : Token name p : _ -> [FoundThing FTFuncImpl name p]
_ -> []
findF :: [Token] -> [FoundThing]
findF (Token name p : xs) =
[FoundThing FTFuncImpl name p | any (("=" ==) . tokenString) xs]
findF _ = []
tail' :: [a] -> [a]
tail' (_:xs) = xs
tail' [] = []
getcons :: FoundThingType -> [Token] -> [FoundThing]
getcons ftt (Token "=" _: Token name pos : xs) =
FoundThing ftt name pos : getcons2 xs
getcons ftt (_:xs) = getcons ftt xs
getcons _ [] = []
getcons2 :: [Token] -> [FoundThing]
getcons2 (Token name pos : Token "::" _ : xs) =
FoundThing FTConsAccessor name pos : getcons2 xs
getcons2 (Token "|" _ : Token name pos : xs) =
FoundThing FTCons name pos : getcons2 xs
getcons2 (_:xs) = getcons2 xs
getcons2 [] = []
splitByNL :: Maybe Int -> [Token] -> [[Token]]
splitByNL maybeIndent (nl@(NewLine _):ts) =
let (a,b) = break (isNewLine maybeIndent) ts
in (nl : a) : splitByNL maybeIndent b
splitByNL _ _ = []
getTopLevelIndent :: Bool -> [[Token]] -> Int
getTopLevelIndent _ [] = 0
getTopLevelIndent isLiterate ((nl:next:_):xs) = if "import" == (tokenString next)
then let (NewLine i) = nl in i
else getTopLevelIndent isLiterate xs
getTopLevelIndent isLiterate (_:xs) = getTopLevelIndent isLiterate xs
fromLiterate :: FilePath -> [(String, Int)]
-> (Bool
, [(String, Int)])
fromLiterate file lns =
if ".lhs" `isSuffixOf` file
then (True, unlit lns)
else (False, lns)
where unlit, returnCode :: [(String, Int)] -> [(String, Int)]
unlit ((('>':' ':xs),n):ns) = ((' ':xs),n):unlit(ns)
unlit ((line,_):ns) = if "\\begin{code}" `isPrefixOf` line then returnCode ns else unlit ns
unlit [] = []
returnCode (t@(line,_):ns) = if "\\end{code}" `isPrefixOf` line then unlit ns else t:(returnCode ns)
returnCode [] = []
dirToFiles :: Bool -> [String] -> FilePath -> IO [ FilePath ]
dirToFiles _ _ "STDIN" = fmap lines $ hGetContents stdin
dirToFiles followSyms suffixes p = do
isD <- doesDirectoryExist p
isSymLink <- isSymbolicLink p
case isD of
False -> return $ if matchingSuffix then [p] else []
True ->
if isSymLink && not followSyms
then return []
else do
contents <- filter ((/=) '.' . head) `fmap` getDirectoryContents p
concat `fmap` (mapM (dirToFiles followSyms suffixes . (</>) p) contents)
where matchingSuffix = any (`isSuffixOf` p) suffixes