diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,10 +2,11 @@ ======================== ![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-8D82AC.svg) ![MPL-2.0 License](http://img.shields.io/badge/license-MPL20-brightgreen.svg) -![Hackage](http://img.shields.io/hackage/v/ghc-tags-plugin.svg) -![](https://github.com/coot/ghc-tags-plugin/workflows/GHC-8.8.3/badge.svg) -![](https://github.com/coot/ghc-tags-plugin/workflows/GHC-8.6.5/badge.svg) +[![](https://github.com/coot/ghc-tags-plugin/workflows/Linux%20GHC-8.6.5/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions) +[![](https://github.com/coot/ghc-tags-plugin/workflows/Linux%20GHC-8.8.3/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions) +[![](https://github.com/coot/ghc-tags-plugin/workflows/Windows%20GHC-8.6.5/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions) +[![](https://matrix.hackage.haskell.org/api/v2/packages/ghc-tags-plugin/badge)](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: [-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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/check.hs b/app/check.hs new file mode 100644 --- /dev/null +++ b/app/check.hs @@ -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" diff --git a/ghc-tags-plugin.cabal b/ghc-tags-plugin.cabal --- a/ghc-tags-plugin.cabal +++ b/ghc-tags-plugin.cabal @@ -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 diff --git a/lib/Plugin/GhcTags.hs b/lib/Plugin/GhcTags.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags.hs @@ -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 "" 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 diff --git a/lib/Plugin/GhcTags/CTag.hs b/lib/Plugin/GhcTags/CTag.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/CTag.hs @@ -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" diff --git a/lib/Plugin/GhcTags/FileLock.hs b/lib/Plugin/GhcTags/FileLock.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/FileLock.hs @@ -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) diff --git a/lib/Plugin/GhcTags/Generate.hs b/lib/Plugin/GhcTags/Generate.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags/Generate.hs +++ /dev/null @@ -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 diff --git a/lib/Plugin/GhcTags/Options.hs b/lib/Plugin/GhcTags/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Options.hs @@ -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 diff --git a/lib/Plugin/GhcTags/Tag.hs b/lib/Plugin/GhcTags/Tag.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags/Tag.hs +++ /dev/null @@ -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 #-} diff --git a/lib/Plugin/GhcTags/Vim.hs b/lib/Plugin/GhcTags/Vim.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags/Vim.hs +++ /dev/null @@ -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 diff --git a/lib/Plugin/GhcTags/Vim/Formatter.hs b/lib/Plugin/GhcTags/Vim/Formatter.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags/Vim/Formatter.hs +++ /dev/null @@ -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 diff --git a/lib/Plugin/GhcTags/Vim/Parser.hs b/lib/Plugin/GhcTags/Vim/Parser.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags/Vim/Parser.hs +++ /dev/null @@ -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 diff --git a/src/Plugin/GhcTags.hs b/src/Plugin/GhcTags.hs deleted file mode 100644 --- a/src/Plugin/GhcTags.hs +++ /dev/null @@ -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) diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -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 - ] diff --git a/test/Test/Golden/Parser.hs b/test/Test/Golden/Parser.hs deleted file mode 100644 --- a/test/Test/Golden/Parser.hs +++ /dev/null @@ -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) diff --git a/test/Test/Tag.hs b/test/Test/Tag.hs deleted file mode 100644 --- a/test/Test/Tag.hs +++ /dev/null @@ -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 diff --git a/test/Test/Tag/Generators.hs b/test/Test/Tag/Generators.hs deleted file mode 100644 --- a/test/Test/Tag/Generators.hs +++ /dev/null @@ -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) - ] diff --git a/test/Test/Vim.hs b/test/Test/Vim.hs deleted file mode 100644 --- a/test/Test/Vim.hs +++ /dev/null @@ -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')