{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
module Tags where
import Control.Monad (when)
import Data.Char (isSpace)
import Data.Data (Data, Typeable)
import Data.List (sortBy)
import Data.List (intercalate)
import Lens.Micro.Platform
import System.IO (Handle, hPutStr, hPutStrLn)
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
type Scope = Maybe (FoundThingType, String)
data Pos = Pos { _fileName :: FileName
, _lineNumber :: Int
, _tokenNumber :: Int
, _lineContent :: String
}
deriving (Show,Eq,Typeable,Data)
data FoundThingType
= FTFuncTypeDef String Scope
| FTFuncImpl Scope
| FTType
| FTData
| FTDataGADT
| FTNewtype
| FTClass
| FTInstance
| FTModule
| FTCons FoundThingType String
| FTOther
| FTConsAccessor FoundThingType String String
| FTConsGADT String
| FTPatternTypeDef String
| FTPattern
deriving (Eq,Typeable,Data)
instance Show FoundThingType where
show (FTFuncTypeDef s (Just (FTClass, p))) =
"ft\t" ++ "signature:(" ++ s ++ ")\t" ++ "class:" ++ p
show (FTFuncTypeDef s (Just (FTInstance, p))) =
"ft\t" ++ "signature:(" ++ s ++ ")\t" ++ "instance:" ++ p
show (FTFuncTypeDef s _) = "ft\t" ++ "signature:(" ++ s ++ ")"
show (FTFuncImpl (Just (FTClass, p)))= "fi\t" ++ "class:" ++ p
show (FTFuncImpl (Just (FTInstance, p)))= "fi\t" ++ "instance:" ++ p
show (FTFuncImpl _)= "fi"
show FTType = "t"
show FTData = "d"
show FTDataGADT = "d_gadt"
show FTNewtype = "nt"
show FTClass = "c"
show FTInstance = "i"
show FTModule = "m"
show (FTCons FTData p) = "cons\t" ++ "data:" ++ p
show (FTCons FTNewtype p) = "cons\t" ++ "newtype:" ++ p
show FTCons {} = "cons"
show (FTConsGADT p) = "c_gadt\t" ++ "d_gadt:" ++ p
show (FTConsAccessor FTData p c) = "c_a\t" ++ "cons:" ++ p ++ "." ++ c
show (FTConsAccessor FTNewtype p c) = "c_a\t" ++ "cons:" ++ p ++ "." ++ c
show FTConsAccessor {} = "c_a"
show (FTPatternTypeDef s) = "pt\t" ++ "signature:(" ++ s ++ ")"
show FTPattern = "pi"
show FTOther = "o"
data FoundThing = FoundThing FoundThingType ThingName Pos
deriving (Show,Eq,Typeable,Data)
data FileData = FileData FileName [FoundThing]
deriving (Typeable,Data,Show)
makeLenses ''Pos
getfoundthings :: FileData -> [FoundThing]
getfoundthings (FileData _ things) = things
ctagEncode :: Char -> String
ctagEncode '/' = "\\/"
ctagEncode '\\' = "\\\\"
ctagEncode a = [a]
showLine :: Pos -> String
showLine = show . view lineNumber . over lineNumber (+1)
normalDump :: FoundThing -> String
normalDump (FoundThing _ n p) = intercalate "\t" [n, p^.fileName, showLine p]
extendedDump :: FoundThing -> String
extendedDump (FoundThing t n p) = intercalate "\t" [n, p^.fileName, content, kindInfo, lineInfo, "language:Haskell"]
where content = "/^" ++ concatMap ctagEncode (p^.lineContent) ++ "$/;\""
kindInfo = show t
lineInfo = "line:" ++ showLine p
dumpThing :: Bool -> FoundThing -> String
dumpThing cond thing = if cond
then extendedDump thing
else normalDump thing
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) =
let line = pos^.lineNumber
token = pos^.tokenNumber
toks = mywords True (pos^.lineContent)
lineIdentifier = concat (take token toks ++ map (take 1) (take 1 $ drop token toks))
in concat [lineIdentifier, "\x7f", name, "\x01", show line, ",", show (line + 1), "\n"]