{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
-- Module      :  Yi.Tag
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- A module for CTags integration. Note that this reads the ‘tags’
-- file produced by @hasktags@, not the ‘TAGS’ file which uses a
-- different format (etags).

module Yi.Tag ( lookupTag
              , importTagTable
              , hintTags
              , completeTag
              , Tag(..)
              , unTag'
              , TagTable(..)
              , getTags
              , setTags
              , resetTags
              , tagsFileList
              , readCTags
              ) where

import           GHC.Generics (Generic)

import           Lens.Micro.Platform             (makeLenses)
import           Data.Binary            (Binary)
import qualified Data.ByteString        as BS (readFile)
import           Data.Default           (Default, def)
import qualified Data.Foldable          as F (concat)
import           Data.Map               (Map, fromListWith, keys, lookup)
import           Data.Maybe             (mapMaybe)
import qualified Data.Text              as T (Text, append, isPrefixOf, lines, unpack, words)
import qualified Data.Text.Encoding     as E (decodeUtf8)
import qualified Data.Text.Read         as R (decimal)
import qualified Yi.CompletionTree      as CT
import           System.FilePath        (takeDirectory, takeFileName, (</>))
import           System.FriendlyPath    (expandTilda)
import           Yi.Config.Simple.Types (Field, customVariable)
import           Yi.Editor              (EditorM, getEditorDyn, putEditorDyn)
import           Yi.Types               (YiConfigVariable, YiVariable)

newtype TagsFileList  = TagsFileList { TagsFileList -> [FilePath]
_unTagsFileList :: [FilePath] }

instance Default TagsFileList where
    def :: TagsFileList
def = [FilePath] -> TagsFileList
TagsFileList [FilePath
"tags"]

instance YiConfigVariable TagsFileList

makeLenses ''TagsFileList

tagsFileList :: Field [FilePath]
tagsFileList :: ([FilePath] -> f [FilePath]) -> Config -> f Config
tagsFileList = (TagsFileList -> f TagsFileList) -> Config -> f Config
forall a. YiConfigVariable a => Field a
customVariable ((TagsFileList -> f TagsFileList) -> Config -> f Config)
-> (([FilePath] -> f [FilePath]) -> TagsFileList -> f TagsFileList)
-> ([FilePath] -> f [FilePath])
-> Config
-> f Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath] -> f [FilePath]) -> TagsFileList -> f TagsFileList
Lens' TagsFileList [FilePath]
unTagsFileList

newtype Tags = Tags (Maybe TagTable) deriving (Get Tags
[Tags] -> Put
Tags -> Put
(Tags -> Put) -> Get Tags -> ([Tags] -> Put) -> Binary Tags
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Tags] -> Put
$cputList :: [Tags] -> Put
get :: Get Tags
$cget :: Get Tags
put :: Tags -> Put
$cput :: Tags -> Put
Binary)

instance Default Tags where
    def :: Tags
def = Maybe TagTable -> Tags
Tags Maybe TagTable
forall a. Maybe a
Nothing

instance YiVariable Tags

newtype Tag = Tag { Tag -> Text
_unTag :: T.Text } deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> FilePath
(Int -> Tag -> ShowS)
-> (Tag -> FilePath) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> FilePath
$cshow :: Tag -> FilePath
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Eq Tag
Eq Tag
-> (Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord, Get Tag
[Tag] -> Put
Tag -> Put
(Tag -> Put) -> Get Tag -> ([Tag] -> Put) -> Binary Tag
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Tag] -> Put
$cputList :: [Tag] -> Put
get :: Get Tag
$cget :: Get Tag
put :: Tag -> Put
$cput :: Tag -> Put
Binary)

unTag' :: Tag -> T.Text
unTag' :: Tag -> Text
unTag' =  Tag -> Text
_unTag

data TagTable = TagTable
    { TagTable -> FilePath
tagFileName :: FilePath
    -- ^ local name of the tag file
    -- TODO: reload if this file is changed
    , TagTable -> FilePath
tagBaseDir :: FilePath
    -- ^ path to the tag file directory
    -- tags are relative to this path
    , TagTable -> Map Tag [(FilePath, Int)]
tagFileMap :: Map Tag [(FilePath, Int)]
    -- ^ map from tags to files
    , TagTable -> CompletionTree Text
tagCompletionTree :: CT.CompletionTree T.Text
    -- ^ trie to speed up tag hinting
    } deriving ((forall x. TagTable -> Rep TagTable x)
-> (forall x. Rep TagTable x -> TagTable) -> Generic TagTable
forall x. Rep TagTable x -> TagTable
forall x. TagTable -> Rep TagTable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TagTable x -> TagTable
$cfrom :: forall x. TagTable -> Rep TagTable x
Generic)

