diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,3 +20,11 @@ * Change order of tags: type classes, type families and data type families are sorted before their instances. If one is using multipe tags (the default), the order of them also matters (i.e. in the vim `tags` option). + +## 0.1.4.0 -- 2020-03.11 + +* Tags for default instances of associated (data) type familes. +* Added path argument, can be passed using `-fplugin-opt=Plugin.GhcTags:../tags`. +* Wrapped `IOExceptions`, so when it will happen it will be obvious that the + plugin failed not `ghc` +* Fixed the tag ordering function to be fullfil the transitivness property. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -2,27 +2,27 @@ # install, uninstall and friends ghc-tags-plugin in cabal store # -CABAL_STORE = ${HOME}/.cabal/store/ghc-$(shell ghc --numeric-version)/package.db +PACKAGE_DB = ${HOME}/.cabal/store/ghc-$(shell ghc --numeric-version)/package.db uninstall: ghc-pkg unregister \ - --package-db=${CABAL_STORE} \ + --package-db=${PACKAGE_DB} \ --force \ z-ghc-tags-plugin-z-ghc-tags-library \ ghc-tags-plugin install: - cabal install --package-db=${CABAL_STORE} --lib ghc-tags-plugin + cabal install --package-db=${PACKAGE_DB} --lib ghc-tags-plugin reinstall: uninstall install list: - ghc-pkg list --package-db=${CABAL_STORE} | grep ghc-tags + ghc-pkg list --package-db=${PACKAGE_DB} | grep ghc-tags latest: - ghc-pkg latest --package-db=${CABAL_STORE} ghc-tags-plugin + ghc-pkg latest --package-db=${PACKAGE_DB} ghc-tags-plugin recache: - ghc-pkg recache --package-db=${CABAL_STORE} + ghc-pkg recache --package-db=${PACKAGE_DB} .PHONY: install, uninstall, reinstall, show, latest diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,41 +5,58 @@ A [Ghc Compiler Plugin](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#compiler-plugins) which generates tags for each compiled module or component. -# Requirements +# ● Requirements + ``` ghc >= 8.6 ``` -# Vim configuration +# ● Vim configuration -Each generated tags file is put next to the corresponding `*.cabal` file. If -you just have a repo with a cabal file in the main directory `vim` default -`tags` setting will work, if you have some modules in subdirectories you will -need to set: +By default each generated tags file is put next to the corresponding `*.cabal` +package file. If you just have a repo with a cabal file in the main directory +`vim` default `tags` setting will work, if you have some modules in +subdirectories you will either need to set: ``` :set tags+=*/tags ``` +or pass an option to modify where tags are written, see below. -# Plugin configuration +# ● Plugin options + +The plugin accepts an only one option, which is a file path to the tags file. +It can be an absolute path or relative (to the `*.cabal` package file rather +than `cabal.project` file), for example: +``` +-fplugin-opt=Plugin.GhcTags:../tags +``` +This is useful if for *cabal packages* which are located in subdirectories. + + +# ● Configuration: Ghc / Cabal / Stack + Configuration of this plugin requires some familiarity with `ghc` packages. Check out [documentation](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/packages.html#packages) -how to use `-plugin-package` or `-plugin-package-id`. In the examples below we -us `-plugin-package=ghc-tags-plugin` but specifying version +to use `-plugin-package` or `-plugin-package-id`. In the examples below we +use `-plugin-package=ghc-tags-plugin` but specifying version `-package=ghc-tags-plugin-0.0.0.0` (where `0.0.0.0` is the version you -installed), might work better. You can use `ghc-pkg latest` (likely with -appropriate `--package-db` flag) to check which version is available. +installed), might work better. You can use `ghc-pkg latest ghc-tags-plugin` +(likely with appropriate `--package-db` flag) to check which version is +available. -## ghc +## ● Ghc ``` ghc -plugin-package=ghc-tags-plugin -fplugin=Plugin.GhcTags ``` -## cabal +You might also need to pass `-package-db` in which you installed the plugin. +## ● Cabal + Install the `ghc-tags-plugin` to cabal store with: ``` cabal install --lib ghc-tags-plugin @@ -63,33 +80,66 @@ "C:\\Users\\USER_NAME\\AppData\\Roaming\\cabal\\store\\ghc-8.6.5\\package.db ``` -## stack +Note that you can also configure in this way non-local projects. You will +likely want to pass `-fplugin-opt=Plugin.GhcTags=PATH` where `PATH` is *an +absolute* path to your `tags` file. -Install `ghc-tags-plugin` +## ● Stack + +This is alternative method, which also could be modified for `cabal` (but it is +not as nice as the previous method where you don't need to modify any files +checked in vcs). + +Add `ghc-tags-plugin` to `build-depends` in your `*.cabal` files. (You should +hide it behind a cabal flag). And add these lines to `stack.yaml` file: + ``` -stack install ghc-tags-plugin +extra-deps: + - git: https://github.com/coot/ghc-tags-plugin + commit: a841dae7fb9c335101f7fa4187d02687d306f972 + +test-project: -plugin-package=ghc-tags-plugin + -fplugin=Plugin.GhcTags ``` -In `stack.yaml` file add: +Check out an example +[here](https://github.com/coot/ghc-tags-plugin/tree/stack-setup/test-project). + + +## ● Ghcid + +If you follow the cabal configuration as above (using `stack` should work too) ``` -ghc-options: - some-project: -package-db=PACKAGE_DB - -plugin-package=ghc-tags-plugin - -fplugin=Plugin.GhcTags +ghcid --comaand "cabal repl project" ``` +will update `tags` file as you modify your project. -where `PACKAGE_DB` is the package db where `ghc-tags-plugin` was installed by -`stack`. -## modifying `cabal` files +## ● Makefile -You can always add `ghc-tags-plugin` as a build dependency in a cabal file (for -each component). You should hide it behind a flag and then use `cabal` or `stack` -to enable it (or `cabal.project.local` or `stack.yaml` files for that purpose). +The [Makefile](https://github.com/coot/ghc-tags-plugin/blob/master/Makefile) +contains some useful commands, e.g. `install`, `uninstall` or `reinstall` the +package in a `package.db` (by default into `cabal` store). This is mostly for +development, but it could be useful in other scenarios as well. -# Security implications of compiler plugins +# ● Exceptions +If a `GHC` plugin throws an exception, `GHC` stops. This plugin wraps +`IOException`s, to make it obvious that it filed rather than `GHC`. This +might mean you misconfigured the plugin (by passing wrong options). The +result might look like this: + +``` +ghc: panic! (the 'impossible' happened) + (GHC version 8.6.5 for x86_64-unknown-linux): + GhcTagsPluginIOException ../: openFile: inappropriate type (Is a directory) + +``` + + +# ● Security implications of compiler plugins + Such plugins can: * run arbitrary `IO`; @@ -98,5 +148,5 @@ This plugin only reads & writes to `tags` file (and updates a shared mutable state) as of `IO`, and does not -[modify/](https://github.com/coot/ghc-tags-plugin/blob/master/lib/Plugin/GhcTags.hs#L79) +[modify/](https://github.com/coot/ghc-tags-plugin/blob/master/src/Plugin/GhcTags.hs#L95) the syntax tree. diff --git a/ghc-tags-plugin.cabal b/ghc-tags-plugin.cabal --- a/ghc-tags-plugin.cabal +++ b/ghc-tags-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin -version: 0.1.3.0 +version: 0.1.4.0 synopsis: A compiler plugin which generates tags file from GHC syntax tree. description: A compiler source plugin which takes parsed Haskell syntax tree and saves @@ -26,9 +26,10 @@ hs-source-dirs: src exposed-modules: Plugin.GhcTags build-depends: base >=4.12.0.0 && <4.14, + bytestring ^>=0.10, containers ^>=0.6, directory ^>=1.3, - bytestring ^>=0.10, + filepath ^>=1.4, ghc >=8.4 && <8.9, text ^>=1.2, @@ -46,11 +47,11 @@ Plugin.GhcTags.Vim.Formatter Paths_ghc_tags_plugin autogen-modules: Paths_ghc_tags_plugin - build-depends: base >=4.12.0.0 && <4.14, - attoparsec ^>=0.13.0.0, + build-depends: attoparsec ^>=0.13.0.0, + base >=4.12.0.0 && <4.14, + bytestring ^>=0.10, containers ^>=0.6, directory ^>=1.3, - bytestring ^>=0.10, ghc >=8.4 && <8.9, text ^>=1.2 @@ -66,15 +67,16 @@ Test.Tag.Generators Test.Vim default-language: Haskell2010 - build-depends: base, - attoparsec, + build-depends: attoparsec, + base, bytestring, + lattices, + QuickCheck, + quickcheck-instances, tasty, tasty-golden, tasty-quickcheck, text, - QuickCheck, - quickcheck-instances, ghc-tags-library ghc-options: -Wall diff --git a/lib/Plugin/GhcTags/Generate.hs b/lib/Plugin/GhcTags/Generate.hs --- a/lib/Plugin/GhcTags/Generate.hs +++ b/lib/Plugin/GhcTags/Generate.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Interface for generatating tags for a parsed module. +-- | Interface for generating tags for a parsed module. -- module Plugin.GhcTags.Generate ( GhcTag (..) @@ -16,8 +16,7 @@ , getGhcTags ) where --- import Data.ByteString (ByteString) -import Data.List (find) + import Data.Maybe (mapMaybe, maybeToList) import Data.Foldable (foldl') import Data.Text (Text) @@ -77,19 +76,9 @@ import Name ( nameOccName , occNameFS ) -{- -import OccName ( NameSpace - , isDataConNameSpace - , isTcClsNameSpace - , isTvNameSpace - , isValNameSpace - , isVarNameSpace - , occNameSpace - , pprNameSpace - ) --} --- | `ctags` can generate tags kind, so do we. + +-- | `ctags` can generate tags kinds, so do we. -- data GhcKind = TkTerm | TkFunction @@ -158,17 +147,24 @@ +-- | Unit of data associated with a tag. Vim natively supports `file:` and +-- `kind:` tags but it can display any other tags too. +-- data TagField = TagField { fieldName :: Text, fieldValue :: Text } deriving (Eq, Ord, Show) + +-- | File field; tags which contain 'fileFields' are called static (aka static +-- in 'C'), such tags are only visible in the current file) +-- fileField :: TagField fileField = TagField { fieldName = "file", fieldValue = "" } --- | We can read names from using fields of type 'GHC.Hs.Extensions.IdP' (a tpye +-- | 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 { @@ -179,6 +175,7 @@ } deriving Show + appendField :: TagField -> GhcTag -> GhcTag appendField f gt = gt { gtFields = f : gtFields gt } @@ -186,10 +183,14 @@ type GhcTags = [GhcTag] +-- | Check if an identifier is exported, if it is not return 'fileField'. +-- getFileTagField :: Maybe [IE GhcPs] -> Located RdrName -> Maybe TagField getFileTagField Nothing _name = Nothing -getFileTagField (Just ies) name = - maybe (Just fileField) (const Nothing) $ find (\a -> ieName a == Just (unLoc name)) ies +getFileTagField (Just ies) (L _ name) = + if any (\ie -> ieName ie == Just name) ies + then Nothing + else Just fileField where -- TODO: the GHC's one is partial, and I got a panic error. ieName :: IE GhcPs -> Maybe RdrName @@ -199,6 +200,7 @@ ieName (IEThingAll _ (L _ n)) = Just $ ieWrappedName n ieName _ = Nothing + -- | Either class members or type constructors. -- getFileTagFieldForMember :: Maybe [IE GhcPs] @@ -207,7 +209,9 @@ -> Maybe TagField getFileTagFieldForMember Nothing _memberName _className = Nothing getFileTagFieldForMember (Just ies) memberName className = - maybe (Just fileField) (const Nothing) $ find go ies + if any go ies + then Nothing + else Just fileField where go :: IE GhcPs -> Bool @@ -232,6 +236,8 @@ go _ = False +-- | Create a 'GhcTag', effectively a smart constructor. +-- mkGhcTag :: Located RdrName -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier. -> GhcKind @@ -287,8 +293,8 @@ -- * data type families instances -- * data type family instances constructors -- -getGhcTags :: Located (HsModule GhcPs) - -> GhcTags +getGhcTags ::Located (HsModule GhcPs) + -> GhcTags getGhcTags (L _ HsModule { hsmodDecls, hsmodExports }) = reverse $ foldl' go [] hsmodDecls where @@ -308,21 +314,34 @@ -> GhcKind -> GhcTag mkGhcTagForMember memberName className kind = - mkGhcTag memberName kind (maybeToList $ getFileTagFieldForMember mies memberName className) + mkGhcTag memberName kind + (maybeToList $ getFileTagFieldForMember mies memberName className) + + -- Main routine which traverse all top level declarations. + -- go :: GhcTags -> LHsDecl GhcPs -> GhcTags go tags (L _ hsDecl) = case hsDecl of + -- type or class declaration TyClD _ tyClDecl -> case tyClDecl of + + -- type family declarations FamDecl { tcdFam } -> case mkFamilyDeclTags tcdFam Nothing of Just tag -> tag : tags Nothing -> tags + -- type synonyms SynDecl { tcdLName } -> mkGhcTag' tcdLName TkTypeSynonym : tags + -- data declaration: + -- type, + -- constructors, + -- record fields + -- DataDecl { tcdLName, tcdDataDefn } -> case tcdDataDefn of HsDataDefn { dd_cons } -> @@ -332,23 +351,47 @@ XHsDataDefn {} -> tags - -- TODO: add 'tcdATDefs' - ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs } -> + -- Type class declaration: + -- type class name, + -- type class members, + -- default methods, + -- default data type instance + -- + ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs, tcdATDefs } -> -- class name mkGhcTag' tcdLName TkTypeClass -- class methods : (mkClsMemberTags tcdLName . unLoc) `concatMap` tcdSigs -- default methods ++ foldl' (\tags' hsBind -> mkHsBindLRTags (unLoc hsBind) ++ tags') - tags + [] tcdMeths -- associated types ++ (flip mkFamilyDeclTags (Just tcdLName) . unLoc) `mapMaybe` tcdATs + -- associated type defaults (data type families, type families + -- (open or closed) + ++ foldl' + (\tags' (L _ tyFamDeflEqn) -> + case tyFamDeflEqn of + FamEqn { feqn_rhs } -> + case hsTypeTagName (unLoc feqn_rhs) of + -- TODO: add a `default` field + Just a -> mkGhcTag' a TkTypeFamilyInstance : tags' + Nothing -> tags' + XFamEqn {} -> tags') + [] tcdATDefs + ++ tags XTyClDecl {} -> tags + -- Instance declarations + -- class instances + -- type family instance + -- data type family instances + -- InstD _ instDecl -> case instDecl of + -- class instance declaration ClsInstD { cid_inst } -> case cid_inst of XClsInstDecl {} -> tags @@ -361,23 +404,26 @@ -- TODO: @hsbib_body :: LHsType GhcPs@ HsIB { hsib_body } -> case mkLHsTypeTag hsib_body of - Nothing -> tyFamTags ++ dataFamTags ++ tags + Nothing -> tyFamTags ++ dataFamTags ++ tags Just tag -> tag : tyFamTags ++ dataFamTags ++ tags where + -- associated type and data type family instances dataFamTags = (mkDataFamInstDeclTag . unLoc) `concatMap` cid_datafam_insts tyFamTags = (mkTyFamInstDeclTag . unLoc) `mapMaybe` cid_tyfam_insts + -- data family instance DataFamInstD { dfid_inst } -> mkDataFamInstDeclTag dfid_inst ++ tags + -- type family instance TyFamInstD { tfid_inst } -> case mkTyFamInstDeclTag tfid_inst of - Nothing -> tags + Nothing -> tags Just tag -> tag : tags XInstDecl {} -> tags - -- deriveving declaration + -- deriving declaration DerivD {} -> tags -- value declaration @@ -412,31 +458,34 @@ -- TODO: Rules are named it would be nice to get them too RuleD {} -> tags - - -- TODO: splices SpliceD {} -> tags - DocD {} -> tags RoleAnnotD {} -> tags XHsDecl {} -> tags - -- tags of all constructors of a type + + -- generate tags of all constructors of a type + -- mkConsTags :: Located RdrName -- name of the type -> ConDecl GhcPs - -- constrtructor declaration + -- constructor declaration -> GhcTags + mkConsTags tyName ConDeclGADT { con_names, con_args } = (\n -> mkGhcTagForMember n tyName TkGADTConstructor) `map` con_names - ++ mkHsConDeclDetails con_args + ++ mkHsConDeclDetails tyName con_args + mkConsTags tyName ConDeclH98 { con_name, con_args } = mkGhcTagForMember con_name tyName TkDataConstructor - : mkHsConDeclDetails con_args + : mkHsConDeclDetails tyName con_args + mkConsTags _ XConDecl {} = [] - mkHsConDeclDetails :: HsConDeclDetails GhcPs -> GhcTags - mkHsConDeclDetails (RecCon (L _ fields)) = foldl' f [] fields + mkHsConDeclDetails :: Located RdrName -> HsConDeclDetails GhcPs -> GhcTags + mkHsConDeclDetails tyName (RecCon (L _ fields)) = + foldl' f [] fields where f :: GhcTags -> LConDeclField GhcPs -> GhcTags f ts (L _ ConDeclField { cd_fld_names }) = foldl' g ts cd_fld_names @@ -444,12 +493,13 @@ g :: GhcTags -> LFieldOcc GhcPs -> GhcTags g ts (L _ FieldOcc { rdrNameFieldOcc }) = - mkGhcTag' rdrNameFieldOcc TkRecordField + mkGhcTagForMember rdrNameFieldOcc tyName TkRecordField : ts g ts _ = ts - mkHsConDeclDetails _ = [] + mkHsConDeclDetails _ _ = [] + mkHsBindLRTags :: HsBindLR GhcPs GhcPs -> GhcTags mkHsBindLRTags hsBind = case hsBind of @@ -464,7 +514,7 @@ VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag' (L srcSpan var_id) TkTerm] - -- abstraction binding are only used after translaction + -- abstraction binding is only used after translation AbsBinds {} -> [] PatSynBind _ PSB { psb_id } -> [mkGhcTag' psb_id TkPatternSynonym] @@ -472,6 +522,7 @@ XHsBindsLR {} -> [] + mkClsMemberTags :: Located RdrName -> Sig GhcPs -> GhcTags mkClsMemberTags clsName (TypeSig _ lhs _) = (\n -> mkGhcTagForMember n clsName TkTypeSignature) @@ -484,6 +535,7 @@ `map` lhs mkClsMemberTags _ _ = [] + mkSigTags :: Sig GhcPs -> GhcTags mkSigTags (TypeSig _ lhs _) = flip mkGhcTag' TkTypeSignature `map` lhs mkSigTags (PatSynSig _ lhs _) = flip mkGhcTag' TkPatternSynonym `map` lhs @@ -503,6 +555,7 @@ mkSigTags CompleteMatchSig {} = [] mkSigTags XSig {} = [] + mkFamilyDeclTags :: FamilyDecl GhcPs -> Maybe (Located RdrName) -- if this type family is associate, pass the name of the @@ -519,10 +572,12 @@ ClosedTypeFamily {} -> TkTypeFamily mkFamilyDeclTags XFamilyDecl {} _ = Nothing + -- used to generate tag of an instance declaration mkLHsTypeTag :: LHsType GhcPs -> Maybe GhcTag mkLHsTypeTag (L _ hsType) = (\a -> mkGhcTag a TkTypeClassInstance []) <$> hsTypeTagName hsType + hsTypeTagName :: HsType GhcPs -> Maybe (Located RdrName) hsTypeTagName hsType = case hsType of @@ -538,7 +593,9 @@ _ -> Nothing - -- todo: type constructors + + -- data family instance declaration + -- mkDataFamInstDeclTag :: DataFamInstDecl GhcPs -> GhcTags mkDataFamInstDeclTag DataFamInstDecl { dfid_eqn } = case dfid_eqn of @@ -554,6 +611,9 @@ HsIB { hsib_body = XFamEqn {} } -> [] + + -- type family instance declaration + -- mkTyFamInstDeclTag :: TyFamInstDecl GhcPs -> Maybe GhcTag mkTyFamInstDeclTag TyFamInstDecl { tfid_eqn } = case tfid_eqn of @@ -564,22 +624,3 @@ Just $ mkGhcTag' feqn_tycon TkTypeFamilyInstance HsIB { hsib_body = XFamEqn {} } -> Nothing - --- --- Debugging --- - -{- -rdrNameToBS :: RdrName -> ByteString -rdrNameToBS = fs_bs . occNameFS . rdrNameOcc - -showNameSpace :: NameSpace -> String -showNameSpace ns | isDataConNameSpace ns = "data constructor" - | isTcClsNameSpace ns = "type constructor or class" - | isTvNameSpace ns = "type variable" - | isValNameSpace ns = "variable" - | otherwise = error "impossible happend" - -rdrNameSpace :: RdrName -> String -rdrNameSpace = showNameSpace . occNameSpace . rdrNameOcc --} diff --git a/lib/Plugin/GhcTags/Tag.hs b/lib/Plugin/GhcTags/Tag.hs --- a/lib/Plugin/GhcTags/Tag.hs +++ b/lib/Plugin/GhcTags/Tag.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,6 +26,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -- GHC imports @@ -53,13 +53,13 @@ -- | 'ByteString' which encodes a tag name. -- newtype TagName = TagName { getTagName :: Text } - deriving newtype (Eq, Ord, Show) + deriving (Eq, Ord, Show) -- | 'ByteString' which encodes a tag file. -- -newtype TagFile = TagFile { getTagFile :: Text } - deriving newtype (Eq, Ord, Show) +newtype TagFile = TagFile { getTagFile :: String } + deriving (Eq, Ord, Show) -- | When we parse a `tags` file we can eithera find no kind or recognize the @@ -87,40 +87,23 @@ } deriving (Eq, Show) +-- | Total order relation on 'Tag' elements. +-- +-- It sorts type classes / type families ('TkTypeClass', 'TkTypeFamily', +-- 'TkDataTypeFamily') before instances ('TkTypeClassInstance', +-- 'TkTypeFamilyInstance', 'TkDataTypeFamilyInstance'); but also (as a side +-- effect of keeping transitivity property) it will put type classes and their +-- instances before other kinds. +-- compareTags :: Tag -> Tag -> Ordering compareTags t0 t1 | on (/=) tagName t0 t1 = on compare tagName t0 t1 -- sort type classes / type families before their instances, -- and take precendence over a file where they are defined. - | tagKind t0 == GhcKind TkTypeClass - && - tagKind t1 == GhcKind TkTypeClassInstance - = LT - - | tagKind t1 == GhcKind TkTypeClass - && - tagKind t0 == GhcKind TkTypeClassInstance - = GT - - | tagKind t0 == GhcKind TkTypeFamily - && - tagKind t1 == GhcKind TkTypeFamilyInstance - = LT - - | tagKind t1 == GhcKind TkTypeFamily - && - tagKind t0 == GhcKind TkTypeFamilyInstance - = GT - - | tagKind t0 == GhcKind TkDataTypeFamily - && - tagKind t1 == GhcKind TkDataTypeFamilyInstance - = LT - - | tagKind t1 == GhcKind TkDataTypeFamily - && - tagKind t0 == GhcKind TkDataTypeFamilyInstance - = GT + -- + -- This will also sort type classes and instances before any + -- other terms. + | on (/=) getTkClass t0 t1 = on compare getTkClass t0 t1 | on (/=) tagFile t0 t1 = on compare tagFile t0 t1 | on (/=) tagAddr t0 t1 = on compare tagAddr t0 t1 @@ -129,6 +112,16 @@ -- this is not compatible with 'Eq' intsance, but we are not -- defining a 'Ord' instance! | otherwise = EQ + where + getTkClass :: Tag -> Maybe GhcKind + getTkClass t = case tagKind t of + GhcKind TkTypeClass -> Just TkTypeClass + GhcKind TkTypeClassInstance -> Just TkTypeClassInstance + GhcKind TkTypeFamily -> Just TkTypeFamily + GhcKind TkTypeFamilyInstance -> Just TkTypeFamilyInstance + GhcKind TkDataTypeFamily -> Just TkDataTypeFamily + GhcKind TkDataTypeFamilyInstance -> Just TkDataTypeFamilyInstance + _ -> Nothing ghcTagToTag :: GhcTag -> Maybe Tag @@ -137,7 +130,7 @@ UnhelpfulSpan {} -> Nothing RealSrcSpan realSrcSpan -> Just $ Tag { tagName = TagName (Text.decodeUtf8 $ fs_bs gtTag) - , tagFile = TagFile (Text.decodeUtf8 $ fs_bs (srcSpanFile realSrcSpan)) + , tagFile = TagFile (Text.unpack $ Text.decodeUtf8 $ fs_bs (srcSpanFile realSrcSpan)) , tagAddr = Left (srcSpanStartLine realSrcSpan) , tagKind = GhcKind gtKind , tagFields = gtFields diff --git a/lib/Plugin/GhcTags/Vim/Formatter.hs b/lib/Plugin/GhcTags/Vim/Formatter.hs --- a/lib/Plugin/GhcTags/Vim/Formatter.hs +++ b/lib/Plugin/GhcTags/Vim/Formatter.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Builder as BS import Data.Char (isAscii) import Data.Version (showVersion) +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Text.Printf (printf) @@ -27,7 +28,7 @@ formatTag Tag { tagName, tagFile, tagAddr, tagKind, tagFields} = (BS.byteString . Text.encodeUtf8 . getTagName $ tagName) <> BS.charUtf8 '\t' - <> (BS.byteString . Text.encodeUtf8 . getTagFile $ tagFile) + <> (BS.byteString . Text.encodeUtf8 . Text.pack . getTagFile $ tagFile) <> BS.charUtf8 '\t' <> either BS.intDec (BS.byteString . Text.encodeUtf8) tagAddr -- we are using extended format: '_TAG_FILE_FROMAT 2' diff --git a/lib/Plugin/GhcTags/Vim/Parser.hs b/lib/Plugin/GhcTags/Vim/Parser.hs --- a/lib/Plugin/GhcTags/Vim/Parser.hs +++ b/lib/Plugin/GhcTags/Vim/Parser.hs @@ -80,7 +80,7 @@ "parsing tag name failed" parseFileName :: Parser TagFile - parseFileName = TagFile <$> AT.takeWhile (/= '\t') + parseFileName = TagFile . Text.unpack <$> AT.takeWhile (/= '\t') parseExCommand :: Parser Text parseExCommand = (\x -> Text.take (Text.length x - 1) x) <$> diff --git a/src/Plugin/GhcTags.hs b/src/Plugin/GhcTags.hs --- a/src/Plugin/GhcTags.hs +++ b/src/Plugin/GhcTags.hs @@ -15,10 +15,11 @@ import Data.List (sortBy) import qualified Data.Map as Map import Data.Maybe (mapMaybe) +import System.Directory +import System.FilePath import System.IO import System.IO.Error (tryIOError) import System.IO.Unsafe (unsafePerformIO) -import System.Directory import qualified Data.Text.Encoding as Text import GhcPlugins ( CommandLineOption @@ -38,16 +39,16 @@ -- | Global shared state which persists across compilation of different --- modules - a nasty hack which is only used for optimzation. +-- modules - a nasty hack which is only used for optimization. -- tagsMVar :: MVar (Maybe TagsMap) tagsMVar = unsafePerformIO $ newMVar Nothing -- | The GhcTags plugin. It will run for every compiled module and have access --- to parsed syntax tree. It will inpect it and: +-- to parsed syntax tree. It will inspect it and: -- -- * update a global mutable state variable, which stores a tag map. --- It is shared accross modules compiled in the same `ghc` run. +-- It is shared across modules compiled in the same `ghc` run. -- * update 'tags' file. -- -- The global mutable variable save us from parsing the tags file for every @@ -72,15 +73,25 @@ -- plugin :: Plugin plugin = GhcPlugins.defaultPlugin { - parsedResultAction = ghcTagPlugin, + parsedResultAction = ghcTagsPlugin, pluginRecompile = GhcPlugins.purePlugin } +-- | IOExcption wrapper; it is useful for the user to know that it's the plugin +-- not `ghc` that thrown the error. +-- +data GhcTagsPluginException = + GhcTagsPluginIOExceptino IOException + deriving Show + +instance Exception GhcTagsPluginException + + -- | The plugin does not change the 'HsParedModule', it only runs side effects. -- -ghcTagPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule -ghcTagPlugin options _modSummary hsParsedModule@HsParsedModule {hpm_module} = +ghcTagsPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule +ghcTagsPlugin options _modSummary hsParsedModule@HsParsedModule {hpm_module} = hsParsedModule <$ GhcPlugins.liftIO (updateTags tagsFile hpm_module) where tagsFile :: FilePath @@ -99,58 +110,73 @@ -> Located (HsModule GhcPs) -> IO () updateTags tagsFile lmodule = - -- Take exclusive lock. This assures that only one thread will have access to - -- the tags file. Parsing and the rest of the compilation pipeline can - -- happen concurrently. - mvarLock tagsMVar $ \mTagsMap -> do - (tagsMap :: TagsMap) <- - case mTagsMap of + -- wrap 'IOException's + handle (throwIO . GhcTagsPluginIOExceptino) $ - Just tagsMap -> return tagsMap + -- Take exclusive lock. This assures that only one thread will have access to + -- the tags file. Parsing and the rest of the compilation pipeline can + -- happen concurrently. + mvarLock tagsMVar $ \mTagsMap -> do + (tagsMap :: TagsMap) <- + case mTagsMap of - -- the 'tagsMVar' is empty, which means we are compiling the first - -- module. In this case read the tags from disk. - Nothing -> do - a <- doesFileExist tagsFile - res <- - if a - then do - mtext <- tryIOError (Text.decodeUtf8 <$> BS.readFile tagsFile) - case mtext of - Left err -> do - putStrLn $ "GhcTags: error reading \"" ++ tagsFile ++ "\": " ++ (show err) - pure $ Right [] - Right txt -> - Vim.parseTagsFile txt - else pure $ Right [] - case res of - Left err -> do - putStrLn $ "GhcTags: error reading or parsing \"" ++ tagsFile ++ "\": " ++ err - return $ Map.empty - Right tagList -> do - return $ mkTagsMap tagList + Just tagsMap -> return tagsMap - let tagsMap' :: TagsMap - tagsMap' = - (mkTagsMap -- created 'TagsMap' - . mapMaybe ghcTagToTag -- tranalte 'GhcTag' to 'Tag' - . getGhcTags -- generate 'GhcTag's - $ lmodule) - `Map.union` - tagsMap + -- the 'tagsMVar' is empty, which means we are compiling the first + -- module. In this case read the tags from disk. + Nothing -> do + a <- doesFileExist tagsFile + res <- + if a + then do + mtext <- tryIOError (Text.decodeUtf8 <$> BS.readFile tagsFile) + case mtext of + Left err -> do + putStrLn $ "GhcTags: error reading \"" ++ tagsFile ++ "\": " ++ (show err) + pure $ Right [] + Right txt -> + Vim.parseTagsFile txt + else pure $ Right [] + case res of + Left err -> do + putStrLn $ "GhcTags: error reading or parsing \"" ++ tagsFile ++ "\": " ++ err + return $ Map.empty + Right tagList -> do + return $ mkTagsMap tagList - -- update tags file, this will force evaluation `tagsMap'`, so when we - -- write it to `tagsMVar' it will not contain any thunks. - withFile tagsFile WriteMode - $ flip BS.hPutBuilder - ( Vim.formatTagsFile - . sortBy compareTags - . concat - . Map.elems - $ tagsMap' - ) + cwd <- getCurrentDirectory + -- absolute directory path of the tags file; we need canonical path + -- (without ".." and ".") to make 'makeRelative' works. + tagsDir <- canonicalizePath (fst $ splitFileName tagsFile) - pure (Just tagsMap') + let tagsMap' :: TagsMap + tagsMap' = + (mkTagsMap -- created 'TagsMap' + . map (fixFileName cwd tagsDir) + -- fix file names + . mapMaybe ghcTagToTag -- translate 'GhcTag' to 'Tag' + . getGhcTags -- generate 'GhcTag's + $ lmodule) + `Map.union` + tagsMap + + -- update tags file, this will force evaluation `tagsMap'`, so when we + -- write it to `tagsMVar' it will not contain any thunks. + withFile tagsFile WriteMode + $ flip BS.hPutBuilder + ( Vim.formatTagsFile + . sortBy compareTags + . concat + . Map.elems + $ tagsMap' + ) + + pure (Just tagsMap') + + where + fixFileName :: FilePath -> FilePath -> Tag -> Tag + fixFileName cwd tagsDir tag@Tag { tagFile = TagFile path } = + tag { tagFile = TagFile (makeRelative tagsDir (cwd path)) } -- | The 'MVar' is used as an exlusive lock. Also similar to 'bracket' but diff --git a/test/Test/Tag.hs b/test/Test/Tag.hs --- a/test/Test/Tag.hs +++ b/test/Test/Tag.hs @@ -35,17 +35,18 @@ instance Arbitrary ArbOrdTag where arbitrary = fmap ArbOrdTag $ Tag - <$> elements (TagName `map` - [ "find" - , "Ord" - , "Eq" - , "hPut" - ]) + <$> elements + (TagName `map` + [ "find" + , "Ord" + , "Eq" + ]) <*> genTagKind - <*> elements (TagFile `map` - [ "Main.hs" - , "Lib.hs" - ]) + <*> elements + (TagFile `map` + [ "Main.hs" + , "Lib.hs" + ]) <*> frequency [ (8, Left . getPositive <$> arbitrary) , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty) diff --git a/test/Test/Tag/Generators.hs b/test/Test/Tag/Generators.hs --- a/test/Test/Tag/Generators.hs +++ b/test/Test/Tag/Generators.hs @@ -3,10 +3,13 @@ module Test.Tag.Generators where import qualified Data.Char as Char +import Data.List as List import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as Text +import Algebra.Lattice + import Test.QuickCheck import Test.QuickCheck.Instances.Text () @@ -26,9 +29,19 @@ -- filter only printable characters, removing tabs and newlines which have -- special role in vim tag syntax fixText :: Text -> Text -fixText = Text.filter (\x -> x /= '\t' && x /= '\n' && Char.isPrint x) +fixText = Text.filter ( ((/= Char.Control) . Char.generalCategory) + /\ Char.isPrint) +fixFilePath :: String -> String +fixFilePath = List.filter ( ((/= Char.Control) . Char.generalCategory) + /\ Char.isPrint) +genFilePath :: Gen String +genFilePath = + suchThat + (fixFilePath <$> arbitrary) + (not . null) + genField :: Gen TagField genField = TagField @@ -41,7 +54,9 @@ -- filter only printable characters, removing tabs, newlines and colons which -- have special role in vim field syntax fixFieldText :: Text -> Text -fixFieldText = Text.filter (\x -> x /= '\t' && x /= ':' && x /= '\n' && Char.isPrint x) +fixFieldText = Text.filter ( (/= ':') + /\ ((/= Char.Control) . Char.generalCategory) + /\ Char.isPrint) -- address cannot contain ";\"" sequence @@ -81,13 +96,7 @@ ] where genChar = suchThat arbitrary - (\x -> x /= '\t' - && x /= '\n' - && x /= ':' - && x /= '\NUL' - && isNothing (charToGhcKind x) + ( ((/= Char.Control) . Char.generalCategory) + /\ (/= ':') + /\ (isNothing . charToGhcKind) ) - --- --- --- diff --git a/test/Test/Vim.hs b/test/Test/Vim.hs --- a/test/Test/Vim.hs +++ b/test/Test/Vim.hs @@ -38,7 +38,7 @@ Tag <$> (TagName <$> genTextNonEmpty) <*> genTagKind - <*> (TagFile <$> genTextNonEmpty) + <*> (TagFile <$> genFilePath) <*> frequency [ (2, Left . getPositive <$> arbitrary) , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty) @@ -51,8 +51,8 @@ , not (Text.null x) ] ++ [ ArbTag $ tag { tagFile = TagFile x } - | x <- fixText `map` shrink (getTagFile tagFile) - , not (Text.null x) + | x <- fixFilePath `map` shrink (getTagFile tagFile) + , not (null x) ] ++ [ ArbTag $ tag { tagAddr = addr } | addr <- case tagAddr of