ghc-tags-plugin 0.1.5.0 → 0.1.6.0
raw patch · 21 files changed
+613/−1872 lines, 21 filesdep +ghc-tags-coredep +mtldep +optparse-applicativedep −QuickCheckdep −attoparsecdep −filelockdep ~directorydep ~filepathdep ~textsetup-changednew-component:exe:gtp-check
Dependencies added: ghc-tags-core, mtl, optparse-applicative, pipes, pipes-attoparsec, pipes-bytestring, pipes-safe, pipes-text
Dependencies removed: QuickCheck, attoparsec, filelock, lattices, quickcheck-instances, tasty, tasty-golden, tasty-quickcheck
Dependency ranges changed: directory, filepath, text
Files
- CHANGELOG.md +9/−0
- Makefile +0/−31
- README.md +49/−23
- Setup.hs +0/−2
- app/check.hs +26/−0
- ghc-tags-plugin.cabal +44/−55
- lib/Plugin/GhcTags.hs +340/−0
- lib/Plugin/GhcTags/CTag.hs +49/−0
- lib/Plugin/GhcTags/FileLock.hs +22/−0
- lib/Plugin/GhcTags/Generate.hs +0/−626
- lib/Plugin/GhcTags/Options.hs +74/−0
- lib/Plugin/GhcTags/Tag.hs +0/−159
- lib/Plugin/GhcTags/Vim.hs +0/−6
- lib/Plugin/GhcTags/Vim/Formatter.hs +0/−81
- lib/Plugin/GhcTags/Vim/Parser.hs +0/−160
- src/Plugin/GhcTags.hs +0/−183
- test/Main.hs +0/−19
- test/Test/Golden/Parser.hs +0/−79
- test/Test/Tag.hs +0/−246
- test/Test/Tag/Generators.hs +0/−137
- test/Test/Vim.hs +0/−65
CHANGELOG.md view
@@ -32,3 +32,12 @@ ## 0.1.5.0 -- 2020-03-13 * concurrency safety - protection `tags` file using a file lock++## 0.1.6.0 -- 2020-03-24++* support for etags files+* various bug fixes+* type level information (not type checked!), from the parsed tree, including:+ type of instances (instance context & instance head), types of `GADTs`+ constructors, rhs of type synonyms, kinds of type or data families.+* expanded ctags pseudo tags with descriptions of fields and tag kinds
− Makefile
@@ -1,31 +0,0 @@-#-# install, uninstall and friends ghc-tags-plugin in cabal store-#--PACKAGE_DB = ${HOME}/.cabal/store/ghc-$(shell ghc --numeric-version)/package.db--uninstall:- ghc-pkg unregister \- --package-db=${PACKAGE_DB} \- --force \- z-ghc-tags-plugin-z-ghc-tags-library \- ghc-tags-plugin--install:- cabal install --package-db=${PACKAGE_DB} --lib ghc-tags-plugin--reinstall: uninstall install--list:- ghc-pkg list --package-db=${PACKAGE_DB} | grep ghc-tags--latest:- ghc-pkg latest --package-db=${PACKAGE_DB} ghc-tags-plugin--recache:- ghc-pkg recache --package-db=${PACKAGE_DB}--check:- ghc-pkg check --package-db=${PACKAGE_DB} 2>&1 | grep ghc-tags--.PHONY: install, uninstall, reinstall, latest, check
README.md view
@@ -2,10 +2,11 @@ ========================  - --+[](https://github.com/coot/ghc-tags-plugin/actions)+[](https://github.com/coot/ghc-tags-plugin/actions)+[](https://github.com/coot/ghc-tags-plugin/actions)+[](https://matrix.hackage.haskell.org/#/package/ghc-tags-plugin) A [Ghc Compiler Plugin](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#compiler-plugins) which generates tags for each compiled module or component.@@ -18,23 +19,20 @@ ghc >= 8.6 ``` -● Vim configuration-------------------- -By default each generated tags file is put next to the corresponding `*.cabal`-package file. If you just have a repo with a cabal file in the main directory-`vim` default `tags` setting will work, if you have some modules in-subdirectories you will either need to set:-```-:set tags+=*/tags-```-or pass an option to modify where tags are written, see below.-- ● Plugin options ---------------- -The plugin accepts an only one option, which is a file path to the tags file.+```+Usage: <program> [-e|--etags] [file_path]+ write tags from ghc abstract syntax tree++Available options:+ -e,--etags produce emacs etags file+ file_path tags file: default tags or TAGS (when --etags is+ specified)+```+ It can be an absolute path or relative (to the `*.cabal` package file rather than `cabal.project` file), for example: ```@@ -42,7 +40,24 @@ ``` This is useful if for *cabal packages* which are located in subdirectories. +## ● Emacs support +To produce `etags` file you will need to pass the follwing option+```+-fplugin-opt=Plugin.GhcTags:--etags+```++## ● Editor configuration++By default each generated tags file is put next to the corresponding `*.cabal`+package file. If you just have a repo with a cabal file in the main directory+`vim` default `tags` setting will work, if you have some modules in+subdirectories you will either need to set:+```+:set tags+=*/tags+```+or pass an option to modify where tags are written, see below.+ ● Configuration: Ghc / Cabal / Stack ------------------------------------ @@ -112,10 +127,6 @@ -fplugin=Plugin.GhcTags ``` -Check out an example-[here](https://github.com/coot/ghc-tags-plugin/tree/stack-setup/test-project).-- ## ● Ghcid If you follow the cabal configuration as above (using `stack` should work too)@@ -150,9 +161,24 @@ ● Tips ------ -- The plugin is safe for concurrent compilation. Setting `jobs: $ncpus` is- safe. The plugin holds an exclusive (advisory) lock on the `tags` file.- This will create synchronisation between threads / process which are using+- If you're getting installation problems when running+ `cabal install --lib ghc-tags-plugin`; you may need to++ * remove the installed version from+ `~/.ghc/x86_64-linux-8.6.5/environments/default`+ (or whatever is your default environment)++ * unregister the installeld version from cabal store (you can check what is+ installed in your store with `ghc-pkg --package=PACKAGE_DB list | grep ghc-tags`+ for the following command):++ ```+ ghc-pkg --package-db=PACKAGE_DB unregister z-ghc-tags-plugin-z-ghc-tags-library ghc-tags-plugin+ ```++- The plugin is safe for concurrent compilation, i.e. setting `jobs: $ncpus` is+ safe. The plugin holds an exclusive (advisory) lock on a lock file. This+ will create synchronisation between threads / process which are using the same `tags` file. - If you are working on a larger project, it might be better to not collect all
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ app/check.hs view
@@ -0,0 +1,26 @@+-- | Utility program which checks the size of tags file.+--+-- It's a like `wc` but using `lock` file, so we don't get intermediate+-- results.+--+module Main where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import System.FilePath+import System.IO+import System.Environment+import GHC.IO.Handle++import Plugin.GhcTags.FileLock+++main :: IO ()+main = do+ file :_ <- getArgs+ withFileLock (lockFile file) ExclusiveLock ReadWriteMode $ \_h -> do+ numOfLines <- length . BSC.lines <$> BS.readFile file+ putStrLn (show numOfLines)+ where+ lockFile file = case splitFileName file of+ (dir, name) -> dir </> "." ++ name ++ ".lock"
ghc-tags-plugin.cabal view
@@ -1,85 +1,74 @@ cabal-version: 2.4 name: ghc-tags-plugin-version: 0.1.5.0-synopsis: A compiler plugin which generates tags file from GHC syntax tree.+version: 0.1.6.0+synopsis: A compiler plugin which generates tags file from GHC parsed syntax tree. description:- A compiler source plugin which takes parsed Haskell syntax tree and saves- tags file to disk, leaving the parsed tree untouched.+ A [GHC compiler plugin](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/extending_ghc.html?highlight=compiler%20plugin#compiler-plugins)+ which takes parsed Haskell representation @HsModule GhcPs@,+ extracts __tags__ information and saves it either in __ctags__ or+ __etags__ format. license: MPL-2.0 license-file: LICENSE author: Marcin Szamotulski maintainer: profunctor@pm.me copyright: (c) 2020, Marcin Szamotulski category: Development+stability: alpha extra-source-files: CHANGELOG.md README.md- Makefile homepage: https://github.com/coot/ghc-tags-plugin#readme bug-reports: https://github.com/coot/ghc-tags-plugin/issues tested-with: GHC==8.6.3, GHC==8.8.3 +-- Don't build gtp-check command by default; it's a development tool.+flag gtp-check+ default: False+ manual: False source-repository head type: git location: https://github.com/coot/ghc-tags-plugin - library- hs-source-dirs: src- exposed-modules: Plugin.GhcTags- build-depends: base >=4.12.0.0 && <4.14,- bytestring ^>=0.10,- directory ^>=1.3,- filelock ^>=0.1.1,- filepath ^>=1.4,- ghc >=8.4 && <8.9,- text ^>=1.2,-- ghc-tags-library-- default-language: Haskell2010- ghc-options: -Wall---library ghc-tags-library hs-source-dirs: lib- exposed-modules: Plugin.GhcTags.Generate- Plugin.GhcTags.Tag- Plugin.GhcTags.Vim- Plugin.GhcTags.Vim.Parser- Plugin.GhcTags.Vim.Formatter+ exposed-modules: Plugin.GhcTags+ Plugin.GhcTags.Options+ Plugin.GhcTags.FileLock+ other-modules: Plugin.GhcTags.CTag Paths_ghc_tags_plugin autogen-modules: Paths_ghc_tags_plugin- build-depends: attoparsec ^>=0.13.0.0,- base >=4.12.0.0 && <4.14,- bytestring ^>=0.10,- directory ^>=1.3,- ghc >=8.4 && <8.9,- text ^>=1.2+ build-depends: base >=4.12.0.0 && <4.14,+ bytestring ^>=0.10,+ directory ^>=1.3,+ filepath ^>=1.4,+ ghc >=8.4 && <8.9,+ mtl ^>=2.2,+ optparse-applicative+ ^>=0.15.1,+ pipes ^>=4.3,+ pipes-attoparsec ^>=0.5,+ pipes-bytestring ^>=2.1,+ pipes-text >=0.0.2 && <0.0.3 ,+ pipes-safe ^>=2.3,+ text ^>=1.2, + ghc-tags-core+ default-language: Haskell2010 ghc-options: -Wall -test-suite ghc-tags-tests- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs- other-modules: Test.Golden.Parser- Test.Tag- Test.Tag.Generators- Test.Vim- default-language: Haskell2010 - build-depends: attoparsec,- base,- bytestring,- lattices,- QuickCheck,- quickcheck-instances,- tasty,- tasty-golden,- tasty-quickcheck,- text,+executable gtp-check+ if flag(gtp-check)+ buildable: True+ else+ buildable: False+ hs-source-dirs: app+ main-is: check.hs+ default-language: Haskell2010+ build-depends: base+ , bytestring+ , directory+ , filepath - ghc-tags-library- ghc-options: -Wall+ , ghc-tags-plugin
+ lib/Plugin/GhcTags.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Plugin.GhcTags ( plugin, Options (..) ) where++import Control.Exception+import Control.Monad.State.Strict+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Builder as BB+#if __GLASGOW_HASKELL__ < 808+import Data.Functor (void, (<$))+#endif+import Data.Functor.Identity (Identity (..))+import Data.List (sortBy)+import Data.Foldable (traverse_)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import System.Directory+import System.FilePath+import System.IO++import Options.Applicative.Types (ParserFailure (..))++import Pipes ((~>))+import qualified Pipes as Pipes+import Pipes.Safe (SafeT)+import qualified Pipes.Safe as Pipes.Safe+import qualified Pipes.ByteString as Pipes.BS+import qualified Pipes.Text.Encoding as Pipes.Text++import GhcPlugins ( CommandLineOption+ , DynFlags+ , Hsc+ , HsParsedModule (..)+ , Located+ , Module+ , ModSummary (..)+ , ModLocation (..)+ , Plugin (..)+ )+import qualified GhcPlugins+import HsExtension (GhcPs)+import HsSyn (HsModule (..))+import Outputable (($+$), ($$))+import qualified Outputable as Out+import qualified PprColour++import GhcTags.Ghc+import GhcTags.Tag+import GhcTags.Stream+import qualified GhcTags.CTag as CTag+import qualified GhcTags.ETag as ETag++import Plugin.GhcTags.Options+import Plugin.GhcTags.FileLock+import qualified Plugin.GhcTags.CTag as CTag+++-- | The GhcTags plugin. It will run for every compiled module and have access+-- to parsed syntax tree. It will inspect it and:+--+-- * update a global mutable state variable, which stores a tag map.+-- It is shared across modules compiled in the same `ghc` run.+-- * update 'tags' file.+--+-- The global mutable variable save us from parsing the tags file for every+-- compiled module.+--+-- __The syntax tree is left unchanged.__+-- +-- The tags file will contain location information about:+--+-- * /top level terms/+-- * /data types/+-- * /record fields/+-- * /type synonyms/+-- * /type classes/+-- * /type class members/+-- * /type class instances/+-- * /type families/ /(standalone and associated)/+-- * /type family instances/ /(standalone and associated)/+-- * /data type families/ /(standalone and associated)/+-- * /data type families instances/ /(standalone and associated)/+-- * /data type family instances constructors/ /(standalone and associated)/+--+plugin :: Plugin+plugin = GhcPlugins.defaultPlugin {+ parsedResultAction = ghcTagsPlugin,+ pluginRecompile = GhcPlugins.purePlugin+ }+++-- | IOExcption wrapper; it is useful for the user to know that it's the plugin+-- not `ghc` that thrown the error.+--+data GhcTagsPluginException =+ GhcTagsPluginIOExceptino IOException+ deriving Show++instance Exception GhcTagsPluginException+++-- | The plugin does not change the 'HsParedModule', it only runs side effects.+--+ghcTagsPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule+ghcTagsPlugin options moduleSummary hsParsedModule@HsParsedModule {hpm_module} =+ hsParsedModule <$+ case runOptionParser options of+ Success opts -> GhcPlugins.liftIO (updateTags opts moduleSummary hpm_module)++ Failure (ParserFailure f) -> GhcPlugins.liftIO $+ putDocLn (ms_hspp_opts moduleSummary)+ (messageDoc+ OptionParserFailure+ (ms_mod moduleSummary)+ (show $ case f "<ghc-tags-plugin>" of (h, _, _) -> h))++ CompletionInvoked {} -> error "ghc-tags-plugin: impossible happend"+++data ExceptionType =+ ReadException+ | ParserException+ | WriteException+ | UnhandledException+ | OptionParserFailure++instance Show ExceptionType where+ show ReadException = "read error"+ show ParserException = "tags parser error"+ show WriteException = "write error"+ show UnhandledException = "unhandled error"+ show OptionParserFailure = "plugin options parser error"++-- | Extract tags from a module and update tags file+--+updateTags :: Options Identity+ -> ModSummary+ -> Located (HsModule GhcPs)+ -> IO ()+updateTags Options { etags, filePath = Identity tagsFile }+ ModSummary {ms_mod, ms_location, ms_hspp_opts = dynFlags}+ lmodule =+ -- wrap 'IOException's+ handle (\ioerr -> do+ putDocLn dynFlags (messageDoc UnhandledException ms_mod (displayException ioerr))+ throwIO $ GhcTagsPluginIOExceptino ioerr) $+ flip finally (void $ try @IOException $ removeFile sourceFile) $+ -- Take advisory exclusive lock (a BSD lock using `flock`) on the tags+ -- file. This is needed when `cabal` compiles in parallel.+ -- We take the lock on the copy, otherwise the lock would be removed when+ -- we move the file.+ withFileLock lockFile ExclusiveLock WriteMode $ \_ -> do+ tagsFileExists <- doesFileExist tagsFile+ when tagsFileExists+ $ renameFile tagsFile sourceFile+ withFile tagsFile WriteMode $ \writeHandle ->+ withFile sourceFile ReadWriteMode $ \readHandle -> do+ cwd <- getCurrentDirectory+ -- absolute directory path of the tags file; we need canonical path+ -- (without ".." and ".") to make 'makeRelative' works.+ tagsDir <- canonicalizePath (fst $ splitFileName tagsFile)++ case (etags, ml_hs_file ms_location) of++ --+ -- ctags+ --+ (False, Nothing) -> pure ()+ (False, Just sourcePath) -> do++ let -- text parser+ producer :: Pipes.Producer Text (SafeT IO) ()+ producer+ | tagsFileExists =+ void (Pipes.Text.decodeUtf8+ (Pipes.BS.fromHandle readHandle))+ `Pipes.Safe.catchP` \(e :: IOException) ->+ Pipes.lift $ Pipes.liftIO $+ -- don't re-throw; this would kill `ghc`, error+ -- loudly and continue.+ putDocLn dynFlags (messageDoc ReadException ms_mod (displayException e))+ | otherwise = pure ()++ -- gags pipe+ pipe :: Pipes.Effect (StateT [CTag] (SafeT IO)) ()+ pipe =+ Pipes.for+ (Pipes.hoist Pipes.lift (tagParser (either (const Nothing) Just <$> CTag.parseTagLine) producer)+ `Pipes.Safe.catchP` \(e :: IOException) ->+ Pipes.lift $ Pipes.liftIO $+ -- don't re-throw; this would kill `ghc`, error+ -- loudly and continue.+ putDocLn dynFlags $ messageDoc ParserException ms_mod (displayException e)+ )+ $+ -- normalise paths+ (\tag -> Pipes.yield tag { tagFilePath = normalise (tagFilePath tag) })+ ~>+ -- merge tags+ (\tag ->+ runCombineTagsPipe writeHandle CTag.compareTags CTag.formatTag (fixFilePath cwd tagsDir sourcePath) tag+ `Pipes.Safe.catchP` \(e :: IOException) ->+ Pipes.lift $ Pipes.liftIO $+ -- don't re-throw; this would kill `ghc`, error+ -- loudly and continue.+ putDocLn dynFlags $ messageDoc WriteException ms_mod (displayException e)+ )++ let tags :: [CTag]+ tags = map (fixTagFilePath cwd tagsDir)+ -- fix file names+ . sortBy compareTags -- sort+ . mapMaybe (ghcTagToTag SingCTag dynFlags)+ -- translate 'GhcTag' to 'Tag'+ . getGhcTags -- generate 'GhcTag's+ $ lmodule++ -- Write header+ BSL.hPut writeHandle (BB.toLazyByteString (foldMap CTag.formatHeader CTag.headers))+ -- update tags file / run 'pipe'+ tags' <- Pipes.Safe.runSafeT $ execStateT ((Pipes.runEffect pipe)) tags+ -- write the remaining tags'+ traverse_ (BSL.hPut writeHandle . BB.toLazyByteString . CTag.formatTag) tags'++ --+ -- etags+ --+ (True, Nothing) -> pure ()+ (True, Just sourcePath) ->+ try @IOException (Text.decodeUtf8 <$> BS.hGetContents readHandle)+ >>= \case+ Left err ->+ putDocLn dynFlags $ messageDoc ReadException ms_mod (displayException err)++ Right txt -> do+ pres <- try @IOException $ ETag.parseTagsFile txt+ case pres of+ Left err -> + putDocLn dynFlags $ messageDoc ParserException ms_mod (displayException err)++ Right (Left err) ->+ printMessageDoc dynFlags ParserException ms_mod err++ Right (Right tags) -> do++ -- read the source file to calculate byteoffsets+ ll <- map (succ . BS.length) . BSC.lines <$> BS.readFile sourcePath++ let tags' :: [ETag]+ tags' = combineTags+ ETag.compareTags+ (fixFilePath cwd tagsDir sourcePath)+ (sortBy ETag.compareTags+ . map ( ETag.withByteOffset ll+ . fixTagFilePath cwd tagsDir+ )+ . mapMaybe (ghcTagToTag SingETag dynFlags)+ . getGhcTags+ $ lmodule)+ (sortBy ETag.compareTags tags)++ BB.hPutBuilder writeHandle (ETag.formatETagsFile tags')+++ where++ sourceFile = case splitFileName tagsFile of+ (dir, name) -> dir </> "." ++ name+ lockFile = sourceFile ++ ".lock"++ fixFilePath :: FilePath -- curent directory+ -> FilePath -- tags directory+ -> FilePath -> FilePath+ fixFilePath cwd tagsDir = normalise . makeRelative tagsDir . (cwd </>)++ fixTagFilePath :: FilePath -> FilePath -> Tag tk -> Tag tk+ fixTagFilePath cwd tagsDir tag@Tag { tagFilePath } =+ tag { tagFilePath = fixFilePath cwd tagsDir tagFilePath }+++--+-- Error Formatting+--++data MessageSeverity+ = Warning+ | Error++messageDoc :: ExceptionType -> Module -> String -> Out.SDoc+messageDoc errorType mod_ errorMessage =+ Out.blankLine+ $+$+ Out.coloured PprColour.colBold+ ((Out.text "GhcTagsPlugin: ")+ Out.<> (Out.coloured messageColour (Out.text $ show errorType ++ ":")))+ $$+ Out.coloured PprColour.colBold (Out.nest 4 $ Out.ppr mod_)+ $$+ (Out.nest 8 $ Out.coloured messageColour (Out.text errorMessage))+ $+$+ Out.blankLine+ $+$ case severity of+ Error ->+ Out.coloured PprColour.colBold (Out.text "Please report this bug to: ")+ Out.<> Out.text "https://github.com/coot/ghc-tags-plugin/issues"+ $+$ Out.blankLine+ Warning -> Out.blankLine+ where+ severity = case errorType of+ ReadException -> Error+ ParserException -> Error+ WriteException -> Error+ UnhandledException -> Error+ OptionParserFailure -> Warning++ messageColour = case severity of+ Error -> PprColour.colRedFg+ Warning -> PprColour.colBlueFg+++putDocLn :: DynFlags -> Out.SDoc -> IO ()+putDocLn dynFlags sdoc =+ putStrLn $+ Out.renderWithStyle+ dynFlags+ sdoc+ (Out.setStyleColoured True $ Out.defaultErrStyle dynFlags)+++printMessageDoc :: DynFlags -> ExceptionType -> Module -> String -> IO ()+printMessageDoc dynFlags = (fmap . fmap . fmap) (putDocLn dynFlags) messageDoc
+ lib/Plugin/GhcTags/CTag.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Plugin.GhcTags.CTag where++import qualified Data.Text as Text+import Data.Version++import Paths_ghc_tags_plugin++import GhcTags.CTag.Header+++headers :: [Header]+headers =+ [ Header FileFormat Nothing 2 ""+ , Header FileSorted Nothing 1 ""+ , Header FileEncoding Nothing "utf-8" ""+ , Header ProgramAuthor Nothing "Marcin Szamotulski" ""+ , Header ProgramName Nothing "ghc-tags-plugin" ""+ , Header ProgramUrl Nothing "https://hackage.haskell.org/package/ghc-tags-plugin" ""+ , Header ProgramVersion Nothing (Text.pack $ showVersion version) ""++ , Header FieldDescription haskellLang "type" "type of expression"+ , Header FieldDescription haskellLang "ffi" "foreign object name"+ , Header FieldDescription haskellLang "file" "not exported term"+ , Header FieldDescription haskellLang "instance" "class, type or data type instance"+ , Header FieldDescription haskellLang "Kind" "kind of a type"++ , Header KindDescription haskellLang "`" "module top level term, but not a function"+ , Header KindDescription haskellLang "λ" "module top level function term"+ , Header KindDescription haskellLang "Λ" "type constructor"+ , Header KindDescription haskellLang "c" "data constructor"+ , Header KindDescription haskellLang "g" "gadt constructor"+ , Header KindDescription haskellLang "r" "record field"+ , Header KindDescription haskellLang "≡" "type synonym"+ , Header KindDescription haskellLang "~" "type signature"+ , Header KindDescription haskellLang "p" "pattern synonym"+ , Header KindDescription haskellLang "C" "type class"+ , Header KindDescription haskellLang "m" "type class member"+ , Header KindDescription haskellLang "i" "type class instance"+ , Header KindDescription haskellLang "F" "type family"+ , Header KindDescription haskellLang "f" "type family instance"+ , Header KindDescription haskellLang "D" "data type family"+ , Header KindDescription haskellLang "d" "data type family instance"+ , Header KindDescription haskellLang "I" "foreign import"+ , Header KindDescription haskellLang "E" "foreign export"+ ]+ where+ haskellLang = Just "Haskell"
+ lib/Plugin/GhcTags/FileLock.hs view
@@ -0,0 +1,22 @@+module Plugin.GhcTags.FileLock+ ( withFileLock+ , LockMode (..)+ ) where++import Control.Exception+import System.IO+import GHC.IO.Handle+import GHC.IO.Handle.Lock++-- | 'flock' base lock (on posix) or `LockFileEx` on Windows.+--+withFileLock :: FilePath -> LockMode -> IOMode -> (Handle -> IO x) -> IO x+withFileLock path mode iomode k =+ bracket+ (openFile path iomode)+ (\h -> hClose h)+ $ \h ->+ bracket+ (hLock h mode)+ (\_ -> hUnlock h)+ (\_ -> k h)
− lib/Plugin/GhcTags/Generate.hs
@@ -1,626 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Interface for generating tags for a parsed module.----module Plugin.GhcTags.Generate- ( GhcTag (..)- , GhcTags- , GhcKind (..)- , TagField (..)- , ghcKindToChar- , charToGhcKind- , getGhcTags- ) where---import Data.Maybe (mapMaybe, maybeToList)-import Data.Foldable (foldl')-import Data.Text (Text)-import qualified Data.Text as Text---- Ghc imports-import BasicTypes ( SourceText (..)- )-import FastString ( FastString (..)- )-import FieldLabel ( FieldLbl (..)- )-import HsBinds ( HsBindLR (..)- , PatSynBind (..)- , Sig (..)- )-import HsDecls ( ForeignImport (..)- , ClsInstDecl (..)- , ConDecl (..)- , DataFamInstDecl (..)- , FamEqn (..)- , FamilyDecl (..)- , FamilyInfo (..)- , ForeignDecl (..)- , LHsDecl- , HsConDeclDetails- , HsDecl (..)- , HsDataDefn (..)- , InstDecl (..)- , TyClDecl (..)- , TyFamInstDecl (..)- )-import HsImpExp ( IE (..)- , IEWildcard (..)- , ieWrappedName- )-import HsSyn ( FieldOcc (..)- , GhcPs- , HsModule (..)- , LFieldOcc- )-import HsTypes ( ConDeclField (..)- , HsConDetails (..)- , HsImplicitBndrs (..)- , HsType (..)- , LConDeclField- , LHsType- )-import SrcLoc ( GenLocated (..)- , Located- , SrcSpan (..)- , unLoc- )-import RdrName ( RdrName (..)- , rdrNameOcc- )-import Name ( nameOccName- , occNameFS- )----- | `ctags` can generate tags kinds, so do we.----data GhcKind = TkTerm- | TkFunction- | TkTypeConstructor- | TkDataConstructor- | TkGADTConstructor- | TkRecordField- | TkTypeSynonym- | TkTypeSignature- | TkPatternSynonym- | TkTypeClass- | TkTypeClassMember- | TkTypeClassInstance- | TkTypeFamily- | TkTypeFamilyInstance- | TkDataTypeFamily- | TkDataTypeFamilyInstance- | TkForeignImport- | TkForeignExport- deriving (Ord, Eq, Show)---ghcKindToChar :: GhcKind -> Char-ghcKindToChar tagKind = case tagKind of- TkTerm -> '`'- TkFunction -> 'λ'- TkTypeConstructor -> 'Λ'- TkDataConstructor -> 'c'- TkGADTConstructor -> 'g'- TkRecordField -> 'r'- TkTypeSynonym -> '≡'- TkTypeSignature -> '⊢'- TkPatternSynonym -> 'p'- TkTypeClass -> 'C'- TkTypeClassMember -> 'm'- TkTypeClassInstance -> 'i'- TkTypeFamily -> 'f'- TkTypeFamilyInstance -> 'F'- TkDataTypeFamily -> 'd'- TkDataTypeFamilyInstance -> 'D'- TkForeignImport -> 'I'- TkForeignExport -> 'E'---charToGhcKind :: Char -> Maybe GhcKind-charToGhcKind c = case c of- '`' -> Just TkTerm- 'λ' -> Just TkFunction- 'Λ' -> Just TkTypeConstructor- 'c' -> Just TkDataConstructor- 'g' -> Just TkGADTConstructor- 'r' -> Just TkRecordField- '≡' -> Just TkTypeSynonym- '⊢' -> Just TkTypeSignature- 'p' -> Just TkPatternSynonym- 'C' -> Just TkTypeClass- 'm' -> Just TkTypeClassMember- 'i' -> Just TkTypeClassInstance- 'f' -> Just TkTypeFamily- 'F' -> Just TkTypeFamilyInstance- 'd' -> Just TkDataTypeFamily- 'D' -> Just TkDataTypeFamilyInstance- 'I' -> Just TkForeignImport- 'E' -> Just TkForeignExport- _ -> Nothing------ | Unit of data associated with a tag. Vim natively supports `file:` and--- `kind:` tags but it can display any other tags too.----data TagField = TagField {- fieldName :: Text,- fieldValue :: Text- }- deriving (Eq, Ord, Show)----- | File field; tags which contain 'fileFields' are called static (aka static--- in 'C'), such tags are only visible in the current file)----fileField :: TagField-fileField = TagField { fieldName = "file", fieldValue = "" }----- | We can read names from using fields of type 'GHC.Hs.Extensions.IdP' (a type--- family) which for @'Parsed@ resolved to 'RdrName'----data GhcTag = GhcTag {- gtSrcSpan :: !SrcSpan- , gtTag :: !FastString- , gtKind :: !GhcKind- , gtFields :: ![TagField]- }- deriving Show---appendField :: TagField -> GhcTag -> GhcTag-appendField f gt = gt { gtFields = f : gtFields gt }---type GhcTags = [GhcTag]----- | Check if an identifier is exported, if it is not return 'fileField'.----getFileTagField :: Maybe [IE GhcPs] -> Located RdrName -> Maybe TagField-getFileTagField Nothing _name = Nothing-getFileTagField (Just ies) (L _ name) =- if any (\ie -> ieName ie == Just name) ies- then Nothing- else Just fileField- where- -- TODO: the GHC's one is partial, and I got a panic error.- ieName :: IE GhcPs -> Maybe RdrName- ieName (IEVar _ (L _ n)) = Just $ ieWrappedName n- ieName (IEThingAbs _ (L _ n)) = Just $ ieWrappedName n- ieName (IEThingWith _ (L _ n) _ _ _) = Just $ ieWrappedName n- ieName (IEThingAll _ (L _ n)) = Just $ ieWrappedName n- ieName _ = Nothing----- | Either class members or type constructors.----getFileTagFieldForMember :: Maybe [IE GhcPs]- -> Located RdrName -- member name / constructor name- -> Located RdrName -- type class name / type constructor name- -> Maybe TagField-getFileTagFieldForMember Nothing _memberName _className = Nothing-getFileTagFieldForMember (Just ies) memberName className =- if any go ies- then Nothing- else Just fileField- where- go :: IE GhcPs -> Bool-- go (IEVar _ (L _ n)) = ieWrappedName n == unLoc memberName-- go (IEThingAbs _ _) = False-- go (IEThingAll _ (L _ n)) = ieWrappedName n == unLoc className-- go (IEThingWith _ _ IEWildcard{} _ _) = True-- go (IEThingWith _ (L _ n) NoIEWildcard ns lfls) =- ieWrappedName n == unLoc className- && (isInWrappedNames || isInFieldLbls)- where- -- the 'NameSpace' does not agree between things that are in the 'IE'- -- list and passed member or type class names (constructor / type- -- constructor names, respectively)- isInWrappedNames = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . ieWrappedName . unLoc) ns- isInFieldLbls = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . flSelector. unLoc) lfls -- go _ = False----- | Create a 'GhcTag', effectively a smart constructor.----mkGhcTag :: Located RdrName- -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier.- -> GhcKind- -- ^ tag's kind- -> [TagField]- -- ^ tag's fields- -> GhcTag-mkGhcTag (L gtSrcSpan rdrName) gtKind gtFields =- case rdrName of- Unqual occName ->- GhcTag { gtTag = occNameFS occName- , gtSrcSpan- , gtKind- , gtFields- }-- Qual _ occName ->- GhcTag { gtTag = occNameFS occName- , gtSrcSpan- , gtKind- , gtFields- }-- -- Orig is the only one we are interested in- Orig _ occName ->- GhcTag { gtTag = occNameFS occName- , gtSrcSpan- , gtKind- , gtFields- }-- Exact eName -> - GhcTag { gtTag = occNameFS $ nameOccName eName- , gtSrcSpan- , gtKind- , gtFields- }----- | Generate tags for a module - simple walk over the syntax tree.------ Supported identifiers:--- * top level terms--- * data types--- * record fields--- * type synonyms--- * type classes--- * type class members--- * type class instances--- * type families--- * type family instances--- * data type families--- * data type families instances--- * data type family instances constructors----getGhcTags ::Located (HsModule GhcPs)- -> GhcTags-getGhcTags (L _ HsModule { hsmodDecls, hsmodExports }) = - reverse $ foldl' go [] hsmodDecls- where- mies :: Maybe [IE GhcPs]- mies = map unLoc . unLoc <$> hsmodExports-- -- like 'mkGhcTag' but checks if the identifier is exported- mkGhcTag' :: Located RdrName- -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier.- -> GhcKind- -- ^ tag's kind- -> GhcTag- mkGhcTag' a k = mkGhcTag a k (maybeToList $ getFileTagField mies a)-- mkGhcTagForMember :: Located RdrName -- member name- -> Located RdrName -- class name- -> GhcKind- -> GhcTag- mkGhcTagForMember memberName className kind =- mkGhcTag memberName kind- (maybeToList $ getFileTagFieldForMember mies memberName className)--- -- Main routine which traverse all top level declarations.- --- go :: GhcTags -> LHsDecl GhcPs -> GhcTags- go tags (L _ hsDecl) = case hsDecl of-- -- type or class declaration- TyClD _ tyClDecl ->- case tyClDecl of-- -- type family declarations- FamDecl { tcdFam } ->- case mkFamilyDeclTags tcdFam Nothing of- Just tag -> tag : tags- Nothing -> tags-- -- type synonyms- SynDecl { tcdLName } ->- mkGhcTag' tcdLName TkTypeSynonym : tags-- -- data declaration:- -- type,- -- constructors,- -- record fields- --- DataDecl { tcdLName, tcdDataDefn } -> - case tcdDataDefn of- HsDataDefn { dd_cons } ->- mkGhcTag' tcdLName TkTypeConstructor- : (mkConsTags tcdLName . unLoc) `concatMap` dd_cons- ++ tags-- XHsDataDefn {} -> tags-- -- Type class declaration:- -- type class name,- -- type class members,- -- default methods,- -- default data type instance- --- ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs, tcdATDefs } ->- -- class name- mkGhcTag' tcdLName TkTypeClass- -- class methods- : (mkClsMemberTags tcdLName . unLoc) `concatMap` tcdSigs- -- default methods- ++ foldl' (\tags' hsBind -> mkHsBindLRTags (unLoc hsBind) ++ tags')- []- tcdMeths- -- associated types- ++ (flip mkFamilyDeclTags (Just tcdLName) . unLoc) `mapMaybe` tcdATs- -- associated type defaults (data type families, type families- -- (open or closed)- ++ foldl'- (\tags' (L _ tyFamDeflEqn) ->- case tyFamDeflEqn of- FamEqn { feqn_rhs } -> - case hsTypeTagName (unLoc feqn_rhs) of- -- TODO: add a `default` field- Just a -> mkGhcTag' a TkTypeFamilyInstance : tags'- Nothing -> tags'- XFamEqn {} -> tags')- [] tcdATDefs- ++ tags-- XTyClDecl {} -> tags-- -- Instance declarations- -- class instances- -- type family instance- -- data type family instances- --- InstD _ instDecl ->- case instDecl of- -- class instance declaration- ClsInstD { cid_inst } ->- case cid_inst of- XClsInstDecl {} -> tags-- ClsInstDecl { cid_poly_ty, cid_tyfam_insts, cid_datafam_insts } ->- case cid_poly_ty of- XHsImplicitBndrs {} ->- tyFamTags ++ dataFamTags ++ tags-- -- TODO: @hsbib_body :: LHsType GhcPs@- HsIB { hsib_body } ->- case mkLHsTypeTag hsib_body of- Nothing -> tyFamTags ++ dataFamTags ++ tags- Just tag -> tag : tyFamTags ++ dataFamTags ++ tags- where- -- associated type and data type family instances- dataFamTags = (mkDataFamInstDeclTag . unLoc) `concatMap` cid_datafam_insts- tyFamTags = (mkTyFamInstDeclTag . unLoc) `mapMaybe` cid_tyfam_insts-- -- data family instance- DataFamInstD { dfid_inst } ->- mkDataFamInstDeclTag dfid_inst ++ tags-- -- type family instance- TyFamInstD { tfid_inst } ->- case mkTyFamInstDeclTag tfid_inst of- Nothing -> tags- Just tag -> tag : tags-- XInstDecl {} -> tags-- -- deriving declaration- DerivD {} -> tags-- -- value declaration- ValD _ hsBind -> mkHsBindLRTags hsBind ++ tags-- -- signature declaration- SigD _ sig -> mkSigTags sig ++ tags-- -- default declaration- DefD {} -> tags-- -- foreign declaration- ForD _ foreignDecl ->- case foreignDecl of- ForeignImport { fd_name, fd_fi = CImport _ _ _mheader _ (L _ sourceText) } ->- case sourceText of- NoSourceText -> tag- -- TODO: add header information from '_mheader'- SourceText s -> TagField "ffi" (Text.pack s) `appendField` tag- : tags- where- tag = mkGhcTag' fd_name TkForeignImport-- ForeignExport { fd_name } ->- mkGhcTag' fd_name TkForeignExport- : tags-- XForeignDecl {} -> tags-- WarningD {} -> tags- AnnD {} -> tags-- -- TODO: Rules are named it would be nice to get them too- RuleD {} -> tags- SpliceD {} -> tags- DocD {} -> tags- RoleAnnotD {} -> tags- XHsDecl {} -> tags--- -- generate tags of all constructors of a type- --- mkConsTags :: Located RdrName- -- name of the type- -> ConDecl GhcPs- -- constructor declaration- -> GhcTags-- mkConsTags tyName ConDeclGADT { con_names, con_args } =- (\n -> mkGhcTagForMember n tyName TkGADTConstructor)- `map` con_names- ++ mkHsConDeclDetails tyName con_args-- mkConsTags tyName ConDeclH98 { con_name, con_args } =- mkGhcTagForMember con_name tyName TkDataConstructor- : mkHsConDeclDetails tyName con_args-- mkConsTags _ XConDecl {} = []-- mkHsConDeclDetails :: Located RdrName -> HsConDeclDetails GhcPs -> GhcTags- mkHsConDeclDetails tyName (RecCon (L _ fields)) =- foldl' f [] fields- where- f :: GhcTags -> LConDeclField GhcPs -> GhcTags- f ts (L _ ConDeclField { cd_fld_names }) = foldl' g ts cd_fld_names- f ts _ = ts-- g :: GhcTags -> LFieldOcc GhcPs -> GhcTags- g ts (L _ FieldOcc { rdrNameFieldOcc }) =- mkGhcTagForMember rdrNameFieldOcc tyName TkRecordField- : ts- g ts _ = ts-- mkHsConDeclDetails _ _ = []--- mkHsBindLRTags :: HsBindLR GhcPs GhcPs -> GhcTags- mkHsBindLRTags hsBind =- case hsBind of- FunBind { fun_id } -> [mkGhcTag' fun_id TkFunction]-- -- TODO- -- This is useful fo generating tags for- -- ````- -- Just x = lhs- -- ```- PatBind {} -> []-- VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag' (L srcSpan var_id) TkTerm]-- -- abstraction binding is only used after translation- AbsBinds {} -> []-- PatSynBind _ PSB { psb_id } -> [mkGhcTag' psb_id TkPatternSynonym]- PatSynBind _ XPatSynBind {} -> []-- XHsBindsLR {} -> []--- mkClsMemberTags :: Located RdrName -> Sig GhcPs -> GhcTags- mkClsMemberTags clsName (TypeSig _ lhs _) =- (\n -> mkGhcTagForMember n clsName TkTypeSignature)- `map` lhs- mkClsMemberTags clsName (PatSynSig _ lhs _) =- (\n -> mkGhcTagForMember n clsName TkPatternSynonym)- `map` lhs- mkClsMemberTags clsName (ClassOpSig _ _ lhs _) =- (\n -> mkGhcTagForMember n clsName TkTypeClassMember)- `map` lhs- mkClsMemberTags _ _ = []--- mkSigTags :: Sig GhcPs -> GhcTags- mkSigTags (TypeSig _ lhs _) = flip mkGhcTag' TkTypeSignature `map` lhs- mkSigTags (PatSynSig _ lhs _) = flip mkGhcTag' TkPatternSynonym `map` lhs- mkSigTags (ClassOpSig _ _ lhs _) = flip mkGhcTag' TkTypeClassMember `map` lhs- mkSigTags IdSig {} = []- -- TODO: generate theses with additional info (fixity)- mkSigTags FixSig {} = []- mkSigTags InlineSig {} = []- -- SPECIALISE pragmas- mkSigTags SpecSig {} = []- mkSigTags SpecInstSig {} = []- -- MINIMAL pragma- mkSigTags MinimalSig {} = []- -- SSC pragma- mkSigTags SCCFunSig {} = []- -- COMPLETE pragma- mkSigTags CompleteMatchSig {} = []- mkSigTags XSig {} = []--- mkFamilyDeclTags :: FamilyDecl GhcPs- -> Maybe (Located RdrName)- -- if this type family is associate, pass the name of the- -- associated class- -> Maybe GhcTag- mkFamilyDeclTags FamilyDecl { fdLName, fdInfo } assocClsName =- case assocClsName of- Nothing -> Just $ mkGhcTag' fdLName tk- Just clsName -> Just $ mkGhcTagForMember fdLName clsName tk - where- tk = case fdInfo of- DataFamily -> TkDataTypeFamily- OpenTypeFamily -> TkTypeFamily- ClosedTypeFamily {} -> TkTypeFamily- mkFamilyDeclTags XFamilyDecl {} _ = Nothing--- -- used to generate tag of an instance declaration- mkLHsTypeTag :: LHsType GhcPs -> Maybe GhcTag- mkLHsTypeTag (L _ hsType) = (\a -> mkGhcTag a TkTypeClassInstance []) <$> hsTypeTagName hsType--- hsTypeTagName :: HsType GhcPs -> Maybe (Located RdrName)- hsTypeTagName hsType =- case hsType of- HsForAllTy {hst_body} -> hsTypeTagName (unLoc hst_body)- - HsQualTy {hst_body} -> hsTypeTagName (unLoc hst_body)-- HsTyVar _ _ a -> Just $ a-- HsAppTy _ a _ -> hsTypeTagName (unLoc a)- HsOpTy _ _ a _ -> Just $ a- HsKindSig _ a _ -> hsTypeTagName (unLoc a)-- _ -> Nothing--- -- data family instance declaration- --- mkDataFamInstDeclTag :: DataFamInstDecl GhcPs -> GhcTags- mkDataFamInstDeclTag DataFamInstDecl { dfid_eqn } =- case dfid_eqn of- XHsImplicitBndrs {} -> []-- HsIB { hsib_body = FamEqn { feqn_tycon, feqn_rhs } } ->- case feqn_rhs of- HsDataDefn { dd_cons } ->- mkGhcTag' feqn_tycon TkDataTypeFamilyInstance- : (mkConsTags feqn_tycon . unLoc) `concatMap` dd_cons- XHsDataDefn {} ->- mkGhcTag' feqn_tycon TkDataTypeFamilyInstance : []-- HsIB { hsib_body = XFamEqn {} } -> []--- -- type family instance declaration- --- mkTyFamInstDeclTag :: TyFamInstDecl GhcPs -> Maybe GhcTag- mkTyFamInstDeclTag TyFamInstDecl { tfid_eqn } =- case tfid_eqn of- XHsImplicitBndrs {} -> Nothing-- -- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?- HsIB { hsib_body = FamEqn { feqn_tycon } } ->- Just $ mkGhcTag' feqn_tycon TkTypeFamilyInstance-- HsIB { hsib_body = XFamEqn {} } -> Nothing
+ lib/Plugin/GhcTags/Options.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Plugin.GhcTags.Options+ ( Options (..)+ , ParserResult (..)+ , runOptionParser+ ) where++import Data.Bool (bool)+import Data.Monoid (Last (..))+import Data.Functor.Identity (Identity (..))+import System.IO (FilePath)+import Options.Applicative+++etagsParser :: Parser Bool+etagsParser = switch $+ short 'e'+ <> long "etags"+ <> showDefault+ <> help "produce emacs etags file"+++filePathParser :: Parser (FilePath)+filePathParser =+ strArgument $+ help "tags file: default tags or TAGS (when --etags is specified)"+ <> metavar "file_path"+++-- | /ghc-tags-plugin/ options+--+data Options f = Options+ { etags :: Bool+ -- ^ if 'True' use emacs tags file format, the default is 'False'.++ , filePath :: f FilePath+ -- ^ file path to the tags file (relative to the @*.cabal@ file). The+ -- default is either 'tags' (if 'etags' if 'False') or 'TAGS' otherwise.+ }++deriving instance Show (Options Identity)+++parseOtions :: Parser (Options Last)+parseOtions = Options+ <$> etagsParser+ -- allow to pass the argument multiple times+ <*> (foldMap (Last . Just) <$> many filePathParser)+++parserInfo :: ParserInfo (Options Last)+parserInfo = info (parseOtions <**> helper) $+ progDesc "write tags from ghc abstract syntax tree"+ <> fullDesc+++runOptionParser :: [String]+ -> ParserResult (Options Identity)+runOptionParser = fmap defaultOptions . execParserPure defaultPrefs parserInfo+ where+ defaultOptions :: Options Last -> Options Identity+ defaultOptions Options { etags, filePath } =+ Options {+ etags,+ filePath = Identity filePath'+ }+ where+ filePath' =+ case filePath of+ Last Nothing -> bool "tags" "TAGS" etags+ Last (Just fp) -> fp
− lib/Plugin/GhcTags/Tag.hs
@@ -1,159 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Plugin.GhcTags.Tag- ( -- * Tag- Tag (..)- , compareTags- , tagFilePath- , TagName (..)- , TagFile (..)- , TagKind (..)- , GhcKind (..)- , charToGhcKind- , ghcKindToChar- , TagField (..)- , ghcTagToTag- , combineTags- ) where--import Data.Function (on)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text---- GHC imports-import FastString ( FastString (..)- )-import SrcLoc ( SrcSpan (..)- , srcSpanFile- , srcSpanStartLine- )--import Plugin.GhcTags.Generate- ( GhcTag (..)- , GhcKind (..)- , TagField (..)- , charToGhcKind- , ghcKindToChar- )------- Tag-------- | 'ByteString' which encodes a tag name.----newtype TagName = TagName { getTagName :: Text }- deriving (Eq, Ord, Show)----- | 'ByteString' which encodes a tag file.----newtype TagFile = TagFile { getTagFile :: String }- deriving (Eq, Ord, Show)--tagFilePath :: Tag -> FilePath-tagFilePath = getTagFile . tagFile----- | When we parse a `tags` file we can eithera find no kind or recognize the--- kind of GhcKind or we store the found character kind. This allows us to--- preserve information from parsed tags files which were not created by--- `ghc-tags-plugin'----data TagKind- = GhcKind !GhcKind- | CharKind !Char- | NoKind- deriving (Eq, Ord, Show)---- | Simple Tag record. For the moment on tag name, tag file and line numbers--- are supported.------ TODO: expand to support column numbers and extra information.----data Tag = Tag- { tagName :: !TagName- , tagKind :: !TagKind- , tagFile :: !TagFile- , tagAddr :: !(Either Int Text)- , tagFields :: ![TagField]- }- deriving (Eq, Show)----- | Total order relation on 'Tag' elements.------ It sorts type classes / type families ('TkTypeClass', 'TkTypeFamily',--- 'TkDataTypeFamily') before instances ('TkTypeClassInstance',--- 'TkTypeFamilyInstance', 'TkDataTypeFamilyInstance'); but also (as a side--- effect of keeping transitivity property) it will put type classes and their--- instances before other kinds.----compareTags :: Tag -> Tag -> Ordering-compareTags t0 t1 | on (/=) tagName t0 t1 = on compare tagName t0 t1-- -- sort type classes / type families before their instances,- -- and take precendence over a file where they are defined.- -- - -- This will also sort type classes and instances before any- -- other terms.- | on (/=) getTkClass t0 t1 = on compare getTkClass t0 t1-- | on (/=) tagFile t0 t1 = on compare tagFile t0 t1- | on (/=) tagAddr t0 t1 = on compare tagAddr t0 t1- | on (/=) tagKind t0 t1 = on compare tagKind t0 t1-- -- this is not compatible with 'Eq' intsance, but we are not- -- defining a 'Ord' instance!- | otherwise = EQ- where- getTkClass :: Tag -> Maybe GhcKind- getTkClass t = case tagKind t of- GhcKind TkTypeClass -> Just TkTypeClass- GhcKind TkTypeClassInstance -> Just TkTypeClassInstance- GhcKind TkTypeFamily -> Just TkTypeFamily- GhcKind TkTypeFamilyInstance -> Just TkTypeFamilyInstance- GhcKind TkDataTypeFamily -> Just TkDataTypeFamily- GhcKind TkDataTypeFamilyInstance -> Just TkDataTypeFamilyInstance- _ -> Nothing---ghcTagToTag :: GhcTag -> Maybe Tag-ghcTagToTag GhcTag { gtSrcSpan, gtTag, gtKind, gtFields } =- case gtSrcSpan of- UnhelpfulSpan {} -> Nothing- RealSrcSpan realSrcSpan ->- Just $ Tag { tagName = TagName (Text.decodeUtf8 $ fs_bs gtTag)- , tagFile = TagFile (Text.unpack $ Text.decodeUtf8 $ fs_bs (srcSpanFile realSrcSpan))- , tagAddr = Left (srcSpanStartLine realSrcSpan)- , tagKind = GhcKind gtKind- , tagFields = gtFields- }----- This is crtitical function for perfomance. Tags from the first list are--- assumeed to be from the same file.------ complexity: /O(max n m)/-combineTags :: [Tag] -> [Tag] -> [Tag]-combineTags [] ts1 = ts1-combineTags ts0@(t : _) ts1 = go ts0 ts1- where- modPath = tagFilePath t-- go as@(a : as') bs@(b : bs')- | tagFilePath b == modPath = go as bs'- | otherwise = case a `compareTags` b of- LT -> a : go as' bs- EQ -> a : go as' bs'- GT -> b : go as bs'- go [] bs = filter (\b -> tagFilePath b /= modPath) bs- go as [] = as- {-# INLINE go #-}
− lib/Plugin/GhcTags/Vim.hs
@@ -1,6 +0,0 @@-module Plugin.GhcTags.Vim- ( module X- ) where--import Plugin.GhcTags.Vim.Parser as X-import Plugin.GhcTags.Vim.Formatter as X
− lib/Plugin/GhcTags/Vim/Formatter.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}---- | 'bytestring''s 'Builder' for a 'Tag'----module Plugin.GhcTags.Vim.Formatter- ( formatTagsFile- , formatTag- , formatHeader- ) where--import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BS-import Data.Char (isAscii)-import Data.Version (showVersion)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import Text.Printf (printf)--import Paths_ghc_tags_plugin (version)--import Plugin.GhcTags.Generate-import Plugin.GhcTags.Tag----- | 'ByteString' 'Builder' for a single line.----formatTag :: Tag -> Builder-formatTag Tag { tagName, tagFile, tagAddr, tagKind, tagFields} =- (BS.byteString . Text.encodeUtf8 . getTagName $ tagName)- <> BS.charUtf8 '\t'- <> (BS.byteString . Text.encodeUtf8 . Text.pack . getTagFile $ tagFile)- <> BS.charUtf8 '\t'- <> either BS.intDec (BS.byteString . Text.encodeUtf8) tagAddr- -- we are using extended format: '_TAG_FILE_FROMAT 2'- <> BS.stringUtf8 ";\""- -- tag kind: we are encoding them using field syntax: this is because vim- -- is using them in the right way: https://github.com/vim/vim/issues/5724- <> formatKindChar tagKind- -- tag fields- <> foldMap ((BS.charUtf8 '\t' <>) . formatField) tagFields - <> BS.charUtf8 '\n'- where- formatKindChar :: TagKind -> Builder- formatKindChar NoKind = mempty- formatKindChar (CharKind c)- | isAscii c = BS.charUtf8 '\t' <> BS.charUtf8 c- | otherwise = BS.stringUtf8 "\tkind:" <> BS.charUtf8 c- formatKindChar (GhcKind ghcKind)- | isAscii c = BS.charUtf8 '\t' <> BS.charUtf8 c- | otherwise = BS.stringUtf8 "\tkind:" <> BS.charUtf8 c- where- c = ghcKindToChar ghcKind---formatField :: TagField -> Builder-formatField TagField { fieldName, fieldValue } =- BS.byteString (Text.encodeUtf8 fieldName)- <> BS.charUtf8 ':'- <> BS.byteString (Text.encodeUtf8 fieldValue)---formatHeader :: String -> String -> String-formatHeader header arg = printf ("!_" ++ header ++ "\t%s\t\n") arg----- | 'ByteString' 'Builder' for vim 'Tag' file.----formatTagsFile :: [Tag] -> Builder-formatTagsFile tags =- -- format 1 does not append ';"' to lines- BS.stringUtf8 (formatHeader "TAG_FILE_FORMAT" "2")- -- allows for binary search- <> BS.stringUtf8 (formatHeader "TAG_FILE_SORTED" "1")- <> BS.stringUtf8 (formatHeader "TAG_FILE_ENCODING" "utf-8")- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_AUTHOR" "Marcin Szamotulski")- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_NAME" "ghc-tags-pluginn")- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_URL"- "https://hackage.haskell.org/package/ghc-tags-plugin")- -- version number with git revision- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_VERSION" (showVersion version))- <> foldMap formatTag tags
− lib/Plugin/GhcTags/Vim/Parser.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Parser combinators for vim style tags----module Plugin.GhcTags.Vim.Parser- ( parseTagsFile- , parseTags- , parseTag- , parseField- ) where--import Control.Arrow ((***))-import Control.Applicative (many, (<|>))-import Data.Attoparsec.Text (Parser, (<?>))-import qualified Data.Attoparsec.Text as AT-import Data.Either (rights)-import Data.Functor (void, ($>))-import Data.Text (Text)-import qualified Data.Text as Text--import Plugin.GhcTags.Tag----- | Parser for a single line of a vim-style tag file.----parseTag :: Parser Tag-parseTag =- (\tagName tagFile tagAddr (tagKind, tagFields)- -> Tag { tagName, tagFile, tagAddr, tagKind, tagFields })- <$> parseTagName- <* separator-- <*> parseFileName- <* separator-- -- includes an optional ';"' separator- <*> AT.eitherP parseAddr parseExCommand-- <*> ( -- kind field followed by list of fields or end of line.- ((,) <$> ( separator *> parseKindField )- <*> ( separator *> parseFields <* AT.endOfLine- <|>- AT.endOfLine $> [])- )-- -- list of fields (kind field might be later, but don't check it, we- -- always format it as the first field) or end of line.- <|> curry id NoKind- <$> ( separator *> parseFields <* AT.endOfLine- <|>- AT.endOfLine $> []- )-- -- kind encoded as a single letter, followed by a list- -- of fields or end of line.- <|> curry (charToTagKind *** id)- <$> ( separator *> AT.satisfy notTabOrNewLine )- <*> ( separator *> parseFields <* AT.endOfLine- <|>- AT.endOfLine $> []- )- <|> AT.endOfLine $> (NoKind, [])- )-- where- separator :: Parser Char- separator = AT.char '\t'-- notTabOrNewLine :: Char -> Bool- notTabOrNewLine = \x -> x /= '\t' && x /= '\n' -- parseTagName :: Parser TagName- parseTagName = TagName <$> AT.takeWhile (/= '\t')- <?> "parsing tag name failed"-- parseFileName :: Parser TagFile- parseFileName = TagFile . Text.unpack <$> AT.takeWhile (/= '\t')-- parseExCommand :: Parser Text- parseExCommand = (\x -> Text.take (Text.length x - 1) x) <$>- AT.scan "" go- <* AT.anyChar- where- -- go until either '\n' or ';"' sequence is found.- go :: String -> Char -> Maybe String- go _ '\n' = Nothing- go !s c | l == "\";" = Nothing- | otherwise = Just l- where- l = take 2 (c : s)-- parseAddr :: Parser Int- parseAddr = AT.decimal- <* AT.eitherP- AT.endOfLine- (AT.char ';' *> AT.char '"')-- parseKindField :: Parser TagKind- parseKindField =- charToTagKind <$>- (AT.string "kind:" *> AT.satisfy notTabOrNewLine)-- parseFields :: Parser [TagField]- parseFields = AT.sepBy parseField separator---charToTagKind :: Char -> TagKind-charToTagKind c = case charToGhcKind c of- Nothing -> CharKind c- Just ghcTag -> GhcKind ghcTag---parseField :: Parser TagField-parseField =- TagField- <$> AT.takeWhile (\x -> x /= ':' && x /= '\n' && x /= '\t')- <* AT.char ':'- <*> AT.takeWhile (\x -> x /= '\t' && x /= '\n')----- | A vim-style tag file parser.----parseTags :: Parser [Tag]-parseTags = rights <$> many parseTagLine---parseTagLine :: Parser (Either () Tag)-parseTagLine =- AT.eitherP- (parseHeader <?> "failed parsing tag")- (parseTag <?> "failed parsing header")---parseHeader :: Parser ()-parseHeader = AT.choice- [ AT.string (Text.pack "!_TAG_FILE_FORMAT") *> params- , AT.string (Text.pack "!_TAG_FILE_SORTED") *> params- , AT.string (Text.pack "!_TAG_FILE_ENCODING") *> params- , AT.string (Text.pack "!_TAG_PROGRAM_AUTHOR") *> params- , AT.string (Text.pack "!_TAG_PROGRAM_NAME") *> params- , AT.string (Text.pack "!_TAG_PROGRAM_URL") *> params- , AT.string (Text.pack "!_TAG_PROGRAM_VERSION") *> params- ]- where- params = void $ AT.char '\t' *> AT.skipWhile (/= '\n') *> AT.char '\n'----- | Parse a vim-style tag file.----parseTagsFile :: Text- -> IO (Either String [Tag])-parseTagsFile =- fmap AT.eitherResult- . AT.parseWith (pure mempty) parseTags
− src/Plugin/GhcTags.hs
@@ -1,183 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Plugin.GhcTags ( plugin ) where--import Control.Exception-import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as BS-#if __GLASGOW_HASKELL__ < 808-import Data.Functor ((<$))-#endif-import Data.List (sortBy)-import Data.Maybe (mapMaybe)-import qualified Data.Text.Encoding as Text-import System.Directory-import System.FilePath-import System.IO-import System.IO.Error (tryIOError)-import System.FileLock ( SharedExclusive (..)- , withFileLock)--import GhcPlugins ( CommandLineOption- , Hsc- , HsParsedModule (..)- , Located- , ModSummary (..)- , Plugin (..)- )-import qualified GhcPlugins-import HsExtension (GhcPs)-import HsSyn (HsModule (..))-import qualified Outputable as Out-import qualified PprColour--import Plugin.GhcTags.Generate-import Plugin.GhcTags.Tag-import qualified Plugin.GhcTags.Vim as Vim----- | The GhcTags plugin. It will run for every compiled module and have access--- to parsed syntax tree. It will inspect it and:------ * update a global mutable state variable, which stores a tag map.--- It is shared across modules compiled in the same `ghc` run.--- * update 'tags' file.------ The global mutable variable save us from parsing the tags file for every--- compiled module.------ __The syntax tree is left unchanged.__--- --- The tags file will contain location information about:------ * top level terms--- * data types--- * record fields--- * type synonyms--- * type classes--- * type class members--- * type class instances--- * type families /(standalone and associated)/--- * type family instances /(standalone and associated)/--- * data type families /(standalone and associated)/--- * data type families instances /(standalone and associated)/--- * data type family instances constructors /(standalone and associated)/----plugin :: Plugin-plugin = GhcPlugins.defaultPlugin {- parsedResultAction = ghcTagsPlugin,- pluginRecompile = GhcPlugins.purePlugin- }----- | IOExcption wrapper; it is useful for the user to know that it's the plugin--- not `ghc` that thrown the error.----data GhcTagsPluginException =- GhcTagsPluginIOExceptino IOException- deriving Show--instance Exception GhcTagsPluginException----- | The plugin does not change the 'HsParedModule', it only runs side effects.----ghcTagsPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule-ghcTagsPlugin options moduleSummary hsParsedModule@HsParsedModule {hpm_module} =- hsParsedModule <$ GhcPlugins.liftIO (updateTags moduleSummary tagsFile hpm_module)- where- tagsFile :: FilePath- tagsFile = case options of- [] -> "tags"- a : _ -> a----- | Extract tags from a module and update tags file----updateTags :: ModSummary- -> FilePath- -> Located (HsModule GhcPs)- -> IO ()-updateTags ModSummary {ms_mod, ms_hspp_opts = dynFlags} tagsFile lmodule =- -- wrap 'IOException's- handle (throwIO . GhcTagsPluginIOExceptino) $-- -- Take advisory exclusive lock (a BSD lock using `flock`) on the tags- -- file. This is needed when `cabal` compiles in parallel.- withFileLock tagsFile Exclusive $ \_ -> do- -- read and parse - a <- doesFileExist tagsFile- tags <-- if a- then do- res <- tryIOError $- Text.decodeUtf8 <$> BS.readFile tagsFile- >>= Vim.parseTagsFile- case res of- -- reading failed- Left err -> do- putDocLn (errorDoc $ displayException err)- pure []-- -- parsing failed- Right (Left err) -> do- -- shout and continue- putDocLn (errorDoc err)- pure []-- Right (Right tags) ->- pure tags-- -- no such file- else pure []-- cwd <- getCurrentDirectory- -- absolute directory path of the tags file; we need canonical path- -- (without ".." and ".") to make 'makeRelative' works.- tagsDir <- canonicalizePath (fst $ splitFileName tagsFile)-- let tags' :: [Tag]- tags' =- ( map (fixFileName cwd tagsDir)- -- fix file names- . sortBy compareTags -- sort- . mapMaybe ghcTagToTag -- translate 'GhcTag' to 'Tag'- . getGhcTags -- generate 'GhcTag's- $ lmodule)- `combineTags`- tags- - -- update tags file- withFile tagsFile WriteMode $ \h ->- BS.hPutBuilder h (Vim.formatTagsFile tags')-- where-- fixFileName :: FilePath -> FilePath -> Tag -> Tag- fixFileName cwd tagsDir tag@Tag { tagFile = TagFile path } =- tag { tagFile = TagFile (makeRelative tagsDir (cwd </> path)) }-- errorDoc :: String -> Out.SDoc- errorDoc errorMessage =- Out.coloured PprColour.colBold- $ Out.blankLine- Out.$+$- ((Out.text "GhcTagsPlugin: ")- Out.<> (Out.coloured PprColour.colRedFg (Out.text "error:")))- Out.$$- (Out.nest 4 $ Out.ppr ms_mod)- Out.$$- (Out.nest 8 $ Out.coloured PprColour.colRedFg (Out.text errorMessage))- Out.$+$- Out.blankLine-- putDocLn :: Out.SDoc -> IO ()- putDocLn sdoc =- putStrLn $- Out.renderWithStyle- dynFlags- sdoc- (Out.setStyleColoured True $ Out.defaultErrStyle dynFlags)
− test/Main.hs
@@ -1,19 +0,0 @@-module Main where--import Test.Tasty--import qualified Test.Golden.Parser (tests)-import qualified Test.Tag (tests)-import qualified Test.Vim (tests)---main ::IO ()-main = defaultMain tests--tests :: TestTree-tests =- testGroup "Plugin.GhcTags"- [ Test.Golden.Parser.tests- , Test.Tag.tests- , Test.Vim.tests- ]
− test/Test/Golden/Parser.hs
@@ -1,79 +0,0 @@-module Test.Golden.Parser (tests) where--import Control.Exception-import Control.Monad ((>=>))--import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as BS-import qualified Data.Text.Encoding as Text-import System.IO--import qualified Plugin.GhcTags.Vim as Vim--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.Golden---tests :: TestTree-tests = testGroup "Golden.Parser"- [ let input = "test/golden/test.tags"- output = "test/golden/test.tags.out"- in goldenVsFile - "test tags"- input- output- (parseGoldenFile input output)-- , let input = "test/golden/vim.tags"- output = "test/golden/vim.tags.out"- in goldenVsFile - "vim tags"- input- output- (parseGoldenFile input output)-- , let input = "test/golden/typed-protocols.tags"- output = "test/golden/typed-protocols.tags.out"- in goldenVsFile - "typed-protocols tags"- input- output- (parseGoldenFile input output)-- , let input = "test/golden/io-sim-classes.tags"- output = "test/golden/io-sim-classes.tags.out"- in goldenVsFile - "io-sim-classes tags"- input- output- (parseGoldenFile input output)- - , let input = "test/golden/ouroboros-network.tags"- output = "test/golden/ouroboros-network.tags.out"- in goldenVsFile - "ouroboros-network tags"- input- output- (parseGoldenFile input output)-- , let input = "test/golden/ouroboros-consensus.tags"- output = "test/golden/ouroboros-consensus.tags.out"- in goldenVsFile - "ouroboros-consensus tags"- input- output- (parseGoldenFile input output)- ]---parseGoldenFile :: FilePath -- input file- -> FilePath -- output file- -> IO ()-parseGoldenFile input output = do- res <- withBinaryFile input ReadMode- (BS.hGetContents >=> Vim.parseTagsFile . Text.decodeUtf8)- case res of- Left err -> throwIO (userError err)- Right tags ->- withBinaryFile output WriteMode- $ flip BS.hPutBuilder (foldMap Vim.formatTag tags)
− test/Test/Tag.hs
@@ -1,246 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UnicodeSyntax #-}--module Test.Tag (tests) where--import Data.Function (on)-import Data.List (nub, sortBy)--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck-import Test.QuickCheck.Instances.Text ()--import Plugin.GhcTags.Tag--import Test.Tag.Generators--tests :: TestTree-tests = testGroup "Tag"- [ testGroup "compareTags"- [ testProperty "antisymmetry" ordAntiSymmetryProp- , testProperty "reflexivity" (on ordReflexivityyProp getArbOrdTag)- , testProperty "transitivity" (\a b c ->- ordTransitiveProp- (getArbOrdTag a)- (getArbOrdTag b)- (getArbOrdTag c))- , testProperty "Eq:consistency" (weakConsistency . getArbOrdTag)- , testProperty "sort:idempotent" sortIdempotentProp- ]- , testGroup "combineTags"- [ testProperty "subset" combineTags_subset- , testProperty "idempotent" combineTags_idempotent- , testProperty "identity" combineTags_identity- , testProperty "preserve" combineTags_preserve- , testProperty "substitution" combineTags_substitution- , testProperty "order" combineTags_order- ]- ]----- | 'Tag' generator-newtype ArbTag = ArbTag { getArbTag :: Tag }- deriving Show--instance Arbitrary ArbTag where- arbitrary =- fmap ArbTag $- Tag- <$> (TagName <$> resize 5 genTextNonEmpty)- <*> genTagKind- <*> (TagFile <$> genSmallFilePath)- <*> frequency- [ (8, Left . getPositive <$> arbitrary)- , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty)- , (1, Right . (wrap '?' . fixAddr) <$> genTextNonEmpty)- ]- <*> listOf genField-- shrink = map ArbTag . shrinkTag . getArbTag----- | Arbitrary instance with a high probability of gettings the same tags or files.----newtype ArbOrdTag = ArbOrdTag { getArbOrdTag :: Tag }- deriving Show---instance Arbitrary ArbOrdTag where- arbitrary = fmap ArbOrdTag- $ Tag- <$> elements- (TagName `map`- [ "find"- , "Ord"- , "Eq"- ])- <*> genTagKind- <*> elements- (TagFile `map`- [ "Main.hs"- , "Lib.hs"- ])- <*> frequency- [ (8, Left . getPositive <$> arbitrary)- , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty)- , (1, Right . (wrap '?' . fixAddr) <$> genTextNonEmpty)- ]- <*> pure []-- shrink = map ArbOrdTag . shrinkTag . getArbOrdTag----- | Generate pairs of tags which are equal in the sense of `compare`.----data EqTags = EqTags Tag Tag- deriving Show--instance Arbitrary EqTags where- arbitrary = do- x <- getArbOrdTag <$> arbitrary- fieldsA <- listOf genField- fieldsB <- listOf genField- pure $ EqTags x { tagFields = fieldsA }- x { tagFields = fieldsB }----- | Note that this property is weaker than required. There are unequal `Tag`s--- in the sense of `==`, which are considered equal by `compare`.----ordAntiSymmetryProp :: EqTags -> Bool-ordAntiSymmetryProp (EqTags a b) = a `compareTags` b == EQ----- We don't provide 'Ord' instance, since it's not compatible with 'compare',--- see 'weakConsistency'.----(≤), (≥) :: Tag -> Tag -> Bool-a ≤ b = a `compareTags` b /= GT-a ≥ b = a `compareTags` b /= LT--ordReflexivityyProp :: Tag -> Tag -> Bool-ordReflexivityyProp a b = a ≤ b || a ≥ b--ordTransitiveProp :: Tag -> Tag -> Tag -> Property-ordTransitiveProp a b c =- a ≤ b && b ≤ c- || a ≥ b && b ≥ c ==>- if | a ≤ b && b ≤ c -> a ≤ c- | a ≥ b && b ≥ c -> a ≥ c- | otherwise -> error "impossible happened"- where--sortIdempotentProp :: [ArbTag] -> Bool-sortIdempotentProp ts =- let ts' = getArbTag `map` ts- ts'' = sortBy compareTags ts'- in sortBy compareTags ts'' == ts''----- | The------ prop> a == b ==> a `compare` b == EQ`------ But since 'Tag' is using derived 'Eq' instance, it is equivalent to-weakConsistency :: Tag -> Bool-weakConsistency a = a `compareTags` a == EQ-------- combineTags properties-----genSmallFilePath :: Gen String-genSmallFilePath = suchThat (resize 3 arbitrary) (not . null)----- | sorted list of Tags-newtype ArbTagList = ArbTagList { getArbTagList :: [Tag] }- deriving Show--instance Arbitrary ArbTagList where- arbitrary = (ArbTagList . nub . sortBy compareTags . map getArbTag)- <$> listOf arbitrary- shrink (ArbTagList ts) =- (ArbTagList . sortBy compareTags) `map` shrinkList shrinkTag ts----- | List of tags from the same file----data ArbTagsFromFile = ArbTagsFromFile FilePath [Tag]- deriving Show--instance Arbitrary ArbTagsFromFile where- arbitrary = do- filePath <- genSmallFilePath- ArbTagList tags <- arbitrary- let tags' = (\t -> t { tagFile = TagFile filePath, tagFields = [] }) `map` tags- pure $ ArbTagsFromFile filePath (sortBy compareTags tags')-- shrink (ArbTagsFromFile fp tags) =- [ ArbTagsFromFile fp (sortBy compareTags tags')- -- Don't shrink file name!- | tags' <- shrinkList shrinkTag' tags- ]- ++- [ ArbTagsFromFile fp' ((\t -> t { tagFile = TagFile fp' }) `map` tags)- | fp' <- shrinkList (const []) fp- , not (null fp')- ]------ properties--combineTags_subset :: ArbTagsFromFile- -> [ArbTag]- -> Bool-combineTags_subset (ArbTagsFromFile _ as) bs =- let bs' = getArbTag `map` bs- cs = as `combineTags` bs'- in all (`elem` cs) as----- | The tag list be ordered for this property to hold.----combineTags_idempotent :: ArbTagList- -> ArbTagList- -> Bool-combineTags_idempotent (ArbTagList as) (ArbTagList bs) =- combineTags as bs == combineTags as (combineTags as bs)----- | The tag list cannot connot contain duplicates for this property to hold.----combineTags_identity :: ArbTagList- -> Bool-combineTags_identity (ArbTagList as) =- combineTags as as == as----- | Does not modify tags outside of the module.----combineTags_preserve :: ArbTagsFromFile -> ArbTagList -> Bool-combineTags_preserve (ArbTagsFromFile fp as) (ArbTagList bs) =- filter (\t -> tagFilePath t /= fp) (as `combineTags` bs)- == - filter (\t -> tagFilePath t /= fp) bs----- | Substitutes all tags of the current file.----combineTags_substitution :: ArbTagsFromFile -> ArbTagList -> Bool-combineTags_substitution (ArbTagsFromFile fp as) (ArbTagList bs) =- filter (\t -> tagFilePath t == fp) (as `combineTags` bs)- == - as---- | 'combineTags' must preserver order of tags.----combineTags_order :: ArbTagsFromFile -> ArbTagList -> Bool-combineTags_order (ArbTagsFromFile _ as) (ArbTagList bs) =- let cs = as `combineTags` bs- in sortBy compareTags cs == cs
− test/Test/Tag/Generators.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Test.Tag.Generators where--import qualified Data.Char as Char-import Data.List as List-import Data.Maybe (isNothing)-import Data.Text (Text)-import qualified Data.Text as Text--import Algebra.Lattice--import Test.QuickCheck-import Test.QuickCheck.Instances.Text ()--import Plugin.GhcTags.Tag------- Generators------- a quick hack-genTextNonEmpty :: Gen Text-genTextNonEmpty =- suchThat- (fixText <$> arbitrary)- (not . Text.null)---- filter only printable characters, removing tabs and newlines which have--- special role in vim tag syntax-fixText :: Text -> Text-fixText = Text.filter ( ((/= Char.Control) . Char.generalCategory)- /\ Char.isPrint)--fixFilePath :: String -> String-fixFilePath = List.filter ( ((/= Char.Control) . Char.generalCategory)- /\ Char.isPrint)--genFilePath :: Gen String-genFilePath =- suchThat- (fixFilePath <$> arbitrary)- (not . null)--genField :: Gen TagField-genField =- TagField- <$> suchThat g (not . Text.null)- <*> g- where- g :: Gen Text- g = fixFieldText <$> arbitrary---- filter only printable characters, removing tabs, newlines and colons which--- have special role in vim field syntax-fixFieldText :: Text -> Text-fixFieldText = Text.filter ( (/= ':')- /\ ((/= Char.Control) . Char.generalCategory)- /\ Char.isPrint)----- address cannot contain ";\"" sequence-fixAddr :: Text -> Text-fixAddr = fixText . Text.replace ";\"" ""--wrap :: Char -> Text -> Text-wrap c = Text.cons c . flip Text.snoc c--genGhcKind :: Gen GhcKind-genGhcKind = elements- [ TkTerm- , TkFunction- , TkTypeConstructor- , TkDataConstructor- , TkGADTConstructor- , TkRecordField- , TkTypeSynonym- , TkTypeSignature- , TkPatternSynonym- , TkTypeClass- , TkTypeClassMember- , TkTypeClassInstance- , TkTypeFamily- , TkTypeFamilyInstance- , TkDataTypeFamily- , TkDataTypeFamilyInstance- , TkForeignImport- , TkForeignExport- ]--genTagKind :: Gen TagKind-genTagKind = oneof- [ pure NoKind- , CharKind <$> genChar- , GhcKind <$> genGhcKind- ]- where- genChar = suchThat arbitrary- ( ((/= Char.Control) . Char.generalCategory)- /\ (/= ':')- /\ (isNothing . charToGhcKind)- )--shrinkTag' :: Tag -> [Tag]-shrinkTag' tag@Tag {tagName, tagAddr, tagFields} =- [ tag { tagName = TagName x }- | x <- fixText `map` shrink (getTagName tagName)- , not (Text.null x)- ]- ++ [ tag { tagAddr = addr }- | addr <- case tagAddr of- Left addr -> Left `map` shrink addr- Right addr -> Left 0- : (Right . wrap '/' . fixAddr)- `map` (shrink . stripEnds) addr- , addr /= tagAddr -- wrap might restore the same address!- ]- ++ [ tag { tagFields = fields }- | fields <- shrinkList (const []) tagFields- ]- where- stripEnds :: Text -> Text- stripEnds addr = case Text.uncons addr of- Nothing -> error "impossible happend"- Just (_, addr') -> case Text.unsnoc addr' of- Nothing -> error "impossible happend"- Just (addr'', _) -> addr''---shrinkTag :: Tag -> [Tag]-shrinkTag tag@Tag {tagFile} =- shrinkTag' tag- ++ [ tag { tagFile = TagFile x }- | x <- fixFilePath `map` shrink (getTagFile tagFile)- , not (null x)- ]
− test/Test/Vim.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Test.Vim (tests) where--import qualified Data.Attoparsec.Text as AT-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck-import Test.QuickCheck.Instances.Text ()--import Plugin.GhcTags.Tag-import qualified Plugin.GhcTags.Vim as Vim--import Test.Tag.Generators---tests :: TestTree-tests = testGroup "Vim"- [ testProperty "round-trip" (roundTrip . getArbTag)- ]------- Generators-----newtype ArbTag = ArbTag { getArbTag :: Tag }- deriving Show--instance Arbitrary ArbTag where- arbitrary = fmap ArbTag $- Tag- <$> (TagName <$> genTextNonEmpty)- <*> genTagKind- <*> (TagFile <$> genFilePath)- <*> frequency- [ (2, Left . getPositive <$> arbitrary)- , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty)- , (1, Right . (wrap '?' . fixAddr) <$> genTextNonEmpty)- ]- <*> listOf genField- shrink = map ArbTag . shrinkTag . getArbTag---roundTrip :: Tag -> Property-roundTrip tag =- let bs = BL.toStrict- . BB.toLazyByteString- . Vim.formatTag- $ tag- mtag = AT.parseOnly Vim.parseTag- . Text.decodeUtf8- $ bs- in case mtag of- Left err -> counterexample- ("parser error: " ++ err ++ " bs: " ++ (Text.unpack (Text.decodeUtf8 bs)))- (property False)- Right tag' -> counterexample- (show $ Text.decodeUtf8 bs)- (tag === tag')