ghc-tags-plugin 0.1.2.1 → 0.1.3.0
raw patch · 9 files changed
+275/−84 lines, 9 filesdep −gitrevPVP ok
version bump matches the API change (PVP)
Dependencies removed: gitrev
API changes (from Hackage documentation)
Files
- CHANGELOG.md +12/−0
- README.md +8/−2
- ghc-tags-plugin.cabal +3/−2
- lib/Plugin/GhcTags/Tag.hs +48/−3
- src/Plugin/GhcTags.hs +2/−2
- test/Main.hs +2/−0
- test/Test/Tag.hs +102/−0
- test/Test/Tag/Generators.hs +93/−0
- test/Test/Vim.hs +5/−75
CHANGELOG.md view
@@ -8,3 +8,15 @@ * Added support for tag's kinds. * Added various file headers++## 0.1.2.0 -- 2020-03-05++* Preserve tag information in ctags generated files+* Support for `file:` tags (exported / not exported terms)+* Added a test-suite (golden tests and property tests)++## 0.1.3.0 -- 2020-03.08++* 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).
README.md view
@@ -54,8 +54,14 @@ ``` `PACKAGE_DB` is likely to be something like (for `ghc-8.6.5`)-'${HOME}/.cabal/store/ghc-8.6.5/package.db' (all environment variables must be-expanded).+(all environment variables must be expanded):+```+${HOME}/.cabal/store/ghc-8.6.5/package.db+```+or on Windows (note the `""` syntax)+```+"C:\\Users\\USER_NAME\\AppData\\Roaming\\cabal\\store\\ghc-8.6.5\\package.db+``` ## stack
ghc-tags-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin-version: 0.1.2.1+version: 0.1.3.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@@ -30,7 +30,6 @@ directory ^>=1.3, bytestring ^>=0.10, ghc >=8.4 && <8.9,- gitrev ^>=1.3, text ^>=1.2, ghc-tags-library@@ -63,6 +62,8 @@ hs-source-dirs: test main-is: Main.hs other-modules: Test.Golden.Parser+ Test.Tag+ Test.Tag.Generators Test.Vim default-language: Haskell2010 build-depends: base,
lib/Plugin/GhcTags/Tag.hs view
@@ -9,6 +9,7 @@ module Plugin.GhcTags.Tag ( -- * Tag Tag (..)+ , compareTags , TagName (..) , TagFile (..) , TagKind (..)@@ -21,7 +22,8 @@ , mkTagsMap ) where -import Data.List (sort)+import Data.Function (on)+import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text)@@ -83,9 +85,52 @@ , tagAddr :: !(Either Int Text) , tagFields :: ![TagField] }- deriving (Ord, Eq, Show)+ deriving (Eq, Show) +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++ | on (/=) tagFile t0 t1 = on compare tagFile t0 t1+ | on (/=) tagAddr t0 t1 = on compare tagAddr t0 t1+ | on (/=) tagKind t0 t1 = on compare tagKind t0 t1++ -- this is not compatible with 'Eq' intsance, but we are not+ -- defining a 'Ord' instance!+ | otherwise = EQ++ ghcTagToTag :: GhcTag -> Maybe Tag ghcTagToTag GhcTag { gtSrcSpan, gtTag, gtKind, gtFields } = case gtSrcSpan of@@ -111,6 +156,6 @@ -- mkTagsMap :: [Tag] -> TagsMap mkTagsMap =- fmap sort+ fmap (sortBy compareTags) . Map.fromListWith (<>) . map (\t -> (tagFile t, [t]))
src/Plugin/GhcTags.hs view
@@ -12,7 +12,7 @@ #if __GLASGOW_HASKELL__ < 808 import Data.Functor ((<$)) #endif-import Data.List (sort)+import Data.List (sortBy) import qualified Data.Map as Map import Data.Maybe (mapMaybe) import System.IO@@ -144,7 +144,7 @@ withFile tagsFile WriteMode $ flip BS.hPutBuilder ( Vim.formatTagsFile- . sort+ . sortBy compareTags . concat . Map.elems $ tagsMap'
test/Main.hs view
@@ -3,6 +3,7 @@ import Test.Tasty import qualified Test.Golden.Parser (tests)+import qualified Test.Tag (tests) import qualified Test.Vim (tests) @@ -13,5 +14,6 @@ tests = testGroup "Plugin.GhcTags" [ Test.Golden.Parser.tests+ , Test.Tag.tests , Test.Vim.tests ]
+ test/Test/Tag.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}++module Test.Tag (tests) where++import Data.Function (on)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import Test.QuickCheck.Instances.Text ()++import Plugin.GhcTags.Tag++import Test.Tag.Generators++tests :: TestTree+tests = testGroup "Tag"+ [ testProperty "Ord:antisymmetry" ordAntiSymmetryProp+ , testProperty "Ord:reflexivity" (on ordReflexivityyProp getArbOrdTag)+ , testProperty "Ord:transitivity" (\a b c ->+ ordTransitiveProp+ (getArbOrdTag a)+ (getArbOrdTag b)+ (getArbOrdTag c))+ , testProperty "Ord:Eq:consistency" (weakConsistency . getArbOrdTag)+ ]+++-- | Arbitrary instance with a high probability of gettings the same tags or files.+newtype ArbOrdTag = ArbOrdTag { getArbOrdTag :: Tag }+ deriving Show++instance Arbitrary ArbOrdTag where+ arbitrary = fmap ArbOrdTag+ $ Tag+ <$> elements (TagName `map`+ [ "find"+ , "Ord"+ , "Eq"+ , "hPut"+ ])+ <*> genTagKind+ <*> elements (TagFile `map`+ [ "Main.hs"+ , "Lib.hs"+ ])+ <*> frequency+ [ (8, Left . getPositive <$> arbitrary)+ , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty)+ , (1, Right . (wrap '?' . fixAddr) <$> genTextNonEmpty)+ ]+ <*> pure []+++-- | Generate pairs of tags which are equal in the sense of `compare`.+--+data EqTags = EqTags Tag Tag+ deriving Show++instance Arbitrary EqTags where+ arbitrary = do+ x <- getArbOrdTag <$> arbitrary+ fieldsA <- listOf genField+ fieldsB <- listOf genField+ pure $ EqTags x { tagFields = fieldsA }+ x { tagFields = fieldsB }++-- | Note that this property is weaker than required. There are unequal `Tag`s+-- in the sense of `==`, which are considered equal by `compare`.+--+ordAntiSymmetryProp :: EqTags -> Bool+ordAntiSymmetryProp (EqTags a b) = a `compareTags` b == EQ++-- We don't provide 'Ord' instance, since it's not compatible with 'compare',+-- see 'weakConsistency'.+--+(≤), (≥) :: Tag -> Tag -> Bool+a ≤ b = a `compareTags` b /= GT+a ≥ b = a `compareTags` b /= LT++ordReflexivityyProp :: Tag -> Tag -> Bool+ordReflexivityyProp a b = a ≤ b || a ≥ b++ordTransitiveProp :: Tag -> Tag -> Tag -> Property+ordTransitiveProp a b c =+ a ≤ b && b ≤ c+ || a ≥ b && b ≥ c ==>+ if | a ≤ b && b ≤ c -> a ≤ c+ | a ≥ b && b ≥ c -> a ≥ c+ | otherwise -> error "impossible happened"+ where+++-- | The+--+-- prop> a == b ==> a `compare` b == EQ`+--+-- But since 'Tag' is using derived 'Eq' instance, it is equivalent to+weakConsistency :: Tag -> Bool+weakConsistency a = a `compareTags` a == EQ
+ test/Test/Tag/Generators.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Tag.Generators where++import qualified Data.Char as Char+import Data.Maybe (isNothing)+import Data.Text (Text)+import qualified Data.Text as Text++import Test.QuickCheck+import Test.QuickCheck.Instances.Text ()++import Plugin.GhcTags.Tag++--+-- Generators+--++-- a quick hack+genTextNonEmpty :: Gen Text+genTextNonEmpty =+ suchThat+ (fixText <$> arbitrary)+ (not . Text.null)++-- 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)+++genField :: Gen TagField+genField =+ TagField+ <$> suchThat g (not . Text.null)+ <*> g+ where+ g :: Gen Text+ g = fixFieldText <$> arbitrary++-- 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)+++-- address cannot contain ";\"" sequence+fixAddr :: Text -> Text+fixAddr = fixText . Text.replace ";\"" ""++wrap :: Char -> Text -> Text+wrap c = Text.cons c . flip Text.snoc c++genGhcKind :: Gen GhcKind+genGhcKind = elements+ [ TkTerm+ , TkFunction+ , TkTypeConstructor+ , TkDataConstructor+ , TkGADTConstructor+ , TkRecordField+ , TkTypeSynonym+ , TkTypeSignature+ , TkPatternSynonym+ , TkTypeClass+ , TkTypeClassMember+ , TkTypeClassInstance+ , TkTypeFamily+ , TkTypeFamilyInstance+ , TkDataTypeFamily+ , TkDataTypeFamilyInstance+ , TkForeignImport+ , TkForeignExport+ ]++genTagKind :: Gen TagKind+genTagKind = oneof+ [ pure NoKind+ , CharKind <$> genChar+ , GhcKind <$> genGhcKind+ ]+ where+ genChar = suchThat arbitrary+ (\x -> x /= '\t'+ && x /= '\n'+ && x /= ':'+ && x /= '\NUL'+ && isNothing (charToGhcKind x)+ )++--+--+--
test/Test/Vim.hs view
@@ -6,8 +6,6 @@ import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import qualified Data.Char as Char-import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text@@ -20,85 +18,17 @@ import Plugin.GhcTags.Tag import qualified Plugin.GhcTags.Vim as Vim +import Test.Tag.Generators + tests :: TestTree tests = testGroup "Vim" [ testProperty "round-trip" (roundTrip . getArbTag) ] ---- a quick hack-genTextNonEmpty :: Gen Text-genTextNonEmpty =- suchThat- (fixText <$> arbitrary)- (not . Text.null)---- 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)---genField :: Gen TagField-genField =- TagField- <$> suchThat g (not . Text.null)- <*> g- where- g :: Gen Text- g = fixFieldText <$> arbitrary---- 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)----- address cannot contain ";\"" sequence-fixAddr :: Text -> Text-fixAddr = fixText . Text.replace ";\"" ""--wrap :: Char -> Text -> Text-wrap c = Text.cons c . flip Text.snoc c--genGhcKind :: Gen GhcKind-genGhcKind = elements- [ TkTerm- , TkFunction- , TkTypeConstructor- , TkDataConstructor- , TkGADTConstructor- , TkRecordField- , TkTypeSynonym- , TkTypeSignature- , TkPatternSynonym- , TkTypeClass- , TkTypeClassMember- , TkTypeClassInstance- , TkTypeFamily- , TkTypeFamilyInstance- , TkDataTypeFamily- , TkDataTypeFamilyInstance- , TkForeignImport- , TkForeignExport- ]--genTagKind :: Gen TagKind-genTagKind = oneof- [ pure NoKind- , CharKind <$> genChar- , GhcKind <$> genGhcKind- ]- where- genChar = suchThat arbitrary- (\x -> x /= '\t'- && x /= '\n'- && x /= ':'- && x /= '\NUL'- && isNothing (charToGhcKind x)- )-+--+-- Generators+-- newtype ArbTag = ArbTag { getArbTag :: Tag } deriving Show