diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,16 @@ # Ghc Tags Compiler Plugin +![](https://github.com/coot/ghc-tags-plugin/workflows/GHC-8.8.3/badge.svg) +![](https://github.com/coot/ghc-tags-plugin/workflows/GHC-8.6.5/badge.svg) + 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 : 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.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 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 @@ -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 +-} diff --git a/lib/Plugin/GhcTags/Parser.hs b/lib/Plugin/GhcTags/Parser.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags/Parser.hs +++ /dev/null @@ -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])) diff --git a/lib/Plugin/GhcTags/Tag.hs b/lib/Plugin/GhcTags/Tag.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Tag.hs @@ -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])) diff --git a/lib/Plugin/GhcTags/Vim.hs b/lib/Plugin/GhcTags/Vim.hs --- a/lib/Plugin/GhcTags/Vim.hs +++ b/lib/Plugin/GhcTags/Vim.hs @@ -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 diff --git a/lib/Plugin/GhcTags/Vim/Formatter.hs b/lib/Plugin/GhcTags/Vim/Formatter.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Vim/Formatter.hs @@ -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 diff --git a/lib/Plugin/GhcTags/Vim/Parser.hs b/lib/Plugin/GhcTags/Vim/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Vim/Parser.hs @@ -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 diff --git a/src/Plugin/GhcTags.hs b/src/Plugin/GhcTags.hs --- a/src/Plugin/GhcTags.hs +++ b/src/Plugin/GhcTags.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/Golden/Parser.hs b/test/Test/Golden/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Test/Golden/Parser.hs @@ -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) diff --git a/test/Test/Vim.hs b/test/Test/Vim.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vim.hs @@ -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')