ghc-tags-plugin 0.1.4.0 → 0.1.5.0
raw patch · 9 files changed
+331/−151 lines, 9 filesdep +filelockdep −containersPVP ok
version bump matches the API change (PVP)
Dependencies added: filelock
Dependencies removed: containers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−2
- Makefile +4/−1
- README.md +31/−7
- ghc-tags-plugin.cabal +6/−3
- lib/Plugin/GhcTags/Tag.hs +23/−18
- src/Plugin/GhcTags.hs +73/−84
- test/Test/Tag.hs +152/−9
- test/Test/Tag/Generators.hs +35/−0
- test/Test/Vim.hs +1/−27
CHANGELOG.md view
@@ -15,16 +15,20 @@ * Support for `file:` tags (exported / not exported terms) * Added a test-suite (golden tests and property tests) -## 0.1.3.0 -- 2020-03.08+## 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). -## 0.1.4.0 -- 2020-03.11+## 0.1.4.0 -- 2020-03-11 * Tags for default instances of associated (data) type familes. * Added path argument, can be passed using `-fplugin-opt=Plugin.GhcTags:../tags`. * Wrapped `IOExceptions`, so when it will happen it will be obvious that the plugin failed not `ghc` * Fixed the tag ordering function to be fullfil the transitivness property.++## 0.1.5.0 -- 2020-03-13++* concurrency safety - protection `tags` file using a file lock
Makefile view
@@ -25,4 +25,7 @@ recache: ghc-pkg recache --package-db=${PACKAGE_DB} -.PHONY: install, uninstall, reinstall, show, latest+check:+ ghc-pkg check --package-db=${PACKAGE_DB} 2>&1 | grep ghc-tags++.PHONY: install, uninstall, reinstall, latest, check
README.md view
@@ -1,4 +1,9 @@-# Ghc Tags Compiler Plugin+Ghc Tags Compiler Plugin+========================++++   @@ -6,13 +11,15 @@ which generates tags for each compiled module or component. -# ● Requirements+● Requirements+-------------- ``` ghc >= 8.6 ``` -# ● Vim configuration+● Vim configuration+------------------- By default each generated tags file is put next to the corresponding `*.cabal` package file. If you just have a repo with a cabal file in the main directory@@ -24,7 +31,8 @@ or pass an option to modify where tags are written, see below. -# ● Plugin options+● Plugin options+---------------- The plugin accepts an only one option, which is a file path to the tags file. It can be an absolute path or relative (to the `*.cabal` package file rather@@ -35,7 +43,8 @@ This is useful if for *cabal packages* which are located in subdirectories. -# ● Configuration: Ghc / Cabal / Stack+● Configuration: Ghc / Cabal / Stack+------------------------------------ Configuration of this plugin requires some familiarity with `ghc` packages. Check out@@ -123,7 +132,8 @@ package in a `package.db` (by default into `cabal` store). This is mostly for development, but it could be useful in other scenarios as well. -# ● Exceptions+● Exceptions+------------ If a `GHC` plugin throws an exception, `GHC` stops. This plugin wraps `IOException`s, to make it obvious that it filed rather than `GHC`. This@@ -137,8 +147,22 @@ ``` +● Tips+------ -# ● Security implications of compiler plugins+- The plugin is safe for concurrent compilation. Setting `jobs: $ncpus` is+ safe. The plugin holds an exclusive (advisory) lock on the `tags` file.+ This will create synchronisation between threads / process which are using+ the same `tags` file.++- If you are working on a larger project, it might be better to not collect all+ tags in a single `tags` file, since at every compilation step one will need+ to parse a large `tags` file. Working with tag files of size 10000 tags (or+ ~1.5MB) is ok - though this will depend on the hardware.+++● Security implications of compiler plugins+------------------------------------------- Such plugins can:
ghc-tags-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin-version: 0.1.4.0+version: 0.1.5.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@@ -18,17 +18,19 @@ 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 location: https://github.com/coot/ghc-tags-plugin + library hs-source-dirs: src exposed-modules: Plugin.GhcTags build-depends: base >=4.12.0.0 && <4.14, bytestring ^>=0.10,- containers ^>=0.6, directory ^>=1.3,+ filelock ^>=0.1.1, filepath ^>=1.4, ghc >=8.4 && <8.9, text ^>=1.2,@@ -38,6 +40,7 @@ default-language: Haskell2010 ghc-options: -Wall + library ghc-tags-library hs-source-dirs: lib exposed-modules: Plugin.GhcTags.Generate@@ -50,13 +53,13 @@ build-depends: attoparsec ^>=0.13.0.0, base >=4.12.0.0 && <4.14, bytestring ^>=0.10,- containers ^>=0.6, directory ^>=1.3, ghc >=8.4 && <8.9, text ^>=1.2 default-language: Haskell2010 ghc-options: -Wall+ test-suite ghc-tags-tests type: exitcode-stdio-1.0
lib/Plugin/GhcTags/Tag.hs view
@@ -9,6 +9,7 @@ ( -- * Tag Tag (..) , compareTags+ , tagFilePath , TagName (..) , TagFile (..) , TagKind (..)@@ -17,14 +18,10 @@ , ghcKindToChar , TagField (..) , ghcTagToTag- , TagsMap- , mkTagsMap+ , combineTags ) where import Data.Function (on)-import Data.List (sortBy)-import Data.Map (Map)-import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text@@ -61,7 +58,10 @@ newtype TagFile = TagFile { getTagFile :: String } deriving (Eq, Ord, Show) +tagFilePath :: Tag -> FilePath+tagFilePath = getTagFile . tagFile + -- | 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@@ -87,6 +87,7 @@ } deriving (Eq, Show) + -- | Total order relation on 'Tag' elements. -- -- It sorts type classes / type families ('TkTypeClass', 'TkTypeFamily',@@ -137,18 +138,22 @@ } ------ TagsMap+-- This is crtitical function for perfomance. Tags from the first list are+-- assumeed to be from the same file. -----type TagsMap = Map TagFile [Tag]+-- complexity: /O(max n m)/+combineTags :: [Tag] -> [Tag] -> [Tag]+combineTags [] ts1 = ts1+combineTags ts0@(t : _) ts1 = go ts0 ts1+ where+ modPath = tagFilePath t --- | 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 (sortBy compareTags)- . Map.fromListWith (<>)- . map (\t -> (tagFile t, [t]))+ go as@(a : as') bs@(b : bs')+ | tagFilePath b == modPath = go as bs'+ | otherwise = case a `compareTags` b of+ LT -> a : go as' bs+ EQ -> a : go as' bs'+ GT -> b : go as bs'+ go [] bs = filter (\b -> tagFilePath b /= modPath) bs+ go as [] = as+ {-# INLINE go #-}
src/Plugin/GhcTags.hs view
@@ -5,7 +5,6 @@ module Plugin.GhcTags ( plugin ) where -import Control.Concurrent import Control.Exception import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS@@ -13,37 +12,33 @@ import Data.Functor ((<$)) #endif import Data.List (sortBy)-import qualified Data.Map as Map import Data.Maybe (mapMaybe)+import qualified Data.Text.Encoding as Text import System.Directory import System.FilePath import System.IO import System.IO.Error (tryIOError)-import System.IO.Unsafe (unsafePerformIO)-import qualified Data.Text.Encoding as Text+import System.FileLock ( SharedExclusive (..)+ , withFileLock) import GhcPlugins ( CommandLineOption , Hsc , HsParsedModule (..) , Located- , ModSummary+ , ModSummary (..) , Plugin (..) ) import qualified GhcPlugins import HsExtension (GhcPs)-import HsSyn (HsModule)+import HsSyn (HsModule (..))+import qualified Outputable as Out+import qualified PprColour import Plugin.GhcTags.Generate import Plugin.GhcTags.Tag import qualified Plugin.GhcTags.Vim as Vim --- | Global shared state which persists across compilation of different--- modules - a nasty hack which is only used for optimization.----tagsMVar :: MVar (Maybe TagsMap)-tagsMVar = unsafePerformIO $ newMVar Nothing- -- | The GhcTags plugin. It will run for every compiled module and have access -- to parsed syntax tree. It will inspect it and: --@@ -91,8 +86,8 @@ -- | The plugin does not change the 'HsParedModule', it only runs side effects. -- ghcTagsPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule-ghcTagsPlugin options _modSummary hsParsedModule@HsParsedModule {hpm_module} =- hsParsedModule <$ GhcPlugins.liftIO (updateTags tagsFile hpm_module)+ghcTagsPlugin options moduleSummary hsParsedModule@HsParsedModule {hpm_module} =+ hsParsedModule <$ GhcPlugins.liftIO (updateTags moduleSummary tagsFile hpm_module) where tagsFile :: FilePath tagsFile = case options of@@ -100,95 +95,89 @@ a : _ -> a --- | Extract tags from a module and update tags file as well as the 'tagsMVar'--- Using 'tagsMVar' we can save on parsing the tags file: we do it only when--- the first module is compiled. We need to write the results at every--- compilation step since we don't know if the currently compiled module is the--- last one or not.+-- | Extract tags from a module and update tags file ---updateTags :: FilePath+updateTags :: ModSummary+ -> FilePath -> Located (HsModule GhcPs) -> IO ()-updateTags tagsFile lmodule =+updateTags ModSummary {ms_mod, ms_hspp_opts = dynFlags} tagsFile lmodule = -- wrap 'IOException's handle (throwIO . GhcTagsPluginIOExceptino) $ - -- Take exclusive lock. This assures that only one thread will have access to- -- the tags file. Parsing and the rest of the compilation pipeline can- -- happen concurrently.- mvarLock tagsMVar $ \mTagsMap -> do- (tagsMap :: TagsMap) <-- case mTagsMap of-- Just tagsMap -> return tagsMap-- -- the 'tagsMVar' is empty, which means we are compiling the first- -- module. In this case read the tags from disk.- Nothing -> do- a <- doesFileExist tagsFile- res <-- if a- then do- mtext <- tryIOError (Text.decodeUtf8 <$> BS.readFile tagsFile)- case mtext of- Left err -> do- putStrLn $ "GhcTags: error reading \"" ++ tagsFile ++ "\": " ++ (show err)- pure $ Right []- Right txt ->- Vim.parseTagsFile txt- else pure $ Right []+ -- Take advisory exclusive lock (a BSD lock using `flock`) on the tags+ -- file. This is needed when `cabal` compiles in parallel.+ withFileLock tagsFile Exclusive $ \_ -> do+ -- read and parse + a <- doesFileExist tagsFile+ tags <-+ if a+ then do+ res <- tryIOError $+ Text.decodeUtf8 <$> BS.readFile tagsFile+ >>= Vim.parseTagsFile case res of+ -- reading failed Left err -> do- putStrLn $ "GhcTags: error reading or parsing \"" ++ tagsFile ++ "\": " ++ err- return $ Map.empty- Right tagList -> do- return $ mkTagsMap tagList+ putDocLn (errorDoc $ displayException err)+ pure [] + -- parsing failed+ Right (Left err) -> do+ -- shout and continue+ putDocLn (errorDoc err)+ pure []++ Right (Right tags) ->+ pure tags++ -- no such file+ else pure []+ cwd <- getCurrentDirectory -- absolute directory path of the tags file; we need canonical path -- (without ".." and ".") to make 'makeRelative' works. tagsDir <- canonicalizePath (fst $ splitFileName tagsFile) - let tagsMap' :: TagsMap- tagsMap' =- (mkTagsMap -- created 'TagsMap'- . map (fixFileName cwd tagsDir)- -- fix file names- . mapMaybe ghcTagToTag -- translate 'GhcTag' to 'Tag'- . getGhcTags -- generate 'GhcTag's- $ lmodule)- `Map.union`- tagsMap+ let tags' :: [Tag]+ tags' =+ ( map (fixFileName cwd tagsDir)+ -- fix file names+ . sortBy compareTags -- sort+ . mapMaybe ghcTagToTag -- translate 'GhcTag' to 'Tag'+ . getGhcTags -- generate 'GhcTag's+ $ lmodule)+ `combineTags`+ tags - -- update tags file, this will force evaluation `tagsMap'`, so when we- -- write it to `tagsMVar' it will not contain any thunks.- withFile tagsFile WriteMode- $ flip BS.hPutBuilder- ( Vim.formatTagsFile- . sortBy compareTags- . concat- . Map.elems- $ tagsMap'- )-- pure (Just tagsMap')+ -- update tags file+ withFile tagsFile WriteMode $ \h ->+ BS.hPutBuilder h (Vim.formatTagsFile tags') where+ fixFileName :: FilePath -> FilePath -> Tag -> Tag fixFileName cwd tagsDir tag@Tag { tagFile = TagFile path } = tag { tagFile = TagFile (makeRelative tagsDir (cwd </> path)) } + errorDoc :: String -> Out.SDoc+ errorDoc errorMessage =+ Out.coloured PprColour.colBold+ $ Out.blankLine+ Out.$+$+ ((Out.text "GhcTagsPlugin: ")+ Out.<> (Out.coloured PprColour.colRedFg (Out.text "error:")))+ Out.$$+ (Out.nest 4 $ Out.ppr ms_mod)+ Out.$$+ (Out.nest 8 $ Out.coloured PprColour.colRedFg (Out.text errorMessage))+ Out.$+$+ Out.blankLine --- | The 'MVar' is used as an exlusive lock. Also similar to 'bracket' but--- updates the 'MVar' with returned value, or put the original value if an--- exception is thrown by the continuation (or an async exception).----mvarLock :: MVar a- -> (a -> IO a)- -> IO ()-mvarLock v k = mask $ \unmask -> do- a <- takeMVar v- a' <- unmask (k a)- `onException`- putMVar v a- putMVar v $! a'+ putDocLn :: Out.SDoc -> IO ()+ putDocLn sdoc =+ putStrLn $+ Out.renderWithStyle+ dynFlags+ sdoc+ (Out.setStyleColoured True $ Out.defaultErrStyle dynFlags)
test/Test/Tag.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE UnicodeSyntax #-} module Test.Tag (tests) where import Data.Function (on)+import Data.List (nub, sortBy) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)@@ -17,21 +19,55 @@ 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)+ [ testGroup "compareTags"+ [ testProperty "antisymmetry" ordAntiSymmetryProp+ , testProperty "reflexivity" (on ordReflexivityyProp getArbOrdTag)+ , testProperty "transitivity" (\a b c ->+ ordTransitiveProp+ (getArbOrdTag a)+ (getArbOrdTag b)+ (getArbOrdTag c))+ , testProperty "Eq:consistency" (weakConsistency . getArbOrdTag)+ , testProperty "sort:idempotent" sortIdempotentProp+ ]+ , testGroup "combineTags"+ [ testProperty "subset" combineTags_subset+ , testProperty "idempotent" combineTags_idempotent+ , testProperty "identity" combineTags_identity+ , testProperty "preserve" combineTags_preserve+ , testProperty "substitution" combineTags_substitution+ , testProperty "order" combineTags_order+ ] ] +-- | 'Tag' generator+newtype ArbTag = ArbTag { getArbTag :: Tag }+ deriving Show++instance Arbitrary ArbTag where+ arbitrary =+ fmap ArbTag $+ Tag+ <$> (TagName <$> resize 5 genTextNonEmpty)+ <*> genTagKind+ <*> (TagFile <$> genSmallFilePath)+ <*> frequency+ [ (8, Left . getPositive <$> arbitrary)+ , (1, Right . (wrap '/' . fixAddr) <$> genTextNonEmpty)+ , (1, Right . (wrap '?' . fixAddr) <$> genTextNonEmpty)+ ]+ <*> listOf genField++ shrink = map ArbTag . shrinkTag . getArbTag++ -- | 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@@ -54,7 +90,9 @@ ] <*> pure [] + shrink = map ArbOrdTag . shrinkTag . getArbOrdTag + -- | Generate pairs of tags which are equal in the sense of `compare`. -- data EqTags = EqTags Tag Tag@@ -68,12 +106,14 @@ 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'. --@@ -93,7 +133,13 @@ | otherwise -> error "impossible happened" where +sortIdempotentProp :: [ArbTag] -> Bool+sortIdempotentProp ts =+ let ts' = getArbTag `map` ts+ ts'' = sortBy compareTags ts'+ in sortBy compareTags ts'' == ts'' + -- | The -- -- prop> a == b ==> a `compare` b == EQ`@@ -101,3 +147,100 @@ -- But since 'Tag' is using derived 'Eq' instance, it is equivalent to weakConsistency :: Tag -> Bool weakConsistency a = a `compareTags` a == EQ+++--+-- combineTags properties+--++genSmallFilePath :: Gen String+genSmallFilePath = suchThat (resize 3 arbitrary) (not . null)+++-- | sorted list of Tags+newtype ArbTagList = ArbTagList { getArbTagList :: [Tag] }+ deriving Show++instance Arbitrary ArbTagList where+ arbitrary = (ArbTagList . nub . sortBy compareTags . map getArbTag)+ <$> listOf arbitrary+ shrink (ArbTagList ts) =+ (ArbTagList . sortBy compareTags) `map` shrinkList shrinkTag ts+++-- | List of tags from the same file+--+data ArbTagsFromFile = ArbTagsFromFile FilePath [Tag]+ deriving Show++instance Arbitrary ArbTagsFromFile where+ arbitrary = do+ filePath <- genSmallFilePath+ ArbTagList tags <- arbitrary+ let tags' = (\t -> t { tagFile = TagFile filePath, tagFields = [] }) `map` tags+ pure $ ArbTagsFromFile filePath (sortBy compareTags tags')++ shrink (ArbTagsFromFile fp tags) =+ [ ArbTagsFromFile fp (sortBy compareTags tags')+ -- Don't shrink file name!+ | tags' <- shrinkList shrinkTag' tags+ ]+ +++ [ ArbTagsFromFile fp' ((\t -> t { tagFile = TagFile fp' }) `map` tags)+ | fp' <- shrinkList (const []) fp+ , not (null fp')+ ]++++-- properties++combineTags_subset :: ArbTagsFromFile+ -> [ArbTag]+ -> Bool+combineTags_subset (ArbTagsFromFile _ as) bs =+ let bs' = getArbTag `map` bs+ cs = as `combineTags` bs'+ in all (`elem` cs) as+++-- | The tag list be ordered for this property to hold.+--+combineTags_idempotent :: ArbTagList+ -> ArbTagList+ -> Bool+combineTags_idempotent (ArbTagList as) (ArbTagList bs) =+ combineTags as bs == combineTags as (combineTags as bs)+++-- | The tag list cannot connot contain duplicates for this property to hold.+--+combineTags_identity :: ArbTagList+ -> Bool+combineTags_identity (ArbTagList as) =+ combineTags as as == as+++-- | Does not modify tags outside of the module.+--+combineTags_preserve :: ArbTagsFromFile -> ArbTagList -> Bool+combineTags_preserve (ArbTagsFromFile fp as) (ArbTagList bs) =+ filter (\t -> tagFilePath t /= fp) (as `combineTags` bs)+ == + filter (\t -> tagFilePath t /= fp) bs+++-- | Substitutes all tags of the current file.+--+combineTags_substitution :: ArbTagsFromFile -> ArbTagList -> Bool+combineTags_substitution (ArbTagsFromFile fp as) (ArbTagList bs) =+ filter (\t -> tagFilePath t == fp) (as `combineTags` bs)+ == + as++-- | 'combineTags' must preserver order of tags.+--+combineTags_order :: ArbTagsFromFile -> ArbTagList -> Bool+combineTags_order (ArbTagsFromFile _ as) (ArbTagList bs) =+ let cs = as `combineTags` bs+ in sortBy compareTags cs == cs
test/Test/Tag/Generators.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Test.Tag.Generators where@@ -100,3 +101,37 @@ /\ (/= ':') /\ (isNothing . charToGhcKind) )++shrinkTag' :: Tag -> [Tag]+shrinkTag' tag@Tag {tagName, tagAddr, tagFields} =+ [ tag { tagName = TagName x }+ | x <- fixText `map` shrink (getTagName tagName)+ , not (Text.null x)+ ]+ ++ [ tag { tagAddr = addr }+ | addr <- case tagAddr of+ Left addr -> Left `map` shrink addr+ Right addr -> Left 0+ : (Right . wrap '/' . fixAddr)+ `map` (shrink . stripEnds) addr+ , addr /= tagAddr -- wrap might restore the same address!+ ]+ ++ [ 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''+++shrinkTag :: Tag -> [Tag]+shrinkTag tag@Tag {tagFile} =+ shrinkTag' tag+ ++ [ tag { tagFile = TagFile x }+ | x <- fixFilePath `map` shrink (getTagFile tagFile)+ , not (null x)+ ]
test/Test/Vim.hs view
@@ -6,7 +6,6 @@ import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -45,32 +44,7 @@ , (1, Right . (wrap '?' . 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 <- fixFilePath `map` shrink (getTagFile tagFile)- , not (null x)- ]- ++ [ ArbTag $ tag { tagAddr = addr }- | addr <- case tagAddr of- Left addr -> Left `map` shrink addr- Right addr -> Left 0- : (Right . wrap '/' . 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''+ shrink = map ArbTag . shrinkTag . getArbTag roundTrip :: Tag -> Property