diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/smuggler2.cabal b/smuggler2.cabal --- a/smuggler2.cabal +++ b/smuggler2.cabal @@ -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 diff --git a/src/Smuggler2/Anns.hs b/src/Smuggler2/Anns.hs --- a/src/Smuggler2/Anns.hs +++ b/src/Smuggler2/Anns.hs @@ -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 diff --git a/src/Smuggler2/Exports.hs b/src/Smuggler2/Exports.hs new file mode 100644 --- /dev/null +++ b/src/Smuggler2/Exports.hs @@ -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 diff --git a/src/Smuggler2/Imports.hs b/src/Smuggler2/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Smuggler2/Imports.hs @@ -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 +-- +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 diff --git a/src/Smuggler2/Parser.hs b/src/Smuggler2/Parser.hs --- a/src/Smuggler2/Parser.hs +++ b/src/Smuggler2/Parser.hs @@ -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 () diff --git a/src/Smuggler2/Plugin.hs b/src/Smuggler2/Plugin.hs --- a/src/Smuggler2/Plugin.hs +++ b/src/Smuggler2/Plugin.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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] diff --git a/test/tests/ExportPattern2.hs b/test/tests/ExportPattern2.hs new file mode 100644 --- /dev/null +++ b/test/tests/ExportPattern2.hs @@ -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 +-} diff --git a/test/tests/ImportPattern.hs b/test/tests/ImportPattern.hs new file mode 100644 --- /dev/null +++ b/test/tests/ImportPattern.hs @@ -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 diff --git a/test/tests/Pattern.hs b/test/tests/Pattern.hs new file mode 100644 --- /dev/null +++ b/test/tests/Pattern.hs @@ -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] diff --git a/test/tests/TypeFam.hs b/test/tests/TypeFam.hs new file mode 100644 --- /dev/null +++ b/test/tests/TypeFam.hs @@ -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]