module Tags where
import Data.Char ( isSpace )
import Data.List ( sortBy )
import Data.Data ( Data, Typeable )
import System.IO ( Handle, hPutStrLn, hPutStr )
import Control.Monad ( when )
mywords :: Bool -> String -> [String]
mywords spaced s = case rest of
')':xs -> (blanks' ++ ")") : mywords spaced xs
"" -> []
'{':'-':xs -> (blanks' ++ "{-") : mywords spaced xs
'-':'}':xs -> (blanks' ++ "-}") : mywords spaced xs
'{':xs -> (blanks' ++ "{") : mywords spaced xs
'(':xs -> (blanks' ++ "(") : mywords spaced xs
'`':xs -> (blanks' ++ "`") : mywords spaced xs
'=':'>':xs -> (blanks' ++ "=>") : mywords spaced xs
'=':xs -> (blanks' ++ "=") : mywords spaced xs
',':xs -> (blanks' ++ ",") : mywords spaced xs
':':':':xs -> (blanks' ++ "::") : mywords spaced xs
s' -> (blanks' ++ w) : mywords spaced s''
where (w, s'') = myBreak s'
myBreak [] = ([],[])
myBreak (':':':':xs) = ([], "::"++xs)
myBreak (')':xs) = ([],')':xs)
myBreak ('(':xs) = ([],'(':xs)
myBreak ('`':xs) = ([],'`':xs)
myBreak ('=':xs) = ([],'=':xs)
myBreak (',':xs) = ([],',':xs)
myBreak xss@(x:xs)
| isSpace x
= if spaced
then ([], xss)
else ([], dropWhile isSpace xss)
| otherwise = let (a,b) = myBreak xs
in (x:a,b)
where blanks' = if spaced then blanks else ""
(blanks, rest) = span isSpace s
type FileName = String
type ThingName = String
data Pos = Pos
FileName
Int
Int
String
deriving (Show,Eq,Typeable,Data)
data FoundThingType
= FTFuncTypeDef
| FTFuncImpl
| FTType
| FTData
| FTDataGADT
| FTNewtype
| FTClass
| FTModule
| FTCons
| FTOther
| FTConsAccessor
| FTConsGADT
deriving (Eq,Typeable,Data)
instance Show FoundThingType where
show FTFuncTypeDef = "ft"
show FTFuncImpl = "fi"
show FTType = "t"
show FTData = "d"
show FTDataGADT = "d_gadt"
show FTNewtype = "nt"
show FTClass = "c"
show FTModule = "m"
show FTCons = "cons"
show FTConsGADT = "c_gadt"
show FTConsAccessor = "c_a"
show FTOther = "o"
data FoundThing = FoundThing FoundThingType ThingName Pos
deriving (Show,Eq,Typeable,Data)
data FileData = FileData FileName [FoundThing]
deriving (Typeable,Data,Show)
getfoundthings :: FileData -> [FoundThing]
getfoundthings (FileData _ things) = things
ctagEncode :: Char -> String
ctagEncode '/' = "\\/"
ctagEncode '\\' = "\\\\"
ctagEncode a = [a]
dumpthing :: Bool -> FoundThing -> String
dumpthing False (FoundThing _ name (Pos filename line _ _)) =
name ++ "\t" ++ filename ++ "\t" ++ show (line + 1)
dumpthing True (FoundThing kind name (Pos filename line _ lineText)) =
name ++ "\t" ++ filename
++ "\t/^" ++ concatMap ctagEncode lineText
++ "$/;\"\t" ++ show kind
++ "\tline:" ++ show (line + 1)
++ "\tlanguage:Haskell"
writectagsfile :: Handle -> Bool -> [FileData] -> IO ()
writectagsfile ctagsfile extended filedata = do
let things = concatMap getfoundthings filedata
when extended
(do hPutStrLn
ctagsfile
$ "!_TAG_FILE_FORMAT\t2\t/extended format; --format=1 will not "
++ "append ;\" to lines/"
hPutStrLn
ctagsfile
"!_TAG_FILE_SORTED\t1\t/0=unsorted, 1=sorted, 2=foldcase/"
hPutStrLn ctagsfile "!_TAG_PROGRAM_NAME\thasktags")
mapM_ (hPutStrLn ctagsfile . dumpthing extended) (sortThings things)
sortThings :: [FoundThing] -> [FoundThing]
sortThings = sortBy comp
where
comp (FoundThing _ a (Pos f1 l1 _ _)) (FoundThing _ b (Pos f2 l2 _ _)) =
c (c (compare a b) (compare f1 f2)) (compare l1 l2)
c a b = if a == EQ then b else a
writeetagsfile :: Handle -> [FileData] -> IO ()
writeetagsfile etagsfile = mapM_ (hPutStr etagsfile . etagsDumpFileData)
etagsDumpFileData :: FileData -> String
etagsDumpFileData (FileData filename things) =
"\x0c\n" ++ filename ++ "," ++ show thingslength ++ "\n" ++ thingsdump
where thingsdump = concatMap etagsDumpThing things
thingslength = length thingsdump
etagsDumpThing :: FoundThing -> String
etagsDumpThing (FoundThing _ name (Pos _filename line token fullline)) =
let wrds = mywords True fullline
in concat (take token wrds ++ map (take 1) (take 1 $ drop token wrds))
++ "\x7f"
++ name ++ "\x01"
++ show line ++ "," ++ show (line + 1) ++ "\n"