diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +# ghc-tags-1.0 (2021-05-17) +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,104 @@ +# ghc-tags + +[![Build Status](https://github.com/arybczak/ghc-tags/workflows/Haskell-CI/badge.svg?branch=master)](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. diff --git a/ghc-tags.cabal b/ghc-tags.cabal new file mode 100644 --- /dev/null +++ b/ghc-tags.cabal @@ -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 diff --git a/src/GhcTags.hs b/src/GhcTags.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags.hs @@ -0,0 +1,8 @@ +module GhcTags + ( module GhcTags.Ghc + , module GhcTags.Tag + ) where + + +import GhcTags.Ghc +import GhcTags.Tag diff --git a/src/GhcTags/CTag.hs b/src/GhcTags/CTag.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/CTag.hs @@ -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 diff --git a/src/GhcTags/CTag/Formatter.hs b/src/GhcTags/CTag/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/CTag/Formatter.hs @@ -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 diff --git a/src/GhcTags/CTag/Header.hs b/src/GhcTags/CTag/Header.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/CTag/Header.hs @@ -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" diff --git a/src/GhcTags/CTag/Parser.hs b/src/GhcTags/CTag/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/CTag/Parser.hs @@ -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' diff --git a/src/GhcTags/CTag/Utils.hs b/src/GhcTags/CTag/Utils.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/CTag/Utils.hs @@ -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 diff --git a/src/GhcTags/Config/Args.hs b/src/GhcTags/Config/Args.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/Config/Args.hs @@ -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 "" + + 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" diff --git a/src/GhcTags/Config/Project.hs b/src/GhcTags/Config/Project.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/Config/Project.hs @@ -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] diff --git a/src/GhcTags/ETag.hs b/src/GhcTags/ETag.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/ETag.hs @@ -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 diff --git a/src/GhcTags/ETag/Formatter.hs b/src/GhcTags/ETag/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/ETag/Formatter.hs @@ -0,0 +1,103 @@ +-- | Simple etags formatter. See +-- +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" diff --git a/src/GhcTags/ETag/Parser.hs b/src/GhcTags/ETag/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/ETag/Parser.hs @@ -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' $> () diff --git a/src/GhcTags/Ghc.hs b/src/GhcTags/Ghc.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/Ghc.hs @@ -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)) diff --git a/src/GhcTags/Tag.hs b/src/GhcTags/Tag.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/Tag.hs @@ -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) diff --git a/src/GhcTags/Utils.hs b/src/GhcTags/Utils.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/Utils.hs @@ -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' diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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