diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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, 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 @@ -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])) diff --git a/src/Plugin/GhcTags.hs b/src/Plugin/GhcTags.hs --- a/src/Plugin/GhcTags.hs +++ b/src/Plugin/GhcTags.hs @@ -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' diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ] diff --git a/test/Test/Tag.hs b/test/Test/Tag.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tag.hs @@ -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 diff --git a/test/Test/Tag/Generators.hs b/test/Test/Tag/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tag/Generators.hs @@ -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) + ) + +-- +-- +-- diff --git a/test/Test/Vim.hs b/test/Test/Vim.hs --- a/test/Test/Vim.hs +++ b/test/Test/Vim.hs @@ -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