smuggler2 0.3.2.2 → 0.3.3.2
raw patch · 16 files changed
+882/−236 lines, 16 filesdep ~containersdep ~directorydep ~ghc-pathsnew-component:exe:ghc-smuggler2
Dependency ranges changed: containers, directory, ghc-paths, tasty-golden, typed-process
Files
- CHANGELOG.md +3/−2
- Makefile +20/−5
- README.md +48/−28
- TODO.md +19/−1
- app/Main.hs +15/−7
- smuggler2.cabal +13/−15
- src/Smuggler2/Anns.hs +9/−93
- src/Smuggler2/Exports.hs +113/−0
- src/Smuggler2/Imports.hs +182/−0
- src/Smuggler2/Parser.hs +5/−2
- src/Smuggler2/Plugin.hs +76/−73
- test/Test.hs +46/−10
- test/tests/ExportPattern2.hs +141/−0
- test/tests/ImportPattern.hs +134/−0
- test/tests/Pattern.hs +10/−0
- test/tests/TypeFam.hs +48/−0
CHANGELOG.md view
@@ -5,8 +5,9 @@ `smuggler2` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. -## [Unreleased]-- Nothing to report+## [0.3.3.2]: -- 8 June 2020+- pattern synonyms and type families are handled+- ghc-smuggler2 wrapper for ghc ## [0.3.2.2]: -- 31 May 2020 - Documentation only
Makefile view
@@ -1,18 +1,29 @@ # For convenience # -.PHONY: test clean accept doc hlint ghcid weed+.PHONY: build install test clean accept doc hlint ghcid weed -all: test doc+all: build test doc -test:- cabal test --test-show-details=streaming+build:+ # Creates a package environment file needed to get the tests to run in some+ # environments (eg, travis)+ cabal build # --write-ghc-environment-files=always +install:+ cabal install --lib smuggler2+ cabal install exe:ghc-smuggler2 --overwrite-policy=always++test: build+ git diff --check+ cabal test --test-show-details=streaming --test-option=--delete-output=onpass+ clean: cabal clean+ cabal v1-clean accept:- cabal run smuggler2-test -- --accept+ cabal run smuggler2-test -- --accept --delete-output=onpass doc: cabal haddock@@ -26,3 +37,7 @@ weed: cabal build weeder++whitespace:+ git diff --check+ git rebase --whitespace=fix
README.md view
@@ -23,6 +23,10 @@ ## How to use +Install `smuggler2` using `cabal install --lib smuggler2`.++If you also want the `ghc` wrapper, install it using `cabal install exe:smuggler2`.+ ### Adding Smuggler2 to your dependencies Add `smuggler2` to the dependencies of your project and to your compiler flags.@@ -37,7 +41,7 @@ common smuggler-options if flag(smuggler2)- ghc-options: -fplugin:Smuggler2.Plugin+ ghc-options: -fplugin=Smuggler2.Plugin build-depends: smuggler2 >= 0.3 ``` @@ -59,21 +63,28 @@ ### Alternatively, using a local version If you have installed `smuggler2` from a local copy of this repository, you may-only need to add `-package smuggler2` to your `ghc-options`.+need to add `-package smuggler2` to your `ghc-options` if you did not+install using the `--lib` flag to `cabal install`. -```Cabal-common smuggler-options- if flag(smuggler2)- ghc-options: -fplugin:Smuggler2.Plugin --package smuggler22-```+### Or use a `ghc` wrapper -(You may need to install from a local copy using `cabal v1-install` for-`smuggler2` to be recognised, perhaps depending on your version of `cabal`.)+The `smuggler2` package provides an executable `ghc-smuggler2` that calls `ghc`+with the `-fplugin=Smuggler2.Plugin` argument (followed by any others that you+supply). This allows you to run the plugin over your sources without modifying+your `.cabal` file: +```bash+$ cabal build -with-compiler=ghc-smuggler2+```+or just+```bash+$ cabal build -w ghc-smuggler2+```+ ### Options -`Smuggler2` has several (case-insensitive) options, which can be set by adding a-`-fplugin-opt=Smuggler2.Plugin:` to your `ghc-options`+`Smuggler2` has several (case-insensitive) options, which can be set by adding+`-fplugin-opt=Smuggler2.Plugin:` flags to your `ghc-options` - `NoImportProcessing` - do no import processing - `PreserveInstanceImports` - remove unused imports, but preserve a library@@ -99,28 +110,32 @@ original file. ```Cabal- ghc-options: -fplugin:Smuggler2.Plugin -fplugin-opt=Smuggler2.Plugin:new+ ghc-options: -fplugin=Smuggler2.Plugin -fplugin-opt=Smuggler2.Plugin:new ``` This will create output files with a `.new` suffix rather the overwriting the originals. -Smuggler2 tries not to perform file changes when there are no unused imports or-exports to be added or replaced. So you can just run `ghcid` as usual:+Smuggler2 tries not to change files when there is no work to do.+So you can just run `ghcid` as usual: ```bash $ ghcid --command='cabal repl' ``` -If you add `-v` to your `ghc-options` ## Caveats +- Because `cabal` and `ghc` don't have full support for distinguishing dependent+ packages from plug-ins you will probably want to ensure that the build+ dependencies for your project are installed into your local package db first,+ before enabling sumuggler, otherwise they will all be processed by it too,+ as your project builds, which should do no harm, but will increase your build time.+ `Smugggler2` is robust -- it can chew through the-[agda](https://github.com/agda/agda) codebase of over 370 modules with complex+[Agda](https://github.com/agda/agda) codebase of over 370 modules with complex interdependencies and be tripped over by only -- a handful of pattern synonym imports, - a couple of ambiguous exports (are we trying to export something defined in the current module or something with the same name from an imported module) - and a couple of imports where both qualifed and unqualifed version of the@@ -128,7 +143,7 @@ version of the same names But there are some caveats, most of which are either easy enough to work around-(and still benefit from a great reduction in keyboard work):+(and still offer the benefit of a great reduction in keyboard work): - `Smuggler2` rewrites the existing imports, rather than attempting to prune them. (This is a more aggressive approach than `smuggler` which focuses on@@ -173,9 +188,6 @@ - `hiding` clauses may not be properly analysed. So hiding things that are not used may not be spotted. -- Certain syntax pattern imports may not be imported correctly (the `pattern`- keyword is missing)- - The test suite does not seem to run reliably on Windows. This is probably more of an issue with the way that the tests are run, than `Smuggler2` itself. @@ -206,7 +218,7 @@ To build with debugging: ```shell-$ cabal bulid -fdebug+$ cabal build -fdebug ``` Curently this just adds an `-fdump-minimal-imports` parameter to GHC@@ -244,14 +256,23 @@ variable. This may be helpful for certain workflows where `cabal` is not in the current path, or you want to add extra flags to the `cabal` command. -The test suite does not run reliably on Windows+The test suite does not seem to run reliably on Windows +Importing a test module from another test module in the same directory is likely+to lead to race conditions as 'Tasty' runs tests in parallel and so will try to+generate the same `smuggler2` output both when the imported module is being+tested directly and when it is being processed when the importing module is+being tested. Put the imported module in a subdirectory to avoid this issue, as+the test harness only looks for tests in `test\tests` and not its+subdirectories.+ ## Implementation approach `smuggler2` uses the `ghc-exactprint` [library](https://hackage.haskell.org/package/ghc-exactprint) to modiify the source code. The documentation for the library is fairly spartan, and the-library is not widely used, so the use here can, no doubt, be optimised.+library is not widely used, at least in publicly available code, so the use here+can, no doubt, be optimised. The library is needed because the annotated AST that GHC generates does not have enough information to reconstitute the original source. Some parts of the@@ -287,10 +308,9 @@ - `exactPrint`s the result back over the original file (or one with a different suffix, if that was specified as option to `smuggler2`) -This round tripping is needed because the AST provided by GHC to `smuggler2` is-of a different type from the AST that `ghc-exactprint` uses. (It is the product-of the renaming phase of the compiler, while `ghc-exactprint` uses a parse phase-AST.)+This round tripping is needed because the AST that `ghc` provides does not have+enough information in it to reconstitute the source (which is why+`ghc-exactprint` exists). ### Exports
TODO.md view
@@ -7,8 +7,26 @@ - [ ] Script to generate new test (from template?) - [ ] get tasty-golden to delete successful results and update tests where- smuggler makes no changes+ smuggler makes no changes - [ ] refactor the much more sophisticated https://github.com/ddssff/refact-global-hse - [ ] Do a better job of preserving comments++- [ ] Running test suite on both an imported module and the module that imports+ it creates race conditions because both cases will generate the same minimum+ imprts dump file++- [ ] Do a better job of preserving imported pattern annotation.++- [ ] Check that type imports / exports work, Type Operators, ++- [X] Running test suite on both an imported module and the module that imports+ it creates race conditions because both cases will generate the same minimum+ imports dump file++- [ ] User ghc environment files instead of `cabal exec` to launch tests++- [ ] Use NamedFieldPuns / RecordWildCards for Options++- [ ] Check that an export does not need to be qualified
app/Main.hs view
@@ -1,13 +1,21 @@ module Main ( main ) where -import Data.Bool ( bool )-import Data.List ()-import Data.Maybe ( fromMaybe )+import GHC.Paths ( ghc )+import System.Environment ( getArgs )+import System.Exit ( exitWith )+import System.Process.Typed+ ( runProcess, setEnvInherit, setWorkingDirInherit, shell ) main :: IO () main = do- let foo = fromMaybe bool Nothing- print (foo undefined undefined undefined :: Int)- print True--- main = parseFile+ args <- getArgs+ runProcess+ ( setWorkingDirInherit . setEnvInherit $+ shell+ ( ghc+ ++ " -fplugin=Smuggler2.Plugin "+ ++ unwords args+ )+ )+ >>= exitWith
smuggler2.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: smuggler2-version: 0.3.2.2+version: 0.3.3.2 synopsis: GHC Source Plugin that helps to minimise imports and generate explicit exports @@ -49,7 +49,7 @@ source-repository head type: git- location: https://github.com/jrp2014/smuggler+ location: https://github.com/jrp2014/smuggler2 common common-options -- test these bounds@@ -95,16 +95,15 @@ import: common-options hs-source-dirs: src exposed-modules:- Smuggler2.Options Smuggler2.Anns+ Smuggler2.Exports+ Smuggler2.Imports+ Smuggler2.Options Smuggler2.Parser Smuggler2.Plugin - other-modules:- Paths_smuggler2-+ other-modules: Paths_smuggler2 autogen-modules: Paths_smuggler2- build-depends: , containers ^>=0.6.0 , directory ^>=1.3.3@@ -116,28 +115,27 @@ if flag(debug) build-depends: text --- Currently doesn't do anything much-executable play-smuggler2+executable ghc-smuggler2 import: common-options import: executable-options hs-source-dirs: app main-is: Main.hs-- if flag(debug)- ghc-options: -fplugin=Smuggler2.Plugin-- build-depends: smuggler2+ build-depends:+ , ghc-paths ^>=0.1.0+ , typed-process ^>=0.2.6 test-suite smuggler2-test import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test build-depends:+ , containers+ , directory , filepath , ghc-paths , smuggler2 , tasty- , tasty-golden+ , tasty-golden ^>=2.3.4 , typed-process main-is: Test.hs
src/Smuggler2/Anns.hs view
@@ -1,9 +1,8 @@-{-|- Description: Utility functions for transforming and manipulating 'ghc' AST elements- and their associated 'ghc-exactprint' 'Language.Haskell.GHC.ExactPrint.Anns'- -}+-- |+-- Description: Utility functions for transforming and manipulating+-- 'ghc-exactprint' 'Language.Haskell.GHC.ExactPrint.Anns' module Smuggler2.Anns- ( mkExportAnnT,+ ( mkLocWithAnns, mkLoc, mkParenT, setAnnsForT,@@ -11,98 +10,15 @@ ) where -import Avail (AvailInfo (..)) import Data.Generics as SYB (Data) import qualified Data.Map.Strict as Map (alter, fromList, insert, lookup, toList, union) import Data.Maybe (fromMaybe)-import GHC- ( AnnKeywordId (AnnCloseP, AnnDotdot, AnnOpenP, AnnVal),- GhcPs,- IE (..),- IEWrappedName (..),- LIEWrappedName,- Name,- RdrName,- )-import GhcPlugins (GenLocated (L), Located, getOccFS, getOccString, mkVarUnqual)-import Language.Haskell.GHC.ExactPrint- ( Annotation (annEntryDelta, annPriorComments, annsDP),- TransformT,- modifyAnnsT,- uniqueSrcSpanT,- )-import Language.Haskell.GHC.ExactPrint.Types- ( DeltaPos (..),- KeywordId (G),- annNone,- mkAnnKey,- noExt,- )-import Lexeme (isLexSym)---- Generates the annotations for a name, wrapping () around symbollic names-mkLIEName :: Monad m => Name -> TransformT m (LIEWrappedName RdrName)-mkLIEName name = do- let nameFS = getOccFS name- let ann =- if isLexSym nameFS -- infix type or data constructor / identifier- then [(G AnnOpenP, DP (0, 0)), (G AnnVal, DP (0, 0)), (G AnnCloseP, DP (0, 0))]- else [(G AnnVal, DP (0, 0))]- lname <-- mkLocWithAnns- (mkVarUnqual nameFS)- (DP (1, 2)) -- drop downn a line and indent 2 spaces- ann- mkLoc (IEName lname)---- | Uses 'AvailInfo' about an exportable thing to generate the corresponding--- piece of (annotated) AST-mkExportAnnT :: Monad m => AvailInfo -> TransformT m (Located (IE GhcPs))--- Ordinary identifier-mkExportAnnT (Avail name) = do- liename <- mkLIEName name- mkLoc (IEVar noExt liename)---- A type or class. Since we expect @name@ to be in scope, it should be the head--- of @names@-mkExportAnnT (AvailTC name names fieldlabels) = do- liename <- mkLIEName name-- -- Could export pieces explicitly, but this becomes ugly;- -- operators need to be wrapped in (), etc, so just export things- -- with pieces by wildcard- let lienameWithWildcard =- mkLocWithAnns- (IEThingAll noExt liename)- (DP (0, 0))- [(G AnnOpenP, DP (0, 0)), (G AnnDotdot, DP (0, 0)), (G AnnCloseP, DP (0, 0))]-- case (names, fieldlabels) of- -- This case implies that the type or class is not to be in scope- -- which should not happen as we should only be processing exportable things- -- Alternativey, could just: mkLoc (IEThingAbs noExt liename)- ([], _) ->- error $- "smuggler: trying to export type class that is not to be in scope "- ++ getOccString name- -- A type class with no pieces- ([_typeclass], []) -> mkLoc (IEThingAbs noExt liename)- -- A type class with no pieces, but with field selectors. A record type?- ([_typeclass], _fl) -> lienameWithWildcard- -- A type class with pieces- (typeorclass : _pieces, _fl) ->- if name == typeorclass -- check AvailTC invariant- then- lienameWithWildcard- else- error $- "smuggler: broken AvailTC invariant: "- ++ getOccString name- ++ "/="- ++ getOccString typeorclass-+import GHC (AnnKeywordId (AnnCloseP, AnnOpenP))+import GhcPlugins (GenLocated (L), Located)+import Language.Haskell.GHC.ExactPrint (Annotation (annEntryDelta, annPriorComments, annsDP),+ TransformT, modifyAnnsT, uniqueSrcSpanT)+import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (..), KeywordId (G), annNone, mkAnnKey) -------------------------------------------------------------------------------- -- Inspired by retrie -- | Generates a unique location and wraps the given ast chunk with that location
+ src/Smuggler2/Exports.hs view
@@ -0,0 +1,113 @@+-- |+-- Description: Utility functions for generating an export list ast and+-- associated Anns. It's a bit fiddlier than it could be because ghc's+-- functions for producing exportable things generates @AvailInfo@ from which we+-- need to reconstitue @IEWrappedName@ and then @IE@+module Smuggler2.Exports+ ( mkExportAnnT+ )+where++import Avail ( AvailInfo(..) )+import GHC+ ( AnnKeywordId(AnnCloseP, AnnVal, AnnType, AnnPattern, AnnDotdot,+ AnnOpenP),+ GhcPs,+ IE(IEThingAbs, IEVar, IEThingAll),+ IEWrappedName(IEName, IEType, IEPattern),+ LIEWrappedName,+ RdrName )+import GhcPlugins ( Located, mkVarUnqual )+import Language.Haskell.GHC.ExactPrint ( TransformT )+import Language.Haskell.GHC.ExactPrint.Types+ ( noExt, DeltaPos(DP), KeywordId(G) )+import Lexeme ( isLexSym )+import Name+ ( Name,+ OccName(occNameFS),+ getOccString,+ isDataOcc,+ isSymOcc,+ isTcOcc,+ HasOccName(occName) )+import Smuggler2.Anns ( mkLocWithAnns, mkLoc )++-- | Generates the annotations for a name, wrapping () around symbollic names+mkLIEName ::+ Monad m =>+ Name ->+ TransformT m (LIEWrappedName RdrName)+mkLIEName name+ | isTcOcc occ && isSymOcc occ = do+ lname <-+ mkLocWithAnns+ (mkVarUnqual nameFS)+ (DP (0, 0)) -- for a gap afer @type@+ ann+ mkLocWithAnns (IEType lname) (DP (1, 2)) [(G AnnType, DP (0, 0))]+ | isDataOcc occ = do+ lname <-+ mkLocWithAnns+ (mkVarUnqual nameFS)+ (DP (0, 1)) -- for a gap after @pattern@+ ann+ mkLocWithAnns (IEPattern lname) (DP (1, 2)) [(G AnnPattern, DP (0, 0))]+ | otherwise = do+ lname <-+ mkLocWithAnns+ (mkVarUnqual nameFS)+ (DP (0, 0))+ ann+ mkLocWithAnns (IEName lname) (DP (1, 2)) []+ where+ occ = occName name+ nameFS = occNameFS occ+ ann =+ if isLexSym nameFS -- infix type or data constructor / identifier, so add ()+ then [(G AnnOpenP, DP (0, 0)), (G AnnVal, DP (0, 0)), (G AnnCloseP, DP (0, 0))]+ else [(G AnnVal, DP (0, 0))]++-- | Uses an exportable thing to generate the corresponding+-- piece of (annotated) AST.+mkExportAnnT :: (Monad m) => AvailInfo -> TransformT m (Located (IE GhcPs))+-- Ordinary identifier+mkExportAnnT (Avail name) = do+ liename <- mkLIEName name+ mkLoc (IEVar noExt liename)++-- A type or class. Since we expect @name@ to be in scope, it should be the head+-- of @names@+mkExportAnnT (AvailTC name names fieldlabels) = do+ liename <- mkLIEName name++ -- Could export pieces explicitly, but this becomes ugly;+ -- operators need to be wrapped in (), etc, so just export things+ -- with pieces by wildcard+ let lienameWithWildcard =+ mkLocWithAnns+ (IEThingAll noExt liename)+ (DP (0, 0))+ [(G AnnOpenP, DP (0, 0)), (G AnnDotdot, DP (0, 0)), (G AnnCloseP, DP (0, 0))]++ case (names, fieldlabels) of+ -- This case implies that the type or class is not to be in scope+ -- which should not happen as we should only be processing exportable things+ -- Alternativey, could just: mkLoc (IEThingAbs noExt liename)+ ([], _) ->+ error $+ "smuggler: trying to export type class that is not to be in scope "+ ++ getOccString name+ -- A type class with no pieces+ ([_typeclass], []) -> mkLoc (IEThingAbs noExt liename)+ -- A type class with no pieces, but with field selectors. A record type?+ ([_typeclass], _fl) -> lienameWithWildcard+ -- A type class with pieces+ (typeorclass : _pieces, _fl) ->+ if name == typeorclass -- check AvailTC invariant+ then lienameWithWildcard+ else+ error $+ "smuggler: broken AvailTC invariant: "+ ++ getOccString name+ ++ "/="+ ++ getOccString typeorclass
+ src/Smuggler2/Imports.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+-- | Description: A replacement for 'RnNames.getMinimalImports' that attempts+-- to handle patterns and types, which is not done correctly in GHC 8.10.1 and+-- earlier.+module Smuggler2.Imports (getMinimalImports) where++import Avail ( AvailInfo(..) )+import BasicTypes ( StringLiteral(sl_fs) )+import FieldLabel ( FieldLbl(flIsOverloaded, flLabel, flSelector) )+import GHC+ ( GhcRn,+ IE(IEThingAbs, IEThingAll, IEThingWith, IEVar),+ IEWildcard(NoIEWildcard),+ IEWrappedName(IEName, IEPattern, IEType),+ ImportDecl(ImportDecl, ideclHiding, ideclName, ideclPkgQual,+ ideclSource),+ LIEWrappedName,+ LImportDecl )+import HscTypes -- earlier versions of Ghc don't have ModIface_+import LoadIface ( loadSrcInterface )+import Name ( HasOccName(..), isDataOcc, isSymOcc, isTcOcc )+import Outputable ( Outputable(ppr), text, (<+>) )+import RdrName ( gresToAvailInfo )+import RnNames ( ImportDeclUsage )+import SrcLoc ( GenLocated(L), Located, noLoc )+import TcRnMonad ( RnM )+import Language.Haskell.GHC.ExactPrint.Types ( noExt )++{-+Note [Partial export]+~~~~~~~~~~~~~~~~~~~~~+Suppose we have++ module A( op ) where+ class C a where+ op :: a -> a++ module B where+ import A+ f = ..op...++Then the minimal import for module B is+ import A( op )+not+ import A( C( op ) )+which we would usually generate if C was exported from B. Hence+the (x `elem` xs) test when deciding what to generate.+++Note [Overloaded field import]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On the other hand, if we have++ {-# LANGUAGE DuplicateRecordFields #-}+ module A where+ data T = MkT { foo :: Int }++ module B where+ import A+ f = ...foo...++then the minimal import for module B must be+ import A ( T(foo) )+because when DuplicateRecordFields is enabled, field selectors are+not in scope without their enclosing datatype.++-}++-- | Attempt to fix+-- <https://hackage.haskell.org/package/ghc/docs/RnNames.html#v:getMinimalImports>+getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]+getMinimalImports = mapM mk_minimal+ where+ mk_minimal (L l decl, used_gres, unused)+ | null unused+ , Just (False, _) <- ideclHiding decl+ = return (L l decl)+ | otherwise+ = do { let ImportDecl { ideclName = L _ mod_name+ , ideclSource = is_boot+ , ideclPkgQual = mb_pkg } = decl+ ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)+#if MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)+ -- TODO not sure when this was introduced+ ; let used_avails = gresToAvailInfo used_gres+ lies = map (L l) (concatMap (to_ie iface) used_avails)+#else+ -- used_gres are actually already AvailInfo in earlier versions of+ -- GHC+ ; let lies = map (L l) (concatMap (to_ie iface) used_gres)+#endif+ ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }+ where+ doc = text "Compute minimal imports for" <+> ppr decl++ to_ie :: ModIface -> AvailInfo -> [IE GhcRn]+ -- The main trick here is that if we're importing all the constructors+ -- we want to say "T(..)", but if we're importing only a subset we want+ -- to say "T(A,B,C)". So we have to find out what the module exports.+ to_ie _ (Avail n) -- An ordinary identifier (eg, var, data constructor)+ = [IEVar noExt (to_ie_post_rn_var $ noLoc n)]+ to_ie _ (AvailTC n [m] []) -- type or class with absent () list+ | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]+ to_ie iface (AvailTC n ns fs)+ = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface+ , x == n+ , x `elem` xs -- Note [Partial export]+ ] of+ -- class / type with methods / constructors+ [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn_var $ noLoc n)] -- (..)++ | isTcOcc (occName n) -> -- class+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+ (map (to_ie_post_rn_tc . noLoc) (filter (/= n) ns))+ (map noLoc fs)]+ -- Note [Overloaded field import]++ | otherwise -> -- type+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+ (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+ (map noLoc fs)]++ -- record type+ _other | all_non_overloaded fs+ -> map (IEVar noExt . to_ie_post_rn . noLoc) $ ns+ ++ map flSelector fs+ | otherwise -> -- DuplicateRecordFields is applicable+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+ (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+ (map noLoc fs)]+ where++ fld_lbls = map flLabel fs++ all_used (avail_occs, avail_flds)+ = all (`elem` ns) avail_occs+ && all ((`elem` fld_lbls) . flLabel) avail_flds++ all_non_overloaded = not . any flIsOverloaded+++-- An import is+-- a var+-- a tycon -> [ (..) | ( cname1 , … , cnamen )]+-- a tycls -> [(..) | ( var1 , … , varn )]++-- cname -> var | con+-- var -> varid | ( varsym ) -- (does not start with :)+-- con -> conid | ( consym ) -- (starts with :)++-- GHC User Guide 8.7.3+-- The name of the pattern synonym is in the same namespace as proper data constructors.+-- Like normal data constructors, pattern synonyms can be imported through associations+-- with a type constructor or independently.+-- To export them on their own, in an export or import specification,+-- you must prefix pattern names with the pattern keyword+--+-- GHC User Guide 9.9.5+--The form C(.., mi, .., type Tj, ..), where C is a class, names the class C, and the+--specified methods mi and associated types Tj. The types need a keyword “type” to distinguish+--them from data constructors.+--+--Whenever there is no export list and a data instance is defined, the corresponding+--data family type constructor is exported along with the new data constructors, regardless of+--whether the data family is defined locally or in another module.++to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn_var (L l n)+ | isDataOcc $ occName n = L l (IEPattern (L l n))+ | otherwise = L l (IEName (L l n))++to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn (L l n)+ | isTcOcc occ && isSymOcc occ = L l (IEType (L l n)) -- starts with :, ->, etc+ | otherwise = L l (IEName (L l n))+ where occ = occName n++to_ie_post_rn_tc :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn_tc (L l n)+ | isTcOcc occ = L l (IEType (L l n))+ | otherwise = L l (IEName (L l n))+ where occ = occName n
src/Smuggler2/Parser.hs view
@@ -33,15 +33,18 @@ -- Withoout the following, comments are stripped (see #10942) -- It would be more efficient, but less visible to apply this tweak at the -- outset, in the main plugin function, but keep it here for visibility+ -- See also https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations, which+ -- notes that the flags are returned as annotations by the+ -- @Opt_KeepRawTokenStream@ flag. let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream case parseModuleFromStringInternal dflags' fileName fileContents of Left msg -> liftIO $ do #if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)- fatalErrorMsg dflags (text "smuggler parse failure:")+ fatalErrorMsg dflags (text "smuggler2 parse failure:") printBagOfErrors dflags msg #else- fatalErrorMsg dflags (text $ "smuggler parse failure: " +++ fatalErrorMsg dflags (text $ "smuggler2 parse failure: " ++ showSDoc dflags (ppr $ fst msg) ++ ": " ++ snd msg) #endif return $ Left ()
src/Smuggler2/Plugin.hs view
@@ -1,72 +1,72 @@-{-|- Description: the core of 'smuggler2'- -} {-# LANGUAGE LambdaCase #-} +-- |+-- Description: the core of the 'Smuggler2.Plugin' module Smuggler2.Plugin ( plugin, ) where -import Avail (AvailInfo, Avails)-import Control.Monad (unless)-import Data.Maybe (fromMaybe, isNothing)-import Data.Version (showVersion)-import DynFlags (DynFlags (dumpDir), HasDynFlags (getDynFlags))-import ErrUtils (compilationProgressMsg, fatalErrorMsg)+import Avail ( AvailInfo, Avails )+import Control.Monad ( unless )+import Data.Maybe ( fromMaybe, isNothing )+import Data.Version ( showVersion )+import DynFlags ( DynFlags(dumpDir), HasDynFlags(getDynFlags) )+import ErrUtils ( compilationProgressMsg, fatalErrorMsg ) import GHC- ( GenLocated (L),- GhcPs,- HsModule (hsmodExports, hsmodImports),- ImportDecl (ideclHiding, ideclImplicit),- LIE,- LImportDecl,- Located,- ModSummary (ms_hspp_buf, ms_hspp_file, ms_mod),- Module (moduleName),- ParsedSource,- moduleNameString,- unLoc,- )-import GHC.IO.Encoding (setLocaleEncoding, utf8)-import IOEnv (MonadIO (liftIO), readMutVar)+ ( GenLocated(L),+ GhcPs,+ HsModule(hsmodExports, hsmodImports),+ ImportDecl(ideclHiding, ideclImplicit),+ LIE,+ LImportDecl,+ Located,+ ModSummary(ms_hspp_buf, ms_hspp_file, ms_mod),+ Module(moduleName),+ ParsedSource,+ moduleNameString,+ unLoc )+import GHC.IO.Encoding ( setLocaleEncoding, utf8 )+import IOEnv ( MonadIO(liftIO), readMutVar ) import Language.Haskell.GHC.ExactPrint- ( Anns,- TransformT,- addTrailingCommaT,- exactPrint,- graftT,- runTransform,- setEntryDPT,- )-import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP))-import Outputable (Outputable (ppr), neverQualify, printForUser, text, vcat)-import Paths_smuggler2 (version)+ ( Anns,+ TransformT,+ addTrailingCommaT,+ exactPrint,+ graftT,+ runTransform,+ setEntryDPT )+import Language.Haskell.GHC.ExactPrint.Types ( DeltaPos(DP) )+import Outputable+ ( Outputable(ppr), neverQualify, printForUser, text, vcat )+import Paths_smuggler2 ( version ) import Plugins- ( CommandLineOption,- Plugin (pluginRecompile, typeCheckResultAction),- defaultPlugin,- purePlugin,- )-import RnNames (ImportDeclUsage, findImportUsage, getMinimalImports)-import Smuggler2.Anns (mkExportAnnT, mkLoc, mkParenT)+ ( CommandLineOption,+ Plugin(pluginRecompile, typeCheckResultAction),+ defaultPlugin,+ purePlugin )+import RnNames+ ( ImportDeclUsage, findImportUsage )+import Smuggler2.Anns+import Smuggler2.Imports+import Smuggler2.Exports import Smuggler2.Options- ( ExportAction (AddExplicitExports, NoExportProcessing, ReplaceExports),- ImportAction (MinimiseImports, NoImportProcessing),- Options (exportAction, importAction, newExtension),- parseCommandLineOptions,- )-import Smuggler2.Parser (runParser)-import StringBuffer (StringBuffer (StringBuffer), lexemeToString)-import System.Directory (removeFile)-import System.FilePath ((-<.>), (</>))-import System.IO (IOMode (WriteMode), withFile)-import TcRnExports (exports_from_avail)+ ( ExportAction(AddExplicitExports, NoExportProcessing,+ ReplaceExports),+ ImportAction(MinimiseImports, NoImportProcessing),+ Options(exportAction, importAction, newExtension),+ parseCommandLineOptions )+import Smuggler2.Parser ( runParser )+import StringBuffer ( StringBuffer(StringBuffer), lexemeToString )+import System.Directory ( removeFile )+import System.FilePath ( (-<.>), (</>) )+import System.IO ( IOMode(WriteMode), withFile )+import TcRnExports ( exports_from_avail ) import TcRnTypes- ( RnM,- TcGblEnv (tcg_exports, tcg_imports, tcg_mod, tcg_rdr_env, tcg_rn_exports, tcg_rn_imports, tcg_used_gres),- TcM,- )+ ( TcGblEnv(tcg_rdr_env, tcg_imports, tcg_mod, tcg_exports,+ tcg_rn_imports, tcg_used_gres, tcg_rn_exports),+ TcM,+ RnM ) -- | 'Plugin' interface to GHC plugin :: Plugin@@ -91,11 +91,11 @@ -- This ensures that the source file is not touched if there are no unused -- imports, or exports already exist and we are not replacing them- let noUnusedImports = all (\(_decl, _used, unused) -> null unused) usage+ let noUnusedImports = all (\(_decl, used, unused) -> not (null used) && null unused) usage let hasExplicitExports = case tcg_rn_exports tcEnv of- Nothing -> False -- There is not even a module header+ Nothing -> False -- There is not even a module header (Just []) -> False- (Just _) -> True+ (Just _) -> True -- ... so short circuit if: -- - we are skipping import processing or there are no unused imports, and -- - we are skipping export processing or there are explict exports and we are not replacing them@@ -108,13 +108,16 @@ then return tcEnv else do dflags <- getDynFlags- liftIO $ compilationProgressMsg dflags ("smuggler: " ++ showVersion version)+ liftIO $ compilationProgressMsg dflags ("smuggler2 " ++ showVersion version) -- Dump GHC's view of what the minimal imports are for the current -- module, so that they can be annotated when parsed back in- -- This is needed because 'getMinimalImports` returns a list of import- -- declarations that are `GhcRn` but `ghc-exactPrint` operates in- -- `GhcPs`+ -- This is needed because there too much information loss between+ -- the parsed and renamed AST to use the latter for reconstituting the+ -- source. An alternative would be to "index" each name location with+ -- a SrcSpan to allow the name matchup, and to make the 'ParsedSource' a+ -- 100% representation of the original source (modulo tabs, trailing+ -- whitespace per line). let minImpFilePath = mkMinimalImportsPath dflags (ms_mod modSummary) printMinimalImports' dflags minImpFilePath usage @@ -135,7 +138,7 @@ -- Get the pre-processed module source code let modFileContents = case ms_hspp_buf modSummary of -- Not clear under what circumstances this could happen- Nothing -> error $ "smuggler: missing source file: " ++ modulePath+ Nothing -> error $ "smuggler: missing source file: " ++ modulePath Just contents -> strBufToStr contents -- Parse the whole module@@ -170,7 +173,7 @@ -- Print the result let newContent = exactPrint astHsMod' annsHsMod' liftIO $ case newExtension options of- Nothing -> writeFile modulePath newContent+ Nothing -> writeFile modulePath newContent Just ext -> writeFile (modulePath -<.> ext) newContent -- Clean up: delete the GHC-generated imports file@@ -223,8 +226,8 @@ case exportAction options of NoExportProcessing -> return t AddExplicitExports ->- -- only add explicit exports if there are none- -- seems to work even if there is no explict module declaration+ -- Only add explicit exports if there are none.+ -- Seems to work even if there is no explict module declaration -- presumably because the annotations that we generate are just -- unused by exactPrint if isNothing currentExplicitExports then result else return t@@ -239,7 +242,7 @@ | null exports = return t -- there is nothing exportable | otherwise = do -- Generate the exports list- exportsList <- mapM mkExportAnnT exports+ exportsList <- mapM mkExportAnnT exports -- add commas in between and parens around mapM_ addTrailingCommaT (init exportsList) lExportsList <- mkLoc exportsList >>= mkParenT unLoc@@ -254,7 +257,7 @@ printMinimalImports' :: DynFlags -> FilePath -> [ImportDeclUsage] -> RnM () printMinimalImports' dflags filename imports_w_usage = do- imports' <- getMinimalImports imports_w_usage+ imports' <- Smuggler2.Imports.getMinimalImports imports_w_usage liftIO $ withFile filename@@ -274,7 +277,7 @@ notInstancesOnly :: ImportDecl pass -> Bool notInstancesOnly i = case ideclHiding i of Just (False, L _ []) -> False- _ -> True+ _ -> True keepInstanceOnlyImports :: Bool keepInstanceOnlyImports = importAction options /= MinimiseImports@@ -289,8 +292,8 @@ | otherwise = basefn where basefn =- "smuggler-" ++ moduleNameString (moduleName this_mod) ++ "."- ++ fromMaybe "smuggler" (newExtension options)+ "smuggler2-" ++ moduleNameString (moduleName this_mod) ++ "."+ ++ fromMaybe "smuggler2" (newExtension options) ++ ".imports" options :: Options
test/Test.hs view
@@ -2,11 +2,15 @@ module Main where +import Control.Monad (forM)+import Data.List (sort) import Data.Maybe (fromMaybe)+import qualified Data.Set as Set (fromList, member) import GHC.Paths (ghc) import Smuggler2.Options (ExportAction (..), ImportAction (..), Options (..))+import System.Directory (doesDirectoryExist, getDirectoryContents) import System.Environment (lookupEnv)-import System.FilePath ((-<.>), (</>), takeBaseName)+import System.FilePath ((-<.>), (</>), takeBaseName, takeExtension) import System.Process.Typed ( ProcessConfig, proc,@@ -15,7 +19,7 @@ setWorkingDirInherit, ) import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.Golden (findByExtension, goldenVsFileDiff, writeBinaryFile)+import Test.Tasty.Golden (goldenVsFileDiff, writeBinaryFile) -- | Where the tests are, relative to the project level cabal file testDir :: FilePath@@ -49,7 +53,7 @@ -- imports and exports) goldenTests :: Options -> IO TestTree goldenTests opts = do- testFiles <- findByExtension [".hs"] testDir+ testFiles <- findByExtension' [".hs"] testDir return $ testGroup testName@@ -64,12 +68,43 @@ writeBinaryFile outputFilename "Source file was not touched\r\n" compile testFile opts )- | testFile <- testFiles,+ | testFile <- sort testFiles, let outputFilename = testFile -<.> testName ] where testName = fromMaybe "NoNewExtension" (newExtension opts) +-- | A version of 'Test.Tasty.Golden.findByExtension' that does not look into+-- subdirectories. This allows tests to be run on a module that imports other+-- modules without risking the race condition where smuggler is being run+-- on the imported module directly, and also when the importing module is being+-- tested. ('Tasty' runs test in parallel and the same output files are+-- produced in both direct and imported cases.) Putting the imported module in+-- a subdirectory and not testing it direcly avoids this race condition.+findByExtension' ::+ -- | extensions+ [FilePath] ->+ -- | directory+ FilePath ->+ -- | paths+ IO [FilePath]+findByExtension' extsList = go+ where+ exts = Set.fromList extsList+ go :: FilePath -> IO [FilePath]+ go dir = do+ allEntries <- getDirectoryContents dir+ let entries = filter (not . (`elem` [".", ".."])) allEntries+ fmap concat $ forM entries $ \e -> do+ let path = dir ++ "/" ++ e+ isDir <-+ doesDirectoryExist+ path+ return $+ if isDir+ then [] -- don't recurse+ else [path | takeExtension path `Set.member` exts]+ -- | Just run all the tests main :: IO () main = defaultMain =<< testOptions optionsList@@ -82,14 +117,16 @@ let cabalCmd = words $ fromMaybe "cabal" cabalPath -- default to @cabal@ if @CABAL@ is not set let cabalConfig = setWorkingDirInherit . setEnvInherit $- proc (head cabalCmd) (tail cabalCmd ++ cabalArgs) :: ProcessConfig () () ()+ proc+ (head cabalCmd)+ (tail cabalCmd ++ cabalArgs) :: ProcessConfig () () () runProcess_ cabalConfig where cabalArgs :: [String] cabalArgs = -- - not sure why it is necessary to mention the smuggler2 package explicitly, -- but it appears to be hidden otherwise.- -- - This puts the .imports files that smuggler generates somewhere they+ -- - This also puts the .imports files that smuggler generates somewhere they -- can easily be found [ "--with-compiler=" ++ ghc, "exec",@@ -99,15 +136,14 @@ "-v0", "-dumpdir=" ++ testDir, "-fno-code",+ "-i" ++ testDir, "-fplugin=Smuggler2.Plugin" ] ++ map ("-fplugin-opt=Smuggler2.Plugin:" ++) ( let ia = importAction opts ea = exportAction opts- p = [show ia, show ea]- in case newExtension opts of- Nothing -> mkExt ia ea : p -- provide a default extension- Just e -> e : p+ -- the extension should have been set by 'optionsList'+ in (fromMaybe "missng" (newExtension opts) : [show ia, show ea]) ) ++ [testcase]
+ test/tests/ExportPattern2.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module ExportPattern2 where++import Control.Monad (guard)+import qualified Data.Sequence as Seq++pattern P = 42++--useP P = 43++--++data Type = App String [Type]++pattern Arrow :: Type -> Type -> Type+pattern Arrow t1 t2 = App "->" [t1, t2]++pattern Int = App "Int" []++pattern Maybe t = App "Maybe" [t]+++{-+collectArgs :: Type -> [Type]+collectArgs (Arrow t1 t2) = t1 : collectArgs t2+collectArgs _ = []++isInt :: Type -> Bool+isInt Int = True+isInt _ = False++isIntEndo :: Type -> Bool+isIntEndo (Arrow Int Int) = True+isIntEndo _ = False++arrows :: [Type] -> Type -> Type+arrows = flip $ foldr Arrow+-}++--+++pattern Empty <- (Seq.viewl -> Seq.EmptyL)+pattern x :< xs <- (Seq.viewl -> x Seq.:< xs)+pattern xs :> x <- (Seq.viewr -> xs Seq.:> x)++{-+viewPL (x :< Empty) = x+viewPR (Empty :> y) = y+-}++--+++pattern Succ n <-+ (\x -> (x -1) <$ guard (x > 0) -> Just n)+ where+ Succ n = n + 1++{-+fac (Succ n) = Succ n * fac n+fac 0 = 1+-}++--+++data Showable where+ MkShowable :: (Show a) => a -> Showable++-- Required context is empty, but provided context is not+pattern Sh :: () => (Show a) => a -> Showable+pattern Sh x <- MkShowable x++{-+showable :: (Show a) => a -> Showable+showable x = MkShowable x+-}++--+++-- Provided context is empty+pattern One :: (Num a, Eq a) => a+pattern One <- 1+++-- one One = 2++--+++pattern Pair x y <- [x, y]++++{-+f (Pair True True) = True+f _ = False++g [True, True] = True+g _ = False+-}++++--++data Nat = Z | S Nat deriving (Show)++pattern Ess p = S p+++--two = S ( S Z)++--++pattern Single x = [x]++pattern Head x <- x : xs++{- single (Single x) = x+hd :: [a] -> a+hd (Head x) = x+-}++--+++data T a where+ MkT :: (Show b) => a -> b -> T a++pattern ExNumPat x = MkT 42 x++{-+h :: (Num t, Eq t) => T t -> String+h (ExNumPat x) = show x+-}
+ test/tests/ImportPattern.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module ImportPattern where++import Control.Monad (guard)+import qualified Data.Sequence as Seq++import Imported.ExportPattern++-- pattern P = 42++useP P = 43++--++{-+data Type = App String [Type]++pattern Arrow :: Type -> Type -> Type+pattern Arrow t1 t2 = App "->" [t1, t2]++pattern Int = App "Int" []++pattern Maybe t = App "Maybe" [t]++-}++collectArgs :: Type -> [Type]+collectArgs (Arrow t1 t2) = t1 : collectArgs t2+collectArgs _ = []++isInt :: Type -> Bool+isInt Int = True+isInt _ = False++isIntEndo :: Type -> Bool+isIntEndo (Arrow Int Int) = True+isIntEndo _ = False++arrows :: [Type] -> Type -> Type+arrows = flip $ foldr Arrow++--+{-++pattern Empty <- (Seq.viewl -> Seq.EmptyL)+pattern x :< xs <- (Seq.viewl -> x Seq.:< xs)+pattern xs :> x <- (Seq.viewr -> xs Seq.:> x)+-}++viewPL (x :< Empty) = x+viewPR (Empty :> y) = y++--++{-+pattern Succ n <-+ (\x -> (x -1) <$ guard (x > 0) -> Just n)+ where+ Succ n = n + 1+-}++fac (Succ n) = Succ n * fac n+fac 0 = 1++--++{-+data Showable where+ MkShowable :: (Show a) => a -> Showable++-- Required context is empty, but provided context is not+pattern Sh :: () => (Show a) => a -> Showable+pattern Sh x <- MkShowable x+-}++showable :: (Show a) => a -> Showable+showable x = MkShowable x++--++{-+-- Provided context is empty+pattern One :: (Num a, Eq a) => a+pattern One <- 1+-}++one One = 2++--+++--pattern Pair x y <- [x, y]+++f (Pair True True) = True+f _ = False++g [True, True] = True+g _ = False+++--+{-+data Nat = Z | S Nat deriving (Show)++pattern Ess p = S p+-}++two = S ( S Z)++--++-- pattern Single x = [x]++-- pattern Head x <- x : xs++single (Single x) = x+hd :: [a] -> a+hd (Head x) = x++--++{-+data T a where+ MkT :: (Show b) => a -> b -> T a++pattern ExNumPat x = MkT 42 x+-}++h :: (Num t, Eq t) => T t -> String+h (ExNumPat x) = show x
+ test/tests/Pattern.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE PatternSynonyms #-}+module Pattern where++import qualified Data.List.NonEmpty as List1+import Data.List.NonEmpty (NonEmpty, pattern (:|), (<|))+++test = List1.cycle (1 :| [2,3]) ++test2 = 1 :| [2,3,1,2,3]
+ test/tests/TypeFam.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- http://www.mchaver.com/posts/2017-06-21-type-families.html++module TypeFam where++import qualified Data.ByteString.Char8 as BS+import Data.ByteString (ByteString)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text (Text)++import Imported.TypeFam+++result :: ConcatTy Text String+result = cat ("Hello" :: Text) (" World!" :: String)++main = print result++class Container c where+ type Elem c+ empty :: c+ insert :: Elem c -> c -> c+ member :: Elem c -> c -> Bool+ toList :: c -> [Elem c]++instance Eq e => Container [e] where+ type Elem [e] = e+ empty = []+ insert e l = (e:l)+ member e [] = False+ member e (x:xs)+ | e == x = True+ | otherwise = member e xs+ toList l = l++instance Eq e => Container (Maybe e) where+ type Elem (Maybe e) = e -- type synonym+ empty = Nothing+ insert e l = Just e -- destructive, replaces previous element+ member e Nothing = False+ member e (Just x) = e == x+ toList Nothing = []+ toList (Just x) = [x]