-- | Find the location of a tag using the tag table.
-- Returns a full path and line number
lookupTag :: Tag -> TagTable -> [(FilePath, Int)]
lookupTag :: Tag -> TagTable -> [(FilePath, Int)]
lookupTag Tag
tag TagTable
tagTable = do
  (FilePath
file, Int
line) <- Maybe [(FilePath, Int)] -> [(FilePath, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
F.concat (Maybe [(FilePath, Int)] -> [(FilePath, Int)])
-> (Map Tag [(FilePath, Int)] -> Maybe [(FilePath, Int)])
-> Map Tag [(FilePath, Int)]
-> [(FilePath, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Map Tag [(FilePath, Int)] -> Maybe [(FilePath, Int)]
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup Tag
tag (Map Tag [(FilePath, Int)] -> [(FilePath, Int)])
-> Map Tag [(FilePath, Int)] -> [(FilePath, Int)]
forall a b. (a -> b) -> a -> b
$ TagTable -> Map Tag [(FilePath, Int)]
tagFileMap TagTable
tagTable
  (FilePath, Int) -> [(FilePath, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return (TagTable -> FilePath
tagBaseDir TagTable
tagTable FilePath -> ShowS
</> FilePath
file, Int
line)

-- | Super simple parsing CTag format 1 parsing algorithm
-- TODO: support search patterns in addition to lineno
readCTags :: T.Text -> Map Tag [(FilePath, Int)]
readCTags :: Text -> Map Tag [(FilePath, Int)]
readCTags =
    ([(FilePath, Int)] -> [(FilePath, Int)] -> [(FilePath, Int)])
-> [(Tag, [(FilePath, Int)])] -> Map Tag [(FilePath, Int)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [(FilePath, Int)] -> [(FilePath, Int)] -> [(FilePath, Int)]
forall a. [a] -> [a] -> [a]
(++) ([(Tag, [(FilePath, Int)])] -> Map Tag [(FilePath, Int)])
-> (Text -> [(Tag, [(FilePath, Int)])])
-> Text
-> Map Tag [(FilePath, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Tag, [(FilePath, Int)]))
-> [Text] -> [(Tag, [(FilePath, Int)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> Maybe (Tag, [(FilePath, Int)])
forall b. Integral b => [Text] -> Maybe (Tag, [(FilePath, b)])
parseTagLine ([Text] -> Maybe (Tag, [(FilePath, Int)]))
-> (Text -> [Text]) -> Text -> Maybe (Tag, [(FilePath, Int)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) ([Text] -> [(Tag, [(FilePath, Int)])])
-> (Text -> [Text]) -> Text -> [(Tag, [(FilePath, Int)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
    where parseTagLine :: [Text] -> Maybe (Tag, [(FilePath, b)])
parseTagLine (Text
tag:Text
tagfile:Text
lineno:[Text]
_) =
              -- remove ctag control lines
              if Text
"!_TAG_" Text -> Text -> Bool
`T.isPrefixOf` Text
tag then Maybe (Tag, [(FilePath, b)])
forall a. Maybe a
Nothing
              else (Tag, [(FilePath, b)]) -> Maybe (Tag, [(FilePath, b)])
forall a. a -> Maybe a
Just (Text -> Tag
Tag Text
tag, [(Text -> FilePath
T.unpack Text
tagfile, Text -> b
getLineNumber Text
lineno)])
              where getLineNumber :: Text -> b
getLineNumber = (\(Right b
x) -> b
x) (Either FilePath b -> b)
-> (Text -> Either FilePath b) -> Text -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, Text) -> b) -> Either FilePath (b, Text) -> Either FilePath b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, Text) -> b
forall a b. (a, b) -> a
fst (Either FilePath (b, Text) -> Either FilePath b)
-> (Text -> Either FilePath (b, Text)) -> Text -> Either FilePath b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either FilePath (b, Text)
forall a. Integral a => Reader a
R.decimal
          parseTagLine [Text]
_ = Maybe (Tag, [(FilePath, b)])
forall a. Maybe a
Nothing

-- | Read in a tag file from the system
importTagTable :: FilePath -> IO TagTable
importTagTable :: FilePath -> IO TagTable
importTagTable FilePath
filename = do
  FilePath
friendlyName <-  FilePath -> IO FilePath
expandTilda FilePath
filename
  Text
tagStr <- ByteString -> Text
E.decodeUtf8 (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
friendlyName
  let cts :: Map Tag [(FilePath, Int)]
cts = Text -> Map Tag [(FilePath, Int)]
readCTags Text
tagStr
  TagTable -> IO TagTable
forall (m :: * -> *) a. Monad m => a -> m a
return TagTable :: FilePath
-> FilePath
-> Map Tag [(FilePath, Int)]
-> CompletionTree Text
-> TagTable
TagTable { tagFileName :: FilePath
tagFileName = ShowS
takeFileName FilePath
filename
                  , tagBaseDir :: FilePath
tagBaseDir  = ShowS
takeDirectory FilePath
filename
                  , tagFileMap :: Map Tag [(FilePath, Int)]
tagFileMap  = Map Tag [(FilePath, Int)]
cts
                  , tagCompletionTree :: CompletionTree Text
tagCompletionTree = [Text] -> CompletionTree Text
forall a i. (Ord a, ListLike a i, Eq i) => [a] -> CompletionTree a
CT.fromList ([Text] -> CompletionTree Text)
-> ([Tag] -> [Text]) -> [Tag] -> CompletionTree Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag -> Text) -> [Tag] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Tag -> Text
_unTag) ([Tag] -> CompletionTree Text) -> [Tag] -> CompletionTree Text
forall a b. (a -> b) -> a -> b
$ Map Tag [(FilePath, Int)] -> [Tag]
forall k a. Map k a -> [k]
keys Map Tag [(FilePath, Int)]
cts
                  }

-- | Gives all the possible expanded tags that could match a given @prefix@
hintTags :: TagTable -> T.Text -> [T.Text]
hintTags :: TagTable -> Text -> [Text]
hintTags TagTable
tags Text
prefix = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
prefix Text -> Text -> Text
`T.append`) [Text]
sufs
  where
    sufs :: [T.Text]
    sufs :: [Text]
sufs = CompletionTree Text -> [Text]
forall a i. (Ord a, ListLike a i) => CompletionTree a -> [a]
CT.toList (CompletionTree Text -> Text -> CompletionTree Text
forall a i.
(Ord a, ListLike a i, Eq i) =>
CompletionTree a -> a -> CompletionTree a
CT.update (TagTable -> CompletionTree Text
tagCompletionTree TagTable
tags) Text
prefix)

-- | Extends the string to the longest certain length
completeTag :: TagTable -> T.Text -> T.Text
completeTag :: TagTable -> Text -> Text
completeTag TagTable
tags Text
prefix =
  Text
prefix Text -> Text -> Text
`T.append` (Text, CompletionTree Text) -> Text
forall a b. (a, b) -> a
fst (CompletionTree Text -> (Text, CompletionTree Text)
forall i a.
(Eq i, Ord a, ListLike a i) =>
CompletionTree a -> (a, CompletionTree a)
CT.complete (CompletionTree Text -> Text -> CompletionTree Text
forall a i.
(Ord a, ListLike a i, Eq i) =>
CompletionTree a -> a -> CompletionTree a
CT.update (TagTable -> CompletionTree Text
tagCompletionTree TagTable
tags) Text
prefix))


-- ---------------------------------------------------------------------
-- Direct access interface to TagTable.

-- | Set a new TagTable
setTags :: TagTable -> EditorM ()
setTags :: TagTable -> EditorM ()
setTags = Tags -> EditorM ()
forall (m :: * -> *) a.
(MonadEditor m, YiVariable a, Functor m) =>
a -> m ()
putEditorDyn (Tags -> EditorM ())
-> (TagTable -> Tags) -> TagTable -> EditorM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TagTable -> Tags
Tags (Maybe TagTable -> Tags)
-> (TagTable -> Maybe TagTable) -> TagTable -> Tags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagTable -> Maybe TagTable
forall a. a -> Maybe a
Just

-- | Reset the TagTable
resetTags :: EditorM ()
resetTags :: EditorM ()
resetTags = Tags -> EditorM ()
forall (m :: * -> *) a.
(MonadEditor m, YiVariable a, Functor m) =>
a -> m ()
putEditorDyn (Tags -> EditorM ()) -> Tags -> EditorM ()
forall a b. (a -> b) -> a -> b
$ Maybe TagTable -> Tags
Tags Maybe TagTable
forall a. Maybe a
Nothing

-- | Get the currently registered tag table
getTags :: EditorM (Maybe TagTable)
getTags :: EditorM (Maybe TagTable)
getTags = do
  Tags Maybe TagTable
t <- EditorM Tags
forall (m :: * -> *) a.
(MonadEditor m, YiVariable a, Default a, Functor m) =>
m a
getEditorDyn
  Maybe TagTable -> EditorM (Maybe TagTable)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TagTable
t

instance Binary TagTable