diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # ghc-tags -[![Build Status](https://github.com/arybczak/ghc-tags/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster) +[![Build Status](https://github.com/arybczak/ghc-tags/actions/workflows/haskell-gha.yaml/badge.svg?branch=master)](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster) [![Hackage](https://img.shields.io/hackage/v/ghc-tags.svg)](https://hackage.haskell.org/package/ghc-tags) A command line tool that generates etags diff --git a/ghc-tags.cabal b/ghc-tags.cabal --- a/ghc-tags.cabal +++ b/ghc-tags.cabal @@ -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 diff --git a/src/GhcTags.hs b/src/GhcTags.hs --- a/src/GhcTags.hs +++ b/src/GhcTags.hs @@ -3,6 +3,5 @@ , module GhcTags.Tag ) where - import GhcTags.Ghc import GhcTags.Tag diff --git a/src/GhcTags/CTag.hs b/src/GhcTags/CTag.hs --- a/src/GhcTags/CTag.hs +++ b/src/GhcTags/CTag.hs @@ -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 diff --git a/src/GhcTags/CTag/Formatter.hs b/src/GhcTags/CTag/Formatter.hs --- a/src/GhcTags/CTag/Formatter.hs +++ b/src/GhcTags/CTag/Formatter.hs @@ -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 diff --git a/src/GhcTags/CTag/Header.hs b/src/GhcTags/CTag/Header.hs --- a/src/GhcTags/CTag/Header.hs +++ b/src/GhcTags/CTag/Header.hs @@ -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" diff --git a/src/GhcTags/CTag/Parser.hs b/src/GhcTags/CTag/Parser.hs --- a/src/GhcTags/CTag/Parser.hs +++ b/src/GhcTags/CTag/Parser.hs @@ -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 diff --git a/src/GhcTags/CTag/Utils.hs b/src/GhcTags/CTag/Utils.hs --- a/src/GhcTags/CTag/Utils.hs +++ b/src/GhcTags/CTag/Utils.hs @@ -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 diff --git a/src/GhcTags/Config/Args.hs b/src/GhcTags/Config/Args.hs --- a/src/GhcTags/Config/Args.hs +++ b/src/GhcTags/Config/Args.hs @@ -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 "" 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" diff --git a/src/GhcTags/Config/Project.hs b/src/GhcTags/Config/Project.hs --- a/src/GhcTags/Config/Project.hs +++ b/src/GhcTags/Config/Project.hs @@ -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] diff --git a/src/GhcTags/ETag.hs b/src/GhcTags/ETag.hs --- a/src/GhcTags/ETag.hs +++ b/src/GhcTags/ETag.hs @@ -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 diff --git a/src/GhcTags/ETag/Formatter.hs b/src/GhcTags/ETag/Formatter.hs --- a/src/GhcTags/ETag/Formatter.hs +++ b/src/GhcTags/ETag/Formatter.hs @@ -1,5 +1,4 @@ -- | Simple etags formatter. See --- 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 diff --git a/src/GhcTags/ETag/Parser.hs b/src/GhcTags/ETag/Parser.hs --- a/src/GhcTags/ETag/Parser.hs +++ b/src/GhcTags/ETag/Parser.hs @@ -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' $> () diff --git a/src/GhcTags/Ghc.hs b/src/GhcTags/Ghc.hs --- a/src/GhcTags/Ghc.hs +++ b/src/GhcTags/Ghc.hs @@ -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)) diff --git a/src/GhcTags/GhcCompat.hs b/src/GhcTags/GhcCompat.hs --- a/src/GhcTags/GhcCompat.hs +++ b/src/GhcTags/GhcCompat.hs @@ -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 diff --git a/src/GhcTags/Tag.hs b/src/GhcTags/Tag.hs --- a/src/GhcTags/Tag.hs +++ b/src/GhcTags/Tag.hs @@ -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) diff --git a/src/GhcTags/Utils.hs b/src/GhcTags/Utils.hs --- a/src/GhcTags/Utils.hs +++ b/src/GhcTags/Utils.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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