ghc-tags (empty) → 1.0
raw patch · 19 files changed
+3182/−0 lines, 19 filesdep +aesondep +asyncdep +attoparsec
Dependencies added: aeson, async, attoparsec, base, bytestring, containers, deepseq, directory, filepath, ghc, ghc-boot, ghc-lib, ghc-paths, optparse-applicative, process, stm, temporary, text, time, unordered-containers, vector, yaml
Files
- CHANGELOG.md +2/−0
- LICENSE +373/−0
- README.md +104/−0
- ghc-tags.cabal +93/−0
- src/GhcTags.hs +8/−0
- src/GhcTags/CTag.hs +17/−0
- src/GhcTags/CTag/Formatter.hs +134/−0
- src/GhcTags/CTag/Header.hs +192/−0
- src/GhcTags/CTag/Parser.hs +248/−0
- src/GhcTags/CTag/Utils.hs +58/−0
- src/GhcTags/Config/Args.hs +92/−0
- src/GhcTags/Config/Project.hs +167/−0
- src/GhcTags/ETag.hs +22/−0
- src/GhcTags/ETag/Formatter.hs +103/−0
- src/GhcTags/ETag/Parser.hs +86/−0
- src/GhcTags/Ghc.hs +559/−0
- src/GhcTags/Tag.hs +457/−0
- src/GhcTags/Utils.hs +25/−0
- src/Main.hs +442/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# ghc-tags-1.0 (2021-05-17)+* Initial release.
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,104 @@+# ghc-tags++[](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster)++A command line tool that generates etags (Emacs) and ctags (Vim and other+editors) for efficient code navigation (jump to definition).++Main features:+* Leverages GHC API to obtain accurate information.+* Uses multiple CPU cores when processing source files.+* Supports fast incremental updates.++Supported file extensions:+* `.hs`+* `.hs-boot`+* `.lhs`+* `.x` (requires `alex`)+* `.hsc` (requires `hsc2hs`)++## Usage++For simple projects, i.e. the ones that don't use C pre-processor in non-trivial+ways nor include any C sources it should be enough to execute `ghc-tags -e` (for+etags) or `ghc-tags -c` (for ctags) in the root directory of the project.++For more complicated projects you need to create the configuration file+(`ghc-tags.yaml` by default). It can contain the following keys:++* `source_paths` - a list of paths for `ghc-tags` to process. Directories are+ traversed recursively.+* `exclude_paths` - a list of paths for `ghc-tags` to exclude from processing.+* `language` - the flavour of Haskell, either `Haskell98` or `Haskell2010`.+* `extensions` - a list of GHC language extensions to enable when parsing. Note+ that GHC needs much less extensions for parsing alone, so you should almost+ never need to override this.+* `cpp_includes` - include paths for the C pre-processor.+* `cpp_options` - other options for the C pre-processor, e.g. defines (usually+ undefined `MIN_VERSION_x` macros will go here).++If any of these keys is not specified, an appropriate default value will be+picked instead. You can inspect the defaults by executing `ghc-tags --default`.++**Note:** it is possible to specify multiple project configurations in the+configuration file by separating them with `---`. For example, here is a+configuration for GHC on Linux (compiler, utils and base):++```yaml+source_paths:+- compiler++cpp_includes:+- _build/stage1/compiler/build+- compiler+- includes/dist-derivedconstants/header++---++source_paths:+- libraries/base++exclude_paths:+- libraries/base/GHC/Conc/POSIX/Const.hsc+- libraries/base/GHC/Event/Windows.hsc+- libraries/base/GHC/Event/Windows/ConsoleEvent.hsc+- libraries/base/GHC/Event/Windows/FFI.hsc+- libraries/base/GHC/IO/Windows/Handle.hsc+- libraries/base/System/CPUTime/Windows.hsc+- libraries/base/tests++cpp_includes:+- _build/stage1/libraries/base/build/include+- includes+- libraries/base/include++---++source_paths:+- libraries/ghc-bignum++exclude_paths:+- libraries/ghc-bignum/src/GHC/Num/Backend/Selected.hs++cpp_includes:+- libraries/ghc-bignum/include++---++source_paths:+- libraries/ghc-boot+- libraries/ghc-boot-th+- libraries/ghc-compact+- libraries/ghc-heap+- libraries/ghc-prim++exclude_paths:+- libraries/ghc-compact/tests+- libraries/ghc-heap/tests+- libraries/ghc-prim/tests+```++## Acknowledgments++Thanks to Marcin Szamotulski for his work on+[ghc-tags-plugin](https://github.com/coot/ghc-tags-plugin) `ghc-tags` is based on.
+ ghc-tags.cabal view
@@ -0,0 +1,93 @@+cabal-version: 2.4+name: ghc-tags+version: 1.0+synopsis: Utility for generating ctags and etags with GHC API.+description: Utility for generating etags (Emacs) and ctags (Vim and other+ editors) with GHC API for efficient project navigation.+license: MPL-2.0+license-file: LICENSE+author: Andrzej Rybczak+maintainer: andrzej@rybczak.net+copyright: (c) 2021, Andrzej Rybczak+category: Development+extra-source-files: CHANGELOG.md+ README.md+homepage: https://github.com/arybczak/ghc-tags+bug-reports: https://github.com/arybczak/ghc-tags/issues+tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1++source-repository head+ type: git+ location: https://github.com/arybczak/ghc-tags++flag ghc-lib+ default: False+ manual: True+ description: Use ghc-lib even when compiling with compatible GHC version.++executable ghc-tags+ ghc-options: -Wall -threaded -rtsopts++ if !flag(ghc-lib) && impl(ghc == 9.0.*)+ build-depends: ghc, ghc-boot+ else+ build-depends: ghc-lib == 9.0.*++ build-depends: base >=4.13 && <5+ , aeson+ , async+ , attoparsec+ , bytestring+ , containers+ , deepseq+ , directory+ , filepath+ , ghc-paths+ , stm+ , optparse-applicative+ , process+ , temporary+ , text+ , time+ , unordered-containers+ , vector+ , yaml++ hs-source-dirs: src++ main-is: Main.hs++ other-modules: GhcTags+ GhcTags.Config.Args+ GhcTags.Config.Project+ GhcTags.Ghc+ GhcTags.Tag+ GhcTags.CTag+ GhcTags.CTag.Header+ GhcTags.CTag.Parser+ GhcTags.CTag.Formatter+ GhcTags.CTag.Utils+ GhcTags.ETag+ GhcTags.ETag.Parser+ GhcTags.ETag.Formatter+ GhcTags.Utils+ Paths_ghc_tags++ autogen-modules: Paths_ghc_tags++ default-language: Haskell2010+ default-extensions: BangPatterns+ , DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , KindSignatures+ , LambdaCase+ , MultiWayIf+ , NamedFieldPuns+ , OverloadedStrings+ , RecordWildCards+ , ScopedTypeVariables+ , StrictData+ , StandaloneDeriving+ , TupleSections
+ src/GhcTags.hs view
@@ -0,0 +1,8 @@+module GhcTags+ ( module GhcTags.Ghc+ , module GhcTags.Tag+ ) where+++import GhcTags.Ghc+import GhcTags.Tag
+ src/GhcTags/CTag.hs view
@@ -0,0 +1,17 @@+module GhcTags.CTag+ ( module X+ , compareTags+ ) where++import GhcTags.CTag.Header as X+import GhcTags.CTag.Parser as X+import GhcTags.CTag.Formatter as X+import GhcTags.CTag.Utils as X++import GhcTags.Tag (CTag)+import qualified GhcTags.Tag as Tag++-- | A specialisation of 'GhcTags.Tag.compareTags' to 'CTag's.+--+compareTags :: CTag -> CTag -> Ordering+compareTags = Tag.compareTags
+ src/GhcTags/CTag/Formatter.hs view
@@ -0,0 +1,134 @@+-- | 'bytestring''s 'Builder' for a 'Tag'+--+module GhcTags.CTag.Formatter+ ( formatTagsFile+ -- * format a ctag+ , formatTag+ -- * format a pseudo-ctag+ , formatHeader+ ) where++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BS+import Data.Char (isAscii)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text.Encoding as Text++import GhcTags.Tag+import GhcTags.Utils (endOfLine)+import GhcTags.CTag.Header+import GhcTags.CTag.Utils+++-- | 'ByteString' 'Builder' for a single line.+--+formatTag :: TagFileName -> CTag -> Builder+formatTag fileName Tag { tagName, tagAddr, tagKind, tagFields = TagFields tagFields } =++ (BS.byteString . Text.encodeUtf8 . getTagName $ tagName)+ <> BS.charUtf8 '\t'++ <> (BS.byteString . Text.encodeUtf8 . getTagFileName $ fileName)+ <> BS.charUtf8 '\t'++ <> formatTagAddress 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.stringUtf8 endOfLine++ where++ formatTagAddress :: CTagAddress -> Builder+ formatTagAddress (TagLineCol lineNo _colNo) =+ BS.intDec lineNo -- Vim only allows to use ranges; there's no way to+ -- specify column (`c|` command is not allowed)+ formatTagAddress (TagLine lineNo) =+ BS.intDec lineNo+ formatTagAddress (TagCommand exCommand) =+ BS.byteString . Text.encodeUtf8 . getExCommand $ exCommand ++ formatKindChar :: CTagKind -> Builder+ formatKindChar tk =+ case tagKindToChar tk of+ Nothing -> mempty+ Just c | isAscii c -> BS.charUtf8 '\t' <> BS.charUtf8 c+ | otherwise -> BS.stringUtf8 "\tkind:" <> BS.charUtf8 c+++formatField :: TagField -> Builder+formatField TagField { fieldName, fieldValue } =+ BS.byteString (Text.encodeUtf8 fieldName)+ <> BS.charUtf8 ':'+ <> BS.byteString (Text.encodeUtf8 fieldValue)+++formatHeader :: Header -> Builder+formatHeader Header { headerType, headerLanguage, headerArg, headerComment } =+ case headerType of+ FileEncoding ->+ formatTextHeaderArgs "FILE_ENCODING" headerLanguage headerArg headerComment+ FileFormat ->+ formatIntHeaderArgs "FILE_FORMAT" headerLanguage headerArg headerComment+ FileSorted ->+ formatIntHeaderArgs "FILE_SORTED" headerLanguage headerArg headerComment+ OutputMode ->+ formatTextHeaderArgs "OUTPUT_MODE" headerLanguage headerArg headerComment+ KindDescription ->+ formatTextHeaderArgs "KIND_DESCRIPTION" headerLanguage headerArg headerComment+ KindSeparator ->+ formatTextHeaderArgs "KIND_SEPARATOR" headerLanguage headerArg headerComment+ ProgramAuthor ->+ formatTextHeaderArgs "PROGRAM_AUTHOR" headerLanguage headerArg headerComment+ ProgramName ->+ formatTextHeaderArgs "PROGRAM_NAME" headerLanguage headerArg headerComment+ ProgramUrl ->+ formatTextHeaderArgs "PROGRAM_URL" headerLanguage headerArg headerComment+ ProgramVersion ->+ formatTextHeaderArgs "PROGRAM_VERSION" headerLanguage headerArg headerComment+ ExtraDescription ->+ formatTextHeaderArgs "EXTRA_DESCRIPTION" headerLanguage headerArg headerComment+ FieldDescription ->+ formatTextHeaderArgs "FIELD_DESCRIPTION" headerLanguage headerArg headerComment+ PseudoTag name ->+ formatHeaderArgs (BS.byteString . Text.encodeUtf8)+ "!_" name headerLanguage headerArg headerComment+ where+ formatHeaderArgs :: (ty -> Builder)+ -> String+ -> Text+ -> Maybe Text+ -> ty+ -> Text+ -> Builder+ formatHeaderArgs formatArg prefix headerName language arg comment =+ BS.stringUtf8 prefix+ <> BS.byteString (Text.encodeUtf8 headerName)+ <> foldMap ((BS.charUtf8 '!' <>) . BS.byteString . Text.encodeUtf8) language+ <> BS.charUtf8 '\t'+ <> formatArg arg+ <> BS.stringUtf8 "\t/"+ <> BS.byteString (Text.encodeUtf8 comment)+ <> BS.charUtf8 '/'+ <> BS.stringUtf8 endOfLine++ formatTextHeaderArgs = formatHeaderArgs (BS.byteString . Text.encodeUtf8) "!_TAG_"+ formatIntHeaderArgs = formatHeaderArgs BS.intDec "!_TAG_"+++-- | 'ByteString' 'Builder' for vim 'Tag' file.+--+formatTagsFile :: [Header] -- ^ Headers+ -> CTagMap -- ^ 'CTag's+ -> Builder+formatTagsFile headers tags =+ foldMap formatHeader headers+ <> Map.foldMapWithKey (foldMap . formatTag) tags
+ src/GhcTags/CTag/Header.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}++module GhcTags.CTag.Header+ ( Header (..)+ , defaultHeaders+ , HeaderType (..)+ , SomeHeaderType (..)+ -- * Utils+ , SingHeaderType (..)+ , headerTypeSing+ ) where++import Data.Version+import qualified Data.Text as T++import Paths_ghc_tags (version)++-- | A type safe representation of a /ctag/ header.+--+data Header where+ Header :: forall ty. Show ty =>+ { headerType :: HeaderType ty+ , headerLanguage :: Maybe T.Text+ , headerArg :: ty+ , headerComment :: T.Text+ }+ -> Header++instance Eq Header where+ Header { headerType = headerType0+ , headerLanguage = headerLanguage0+ , headerArg = headerArg0+ , headerComment = headerComment0+ }+ ==+ Header { headerType = headerType1+ , headerLanguage = headerLanguage1+ , headerArg = headerArg1+ , headerComment = headerComment1+ } =+ case (headerType0, headerType1) of+ (FileEncoding, FileEncoding) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (FileFormat, FileFormat) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (FileSorted, FileSorted) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (OutputMode, OutputMode) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (KindDescription, KindDescription) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (KindSeparator, KindSeparator) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (ProgramAuthor, ProgramAuthor) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (ProgramName, ProgramName) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (ProgramUrl, ProgramUrl) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (ProgramVersion, ProgramVersion) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (ExtraDescription, ExtraDescription) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (FieldDescription, FieldDescription) ->+ headerArg0 == headerArg1 &&+ headerLanguage0 == headerLanguage1 &&+ headerComment0 == headerComment1+ (PseudoTag name0, PseudoTag name1) ->+ name0 == name1 &&+ headerLanguage0 == headerLanguage1 &&+ headerArg0 == headerArg1 &&+ headerComment0 == headerComment1+ _ -> False++deriving instance Show Header++-- | Enumeration of header type and values of their corresponding argument+--+data HeaderType ty where+ FileEncoding :: HeaderType T.Text+ FileFormat :: HeaderType Int+ FileSorted :: HeaderType Int+ OutputMode :: HeaderType T.Text+ KindDescription :: HeaderType T.Text+ KindSeparator :: HeaderType T.Text+ ProgramAuthor :: HeaderType T.Text+ ProgramName :: HeaderType T.Text+ ProgramUrl :: HeaderType T.Text+ ProgramVersion :: HeaderType T.Text++ ExtraDescription :: HeaderType T.Text+ FieldDescription :: HeaderType T.Text+ PseudoTag :: T.Text -> HeaderType T.Text++deriving instance Eq (HeaderType ty)+deriving instance Ord (HeaderType ty)+deriving instance Show (HeaderType ty)++-- | Existential wrapper.+--+data SomeHeaderType where+ SomeHeaderType :: forall ty. HeaderType ty -> SomeHeaderType+++-- | Singletons which makes it easier to work with 'HeaderType'+--+data SingHeaderType ty where+ SingHeaderTypeText :: SingHeaderType T.Text+ SingHeaderTypeInt :: SingHeaderType Int+++headerTypeSing :: HeaderType ty -> SingHeaderType ty+headerTypeSing = \case+ FileEncoding -> SingHeaderTypeText+ FileFormat -> SingHeaderTypeInt+ FileSorted -> SingHeaderTypeInt+ OutputMode -> SingHeaderTypeText+ KindDescription -> SingHeaderTypeText+ KindSeparator -> SingHeaderTypeText+ ProgramAuthor -> SingHeaderTypeText+ ProgramName -> SingHeaderTypeText+ ProgramUrl -> SingHeaderTypeText+ ProgramVersion -> SingHeaderTypeText++ ExtraDescription -> SingHeaderTypeText+ FieldDescription -> SingHeaderTypeText+ PseudoTag {} -> SingHeaderTypeText++----------------------------------------++defaultHeaders :: [Header]+defaultHeaders =+ [ Header FileFormat Nothing 2 ""+ , Header FileSorted Nothing 1 ""+ , Header FileEncoding Nothing "utf-8" ""+ , Header ProgramName Nothing "ghc-tags" ""+ , Header ProgramUrl Nothing "https://hackage.haskell.org/package/ghc-tags" ""+ , Header ProgramVersion Nothing (T.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"
+ src/GhcTags/CTag/Parser.hs view
@@ -0,0 +1,248 @@+-- | Parser combinators for vim style tags (ctags)+--+module GhcTags.CTag.Parser+ ( parseTagsFile+ , parseTagLine+ -- * parse a ctag+ , parseTag+ -- * parse a pseudo-ctag+ , parseHeader+ ) where++import Control.Arrow ((***), second)+import Control.Applicative (many, (<|>))+import Data.Attoparsec.Text (Parser, (<?>))+import qualified Data.Attoparsec.Text as AT+import Data.Either (partitionEithers)+import Data.Functor (void, ($>))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text++import GhcTags.Tag+import qualified GhcTags.Utils as Utils+import GhcTags.CTag.Header+import GhcTags.CTag.Utils+++-- | Parser for a 'CTag' from a single text line.+--+parseTag :: Parser (TagFileName, CTag)+parseTag =+ (\tagName tagFileName tagAddr (tagKind, tagFields)+ -> (tagFileName, Tag { tagName+ , tagAddr+ , tagKind+ , tagFields+ , tagDefinition = NoTagDefinition+ })+ )+ <$> parseTagName+ <* separator++ <*> parseFileName+ <* separator++ -- includes an optional ';"' separator+ <*> parseTagAddress++ <*> ( -- kind field followed by list of fields or end of line, e.g.+ -- '(TagField, CTagFields)'.+ ((,) <$> ( separator *> parseKindField )+ <*> ( separator *> parseFields <* endOfLine+ <|>+ endOfLine $> mempty)+ )++ -- 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 <* endOfLine+ <|>+ endOfLine $> mempty+ )++ -- 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 <* endOfLine+ <|>+ endOfLine $> mempty+ )+ <|> endOfLine $> (NoKind, mempty)+ )++ where+ separator :: Parser Char+ separator = AT.char '\t'++ parseTagName :: Parser TagName+ parseTagName = TagName <$> AT.takeWhile (/= '\t')+ <?> "parsing tag name failed"++ parseFileName :: Parser TagFileName+ parseFileName = TagFileName <$> AT.takeWhile (/= '\t')++ parseExCommand :: Parser ExCommand+ parseExCommand = (\x -> ExCommand $ Text.take (Text.length x - 1) x)+ <$> AT.scan "" go+ <* AT.anyChar+ where+ -- go until either eol or ';"' sequence is found.+ go :: String -> Char -> Maybe String++ go !s c | -- eol+ take (length Utils.endOfLine) (c : s)+ == reverse Utils.endOfLine+ = Nothing++ | -- ';"' sequence+ l == "\";" = Nothing++ | otherwise = Just l+ where+ l = take 2 (c : s)++ -- We only parse `TagLine` or `TagCommand`.+ parseTagAddress :: Parser CTagAddress+ parseTagAddress =+ TagLine <$> AT.decimal <* (endOfLine <|> void (AT.string ";\""))+ <|>+ TagCommand <$> parseExCommand++ parseKindField :: Parser CTagKind+ parseKindField =+ charToTagKind <$>+ (AT.string "kind:" *> AT.satisfy notTabOrNewLine)++ parseFields :: Parser CTagFields+ parseFields = TagFields <$> AT.sepBy parseField separator+++parseField :: Parser TagField+parseField =+ TagField+ <$> AT.takeWhile (\x -> x /= ':' && notTabOrNewLine x)+ <* AT.char ':'+ <*> AT.takeWhile notTabOrNewLine+++-- | A vim-style tag file parser.+--+parseTags :: Parser ([Header], CTagMap)+parseTags = second (Map.fromListWith (++) . map (second (:[])))+ . partitionEithers+ <$> many parseTagLine+++-- | Parse either a header line ot a 'CTag'.+--+parseTagLine :: Parser (Either Header (TagFileName, CTag))+parseTagLine =+ AT.eitherP+ (parseHeader <?> "failed parsing tag")+ (parseTag <?> "failed parsing header")+++parseHeader :: Parser Header+parseHeader = do+ e <- AT.string "!_TAG_" $> False+ <|>+ AT.string "!_" $> True+ case e of+ True ->+ flip parsePseudoTagArgs (AT.takeWhile notTabOrNewLine)+ . PseudoTag+ =<< AT.takeWhile (\x -> notTabOrNewLine x && x /= '!')+ False -> do+ headerType <-+ AT.string "FILE_ENCODING" $> SomeHeaderType FileEncoding+ <|> AT.string "FILE_FORMAT" $> SomeHeaderType FileFormat+ <|> AT.string "FILE_SORTED" $> SomeHeaderType FileSorted+ <|> AT.string "OUTPUT_MODE" $> SomeHeaderType OutputMode+ <|> AT.string "KIND_DESCRIPTION" $> SomeHeaderType KindDescription+ <|> AT.string "KIND_SEPARATOR" $> SomeHeaderType KindSeparator+ <|> AT.string "PROGRAM_AUTHOR" $> SomeHeaderType ProgramAuthor+ <|> AT.string "PROGRAM_NAME" $> SomeHeaderType ProgramName+ <|> AT.string "PROGRAM_URL" $> SomeHeaderType ProgramUrl+ <|> AT.string "PROGRAM_VERSION" $> SomeHeaderType ProgramVersion+ <|> AT.string "EXTRA_DESCRIPTION" $> SomeHeaderType ExtraDescription+ <|> AT.string "FIELD_DESCRIPTION" $> SomeHeaderType FieldDescription+ case headerType of+ SomeHeaderType ht@FileEncoding ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@FileFormat ->+ parsePseudoTagArgs ht AT.decimal+ SomeHeaderType ht@FileSorted ->+ parsePseudoTagArgs ht AT.decimal+ SomeHeaderType ht@OutputMode ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@KindDescription ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@KindSeparator ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@ProgramAuthor ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@ProgramName ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@ProgramUrl ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@ProgramVersion ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@ExtraDescription ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType ht@FieldDescription ->+ parsePseudoTagArgs ht (AT.takeWhile notTabOrNewLine)+ SomeHeaderType PseudoTag {} ->+ error "parseHeader: impossible happened"++ where+ parsePseudoTagArgs :: Show ty+ => HeaderType ty+ -> Parser ty+ -> Parser Header+ parsePseudoTagArgs ht parseArg =+ Header ht+ <$> ( (Just <$> (AT.char '!' *> AT.takeWhile notTabOrNewLine))+ <|> pure Nothing+ )+ <*> (AT.char '\t' *> parseArg)+ <*> (AT.char '\t' *> parseComment)++ parseComment :: Parser Text+ parseComment =+ AT.char '/'+ *> (Text.init <$> AT.takeWhile notNewLine)+ <* endOfLine++++-- | Parse a vim-style tag file.+--+parseTagsFile :: Text+ -> IO (Either String ([Header], CTagMap))+parseTagsFile =+ fmap AT.eitherResult+ . AT.parseWith (pure mempty) parseTags+++--+-- Utils+--+++-- | Unlike 'AT.endOfLine', it also matches for a single '\r' characters (which+-- marks enf of lines on darwin).+--+endOfLine :: Parser ()+endOfLine = AT.string "\r\n" $> ()+ <|> AT.char '\r' $> ()+ <|> AT.char '\n' $> ()+++notTabOrNewLine :: Char -> Bool+notTabOrNewLine = \x -> x /= '\t' && notNewLine x++notNewLine :: Char -> Bool+notNewLine = \x -> x /= '\n' && x /= '\r'
+ src/GhcTags/CTag/Utils.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE GADTs #-}++module GhcTags.CTag.Utils+ ( tagKindToChar+ , charToTagKind+ ) where++import GhcTags.Tag++tagKindToChar :: CTagKind -> Maybe Char+tagKindToChar tk = case tk of+ TkModule -> Just 'M'+ TkTerm -> Just '`'+ TkFunction -> Just 'λ'+ TkTypeConstructor -> Just 'Λ'+ TkDataConstructor -> Just 'c'+ TkGADTConstructor -> Just 'g'+ TkRecordField -> Just 'r'+ TkTypeSynonym -> Just '≡'+ TkTypeSignature -> Just '⊢'+ TkPatternSynonym -> Just 'p'+ TkTypeClass -> Just 'C'+ TkTypeClassMember -> Just 'm'+ TkTypeClassInstance -> Just 'i'+ TkTypeFamily -> Just 'f'+ TkTypeFamilyInstance -> Just 'F'+ TkDataTypeFamily -> Just 'd'+ TkDataTypeFamilyInstance -> Just 'D'+ TkForeignImport -> Just 'I'+ TkForeignExport -> Just 'E'++ CharKind c -> Just c+ NoKind -> Nothing+++charToTagKind :: Char -> CTagKind+charToTagKind c = case c of+ 'M' -> TkModule+ '`' -> TkTerm+ 'λ' -> TkFunction+ 'Λ' -> TkTypeConstructor+ 'c' -> TkDataConstructor+ 'g' -> TkGADTConstructor+ 'r' -> TkRecordField+ '≡' -> TkTypeSynonym+ '⊢' -> TkTypeSignature+ 'p' -> TkPatternSynonym+ 'C' -> TkTypeClass+ 'm' -> TkTypeClassMember+ 'i' -> TkTypeClassInstance+ 'f' -> TkTypeFamily+ 'F' -> TkTypeFamilyInstance+ 'd' -> TkDataTypeFamily+ 'D' -> TkDataTypeFamilyInstance+ 'I' -> TkForeignImport+ 'E' -> TkForeignExport++ _ -> CharKind c
+ src/GhcTags/Config/Args.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE ApplicativeDo #-}+module GhcTags.Config.Args where++import Data.Version+import Options.Applicative++import GhcTags.Config.Project+import Paths_ghc_tags (version)++-- | Generate either ctags or etags.+data TagType = CTags | ETags+ deriving Show++defaultOutputFile :: TagType -> FilePath+defaultOutputFile CTags = "tags"+defaultOutputFile ETags = "TAGS"++-- | Get source paths from the configuration file or command line arguments.+data SourcePaths+ = SourceArgs [FilePath]+ | ConfigFile FilePath+ deriving Show++data Args = Args+ { aTagType :: TagType+ , aTagFile :: FilePath+ , aThreads :: Int+ , aSourcePaths :: SourcePaths+ } deriving Show++argsParser :: Int -> Parser Args+argsParser defaultThreads = do+ aTagType <- ctags <|> etags+ aTagFile0 <- tagFile+ aThreads <- threads+ aSourcePaths <- (SourceArgs <$> sourcePaths) <|> (ConfigFile <$> configFile)+ pure $ Args { aTagFile = if null aTagFile0+ then defaultOutputFile aTagType+ else aTagFile0+ , ..+ }+ where+ ctags :: Parser TagType+ ctags = flag' CTags $ long "ctags"+ <> short 'c'+ <> help "Generate ctags"++ etags :: Parser TagType+ etags = flag' ETags $ long "etags"+ <> short 'e'+ <> help "Generate etags"++ tagFile :: Parser FilePath+ tagFile = strOption $ long "output"+ <> short 'o'+ <> metavar "FILE"+ <> help "Output file"+ <> value ""+ <> showDefaultWith (const "TAGS (etags) or tags (ctags)")++ configFile :: Parser FilePath+ configFile = strOption $ long "config"+ <> metavar "FILE"+ <> value "ghc-tags.yaml"+ <> showDefaultWith id+ <> help "Configuration file"++ sourcePaths :: Parser [FilePath]+ sourcePaths = some . argument str $ metavar "<source paths...>"++ threads :: Parser Int+ threads = option auto $ long "threads"+ <> short 'j'+ <> metavar "NUMBER"+ <> value defaultThreads+ <> showDefault+ <> help "Number of threads to use"++parseArgs :: Int -> [String] -> IO Args+parseArgs defaultThreads = handleParseResult . execParserPure defaultPrefs opts+ where+ opts = info+ (argsParser defaultThreads <**> defaultConfigFlag <**> versionFlag <**> helper)+ fullDesc++ defaultConfigFlag = infoOption (ppProjectConfig defaultProjectConfig)+ $ long "default"+ <> help "Show a default configuration file"++ versionFlag = infoOption (showVersion version)+ $ long "version"+ <> help "Show version"
+ src/GhcTags/Config/Project.hs view
@@ -0,0 +1,167 @@+module GhcTags.Config.Project where++import Data.Aeson+import Data.Aeson.Types+import Data.Maybe+import Data.List+import Data.Ord+import GHC.Driver.Flags+import GHC.Driver.Session+import GHC.LanguageExtensions+import GHC.Settings+import System.Directory+import qualified Data.ByteString.Char8 as BS+import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Yaml as Y+import qualified Data.Yaml.Pretty as Y++data ProjectConfig = ProjectConfig+ { pcSourcePaths :: [FilePath]+ , pcExcludePaths :: [FilePath]+ , pcLanguage :: Language+ , pcExtensions :: [Extension]+ , pcCppIncludes :: [FilePath]+ , pcCppOptions :: [String]+ }++defaultProjectConfig :: ProjectConfig+defaultProjectConfig = ProjectConfig+ { pcSourcePaths = [ "."+ ]+ , pcExcludePaths = [ ".stack-work"+ , "dist"+ , "dist-newstyle"+ ]+ , pcLanguage = Haskell2010+ , pcExtensions = [ BangPatterns+ , ExplicitForAll+ , LambdaCase+ , MultiWayIf+ , OverloadedLabels+ , TypeApplications+ ]+ , pcCppIncludes = []+ , pcCppOptions = []+ }++getProjectConfigs :: FilePath -> IO [ProjectConfig]+getProjectConfigs file = doesFileExist file >>= \case+ True -> Y.decodeAllFileEither file >>= \case+ Left e -> do+ putStrLn $ file ++ ": " ++ Y.prettyPrintParseException e+ pure []+ Right pcs -> pure pcs+ False -> pure [defaultProjectConfig]++ppProjectConfig :: ProjectConfig -> String+ppProjectConfig = BS.unpack . Y.encodePretty conf+ where+ conf = Y.setConfCompare (keyOrder projectConfigKeys) Y.defConfig++ keyOrder :: [T.Text] -> T.Text -> T.Text -> Ordering+ keyOrder ks = comparing $ \k -> fromMaybe maxBound (elemIndex k ks)++adjustDynFlags :: ProjectConfig -> DynFlags -> DynFlags+adjustDynFlags ProjectConfig{..} = applyCppOptions+ . applyCppIncludes+ . applyExtensions+ . applyLanguage+ where+ applyLanguage fs = lang_set fs (Just pcLanguage)++ applyExtensions fs = foldl' xopt_set fs pcExtensions++ applyCppIncludes fs =+ fs { includePaths = addGlobalInclude (includePaths fs) pcCppIncludes+ }++ applyCppOptions fs = foldr addOptP fs pcCppOptions+ where+ addOptP opt acc =+ let ts = toolSettings acc+ in acc { toolSettings = ts+ { toolSettings_opt_P = opt : toolSettings_opt_P ts+ }+ }++----------------------------------------+-- JSON instances++instance ToJSON ProjectConfig where+ toJSON ProjectConfig{..} = object+ [ "source_paths" .= pcSourcePaths+ , "exclude_paths" .= pcExcludePaths+ , "language" .= show pcLanguage+ , "extensions" .= map showExtension pcExtensions+ , "cpp_includes" .= pcCppIncludes+ , "cpp_options" .= pcCppOptions+ ]++instance FromJSON ProjectConfig where+ parseJSON (Object v) = do+ checkUnknownKeys $ HM.keys v+ pcSourcePaths <- def pcSourcePaths <$> v .:! "source_paths"+ pcExcludePaths <- def pcExcludePaths <$> v .:! "exclude_paths"+ pcLanguage <- def pcLanguage <$> explicitParseFieldMaybe'+ parseLanguage v+ "language"+ pcExtensions <- def pcExtensions <$> explicitParseFieldMaybe'+ (listParser parseExtension) v+ "extensions"+ pcCppIncludes <- def pcCppIncludes <$> v .:! "cpp_includes"+ pcCppOptions <- def pcCppOptions <$> v .:! "cpp_options"+ pure ProjectConfig{..}+ where+ def f = fromMaybe (f defaultProjectConfig)++ checkUnknownKeys :: [T.Text] -> Parser ()+ checkUnknownKeys keys = case keys \\ projectConfigKeys of+ [] -> pure ()+ [k] -> fail $ "unknown key: " ++ T.unpack k+ ks -> fail $ "unknown keys: " ++ intercalate ", " (map T.unpack ks)++ parseLanguage :: Value -> Parser Language+ parseLanguage (String t) = case readLanguage t of+ Just lang -> pure lang+ Nothing -> fail $ "unknown language: " ++ T.unpack t+ parseLanguage inv = typeMismatch "String" inv++ parseExtension :: Value -> Parser Extension+ parseExtension (String t) = case readExtension t of+ Just ext -> pure ext+ Nothing -> fail $ "unknown extension: " ++ T.unpack t+ parseExtension inv = typeMismatch "String" inv++ parseJSON v = prependFailure "parsing project configuration failed: " $+ typeMismatch "Object" v++projectConfigKeys :: [T.Text]+projectConfigKeys = [ "source_paths"+ , "exclude_paths"+ , "language"+ , "extensions"+ , "cpp_includes"+ , "cpp_options"+ ]++----------------------------------------+-- Utils++readLanguage :: T.Text -> Maybe Language+readLanguage "Haskell98" = Just Haskell98+readLanguage "Haskell2010" = Just Haskell2010+readLanguage _ = Nothing++showExtension :: Extension -> T.Text+showExtension Cpp = "CPP"+showExtension ext = T.pack $ show ext++readExtension :: T.Text -> Maybe Extension+readExtension ext = ext `Map.lookup` exts+ where+ exts :: Map.Map T.Text Extension+ exts = Map.fromList . (("CPP", Cpp) :)+ . map (\e -> (T.pack $ show e, e))+ $ filter (/= Cpp) [minBound..maxBound]
+ src/GhcTags/ETag.hs view
@@ -0,0 +1,22 @@+module GhcTags.ETag+ ( module X+ , compareTags+ ) where++import Data.Function (on)++import GhcTags.ETag.Formatter as X+import GhcTags.ETag.Parser as X++import GhcTags.Tag ( Tag (..)+ , ETag+ )+++-- | Order 'ETag's according to addr, name and kind.+--+compareTags :: ETag -> ETag -> Ordering+compareTags t0 t1 =+ on compare tagAddr t0 t1+ <> on compare tagName t0 t1+ <> on compare tagKind t0 t1
+ src/GhcTags/ETag/Formatter.hs view
@@ -0,0 +1,103 @@+-- | Simple etags formatter. See <https://en.wikipedia.org/wiki/Ctags#Etags>+--+module GhcTags.ETag.Formatter+ ( withByteOffset+ , formatETagsFile + , formatTagsFile+ , formatTag+ , BuilderWithSize (..)+ ) where++import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import Data.Foldable (foldl')+import qualified Data.Map.Strict as Map+import qualified Data.Text.Encoding as Text++import GhcTags.Tag+++-- | A product of two monoids: 'Builder' and 'Sum'.+--+data BuilderWithSize = BuilderWithSize {+ builder :: Builder,+ builderSize :: Int+ }++instance Semigroup BuilderWithSize where+ BuilderWithSize b0 s0 <> BuilderWithSize b1 s1 =+ BuilderWithSize (b0 <> b1) (s0 + s1)++instance Monoid BuilderWithSize where+ mempty = BuilderWithSize mempty 0++computeByteOffset+ :: [Int]+ -- ^ lengths of lines+ -> ETagAddress+ -> ETagAddress+computeByteOffset ll (TagLineCol line col) = TagLineCol line byteOffset+ where+ byteOffset =+ foldl' (+) 0 (take (pred line) ll)+ + col++withByteOffset :: [Int] -> ETag -> ETag+withByteOffset ll tag@Tag { tagAddr } = tag { tagAddr = computeByteOffset ll tagAddr }++formatTag :: ETag -> BuilderWithSize+formatTag Tag {tagName, tagAddr = TagLineCol lineNr byteOffset, tagDefinition} =+ flip BuilderWithSize tagSize $+ BB.byteString tagDefinitionBS+ <> BB.charUtf8 '\DEL' -- or '\x7f'+ <> BB.byteString tagNameBS+ <> BB.charUtf8 '\SOH' -- or '\x01'+ <> BB.intDec lineNr+ <> BB.charUtf8 ','+ <> BB.intDec byteOffset+ <> BB.stringUtf8 endOfLine+ where+ tagDefinitionBS = case tagDefinition of+ NoTagDefinition -> tagNameBS+ TagDefinition def -> Text.encodeUtf8 def+ tagDefinitionSize = BS.length tagDefinitionBS++ tagNameBS = Text.encodeUtf8 . getTagName $ tagName+ tagNameSize = BS.length tagNameBS++ tagSize =+ 3 -- delimiters: '\DEL', '\SOH', ','+ + tagNameSize+ + tagDefinitionSize+ + (length $ show lineNr)+ + (length $ show byteOffset)+ + (length $ endOfLine)+++-- | The precondition is that all the tags come frome the same file.+--+formatTagsFile :: TagFileName -> [ETag] -> Builder+formatTagsFile _ [] = mempty+formatTagsFile fileName ts =+ case foldMap formatTag ts of+ BuilderWithSize {builder, builderSize} ->+ if builderSize > 0+ then BB.charUtf8 '\x0c'+ <> BB.stringUtf8 endOfLine+ <> (BB.byteString . Text.encodeUtf8 . getTagFileName $ fileName)+ <> BB.charUtf8 ','+ <> BB.intDec builderSize+ <> BB.stringUtf8 endOfLine+ <> builder+ else mempty+++-- | Format a list of tags as etags file. Tags from the same file must be+-- grouped together.+--+formatETagsFile :: ETagMap -> Builder+formatETagsFile = Map.foldMapWithKey formatTagsFile++endOfLine :: String+endOfLine = "\n"
+ src/GhcTags/ETag/Parser.hs view
@@ -0,0 +1,86 @@+-- | Parser combinators for etags file format+--+module GhcTags.ETag.Parser+ ( parseTagsFile+ , parseTagFileSection+ , parseTag+ ) where++import Control.Applicative (many, (<|>))+import Data.Attoparsec.Text (Parser, (<?>))+import qualified Data.Attoparsec.Text as AT+import Data.Functor (($>))+import qualified Data.Map.Strict as Map+import Data.Text (Text)++import GhcTags.Tag+import qualified GhcTags.Utils as Utils+++-- | Parse whole etags file+--+parseTagsFile :: Text+ -> IO (Either String ETagMap)+parseTagsFile =+ fmap AT.eitherResult+ . AT.parseWith (pure mempty)+ (Map.fromList <$> many parseTagFileSection)+++-- | Parse tags from a single file (a single section in etags file).+--+parseTagFileSection :: Parser (TagFileName, [ETag])+parseTagFileSection =+ (,) <$> (AT.char '\x0c' *> endOfLine *> parseTagFile)+ <*> many parseTag++parseTagFile :: Parser TagFileName+parseTagFile =+ TagFileName+ <$> AT.takeWhile (\x -> x /= ',' && Utils.notNewLine x)+ <* AT.char ','+ <* (AT.decimal :: Parser Int)+ <* endOfLine+ <?> "parsing tag file name failed"+++-- | Parse an 'ETag' from a single line.+--+parseTag :: Parser ETag+parseTag =+ mkTag+ <$> parseTagDefinition+ <*> ((Just <$> parseTagName) <|> pure Nothing)+ <*> AT.decimal+ <* AT.char ','+ <*> AT.decimal+ <* endOfLine+ <?> "parsing tag failed"+ where+ mkTag :: Text -> Maybe TagName -> Int -> Int -> ETag+ mkTag tagDefinition mTagName lineNo byteOffset = + Tag { tagName = case mTagName of+ Nothing -> TagName tagDefinition+ Just name -> name+ , tagKind = NoKind+ , tagAddr = TagLineCol lineNo byteOffset+ , tagDefinition = case mTagName of+ Nothing -> NoTagDefinition+ Just _ -> TagDefinition tagDefinition+ , tagFields = NoTagFields+ }++ parseTagName :: Parser TagName+ parseTagName = TagName <$> AT.takeWhile (\x -> x /= '\SOH' && Utils.notNewLine x)+ <* AT.char '\SOH'+ <?> "parsing tag name failed"++ parseTagDefinition :: Parser Text+ parseTagDefinition = AT.takeWhile (\x -> x /= '\DEL' && Utils.notNewLine x)+ <* AT.char '\DEL'+ <?> "parsing tag definition failed"++endOfLine :: Parser ()+endOfLine = AT.string "\r\n" $> ()+ <|> AT.char '\r' $> ()+ <|> AT.char '\n' $> ()
+ src/GhcTags/Ghc.hs view
@@ -0,0 +1,559 @@+-- | Generate tags from @'HsModule' 'GhcPs'@ representation.+--+module GhcTags.Ghc+ ( GhcTag (..)+ , GhcTagKind (..)+ , getGhcTags+ , hsDeclsToGhcTags+ ) where++import Data.ByteString (ByteString)+import Data.Maybe+import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Hs (HsModule(..))+import GHC.Hs.Binds+import GHC.Hs.Decls hiding (famResultKindSignature)+import GHC.Hs.Expr+import GHC.Hs.Extension+import GHC.Hs.ImpExp+import GHC.Hs.Type hiding (hsSigWcType)+import GHC.Types.Basic+import GHC.Types.FieldLabel+import GHC.Types.Name (nameOccName, occNameFS)+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import GHC.Unit.Module.Name++-- | Kind of the term.+--+data GhcTagKind+ = GtkModule+ | GtkTerm+ | GtkFunction+ | GtkTypeConstructor (Maybe (HsKind GhcPs))++ -- | H98 data construtor+ | GtkDataConstructor (ConDecl GhcPs)++ -- | GADT constructor with its type+ | GtkGADTConstructor (ConDecl GhcPs)+ | GtkRecordField+ | GtkTypeSynonym (HsType GhcPs)+ | GtkTypeSignature (HsWildCardBndrs GhcPs (LHsSigType GhcPs))+ | GtkTypeKindSignature (LHsSigType GhcPs)+ | GtkPatternSynonym+ | GtkTypeClass+ | GtkTypeClassMember (HsType GhcPs)+ | GtkTypeClassInstance (HsType GhcPs)+ | GtkTypeFamily (Maybe ([HsTyVarBndr () GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs)))+ | GtkTypeFamilyInstance (TyFamInstDecl GhcPs)+ | GtkDataTypeFamily (Maybe ([HsTyVarBndr () GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs)))+ | GtkDataTypeFamilyInstance (Maybe (HsKind GhcPs))+ | GtkForeignImport+ | GtkForeignExport++-- | 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+ -- ^ term location+ , gtTag :: ByteString+ -- ^ utf8 encoded tag's name+ , gtKind :: GhcTagKind+ -- ^ tag's kind+ , gtIsExported :: Bool+ -- ^ 'True' iff the term is exported+ , gtFFI :: Maybe String+ -- ^ @ffi@ import+ }++-- | Check if an identifier is exported.+--+isExported :: Maybe [IE GhcPs] -> Located RdrName -> Bool+isExported Nothing _name = True+isExported (Just ies) (L _ name) =+ any (\ie -> listToMaybe (ieNames ie) == Just name) ies++-- | Check if a class member or a type constructors is exported.+--+isMemberExported :: Maybe [IE GhcPs]+ -> Located RdrName -- member name / constructor name+ -> Located RdrName -- type class name / type constructor name+ -> Bool+isMemberExported Nothing _memberName _className = True+isMemberExported (Just ies) memberName className = any go ies+ 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.+ -> GhcTagKind+ -- ^ tag's kind+ -> Bool+ -- ^ is term exported+ -> GhcTag+mkGhcTag (L gtSrcSpan rdrName) gtKind gtIsExported =+ case rdrName of+ Unqual occName ->+ GhcTag { gtTag = bytesFS (occNameFS occName)+ , gtSrcSpan+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }++ Qual _ occName ->+ GhcTag { gtTag = bytesFS (occNameFS occName)+ , gtSrcSpan+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }++ -- Orig is the only one we are interested in+ Orig _ occName ->+ GhcTag { gtTag = bytesFS (occNameFS occName)+ , gtSrcSpan+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }++ Exact eName ->+ GhcTag { gtTag = bytesFS (occNameFS (nameOccName eName))+ , gtSrcSpan+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }+++-- | Generate tags for a module - simple walk over the syntax tree.+--+-- Supported identifiers:+--+-- * /module name/+-- * /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+ -> [GhcTag]+getGhcTags (L _ HsModule { hsmodName, hsmodDecls, hsmodExports }) =+ maybeToList (mkModNameTag <$> hsmodName)+ ++ hsDeclsToGhcTags mies hsmodDecls+ where+ mies :: Maybe [IE GhcPs]+ mies = map unLoc . unLoc <$> hsmodExports++ mkModNameTag :: Located ModuleName -> GhcTag+ mkModNameTag (L gtSrcSpan modName) =+ GhcTag { gtSrcSpan+ , gtTag = bytesFS $ moduleNameFS modName+ , gtKind = GtkModule+ , gtIsExported = True+ , gtFFI = Nothing+ }++hsDeclsToGhcTags :: Maybe [IE GhcPs]+ -> [LHsDecl GhcPs]+ -> [GhcTag]+hsDeclsToGhcTags mies = foldr go []+ where+ fixLoc :: SrcSpan -> GhcTag -> GhcTag+ fixLoc loc gt@GhcTag { gtSrcSpan = UnhelpfulSpan {} } = gt { gtSrcSpan = loc }+ fixLoc _ gt = gt++ -- like 'mkGhcTag' but checks if the identifier is exported+ mkGhcTag' :: SrcSpan+ -- ^ declaration's location; it is useful when the term does not+ -- contain useful inforamtion (e.g. code generated from template+ -- haskell splices).+ -> Located RdrName+ -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level+ -- identifier.+ -> GhcTagKind+ -- ^ tag's kind+ -> GhcTag+ mkGhcTag' l a k = fixLoc l $ mkGhcTag a k (isExported mies a)+++ mkGhcTagForMember :: SrcSpan+ -- ^ declartion's 'SrcSpan'+ -> Located RdrName -- member name+ -> Located RdrName -- class name+ -> GhcTagKind+ -> GhcTag+ mkGhcTagForMember decLoc memberName className kind =+ fixLoc decLoc $ mkGhcTag memberName kind+ (isMemberExported mies memberName className)++ -- Main routine which traverse all top level declarations.+ --+ go :: LHsDecl GhcPs -> [GhcTag] -> [GhcTag]+ go (L decLoc hsDecl) tags = case hsDecl of++ -- type or class declaration+ TyClD _ tyClDecl ->+ case tyClDecl of++ -- type family declarations+ FamDecl { tcdFam } ->+ case mkFamilyDeclTags decLoc tcdFam Nothing of+ Just tag -> tag : tags+ Nothing -> tags++ -- type synonyms+ SynDecl { tcdLName, tcdRhs = L _ hsType } ->+ mkGhcTag' decLoc tcdLName (GtkTypeSynonym hsType) : tags++ -- data declaration:+ -- type,+ -- constructors,+ -- record fields+ --+ DataDecl { tcdLName, tcdDataDefn } ->+ case tcdDataDefn of+ HsDataDefn { dd_cons, dd_kindSig } ->+ mkGhcTag' decLoc tcdLName (GtkTypeConstructor (unLoc <$> dd_kindSig))+ : (mkConsTags decLoc tcdLName . unLoc) `concatMap` dd_cons+ ++ 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' decLoc tcdLName GtkTypeClass+ -- class methods+ : (mkClsMemberTags decLoc tcdLName . unLoc) `concatMap` tcdSigs+ -- default methods+ ++ concatMap (\hsBind -> mkHsBindLRTags decLoc (unLoc hsBind)) tcdMeths+ -- associated types+ ++ ((\a -> mkFamilyDeclTags decLoc a (Just tcdLName)) . unLoc) `mapMaybe` tcdATs+ -- associated type defaults (data type families, type families+ -- (open or closed)+ ++ foldr+ (\(L _ decl@(TyFamInstDecl (HsIB { hsib_body = tyFamDeflEqn }))) tags' ->+ case tyFamDeflEqn of+ FamEqn { feqn_rhs = L _ hsType } ->+ case hsTypeTagName hsType of+ -- TODO: add a `default` field+ Just a -> mkGhcTag' decLoc a (GtkTypeFamilyInstance decl) : tags'+ Nothing -> tags'+ )+ [] tcdATDefs+ ++ 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+ ClsInstDecl { cid_poly_ty, cid_tyfam_insts, cid_datafam_insts+ , cid_binds, cid_sigs } ->+ case cid_poly_ty of+ -- TODO: @hsbib_body :: LHsType GhcPs@+ HsIB { hsib_body } ->+ case mkLHsTypeTag decLoc hsib_body of+ Nothing -> tags'+ Just tag -> tag : tags'+ where+ tags' =+ -- type family instances+ mapMaybe (mkTyFamInstDeclTag decLoc . unLoc) cid_tyfam_insts+ -- data family instances+ ++ concatMap (mkDataFamInstDeclTag decLoc . unLoc) cid_datafam_insts+ -- class methods+ ++ concatMap (mkHsBindLRTags decLoc . unLoc) cid_binds+ -- optional method signatures+ ++ concatMap (mkSigTags decLoc . unLoc) cid_sigs+ ++ tags++ -- data family instance+ DataFamInstD { dfid_inst } ->+ mkDataFamInstDeclTag decLoc dfid_inst ++ tags++ -- type family instance+ TyFamInstD { tfid_inst } ->+ case mkTyFamInstDeclTag decLoc tfid_inst of+ Nothing -> tags+ Just tag -> tag : tags++ -- deriving declaration+ DerivD {} -> tags++ -- value declaration+ ValD _ hsBind -> mkHsBindLRTags decLoc hsBind ++ tags++ -- signature declaration+ SigD _ sig -> mkSigTags decLoc sig ++ tags++ -- standalone kind signatures+ KindSigD _ stdKindSig ->+ case stdKindSig of+ StandaloneKindSig _ ksName sigType ->+ mkGhcTag' decLoc ksName (GtkTypeKindSignature sigType) : 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 -> tag { gtFFI = Just s }+ : tags+ where+ tag = mkGhcTag' decLoc fd_name GtkForeignImport++ ForeignExport { fd_name } ->+ mkGhcTag' decLoc fd_name GtkForeignExport+ : 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++ -- generate tags of all constructors of a type+ --+ mkConsTags :: SrcSpan+ -> Located RdrName+ -- name of the type+ -> ConDecl GhcPs+ -- constructor declaration+ -> [GhcTag]++ mkConsTags decLoc tyName con@ConDeclGADT { con_names, con_args } =+ (\n -> mkGhcTagForMember decLoc n tyName (GtkGADTConstructor con))+ `map` con_names+ ++ mkHsConDeclDetails decLoc tyName con_args++ mkConsTags decLoc tyName con@ConDeclH98 { con_name, con_args } =+ mkGhcTagForMember decLoc con_name tyName+ (GtkDataConstructor con)+ : mkHsConDeclDetails decLoc tyName con_args++ mkHsLocalBindsTags :: SrcSpan -> HsLocalBindsLR GhcPs GhcPs -> [GhcTag]+ mkHsLocalBindsTags decLoc (HsValBinds _ (ValBinds _ hsBindsLR sigs)) =+ -- where clause bindings+ concatMap (mkHsBindLRTags decLoc . unLoc) (bagToList hsBindsLR)+ ++ concatMap (mkSigTags decLoc . unLoc) sigs++ mkHsLocalBindsTags _ _ = []++ mkHsConDeclDetails :: SrcSpan -> Located RdrName -> HsConDeclDetails GhcPs -> [GhcTag]+ mkHsConDeclDetails decLoc tyName (RecCon (L _ fields)) =+ foldr f [] fields+ where+ f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]+ f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names++ g :: LFieldOcc GhcPs -> GhcTag+ g (L _ FieldOcc { rdrNameFieldOcc }) =+ mkGhcTagForMember decLoc rdrNameFieldOcc tyName GtkRecordField++ mkHsConDeclDetails _ _ _ = []+++ mkHsBindLRTags :: SrcSpan+ -- ^ declaration's 'SrcSpan'+ -> HsBindLR GhcPs GhcPs+ -> [GhcTag]+ mkHsBindLRTags decLoc hsBind = case hsBind of+ FunBind { fun_id, fun_matches } ->+ let binds = map (unLoc . grhssLocalBinds . m_grhss . unLoc)+ . unLoc+ . mg_alts+ $ fun_matches+ in mkGhcTag' decLoc fun_id GtkFunction+ : concatMap (mkHsLocalBindsTags decLoc) binds++ -- TODO+ -- This is useful fo generating tags for+ -- ````+ -- Just x = lhs+ -- ```+ PatBind {} -> []++ VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag' decLoc (L srcSpan var_id) GtkTerm]++ -- abstraction binding is only used after translation+ AbsBinds {} -> []++ PatSynBind _ PSB { psb_id } -> [mkGhcTag' decLoc psb_id GtkPatternSynonym]++ mkClsMemberTags :: SrcSpan -> Located RdrName -> Sig GhcPs -> [GhcTag]+ mkClsMemberTags decLoc clsName (TypeSig _ lhs hsSigWcType) =+ (\n -> mkGhcTagForMember decLoc n clsName (GtkTypeSignature hsSigWcType)) `map` lhs+ mkClsMemberTags decLoc clsName (PatSynSig _ lhs hsSigWcType) =+ (\n -> mkGhcTagForMember decLoc n clsName $+ GtkTypeSignature HsWC { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }) `map` lhs+ mkClsMemberTags decLoc clsName (ClassOpSig _ _ lhs hsSigWcType) =+ (\n -> mkGhcTagForMember decLoc n clsName $+ GtkTypeSignature HsWC { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }) `map` lhs+ mkClsMemberTags _ _ _ = []+++ mkSigTags :: SrcSpan -> Sig GhcPs -> [GhcTag]+ mkSigTags decLoc (TypeSig _ lhs hsSigWcType) =+ flip (mkGhcTag' decLoc) (GtkTypeSignature hsSigWcType) `map` lhs+ mkSigTags decLoc (PatSynSig _ lhs hsSigWcType) =+ flip (mkGhcTag' decLoc) (GtkTypeSignature HsWC { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }) `map` lhs+ mkSigTags decLoc (ClassOpSig _ _ lhs hsSigWcType) =+ flip (mkGhcTag' decLoc) (GtkTypeSignature HsWC { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }) `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 {} = []++ mkFamilyDeclTags :: SrcSpan+ -> FamilyDecl GhcPs+ -- ^ declaration's 'SrcSpan'+ -> Maybe (Located RdrName)+ -- if this type family is associate, pass the name of the+ -- associated class+ -> Maybe GhcTag+ mkFamilyDeclTags decLoc FamilyDecl { fdLName, fdInfo, fdTyVars, fdResultSig = L _ familyResultSig } assocClsName =+ case assocClsName of+ Nothing -> Just $ mkGhcTag' decLoc fdLName tk+ Just clsName -> Just $ mkGhcTagForMember decLoc fdLName clsName tk+ where++ mb_fdvars = case fdTyVars of+ HsQTvs { hsq_explicit } -> Just $ unLoc `map` hsq_explicit+ mb_resultsig = famResultKindSignature familyResultSig++ mb_typesig = (,) <$> mb_fdvars <*> mb_resultsig++ tk = case fdInfo of+ DataFamily -> GtkDataTypeFamily mb_typesig+ OpenTypeFamily -> GtkTypeFamily mb_typesig+ ClosedTypeFamily {} -> GtkTypeFamily mb_typesig++ -- used to generate tag of an instance declaration+ mkLHsTypeTag :: SrcSpan+ -- declartaion's 'SrcSpan'+ -> LHsType GhcPs+ -> Maybe GhcTag+ mkLHsTypeTag decLoc (L _ hsType) =+ (\a -> fixLoc decLoc $ mkGhcTag a (GtkTypeClassInstance hsType) True)+ <$> 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 :: SrcSpan -> DataFamInstDecl GhcPs -> [GhcTag]+ mkDataFamInstDeclTag decLoc DataFamInstDecl { dfid_eqn } =+ case dfid_eqn of++ HsIB { hsib_body = FamEqn { feqn_tycon, feqn_rhs } } ->+ case feqn_rhs of+ HsDataDefn { dd_cons, dd_kindSig } ->+ mkGhcTag' decLoc feqn_tycon+ (GtkDataTypeFamilyInstance+ (unLoc <$> dd_kindSig))+ : (mkConsTags decLoc feqn_tycon . unLoc)+ `concatMap` dd_cons++ -- type family instance declaration+ --+ mkTyFamInstDeclTag :: SrcSpan -> TyFamInstDecl GhcPs -> Maybe GhcTag+ mkTyFamInstDeclTag decLoc decl@TyFamInstDecl { tfid_eqn } =+ case tfid_eqn of+ -- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?+ HsIB { hsib_body = FamEqn { feqn_tycon } } ->+ Just $ mkGhcTag' decLoc feqn_tycon (GtkTypeFamilyInstance decl)++--+--+--++famResultKindSignature :: FamilyResultSig GhcPs+ -> Maybe (Either (HsKind GhcPs) (HsTyVarBndr () GhcPs))+famResultKindSignature (NoSig _) = Nothing+famResultKindSignature (KindSig _ ki) = Just (Left (unLoc ki))+famResultKindSignature (TyVarSig _ bndr) = Just (Right (unLoc bndr))
+ src/GhcTags/Tag.hs view
@@ -0,0 +1,457 @@+module GhcTags.Tag+ ( -- * Tag+ TAG_KIND (..)+ , SingTagKind (..)+ , Tag (..)+ , ETag+ , CTag+ , ETagMap+ , CTagMap+ -- ** Tag fields+ , TagName (..)+ , TagFileName (..)+ , ExCommand (..)+ , TagAddress (..)+ , CTagAddress+ , ETagAddress+ , TagKind (..)+ , CTagKind+ , ETagKind+ , TagDefinition (..)+ , TagFields (..)+ , CTagFields+ , ETagFields+ , TagField (..)+ -- ** Ordering and combining tags+ , compareTags++ -- * Create 'Tag' from a 'GhcTag'+ , ghcTagToTag+ ) where++import Control.DeepSeq+import Data.Function (on)+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++-- GHC imports+import GHC.Driver.Session (DynFlags)+import GHC.Data.FastString (bytesFS)++import GHC.Types.SrcLoc+ ( SrcSpan (..)+ , srcSpanFile+ , srcSpanStartLine+ , srcSpanStartCol+ )++import GhcTags.Ghc ( GhcTag (..)+ , GhcTagKind (..)+ )+import qualified GHC.Utils.Outputable as Out++--+-- Tag+--++-- | Promoted data type used to disntinguish 'CTAG's from 'ETAG's.+--+data TAG_KIND = CTAG | ETAG+++-- | Singletons for promoted types.+--+data SingTagKind (tk :: TAG_KIND) where+ SingCTag :: SingTagKind 'CTAG+ SingETag :: SingTagKind 'ETAG+++-- | 'ByteString' which encodes a tag name.+--+newtype TagName = TagName { getTagName :: Text }+ deriving (Eq, Ord, Show)++instance NFData TagName where+ rnf = rnf . getTagName++-- | 'ByteString' which encodes a tag file name.+--+newtype TagFileName = TagFileName { getTagFileName :: Text }+ deriving (Eq, Ord, Show)++instance NFData TagFileName where+ rnf = rnf . getTagFileName++-- | When we parse a `tags` file we can eithera find no kind or recognize the+-- kind of GhcTagKind 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'+--+-- * 'TkModule' - @`@+-- * '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@+--+data TagKind (tk :: TAG_KIND) where+ TkModule :: TagKind tk+ TkTerm :: TagKind tk+ TkFunction :: TagKind tk+ TkTypeConstructor :: TagKind tk+ TkDataConstructor :: TagKind tk+ TkGADTConstructor :: TagKind tk+ TkRecordField :: TagKind tk+ TkTypeSynonym :: TagKind tk+ TkTypeSignature :: TagKind tk+ TkPatternSynonym :: TagKind tk+ TkTypeClass :: TagKind tk+ TkTypeClassMember :: TagKind tk+ TkTypeClassInstance :: TagKind tk+ TkTypeFamily :: TagKind tk+ TkTypeFamilyInstance :: TagKind tk+ TkDataTypeFamily :: TagKind tk+ TkDataTypeFamilyInstance :: TagKind tk+ TkForeignImport :: TagKind tk+ TkForeignExport :: TagKind tk+ CharKind :: Char -> TagKind tk+ NoKind :: TagKind tk++instance NFData (TagKind tk) where+ rnf x = x `seq` ()++type CTagKind = TagKind 'CTAG+type ETagKind = TagKind 'ETAG++deriving instance Eq (TagKind tk)+deriving instance Ord (TagKind tk)+deriving instance Show (TagKind tk)+++newtype ExCommand = ExCommand { getExCommand :: Text }+ deriving (Eq, Ord, Show)+++-- | Tag address, either from a parsed file or from Haskell's AST>+--+data TagAddress (tk :: TAG_KIND) where+ -- | Precise addres: line and column. This is what we infer from @GHC@+ -- AST.+ --+ -- The two arguments are line number and either column number or offset+ -- from the begining of the file.+ --+ TagLineCol :: Int -> Int -> TagAddress tk++ -- | ctags can only use range ex-commands as an address (or a sequence of+ -- them separated by `;`). We parse line number specifically, since they+ -- are useful for ordering tags.+ --+ TagLine :: Int -> TagAddress 'CTAG++ -- | A tag address can be just an ex command.+ --+ TagCommand :: ExCommand -> TagAddress 'CTAG++instance NFData (TagAddress tk) where+ rnf x = x `seq` ()++-- | 'CTag' addresses.+--+type CTagAddress = TagAddress 'CTAG++-- | 'ETag' addresses.+--+type ETagAddress = TagAddress 'ETAG+++deriving instance Eq (TagAddress tk)+deriving instance Ord (TagAddress tk)+deriving instance Show (TagAddress tk)+++-- | Emacs tags specific field.+--+data TagDefinition (tk :: TAG_KIND) where+ TagDefinition :: Text -> TagDefinition 'ETAG+ NoTagDefinition :: TagDefinition tk++instance NFData (TagDefinition tk) where+ rnf x = x `seq` ()++deriving instance Show (TagDefinition tk)+deriving instance Eq (TagDefinition tk)++-- | 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)++instance NFData TagField where+ rnf x = x `seq` ()++-- | File field; tags which contain 'fileField' are called static (aka static+-- in @C@), such tags are only visible in the current file)+--+fileField :: TagField+fileField = TagField { fieldName = "file", fieldValue = "" }+++-- | Ctags specific list of 'TagField's.+--+data TagFields (tk :: TAG_KIND) where+ NoTagFields :: TagFields 'ETAG++ TagFields :: [TagField]+ -> TagFields 'CTAG++instance NFData (TagFields tk) where+ rnf NoTagFields = ()+ rnf (TagFields fs) = rnf fs++deriving instance Show (TagFields tk)+deriving instance Eq (TagFields tk)+instance Semigroup (TagFields tk) where+ NoTagFields <> NoTagFields = NoTagFields+ (TagFields a) <> (TagFields b) = TagFields (a ++ b)+instance Monoid (TagFields 'CTAG) where+ mempty = TagFields mempty+instance Monoid (TagFields 'ETAG) where+ mempty = NoTagFields++type CTagFields = TagFields 'CTAG+type ETagFields = TagFields 'ETAG+++-- | Tag record. For either ctags or etags formats. It is either filled with+-- information parsed from a tags file or from *GHC* ast.+--+data Tag (tk :: TAG_KIND) = Tag+ { tagName :: TagName+ -- ^ name of the tag+ , tagKind :: TagKind tk+ -- ^ ctags specifc field, which classifies tags+ , tagAddr :: TagAddress tk+ -- ^ address in source file+ , tagDefinition :: TagDefinition tk+ -- ^ etags specific field; only tags read from emacs tags file contain this+ -- field.+ , tagFields :: TagFields tk+ -- ^ ctags specific field+ }+ deriving (Show, Eq)++instance NFData (Tag tk) where+ rnf Tag{..} = rnf tagName+ `seq` rnf tagKind+ `seq` rnf tagAddr+ `seq` rnf tagDefinition+ `seq` rnf tagFields++type CTag = Tag 'CTAG+type ETag = Tag 'ETAG++type TagMap tk = Map TagFileName [Tag tk]+type CTagMap = TagMap 'CTAG+type ETagMap = TagMap 'ETAG++-- | 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.+--+-- It satisfies the following properties:+--+-- * anti-symmetry+-- * reflexivity+-- * transitivity+-- * partial consistency with 'Eq' instance: +--+-- prop> a == b => compareTags a b == EQ+--+compareTags :: forall (tk :: TAG_KIND). Ord (TagAddress tk) => Tag tk -> Tag tk -> Ordering+compareTags 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 compare getTkClass t0 t1+ <> on compare tagAddr t0 t1+ <> on compare tagKind t0 t1++ where+ getTkClass :: Tag tk -> Maybe (TagKind tk)+ getTkClass t = case tagKind t of+ TkTypeClass -> Just TkTypeClass+ TkTypeClassInstance -> Just TkTypeClassInstance+ TkTypeFamily -> Just TkTypeFamily+ TkTypeFamilyInstance -> Just TkTypeFamilyInstance+ TkDataTypeFamily -> Just TkDataTypeFamily+ TkDataTypeFamilyInstance -> Just TkDataTypeFamilyInstance+ _ -> Nothing++--+-- GHC interface+--++-- | Create a 'Tag' from 'GhcTag'.+--+ghcTagToTag :: SingTagKind tk -> DynFlags -> GhcTag -> Maybe (TagFileName, Tag tk)+ghcTagToTag sing dynFlags GhcTag { gtSrcSpan, gtTag, gtKind, gtIsExported, gtFFI } =+ case gtSrcSpan of+ UnhelpfulSpan {} -> Nothing+ RealSrcSpan realSrcSpan _ ->+ Just . (fileName realSrcSpan, ) $ Tag+ { tagName = TagName tagName ++ , tagAddr = TagLineCol (srcSpanStartLine realSrcSpan)+ (srcSpanStartCol realSrcSpan)++ , tagKind = fromGhcTagKind gtKind++ , tagDefinition = NoTagDefinition++ , tagFields = ( staticField+ <> ffiField+ <> kindField+ ) sing+ }++ where+ fileName = TagFileName . Text.decodeUtf8 . bytesFS . srcSpanFile++ tagName = Text.decodeUtf8 gtTag++ fromGhcTagKind :: GhcTagKind -> TagKind tk+ fromGhcTagKind = \case+ GtkModule -> TkModule+ GtkTerm -> TkTerm+ GtkFunction -> TkFunction+ GtkTypeConstructor {} -> TkTypeConstructor+ GtkDataConstructor {} -> TkDataConstructor+ GtkGADTConstructor {} -> TkGADTConstructor+ GtkRecordField -> TkRecordField+ GtkTypeSynonym {} -> TkTypeSynonym+ GtkTypeSignature {} -> TkTypeSignature+ GtkTypeKindSignature {} -> TkTypeSignature+ GtkPatternSynonym -> TkPatternSynonym+ GtkTypeClass -> TkTypeClass+ GtkTypeClassMember {} -> TkTypeClassMember+ GtkTypeClassInstance {} -> TkTypeClassInstance+ GtkTypeFamily {} -> TkTypeFamily+ GtkTypeFamilyInstance {} -> TkTypeFamilyInstance+ GtkDataTypeFamily {} -> TkDataTypeFamily+ GtkDataTypeFamilyInstance {} -> TkDataTypeFamilyInstance+ GtkForeignImport -> TkForeignImport+ GtkForeignExport -> TkForeignExport++ -- static field (wheather term is exported or not)+ staticField :: SingTagKind tk -> TagFields tk+ staticField = \case+ SingETag -> NoTagFields+ SingCTag ->+ TagFields $+ if gtIsExported+ then mempty+ else [fileField]++ -- ffi field+ ffiField :: SingTagKind tk -> TagFields tk+ ffiField = \case+ SingETag -> NoTagFields+ SingCTag ->+ TagFields $+ case gtFFI of+ Nothing -> mempty+ Just ffi -> [TagField "ffi" $ Text.pack ffi]+++ -- 'TagFields' from 'GhcTagKind'+ kindField :: SingTagKind tk -> TagFields tk+ kindField = \case+ SingETag -> NoTagFields+ SingCTag ->+ case gtKind of+ GtkTypeClassInstance hsType ->+ mkField "instance" hsType++ GtkTypeFamily (Just hsKind) ->+ mkField kindFieldName hsKind++ GtkDataTypeFamily (Just hsKind) ->+ mkField kindFieldName hsKind++ GtkTypeSignature hsSigWcType ->+ mkField typeFieldName hsSigWcType++ GtkTypeSynonym hsType ->+ mkField typeFieldName hsType++ GtkTypeConstructor (Just hsKind) ->+ mkField kindFieldName hsKind++ GtkDataConstructor decl ->+ TagFields+ [TagField+ { fieldName = termFieldName+ , fieldValue = render decl+ }]+++ GtkGADTConstructor hsType ->+ mkField typeFieldName hsType++ _ -> mempty+++ kindFieldName, typeFieldName, termFieldName :: Text+ kindFieldName = "Kind" -- "kind" is reserverd+ typeFieldName = "type"+ termFieldName = "term"++ --+ -- fields+ --+ + mkField :: Out.Outputable p => Text -> p -> TagFields 'CTAG+ mkField fieldName p =+ TagFields+ [ TagField+ { fieldName+ , fieldValue = render p+ }]++ render :: Out.Outputable p => p -> Text+ render hsType =+ Text.intercalate " " -- remove all line breaks, tabs and multiple spaces+ . Text.words+ . Text.pack+ $ Out.renderWithStyle+ (Out.initSDocContext+ dynFlags+ (Out.setStyleColoured False+ $ Out.mkErrStyle Out.neverQualify))+ (Out.ppr hsType)
+ src/GhcTags/Utils.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}++module GhcTags.Utils+ ( endOfLine+ , notNewLine+ ) where++-- | Platform dependend eol:+--+-- * windows "CRNL"+-- * maxos "CR"+-- * linux (unit) "NL"+--+endOfLine :: String+#if defined(mingw32_HOST_OS)+endOfLine = "\r\n"+#elif defined(darwin_HIST_OS)+endOfLine = "\r"+#else+endOfLine = "\n"+#endif+++notNewLine :: Char -> Bool+notNewLine = \x -> x /= '\n' && x /= '\r'
+ src/Main.hs view
@@ -0,0 +1,442 @@+module Main (main) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Bifunctor+import Data.Char+import Data.Function+import Data.IORef+import Data.List+import Data.Maybe (mapMaybe)+import Data.Time+import Data.Time.Format.ISO8601+import GHC.Conc (getNumProcessors)+import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Driver.Main+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Driver.Types (HscEnv(..))+import GHC.Hs+import GHC.Parser.Lexer+import GHC.Paths+import GHC.Platform+import GHC.SysTools+import GHC.Types.SrcLoc+import GHC.Unit.Module.Env+import GHC.Utils.Error+import System.Directory+import System.Environment+import System.Exit+import System.FilePath+import System.IO+import System.IO.Error+import System.IO.Temp+import System.Process+import qualified Data.ByteString.Builder as BS+import qualified Data.ByteString.Char8 as BS+import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.Vector as V+import qualified GHC+import qualified GHC.Driver.Pipeline as DP+import qualified GHC.Parser as Parser+import qualified GHC.Utils.Outputable as Out++import GhcTags+import GhcTags.Config.Args+import GhcTags.Config.Project+import GhcTags.CTag.Header+import qualified GhcTags.CTag as CTag+import qualified GhcTags.ETag as ETag++----------------------------------------++data Updated a = Updated Bool a++data HsFileType = HsFile | HsBootFile | LHsFile | AlexFile | HscFile++data WorkerData = WorkerData+ { wdTags :: MVar DirtyTags+ , wdTimes :: MVar DirtyModTimes+ , wdQueue :: TBQueue (Maybe (FilePath, HsFileType, UTCTime))+ }++generateTagsForProject :: Int -> WorkerData -> ProjectConfig -> IO ()+generateTagsForProject threads wd pc = runConcurrently . F.fold+ $ Concurrently (processFiles (pcSourcePaths pc) >> terminateWorkers)+ : replicate threads (Concurrently worker)+ where+ -- Walk a list of paths recursively and process eligible source files.+ processFiles :: [String] -> IO ()+ processFiles = mapM_ $ \origPath -> do+ let path = normalise origPath+ unless (path `elem` pcExcludePaths pc) $ do+ doesDirectoryExist path >>= \case+ True -> do+ paths <- map (path </>) <$> listDirectory path+ processFiles paths+ False -> F.forM_ (takeExtension path `lookup` haskellExts) $ \hsType -> do+ -- Source files are scanned and updated only if their mtime changed or+ -- it's not recorded.+ time <- getModificationTime path+ updateTags <- withMVar (wdTimes wd) $ \times -> pure $+ case TagFileName (T.pack path) `Map.lookup` times of+ Just (Updated _ oldTime) -> oldTime < time+ Nothing -> True+ when updateTags $ do+ atomically . writeTBQueue (wdQueue wd) $ Just (path, hsType, time)+ where+ haskellExts = [ (".hs", HsFile)+ , (".hs-boot", HsBootFile)+ , (".lhs", LHsFile)+ , (".x", AlexFile)+ , (".hsc", HscFile)+ ]++ terminateWorkers :: IO ()+ terminateWorkers = atomically $ do+ replicateM_ threads $ writeTBQueue (wdQueue wd) Nothing++ -- Extract tags from a given file and update the TagMap.+ worker :: IO ()+ worker = runGhc $ do+ void $ GHC.setSessionDynFlags . adjustDynFlags pc =<< getSessionDynFlags+ env <- getSession+ liftIO . fix $ \loop -> atomically (readTBQueue $ wdQueue wd) >>= \case+ Nothing -> pure ()+ Just (file, hsType, mtime) -> processFile env file hsType mtime >> loop+ where+ processFile :: HscEnv -> FilePath -> HsFileType -> UTCTime -> IO ()+ processFile env rawFile hsType mtime = withHsFile rawFile hsType $ \hsFile -> do+ handle showErr $ DP.preprocess env hsFile Nothing Nothing >>= \case+ Left errs -> report (hsc_dflags env) errs+ Right (flags, file) -> do+ --when (file /= rawFile) $ do+ -- putStrLn $ "Processing " ++ file ++ " (" ++ rawFile ++ ")"+ buffer <- hGetStringBuffer file+ case parseModule file flags buffer of+ PFailed pstate -> do+ let (wrns, errs) = getMessages pstate flags+ report flags wrns+ report flags errs+ POk pstate hsModule -> do+ let (wrns, errs) = getMessages pstate flags+ report flags wrns+ report flags errs+ when (isEmptyBag errs) $ do+ modifyMVar_ (wdTags wd) $ \tags -> do+ pure $! updateTagsWith flags hsModule tags+ modifyMVar_ (wdTimes wd) $ \times -> do+ let path = TagFileName $ T.pack rawFile+ pure $! updateTimesWith path mtime times+ where+ showErr :: GHC.GhcException -> IO ()+ showErr = putStrLn . show++ report :: DynFlags -> Bag ErrMsg -> IO ()+ report flags msgs =+ sequence_ [ putStrLn $ Out.showSDoc flags msg+ | msg <- pprErrMsgBagWithLoc msgs+ ]++ -- Alex and Hsc files need to be preprocessed before going into GHC.+ withHsFile :: FilePath -> HsFileType -> (FilePath -> IO ()) -> IO ()+ withHsFile file hsType k = case hsType of+ AlexFile -> preprocessWith "alex" []+ HscFile -> preprocessWith "hsc2hs" $ map ("-I" ++) (pcCppIncludes pc)+ ++ filter ("-D" `isPrefixOf`) (pcCppOptions pc)+ _ -> k file+ where+ preprocessWith :: FilePath -> [FilePath] -> IO ()+ preprocessWith prog args = withSystemTempDirectory "ghc-tags" $ \dir -> do+ let tmpFile = dir </> "out.hs"+ (ec, out, err) <- readProcessWithExitCode prog+ ([file, "-o", tmpFile] ++ args) ""+ case ec of+ ExitSuccess -> k tmpFile+ ExitFailure code -> do+ putStrLn $ "Preprocessing " ++ file ++ " with " ++ prog+ ++ " failed with exit code " ++ show code+ unless (null out) . putStrLn $ "* STDOUT: " ++ out+ unless (null err) . putStrLn $ "* STDERR: " ++ err++main :: IO ()+main = do+ -- The default number of threads is half the number of CPU cores as usually+ -- the other half are logical cores that don't increase performance when+ -- loaded (or even decrease it in case of high core count, e.g. Ryzen 5950x).+ defaultThreads <- max 1 . (`div` 2) <$> getNumProcessors++ args <- parseArgs defaultThreads =<< getArgs++ pcs <- case aSourcePaths args of+ SourceArgs paths -> pure [defaultProjectConfig { pcSourcePaths = paths }]+ ConfigFile configFile -> getProjectConfigs configFile++ when (not $ null pcs) $ do+ wd <- initWorkerData args (aThreads args)++ setNumCapabilities (aThreads args)+ forM_ pcs $ generateTagsForProject (aThreads args) wd+ setNumCapabilities 1++ cleanTagMap <- withMVar (wdTags wd) cleanupTags+ writeTags (aTagFile args) cleanTagMap+ withMVar (wdTimes wd) $ writeTimes (timesFile args) <=< cleanupTimes cleanTagMap+ where+ timesFile args = aTagFile args <.> "mtime"++ initWorkerData :: Args -> Int -> IO WorkerData+ initWorkerData args threads = do+ wdTags <- newMVar =<< case aTagType args of+ ETags -> readTags SingETag (aTagFile args)+ CTags -> readTags SingCTag (aTagFile args)+ wdTimes <- newMVar =<< readTimes (timesFile args)+ wdQueue <- newTBQueueIO (fromIntegral threads)+ pure WorkerData{..}++----------------------------------------++type DirtyModTimes = Map.Map TagFileName (Updated UTCTime)+type ModTimes = Map.Map TagFileName UTCTime++-- | Read the file with mtimes of previously processed source files.+readTimes :: FilePath -> IO DirtyModTimes+readTimes timesFile = doesFileExist timesFile >>= \case+ False -> pure Map.empty+ True -> tryIOError (T.readFile timesFile) >>= \case+ Right content -> pure . parse Map.empty $ T.lines content+ Left err -> do+ putStrLn $ "Error while reading " ++ timesFile ++ ": " ++ show err+ pure Map.empty+ where+ parse :: DirtyModTimes -> [T.Text] -> DirtyModTimes+ parse !acc (path : mtime : rest) =+ case iso8601ParseM (T.unpack mtime) of+ Just time -> let checkedTime = Updated False time+ in parse (Map.insert (TagFileName path) checkedTime acc) rest+ Nothing -> parse acc rest+ parse !acc _ = acc++-- | Update an mtime of a source file with a new value.+updateTimesWith :: TagFileName -> UTCTime -> DirtyModTimes -> DirtyModTimes+updateTimesWith file time = Map.insert file (Updated True time)++-- | Check if files that were not updated exist and drop them if they don't.+cleanupTimes :: Tags -> DirtyModTimes -> IO ModTimes+cleanupTimes Tags{..} = Map.traverseMaybeWithKey $ \file -> \case+ Updated updated time+ | updated || file `Map.member` tTags -> pure $ Just time+ | otherwise -> do+ let path = T.unpack $ getTagFileName file+ doesFileExist path >>= \case+ True -> pure $ Just time+ False -> pure Nothing++-- | Update the file with mtimes with new values.+writeTimes :: FilePath -> ModTimes -> IO ()+writeTimes timesFile times = withFile timesFile WriteMode $ \h -> do+ forM_ (Map.toList times) $ \(path, mtime) -> do+ T.hPutStrLn h $ getTagFileName path+ hPutStrLn h $ iso8601Show mtime++----------------------------------------++data DirtyTags = forall tk. DirtyTags+ { dtKind :: SingTagKind tk+ , dtHeaders :: [CTag.Header]+ , dtTags :: Map.Map TagFileName (Updated [Tag tk])+ }++data Tags = forall tk. Tags+ { tKind :: SingTagKind tk+ , tHeaders :: [CTag.Header]+ , tTags :: Map.Map TagFileName [Tag tk]+ }++readTags :: forall tk. SingTagKind tk -> FilePath -> IO DirtyTags+readTags tk tagsFile = doesFileExist tagsFile >>= \case+ False -> pure newDirtyTags+ True -> do+ res <- tryIOError $ parseTagsFile . T.decodeUtf8 =<< BS.readFile tagsFile+ case res of+ Right (Right (headers, tags)) ->+ pure $ DirtyTags { dtKind = tk+ , dtHeaders = headers+ , dtTags = Map.map (Updated False) tags+ }+ -- reading failed+ Left err -> do+ putStrLn $ "Error while reading " ++ tagsFile ++ ": " ++ show err+ pure newDirtyTags+ -- parsing failed+ Right (Left err) -> do+ putStrLn $ "Error while parsing " ++ tagsFile ++ ": " ++ show err+ pure newDirtyTags+ where+ newDirtyTags = DirtyTags { dtKind = tk+ , dtHeaders = []+ , dtTags = Map.empty+ }++ parseTagsFile+ :: T.Text+ -> IO (Either String ([CTag.Header], Map.Map TagFileName [Tag tk]))+ parseTagsFile = case tk of+ SingETag -> fmap (fmap ([], )) . ETag.parseTagsFile+ SingCTag -> CTag.parseTagsFile++updateTagsWith :: DynFlags -> Located HsModule -> DirtyTags -> DirtyTags+updateTagsWith dflags hsModule DirtyTags{..} =+ DirtyTags { dtTags = fileTags `Map.union` dtTags+ , ..+ }+ where+ fileTags =+ let tags = Map.fromListWith (++)+ . map (second (:[]))+ . mapMaybe (ghcTagToTag dtKind dflags)+ $ getGhcTags hsModule+ in Map.map (Updated True) $!! tags++cleanupTags :: DirtyTags -> IO Tags+cleanupTags DirtyTags{..} = do+ newTags <- (`Map.traverseMaybeWithKey` dtTags) $ \file (Updated updated tags) -> do+ let path = T.unpack $ getTagFileName file+ -- The file might not exists even though it was updated, e.g. when .x files+ -- are preprocessed as temporary files, some tags from them might make it+ -- here.+ exists <- doesFileExist path+ if | exists && updated -> do+ let cleanedTags = ignoreSimilarClose $ sortBy compareNAK tags+ case dtKind of+ SingCTag -> pure $ Just cleanedTags+ SingETag -> addFileOffsets file cleanedTags+ | exists && not updated -> pure $ Just tags+ | otherwise -> pure Nothing+ newTags `deepseq` pure Tags { tKind = dtKind+ , tHeaders = dtHeaders+ , tTags = newTags+ }+ where+ -- Group the same tags together so that similar ones can be eliminated.+ compareNAK t0 t1 = on compare tagName t0 t1+ <> on compare tagAddr t0 t1+ <> on compare tagKind t0 t1++ ignoreSimilarClose (a : b : rest)+ | tagName a == tagName b =+ if | a `betterThan` b -> a : ignoreSimilarClose rest+ | b `betterThan` a -> b : ignoreSimilarClose rest+ | otherwise -> a : ignoreSimilarClose (b : rest)+ | otherwise = a : ignoreSimilarClose (b : rest)+ where+ -- Prefer definitions of functions and pattern synonyms over their type+ -- signatures and data/GADT constructors over type constructors.+ x `betterThan` y+ = ( (tagKind x == TkFunction || tagKind x == TkPatternSynonym)+ && tagKind y == TkTypeSignature+ )+ || ( (tagKind x == TkDataConstructor || tagKind x == TkGADTConstructor)+ && tagKind y == TkTypeConstructor+ )+ ignoreSimilarClose tags = tags++-- | Add file offsets to etags from a specific file.+addFileOffsets :: TagFileName -> [ETag] -> IO (Maybe [ETag])+addFileOffsets file tags = do+ let path = T.unpack $ getTagFileName file+ addOffset !off line = (off + BS.length line + 1, (off, line))+ tryIOError (BS.readFile path) >>= \case+ Left err -> do+ putStrLn $ "Unexpected error: " ++ show err+ pure Nothing+ Right content -> do+ let linesWithOffsets = V.fromList+ . snd+ . mapAccumL addOffset 0+ . BS.lines+ $ content+ pure . Just $ fillOffsets linesWithOffsets tags+ where+ fillOffsets :: V.Vector (Int, BS.ByteString) -> [ETag] -> [ETag]+ fillOffsets linesWithOffsets = mapMaybe $ \tag -> do+ let TagLineCol lineNo _ = tagAddr tag+ (lineOffset, line) <- linesWithOffsets V.!? (lineNo - 1)+ pure tag+ { tagAddr = TagLineCol lineNo lineOffset+ , tagDefinition =+ -- Prevent weird characters from ending up in the TAGS file.+ TagDefinition . T.takeWhile isPrint $ T.decodeUtf8 line+ }++writeTags :: FilePath -> Tags -> IO ()+writeTags tagsFile Tags{..} = withFile tagsFile WriteMode $ \h ->+ BS.hPutBuilder h $ case tKind of+ SingETag -> (`Map.foldMapWithKey` tTags) $ \path ->+ ETag.formatTagsFile path . sortBy ETag.compareTags+ SingCTag -> CTag.formatTagsFile headers $+ Map.map (sortBy CTag.compareTags) tTags+ where+ headers :: [Header]+ headers = if null tHeaders+ then defaultHeaders+ else tHeaders++----------------------------------------++runGhc :: Ghc a -> IO a+runGhc m = do+ env <- liftIO $ do+ mySettings <- initSysTools libdir+ myLlvmConfig <- lazyInitLlvmConfig libdir+ dflags <- threadSafeInitDynFlags (defaultDynFlags mySettings myLlvmConfig)+ newHscEnv dflags+ ref <- newIORef env+ unGhc (GHC.withCleanupSession m) (Session ref)+ where+ threadSafeInitDynFlags dflags = do+ let -- We can't build with dynamic-too on Windows, as labels before the+ -- fork point are different depending on whether we are building+ -- dynamically or not.+ platformCanGenerateDynamicToo+ = platformOS (targetPlatform dflags) /= OSMinGW32+ refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo+ refNextTempSuffix <- newIORef 0+ refFilesToClean <- newIORef emptyFilesToClean+ refDirsToClean <- newIORef Map.empty+ refGeneratedDumps <- newIORef Set.empty+ refRtldInfo <- newIORef Nothing+ refRtccInfo <- newIORef Nothing+ wrapperNum <- newIORef emptyModuleEnv+ pure dflags+ { canGenerateDynamicToo = refCanGenerateDynamicToo+ , nextTempSuffix = refNextTempSuffix+ , filesToClean = refFilesToClean+ , dirsToClean = refDirsToClean+ , generatedDumps = refGeneratedDumps+ , nextWrapperNum = wrapperNum+ , rtldInfo = refRtldInfo+ , rtccInfo = refRtccInfo+ }++parseModule+ :: FilePath+ -> DynFlags+ -> StringBuffer+ -> ParseResult (Located HsModule)+parseModule filename flags buffer =+ unP Parser.parseModule parseState+ where+ location = mkRealSrcLoc (mkFastString filename) 1 1+ parseState = mkPState flags buffer location