ghc-tags 1.11 → 1.12
raw patch · 19 files changed
+1686/−1863 lines, 19 filesdep +primitivedep +yamletdep −aesondep −vectordep −yaml
Dependencies added: primitive, yamlet
Dependencies removed: aeson, vector, yaml
Files
- CHANGELOG.md +14/−0
- README.md +1/−1
- ghc-tags.cabal +86/−75
- src/GhcTags.hs +0/−1
- src/GhcTags/CTag.hs +6/−8
- src/GhcTags/CTag/Formatter.hs +90/−90
- src/GhcTags/CTag/Header.hs +124/−129
- src/GhcTags/CTag/Parser.hs +127/−138
- src/GhcTags/CTag/Utils.hs +43/−48
- src/GhcTags/Config/Args.hs +71/−48
- src/GhcTags/Config/Project.hs +134/−145
- src/GhcTags/ETag.hs +8/−10
- src/GhcTags/ETag/Formatter.hs +34/−40
- src/GhcTags/ETag/Parser.hs +53/−53
- src/GhcTags/Ghc.hs +417/−415
- src/GhcTags/GhcCompat.hs +18/−220
- src/GhcTags/Tag.hs +185/−218
- src/GhcTags/Utils.hs +2/−5
- src/Main.hs +273/−219
CHANGELOG.md view
@@ -1,3 +1,17 @@+# ghc-tags-1.12 (2026-10-11)+* If the configuration file contains an error, show the line, the column and+ an excerpt of the file. A value of the wrong kind is now reported in plain+ words, e.g. `expected a list, but got an integer`.+* Depend on fewer packages. A build from source no longer compiles the+ bundled C library of libyaml.+* Print errors and warnings to stderr instead of stdout.+* On a terminal, show errors and warnings in colour, as GHC does, with links+ to the Haskell Error Index.+* Exit with code 1 if a source file fails to parse or preprocess. The tags of+ the other files are still written. Earlier versions exited with 0.+* Fix garbled error messages with more than one thread, e.g. errors of the C+ preprocessor. Messages from different files no longer mix.+ # ghc-tags-1.11 (2026-09-13) * Generate a tag for each name that a pattern binding defines, e.g. `pairA` and `pairB` in `(pairA, pairB) = ...`. Earlier versions skipped pattern
README.md view
@@ -1,6 +1,6 @@ # ghc-tags -[](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster)+[](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster) [](https://hackage.haskell.org/package/ghc-tags) A command line tool that generates etags
ghc-tags.cabal view
@@ -1,85 +1,96 @@-cabal-version: 3.0-name: ghc-tags-version: 1.11-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: 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 == { 9.10.3, 9.12.4, 9.14.1 }+cabal-version: 3.8+build-type: Simple+name: ghc-tags+version: 1.12+license: MPL-2.0+license-file: LICENSE+category: Development+maintainer: andrzej@rybczak.net+author: Andrzej Rybczak+copyright: Andrzej Rybczak+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.++extra-doc-files:+ CHANGELOG.md+ README.md++tested-with: GHC ^>= { 9.10, 9.12, 9.14 }++homepage: https://github.com/arybczak/ghc-tags+bug-reports: https://github.com/arybczak/ghc-tags/issues source-repository head- type: git- location: https://github.com/arybczak/ghc-tags+ type: git+ location: https://github.com/arybczak/ghc-tags.git +common language+ ghc-options: -Wall+ -Wunused-packages+ -Werror=missing-deriving-strategies+ -Werror=name-shadowing+ -Werror=prepositive-qualified-module++ default-language: GHC2021++ default-extensions: DataKinds+ DerivingStrategies+ DerivingVia+ GADTs+ LambdaCase+ MultiWayIf+ OverloadedStrings+ PatternSynonyms+ RecordWildCards+ StrictData+ ViewPatterns+ executable ghc-tags- ghc-options: -Wall -Wunused-packages -threaded -rtsopts+ import: language - build-depends: base >=4.20 && <4.23- , aeson >= 2.0.0.0- , async >= 2.2.5- , attoparsec- , bytestring- , containers- , deepseq- , directory- , filepath- , ghc >= 9.10 && < 9.15- , ghc-boot >= 9.10 && < 9.15- , ghc-paths- , stm- , optparse-applicative- , process- , temporary- , text- , time- , vector- , yaml+ ghc-options: -threaded -rtsopts - hs-source-dirs: src+ build-depends: base >= 4.20 && < 4.23+ , async >= 2.2.5+ , attoparsec+ , bytestring+ , containers+ , deepseq+ , directory+ , filepath+ , ghc >= 9.10 && < 9.15+ , ghc-boot >= 9.10 && < 9.15+ , ghc-paths+ , optparse-applicative+ , primitive+ , process+ , stm+ , temporary+ , text+ , time+ , yamlet >= 1.0 - main-is: Main.hs+ hs-source-dirs: src - other-modules: GhcTags- GhcTags.Config.Args- GhcTags.Config.Project- GhcTags.Ghc- GhcTags.GhcCompat- 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+ main-is: Main.hs - autogen-modules: Paths_ghc_tags+ other-modules: GhcTags+ GhcTags.CTag+ GhcTags.CTag.Formatter+ GhcTags.CTag.Header+ GhcTags.CTag.Parser+ GhcTags.CTag.Utils+ GhcTags.Config.Args+ GhcTags.Config.Project+ GhcTags.ETag+ GhcTags.ETag.Formatter+ GhcTags.ETag.Parser+ GhcTags.Ghc+ GhcTags.GhcCompat+ GhcTags.Tag+ GhcTags.Utils+ Paths_ghc_tags - default-language: Haskell2010- default-extensions: BangPatterns- , DataKinds- , FlexibleContexts- , FlexibleInstances- , GADTs- , KindSignatures- , LambdaCase- , MultiWayIf- , NamedFieldPuns- , OverloadedStrings- , RecordWildCards- , ScopedTypeVariables- , StrictData- , StandaloneDeriving- , TupleSections+ autogen-modules: Paths_ghc_tags
src/GhcTags.hs view
@@ -3,6 +3,5 @@ , module GhcTags.Tag ) where - import GhcTags.Ghc import GhcTags.Tag
src/GhcTags/CTag.hs view
@@ -3,15 +3,13 @@ , 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+import GhcTags.CTag.Formatter as X+import GhcTags.CTag.Header as X+import GhcTags.CTag.Parser as X+import GhcTags.CTag.Utils as X+import GhcTags.Tag (CTag)+import GhcTags.Tag qualified as Tag -- | A specialisation of 'GhcTags.Tag.compareTags' to 'CTag's.--- compareTags :: CTag -> CTag -> Ordering compareTags = Tag.compareTags
src/GhcTags/CTag/Formatter.hs view
@@ -1,136 +1,136 @@ -- | 'bytestring''s 'Builder' for a 'Tag'--- module GhcTags.CTag.Formatter ( formatTagsFile- -- * format a ctag++ -- * format a ctag , formatTag- -- * format a pseudo-ctag++ -- * format a pseudo-ctag , formatHeader ) where -import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BS-import Data.Char (isAscii)-import Data.List (sortBy)-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+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder qualified as BS+import Data.Char (isAscii)+import Data.List (sortBy)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text.Encoding qualified as Text +import GhcTags.CTag.Header+import GhcTags.CTag.Utils+import GhcTags.Tag+import GhcTags.Utils (endOfLine) -- | '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)+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 (TagLine lineNo) = BS.intDec lineNo formatTagAddress (TagCommand exCommand) =- BS.byteString . Text.encodeUtf8 . getExCommand $ 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-+ 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)-+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+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+ :: (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+ 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_"-+ formatIntHeaderArgs = formatHeaderArgs BS.intDec "!_TAG_" -- | 'ByteString' 'Builder' for vim 'Tag' file.----formatTagsFile :: [Header] -- ^ Headers- -> CTagMap -- ^ 'CTag's- -> Builder-formatTagsFile headers tags = foldMap formatHeader headers- <> (foldMap formatTagLine . sortBy compareTagLine- . Map.foldrWithKey concatTags []- $ tags)+formatTagsFile+ :: [Header]+ -- ^ Headers+ -> CTagMap+ -- ^ 'CTag's+ -> Builder+formatTagsFile headers tags =+ foldMap formatHeader headers+ <> ( foldMap formatTagLine+ . sortBy compareTagLine+ . Map.foldrWithKey concatTags []+ $ tags+ ) where concatTags :: TagFileName -> [CTag] -> [CTagLine] -> [CTagLine] concatTags file ts acc = map (CTagLine file) ts ++ acc
src/GhcTags/CTag/Header.hs view
@@ -3,177 +3,172 @@ , defaultHeaders , HeaderType (..) , SomeHeaderType (..)- -- * Utils++ -- * Utils , SingHeaderType (..) , headerTypeSing ) where import Control.DeepSeq+import Data.Text qualified as T 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. (NFData ty, Show ty) =>- { headerType :: HeaderType ty- , headerLanguage :: Maybe T.Text- , headerArg :: ty- , headerComment :: T.Text- }- -> Header+ Header+ :: forall ty+ . (NFData ty, Show ty)+ => { headerType :: HeaderType ty+ , headerLanguage :: Maybe T.Text+ , headerArg :: ty+ , headerComment :: T.Text+ }+ -> Header instance NFData Header where- rnf Header{..} = rnf headerType- `seq` rnf headerLanguage- `seq` rnf headerArg- `seq` rnf headerComment+ rnf Header {..} =+ rnf headerType+ `seq` rnf headerLanguage+ `seq` rnf headerArg+ `seq` rnf headerComment 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+ 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+deriving stock 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+ 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 instance NFData (HeaderType ty) where rnf (PseudoTag t) = rnf t- rnf ty = ty `seq` ()+ rnf ty = ty `seq` () -deriving instance Eq (HeaderType ty)-deriving instance Ord (HeaderType ty)-deriving instance Show (HeaderType ty)+deriving stock instance Eq (HeaderType ty)+deriving stock instance Ord (HeaderType ty)+deriving stock instance Show (HeaderType ty) -- | Existential wrapper.--- data SomeHeaderType where- SomeHeaderType :: forall ty. HeaderType ty -> SomeHeaderType-+ 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-+ 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+ 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 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 "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 "M" "module" , Header KindDescription haskellLang "f" "function" , Header KindDescription haskellLang "A" "type constructor"
src/GhcTags/CTag/Parser.hs view
@@ -1,75 +1,72 @@ -- | Parser combinators for vim style tags (ctags)--- module GhcTags.CTag.Parser ( parseTagsFile- -- * parse a ctag++ -- * parse a ctag , parseTag- -- * parse a pseudo-ctag++ -- * parse a pseudo-ctag , parseHeader ) where -import Control.Applicative (many, (<|>))-import Control.DeepSeq (NFData)-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 qualified Data.Text as Text--import GhcTags.Tag-import GhcTags.CTag.Header-import GhcTags.CTag.Utils-import qualified GhcTags.Utils as Utils-+import Control.Applicative (many, (<|>))+import Control.DeepSeq (NFData)+import Data.Attoparsec.Text (Parser, (<?>))+import Data.Attoparsec.Text qualified as AT+import Data.Functor (($>))+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text +import GhcTags.CTag.Header+import GhcTags.CTag.Utils+import GhcTags.Tag+import GhcTags.Utils qualified as 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- })+ ( \tagName tagFileName tagAddr (tagKind, tagFields) ->+ ( tagFileName+ , Tag+ { tagName+ , tagAddr+ , tagKind+ , tagFields+ , tagDefinition = NoTagDefinition+ } )+ ) <$> parseTagName- <* separator-+ <* separator <*> parseFileName- <* separator-+ <* separator <*> parseTagAddress-- <*> ( -- kind followed by list of fields or end of line- (,) <$ AT.string ";\""- <* separator- <*> (charToTagKind <$> AT.satisfy notTabOrNewLine)- <*> fieldsInLine-- -- 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.- <|> (NoKind, ) <$ AT.string ";\""- <*> fieldsInLine-- <|> endOfLine $> (NoKind, mempty)+ <*> ( (,) -- kind followed by list of fields or end of line+ <$ AT.string ";\""+ <* separator+ <*> (charToTagKind <$> AT.satisfy notTabOrNewLine)+ <*> fieldsInLine+ -- 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.+ <|> (NoKind,)+ <$ AT.string ";\""+ <*> fieldsInLine+ <|> endOfLine $> (NoKind, mempty) )- where fieldsInLine :: Parser CTagFields- fieldsInLine = separator *> parseFields <* endOfLine- <|>- endOfLine $> mempty+ fieldsInLine =+ separator *> parseFields <* endOfLine+ <|> endOfLine $> mempty separator :: Parser Char separator = AT.char '\t' parseTagName :: Parser TagName- parseTagName = TagName <$> AT.takeWhile (/= '\t')- <?> "parsing tag name failed"+ parseTagName =+ TagName <$> AT.takeWhile (/= '\t')+ <?> "parsing tag name failed" parseFileName :: Parser TagFileName parseFileName = TagFileName <$> AT.takeWhile (/= '\t')@@ -81,111 +78,108 @@ go (Nothing, c0, c1) delim -- Support both forward and backward searches. | delim == '/' || delim == '?' = go (Just delim, c0, c1) delim- | otherwise = Nothing-+ | otherwise = Nothing go (jdelim@(Just delim), c0, c1) c2 -- Continue until the next unescaped delimiter. | c0 /= '\\' && c1 == delim = Nothing- | otherwise = Just (jdelim, c1, c2)+ | otherwise = Just (jdelim, c1, c2) -- We only parse `TagLine` or `TagCommand`. parseTagAddress :: Parser CTagAddress- parseTagAddress = TagLine <$> AT.decimal- <|>- TagCommand <$> parseExSearchCommand+ parseTagAddress =+ TagLine <$> AT.decimal+ <|> TagCommand <$> parseExSearchCommand 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-+ TagField+ <$> AT.takeWhile (\x -> x /= ':' && notTabOrNewLine x)+ <* AT.char ':'+ <*> AT.takeWhile notTabOrNewLine -- | A vim-style tag file parser.--- parseTags :: Parser ([Header], CTagMap)-parseTags = (\headers tags -> (headers, Map.fromListWith (++) $ map sndList tags))- <$> many parseHeader- <*> many parseTag- <* Utils.endOfInput+parseTags =+ (\headers tags -> (headers, Map.fromListWith (++) $ map sndList tags))+ <$> many parseHeader+ <*> many parseTag+ <* Utils.endOfInput where sndList (file, tag) = (file, [tag]) 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+ 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"-+ 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 :: (NFData ty, Show ty)- => HeaderType ty- -> Parser ty- -> Parser Header+ parsePseudoTagArgs+ :: (NFData ty, Show ty)+ => HeaderType ty+ -> Parser ty+ -> Parser Header parsePseudoTagArgs ht parseArg =- Header ht- <$> ( (Just <$> (AT.char '!' *> AT.takeWhile notTabOrNewLine))+ Header ht+ <$> ( (Just <$> (AT.char '!' *> AT.takeWhile notTabOrNewLine)) <|> pure Nothing- )- <*> (AT.char '\t' *> parseArg)- <*> (AT.char '\t' *> parseComment)+ )+ <*> (AT.char '\t' *> parseArg)+ <*> (AT.char '\t' *> parseComment) parseComment :: Parser Text parseComment =- AT.char '/'- *> (dropEndSlash <$> AT.takeWhile notNewLine)- <* endOfLine+ AT.char '/'+ *> (dropEndSlash <$> AT.takeWhile notNewLine)+ <* endOfLine where -- The comment ends with a slash, but a foreign tags file can omit it. dropEndSlash :: Text -> Text@@ -193,30 +187,25 @@ Just t' -> t' Nothing -> t -- -- | Parse a vim-style tag file.----parseTagsFile :: Text- -> IO (Either String ([Header], CTagMap))+parseTagsFile+ :: Text+ -> IO (Either String ([Header], CTagMap)) parseTagsFile =- fmap AT.eitherResult+ 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' $> ()-+endOfLine =+ AT.string "\r\n" $> ()+ <|> AT.char '\r' $> ()+ <|> AT.char '\n' $> () notTabOrNewLine :: Char -> Bool notTabOrNewLine = \x -> x /= '\t' && notNewLine x
src/GhcTags/CTag/Utils.hs view
@@ -1,59 +1,54 @@-{-# LANGUAGE GADTs #-}- module GhcTags.CTag.Utils ( tagKindToChar , charToTagKind ) where -import GhcTags.Tag+import GhcTags.Tag tagKindToChar :: CTagKind -> Maybe Char tagKindToChar tk = case tk of- -- No 'F' kind since it's for a filename.- TkModule -> Just 'M'- TkTerm -> Just '`'- TkFunction -> Just 'f'- TkTypeConstructor -> Just 'A'- 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 'T'- TkTypeFamilyInstance -> Just 't'- TkDataTypeFamily -> Just 'D'- TkDataTypeFamilyInstance -> Just 'd'- TkForeignImport -> Just 'I'- TkForeignExport -> Just 'E'-- CharKind c -> Just c- NoKind -> Nothing-+ -- No 'F' kind since it's for a filename.+ TkModule -> Just 'M'+ TkTerm -> Just '`'+ TkFunction -> Just 'f'+ TkTypeConstructor -> Just 'A'+ 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 'T'+ TkTypeFamilyInstance -> Just 't'+ 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- 'f' -> TkFunction- 'A' -> TkTypeConstructor- 'c' -> TkDataConstructor- 'g' -> TkGADTConstructor- 'r' -> TkRecordField- '=' -> TkTypeSynonym- ':' -> TkTypeSignature- 'p' -> TkPatternSynonym- 'C' -> TkTypeClass- 'm' -> TkTypeClassMember- 'i' -> TkTypeClassInstance- 'T' -> TkTypeFamily- 't' -> TkTypeFamilyInstance- 'D' -> TkDataTypeFamily- 'd' -> TkDataTypeFamilyInstance- 'I' -> TkForeignImport- 'E' -> TkForeignExport-- _ -> CharKind c+ 'M' -> TkModule+ '`' -> TkTerm+ 'f' -> TkFunction+ 'A' -> TkTypeConstructor+ 'c' -> TkDataConstructor+ 'g' -> TkGADTConstructor+ 'r' -> TkRecordField+ '=' -> TkTypeSynonym+ ':' -> TkTypeSignature+ 'p' -> TkPatternSynonym+ 'C' -> TkTypeClass+ 'm' -> TkTypeClassMember+ 'i' -> TkTypeClassInstance+ 'T' -> TkTypeFamily+ 't' -> TkTypeFamilyInstance+ 'D' -> TkDataTypeFamily+ 'd' -> TkDataTypeFamilyInstance+ 'I' -> TkForeignImport+ 'E' -> TkForeignExport+ _ -> CharKind c
src/GhcTags/Config/Args.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-}+ module GhcTags.Config.Args where import Control.Monad@@ -18,60 +19,77 @@ data SourcePaths = SourceArgs [FilePath] | ConfigFile (Maybe FilePath)- deriving Show+ deriving stock (Show) data Args = Args- { aTagType :: TagType- , aTagFile :: FilePath- , aThreads :: Int- , aSourcePaths :: SourcePaths+ { aTagType :: TagType+ , aTagFile :: FilePath+ , aThreads :: Int+ , aSourcePaths :: SourcePaths , aExModeSearch :: Bool- } deriving Show+ }+ deriving stock (Show) argsParser :: Int -> Parser Args argsParser defaultThreads = do- aTagType <- ctags <|> etags- aTagFile0 <- tagFile- aThreads <- threads- aSourcePaths <- (SourceArgs <$> sourcePaths) <|> (ConfigFile <$> configFile)+ aTagType <- ctags <|> etags+ aTagFile0 <- tagFile+ aThreads <- threads+ aSourcePaths <- (SourceArgs <$> sourcePaths) <|> (ConfigFile <$> configFile) aExModeSearch <- exModeSearch- pure $ Args { aTagFile = if null aTagFile0- then defaultOutputFile aTagType- else aTagFile0- , ..- }+ pure $+ Args+ { aTagFile =+ if null aTagFile0+ then defaultOutputFile aTagType+ else aTagFile0+ , ..+ } where ctags :: Parser TagType- ctags = flag' CTag $ long "ctags"- <> short 'c'- <> help "Generate ctags"+ ctags =+ flag' CTag $+ long "ctags"+ <> short 'c'+ <> help "Generate ctags" etags :: Parser TagType- etags = flag' ETag $ long "etags"- <> short 'e'- <> help "Generate etags"+ etags =+ flag' ETag $+ long "etags"+ <> short 'e'+ <> help "Generate etags" tagFile :: Parser FilePath- tagFile = strOption $ short 'f'- <> short 'o'- <> metavar "FILE"- <> help "Output file"- <> value ""- <> showDefaultWith (const "TAGS (etags) or tags (ctags)")+ tagFile =+ strOption $+ short 'f'+ <> short 'o'+ <> metavar "FILE"+ <> help "Output file"+ <> value ""+ <> showDefaultWith (const "TAGS (etags) or tags (ctags)") configFile :: Parser (Maybe FilePath)- configFile = optional . strOption $ long "config"- <> metavar "FILE"- <> help ("Configuration file (default: "- ++ intercalate ", then " defaultConfigFiles ++ ")")+ configFile =+ optional . strOption $+ long "config"+ <> metavar "FILE"+ <> help+ ( "Configuration file (default: "+ ++ intercalate ", then " defaultConfigFiles+ ++ ")"+ ) threads :: Parser Int- threads = option positive $ long "threads"- <> short 'j'- <> metavar "NUMBER"- <> value defaultThreads- <> showDefault- <> help "Number of threads to use"+ threads =+ option positive $+ long "threads"+ <> short 'j'+ <> metavar "NUMBER"+ <> value defaultThreads+ <> showDefault+ <> help "Number of threads to use" where -- Zero deadlocks the queue and 'setNumCapabilities' rejects anything -- below one, so stop such a value here with a readable message.@@ -85,20 +103,25 @@ sourcePaths = some . argument str $ metavar "<source paths...>" exModeSearch :: Parser Bool- exModeSearch = switch $ long "ex-mode-search"- <> help "Use Ex mode commands instead of line numbers (ctags)"+ exModeSearch =+ switch $+ long "ex-mode-search"+ <> help "Use Ex mode commands instead of line numbers (ctags)" parseArgs :: Int -> [String] -> IO Args parseArgs defaultThreads = handleParseResult . execParserPure defaultPrefs opts where- opts = info- (argsParser defaultThreads <**> defaultConfigFlag <**> versionFlag <**> helper)- fullDesc+ opts =+ info+ (argsParser defaultThreads <**> defaultConfigFlag <**> versionFlag <**> helper)+ fullDesc - defaultConfigFlag = infoOption (ppProjectConfig defaultProjectConfig)- $ long "default"- <> help "Show a default configuration file"+ defaultConfigFlag =+ infoOption (ppProjectConfig defaultProjectConfig) $+ long "default"+ <> help "Show a default configuration file" - versionFlag = infoOption (showVersion version)- $ long "version"- <> help "Show version"+ versionFlag =+ infoOption (showVersion version) $+ long "version"+ <> help "Show version"
src/GhcTags/Config/Project.hs view
@@ -1,78 +1,98 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}+ module GhcTags.Config.Project where import Control.Monad-import Data.Aeson-import Data.Aeson.Types-import Data.Maybe-import Data.List-import Data.Ord+import Data.Map.Strict qualified as Map+import Data.Text qualified as T import GHC.Driver.Flags import GHC.Driver.Session+import GHC.Generics (Generic) import GHC.LanguageExtensions import GHC.Settings import System.Directory import System.IO-import qualified Data.Aeson.Key as K-import qualified Data.Aeson.KeyMap as K-import qualified Data.ByteString.Char8 as BS-import qualified Data.Map.Strict as Map-import qualified Data.Text as T-import qualified Data.Yaml as Y-import qualified Data.Yaml.Pretty as Y+import Yamlet qualified as Y -- | A language extension to either enable or disable. data ExtensionFlag = EnableExtension Extension | DisableExtension Extension- deriving (Eq, Show)+ deriving stock (Eq, Show) data ProjectConfig = ProjectConfig- { pcSourcePaths :: [FilePath]+ { pcSourcePaths :: [FilePath] , pcExcludePaths :: [FilePath]- , pcLanguage :: Language- , pcExtensions :: [ExtensionFlag]- , pcCppIncludes :: [FilePath]- , pcCppOptions :: [String]+ , pcLanguage :: Language+ , pcExtensions :: [ExtensionFlag]+ , pcCppIncludes :: [FilePath]+ , pcCppOptions :: [String] }+ deriving stock (Generic)+ deriving (Y.FromYaml, Y.ToYaml) via Y.GenericYaml ProjectConfig +-- | The keys are the field names without the prefix in snake case, e.g.+-- @source_paths@. A missing key takes its value from 'defaultProjectConfig'.+instance Y.GenericYamlOptions ProjectConfig where+ yamlOptions =+ Y.defaultYamlOptions+ { Y.fieldLabelModifier = Y.snakeCase . drop (length prefix)+ }+ where+ prefix :: String+ prefix = "pc"++ yamlDefault = Just defaultProjectConfig+ defaultProjectConfig :: ProjectConfig-defaultProjectConfig = ProjectConfig- { pcSourcePaths = [ "."- ]- , pcExcludePaths = [ ".stack-work"- , "dist"- , "dist-newstyle"- ]- , pcLanguage = Haskell2010- , pcExtensions = map EnableExtension- [ BangPatterns- , BinaryLiterals- , BlockArguments- , CApiFFI- , ExplicitForAll- , ExplicitNamespaces- , GADTSyntax- , ImportQualifiedPost- , LambdaCase- , LinearTypes- , MagicHash+defaultProjectConfig =+ ProjectConfig+ { pcSourcePaths =+ [ "."+ ]+ , pcExcludePaths =+ [ ".stack-work"+ , "dist"+ , "dist-newstyle"+ ]+ , pcLanguage = Haskell2010+ , pcExtensions =+ map EnableExtension $+ [ BangPatterns+ , BinaryLiterals+ , BlockArguments+ , CApiFFI+ , ExplicitForAll+ , ExplicitNamespaces+ , GADTSyntax+ , ImportQualifiedPost+ , LambdaCase+ , LinearTypes+ , MagicHash+ ]+ ++ multilineStrings+ ++ [ MultiWayIf+ , NumericUnderscores+ , OverloadedLabels+ , PatternSynonyms+ , QualifiedDo+ , QuasiQuotes+ , TemplateHaskellQuotes+ , TypeApplications+ , UnicodeSyntax+ ]+ , pcCppIncludes = []+ , pcCppOptions = []+ }++-- At the top level, because fourmolu cannot format CPP inside a where clause.+multilineStrings :: [Extension] #if __GLASGOW_HASKELL__ >= 912- , MultilineStrings+multilineStrings = [MultilineStrings]+#else+multilineStrings = [] #endif- , MultiWayIf- , NumericUnderscores- , OverloadedLabels- , PatternSynonyms- , QualifiedDo- , QuasiQuotes- , TemplateHaskellQuotes- , TypeApplications- , UnicodeSyntax- ]- , pcCppIncludes = []- , pcCppOptions = []- } -- | Configuration files probed when '--config' is not given, in the order of -- precedence.@@ -83,40 +103,45 @@ -- none, from the first of 'defaultConfigFiles' that exists. Return 'Nothing' -- when the file exists and cannot be parsed. getProjectConfigs :: Maybe FilePath -> IO (Maybe [ProjectConfig])-getProjectConfigs mfile = resolve >>= \case- Nothing -> pure $ Just [defaultProjectConfig]- Just file -> Y.decodeAllFileEither file >>= \case- Left e -> do- hPutStrLn stderr $ file ++ ": " ++ Y.prettyPrintParseException e- pure Nothing- Right pcs -> pure $ Just pcs+getProjectConfigs mfile =+ resolve >>= \case+ Nothing -> pure $ Just [defaultProjectConfig]+ Just file ->+ Y.decodeAllFile @ProjectConfig file >>= \case+ Left errs -> do+ mapM_ (hPutStrLn stderr . Y.prettyError file) errs+ pure Nothing+ Right pcs -> pure $ Just pcs where resolve :: IO (Maybe FilePath) resolve = case mfile of- Just file -> doesFileExist file >>= \case- True -> pure $ Just file- False -> pure Nothing- Nothing -> filterM doesFileExist defaultConfigFiles >>= \case- [] -> pure Nothing- file : others -> do- forM_ others $ \other -> hPutStrLn stderr $- "Warning: both " ++ file ++ " and " ++ other- ++ " exist, reading " ++ file- pure $ Just file+ Just file ->+ doesFileExist file >>= \case+ True -> pure $ Just file+ False -> pure Nothing+ Nothing ->+ filterM doesFileExist defaultConfigFiles >>= \case+ [] -> pure Nothing+ file : others -> do+ forM_ others $ \other ->+ hPutStrLn stderr $+ "Warning: both "+ ++ file+ ++ " and "+ ++ other+ ++ " exist, reading "+ ++ file+ pure $ Just file 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)+ppProjectConfig = T.unpack . Y.encodeText adjustDynFlags :: ProjectConfig -> DynFlags -> DynFlags-adjustDynFlags ProjectConfig{..} = applyCppOptions- . applyCppIncludes- . applyExtensions- . applyLanguage+adjustDynFlags ProjectConfig {..} =+ applyCppOptions+ . applyCppIncludes+ . applyExtensions+ . applyLanguage where applyLanguage fs = lang_set fs (Just pcLanguage) @@ -124,81 +149,43 @@ where setExtension :: DynFlags -> ExtensionFlag -> DynFlags setExtension acc = \case- EnableExtension ext -> xopt_set acc ext+ EnableExtension ext -> xopt_set acc ext DisableExtension ext -> xopt_unset acc ext applyCppIncludes fs =- fs { includePaths = addGlobalInclude (includePaths fs) pcCppIncludes- }+ 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- }- }+ 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 showExtensionFlag pcExtensions- , "cpp_includes" .= pcCppIncludes- , "cpp_options" .= pcCppOptions- ]--instance FromJSON ProjectConfig where- parseJSON (Object v) = do- checkUnknownKeys . map K.toText $ K.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 parseExtensionFlag) 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)+-- YAML instances - 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+instance Y.FromYaml Language where+ parseYaml = Y.withText $ \t -> case readLanguage t of+ Just lang -> pure lang+ Nothing -> fail $ "unknown language: " ++ T.unpack t - parseExtensionFlag :: Value -> Parser ExtensionFlag- parseExtensionFlag (String t) = case readExtensionFlag t of- Just ext -> pure ext- Nothing -> fail $ "unknown extension: " ++ T.unpack t- parseExtensionFlag inv = typeMismatch "String" inv+instance Y.ToYaml Language where+ toYaml = Y.toYaml . show - parseJSON v = prependFailure "parsing project configuration failed: " $- typeMismatch "Object" v+instance Y.FromYaml ExtensionFlag where+ parseYaml = Y.withText $ \t -> case readExtensionFlag t of+ Just ext -> pure ext+ Nothing -> fail $ "unknown extension: " ++ T.unpack t -projectConfigKeys :: [T.Text]-projectConfigKeys = [ "source_paths"- , "exclude_paths"- , "language"- , "extensions"- , "cpp_includes"- , "cpp_options"- ]+instance Y.ToYaml ExtensionFlag where+ toYaml = Y.toYaml . showExtensionFlag ---------------------------------------- -- Utils@@ -213,7 +200,7 @@ showExtensionFlag :: ExtensionFlag -> T.Text showExtensionFlag = \case- EnableExtension ext -> showExtension ext+ EnableExtension ext -> showExtension ext DisableExtension ext -> "No" <> showExtension ext where showExtension :: Extension -> T.Text@@ -226,12 +213,14 @@ readExtensionFlag :: T.Text -> Maybe ExtensionFlag readExtensionFlag name = case readExtension name of Just ext -> Just $ EnableExtension ext- Nothing -> DisableExtension <$> (readExtension =<< T.stripPrefix "No" name)+ Nothing -> DisableExtension <$> (readExtension =<< T.stripPrefix "No" name) where 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]+ exts =+ Map.fromList+ . (("CPP", Cpp) :)+ . map (\e -> (T.pack $ show e, e))+ $ filter (/= Cpp) [minBound .. maxBound]
src/GhcTags/ETag.hs view
@@ -3,20 +3,18 @@ , compareTags ) where -import Data.Function (on)--import GhcTags.ETag.Formatter as X-import GhcTags.ETag.Parser as X--import GhcTags.Tag ( Tag (..)- , ETag- )+import Data.Function (on) +import GhcTags.ETag.Formatter as X+import GhcTags.ETag.Parser as X+import GhcTags.Tag+ ( ETag+ , Tag (..)+ ) -- | Order 'ETag's according to addr, name and kind.--- compareTags :: ETag -> ETag -> Ordering compareTags t0 t1 =- on compare tagAddr t0 t1+ on compare tagAddr t0 t1 <> on compare tagName t0 t1 <> on compare tagKind t0 t1
src/GhcTags/ETag/Formatter.hs view
@@ -1,5 +1,4 @@ -- | Simple etags formatter. See <https://en.wikipedia.org/wiki/Ctags#Etags>--- module GhcTags.ETag.Formatter ( formatETagsFile , formatTagsFile@@ -7,43 +6,41 @@ , BuilderWithSize (..) ) where -import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BB-import qualified Data.Map.Strict as Map-import qualified Data.Text.Encoding as Text--import GhcTags.Tag+import Data.ByteString qualified as BS+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder qualified as BB+import Data.Map.Strict qualified as Map+import Data.Text.Encoding qualified as Text +import GhcTags.Tag -- | A product of two monoids: 'Builder' and 'Sum'.----data BuilderWithSize = BuilderWithSize {- builder :: Builder,- builderSize :: Int+data BuilderWithSize = BuilderWithSize+ { builder :: Builder+ , builderSize :: Int } instance Semigroup BuilderWithSize where- BuilderWithSize b0 s0 <> BuilderWithSize b1 s1 =- BuilderWithSize (b0 <> b1) (s0 + s1)+ BuilderWithSize b0 s0 <> BuilderWithSize b1 s1 =+ BuilderWithSize (b0 <> b1) (s0 + s1) instance Monoid BuilderWithSize where- mempty = BuilderWithSize mempty 0+ mempty = BuilderWithSize mempty 0 formatTag :: ETag -> BuilderWithSize formatTag Tag {tagName, tagAddr = TagLineOff 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+ 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+ NoTagDefinition -> tagNameBS TagDefinition def -> Text.encodeUtf8 def tagDefinitionSize = BS.length tagDefinitionBS @@ -51,35 +48,32 @@ tagNameSize = BS.length tagNameBS tagSize =- 3 -- delimiters: '\DEL', '\SOH', ','- + tagNameSize- + tagDefinitionSize- + (length $ show lineNr)- + (length $ show byteOffset)- + (length $ endOfLine)-+ 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'+ 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-+ 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
src/GhcTags/ETag/Parser.hs view
@@ -1,86 +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+import Control.Applicative (many, (<|>))+import Data.Attoparsec.Text (Parser, (<?>))+import Data.Attoparsec.Text qualified as AT+import Data.Functor (($>))+import Data.Map.Strict qualified as Map+import Data.Text (Text) +import GhcTags.Tag+import GhcTags.Utils qualified as Utils -- | Parse whole etags file----parseTagsFile :: Text- -> IO (Either String ETagMap)+parseTagsFile+ :: Text+ -> IO (Either String ETagMap) parseTagsFile = fmap AT.eitherResult . AT.parseWith (pure mempty) parseTags where parseTags :: Parser ETagMap parseTags = Map.fromList <$> many parseTagFileSection <* Utils.endOfInput - -- | Parse tags from a single file (a single section in etags file).--- parseTagFileSection :: Parser (TagFileName, [ETag]) parseTagFileSection =- (,) <$> (AT.char '\x0c' *> endOfLine *> parseTagFile)- <*> many parseTag+ (,)+ <$> (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"-+ 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"+ 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 = TagLineOff lineNo byteOffset- , tagDefinition = case mTagName of- Nothing -> NoTagDefinition- Just _ -> TagDefinition tagDefinition- , tagFields = NoTagFields- }+ mkTag tagDefinition mTagName lineNo byteOffset =+ Tag+ { tagName = case mTagName of+ Nothing -> TagName tagDefinition+ Just name -> name+ , tagKind = NoKind+ , tagAddr = TagLineOff 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"+ 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"+ 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' $> ()+endOfLine =+ AT.string "\r\n" $> ()+ <|> AT.char '\r' $> ()+ <|> AT.char '\n' $> ()
src/GhcTags/Ghc.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP #-} -- | Generate tags from @'HsModule' 'GhcPs'@ representation.--- module GhcTags.Ghc ( GhcTag (..) , GhcTagKind (..)@@ -9,9 +7,10 @@ ) where import Data.ByteString (ByteString)+import Data.Foldable qualified as F import Data.Maybe import GHC.Data.FastString-import GHC.Hs (HsModule(..), NoExtField(..))+import GHC.Hs (HsModule (..), NoExtField (..)) import GHC.Hs.Binds import GHC.Hs.Decls hiding (famResultKindSignature) import GHC.Hs.Expr@@ -25,134 +24,138 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import Language.Haskell.Syntax.Module.Name-import qualified Data.Foldable as F +import GhcTags.GhcCompat+ -- | 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 (HsWildCardBndrs GhcPs (LHsSigType GhcPs))- | GtkTypeClassInstance (HsType GhcPs)- | GtkTypeFamily (Maybe ([HsTyVarBndr (HsBndrVis GhcPs) GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs)))- | GtkTypeFamilyInstance (TyFamInstDecl GhcPs)- | GtkDataTypeFamily (Maybe ([HsTyVarBndr (HsBndrVis GhcPs) GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs)))- | GtkDataTypeFamilyInstance (Maybe (HsKind GhcPs))- | GtkForeignImport- | GtkForeignExport+ = 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 (HsWildCardBndrs GhcPs (LHsSigType GhcPs))+ | GtkTypeClassInstance (HsType GhcPs)+ | GtkTypeFamily+ ( Maybe+ ([HsTyVarBndr (HsBndrVis GhcPs) GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs))+ )+ | GtkTypeFamilyInstance (TyFamInstDecl GhcPs)+ | GtkDataTypeFamily+ ( Maybe+ ([HsTyVarBndr (HsBndrVis GhcPs) 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+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 ByteString- -- ^ @ffi@ import+ -- ^ 'True' iff the term is exported+ , gtFFI :: Maybe ByteString+ -- ^ @ffi@ import } -- | Check if an identifier is exported.--- isExported :: Maybe [IE GhcPs] -> LocatedN RdrName -> Bool-isExported Nothing _name = True+isExported Nothing _name = True isExported (Just ies) (L _ name) =- any (\ie -> listToMaybe (ieNames ie) == Just name) ies+ any (\ie -> listToMaybe (ieNames ie) == Just name) ies -- | Check if a class member or a type constructors is exported.----isMemberExported :: Maybe [IE GhcPs]- -> LocatedN RdrName -- member name / constructor name- -> LocatedN RdrName -- type class name / type constructor name- -> Bool-isMemberExported Nothing _memberName _className = True-isMemberExported (Just ies) memberName className = any go ies+isMemberExported+ :: Maybe [IE GhcPs]+ -> LocatedN RdrName -- member name / constructor name+ -> LocatedN 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 (IEThingAbs _ _ _) = False go (IEThingAll _ (L _ n) _) = ieWrappedName n == unLoc className-- go (IEThingWith _ _ IEWildcard{} _ _) = True-+ go (IEThingWith _ _ IEWildcard {} _ _) = True go (IEThingWith _ (L _ n) NoIEWildcard ns _) =- ieWrappedName n == unLoc className- && isInWrappedNames+ ieWrappedName n == unLoc className+ && isInWrappedNames 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-+ isInWrappedNames =+ any+ ( (== occNameFS (rdrNameOcc (unLoc memberName)))+ . occNameFS+ . rdrNameOcc+ . ieWrappedName+ . unLoc+ )+ ns go _ = False - -- | Create a 'GhcTag', effectively a smart constructor.----mkGhcTag :: LocatedN RdrName- -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier.- -> GhcTagKind- -- ^ tag's kind- -> Bool- -- ^ is term exported- -> GhcTag+mkGhcTag+ :: LocatedN 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 loc rdrName) gtKind gtIsExported =- case rdrName of- Unqual occName ->- GhcTag { gtTag = bytesFS (occNameFS occName)- , gtSrcSpan = getHasLoc loc- , gtKind- , gtIsExported- , gtFFI = Nothing- }-- Qual _ occName ->- GhcTag { gtTag = bytesFS (occNameFS occName)- , gtSrcSpan = getHasLoc loc- , gtKind- , gtIsExported- , gtFFI = Nothing- }-- -- Orig is the only one we are interested in- Orig _ occName ->- GhcTag { gtTag = bytesFS (occNameFS occName)- , gtSrcSpan = getHasLoc loc- , gtKind- , gtIsExported- , gtFFI = Nothing- }-- Exact eName ->- GhcTag { gtTag = bytesFS (occNameFS (nameOccName eName))- , gtSrcSpan = getHasLoc loc- , gtKind- , gtIsExported- , gtFFI = Nothing- }-+ case rdrName of+ Unqual occName ->+ GhcTag+ { gtTag = bytesFS (occNameFS occName)+ , gtSrcSpan = getHasLoc loc+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }+ Qual _ occName ->+ GhcTag+ { gtTag = bytesFS (occNameFS occName)+ , gtSrcSpan = getHasLoc loc+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }+ -- Orig is the only one we are interested in+ Orig _ occName ->+ GhcTag+ { gtTag = bytesFS (occNameFS occName)+ , gtSrcSpan = getHasLoc loc+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ }+ Exact eName ->+ GhcTag+ { gtTag = bytesFS (occNameFS (nameOccName eName))+ , gtSrcSpan = getHasLoc loc+ , gtKind+ , gtIsExported+ , gtFFI = Nothing+ } -- | Generate tags for a module - simple walk over the syntax tree. --@@ -173,12 +176,12 @@ -- * /data type families/ -- * /data type families instances/ -- * /data type family instances constructors/----getGhcTags :: Located (HsModule GhcPs)- -> [GhcTag]-getGhcTags (L _ HsModule { hsmodName, hsmodDecls, hsmodExports }) =- maybeToList (mkModNameTag <$> hsmodName)- ++ hsDeclsToGhcTags mies hsmodDecls+getGhcTags+ :: Located (HsModule GhcPs)+ -> [GhcTag]+getGhcTags (L _ HsModule {hsmodName, hsmodDecls, hsmodExports}) =+ maybeToList (mkModNameTag <$> hsmodName)+ ++ hsDeclsToGhcTags mies hsmodDecls where mies :: Maybe [IE GhcPs] mies = case map unLoc . unLoc <$> hsmodExports of@@ -186,219 +189,222 @@ -- names no entity, so looking a name up in it always fails. 'isExported' -- takes an absent list to mean that everything is exported. Just ies | any exportsSelf ies -> Nothing- exports -> exports+ exports -> exports where exportsSelf :: IE GhcPs -> Bool exportsSelf = \case IEModuleContents _ (L _ name) -> Just name == (unLoc <$> hsmodName)- _ -> False+ _ -> False mkModNameTag :: LocatedA ModuleName -> GhcTag mkModNameTag (L l modName) =- GhcTag { gtSrcSpan = locA l- , gtTag = bytesFS $ moduleNameFS modName- , gtKind = GtkModule- , gtIsExported = True- , gtFFI = Nothing- }+ GhcTag+ { gtSrcSpan = locA l+ , gtTag = bytesFS $ moduleNameFS modName+ , gtKind = GtkModule+ , gtIsExported = True+ , gtFFI = Nothing+ } -hsDeclsToGhcTags :: Maybe [IE GhcPs]- -> [LHsDecl GhcPs]- -> [GhcTag]+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+ 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).- -> LocatedN RdrName- -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level- -- identifier.- -> GhcTagKind- -- ^ tag's kind- -> GhcTag+ mkGhcTag'+ :: SrcSpan+ -- \^ declaration's location; it is useful when the term does not+ -- contain useful inforamtion (e.g. code generated from template+ -- haskell splices).+ -> LocatedN 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'- -> LocatedN RdrName -- member name- -> LocatedN RdrName -- class name- -> GhcTagKind- -> GhcTag+ mkGhcTagForMember+ :: SrcSpan+ -- \^ declartion's 'SrcSpan'+ -> LocatedN RdrName -- member name+ -> LocatedN RdrName -- class name+ -> GhcTagKind+ -> GhcTag mkGhcTagForMember decLoc memberName className kind =- fixLoc decLoc $ mkGhcTag memberName kind- (isMemberExported mies memberName className)+ fixLoc decLoc $+ mkGhcTag+ memberName+ kind+ (isMemberExported mies memberName className) -- Main routine which traverse all top level declarations. -- go :: LHsDecl GhcPs -> [GhcTag] -> [GhcTag]- go (L loc hsDecl) tags = let decLoc = getHasLoc loc in 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 } ->+ go (L loc hsDecl) tags =+ let decLoc = getHasLoc loc+ in 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)- ++ map- (\(L _ decl@TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon } }) ->- mkGhcTagForMember decLoc feqn_tycon tcdLName- (GtkTypeFamilyInstance decl))- 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@- L _ HsSig { sig_body } ->- case mkLHsTypeTag decLoc sig_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-- -- standalone deriving declaration- DerivD _ DerivDecl { deriv_type = HsWC { hswc_body = L _ HsSig { sig_body } } } ->- maybe tags (: tags) (mkLHsTypeTag decLoc sig_body)-- -- 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 (L _ sourceText) _ _ _mheader _ } ->- case sourceText of- NoSourceText -> tag- -- TODO: add header information from '_mheader'- SourceText s -> tag { gtFFI = Just $ bytesFS s }- : tags- where- tag = mkGhcTag' decLoc fd_name GtkForeignImport-- ForeignExport { fd_name } ->- mkGhcTag' decLoc fd_name GtkForeignExport- : tags-- WarningD {} -> tags- AnnD {} -> tags+ : (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)+ ++ map+ ( \(L _ decl@TyFamInstDecl {tfid_eqn = FamEqn {feqn_tycon}}) ->+ mkGhcTagForMember+ decLoc+ feqn_tycon+ tcdLName+ (GtkTypeFamilyInstance decl)+ )+ 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@+ L _ HsSig {sig_body} ->+ case mkLHsTypeTag decLoc sig_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 - -- TODO: Rules are named it would be nice to get them too- RuleD {} -> tags- SpliceD {} -> tags- DocD {} -> tags- RoleAnnotD {} -> 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+ -- standalone deriving declaration+ DerivD _ DerivDecl {deriv_type = HsWC {hswc_body = L _ HsSig {sig_body}}} ->+ maybe tags (: tags) (mkLHsTypeTag decLoc sig_body)+ -- 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 (L _ sourceText) _ _ _mheader _} ->+ case sourceText of+ NoSourceText -> tag+ -- TODO: add header information from '_mheader'+ SourceText s -> tag {gtFFI = Just $ bytesFS 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- -> LocatedN RdrName- -- name of the type- -> ConDecl GhcPs- -- constructor declaration- -> [GhcTag]-- mkConsTags decLoc tyName con@ConDeclGADT { con_names, con_g_args } =- (\n -> mkGhcTagForMember decLoc n tyName (GtkGADTConstructor con))- `map` F.toList con_names- ++ mkHsConDeclGADTDetails decLoc tyName con_g_args+ mkConsTags+ :: SrcSpan+ -> LocatedN RdrName+ -- name of the type+ -> ConDecl GhcPs+ -- constructor declaration+ -> [GhcTag] - mkConsTags decLoc tyName con@ConDeclH98 { con_name, con_args } =- mkGhcTagForMember decLoc con_name tyName- (GtkDataConstructor con)- : mkHsConDeclH98Details decLoc tyName con_args+ mkConsTags decLoc tyName con@ConDeclGADT {con_names, con_g_args} =+ (\n -> mkGhcTagForMember decLoc n tyName (GtkGADTConstructor con))+ `map` F.toList con_names+ ++ mkHsConDeclGADTDetails decLoc tyName con_g_args+ mkConsTags decLoc tyName con@ConDeclH98 {con_name, con_args} =+ mkGhcTagForMember+ decLoc+ con_name+ tyName+ (GtkDataConstructor con)+ : mkHsConDeclH98Details decLoc tyName con_args mkHsLocalBindsTags :: SrcSpan -> HsLocalBinds GhcPs -> [GhcTag] mkHsLocalBindsTags decLoc (HsValBinds _ (ValBinds _ hsBindsLR sigs)) =- -- where clause bindings- concatMap (mkHsBindLRTags decLoc . unLoc) hsBindsLR- ++ concatMap (mkSigTags decLoc . unLoc) sigs-+ -- where clause bindings+ concatMap (mkHsBindLRTags decLoc . unLoc) hsBindsLR+ ++ concatMap (mkSigTags decLoc . unLoc) sigs mkHsLocalBindsTags _ _ = [] mkHsConDeclGADTDetails@@ -407,19 +413,11 @@ -> HsConDeclGADTDetails GhcPs -> [GhcTag] mkHsConDeclGADTDetails decLoc tyName (RecConGADT _ (L _ fields)) =- foldr f [] fields+ foldr (\field ts -> ts ++ map g (recFieldNames field)) [] fields where-#if __GLASGOW_HASKELL__ >= 914- f :: LHsConDeclRecField GhcPs -> [GhcTag] -> [GhcTag]- f (L _ HsConDeclRecField { cdrf_names }) ts = ts ++ map g cdrf_names-#else- f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]- f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names-#endif- g :: LFieldOcc GhcPs -> GhcTag- g (L _ FieldOcc { foLabel }) =- mkGhcTagForMember decLoc foLabel tyName GtkRecordField+ g (L _ FieldOcc {foLabel}) =+ mkGhcTagForMember decLoc foLabel tyName GtkRecordField mkHsConDeclGADTDetails _ _ _ = [] mkHsConDeclH98Details@@ -428,55 +426,46 @@ -> HsConDeclH98Details GhcPs -> [GhcTag] mkHsConDeclH98Details decLoc tyName (RecCon (L _ fields)) =- foldr f [] fields+ foldr (\field ts -> ts ++ map g (recFieldNames field)) [] fields where-#if __GLASGOW_HASKELL__ >= 914- f :: LHsConDeclRecField GhcPs -> [GhcTag] -> [GhcTag]- f (L _ HsConDeclRecField { cdrf_names }) ts = ts ++ map g cdrf_names-#else- f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]- f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names-#endif- g :: LFieldOcc GhcPs -> GhcTag- g (L _ FieldOcc { foLabel }) =- mkGhcTagForMember decLoc foLabel tyName GtkRecordField+ g (L _ FieldOcc {foLabel}) =+ mkGhcTagForMember decLoc foLabel tyName GtkRecordField mkHsConDeclH98Details _ _ _ = [] - mkHsBindLRTags :: SrcSpan- -- ^ declaration's 'SrcSpan'- -> HsBindLR GhcPs GhcPs- -> [GhcTag]+ mkHsBindLRTags+ :: SrcSpan+ -- \^ declaration's 'SrcSpan'+ -> HsBindLR GhcPs GhcPs+ -> [GhcTag] mkHsBindLRTags decLoc hsBind = case hsBind of- FunBind { fun_id, fun_matches } ->- let binds = map (grhssLocalBinds . m_grhss . unLoc)- . unLoc- . mg_alts- $ fun_matches- in mkGhcTag' decLoc fun_id GtkFunction+ FunBind {fun_id, fun_matches} ->+ let binds =+ map (grhssLocalBinds . m_grhss . unLoc)+ . unLoc+ . mg_alts+ $ fun_matches+ in mkGhcTag' decLoc fun_id GtkFunction : concatMap (mkHsLocalBindsTags decLoc) binds-- PatBind { pat_lhs, pat_rhs } ->- -- 'collectPatBinders' drops the location of each binder, so every- -- tag points at the start of the pattern.- let binder :: RdrName -> GhcTag- binder name =- mkGhcTag' decLoc (L (noAnnSrcSpan (getLocA pat_lhs)) name) GtkTerm- in map binder (collectPatBinders CollNoDictBinders pat_lhs)- ++ mkHsLocalBindsTags decLoc (grhssLocalBinds pat_rhs)-- -- According to the GHC documentation VarBinds are introduced by the- -- type checker, so ghc-tags will never encounter them.- VarBind {} -> []-- PatSynBind _ PSB { psb_id, psb_args } ->- mkGhcTag' decLoc psb_id GtkPatternSynonym : case psb_args of- RecCon fields ->- let fldLabel fld = case recordPatSynField fld of- FieldOcc _ label -> label- XFieldOcc _ -> error "can't happen"- in map (\fld -> mkGhcTag' decLoc (fldLabel fld) GtkRecordField) fields- _ -> []+ PatBind {pat_lhs, pat_rhs} ->+ -- 'collectPatBinders' drops the location of each binder, so every+ -- tag points at the start of the pattern.+ let binder :: RdrName -> GhcTag+ binder name =+ mkGhcTag' decLoc (L (noAnnSrcSpan (getLocA pat_lhs)) name) GtkTerm+ in map binder (collectPatBinders CollNoDictBinders pat_lhs)+ ++ mkHsLocalBindsTags decLoc (grhssLocalBinds pat_rhs)+ -- According to the GHC documentation VarBinds are introduced by the+ -- type checker, so ghc-tags will never encounter them.+ VarBind {} -> []+ PatSynBind _ PSB {psb_id, psb_args} ->+ mkGhcTag' decLoc psb_id GtkPatternSynonym : case psb_args of+ RecCon fields ->+ let fldLabel fld = case recordPatSynField fld of+ FieldOcc _ label -> label+ XFieldOcc _ -> error "can't happen"+ in map (\fld -> mkGhcTag' decLoc (fldLabel fld) GtkRecordField) fields+ _ -> [] mkClsMemberTags :: SrcSpan -> LocatedN RdrName -> Sig GhcPs -> [GhcTag] mkClsMemberTags decLoc clsName (ClassOpSig _ isDefault lhs hsSigWcType)@@ -484,119 +473,132 @@ -- implementation, it doesn't declare the member. | isDefault = [] | otherwise =- (\n -> mkGhcTagForMember decLoc n clsName $- GtkTypeClassMember HsWC { hswc_ext = NoExtField- , hswc_body = hsSigWcType- }) `map` lhs+ ( \n ->+ mkGhcTagForMember decLoc n clsName $+ GtkTypeClassMember+ HsWC+ { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }+ )+ `map` lhs mkClsMemberTags _ _ _ = [] - mkSigTags :: SrcSpan -> Sig GhcPs -> [GhcTag]- mkSigTags decLoc (TypeSig _ lhs hsSigWcType) =+ 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+ 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+ flip+ (mkGhcTag' decLoc)+ ( GtkTypeSignature+ HsWC+ { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }+ )+ `map` lhs -- TODO: generate theses with additional info (fixity)- mkSigTags _ FixSig {} = []- mkSigTags _ InlineSig {} = []+ mkSigTags _ FixSig {} = []+ mkSigTags _ InlineSig {} = [] -- SPECIALISE pragmas- mkSigTags _ SpecSig {} = []-#if __GLASGOW_HASKELL__ >= 914- mkSigTags _ SpecSigE {} = []-#endif- mkSigTags _ SpecInstSig {} = []+ mkSigTags _ SpecSig {} = []+ mkSigTags _ SpecSigE {} = []+ mkSigTags _ SpecInstSig {} = [] -- MINIMAL pragma- mkSigTags _ MinimalSig {} = []+ mkSigTags _ MinimalSig {} = [] -- SSC pragma- mkSigTags _ SCCFunSig {} = []+ mkSigTags _ SCCFunSig {} = [] -- COMPLETE pragma- mkSigTags _ CompleteMatchSig {} = []+ mkSigTags _ CompleteMatchSig {} = [] - mkFamilyDeclTags :: SrcSpan- -> FamilyDecl GhcPs- -- ^ declaration's 'SrcSpan'- -> Maybe (LocatedN 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 =+ mkFamilyDeclTags+ :: SrcSpan+ -> FamilyDecl GhcPs+ -- \^ declaration's 'SrcSpan'+ -> Maybe (LocatedN 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+ 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+ 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+ 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+ :: SrcSpan+ -- declartaion's 'SrcSpan'+ -> LHsType GhcPs+ -> Maybe GhcTag mkLHsTypeTag decLoc (L _ hsType) = (\a -> fixLoc decLoc $ mkGhcTag a (GtkTypeClassInstance hsType) True)- <$> hsTypeTagName hsType-+ <$> hsTypeTagName hsType hsTypeTagName :: HsType GhcPs -> Maybe (LocatedN 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-+ 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 } =+ mkDataFamInstDeclTag decLoc DataFamInstDecl {dfid_eqn} = case dfid_eqn of- FamEqn { feqn_tycon, feqn_rhs } ->+ 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+ 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 } =+ mkTyFamInstDeclTag decLoc decl@TyFamInstDecl {tfid_eqn} = case tfid_eqn of -- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?- FamEqn { feqn_tycon } ->+ 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))+famResultKindSignature+ :: FamilyResultSig GhcPs+ -> Maybe (Either (HsKind GhcPs) (HsTyVarBndr () GhcPs))+famResultKindSignature (NoSig _) = Nothing+famResultKindSignature (KindSig _ ki) = Just (Left (unLoc ki))+famResultKindSignature (TyVarSig _ bndr) = Just (Right (unLoc bndr))
src/GhcTags/GhcCompat.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-missing-fields #-}+ module GhcTags.GhcCompat ( runGhc , parseModule+ , recFieldNames+ , pattern SpecSigE ) where import Data.IORef+import GHC qualified import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Config.Parser@@ -13,26 +16,12 @@ import GHC.Driver.Monad import GHC.Driver.Session import GHC.Hs+import GHC.Parser qualified as Parser import GHC.Parser.Lexer import GHC.Paths-import GHC.Platform-import GHC.Settings-import GHC.Settings.Config-import GHC.Settings.Utils-import GHC.SysTools.BaseDir+import GHC.SysTools import GHC.Types.SrcLoc-import GHC.Utils.Fingerprint-import GHC.Utils.TmpFs-import System.Directory-import System.FilePath-import qualified Data.Map.Strict as Map-import qualified GHC-import qualified GHC.Parser as Parser -#if __GLASGOW_HASKELL__ >= 914-import GHC.Unit.Types-#endif- parseModule :: FilePath -> DynFlags@@ -45,212 +34,21 @@ runGhc :: Ghc a -> IO a runGhc m = do- env <- liftIO $ do- mySettings <- compatInitSettings libdir- tmpdir <- liftIO getTemporaryDirectory- newHscEnv libdir $ (defaultDynFlags mySettings) { tmpDir = TempDir tmpdir }+ dflags <- initDynFlags . defaultDynFlags =<< initSysTools libdir+ env <- newHscEnv libdir dflags ref <- newIORef env unGhc (GHC.withCleanupSession m) (Session ref) -------------------------------------------- Internal---- | Stripped version of 'GHC.Settings.IO.initSettings' that ignores the--- @platformConstants@ file as it's irrelevant for parsing.-compatInitSettings :: FilePath -> IO Settings-compatInitSettings top_dir = do- let installed :: FilePath -> FilePath- installed file = top_dir </> file- libexec :: FilePath -> FilePath- libexec file = top_dir </> "bin" </> file- settingsFile = installed "settings"-- readFileSafe :: FilePath -> IO String- readFileSafe path = doesFileExist path >>= \case- True -> readFile path- False -> error $ "Missing file: " ++ path-- settingsStr <- readFileSafe settingsFile- settingsList <- case maybeReadFuzzy settingsStr of- Just s -> pure s- Nothing -> error $ "Can't parse " ++ show settingsFile- let mySettings = Map.fromList settingsList- -- See Note [Settings file] for a little more about this file. We're- -- just partially applying those functions and throwing 'Left's; they're- -- written in a very portable style to keep ghc-boot light.- let getBooleanSetting :: String -> IO Bool- getBooleanSetting key = either error pure $- getRawBooleanSetting settingsFile mySettings key-- -- On Windows, by mingw is often distributed with GHC,- -- so we look in TopDir/../mingw/bin,- -- as well as TopDir/../../mingw/bin for hadrian.- -- But we might be disabled, in which we we don't do that.- -- useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"- useInplaceMinGW <- pure True -- compatibility with GHC < 9.4- -- see Note [topdir: How GHC finds its files]- -- NB: top_dir is assumed to be in standard Unix- -- format, '/' separated- mtool_dir <- findToolDir useInplaceMinGW top_dir- -- see Note [tooldir: How GHC finds mingw on Windows]-- let getSetting key = either error pure $- getRawFilePathSetting top_dir settingsFile mySettings key- getToolSetting :: String -> IO String- getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key-- -- On Windows, mingw is distributed with GHC,- -- so we look in TopDir/../mingw/bin,- -- as well as TopDir/../../mingw/bin for hadrian.- -- It would perhaps be nice to be able to override this- -- with the settings file, but it would be a little fiddly- -- to make that possible, so for now you can't.- cc_prog <- getToolSetting "C compiler command"- cc_args_str <- getSetting "C compiler flags"- cxx_args_str <- getSetting "C++ compiler flags"- gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"- cpp_prog <- getToolSetting "Haskell CPP command"- cpp_args_str <- getSetting "Haskell CPP flags"-- platform <- either error pure $ compatGetTargetPlatform settingsFile mySettings-- let unreg_cc_args = if platformUnregisterised platform- then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]- else []- cpp_args = map Option (words cpp_args_str)- cc_args = words cc_args_str ++ unreg_cc_args- cxx_args = words cxx_args_str- ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"- ldSupportsFilelist <- getBooleanSetting "ld supports filelist"- ldIsGnuLd <- getBooleanSetting "ld is GNU ld"-- let globalpkgdb_path = installed "package.conf.d"- ghc_usage_msg_path = installed "ghc-usage.txt"- ghci_usage_msg_path = installed "ghci-usage.txt"-- -- For all systems, unlit, split, mangle are GHC utilities- -- architecture-specific stuff is done when building Config.hs- unlit_path <- getToolSetting "unlit command"-- windres_path <- getToolSetting "windres command"- ar_path <- getToolSetting "ar command"- otool_path <- getToolSetting "otool command"- install_name_tool_path <- getToolSetting "install_name_tool command"- ranlib_path <- getToolSetting "ranlib command"-- -- cpp is derived from gcc on all platforms- -- HACK, see setPgmP below. We keep 'words' here to remember to fix- -- Config.hs one day.-- -- Other things being equal, as and ld are simply gcc- cc_link_args_str <- getSetting "C compiler link flags"- let as_prog = cc_prog- as_args = map Option cc_args- ld_prog = cc_prog- ld_args = map Option (cc_args ++ words cc_link_args_str)- ld_r_prog <- getToolSetting "Merge objects command"- ld_r_args <- getSetting "Merge objects flags"- let ld_r- | null ld_r_prog = Nothing- | otherwise = Just (ld_r_prog, map Option $ words ld_r_args)-- -- We just assume on command line- lc_prog <- getSetting "LLVM llc command"- lo_prog <- getSetting "LLVM opt command"-- let iserv_prog = libexec "ghc-iserv"-- return $ Settings- { sGhcNameVersion = GhcNameVersion- { ghcNameVersion_programName = "ghc"- , ghcNameVersion_projectVersion = cProjectVersion- }-- , sFileSettings = FileSettings- { fileSettings_ghcUsagePath = ghc_usage_msg_path- , fileSettings_ghciUsagePath = ghci_usage_msg_path- , fileSettings_toolDir = mtool_dir- , fileSettings_topDir = top_dir- , fileSettings_globalPackageDatabase = globalpkgdb_path- }- #if __GLASGOW_HASKELL__ >= 914- , sUnitSettings = UnitSettings- {- unitSettings_baseUnitId = stringToUnitId ""- }+recFieldNames :: LHsConDeclRecField GhcPs -> [LFieldOcc GhcPs]+recFieldNames (L _ HsConDeclRecField { cdrf_names }) = cdrf_names+#else+recFieldNames :: LConDeclField GhcPs -> [LFieldOcc GhcPs]+recFieldNames (L _ ConDeclField { cd_fld_names }) = cd_fld_names #endif - , sToolSettings = ToolSettings- { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind- , toolSettings_ldSupportsFilelist = ldSupportsFilelist- , toolSettings_ldIsGnuLd = ldIsGnuLd- , toolSettings_ccSupportsNoPie = gccSupportsNoPie-- , toolSettings_pgm_L = unlit_path- , toolSettings_pgm_P = (cpp_prog, cpp_args)- , toolSettings_pgm_F = ""- , toolSettings_pgm_c = cc_prog- , toolSettings_pgm_a = (as_prog, as_args)- , toolSettings_pgm_l = (ld_prog, ld_args)- , toolSettings_pgm_lm = ld_r- , toolSettings_pgm_windres = windres_path- , toolSettings_pgm_ar = ar_path- , toolSettings_pgm_otool = otool_path- , toolSettings_pgm_install_name_tool = install_name_tool_path- , toolSettings_pgm_ranlib = ranlib_path- , toolSettings_pgm_lo = (lo_prog,[])- , toolSettings_pgm_lc = (lc_prog,[])- , toolSettings_pgm_i = iserv_prog- , toolSettings_opt_L = []- , toolSettings_opt_P = []- , toolSettings_opt_P_fingerprint = fingerprint0- , toolSettings_opt_F = []- , toolSettings_opt_c = cc_args- , toolSettings_opt_cxx = cxx_args- , toolSettings_opt_a = []- , toolSettings_opt_l = []- , toolSettings_opt_lm = []- , toolSettings_opt_windres = []- , toolSettings_opt_lo = []- , toolSettings_opt_lc = []- , toolSettings_opt_i = []-- , toolSettings_extraGccViaCFlags = []- }-- , sTargetPlatform = platform-- -- Lots of uninitialized fields here.- , sPlatformMisc = PlatformMisc {}-- , sRawSettings = settingsList- }---- Stripped version of 'GHC.Settings.Platform.getTargetPlatform'. Arch info is--- needed for CPP defines, the rest is irrelevant.-compatGetTargetPlatform- :: FilePath -> RawSettings -> Either String Platform-compatGetTargetPlatform settingsFile mySettings = do- let- readSetting :: (Show a, Read a) => String -> Either String a- readSetting = readRawSetting settingsFile mySettings-- targetArchOS <- getTargetArchOS settingsFile mySettings- targetWordSize <- readSetting "target word size"-- pure $ Platform- { platformArchOS = targetArchOS- , platformWordSize = targetWordSize- , platform_constants = Nothing- -- below is irrelevant- , platformByteOrder = LittleEndian- , platformUnregisterised = True- , platformHasGnuNonexecStack = False- , platformHasIdentDirective = False- , platformHasSubsectionsViaSymbols = False- , platformIsCrossCompiling = False- , platformLeadingUnderscore = False- , platformTablesNextToCode = False- , platformHasLibm = False- }+#if __GLASGOW_HASKELL__ < 914+-- | A stand-in for the constructor that GHC 9.14 added. It never matches.+pattern SpecSigE :: () -> Sig GhcPs+pattern SpecSigE x <- (const Nothing -> Just x)+#endif
src/GhcTags/Tag.hs view
@@ -7,6 +7,7 @@ , CTag , ETagMap , CTagMap+ -- ** Tag fields , TagName (..) , TagFileName (..)@@ -22,64 +23,60 @@ , CTagFields , ETagFields , TagField (..)+ -- ** Ordering and combining tags , compareTags - -- * Create 'Tag' from a 'GhcTag'+ -- * 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-+import Control.DeepSeq+import Data.Function (on)+import Data.Map.Strict (Map)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import GHC.Data.FastString (bytesFS) -- GHC imports-import GHC.Driver.Session (DynFlags, initSDocContext)-import GHC.Data.FastString (bytesFS)--import GHC.Types.SrcLoc- ( SrcSpan (..)- , srcSpanFile- , srcSpanStartLine- )+import GHC.Driver.Session (DynFlags, initSDocContext)+import GHC.Types.SrcLoc+ ( SrcSpan (..)+ , srcSpanFile+ , srcSpanStartLine+ )+import GHC.Utils.Outputable qualified as Out+import Yamlet qualified as Y -import GhcTags.Ghc ( GhcTag (..)- , GhcTagKind (..)- )-import qualified GHC.Utils.Outputable as Out+import GhcTags.Ghc+ ( GhcTag (..)+ , GhcTagKind (..)+ ) -- -- Tag -- -- | Promoted data type used to disntinguish 'CTag's from 'ETag's.--- data TagType = CTag | ETag- deriving Show-+ deriving stock (Show) -- | Singletons for promoted types.--- data SingTagType (tt :: TagType) where- SingCTag :: SingTagType 'CTag- SingETag :: SingTagType 'ETag-+ SingCTag :: SingTagType 'CTag+ SingETag :: SingTagType 'ETag -- | 'ByteString' which encodes a tag name.----newtype TagName = TagName { getTagName :: Text }- deriving (Eq, Ord, Show)+newtype TagName = TagName {getTagName :: Text}+ deriving stock (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)+newtype TagFileName = TagFileName {getTagFileName :: Text}+ deriving stock (Eq, Ord, Show)+ deriving newtype (Y.FromYaml, Y.ToYaml) instance NFData TagFileName where rnf = rnf . getTagFileName@@ -91,29 +88,28 @@ -- -- 'GhcTags.CTag.Utils.tagKindToChar' and 'GhcTags.CTag.Utils.charToTagKind' -- define the character of each kind.--- data TagKind (tt :: TagType) where- TkModule :: TagKind tt- TkTerm :: TagKind tt- TkFunction :: TagKind tt- TkTypeConstructor :: TagKind tt- TkDataConstructor :: TagKind tt- TkGADTConstructor :: TagKind tt- TkRecordField :: TagKind tt- TkTypeSynonym :: TagKind tt- TkTypeSignature :: TagKind tt- TkPatternSynonym :: TagKind tt- TkTypeClass :: TagKind tt- TkTypeClassMember :: TagKind tt- TkTypeClassInstance :: TagKind tt- TkTypeFamily :: TagKind tt- TkTypeFamilyInstance :: TagKind tt- TkDataTypeFamily :: TagKind tt- TkDataTypeFamilyInstance :: TagKind tt- TkForeignImport :: TagKind tt- TkForeignExport :: TagKind tt- CharKind :: Char -> TagKind tt- NoKind :: TagKind tt+ TkModule :: TagKind tt+ TkTerm :: TagKind tt+ TkFunction :: TagKind tt+ TkTypeConstructor :: TagKind tt+ TkDataConstructor :: TagKind tt+ TkGADTConstructor :: TagKind tt+ TkRecordField :: TagKind tt+ TkTypeSynonym :: TagKind tt+ TkTypeSignature :: TagKind tt+ TkPatternSynonym :: TagKind tt+ TkTypeClass :: TagKind tt+ TkTypeClassMember :: TagKind tt+ TkTypeClassInstance :: TagKind tt+ TkTypeFamily :: TagKind tt+ TkTypeFamilyInstance :: TagKind tt+ TkDataTypeFamily :: TagKind tt+ TkDataTypeFamilyInstance :: TagKind tt+ TkForeignImport :: TagKind tt+ TkForeignExport :: TagKind tt+ CharKind :: Char -> TagKind tt+ NoKind :: TagKind tt instance NFData (TagKind tt) where rnf x = x `seq` ()@@ -121,133 +117,115 @@ type CTagKind = TagKind 'CTag type ETagKind = TagKind 'ETag -deriving instance Eq (TagKind tt)-deriving instance Ord (TagKind tt)-deriving instance Show (TagKind tt)---newtype ExCommand = ExCommand { getExCommand :: Text }- deriving (Eq, Ord, Show)+deriving stock instance Eq (TagKind tt)+deriving stock instance Ord (TagKind tt)+deriving stock instance Show (TagKind tt) +newtype ExCommand = ExCommand {getExCommand :: Text}+ deriving stock (Eq, Ord, Show) -- | Tag address, either from a parsed file or from Haskell's AST>--- data TagAddress (tt :: TagType) where- -- | Address of an etag is a line number and byte offset from the begining- -- of the file.- --- TagLineOff :: Int -> Int -> TagAddress 'ETag-- -- | 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+ -- | Address of an etag is a line number and byte offset from the begining+ -- of the file.+ TagLineOff :: Int -> Int -> TagAddress 'ETag+ -- | 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 tt) where rnf x = x `seq` () -- | 'CTag' addresses.--- type CTagAddress = TagAddress 'CTag -- | 'ETag' addresses.--- type ETagAddress = TagAddress 'ETag --deriving instance Eq (TagAddress tt)-deriving instance Ord (TagAddress tt)-deriving instance Show (TagAddress tt)-+deriving stock instance Eq (TagAddress tt)+deriving stock instance Ord (TagAddress tt)+deriving stock instance Show (TagAddress tt) -- | Emacs tags specific field.--- data TagDefinition (tt :: TagType) where- TagDefinition :: Text -> TagDefinition 'ETag- NoTagDefinition :: TagDefinition tt+ TagDefinition :: Text -> TagDefinition 'ETag+ NoTagDefinition :: TagDefinition tt instance NFData (TagDefinition tt) where rnf x = x `seq` () -deriving instance Show (TagDefinition tt)-deriving instance Eq (TagDefinition tt)-deriving instance Ord (TagDefinition tt)+deriving stock instance Show (TagDefinition tt)+deriving stock instance Eq (TagDefinition tt)+deriving stock instance Ord (TagDefinition tt) -- | 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)+data TagField = TagField+ { fieldName :: Text+ , fieldValue :: Text+ }+ deriving stock (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 = "" }-+fileField = TagField {fieldName = "file", fieldValue = ""} -- | Ctags specific list of 'TagField's.--- data TagFields (tt :: TagType) where- NoTagFields :: TagFields 'ETag-- TagFields :: [TagField]- -> TagFields 'CTag+ NoTagFields :: TagFields 'ETag+ TagFields+ :: [TagField]+ -> TagFields 'CTag instance NFData (TagFields tt) where- rnf NoTagFields = ()+ rnf NoTagFields = () rnf (TagFields fs) = rnf fs -deriving instance Show (TagFields tt)-deriving instance Eq (TagFields tt)-deriving instance Ord (TagFields tt)+deriving stock instance Show (TagFields tt)+deriving stock instance Eq (TagFields tt)+deriving stock instance Ord (TagFields tt) instance Semigroup (TagFields tt) where- NoTagFields <> NoTagFields = NoTagFields- (TagFields a) <> (TagFields b) = TagFields (a ++ b)+ NoTagFields <> NoTagFields = NoTagFields+ (TagFields a) <> (TagFields b) = TagFields (a ++ b) instance Monoid (TagFields 'CTag) where- mempty = TagFields mempty+ mempty = TagFields mempty instance Monoid (TagFields 'ETag) where- mempty = NoTagFields+ 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 (tt :: TagType) = Tag- { tagName :: TagName- -- ^ name of the tag- , tagKind :: TagKind tt- -- ^ ctags specifc field, which classifies tags- , tagAddr :: TagAddress tt- -- ^ address in source file+ { tagName :: TagName+ -- ^ name of the tag+ , tagKind :: TagKind tt+ -- ^ ctags specifc field, which classifies tags+ , tagAddr :: TagAddress tt+ -- ^ address in source file , tagDefinition :: TagDefinition tt- -- ^ etags specific field; only tags read from emacs tags file contain this- -- field.- , tagFields :: TagFields tt- -- ^ ctags specific field+ -- ^ etags specific field; only tags read from emacs tags file contain this+ -- field.+ , tagFields :: TagFields tt+ -- ^ ctags specific field }- deriving (Show, Eq, Ord)+ deriving stock (Show, Eq, Ord) instance NFData (Tag tt) where- rnf Tag{..} = rnf tagName- `seq` rnf tagKind- `seq` rnf tagAddr- `seq` rnf tagDefinition- `seq` rnf tagFields+ rnf Tag {..} =+ rnf tagName+ `seq` rnf tagKind+ `seq` rnf tagAddr+ `seq` rnf tagDefinition+ `seq` rnf tagFields type CTag = Tag 'CTag type ETag = Tag 'ETag@@ -269,60 +247,56 @@ -- * anti-symmetry -- * reflexivity -- * transitivity--- * partial consistency with 'Eq' instance: +-- * partial consistency with 'Eq' instance: -- -- prop> a == b => compareTags a b == EQ--- compareTags :: forall (tt :: TagType). Ord (TagAddress tt) => Tag tt -> Tag tt -> 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 tt -> Maybe (TagKind tt)- 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+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 tt -> Maybe (TagKind tt)+ 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 :: SingTagType tt -> DynFlags -> GhcTag -> Maybe (TagFileName, Tag tt)-ghcTagToTag sing dynFlags GhcTag { gtSrcSpan, gtTag, gtKind, gtIsExported, gtFFI } =- case gtSrcSpan of- UnhelpfulSpan {} -> Nothing- RealSrcSpan realSrcSpan _ ->- Just . (fileName realSrcSpan, ) $ Tag- { tagName = TagName tagName -- , tagAddr = case sing of- SingETag -> TagLineOff (srcSpanStartLine realSrcSpan) 0- SingCTag -> TagLine (srcSpanStartLine realSrcSpan)-- , tagKind = fromGhcTagKind gtKind-+ghcTagToTag sing dynFlags GhcTag {gtSrcSpan, gtTag, gtKind, gtIsExported, gtFFI} =+ case gtSrcSpan of+ UnhelpfulSpan {} -> Nothing+ RealSrcSpan realSrcSpan _ ->+ Just . (fileName realSrcSpan,) $+ Tag+ { tagName = TagName tagName+ , tagAddr = case sing of+ SingETag -> TagLineOff (srcSpanStartLine realSrcSpan) 0+ SingCTag -> TagLine (srcSpanStartLine realSrcSpan)+ , tagKind = fromGhcTagKind gtKind , tagDefinition = NoTagDefinition-- , tagFields = ( staticField- <> ffiField- <> kindField- ) sing+ , tagFields =+ ( staticField+ <> ffiField+ <> kindField+ )+ sing }- where -- A file name is not necessarily valid UTF-8, so a strict decoder would -- throw and take the whole run down.@@ -332,26 +306,26 @@ fromGhcTagKind :: GhcTagKind -> TagKind tt 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+ 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+ GtkForeignImport -> TkForeignImport+ GtkForeignExport -> TkForeignExport -- static field (wheather term is exported or not) staticField :: SingTagType tt -> TagFields tt@@ -370,10 +344,9 @@ SingCTag -> TagFields $ case gtFFI of- Nothing -> mempty+ Nothing -> mempty Just ffi -> [TagField "ffi" $ Text.decodeUtf8Lenient ffi] - -- 'TagFields' from 'GhcTagKind' kindField :: SingTagType tt -> TagFields tt kindField = \case@@ -382,36 +355,27 @@ 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- }]--+ [ TagField+ { fieldName = termFieldName+ , fieldValue = render decl+ }+ ] GtkGADTConstructor hsType -> mkField typeFieldName hsType- _ -> mempty - kindFieldName, typeFieldName, termFieldName :: Text kindFieldName = "Kind" -- "kind" is reserverd typeFieldName = "type"@@ -420,23 +384,26 @@ -- -- fields --- + mkField :: Out.Outputable p => Text -> p -> TagFields 'CTag- mkField fieldName p =+ 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.renderWithContext- (initSDocContext- dynFlags- (Out.setStyleColoured False- $ Out.mkErrStyle Out.neverQualify))+ Text.intercalate " " -- remove all line breaks, tabs and multiple spaces+ . Text.words+ . Text.pack+ $ Out.renderWithContext+ ( initSDocContext+ dynFlags+ ( Out.setStyleColoured False $+ Out.mkErrStyle Out.neverQualify+ )+ ) (Out.ppr hsType)
src/GhcTags/Utils.hs view
@@ -7,15 +7,14 @@ ) where import Control.Monad-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text as T+import Data.Attoparsec.Text qualified as AT+import Data.Text qualified as T -- | Platform dependend eol: -- -- * windows "CRNL" -- * maxos "CR" -- * linux (unit) "NL"--- endOfLine :: String #if defined(mingw32_HOST_OS) endOfLine = "\r\n"@@ -25,14 +24,12 @@ endOfLine = "\n" #endif - notNewLine :: Char -> Bool notNewLine = \x -> x /= '\n' && x /= '\r' -- | Fail unless all the input is consumed. A tags file that is only partly -- readable is rejected as a whole, because otherwise every tag after the first -- bad line is lost without a word.--- endOfInput :: AT.Parser () endOfInput = do rest <- AT.takeText
src/Main.hs view
@@ -7,28 +7,37 @@ import Control.Exception import Control.Monad import Data.Bifunctor+import Data.ByteString.Builder qualified as BS+import Data.ByteString.Char8 qualified as BS import Data.Char+import Data.Foldable qualified as F import Data.Function+import Data.Functor+import Data.IORef import Data.List+import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe)+import Data.Primitive.Array+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Data.Time-import Data.Time.Format.ISO8601 import GHC (GhcException, setSessionDynFlags) import GHC.Conc (getNumProcessors) import GHC.Data.Bag import GHC.Data.StringBuffer+import GHC.Driver.Config.Diagnostic import GHC.Driver.Env.Types+import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Monad import GHC.Driver.Pipeline-import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Hs import GHC.Parser.Errors.Types import GHC.Parser.Lexer import GHC.Types.Error import GHC.Types.SrcLoc-import GHC.Utils.Error import System.Directory import System.Environment import System.Exit@@ -37,23 +46,15 @@ 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 Yamlet qualified as Y import GhcTags+import GhcTags.CTag qualified as CTag+import GhcTags.CTag.Header import GhcTags.Config.Args import GhcTags.Config.Project-import GhcTags.CTag.Header+import GhcTags.ETag qualified as ETag import GhcTags.GhcCompat-import qualified GhcTags.CTag as CTag-import qualified GhcTags.ETag as ETag ---------------------------------------- @@ -62,15 +63,18 @@ data HsFileType = HsFile | HsBootFile | LHsFile | AlexFile | HscFile data WorkerData = WorkerData- { wdTags :: MVar DirtyTags- , wdTimes :: MVar DirtyModTimes- , wdQueue :: TBQueue (Maybe (FilePath, HsFileType, UTCTime))+ { wdTags :: MVar DirtyTags+ , wdTimes :: MVar DirtyModTimes+ , wdQueue :: TBQueue (Maybe (FilePath, HsFileType, UTCTime))+ , wdOutputLock :: MVar ()+ , wdFailed :: IORef Bool } generateTagsForProject :: Int -> WorkerData -> ProjectConfig -> IO ()-generateTagsForProject threads wd pc = runConcurrently . F.fold- $ Concurrently (processFiles (pcSourcePaths pc) >> terminateWorkers)- : replicate threads (Concurrently worker)+generateTagsForProject threads wd pc =+ runConcurrently . F.fold $+ Concurrently (processFiles (pcSourcePaths pc) >> terminateWorkers)+ : replicate threads (Concurrently worker) where -- Both sides of the exclusion test go through the same normalisation, so -- that "./dist", "dist/" and "dist" mean the same directory.@@ -102,67 +106,91 @@ -- support the case of parsing the same file multiple times -- with different CPP options. Just (Updated updated oldTime) -> updated || oldTime < time- Nothing -> True+ 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)- ]+ haskellExts =+ [ (".hs", HsFile)+ , (".hs-boot", HsBootFile)+ , (".lhs", LHsFile)+ , (".x", AlexFile)+ , (".hsc", HscFile)+ ] terminateWorkers :: IO () terminateWorkers = atomically $ do replicateM_ threads $ writeTBQueue (wdQueue wd) Nothing - showIOError m = m `catch` \(e::IOError) -> do- putStrLn $ "Error: " ++ show e+ showIOError m =+ m `catch` \(e :: IOError) -> do+ putError $ "Error: " ++ show e + -- Several threads report at once, and stderr is unbuffered, so without+ -- the lock their messages mix character by character.+ putMessage :: String -> IO ()+ putMessage msg = withMVar (wdOutputLock wd) $ \() -> hPutStrLn stderr msg++ putError :: String -> IO ()+ putError msg = markFailed >> putMessage msg++ markFailed :: IO ()+ markFailed = atomicWriteIORef (wdFailed wd) True+ -- Extract tags from a given file and update the TagMap. worker :: IO () worker = runGhc $ do void $ setSessionDynFlags . adjustDynFlags pc =<< getSessionDynFlags+ -- GHC prints the errors of the C preprocessor itself.+ pushLogHookM $ \logAction flags msgClass srcSpan msg ->+ withMVar (wdOutputLock wd) $ \() -> logAction flags msgClass srcSpan msg env <- getSession- liftIO . fix $ \loop -> atomically (readTBQueue $ wdQueue wd) >>= \case- Nothing -> pure ()- Just (file, hsType, mtime) -> do- showIOError $ processFile env file hsType mtime- loop+ liftIO . fix $ \loop ->+ atomically (readTBQueue $ wdQueue wd) >>= \case+ Nothing -> pure ()+ Just (file, hsType, mtime) -> do+ showIOError $ 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 $ preprocessFile hsFile >>= \case- Left errs -> report (hsc_dflags env) (getMessages 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) = getPsMessages pstate- report flags (getMessages wrns)- report flags (getMessages errs)- POk pstate hsModule -> do- let (wrns, errs) = getPsMessages pstate- report flags (getMessages wrns)- report flags (getMessages errs)- when (isEmptyBag $ getMessages 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+ handle showErr $+ preprocessFile hsFile >>= \case+ Left errs -> do+ report (hsc_dflags env) errs+ markFailed+ 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) = getPsMessages pstate+ report flags wrns+ report flags errs+ markFailed+ POk pstate hsModule -> do+ let (wrns, errs) = getPsMessages pstate+ report flags wrns+ report flags errs+ if isEmptyBag $ getMessages errs+ then 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+ else markFailed where showErr :: GHC.GhcException -> IO ()- showErr = putStrLn . show+ showErr = putError . show - report :: Diagnostic e => DynFlags -> Bag (MsgEnvelope e) -> IO ()- report flags msgs =- sequence_ [ putStrLn $ showSDoc flags msg- | msg <- pprMsgEnvelopeBagWithLocDefault msgs- ]+ report :: forall e. Diagnostic e => DynFlags -> Messages e -> IO ()+ report flags =+ printMessages+ (hsc_logger env)+ (defaultDiagnosticOpts @e)+ (initDiagOpts flags) -- GHC rejects a file when an OPTIONS_GHC pragma contains a flag -- that the linked ghc library doesn't know, e.g. when the source@@ -171,18 +199,19 @@ preprocessFile :: FilePath -> IO (Either DriverMessages (DynFlags, FilePath))- preprocessFile file = preprocess env file Nothing Nothing >>= \case- Left errs- | flagSpans@(_ : _) <- unknownFlagSpans errs -> do- content <- T.decodeUtf8Lenient <$> BS.readFile file- let buffer = stringToStringBuffer . T.unpack $ blankSpans flagSpans content- preprocess env file (Just buffer) Nothing- result -> pure result+ preprocessFile file =+ preprocess env file Nothing Nothing >>= \case+ Left errs+ | flagSpans@(_ : _) <- unknownFlagSpans errs -> do+ content <- T.decodeUtf8Lenient <$> BS.readFile file+ let buffer = stringToStringBuffer . T.unpack $ blankSpans flagSpans content+ preprocess env file (Just buffer) Nothing+ result -> pure result unknownFlagSpans :: DriverMessages -> [RealSrcSpan] unknownFlagSpans errs = flip mapMaybe (bagToList $ getMessages errs) $ \msg -> case (errMsgDiagnostic msg, errMsgSpan msg) of- (DriverPsHeaderMessage (PsHeaderMessage PsErrUnknownOptionsPragma{}), RealSrcSpan s _)+ (DriverPsHeaderMessage (PsHeaderMessage PsErrUnknownOptionsPragma {}), RealSrcSpan s _) | srcSpanStartLine s == srcSpanEndLine s -> Just s _ -> Nothing @@ -209,22 +238,33 @@ 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+ 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) ""+ (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+ ExitSuccess -> k tmpFile+ ExitFailure code ->+ putError . intercalate "\n" $+ [ "Preprocessing "+ ++ file+ ++ " with "+ ++ prog+ ++ " failed with exit code "+ ++ show code+ ]+ ++ ["* STDOUT: " ++ out | not (null out)]+ ++ ["* STDERR: " ++ err | not (null err)] main :: IO () main = do@@ -236,10 +276,11 @@ args <- parseArgs defaultThreads =<< getArgs pcs <- case aSourcePaths args of- SourceArgs paths -> pure [defaultProjectConfig { pcSourcePaths = paths }]- ConfigFile configFile -> getProjectConfigs configFile >>= \case- Just pcs -> pure pcs- Nothing -> exitFailure+ SourceArgs paths -> pure [defaultProjectConfig {pcSourcePaths = paths}]+ ConfigFile configFile ->+ getProjectConfigs configFile >>= \case+ Just pcs -> pure pcs+ Nothing -> exitFailure when (not $ null pcs) $ do wd <- initWorkerData args (aThreads args)@@ -250,46 +291,41 @@ cleanTagMap <- withMVar (wdTags wd) (cleanupTags args) writeTags (aTagFile args) cleanTagMap- withMVar (wdTimes wd) $ writeTimes (timesFile args) <=< cleanupTimes cleanTagMap+ withMVar (wdTimes wd) $ Y.encodeFile (timesFile args) <=< cleanupTimes cleanTagMap++ failed <- readIORef (wdFailed wd)+ when failed exitFailure where timesFile args = aTagFile args <.> "mtime" initWorkerData :: Args -> Int -> IO WorkerData initWorkerData args threads = do- tags@DirtyTags{dtTags} <- case aTagType args of+ tags@DirtyTags {dtTags} <- case aTagType args of ETag -> readTags SingETag (aTagFile args) CTag -> readTags SingCTag (aTagFile args) -- If tags are empty there is no point looking at mtimes.- mtimes <- if Map.null dtTags- then pure Map.empty- else readTimes (timesFile args)- wdTags <- newMVar tags+ mtimes <-+ if Map.null dtTags+ then pure Map.empty+ else readTimes (timesFile args)+ wdTags <- newMVar tags wdTimes <- newMVar mtimes wdQueue <- newTBQueueIO (fromIntegral threads)- pure WorkerData{..}+ wdOutputLock <- newMVar ()+ wdFailed <- newIORef False+ pure WorkerData {..} ---------------------------------------- type DirtyModTimes = Map.Map TagFileName (Updated UTCTime)-type ModTimes = Map.Map TagFileName 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+readTimes timesFile =+ tryIOError (Y.decodeFile @ModTimes timesFile) <&> \case+ Right (Right times) -> Updated False <$> times+ _ -> Map.empty -- | Update an mtime of a source file with a new value. updateTimesWith :: TagFileName -> UTCTime -> DirtyModTimes -> DirtyModTimes@@ -297,144 +333,152 @@ -- | 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+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+ 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 tt. DirtyTags- { dtKind :: SingTagType tt+ { dtKind :: SingTagType tt , dtHeaders :: [CTag.Header]- , dtTags :: Map.Map TagFileName (Updated (Set.Set (Tag tt)))+ , dtTags :: Map.Map TagFileName (Updated (Set.Set (Tag tt))) } data Tags = forall tt. Tags- { tKind :: SingTagType tt+ { tKind :: SingTagType tt , tHeaders :: [CTag.Header]- , tTags :: Map.Map TagFileName [Tag tt]+ , tTags :: Map.Map TagFileName [Tag tt] } -- | Like 'try', but let asynchronous exceptions through. A tags file that -- cannot be read must not stop the run, whatever the reason is. trySync :: IO a -> IO (Either SomeException a)-trySync m = try m >>= \case- Right a -> pure $ Right a- Left err -> case fromException err of- Just (SomeAsyncException _) -> throwIO err- Nothing -> pure $ Left err+trySync m =+ try m >>= \case+ Right a -> pure $ Right a+ Left err -> case fromException err of+ Just (SomeAsyncException _) -> throwIO err+ Nothing -> pure $ Left err readTags :: forall tt. SingTagType tt -> FilePath -> IO DirtyTags-readTags tt tagsFile = doesFileExist tagsFile >>= \case- False -> pure newDirtyTags- True -> do- res <- trySync $ do- parsed <- parseTagsFile . T.decodeUtf8Lenient =<< BS.readFile tagsFile- -- Full evaluation decreases performance variation. It also keeps a- -- failure of the parser inside 'trySync'.- evaluate $ force parsed- case res of- Right (Right (headers, tags)) -> pure DirtyTags+readTags tt tagsFile =+ doesFileExist tagsFile >>= \case+ False -> pure newDirtyTags+ True -> do+ res <- trySync $ do+ parsed <- parseTagsFile . T.decodeUtf8Lenient =<< BS.readFile tagsFile+ -- Full evaluation decreases performance variation. It also keeps a+ -- failure of the parser inside 'trySync'.+ evaluate $ force parsed+ case res of+ Right (Right (headers, tags)) ->+ pure+ DirtyTags+ { dtKind = tt+ , dtHeaders = headers+ , dtTags = Map.map (Updated False . Set.fromList) tags+ }+ -- reading failed+ Left err -> do+ hPutStrLn stderr $ "Error while reading " ++ tagsFile ++ ": " ++ show err+ pure newDirtyTags+ -- parsing failed+ Right (Left err) -> do+ hPutStrLn stderr $ "Error while parsing " ++ tagsFile ++ ": " ++ show err+ pure newDirtyTags+ where+ newDirtyTags =+ DirtyTags { dtKind = tt- , dtHeaders = headers- , dtTags = Map.map (Updated False . Set.fromList) tags+ , dtHeaders = []+ , dtTags = Map.empty }- -- 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 = tt- , dtHeaders = []- , dtTags = Map.empty- } parseTagsFile :: T.Text -> IO (Either String ([CTag.Header], Map.Map TagFileName [Tag tt])) parseTagsFile = case tt of- SingETag -> fmap (fmap ([], )) . ETag.parseTagsFile- SingCTag -> CTag.parseTagsFile+ SingETag -> fmap (fmap ([],)) . ETag.parseTagsFile+ SingCTag -> CTag.parseTagsFile updateTagsWith :: DynFlags -> Located (HsModule GhcPs) -> DirtyTags -> DirtyTags-updateTagsWith dflags hsModule DirtyTags{..} =- DirtyTags { dtTags = Map.unionWith mergeTags fileTags dtTags- , ..- }+updateTagsWith dflags hsModule DirtyTags {..} =+ DirtyTags+ { dtTags = Map.unionWith mergeTags fileTags dtTags+ , ..+ } where mergeTags (Updated newUpdated newTags) (Updated oldUpdated oldTags) = -- If the file was already updated, we merge tags. This supports the case -- of parsing the same file multiple times with different CPP options. if oldUpdated- then Updated newUpdated $!! newTags `Set.union` oldTags- else Updated newUpdated $!! newTags+ then Updated newUpdated $!! newTags `Set.union` oldTags+ else Updated newUpdated $!! newTags fileTags =- let tags = Map.fromListWith Set.union- . map (second Set.singleton)- . mapMaybe (ghcTagToTag dtKind dflags)- $ getGhcTags hsModule+ let tags =+ Map.fromListWith Set.union+ . map (second Set.singleton)+ . mapMaybe (ghcTagToTag dtKind dflags)+ $ getGhcTags hsModule in Map.map (Updated True) tags cleanupTags :: Args -> DirtyTags -> IO Tags-cleanupTags args DirtyTags{..} = do+cleanupTags args 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 $ Set.toList tags- case dtKind of- SingCTag -> if aExModeSearch args- then addExCommands file cleanedTags- else pure $ Just cleanedTags- SingETag -> addFileOffsets file cleanedTags- | exists && not updated -> pure . Just $ Set.toList tags- | otherwise -> pure Nothing- newTags `deepseq` pure Tags { tKind = dtKind- , tHeaders = dtHeaders- , tTags = newTags- }+ if+ | exists && updated -> do+ let cleanedTags = ignoreSimilarClose . sortBy compareNAK $ Set.toList tags+ case dtKind of+ SingCTag ->+ if aExModeSearch args+ then addExCommands file cleanedTags+ else pure $ Just cleanedTags+ SingETag -> addFileOffsets file cleanedTags+ | exists && not updated -> pure . Just $ Set.toList 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+ 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)+ 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)+ x `betterThan` y =+ ( (tagKind x == TkFunction || tagKind x == TkPatternSynonym) && tagKind y == TkTypeSignature- )- || ( (tagKind x == TkDataConstructor || tagKind x == TkGADTConstructor)- && tagKind y == TkTypeConstructor- )+ )+ || ( (tagKind x == TkDataConstructor || tagKind x == TkGADTConstructor)+ && tagKind y == TkTypeConstructor+ ) ignoreSimilarClose tags = tags -- | Convert 'tagAddress' of CTags to an Ex mode search command as some editors@@ -444,25 +488,27 @@ let path = T.unpack $ getTagFileName file tryIOError (BS.readFile path) >>= \case Left err -> do- putStrLn $ "Unexpected error: " ++ show err+ hPutStrLn stderr $ "Unexpected error: " ++ show err pure Nothing Right content -> do- let fileLines = V.fromList $ BS.lines content+ let fileLines = arrayFromList $ BS.lines content pure . Just $ fillExCommands fileLines tags where- fillExCommands :: V.Vector BS.ByteString -> [CTag] -> [CTag]+ fillExCommands :: Array BS.ByteString -> [CTag] -> [CTag] fillExCommands fileLines = mapMaybe $ \tag -> case tagAddr tag of- TagCommand{} -> Just tag- TagLine lineNo -> do- line <- fileLines V.!? (lineNo - 1)+ TagCommand {} -> Just tag+ TagLine lineNo -> do+ line <- indexArrayMaybe fileLines (lineNo - 1) let TagFields fields = tagFields tag -- Ex mode forward search command. Slashes need to be escaped.- exCommand = T.concat- ["/^", T.replace "/" "\\/" $ T.decodeUtf8Lenient line, "$/"]- pure tag- { tagAddr = TagCommand $ ExCommand exCommand- , tagFields = TagFields $ TagField "line" (T.pack $ show lineNo) : fields- }+ exCommand =+ T.concat+ ["/^", T.replace "/" "\\/" $ T.decodeUtf8Lenient line, "$/"]+ pure+ tag+ { tagAddr = TagCommand $ ExCommand exCommand+ , tagFields = TagFields $ TagField "line" (T.pack $ show lineNo) : fields+ } -- | Add file offsets to etags from a specific file. addFileOffsets :: TagFileName -> [ETag] -> IO (Maybe [ETag])@@ -471,35 +517,43 @@ addOffset !off line = (off + BS.length line + 1, (off, line)) tryIOError (BS.readFile path) >>= \case Left err -> do- putStrLn $ "Unexpected error: " ++ show err+ hPutStrLn stderr $ "Unexpected error: " ++ show err pure Nothing Right content -> do- let linesWithOffsets = V.fromList- . snd- . mapAccumL addOffset 0- . BS.lines- $ content+ let linesWithOffsets =+ arrayFromList+ . snd+ . mapAccumL addOffset 0+ . BS.lines+ $ content pure . Just $ fillOffsets linesWithOffsets tags where- fillOffsets :: V.Vector (Int, BS.ByteString) -> [ETag] -> [ETag]+ fillOffsets :: Array (Int, BS.ByteString) -> [ETag] -> [ETag] fillOffsets linesWithOffsets = mapMaybe $ \tag -> do let TagLineOff lineNo _ = tagAddr tag- (offset, line) <- linesWithOffsets V.!? (lineNo - 1)- pure tag- { tagAddr = TagLineOff lineNo offset- , tagDefinition =- -- Prevent weird characters from ending up in the TAGS file.- TagDefinition . T.takeWhile isPrint $ T.decodeUtf8Lenient line- }+ (offset, line) <- indexArrayMaybe linesWithOffsets (lineNo - 1)+ pure+ tag+ { tagAddr = TagLineOff lineNo offset+ , tagDefinition =+ -- Prevent weird characters from ending up in the TAGS file.+ TagDefinition . T.takeWhile isPrint $ T.decodeUtf8Lenient line+ } +indexArrayMaybe :: Array a -> Int -> Maybe a+indexArrayMaybe arr i+ | i >= 0 && i < sizeofArray arr = Just $ indexArray arr i+ | otherwise = Nothing+ writeTags :: FilePath -> Tags -> IO ()-writeTags tagsFile Tags{..} = withFile tagsFile WriteMode $ \h ->+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 tTags where headers :: [Header]- headers = if null tHeaders- then defaultHeaders- else tHeaders+ headers =+ if null tHeaders+ then defaultHeaders+ else tHeaders