ghc-tags-plugin 0.1.1.0 → 0.1.2.0
raw patch · 12 files changed
+900/−308 lines, 12 filesdep +QuickCheckdep +quickcheck-instancesdep +tastydep ~attoparsecdep ~basedep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, quickcheck-instances, tasty, tasty-golden, tasty-quickcheck, text
Dependency ranges changed: attoparsec, base, bytestring
API changes (from Hackage documentation)
Files
- README.md +10/−1
- ghc-tags-plugin.cabal +31/−5
- lib/Plugin/GhcTags/Generate.hs +239/−68
- lib/Plugin/GhcTags/Parser.hs +0/−171
- lib/Plugin/GhcTags/Tag.hs +116/−0
- lib/Plugin/GhcTags/Vim.hs +3/−51
- lib/Plugin/GhcTags/Vim/Formatter.hs +80/−0
- lib/Plugin/GhcTags/Vim/Parser.hs +160/−0
- src/Plugin/GhcTags.hs +15/−12
- test/Main.hs +17/−0
- test/Test/Golden/Parser.hs +79/−0
- test/Test/Vim.hs +150/−0
README.md view
@@ -1,7 +1,16 @@ # Ghc Tags Compiler Plugin+++ 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++```+ghc >= 8.6+```+ # vim configuration Each generated tags file is put next to the corresponding `*.cabal` file. If@@ -33,7 +42,7 @@ Install the `ghc-tags-plugin` to cabal store with: ```-cabal install ghc-tags-plugin+cabal install --lib ghc-tags-plugin ``` In `cabal.project.local` file add `package` stanza for every local package :
ghc-tags-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin-version: 0.1.1.0+version: 0.1.2.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@@ -15,6 +15,7 @@ README.md homepage: https://github.com/coot/ghc-tags-plugin#readme bug-reports: https://github.com/coot/ghc-tags-plugin/issues+tested-with: GHC==8.6.3, GHC==8.8.3 source-repository head type: git@@ -23,12 +24,13 @@ library hs-source-dirs: src exposed-modules: Plugin.GhcTags- build-depends: base ^>=4.12.0.0,+ build-depends: base >=4.12.0.0 && <4.14, containers ^>=0.6, directory ^>=1.3, bytestring ^>=0.10, ghc >=8.4 && <8.9, gitrev ^>=1.3,+ text ^>=1.2, ghc-tags-library @@ -38,15 +40,39 @@ library ghc-tags-library hs-source-dirs: lib exposed-modules: Plugin.GhcTags.Generate- Plugin.GhcTags.Parser+ Plugin.GhcTags.Tag Plugin.GhcTags.Vim+ Plugin.GhcTags.Vim.Parser+ Plugin.GhcTags.Vim.Formatter Paths_ghc_tags_plugin autogen-modules: Paths_ghc_tags_plugin- build-depends: base ^>=4.12.0.0,+ build-depends: base >=4.12.0.0 && <4.14, attoparsec ^>=0.13.0.0, containers ^>=0.6, directory ^>=1.3, bytestring ^>=0.10,- ghc >=8.4 && <8.9+ ghc >=8.4 && <8.9,+ text ^>=1.2+ default-language: Haskell2010+ ghc-options: -Wall++test-suite ghc-tags-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Test.Golden.Parser+ Test.Vim+ default-language: Haskell2010 + build-depends: base,+ attoparsec,+ bytestring,+ tasty,+ tasty-golden,+ tasty-quickcheck,+ text,+ QuickCheck,+ quickcheck-instances,++ ghc-tags-library ghc-options: -Wall
lib/Plugin/GhcTags/Generate.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Interface for generatating tags for a parsed module.@@ -7,23 +9,33 @@ module Plugin.GhcTags.Generate ( GhcTag (..) , GhcTags- , TagKind (..)- , tagKindToChar- , charToTagKind+ , GhcKind (..)+ , TagField (..)+ , ghcKindToChar+ , charToGhcKind , getGhcTags ) where -import Data.Maybe (mapMaybe)+-- import Data.ByteString (ByteString)+import Data.List (find)+import Data.Maybe (mapMaybe, maybeToList) import Data.Foldable (foldl')+import Data.Text (Text)+import qualified Data.Text as Text -- Ghc imports+import BasicTypes ( SourceText (..)+ ) import FastString ( FastString (..) )+import FieldLabel ( FieldLbl (..)+ ) import HsBinds ( HsBindLR (..) , PatSynBind (..) , Sig (..) )-import HsDecls ( ClsInstDecl (..)+import HsDecls ( ForeignImport (..)+ , ClsInstDecl (..) , ConDecl (..) , DataFamInstDecl (..) , FamEqn (..)@@ -38,6 +50,10 @@ , TyClDecl (..) , TyFamInstDecl (..) )+import HsImpExp ( IE (..)+ , IEWildcard (..)+ , ieWrappedName+ ) import HsSyn ( FieldOcc (..) , GhcPs , HsModule (..)@@ -56,15 +72,26 @@ , unLoc ) import RdrName ( RdrName (..)+ , rdrNameOcc ) import Name ( nameOccName , occNameFS )-+{-+import OccName ( NameSpace+ , isDataConNameSpace+ , isTcClsNameSpace+ , isTvNameSpace+ , isValNameSpace+ , isVarNameSpace+ , occNameSpace+ , pprNameSpace+ )+-} -- | `ctags` can generate tags kind, so do we. ---data TagKind = TkTerm+data GhcKind = TkTerm | TkFunction | TkTypeConstructor | TkDataConstructor@@ -85,16 +112,16 @@ deriving (Ord, Eq, Show) -tagKindToChar :: TagKind -> Char-tagKindToChar tagKind = case tagKind of- TkTerm -> 'x'- TkFunction -> 'l' -- we should use 'λ' but vim is not showing them in a right way- TkTypeConstructor -> 't'+ghcKindToChar :: GhcKind -> Char+ghcKindToChar tagKind = case tagKind of+ TkTerm -> '`'+ TkFunction -> 'λ'+ TkTypeConstructor -> 'Λ' TkDataConstructor -> 'c' TkGADTConstructor -> 'g' TkRecordField -> 'r'- TkTypeSynonym -> 'S'- TkTypeSignature -> 's'+ TkTypeSynonym -> '≡'+ TkTypeSignature -> '⊢' TkPatternSynonym -> 'p' TkTypeClass -> 'C' TkTypeClassMember -> 'm'@@ -107,16 +134,16 @@ TkForeignExport -> 'E' -charToTagKind :: Char -> Maybe TagKind-charToTagKind c = case c of- 'x' -> Just TkTerm- 'l' -> Just TkFunction- 't' -> Just TkTypeConstructor+charToGhcKind :: Char -> Maybe GhcKind+charToGhcKind c = case c of+ '`' -> Just TkTerm+ 'λ' -> Just TkFunction+ 'Λ' -> Just TkTypeConstructor 'c' -> Just TkDataConstructor 'g' -> Just TkGADTConstructor 'r' -> Just TkRecordField- 'S' -> Just TkTypeSynonym- 's' -> Just TkTypeSignature+ '≡' -> Just TkTypeSynonym+ '⊢' -> Just TkTypeSignature 'p' -> Just TkPatternSynonym 'C' -> Just TkTypeClass 'm' -> Just TkTypeClassMember@@ -130,34 +157,102 @@ _ -> Nothing ++data TagField = TagField {+ fieldName :: Text,+ fieldValue :: Text+ }+ deriving (Eq, Ord, Show)++fileField :: TagField+fileField = TagField { fieldName = "file", fieldValue = "" }++ -- | We can read names from using fields of type 'GHC.Hs.Extensions.IdP' (a tpye -- family) which for @'Parsed@ resolved to 'RdrName' -- data GhcTag = GhcTag { gtSrcSpan :: !SrcSpan , gtTag :: !FastString- , gtKind :: !TagKind+ , gtKind :: !GhcKind+ , gtFields :: ![TagField] } deriving Show +appendField :: TagField -> GhcTag -> GhcTag+appendField f gt = gt { gtFields = f : gtFields gt }++ type GhcTags = [GhcTag] -mkGhcTag :: Located RdrName -- Located (IdP GhcPs)- -> TagKind+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+ where+ -- TODO: the GHC's one is partial, and I got a panic error.+ ieName :: IE GhcPs -> Maybe RdrName+ ieName (IEVar _ (L _ n)) = Just $ ieWrappedName n+ ieName (IEThingAbs _ (L _ n)) = Just $ ieWrappedName n+ ieName (IEThingWith _ (L _ n) _ _ _) = Just $ ieWrappedName n+ ieName (IEThingAll _ (L _ n)) = Just $ ieWrappedName n+ ieName _ = Nothing++-- | Either class members or type constructors.+--+getFileTagFieldForMember :: Maybe [IE GhcPs]+ -> Located RdrName -- member name / constructor name+ -> Located RdrName -- type class name / type constructor name+ -> Maybe TagField+getFileTagFieldForMember Nothing _memberName _className = Nothing+getFileTagFieldForMember (Just ies) memberName className =+ maybe (Just fileField) (const Nothing) $ find go ies+ where+ go :: IE GhcPs -> Bool++ go (IEVar _ (L _ n)) = ieWrappedName n == unLoc memberName++ go (IEThingAbs _ _) = False++ go (IEThingAll _ (L _ n)) = ieWrappedName n == unLoc className++ go (IEThingWith _ _ IEWildcard{} _ _) = True++ go (IEThingWith _ (L _ n) NoIEWildcard ns lfls) =+ ieWrappedName n == unLoc className+ && (isInWrappedNames || isInFieldLbls)+ 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+ isInFieldLbls = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . flSelector. unLoc) lfls ++ go _ = False+++mkGhcTag :: Located RdrName+ -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier.+ -> GhcKind+ -- ^ tag's kind+ -> [TagField]+ -- ^ tag's fields -> GhcTag-mkGhcTag (L gtSrcSpan rdrName) gtKind =+mkGhcTag (L gtSrcSpan rdrName) gtKind gtFields = case rdrName of Unqual occName -> GhcTag { gtTag = occNameFS occName , gtSrcSpan , gtKind+ , gtFields } Qual _ occName -> GhcTag { gtTag = occNameFS occName , gtSrcSpan , gtKind+ , gtFields } -- Orig is the only one we are interested in@@ -165,16 +260,17 @@ GhcTag { gtTag = occNameFS occName , gtSrcSpan , gtKind+ , gtFields } - Exact name -> - GhcTag { gtTag = occNameFS $ nameOccName name+ Exact eName -> + GhcTag { gtTag = occNameFS $ nameOccName eName , gtSrcSpan , gtKind+ , gtFields } - -- | Generate tags for a module - simple walk over the syntax tree. -- -- Supported identifiers:@@ -193,43 +289,61 @@ -- getGhcTags :: Located (HsModule GhcPs) -> GhcTags-getGhcTags (L _ HsModule { hsmodDecls }) = +getGhcTags (L _ HsModule { hsmodDecls, hsmodExports }) = reverse $ foldl' go [] hsmodDecls where+ mies :: Maybe [IE GhcPs]+ mies = map unLoc . unLoc <$> hsmodExports++ -- like 'mkGhcTag' but checks if the identifier is exported+ mkGhcTag' :: Located RdrName+ -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier.+ -> GhcKind+ -- ^ tag's kind+ -> GhcTag+ mkGhcTag' a k = mkGhcTag a k (maybeToList $ getFileTagField mies a)++ mkGhcTagForMember :: Located RdrName -- member name+ -> Located RdrName -- class name+ -> GhcKind+ -> GhcTag+ mkGhcTagForMember memberName className kind =+ mkGhcTag memberName kind (maybeToList $ getFileTagFieldForMember mies memberName className)+ go :: GhcTags -> LHsDecl GhcPs -> GhcTags go tags (L _ hsDecl) = case hsDecl of -- type or class declaration TyClD _ tyClDecl -> case tyClDecl of FamDecl { tcdFam } ->- case mkFamilyDeclTags tcdFam of+ case mkFamilyDeclTags tcdFam Nothing of Just tag -> tag : tags Nothing -> tags SynDecl { tcdLName } ->- mkGhcTag tcdLName TkTypeSynonym : tags+ mkGhcTag' tcdLName TkTypeSynonym : tags DataDecl { tcdLName, tcdDataDefn } -> case tcdDataDefn of HsDataDefn { dd_cons } ->- mkGhcTag tcdLName TkTypeConstructor- : (mkConsTags . unLoc) `concatMap` dd_cons+ mkGhcTag' tcdLName TkTypeConstructor+ : (mkConsTags tcdLName . unLoc) `concatMap` dd_cons ++ tags XHsDataDefn {} -> tags -- TODO: add 'tcdATDefs' ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs } ->- -- class name- mkGhcTag tcdLName TkTypeClass- -- class methods- : (mkSigTags . unLoc) `concatMap` tcdSigs- -- default methods+ -- 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- ++ (mkFamilyDeclTags . unLoc) `mapMaybe` tcdATs+ ++ (flip mkFamilyDeclTags (Just tcdLName) . unLoc) `mapMaybe` tcdATs XTyClDecl {} -> tags @@ -253,7 +367,6 @@ dataFamTags = (mkDataFamInstDeclTag . unLoc) `concatMap` cid_datafam_insts tyFamTags = (mkTyFamInstDeclTag . unLoc) `mapMaybe` cid_tyfam_insts - DataFamInstD { dfid_inst } -> mkDataFamInstDeclTag dfid_inst ++ tags @@ -279,9 +392,18 @@ -- foreign declaration ForD _ foreignDecl -> case foreignDecl of- ForeignImport { fd_name } -> mkGhcTag fd_name TkForeignImport : tags+ ForeignImport { fd_name, fd_fi = CImport _ _ _mheader _ (L _ sourceText) } ->+ case sourceText of+ NoSourceText -> tag+ -- TODO: add header information from '_mheader'+ SourceText s -> TagField "ffi" (Text.pack s) `appendField` tag+ : tags+ where+ tag = mkGhcTag' fd_name TkForeignImport - ForeignExport { fd_name } -> mkGhcTag fd_name TkForeignExport : tags+ ForeignExport { fd_name } ->+ mkGhcTag' fd_name TkForeignExport+ : tags XForeignDecl {} -> tags @@ -299,14 +421,19 @@ XHsDecl {} -> tags -- tags of all constructors of a type- mkConsTags :: ConDecl GhcPs -> GhcTags- mkConsTags ConDeclGADT { con_names, con_args } =- flip mkGhcTag TkGADTConstructor `map` con_names+ mkConsTags :: Located RdrName+ -- name of the type+ -> ConDecl GhcPs+ -- constrtructor declaration+ -> GhcTags+ mkConsTags tyName ConDeclGADT { con_names, con_args } =+ (\n -> mkGhcTagForMember n tyName TkGADTConstructor)+ `map` con_names ++ mkHsConDeclDetails con_args- mkConsTags ConDeclH98 { con_name, con_args } =- mkGhcTag con_name TkDataConstructor+ mkConsTags tyName ConDeclH98 { con_name, con_args } =+ mkGhcTagForMember con_name tyName TkDataConstructor : mkHsConDeclDetails con_args- mkConsTags XConDecl {} = []+ mkConsTags _ XConDecl {} = [] mkHsConDeclDetails :: HsConDeclDetails GhcPs -> GhcTags mkHsConDeclDetails (RecCon (L _ fields)) = foldl' f [] fields@@ -316,7 +443,9 @@ f ts _ = ts g :: GhcTags -> LFieldOcc GhcPs -> GhcTags- g ts (L _ FieldOcc { rdrNameFieldOcc }) = mkGhcTag rdrNameFieldOcc TkRecordField : ts+ g ts (L _ FieldOcc { rdrNameFieldOcc }) =+ mkGhcTag' rdrNameFieldOcc TkRecordField+ : ts g ts _ = ts mkHsConDeclDetails _ = []@@ -324,7 +453,7 @@ mkHsBindLRTags :: HsBindLR GhcPs GhcPs -> GhcTags mkHsBindLRTags hsBind = case hsBind of- FunBind { fun_id } -> [mkGhcTag fun_id TkFunction]+ FunBind { fun_id } -> [mkGhcTag' fun_id TkFunction] -- TODO -- This is useful fo generating tags for@@ -333,20 +462,32 @@ -- ``` PatBind {} -> [] - VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag (L srcSpan var_id) TkTerm]+ VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag' (L srcSpan var_id) TkTerm] -- abstraction binding are only used after translaction AbsBinds {} -> [] - PatSynBind _ PSB { psb_id } -> [mkGhcTag psb_id TkPatternSynonym]+ PatSynBind _ PSB { psb_id } -> [mkGhcTag' psb_id TkPatternSynonym] PatSynBind _ XPatSynBind {} -> [] XHsBindsLR {} -> [] + mkClsMemberTags :: Located RdrName -> Sig GhcPs -> GhcTags+ mkClsMemberTags clsName (TypeSig _ lhs _) =+ (\n -> mkGhcTagForMember n clsName TkTypeSignature)+ `map` lhs+ mkClsMemberTags clsName (PatSynSig _ lhs _) =+ (\n -> mkGhcTagForMember n clsName TkPatternSynonym)+ `map` lhs+ mkClsMemberTags clsName (ClassOpSig _ _ lhs _) =+ (\n -> mkGhcTagForMember n clsName TkTypeClassMember)+ `map` lhs+ mkClsMemberTags _ _ = []+ mkSigTags :: Sig GhcPs -> GhcTags- mkSigTags (TypeSig _ lhs _) = flip mkGhcTag TkTypeSignature `map` lhs- mkSigTags (PatSynSig _ lhs _) = flip mkGhcTag TkPatternSynonym `map` lhs- mkSigTags (ClassOpSig _ _ lhs _) = flip mkGhcTag TkTypeClassMember `map` lhs+ mkSigTags (TypeSig _ lhs _) = flip mkGhcTag' TkTypeSignature `map` lhs+ mkSigTags (PatSynSig _ lhs _) = flip mkGhcTag' TkPatternSynonym `map` lhs+ mkSigTags (ClassOpSig _ _ lhs _) = flip mkGhcTag' TkTypeClassMember `map` lhs mkSigTags IdSig {} = [] -- TODO: generate theses with additional info (fixity) mkSigTags FixSig {} = []@@ -363,28 +504,37 @@ mkSigTags XSig {} = [] mkFamilyDeclTags :: FamilyDecl GhcPs+ -> Maybe (Located RdrName)+ -- if this type family is associate, pass the name of the+ -- associated class -> Maybe GhcTag- mkFamilyDeclTags FamilyDecl { fdLName, fdInfo } = Just $ mkGhcTag fdLName tk+ mkFamilyDeclTags FamilyDecl { fdLName, fdInfo } assocClsName =+ case assocClsName of+ Nothing -> Just $ mkGhcTag' fdLName tk+ Just clsName -> Just $ mkGhcTagForMember fdLName clsName tk where tk = case fdInfo of DataFamily -> TkDataTypeFamily OpenTypeFamily -> TkTypeFamily ClosedTypeFamily {} -> TkTypeFamily- mkFamilyDeclTags XFamilyDecl {} = Nothing+ mkFamilyDeclTags XFamilyDecl {} _ = Nothing -- used to generate tag of an instance declaration mkLHsTypeTag :: LHsType GhcPs -> Maybe GhcTag- mkLHsTypeTag (L _ hsType) =+ mkLHsTypeTag (L _ hsType) = (\a -> mkGhcTag a TkTypeClassInstance []) <$> hsTypeTagName hsType++ hsTypeTagName :: HsType GhcPs -> Maybe (Located RdrName)+ hsTypeTagName hsType = case hsType of- HsForAllTy {hst_body} -> mkLHsTypeTag hst_body+ HsForAllTy {hst_body} -> hsTypeTagName (unLoc hst_body) - HsQualTy {hst_body} -> mkLHsTypeTag hst_body+ HsQualTy {hst_body} -> hsTypeTagName (unLoc hst_body) - HsTyVar _ _ a -> Just $ mkGhcTag a TkTypeClassInstance+ HsTyVar _ _ a -> Just $ a - HsAppTy _ a _ -> mkLHsTypeTag a- HsOpTy _ _ a _ -> Just $ mkGhcTag a TkTypeClassInstance- HsKindSig _ a _ -> mkLHsTypeTag a+ HsAppTy _ a _ -> hsTypeTagName (unLoc a)+ HsOpTy _ _ a _ -> Just $ a+ HsKindSig _ a _ -> hsTypeTagName (unLoc a) _ -> Nothing @@ -397,9 +547,10 @@ HsIB { hsib_body = FamEqn { feqn_tycon, feqn_rhs } } -> case feqn_rhs of HsDataDefn { dd_cons } ->- mkGhcTag feqn_tycon TkDataTypeFamilyInstance : (mkConsTags . unLoc) `concatMap` dd_cons- XHsDataDefn {} ->- mkGhcTag feqn_tycon TkDataTypeFamilyInstance : []+ mkGhcTag' feqn_tycon TkDataTypeFamilyInstance+ : (mkConsTags feqn_tycon . unLoc) `concatMap` dd_cons+ XHsDataDefn {} ->+ mkGhcTag' feqn_tycon TkDataTypeFamilyInstance : [] HsIB { hsib_body = XFamEqn {} } -> [] @@ -409,6 +560,26 @@ XHsImplicitBndrs {} -> Nothing -- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?- HsIB { hsib_body = FamEqn { feqn_tycon } } -> Just $ mkGhcTag feqn_tycon TkTypeFamilyInstance+ HsIB { hsib_body = FamEqn { feqn_tycon } } ->+ 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 +-}
− lib/Plugin/GhcTags/Parser.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE NamedFieldPuns #-}--module Plugin.GhcTags.Parser- ( -- * Tag- TagName (..)- , TagFile (..)- , Tag (..)- , ghcTagToTag- -- * Parsing- , parseVimTagFile- -- * TagsMap'- , TagsMap- , mkTagsMap- ) where--import Control.Applicative (many)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BSC-import Data.Attoparsec.ByteString (Parser)-import qualified Data.Attoparsec.ByteString as A-import Data.Attoparsec.ByteString.Char8 ( (<?>) )-import qualified Data.Attoparsec.ByteString.Char8 as AC-import Data.Either (rights)-import Data.List (sort)-import Data.Functor (void)-import Data.Map (Map)-import qualified Data.Map as Map---- GHC imports-import Plugin.GhcTags.Generate- ( GhcTag (..)- , TagKind- , charToTagKind- )-import FastString ( FastString (..)- )-import SrcLoc ( SrcSpan (..)- , srcSpanFile- , srcSpanStartLine- )-------- Tag-------- | 'ByteString' which encodes a tag name.----newtype TagName = TagName { getTagName :: ByteString }- deriving newtype (Eq, Ord, Show)----- | 'ByteString' which encodes a tag file.----newtype TagFile = TagFile { getTagFile :: ByteString }- deriving newtype (Eq, Ord, Show)----- | Simple Tag record. For the moment on tag name, tag file and line numbers--- are supported.------ TODO: expand to support column numbers and extra information.----data Tag = Tag- { tagName :: !TagName- , tagFile :: !TagFile- , tagLine :: !Int- , tagKind :: !(Maybe TagKind)- }- deriving (Ord, Eq, Show)---ghcTagToTag :: GhcTag -> Maybe Tag-ghcTagToTag GhcTag { gtSrcSpan, gtTag, gtKind } =- case gtSrcSpan of- UnhelpfulSpan {} -> Nothing- RealSrcSpan realSrcSpan ->- Just $ Tag { tagName = TagName (fs_bs gtTag)- , tagFile = TagFile (fs_bs (srcSpanFile realSrcSpan))- , tagLine = srcSpanStartLine realSrcSpan- , tagKind = Just gtKind- }-------- Parsing-------- | Parser for a single line of a vim-style tag file.----vimTagParser:: Parser Tag-vimTagParser = do- -- use monadic form to provide compatibility with previous version where- -- `;"` and tag kinds where not present.- tagName <-- TagName <$> AC.takeWhile (/= '\t') <* AC.skipWhile (== '\t')- <?> "parsing tag name failed"- tagFile <-- TagFile <$> AC.takeWhile (/= '\t') <* AC.skipWhile (== '\t')- <?> "parsing tag file name failed"- tagLine <- AC.decimal- <?> "parsing line number failed"- - mc <- AC.peekChar- tagKind <-- case mc of- Just ';' ->- charToTagKind- <$> (AC.anyChar *> AC.char '"' *> AC.char '\t' *> AC.anyChar)- <?> "parsing tag kind failed"- _ -> pure Nothing- AC.endOfLine- pure $ Tag {tagName, tagFile, tagLine, tagKind}----- | A vim-style tag file parser.----vimTagFileParser :: Parser [Tag]-vimTagFileParser = rights <$> many tagLineParser---tagLineParser :: Parser (Either () Tag)-tagLineParser =- AC.eitherP- (vimTagHeaderLine <?> "failed parsing tag")- (vimTagParser <?> "failed parsing header")---vimTagHeaderLine :: Parser ()-vimTagHeaderLine = AC.choice- [ AC.string (BSC.pack "!_TAG_FILE_FORMAT") *> params- , AC.string (BSC.pack "!_TAG_FILE_SORTED") *> params- , AC.string (BSC.pack "!_TAG_FILE_ENCODING") *> params- , AC.string (BSC.pack "!_TAG_PROGRAM_AUTHOR") *> params- , AC.string (BSC.pack "!_TAG_PROGRAM_NAME") *> params- , AC.string (BSC.pack "!_TAG_PROGRAM_URL") *> params- , AC.string (BSC.pack "!_TAG_PROGRAM_VERSION") *> params- ]- where-- params = void $ AC.char '\t' *> AC.skipWhile (/= '\n') *> AC.char '\n'---- | Parse a vim-style tag file.----parseVimTagFile :: ByteString- -> IO (Either String [Tag])-parseVimTagFile =- fmap A.eitherResult- . A.parseWith (pure mempty) vimTagFileParser-------- TagsMap------type TagsMap = Map TagFile [Tag]---- | Map from TagName to list of tags. This will be useful when updating tags.--- We will just need to merge dictionaries.----mkTagsMap :: [Tag] -> TagsMap-mkTagsMap =- fmap sort- . Map.fromListWith (<>)- . map (\t -> (tagFile t, [t]))
+ lib/Plugin/GhcTags/Tag.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Plugin.GhcTags.Tag+ ( -- * Tag+ Tag (..)+ , TagName (..)+ , TagFile (..)+ , TagKind (..)+ , GhcKind (..)+ , charToGhcKind+ , ghcKindToChar+ , TagField (..)+ , ghcTagToTag+ , TagsMap+ , mkTagsMap+ ) where++import Data.List (sort)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text.Encoding as Text++-- GHC imports+import FastString ( FastString (..)+ )+import SrcLoc ( SrcSpan (..)+ , srcSpanFile+ , srcSpanStartLine+ )++import Plugin.GhcTags.Generate+ ( GhcTag (..)+ , GhcKind (..)+ , TagField (..)+ , charToGhcKind+ , ghcKindToChar+ )++--+-- Tag+--+++-- | 'ByteString' which encodes a tag name.+--+newtype TagName = TagName { getTagName :: Text }+ deriving newtype (Eq, Ord, Show)+++-- | 'ByteString' which encodes a tag file.+--+newtype TagFile = TagFile { getTagFile :: Text }+ deriving newtype (Eq, Ord, Show)+++-- | When we parse a `tags` file we can eithera find no kind or recognize the+-- kind of GhcKind or we store the found character kind. This allows us to+-- preserve information from parsed tags files which were not created by+-- `ghc-tags-plugin'+--+data TagKind+ = GhcKind !GhcKind+ | CharKind !Char+ | NoKind+ deriving (Eq, Ord, Show)++-- | Simple Tag record. For the moment on tag name, tag file and line numbers+-- are supported.+--+-- TODO: expand to support column numbers and extra information.+--+data Tag = Tag+ { tagName :: !TagName+ , tagKind :: !TagKind+ , tagFile :: !TagFile+ , tagAddr :: !(Either Int Text)+ , tagFields :: ![TagField]+ }+ deriving (Ord, Eq, Show)+++ghcTagToTag :: GhcTag -> Maybe Tag+ghcTagToTag GhcTag { gtSrcSpan, gtTag, gtKind, gtFields } =+ case gtSrcSpan of+ UnhelpfulSpan {} -> Nothing+ RealSrcSpan realSrcSpan ->+ Just $ Tag { tagName = TagName (Text.decodeUtf8 $ fs_bs gtTag)+ , tagFile = TagFile (Text.decodeUtf8 $ fs_bs (srcSpanFile realSrcSpan))+ , tagAddr = Left (srcSpanStartLine realSrcSpan)+ , tagKind = GhcKind gtKind+ , tagFields = gtFields+ }+++--+-- TagsMap+--+++type TagsMap = Map TagFile [Tag]++-- | Map from TagName to list of tags. This will be useful when updating tags.+-- We will just need to merge dictionaries.+--+mkTagsMap :: [Tag] -> TagsMap+mkTagsMap =+ fmap sort+ . Map.fromListWith (<>)+ . map (\t -> (tagFile t, [t]))
lib/Plugin/GhcTags/Vim.hs view
@@ -1,54 +1,6 @@-{-# LANGUAGE NamedFieldPuns #-}- module Plugin.GhcTags.Vim- ( formatVimTag- , formatVimTagFile+ ( module X ) where -import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BS-import Data.Version (showVersion)-import Text.Printf (printf)--import Paths_ghc_tags_plugin (version)--import Plugin.GhcTags.Generate-import Plugin.GhcTags.Parser----- | 'ByteString' 'Builder' for a single line.----formatVimTag :: Tag -> Builder-formatVimTag Tag { tagName, tagFile, tagLine, tagKind } =- BS.byteString (getTagName tagName)- <> BS.charUtf8 '\t'- <> BS.byteString (getTagFile tagFile)- <> BS.charUtf8 '\t'- <> BS.intDec tagLine- <> case tagKind of- Just k ->- BS.stringUtf8 ";\"\t"- <> BS.charUtf8 (tagKindToChar k)- Nothing -> mempty- <> BS.charUtf8 '\n'----- | 'ByteString' 'Builder' for vim 'Tag' file.----formatVimTagFile :: [Tag] -> Builder-formatVimTagFile tags =- -- format 1 does not append ';"' to lines- BS.stringUtf8 (formatHeader "TAG_FILE_FORMAT" "2")- -- allows for binary search- <> BS.stringUtf8 (formatHeader "TAG_FILE_SORTED" "1")- <> BS.stringUtf8 (formatHeader "TAG_FILE_ENCODING" "utf-8")- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_AUTHOR" "Marcin Szamotulski")- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_NAME" "ghc-tags-pluginn")- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_URL"- "https://hackage.haskell.org/package/ghc-tags-plugin")- -- version number with git revision- <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_VERSION" (showVersion version))- <> foldMap formatVimTag tags- where- formatHeader :: String -> String -> String- formatHeader header arg = printf ("!_" ++ header ++ "\t%s\t\n") arg+import Plugin.GhcTags.Vim.Parser as X+import Plugin.GhcTags.Vim.Formatter as X
+ lib/Plugin/GhcTags/Vim/Formatter.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | 'bytestring''s 'Builder' for a 'Tag'+--+module Plugin.GhcTags.Vim.Formatter+ ( formatTagsFile+ , formatTag+ , formatHeader+ ) where++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BS+import Data.Char (isAscii)+import Data.Version (showVersion)+import qualified Data.Text.Encoding as Text+import Text.Printf (printf)++import Paths_ghc_tags_plugin (version)++import Plugin.GhcTags.Generate+import Plugin.GhcTags.Tag+++-- | 'ByteString' 'Builder' for a single line.+--+formatTag :: Tag -> Builder+formatTag Tag { tagName, tagFile, tagAddr, tagKind, tagFields} =+ (BS.byteString . Text.encodeUtf8 . getTagName $ tagName)+ <> BS.charUtf8 '\t'+ <> (BS.byteString . Text.encodeUtf8 . getTagFile $ tagFile)+ <> BS.charUtf8 '\t'+ <> either BS.intDec (BS.byteString . Text.encodeUtf8) 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.charUtf8 '\n'+ where+ formatKindChar :: TagKind -> Builder+ formatKindChar NoKind = mempty+ formatKindChar (CharKind c)+ | isAscii c = BS.charUtf8 '\t' <> BS.charUtf8 c+ | otherwise = BS.stringUtf8 "\tkind:" <> BS.charUtf8 c+ formatKindChar (GhcKind ghcKind)+ | isAscii c = BS.charUtf8 '\t' <> BS.charUtf8 c+ | otherwise = BS.stringUtf8 "\tkind:" <> BS.charUtf8 c+ where+ c = ghcKindToChar ghcKind+++formatField :: TagField -> Builder+formatField TagField { fieldName, fieldValue } =+ BS.byteString (Text.encodeUtf8 fieldName)+ <> BS.charUtf8 ':'+ <> BS.byteString (Text.encodeUtf8 fieldValue)+++formatHeader :: String -> String -> String+formatHeader header arg = printf ("!_" ++ header ++ "\t%s\t\n") arg+++-- | 'ByteString' 'Builder' for vim 'Tag' file.+--+formatTagsFile :: [Tag] -> Builder+formatTagsFile tags =+ -- format 1 does not append ';"' to lines+ BS.stringUtf8 (formatHeader "TAG_FILE_FORMAT" "2")+ -- allows for binary search+ <> BS.stringUtf8 (formatHeader "TAG_FILE_SORTED" "1")+ <> BS.stringUtf8 (formatHeader "TAG_FILE_ENCODING" "utf-8")+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_AUTHOR" "Marcin Szamotulski")+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_NAME" "ghc-tags-pluginn")+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_URL"+ "https://hackage.haskell.org/package/ghc-tags-plugin")+ -- version number with git revision+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_VERSION" (showVersion version))+ <> foldMap formatTag tags
+ lib/Plugin/GhcTags/Vim/Parser.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Parser combinators for vim style tags+--+module Plugin.GhcTags.Vim.Parser+ ( parseTagsFile+ , parseTags+ , parseTag+ , parseField+ ) where++import Control.Arrow ((***))+import Control.Applicative (many, (<|>))+import Data.Attoparsec.Text (Parser, (<?>))+import qualified Data.Attoparsec.Text as AT+import Data.Either (rights)+import Data.Functor (void, ($>))+import Data.Text (Text)+import qualified Data.Text as Text++import Plugin.GhcTags.Tag+++-- | Parser for a single line of a vim-style tag file.+--+parseTag :: Parser Tag+parseTag =+ (\tagName tagFile tagAddr (tagKind, tagFields)+ -> Tag { tagName, tagFile, tagAddr, tagKind, tagFields })+ <$> parseTagName+ <* separator++ <*> parseFileName+ <* separator++ -- includes an optional ';"' separator+ <*> AT.eitherP parseAddr parseExCommand++ <*> ( -- kind field followed by list of fields or end of line.+ ((,) <$> ( separator *> parseKindField )+ <*> ( separator *> parseFields <* AT.endOfLine+ <|>+ AT.endOfLine $> [])+ )++ -- 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.+ <|> curry id NoKind+ <$> ( separator *> parseFields <* AT.endOfLine+ <|>+ AT.endOfLine $> []+ )++ -- kind encoded as a single letter, followed by a list+ -- of fields or end of line.+ <|> curry (charToTagKind *** id)+ <$> ( separator *> AT.satisfy notTabOrNewLine )+ <*> ( separator *> parseFields <* AT.endOfLine+ <|>+ AT.endOfLine $> []+ )+ <|> AT.endOfLine $> (NoKind, [])+ )++ where+ separator :: Parser Char+ separator = AT.char '\t'++ notTabOrNewLine :: Char -> Bool+ notTabOrNewLine = \x -> x /= '\t' && x /= '\n' ++ parseTagName :: Parser TagName+ parseTagName = TagName <$> AT.takeWhile (/= '\t')+ <?> "parsing tag name failed"++ parseFileName :: Parser TagFile+ parseFileName = TagFile <$> AT.takeWhile (/= '\t')++ parseExCommand :: Parser Text+ parseExCommand = (\x -> Text.take (Text.length x - 1) x) <$>+ AT.scan "" go+ <* AT.anyChar+ where+ -- go until either '\n' or ';"' sequence is found.+ go :: String -> Char -> Maybe String+ go _ '\n' = Nothing+ go !s c | l == "\";" = Nothing+ | otherwise = Just l+ where+ l = take 2 (c : s)++ parseAddr :: Parser Int+ parseAddr = AT.decimal+ <* AT.eitherP+ AT.endOfLine+ (AT.char ';' *> AT.char '"')++ parseKindField :: Parser TagKind+ parseKindField =+ charToTagKind <$>+ (AT.string "kind:" *> AT.satisfy notTabOrNewLine)++ parseFields :: Parser [TagField]+ parseFields = AT.sepBy parseField separator+++charToTagKind :: Char -> TagKind+charToTagKind c = case charToGhcKind c of+ Nothing -> CharKind c+ Just ghcTag -> GhcKind ghcTag+++parseField :: Parser TagField+parseField =+ TagField+ <$> AT.takeWhile (\x -> x /= ':' && x /= '\n' && x /= '\t')+ <* AT.char ':'+ <*> AT.takeWhile (\x -> x /= '\t' && x /= '\n')+++-- | A vim-style tag file parser.+--+parseTags :: Parser [Tag]+parseTags = rights <$> many parseTagLine+++parseTagLine :: Parser (Either () Tag)+parseTagLine =+ AT.eitherP+ (parseHeader <?> "failed parsing tag")+ (parseTag <?> "failed parsing header")+++parseHeader :: Parser ()+parseHeader = AT.choice+ [ AT.string (Text.pack "!_TAG_FILE_FORMAT") *> params+ , AT.string (Text.pack "!_TAG_FILE_SORTED") *> params+ , AT.string (Text.pack "!_TAG_FILE_ENCODING") *> params+ , AT.string (Text.pack "!_TAG_PROGRAM_AUTHOR") *> params+ , AT.string (Text.pack "!_TAG_PROGRAM_NAME") *> params+ , AT.string (Text.pack "!_TAG_PROGRAM_URL") *> params+ , AT.string (Text.pack "!_TAG_PROGRAM_VERSION") *> params+ ]+ where+ params = void $ AT.char '\t' *> AT.skipWhile (/= '\n') *> AT.char '\n'+++-- | Parse a vim-style tag file.+--+parseTagsFile :: Text+ -> IO (Either String [Tag])+parseTagsFile =+ fmap AT.eitherResult+ . AT.parseWith (pure mempty) parseTags
src/Plugin/GhcTags.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,7 +9,9 @@ import Control.Exception import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS+#if __GLASGOW_HASKELL__ < 808 import Data.Functor ((<$))+#endif import Data.List (sort) import qualified Data.Map as Map import Data.Maybe (mapMaybe)@@ -16,22 +19,22 @@ import System.IO.Error (tryIOError) import System.IO.Unsafe (unsafePerformIO) import System.Directory+import qualified Data.Text.Encoding as Text import GhcPlugins ( CommandLineOption , Hsc , HsParsedModule (..)+ , Located , ModSummary , Plugin (..)- , liftIO- , purePlugin )-import GhcPlugins hiding (occName, (<>))+import qualified GhcPlugins import HsExtension (GhcPs) import HsSyn (HsModule) import Plugin.GhcTags.Generate-import Plugin.GhcTags.Parser-import Plugin.GhcTags.Vim+import Plugin.GhcTags.Tag+import qualified Plugin.GhcTags.Vim as Vim -- | Global shared state which persists across compilation of different@@ -70,7 +73,7 @@ plugin :: Plugin plugin = GhcPlugins.defaultPlugin { parsedResultAction = ghcTagPlugin,- pluginRecompile = purePlugin+ pluginRecompile = GhcPlugins.purePlugin } @@ -78,7 +81,7 @@ -- ghcTagPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule ghcTagPlugin options _modSummary hsParsedModule@HsParsedModule {hpm_module} =- hsParsedModule <$ liftIO (updateTags tagsFile hpm_module)+ hsParsedModule <$ GhcPlugins.liftIO (updateTags tagsFile hpm_module) where tagsFile :: FilePath tagsFile = case options of@@ -112,13 +115,13 @@ res <- if a then do- mbytes <- tryIOError (BS.readFile tagsFile)- case mbytes of+ mtext <- tryIOError (Text.decodeUtf8 <$> BS.readFile tagsFile)+ case mtext of Left err -> do putStrLn $ "GhcTags: error reading \"" ++ tagsFile ++ "\": " ++ (show err) pure $ Right []- Right bytes ->- parseVimTagFile bytes+ Right txt ->+ Vim.parseTagsFile txt else pure $ Right [] case res of Left err -> do@@ -140,7 +143,7 @@ -- write it to `tagsMVar' it will not contain any thunks. withFile tagsFile WriteMode $ flip BS.hPutBuilder- ( formatVimTagFile+ ( Vim.formatTagsFile . sort . concat . Map.elems
+ test/Main.hs view
@@ -0,0 +1,17 @@+module Main where++import Test.Tasty++import qualified Test.Golden.Parser (tests)+import qualified Test.Vim (tests)+++main ::IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup "Plugin.GhcTags"+ [ Test.Golden.Parser.tests+ , Test.Vim.tests+ ]
+ test/Test/Golden/Parser.hs view
@@ -0,0 +1,79 @@+module Test.Golden.Parser (tests) where++import Control.Exception+import Control.Monad ((>=>))++import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BS+import qualified Data.Text.Encoding as Text+import System.IO++import qualified Plugin.GhcTags.Vim as Vim++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden+++tests :: TestTree+tests = testGroup "Golden.Parser"+ [ let input = "test/golden/test.tags"+ output = "test/golden/test.tags.out"+ in goldenVsFile + "test tags"+ input+ output+ (parseGoldenFile input output)++ , let input = "test/golden/vim.tags"+ output = "test/golden/vim.tags.out"+ in goldenVsFile + "vim tags"+ input+ output+ (parseGoldenFile input output)++ , let input = "test/golden/typed-protocols.tags"+ output = "test/golden/typed-protocols.tags.out"+ in goldenVsFile + "typed-protocols tags"+ input+ output+ (parseGoldenFile input output)++ , let input = "test/golden/io-sim-classes.tags"+ output = "test/golden/io-sim-classes.tags.out"+ in goldenVsFile + "io-sim-classes tags"+ input+ output+ (parseGoldenFile input output)+ + , let input = "test/golden/ouroboros-network.tags"+ output = "test/golden/ouroboros-network.tags.out"+ in goldenVsFile + "ouroboros-network tags"+ input+ output+ (parseGoldenFile input output)++ , let input = "test/golden/ouroboros-consensus.tags"+ output = "test/golden/ouroboros-consensus.tags.out"+ in goldenVsFile + "ouroboros-consensus tags"+ input+ output+ (parseGoldenFile input output)+ ]+++parseGoldenFile :: FilePath -- input file+ -> FilePath -- output file+ -> IO ()+parseGoldenFile input output = do+ res <- withBinaryFile input ReadMode+ (BS.hGetContents >=> Vim.parseTagsFile . Text.decodeUtf8)+ case res of+ Left err -> throwIO (userError err)+ Right tags ->+ withBinaryFile output WriteMode+ $ flip BS.hPutBuilder (foldMap Vim.formatTag tags)
+ test/Test/Vim.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Vim (tests) where++import qualified Data.Attoparsec.Text as AT+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Data.Maybe (isNothing)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import Test.QuickCheck.Instances.Text ()++import Plugin.GhcTags.Tag+import qualified Plugin.GhcTags.Vim as Vim+++tests :: TestTree+tests = testGroup "Vim"+ [ testProperty "round-trip" (roundTrip . getArbTag)+ ]+++-- a quick hack+genTextNonEmpty :: Gen Text+genTextNonEmpty =+ suchThat+ (fixText <$> arbitrary)+ (not . Text.null)++fixText :: Text -> Text+fixText = Text.filter (\x -> x /= '\t' && x /= '\n' && x /= '\NUL')+++genField :: Gen TagField+genField =+ TagField+ <$> suchThat g (not . Text.null)+ <*> g+ where + g :: Gen Text+ g = fixFieldText <$> arbitrary++fixFieldText :: Text -> Text+fixFieldText = Text.filter (\x -> x /= '\t' && x /= ':' && x /= '\n' && x /= '\NUL')++fixAddr :: Text -> Text+fixAddr = fixText . Text.replace ";\"" ""++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)+ )+++newtype ArbTag = ArbTag { getArbTag :: Tag }+ deriving Show++instance Arbitrary ArbTag where+ arbitrary = fmap ArbTag $+ Tag+ <$> (TagName <$> genTextNonEmpty)+ <*> genTagKind+ <*> (TagFile <$> genTextNonEmpty)+ <*> oneof+ [ Left . getPositive <$> arbitrary+ , Right . (Text.cons '/' . flip Text.snoc '/' . fixAddr) <$> genTextNonEmpty+ ]+ <*> listOf genField+ shrink (ArbTag tag@Tag {tagName, tagFile, tagAddr, tagFields}) =+ [ ArbTag $ tag { tagName = TagName x }+ | x <- fixText `map` shrink (getTagName tagName)+ , not (Text.null x)+ ]+ ++ [ ArbTag $ tag { tagFile = TagFile x }+ | x <- fixText `map` shrink (getTagFile tagFile)+ , not (Text.null x)+ ]+ ++ [ ArbTag $ tag { tagAddr = addr }+ | addr <- case tagAddr of+ Left addr -> Left `map` shrink addr+ Right addr -> Left 0+ : (Right . Text.cons '/' . flip Text.snoc '/' . fixAddr)+ `map` (shrink . stripEnds) addr+ ]+ ++ [ ArbTag $ tag { tagFields = fields }+ | fields <- shrinkList (const []) tagFields+ ]+ where+ stripEnds :: Text -> Text+ stripEnds addr = case Text.uncons addr of+ Nothing -> error "impossible happend"+ Just (_, addr') -> case Text.unsnoc addr' of+ Nothing -> error "impossible happend"+ Just (addr'', _) -> addr''+ ++roundTrip :: Tag -> Property+roundTrip tag =+ let bs = BL.toStrict+ . BB.toLazyByteString+ . Vim.formatTag+ $ tag+ mtag = AT.parseOnly Vim.parseTag + . Text.decodeUtf8+ $ bs+ in case mtag of+ Left err -> counterexample+ ("parser error: " ++ err ++ " bs: " ++ (Text.unpack (Text.decodeUtf8 bs)))+ (property False)+ Right tag' -> counterexample+ (show $ Text.decodeUtf8 bs)+ (tag === tag')