├── test ├── priority │ ├── Char.hs │ ├── M │ │ └── Char.hs │ ├── Main.hs │ └── expected ├── simple │ ├── A │ │ └── Used.hs │ ├── Main.hs │ └── expected ├── include │ ├── include │ │ ├── A.hs │ │ └── Sub │ │ │ └── B.hs │ ├── flags │ ├── Main.hs │ └── expected ├── unqualified-import │ ├── B.hs │ ├── LTrack.hs │ ├── Unqual.hs │ ├── A │ │ └── Track.hs │ ├── Main.hs │ └── expected ├── two-dots │ ├── Main.hs │ ├── A │ │ └── B │ │ │ └── C.hs │ └── expected ├── format │ ├── Some │ │ └── Long │ │ │ └── Module │ │ │ └── Name │ │ │ └── Module.hs │ ├── Main.hs │ └── expected ├── error │ ├── Main.hs │ └── expected ├── nondecreasing-indent │ ├── Main.hs │ └── expected ├── cpp │ ├── Main.hs │ └── expected ├── prelude-add │ ├── Main.hs │ └── expected ├── prelude-remove │ ├── Main.hs │ └── expected ├── comments │ ├── expected │ └── Main.hs └── run ├── Setup.hs ├── src ├── RunTests.hs ├── .fix-imports └── FixImports │ ├── PkgCache.hs │ ├── Config_test.hs │ ├── Format_test.hs │ ├── Format.hs │ ├── Types.hs │ ├── Parse_test.hs │ ├── Util.hs │ ├── Main.hs │ ├── Index.hs │ ├── FixImports_test.hs │ ├── Parse.hs │ ├── Config.hs │ └── FixImports.hs ├── .gitignore ├── cabal.project ├── LICENSE ├── vimrc ├── README.md ├── .travis.yml ├── dot-fix-imports ├── changelog.md ├── TODO └── fix-imports.cabal /test/priority/Char.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/priority/M/Char.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/simple/A/Used.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/include/include/A.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/unqualified-import/B.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/include/flags: -------------------------------------------------------------------------------- 1 | -iinclude 2 | -------------------------------------------------------------------------------- /test/include/include/Sub/B.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/unqualified-import/LTrack.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/unqualified-import/Unqual.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/two-dots/Main.hs: -------------------------------------------------------------------------------- 1 | x = B.C.f 2 | -------------------------------------------------------------------------------- /test/unqualified-import/A/Track.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/format/Some/Long/Module/Name/Module.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/error/Main.hs: -------------------------------------------------------------------------------- 1 | x = a * b + c 2 | f = a + q# 3 | -------------------------------------------------------------------------------- /test/format/Main.hs: -------------------------------------------------------------------------------- 1 | f = Long.Module.Name.Module.q 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/two-dots/A/B/C.hs: -------------------------------------------------------------------------------- 1 | module A.B.C where 2 | 3 | f = 10 4 | -------------------------------------------------------------------------------- /src/RunTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF test-karya-generate #-} 2 | -------------------------------------------------------------------------------- /test/include/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | f = A.Z + B.Z 4 | -------------------------------------------------------------------------------- /test/two-dots/expected: -------------------------------------------------------------------------------- 1 | import qualified A.B.C as B.C 2 | x = B.C.f 3 | -------------------------------------------------------------------------------- /test/nondecreasing-indent/Main.hs: -------------------------------------------------------------------------------- 1 | x = do 2 | if True then return () else do 3 | return () 4 | -------------------------------------------------------------------------------- /test/nondecreasing-indent/expected: -------------------------------------------------------------------------------- 1 | x = do 2 | if True then return () else do 3 | return () 4 | -------------------------------------------------------------------------------- /test/simple/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified B.Unused as Unused 2 | 3 | f :: Used.A -> Used.B 4 | f x = x * 2 5 | -------------------------------------------------------------------------------- /test/cpp/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CPP where 3 | 4 | #ifdef DEFINE 5 | f x = x * 2 6 | #endif 7 | -------------------------------------------------------------------------------- /test/cpp/expected: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CPP where 3 | 4 | #ifdef DEFINE 5 | f x = x * 2 6 | #endif 7 | -------------------------------------------------------------------------------- /test/error/expected: -------------------------------------------------------------------------------- 1 | error: Main.hs:3:1: Parse error in expression: a + q # 2 | x = a * b + c 3 | f = a + q# 4 | -------------------------------------------------------------------------------- /test/prelude-add/Main.hs: -------------------------------------------------------------------------------- 1 | -- Don't add Prelude import, because it's already implicitly imported. 2 | x = Prelude.x 3 | -------------------------------------------------------------------------------- /test/prelude-add/expected: -------------------------------------------------------------------------------- 1 | -- Don't add Prelude import, because it's already implicitly imported. 2 | x = Prelude.x 3 | -------------------------------------------------------------------------------- /test/include/expected: -------------------------------------------------------------------------------- 1 | module Main where 2 | import qualified A 3 | import qualified Sub.B as B 4 | 5 | f = A.Z + B.Z 6 | -------------------------------------------------------------------------------- /test/format/expected: -------------------------------------------------------------------------------- 1 | import qualified Some.Long.Module.Name.Module as Long.Module.Name.Module 2 | f = Long.Module.Name.Module.q 3 | -------------------------------------------------------------------------------- /test/simple/expected: -------------------------------------------------------------------------------- 1 | added: A.Used; removed: B.Unused 2 | import qualified A.Used as Used 3 | 4 | f :: Used.A -> Used.B 5 | f x = x * 2 6 | -------------------------------------------------------------------------------- /test/prelude-remove/Main.hs: -------------------------------------------------------------------------------- 1 | -- Don't remove the Prelude import, because that turns on implicit import. 2 | import qualified Prelude 3 | x = 10 4 | -------------------------------------------------------------------------------- /test/prelude-remove/expected: -------------------------------------------------------------------------------- 1 | -- Don't remove the Prelude import, because that turns on implicit import. 2 | import qualified Prelude 3 | x = 10 4 | -------------------------------------------------------------------------------- /test/unqualified-import/Main.hs: -------------------------------------------------------------------------------- 1 | import A.Track as Track 2 | import Unqual -- should keep this 3 | import qualified B 4 | 5 | x = Track.y + B.y 6 | -------------------------------------------------------------------------------- /test/unqualified-import/expected: -------------------------------------------------------------------------------- 1 | import A.Track as Track 2 | import qualified B 3 | import Unqual -- should keep this 4 | 5 | x = Track.y + B.y 6 | -------------------------------------------------------------------------------- /src/.fix-imports: -------------------------------------------------------------------------------- 1 | unqualified: Data.Text (Text); Data.Bifunctor (bimap, first, second) 2 | prio-module-high: EL.Debug 3 | sort-unqualified-last: t 4 | 5 | format: 6 | leave-space-for-qualified 7 | columns=80 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | /dist/ 3 | /dist-newstyle/ 4 | /cabal-dev/ 5 | *.o 6 | *.hi 7 | .hsenv 8 | .cabal-sandbox/ 9 | cabal.sandbox.config 10 | cabal.config 11 | /.ghc.environment.* 12 | /cabal.project.local 13 | *~ 14 | *.swp 15 | -------------------------------------------------------------------------------- /test/priority/Main.hs: -------------------------------------------------------------------------------- 1 | -- | Should import Data.Text and not GHC.Something.Something 2 | -- Should chose local Char over M.Char and Data.Char. 3 | -- Should choose System.IO over System.Posix.IO 4 | module Main where 5 | 6 | x = Text.pack Char.toUpper IO.putStrLn 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./*.cabal 3 | -- /Users/elaforge/src/el-debug/*.cabal 4 | 5 | constraints: 6 | -- Force it to use ghc-lib-parser instead of the ghc library. 7 | -- Otherwise I get a mismatch between the Extension type from 8 | -- two different place. 9 | ghc-lib-parser-ex -no-ghc-lib -auto 10 | 11 | write-ghc-environment-files: always 12 | -------------------------------------------------------------------------------- /test/comments/expected: -------------------------------------------------------------------------------- 1 | {-# LAGUAGE SomeExtension #-} -- comment on LANGUAGE 2 | -- | Module haddock. 3 | import qualified Control.Monad as Biz {- block cmt for Biz -} 4 | import qualified Data.List as C 5 | -- cmt1 for Data.Map 6 | -- cmt2 for Data.Map 7 | import qualified Data.Map -- cmt right for Data.Map 8 | import Data.Map (a, b) 9 | 10 | f = C.a + Data.Map.b + Biz.c 11 | -------------------------------------------------------------------------------- /test/priority/expected: -------------------------------------------------------------------------------- 1 | -- | Should import Data.Text and not GHC.Something.Something 2 | -- Should chose local Char over M.Char and Data.Char. 3 | -- Should choose System.IO over System.Posix.IO 4 | module Main where 5 | import qualified Data.Text as Text 6 | import qualified System.IO as IO 7 | 8 | import qualified Char 9 | 10 | x = Text.pack Char.toUpper IO.putStrLn 11 | -------------------------------------------------------------------------------- /test/comments/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LAGUAGE SomeExtension #-} -- comment on LANGUAGE 2 | -- | Module haddock. 3 | import qualified Data.List as C 4 | -- cmt1 for Data.Map 5 | -- cmt2 for Data.Map 6 | import qualified Data.Map -- cmt right for Data.Map 7 | import qualified Control.Monad as Biz {- block cmt for Biz -} 8 | import Data.Map (a, 9 | b) 10 | 11 | f = C.a + Data.Map.b + Biz.c 12 | -------------------------------------------------------------------------------- /test/run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env zsh 2 | 3 | setopt extended_glob 4 | 5 | cd $(dirname $0) 6 | 7 | # New cabal apparently can't be run in a subdir, but gives a confusing error. 8 | root=$(cd .. && pwd) 9 | 10 | # bin=../../dist/build/fix-imports/fix-imports 11 | # bin=(cabal run --builddir=$root fix-imports --) 12 | bin=../../dist-newstyle/build/x86_64-osx/ghc-8.8.3/fix-imports-2.3.0/x/fix-imports/build/fix-imports/fix-imports 13 | 14 | tests=($@) 15 | if [[ -z $tests ]]; then 16 | tests=($(echo *(/))) 17 | fi 18 | 19 | tmp=$(mktemp -t fix-imports) 20 | 21 | function test() { 22 | pushd $1 23 | local flags= 24 | if [[ -r flags ]]; then 25 | flags=$(cat flags) 26 | fi 27 | echo $bin ${=flags} 28 | $bin ${=flags} Main.hs & $tmp 29 | diff $tmp expected 30 | local failed=$? 31 | if [[ $failed != 0 ]]; then 32 | echo '==== expected:' 33 | cat expected 34 | echo '==== got:' 35 | cat $tmp 36 | fi 37 | popd 38 | return $failed 39 | } 40 | 41 | failed=0 42 | for test in $tests; do 43 | if ! test $test; then 44 | echo $test FAILED 45 | failed=1 46 | else 47 | echo $test passed 48 | fi 49 | echo 50 | done 51 | 52 | rm -f $tmp 53 | exit $failed 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Laforge 2011 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Laforge nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /vimrc: -------------------------------------------------------------------------------- 1 | " Example vimrc file to bind a key to fix-imports. 2 | 3 | nm ,a :call FixImports() 4 | 5 | " Parse --edit output and splice in the imports. 6 | function s:ReplaceImports(lines) 7 | let [start, end] = split(a:lines[0], ',') 8 | " +0 or vim does string comparison. 9 | if end+0 > start+0 10 | " This stupidity is necessary because vim apparently has no way to 11 | " delete lines. 12 | let old_line = line('.') 13 | let old_col = col('.') 14 | let old_total = line('$') 15 | silent execute (start+1) . ',' . end . 'delete _' 16 | let new_total = line('$') 17 | " Try to retain the cursor position. 18 | " If <0, then I'm inside the import block and I can just keep the line. 19 | " Otherwise, I have to move down for added lines or up for removed. 20 | let dest_line = old_line + (new_total - old_total) 21 | if dest_line >= 0 22 | call cursor(dest_line, old_col) 23 | call append(start, a:lines[1:]) 24 | else 25 | call append(start, a:lines[1:]) 26 | call cursor(old_line, old_col) 27 | endif 28 | else 29 | " This means no existing import block, just add it. 30 | call append(start, a:lines[1:]) 31 | endif 32 | endfunction 33 | 34 | 35 | " Run the contents of the current buffer through the fix-imports cmd. Print 36 | " any stderr output on the status line. 37 | function FixImports() 38 | let l:err = tempname() 39 | let l:cmd = 'fix-imports -v --edit ' . expand('%') . ' 2>' . l:err 40 | let l:out = systemlist(l:cmd, bufnr('%')) 41 | 42 | let errs = readfile(l:err) 43 | call delete(l:err) 44 | if v:shell_error == 0 45 | call s:ReplaceImports(l:out) 46 | endif 47 | redraw! 48 | if !empty(errs) 49 | echohl WarningMsg 50 | echo join(errs) 51 | echohl None 52 | endif 53 | endfunction 54 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | `fix-imports` is a small standalone program to manage the import block of a 2 | haskell program. It will try to add import lines for qualified names 3 | with no corresponding import, remove unused import lines, and keep the 4 | import block sorted, with optional rules for grouping. 5 | 6 | Support for unqualified imports is limited to symbols you explicitly configure, 7 | so if you list `System.FilePath (())`, it will add that import when you use 8 | it, or remove when it's no longer used, but it won't go search modules for 9 | unqualified imports. 10 | 11 | It doesn't mess with non-managed unqualified imports, so you can still use 12 | unqualified imports, you just have to do it manually. 13 | 14 | Since it's a unix-style filter, it should be possible to integrate into any 15 | editor. There's an example vimrc to bind to a key in vim. 16 | 17 | ### Usage: 18 | 19 | Normally you would integrate it with your editor (see `vimrc` for a vim 20 | example), but for testing, here's an example invocation: 21 | 22 | fix-imports -i src -i test src/A/B/C.hs )) 11 | import qualified Data.Set as Set 12 | 13 | import qualified Distribution.InstalledPackageInfo as IPI 14 | import qualified Distribution.ModuleName as ModuleName 15 | import qualified Distribution.Types.PackageId as PackageId 16 | import qualified Distribution.Types.PackageName as PackageName 17 | import qualified Distribution.Types.UnitId as UnitId 18 | import qualified GHC.Unit.Database as Database 19 | 20 | 21 | -- t_pkgs = Set.fromList . map fst <$> loadCache cache 22 | -- t_load = load (Set.fromList ["base-4.16.4.0"]) 23 | -- [cache, global] 24 | -- cache = "/Users/elaforge/.cabal/store/ghc-9.2.5/package.db" 25 | -- global = "/Users/elaforge/.ghcup/ghc/9.2.5/lib/ghc-9.2.5/lib/package.conf.d" 26 | 27 | type UnitId = Text 28 | type PkgName = Text 29 | type ModuleName = String 30 | 31 | load :: Set UnitId -> [FilePath] -> IO [(PkgName, [ModuleName])] 32 | load wanted pkgDbs = do 33 | pkgs <- concat <$> mapM (\dir -> loadCache (dir "package.cache")) 34 | pkgDbs 35 | pure $ map snd $ filter ((`Set.member` wanted) . fst) pkgs 36 | 37 | loadCache :: FilePath -> IO [(UnitId, (PkgName, [ModuleName]))] 38 | loadCache cachePath = do 39 | (pkgs, _) <- Database.readPackageDbForGhcPkg cachePath 40 | Database.DbOpenReadOnly 41 | pure $ mapMaybe extract pkgs 42 | 43 | extract :: IPI.InstalledPackageInfo -> Maybe (UnitId, (PkgName, [ModuleName])) 44 | extract pkg 45 | | not (IPI.exposed pkg) = Nothing 46 | | otherwise = Just 47 | ( Text.pack $ UnitId.unUnitId $ IPI.installedUnitId pkg 48 | , ( pkgName (IPI.sourcePackageId pkg) 49 | , map (modString . IPI.exposedName) $ IPI.exposedModules pkg 50 | ) 51 | ) 52 | where 53 | modString = map (\c -> if c == '/' then '.' else c) . ModuleName.toFilePath 54 | pkgName = Text.pack . PackageName.unPackageName . PackageId.pkgName 55 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | 3 | # Explicitly request container-based infrastructure. 4 | sudo: false 5 | 6 | # Speed up git. 7 | git: 8 | depth: 5 9 | 10 | cache: 11 | directories: 12 | - $HOME/.cabal 13 | - $HOME/.ghc 14 | 15 | before_cache: 16 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 17 | # remove files that are regenerated by 'cabal update' 18 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 20 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 23 | - rm -rfv $HOME/.cabal/packages/head.hackage 24 | 25 | # happy is required by haskell-src, by test-karya, by pprint. 26 | # Old-style cabal is sadly not smart enough to understand this. 27 | matrix: 28 | include: 29 | - compiler: "ghc-8.4.2" 30 | env: GHC=8.4.2 CABALVER=2.2 ALEXVER=3.1.7 31 | addons: 32 | apt: 33 | packages: [ghc-8.4.2, cabal-install-2.2, happy-1.19.5] 34 | sources: [hvr-ghc] 35 | 36 | # async not updated for base-4.12 37 | # - compiler: "ghc-HEAD" 38 | # env: GHC=head CABALVER=head ALEXVER=3.1.7 39 | # addons: 40 | # apt: 41 | # packages: [ghc-head, cabal-install-head, happy-1.19.5] 42 | # sources: [hvr-ghc] 43 | 44 | install: true 45 | 46 | before_install: 47 | - export PATH="/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH" 48 | - export PATH="/opt/happy/1.19.5/bin:$PATH" 49 | 50 | install: 51 | - echo $(ghc --version) 52 | - ghc-pkg list 53 | - cabal --version 54 | - travis_retry cabal update -v 55 | - cabal install --only-dependencies --enable-tests -j2 56 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 57 | 58 | # Here starts the actual work to be performed for the package under test; 59 | # any command which exits with a non-zero exit code causes the build to fail. 60 | script: 61 | # test that source-distributions can be generated 62 | - cabal configure 63 | - cabal sdist 64 | - cat ./dist/fix-imports-*.tar.gz | (cd "${DISTDIR}/" && tar -xzvf -) 65 | - cd ${DISTDIR}/fix-imports* 66 | # this builds all libraries and executables (without tests/benchmarks) 67 | - cabal configure --enable-tests --disable-benchmarks 68 | - cabal build 69 | - cabal test 70 | -------------------------------------------------------------------------------- /dot-fix-imports: -------------------------------------------------------------------------------- 1 | -- fix-imports looks for a .fix-imports file in the current directory for 2 | -- per-project configuration, otherwise in ~/.config/fix-imports. 3 | -- You can set the file explicitly with --config. 4 | -- 5 | -- The syntax is like ghc-pkg or cabal: word, colon, and a list of words. 6 | -- A line with leading space is a continuation of the previous line. 7 | -- Comments are written with "--". 8 | 9 | -- Include extra directories on the search path. Directories passed via -i 10 | -- go before this list. 11 | include: dist/build/my-project/my-project-tmp 12 | 13 | -- Control the sorting of the import list by prefix. A trailing dot 14 | -- like "M." matches exactly M or anything starting with "M.". 15 | -- These go in the given order, before other imports. 16 | import-order-first: Util. 17 | -- These go in the given order, but after all the other imports. 18 | import-order-last: Global 19 | -- If present at all (the 't' argument is irrelevant), unqualified import-all 20 | -- lines always go last. The idea is that they should be special, and this 21 | -- helps them stand out. 22 | sort-unqualified-last: t 23 | 24 | -- When there are multiple candidates for a module, prefer or don't prefer 25 | -- ones from these lists. These are exact matches: 26 | prio-module-high: Ui 27 | prio-module-low: GHC 28 | 29 | -- Or increase or decrease priority for an entire package: 30 | prio-package-high: 31 | -- haskell98 and ghc export a lot of toplevel modules that most programs 32 | -- don't want to import. 33 | prio-package-low: haskell98 ghc Cabal 34 | 35 | -- In the abscence of prio-* config, the module with the least number of dots 36 | -- is picked. Usually packages put the most "public" modules at the top, e.g. 37 | -- IO should choose System.IO, not Data.Text.Lazy.IO 38 | 39 | -- Manage these symbols as unqualified imports. Use ()s for operators. 40 | -- The syntax is meant to resemble import syntax, separated by semicolons: 41 | unqualified: Data.Bifunctor (first, second); System.FilePath (()) 42 | 43 | -- DTL.something will turn into a search for Data.Text.Lazy. 44 | qualify-as: Data.Text.Lazy as DTL; Data.Vector.Unboxed as VU 45 | 46 | format: 47 | -- Insert a space gap for the "qualified" keyword. 48 | leave-space-for-qualified 49 | -- Suppress the usual behaviour where imports are grouped by the first 50 | -- component. 51 | no-group 52 | -- If there is a long explicit import list, it might have to be wrapped. 53 | -- Wrap to this many columns. 54 | columns=80 55 | 56 | -- Space separated list of extensions that are enabled by default. 57 | language: GeneralizedNewtypeDeriving 58 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | ### 2.5.0 2 | 3 | - update to ghc-lib-parser 9.6, should support at least ghc 9.4 and 9.6 4 | 5 | - add --package-cache flag, to read from a specific package cache. Should be 6 | faster than ghc-pkg. 7 | 8 | ### 2.4.0 9 | 10 | - Support cabal v2, look for .ghc.environment.* and get pkgs from there. 11 | 12 | - Look for config in ~/.config/fix-imports in addition to ./.fix-imports. 13 | 14 | - Switch from haskell-src-exts to ghc-lib-parser. This fixes a bunch of 15 | parsing bugs. Along the way I fixed a bug where locally bound names were 16 | misinterpreted as unqualified names. 17 | 18 | - Detect and abort on CPP in the import block, instead of silently deleting it. 19 | 20 | ### 2.3.0 21 | 22 | - add --edit flag, so I can just replace imports, instead of the whole file 23 | 24 | - add logging, and show findModule info when passed --debug 25 | 26 | - Add --config flag to explicitly set the config file. 27 | 28 | ### 2.2.0 29 | 30 | - fix bugs where pretty printing didn't work right for 31 | leave-space-for-unqualified 32 | 33 | - add `format: columns=n` field 34 | 35 | - separate qualify-as fields with ; instead of , 36 | 37 | - fix a bug where I didn't allow _ in unqualified import names 38 | 39 | - better error reporting 40 | 41 | ### 2.1.0 42 | 43 | - unqualified syntax changed to support multiple imports per module 44 | 45 | - add `format: leave-space-for-qualified` and `format: no-group` 46 | 47 | - add import-as config option 48 | 49 | E.g. import Data.Text.Lazy as DTL, instead of always having to qualify 50 | as a suffix, like Lazy, or Text.Lazy. 51 | 52 | - various bugs with unqualified imports 53 | 54 | #### 2.0.0 55 | 56 | - add support for unqualified imports for explicitly configured symbols, via 57 | the `unqualified` field in `.fix-imports` 58 | 59 | - significant speed improvement, reuse the loaded pkg index instead of asking 60 | ghc-pkg find-module 61 | 62 | - --debug now emits timing metrics 63 | 64 | - import-order-{first,last} are exact matches, or are prefix matches if they 65 | have a trailing dot 66 | 67 | - prio-module-{high,low} are now exact matches instead of prefix 68 | 69 | #### 1.1.0 70 | 71 | - Rename import-order to import-order-first, and add import-order-last. 72 | 73 | #### 1.0.5 74 | 75 | - support haskell-src-exts > 1.16 76 | 77 | - add 'language' field to .fix-imports, to turn on local extensions 78 | 79 | #### 1.0.3 and 1.0.4 80 | 81 | - upgrade to haskell-src-exts-1.16 82 | 83 | #### 1.0.2 84 | 85 | - Fix bug where a qualified import with >1 dot wasn't found. And don't 86 | mess with Prelude. 87 | 88 | #### 1.0.1 89 | 90 | - Fix a bunch of bugs: properly recognize unqualified imports as imports, 91 | never import the current module, don't pick up modules with the same suffix 92 | but a different name. 93 | 94 | #### 1.0.0 95 | 96 | - Change name from FixImports to fix-imports, which is more unixy. 97 | 98 | - Change ghc-pkg parsing from String to Text. It's noticeably faster. 99 | 100 | - Add a more flexible system for prioritizing imports. 101 | When there are several possibilities for a module name, they are all given 102 | to a single function to decide. The config file moved from 103 | fix-imports-priority to .fix-imports and can now specify sort orders for 104 | packages and modules by prefix. 105 | 106 | - Make -i includes for non-existent dirs ignored instead of causing an 107 | error. 108 | -------------------------------------------------------------------------------- /src/FixImports/Config_test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module FixImports.Config_test where 4 | import qualified Data.Map as Map 5 | import qualified Data.Text as Text 6 | 7 | import qualified FixImports.Config as Config 8 | import qualified FixImports.FixImports as FixImports 9 | import qualified FixImports.Types as Types 10 | 11 | import EL.Test.Global 12 | 13 | 14 | test_parse = do 15 | let f = check . Config.parse . Text.unlines 16 | check (config, errs) 17 | | null errs = Right config 18 | | otherwise = Left $ Text.unlines errs 19 | equal (f []) $ Right Config.empty 20 | leftLike (f ["include: a", "include: b"]) "duplicate fields" 21 | equal (Config._order <$> 22 | f ["import-order-first: A", "import-order-last: B"]) $ 23 | Right $ Config.Order 24 | { _importOrder = Config.Priority ["A"] ["B"] 25 | , _sortUnqualifiedLast = False 26 | } 27 | rightEqual 28 | (Config._leaveSpaceForQualified . Config._format <$> 29 | f ["format:", " leave-space-for-qualified"]) 30 | True 31 | 32 | test_parseUnqualified = do 33 | let f = Config._unqualified . parseConfig 34 | equal (f ["unqualified: A.B (c); D.E ((+))"]) $ Map.fromList 35 | [ (Types.Name "c", "A.B") 36 | , (Types.Operator "+", "D.E") 37 | ] 38 | equal (f ["unqualified: A.B(c, d)"]) $ Map.fromList 39 | [ (Types.Name "c", "A.B") 40 | , (Types.Name "d", "A.B") 41 | ] 42 | equal (f ["unqualified: A.B (c,(+))"]) $ Map.fromList 43 | [ (Types.Name "c", "A.B") 44 | , (Types.Operator "+", "A.B") 45 | ] 46 | 47 | test_parseQualifyAs = do 48 | let f = Config._qualifyAs . parseConfig 49 | equal (f ["qualify-as: A.B as AB; E as F"]) $ Map.fromList 50 | [ ("AB", "A.B") 51 | , ("F", "E") 52 | ] 53 | stringsLike (snd $ Config.parse "qualify-as: gibble gabble") 54 | ["stanza should look like"] 55 | 56 | test_pickModule = do 57 | let f config modulePath candidates = Config.pickModule 58 | (Config._modulePriority (parseConfig config)) 59 | modulePath candidates 60 | equal (f [] "X.hs" []) Nothing 61 | let localAB = [(Nothing, "A.M"), (Nothing, "B.M")] 62 | equal (f [] "X.hs" localAB) $ 63 | Just (Nothing, "A.M") 64 | equal (f ["prio-module-high: B.M"] "X.hs" localAB) $ 65 | Just (Nothing, "B.M") 66 | -- Has to be an exact match. 67 | equal (f ["prio-module-high: B"] "X.hs" localAB) $ 68 | Just (Nothing, "A.M") 69 | 70 | -- Local modules take precedence. 71 | equal (f [] "A/B.hs" [(Nothing, "B.M"), (Just "pkg", "B.M")]) $ 72 | Just (Nothing, "B.M") 73 | equal (f [] "A/B/C.hs" [(Nothing, "A.B.M"), (Just "pkg", "B.M")]) $ 74 | Just (Nothing, "A.B.M") 75 | -- Closer local modules precede further ones. 76 | equal (f [] "A/B/C.hs" [(Nothing, "A.B.M"), (Nothing, "A.M")]) $ 77 | Just (Nothing, "A.B.M") 78 | -- Prefer fewer dots. 79 | equal (f [] "X.hs" [(Just "p1", "A.B.M"), (Just "p2", "Z.M")]) $ 80 | Just (Just "p2", "Z.M") 81 | 82 | parseConfig :: [Text.Text] -> Config.Config 83 | parseConfig lines 84 | | null errs = config 85 | | otherwise = error $ "parsing " <> show lines <> ": " 86 | <> Text.unpack (Text.unlines errs) 87 | where (config, errs) = Config.parse (Text.unlines lines) 88 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * done; - not done; / decided against 2 | 3 | bug: 4 | - support unqualified constructors 5 | . e.g. NonEmpty((:|)) 6 | * Ignore unqualified names if they're already imported from a different 7 | module. 8 | - It wants to import unqualified names defined in the module. 9 | 10 | feature: 11 | * support nix-style cabal 12 | I need to get ghc-pkg to see the local packages... is it one of those 13 | hidden files? 14 | . It's .ghc.environment.x86_64-darwin-9.2.5: 15 | clear-package-db 16 | global-package-db 17 | package-db /Users/elaforge/.cabal/store/ghc-9.2.5/package.db 18 | package-db dist-newstyle/packagedb/ghc-9.2.5 19 | package-id hlibgit2-0.18.0.16-inplace 20 | package-id base-4.16.4.0 21 | package-id bndngs-DSL-1.0.25-d82df022 22 | . Since the package db will have multiple packages of the same name, 23 | I need to search the explicit package ids. 24 | . ghc-pkg --unit-id --no-user-package-db --package-db .. \ 25 | field pkgname name,exposed,exposed-modules 26 | . But ghc-pkg doesn't let me list packages in fields, I'd have to run it 27 | a bunch of times. 28 | . So, parse the files myself? I would read the *.conf files, but it 29 | would be nicer to read package.cache. 30 | . Where is ghc-pkg source? 31 | import qualified GHC.Unit.Database as GhcPkg 32 | (db_stack, GhcPkg.DbOpenReadOnly, flag_db_stack) 33 | <- getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 34 | GhcPkg.readPackageDbForGhcPkg cache mode 35 | if not reading the cache: 36 | BS.readFile file >>= fmap fst . parsePackageInfo 37 | parseInstalledPackageInfo 38 | readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t 39 | -> IO (pkgs, DbOpenMode mode PackageDbLock) 40 | readPackageDbForGhcPkg "path" DbOpenReadOnly 41 | 42 | ambiguous import resolution: 43 | - Ask interactively. 44 | . This requires deeper integration, but vim does have menu selection 45 | support. 46 | - Write a simple tool to analyze existing code and assign priorities 47 | based on how often each is imported. 48 | - When run with a flag, add them all, but commented out, so you can pick 49 | on in the editor. Maybe jump the cursor up there automatically. 50 | - Use haskell-names to guess the module to import based on the function 51 | name: http://documentup.com/haskell-suite/haskell-names 52 | - Use tags to guess based on the function name. 53 | . https://github.com/JonnyRa/vim-himposter 54 | - Or use HIE files to do the same. 55 | 56 | automatic unqualified imports: 57 | - any of the haskell-names, tags, or HIE above could do this. 58 | - I'd like a add/removed symbol if it modified an unqualified import list 59 | 60 | / add *all* possible imports, but comment out all but the priority one 61 | . This seems not great because much of the time it guesses right. 62 | . Then I need some notion of certainty. 63 | . Maybe only for local imports? Or local imports where there isn't an 64 | obvious winner, where obvious winner means in the same directory? 65 | 66 | / Use a cabal sandbox if one is present. 67 | - use stack if present 68 | . I think just: 69 | if [ $use_stack ]; then 70 | export GHC_PACKAGE_PATH=$(stack path --ghc-package-path) 71 | PATH=$(stack path --compiler-bin):$PATH 72 | fi 73 | 74 | / Optionally write a cache of the package db. 75 | . No need, most time is spent parsing. 76 | . It's fast enough. 77 | -------------------------------------------------------------------------------- /fix-imports.cabal: -------------------------------------------------------------------------------- 1 | name: fix-imports 2 | version: 2.5.0 3 | cabal-version: >= 1.10 4 | build-type: Simple 5 | synopsis: Program to manage the imports of a haskell module 6 | description: 7 | `fix-imports` is a small standalone program to manage the import block of 8 | a haskell program. It will try to add import lines for qualified names 9 | with no corresponding import, remove unused import lines, and keep the 10 | import block sorted, with optional rules for grouping. 11 | . 12 | Support for unqualified imports is limited to symbols you explicitly 13 | configure, so if you list `System.FilePath.()`, it will add that import 14 | when you use it, or remove when it's no longer used, but it won't go search 15 | modules for unqualified imports. 16 | . 17 | It doesn't mess with non-managed unqualified imports, so you can still use 18 | unqualified imports, you just have to do it manually. 19 | . 20 | Since it's a unix-style filter, it should be possible to integrate into any 21 | editor. There's an example vimrc to bind to a key in vim. 22 | 23 | category: Editor, Haskell, IDE 24 | license: BSD3 25 | license-file: LICENSE 26 | author: Evan Laforge 27 | maintainer: Evan Laforge 28 | stability: stable 29 | tested-with: GHC == 9.2 30 | extra-source-files: 31 | README.md 32 | changelog.md 33 | dot-fix-imports 34 | vimrc 35 | 36 | source-repository head 37 | type: git 38 | location: git://github.com/elaforge/fix-imports.git 39 | 40 | executable fix-imports 41 | main-is: FixImports/Main.hs 42 | other-modules: 43 | FixImports.Config 44 | FixImports.FixImports 45 | FixImports.Format 46 | FixImports.Index 47 | FixImports.Parse 48 | FixImports.PkgCache 49 | FixImports.Types 50 | FixImports.Util 51 | Paths_fix_imports 52 | hs-source-dirs: src 53 | default-language: Haskell2010 54 | build-depends: 55 | base >= 3 && < 5 56 | , Cabal 57 | , containers 58 | , cpphs 59 | , deepseq 60 | , directory 61 | , filepath 62 | -- actually the latest is 9.12, but I guess ghc9.2 can't compile it? 63 | , ghc-lib-parser >= 9.6 && < 9.8 64 | , ghc-lib-parser-ex >= 9.6 && < 9.8 65 | , ghc-paths 66 | , mtl 67 | , pretty 68 | , process 69 | , split 70 | , text 71 | , time 72 | , uniplate 73 | -- , test-karya 74 | -- , el-debug 75 | ghc-options: 76 | -main-is FixImports.Main 77 | -Wall 78 | -fno-warn-name-shadowing 79 | 80 | test-suite test 81 | type: exitcode-stdio-1.0 82 | hs-source-dirs: src 83 | main-is: RunTests.hs 84 | default-language: Haskell2010 85 | build-depends: 86 | -- copy paste of executable, TODO is there a way to deduplicate? 87 | base >= 3 && < 5 88 | , Cabal 89 | , containers 90 | , cpphs 91 | , deepseq 92 | , directory 93 | , filepath 94 | , ghc-lib-parser >= 9.6 && < 9.8 95 | , ghc-lib-parser-ex >= 9.6 && < 9.8 96 | , ghc-paths 97 | , mtl 98 | , pretty 99 | , process 100 | , split 101 | , text 102 | , time 103 | , uniplate 104 | 105 | , test-karya 106 | other-modules: 107 | FixImports.Config 108 | FixImports.Config_test 109 | FixImports.FixImports 110 | FixImports.FixImports_test 111 | FixImports.Format 112 | FixImports.Format_test 113 | FixImports.Index 114 | FixImports.Parse 115 | FixImports.Parse_test 116 | FixImports.PkgCache 117 | FixImports.Types 118 | FixImports.Util 119 | -------------------------------------------------------------------------------- /src/FixImports/Format_test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module FixImports.Format_test where 4 | import qualified Data.Text as Text 5 | import qualified System.IO.Unsafe as Unsafe 6 | 7 | import qualified FixImports.Config as Config 8 | import qualified FixImports.Format as Format 9 | import qualified FixImports.Parse as Parse 10 | import qualified FixImports.Types as Types 11 | 12 | import qualified EL.Test.Testing as Testing 13 | import EL.Test.Global 14 | 15 | 16 | test_formatGroups = do 17 | let f config imports = lines $ Format.formatGroups Config.defaultFormat 18 | (Config._order (parseConfig config)) 19 | (Testing.expectRight (parse (unlines imports))) 20 | equal (f [] []) [] 21 | -- Unqualified import-all goes last. 22 | equal (f ["sort-unqualified-last: t"] 23 | [ "import Z", "import A" 24 | , "import qualified C", "import qualified B" 25 | , "import C (a)" 26 | ]) 27 | [ "import qualified B" 28 | , "import qualified C" 29 | , "import C (a)" 30 | , "" 31 | , "import A" 32 | , "import Z" 33 | ] 34 | 35 | equal (f [] ["import qualified Z", "import qualified A"]) 36 | [ "import qualified A" 37 | , "import qualified Z" 38 | ] 39 | equal (f ["import-order-first: Z"] 40 | ["import qualified Z", "import qualified A"]) 41 | [ "import qualified Z" 42 | , "import qualified A" 43 | ] 44 | equal (f ["import-order-last: A"] 45 | ["import qualified Z", "import qualified A"]) 46 | [ "import qualified Z" 47 | , "import qualified A" 48 | ] 49 | 50 | -- Exact match. 51 | equal (f ["import-order-first: Z"] 52 | ["import qualified Z.A", "import qualified A"]) 53 | [ "import qualified A" 54 | , "import qualified Z.A" 55 | ] 56 | -- Unless it's a prefix match. 57 | equal (f ["import-order-first: Z."] 58 | ["import qualified Z.A", "import qualified A"]) 59 | [ "import qualified Z.A" 60 | , "import qualified A" 61 | ] 62 | 63 | test_showImport = do 64 | let f = fmap (Format.showImport style . Types.importDecl . head) . parse 65 | style = Config.defaultFormat { Config._leaveSpaceForQualified = True } 66 | equal (f "import A.B as C (x)") $ Right "import A.B as C (x)" 67 | 68 | test_leaveSpaceForQualified = do 69 | let f columns leaveSpace = 70 | fmap (Format.showImport (fmt columns leaveSpace) . head 71 | . map Types.importDecl) 72 | . parse 73 | fmt columns leaveSpace = Config.defaultFormat 74 | { Config._columns = columns 75 | , Config._leaveSpaceForQualified = leaveSpace 76 | } 77 | rightEqual (f 80 False "import Foo.Bar (a, b, c)") 78 | "import Foo.Bar (a, b, c)" 79 | rightEqual (f 80 True "import Foo.Bar (a, b, c)") 80 | "import Foo.Bar (a, b, c)" 81 | 82 | rightEqual (f 20 False "import Foo.Bar (a, b, c)") 83 | "import Foo.Bar\n\ 84 | \ (a, b, c)" 85 | rightEqual (f 30 True "import Foo.Bar (a, b, c)") 86 | "import Foo.Bar\n\ 87 | \ (a, b, c)" 88 | 89 | rightEqual (f 30 True "import Foo.Bar (tweetle, beetle, paddle, battle)") 90 | "import Foo.Bar\n\ 91 | \ (tweetle, beetle, paddle,\n\ 92 | \ battle)" 93 | 94 | 95 | -- * util 96 | 97 | parse :: String -> Either String [Types.ImportLine] 98 | parse = Unsafe.unsafePerformIO 99 | . fmap (fmap (map importLine . Parse.extractImports . fst)) 100 | . Parse.parse [] "M.hs" 101 | 102 | importLine :: Types.Import -> Types.ImportLine 103 | importLine imp = Types.ImportLine 104 | { importDecl = imp 105 | , importComments = [] 106 | , importSource = Types.Local 107 | } 108 | 109 | parseConfig :: [Text.Text] -> Config.Config 110 | parseConfig lines 111 | | null errs = config 112 | | otherwise = error $ "parsing " <> show lines <> ": " 113 | <> Text.unpack (Text.unlines errs) 114 | where (config, errs) = Config.parse (Text.unlines lines) 115 | -------------------------------------------------------------------------------- /src/FixImports/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module FixImports.Format ( 3 | formatGroups 4 | , showImport 5 | ) where 6 | import qualified Data.List as List 7 | import qualified Data.Maybe as Maybe 8 | import qualified Text.PrettyPrint as PP 9 | import Text.PrettyPrint ((<+>)) 10 | 11 | import qualified FixImports.Config as Config 12 | import qualified FixImports.Types as Types 13 | import qualified FixImports.Util as Util 14 | 15 | 16 | -- | Format import list. Imports are alphabetized and grouped into sections 17 | -- based on the top level module name (before the first dot). Sections that 18 | -- are too small are grouped with the section below them. 19 | -- 20 | -- The local imports are sorted and grouped separately from the package 21 | -- imports. Rather than being alphabetical, they are sorted in a per-project 22 | -- order that should be general-to-specific. 23 | -- 24 | -- An unqualified import will follow a qualified one. The Prelude, if 25 | -- imported, always goes first. 26 | formatGroups :: Config.Format -> Config.Order -> [Types.ImportLine] -> String 27 | formatGroups format order imports = 28 | unlines $ joinGroups 29 | [ showGroups (group (Util.sortOn packagePrio package)) 30 | , showGroups (group (Util.sortOn localPrio local)) 31 | , showGroups [Util.sortOn name unqualified] 32 | ] 33 | where 34 | packagePrio import_ = 35 | ( name import_ /= prelude 36 | , name import_ 37 | , qualifiedPrio import_ 38 | ) 39 | localPrio import_ = 40 | ( localPriority (Config._importOrder order) (name import_) 41 | , name import_ 42 | , qualifiedPrio import_ 43 | ) 44 | qualifiedPrio = not . Types._importQualified . Types.importDecl 45 | name = Types._importName . Types.importDecl 46 | (unqualified, local, package) = Util.partition2 47 | ((Config._sortUnqualifiedLast order &&) . isUnqualified 48 | . Types.importDecl) 49 | ((==Types.Local) . Types.importSource) 50 | imports 51 | group 52 | | Config._groupImports format = collapse . Util.groupOn topModule 53 | | otherwise = (:[]) 54 | topModule = takeWhile (/='.') . Types.moduleName . name 55 | collapse [] = [] 56 | collapse (x:xs) 57 | | length x <= 2 = case collapse xs of 58 | [] -> [x] 59 | y : ys -> (x ++ y) : ys 60 | | otherwise = x : collapse xs 61 | showGroups = List.intercalate [""] . map (map (showImportLine format)) 62 | joinGroups = List.intercalate [""] . filter (not . null) 63 | prelude = Types.ModuleName "Prelude" 64 | 65 | isUnqualified :: Types.Import -> Bool 66 | isUnqualified imp = not (Types._importQualified imp) 67 | && Maybe.isNothing (Types._importEntities imp) 68 | 69 | -- | Modules whose top level element is in 'importFirst' go first, ones in 70 | -- 'importLast' go last, and the rest go in the middle. 71 | -- 72 | -- Like 'searchPrio' but for order. 73 | localPriority :: Config.Priority Config.ModulePattern -> Types.ModuleName 74 | -> (Int, Maybe Int) 75 | localPriority prio import_ = 76 | case List.findIndex (`Config.matchModule` import_) firsts of 77 | Just k -> (-1, Just k) 78 | Nothing -> case List.findIndex (`Config.matchModule` import_) lasts of 79 | Nothing -> (0, Nothing) 80 | Just k -> (1, Just k) 81 | where 82 | firsts = Config.high prio 83 | lasts = Config.low prio 84 | 85 | showImportLine :: Config.Format -> Types.ImportLine -> String 86 | showImportLine format (Types.ImportLine imp cmts _) = concat 87 | [ above 88 | , showImport format imp 89 | , (if null right then "" else ' ' : right) 90 | ] 91 | where 92 | above = concat [cmt ++ "\n" | Types.Comment Types.CmtAbove cmt <- cmts] 93 | right = Util.join "\n" [cmt | Types.Comment Types.CmtRight cmt <- cmts] 94 | 95 | showImport :: Config.Format -> Types.Import -> String 96 | showImport format 97 | (Types.Import name pkgQualifier source safe qualified as hiding 98 | entities _span) = 99 | PP.renderStyle style $ PP.hang 100 | (PP.hsep 101 | [ "import" 102 | , if qualified || not (Config._leaveSpaceForQualified format) 103 | || source || safe 104 | then mempty 105 | else PP.text (replicate (length ("qualified" :: String)) ' ') 106 | , if source then "{-# SOURCE #-}" else mempty 107 | , if safe then "safe" else mempty 108 | , if qualified then "qualified" else mempty 109 | , maybe mempty (\s -> PP.text (show s)) pkgQualifier 110 | , PP.text $ Types.moduleName name 111 | , maybe mempty 112 | (\(Types.Qualification qual) -> "as" <+> PP.text qual) as 113 | , if hiding then "hiding" else mempty 114 | ]) 115 | (Config._wrapIndent format) (maybe mempty prettyEntities entities) 116 | where 117 | style = PP.style 118 | { PP.lineLength = Config._columns format 119 | , PP.ribbonsPerLine = 1 120 | } 121 | 122 | prettyEntities :: [Either Types.Error Types.Entity] -> PP.Doc 123 | prettyEntities = parenList . map pp 124 | where 125 | -- This means 'extractEntity' hit something it didn't think should be 126 | -- possible. 127 | pp (Left err) = "{{parse error: " <> PP.text err <> "}}" 128 | pp (Right (Types.Entity qualifier var list)) = 129 | (maybe mempty PP.text qualifier <+> PP.text (Types.showName var)) 130 | <> maybe mempty PP.text list 131 | 132 | parenList :: [PP.Doc] -> PP.Doc 133 | parenList = PP.parens . PP.fsep . PP.punctuate PP.comma 134 | -------------------------------------------------------------------------------- /src/FixImports/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE PackageImports #-} 3 | module FixImports.Types ( 4 | module FixImports.Types 5 | , module GHC.LanguageExtensions.Type 6 | ) where 7 | import qualified Control.DeepSeq as DeepSeq 8 | import Control.DeepSeq (deepseq) 9 | import qualified Data.Either as Either 10 | import Data.Maybe (fromMaybe) 11 | import qualified Data.Set as Set 12 | import qualified Data.String as String 13 | import qualified System.FilePath as FilePath 14 | 15 | import "ghc-lib-parser" GHC.LanguageExtensions.Type (Extension(..)) 16 | import qualified "ghc-lib-parser-ex" Language.Haskell.GhclibParserEx.GHC.Driver.Session 17 | 18 | 19 | type Error = String 20 | 21 | parseExtension :: String -> Maybe Extension 22 | parseExtension = 23 | Language.Haskell.GhclibParserEx.GHC.Driver.Session.readExtension 24 | 25 | -- * ImportLine 26 | 27 | data ImportLine = ImportLine { 28 | importDecl :: !Import 29 | , importComments :: ![Comment] 30 | , importSource :: !Source 31 | } deriving (Show) 32 | 33 | instance DeepSeq.NFData ImportLine where 34 | rnf (ImportLine decl cmts source) = 35 | decl `seq` cmts `deepseq` source `deepseq` () 36 | 37 | -- | Where did this import come from? 38 | data Source = Local | Package deriving (Eq, Show) 39 | 40 | instance DeepSeq.NFData Source where 41 | rnf _ = () 42 | 43 | -- | A Comment is associated with a particular import line. 44 | data Comment = Comment !CmtPos !String deriving (Show) 45 | data CmtPos = CmtAbove | CmtRight deriving (Show) 46 | 47 | instance DeepSeq.NFData Comment where 48 | rnf (Comment a b) = a `seq` b `seq` () 49 | 50 | -- * Import 51 | 52 | data Import = Import { 53 | _importName :: !ModuleName 54 | , _importPkgQualifier :: !(Maybe String) 55 | -- | SOURCE pragma? There is also ideclSourceSrc, but it looks like it's 56 | -- just to preserve the exact case or British-ness of the pragma, so I can 57 | -- discard it. 58 | , _importIsBoot :: !Bool 59 | , _importSafe :: !Bool -- ^ safe import 60 | , _importQualified :: !Bool -- ^ qualified 61 | , _importAs :: !(Maybe Qualification) -- ^ import as 62 | , _importHiding :: !Bool -- ^ import list is hiding 63 | , _importEntities :: !(Maybe [Either Error Entity]) 64 | , _importSpan :: !SrcSpan 65 | } deriving (Eq, Ord, Show) 66 | 67 | instance DeepSeq.NFData Import where 68 | rnf imp = _importPkgQualifier `deepseq` _importEntities imp `deepseq` () 69 | 70 | data SrcSpan = SrcSpan { _startLine, _startCol, _endLine, _endCol :: !Int } 71 | deriving (Eq, Ord, Show) 72 | 73 | noSpan :: SrcSpan 74 | noSpan = SrcSpan 0 0 0 0 75 | 76 | makeImport :: ModuleName -> Import 77 | makeImport name = Import 78 | { _importName = name 79 | , _importPkgQualifier = Nothing 80 | , _importIsBoot = False 81 | , _importSafe = False 82 | , _importQualified = False 83 | , _importAs = Nothing 84 | , _importHiding = False 85 | , _importEntities = Nothing 86 | , _importSpan = noSpan 87 | } 88 | 89 | -- | Get the qualified name from an Import. 90 | importQualification :: Import -> Qualification 91 | importQualification imp = 92 | fromMaybe (toQual (_importName imp)) (_importAs imp) 93 | where toQual (ModuleName m) = Qualification m 94 | 95 | setQualification :: Qualification -> Import -> Import 96 | setQualification qual imp = imp 97 | { _importQualified = True 98 | , _importAs = if toQual (_importName imp) == qual then Nothing 99 | else Just qual 100 | } where toQual (ModuleName m) = Qualification m 101 | 102 | -- | @import X hiding (x)@ doesn't count as an unqualified import, at least not 103 | -- the kind that I manage. 104 | importUnqualified :: Import -> Bool 105 | importUnqualified imp = 106 | not (_importQualified imp) && not (_importHiding imp) 107 | 108 | -- | Has an import list, but is empty. This import is a no-op, except for 109 | -- instances. 110 | importEmpty :: Import -> Bool 111 | importEmpty imp = case _importEntities imp of 112 | Just [] -> True 113 | _ -> False 114 | 115 | -- | If this import has a import list, modify its contents. 116 | importModify :: ([Entity] -> [Entity]) -> Import -> Import 117 | importModify modify imp = case (_importHiding imp, _importEntities imp) of 118 | (False, Just errEntities) -> imp 119 | { _importEntities = Just $ map Left errs 120 | ++ map Right (normalize (modify entities)) 121 | } 122 | where (errs, entities) = Either.partitionEithers errEntities 123 | _ -> imp 124 | where 125 | -- Keep entities unique and sorted. 126 | normalize = Set.toList . Set.fromList 127 | 128 | -- | An imported entity, e.g. @import X (entity)@. 129 | data Entity = Entity { 130 | _entityQualifier :: !(Maybe String) 131 | , _entityVar :: !Name 132 | , _entityList :: !(Maybe String) 133 | } deriving (Eq, Ord, Show) 134 | 135 | instance DeepSeq.NFData Entity where 136 | rnf (Entity a b c) = a `deepseq` b `deepseq` c `deepseq` () 137 | 138 | -- | A Qualification is a qualified name minus the actual name. So it should 139 | -- be the tail of a ModuleName. 140 | newtype Qualification = Qualification String 141 | deriving (Eq, Ord, Show, DeepSeq.NFData, String.IsString) 142 | 143 | -- | An unqualified identifier. 144 | data Name = Name !String | Operator !String 145 | deriving (Eq, Ord, Show) 146 | 147 | instance DeepSeq.NFData Name where 148 | rnf (Name s) = DeepSeq.rnf s 149 | rnf (Operator s) = DeepSeq.rnf s 150 | 151 | showName :: Name -> String 152 | showName (Name s) = s 153 | showName (Operator s) = "(" <> s <> ")" 154 | 155 | newtype ModuleName = ModuleName String 156 | deriving (Eq, Ord, Show, DeepSeq.NFData, String.IsString) 157 | 158 | moduleName :: ModuleName -> String 159 | moduleName (ModuleName n) = n 160 | 161 | pathToModule :: FilePath -> ModuleName 162 | pathToModule = ModuleName 163 | . map (\c -> if c == '/' then '.' else c) . FilePath.dropExtension 164 | 165 | moduleToPath :: ModuleName -> FilePath 166 | moduleToPath (ModuleName name) = 167 | map (\c -> if c == '.' then '/' else c) name ++ ".hs" 168 | -------------------------------------------------------------------------------- /src/FixImports/Parse_test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module FixImports.Parse_test where 4 | import qualified Data.Maybe as Maybe 5 | import Data.Maybe (fromMaybe) 6 | import qualified Data.Set as Set 7 | import qualified System.IO.Unsafe as Unsafe 8 | 9 | import qualified GHC.Hs as Hs 10 | import qualified GHC.Types.SrcLoc as SrcLoc 11 | 12 | import qualified FixImports.Parse as Parse 13 | import qualified FixImports.Types as Types 14 | 15 | import EL.Test.Global 16 | 17 | 18 | test_importRange = do 19 | let f = fmap Parse.importRange . parse 20 | rightEqual (f "") (0, 0) 21 | rightEqual (f "module M where\n") (1, 1) 22 | rightEqual (f "-- hi\nmodule M where\n") (2, 2) 23 | rightEqual (f 24 | "module M (\n\ 25 | \ x, y\n\ 26 | \) where\n\ 27 | \import A\n\ 28 | \import B\n\ 29 | \f = 42\n") 30 | (3, 5) 31 | rightEqual (f 32 | "module M (\n\ 33 | \ x, y\n\ 34 | \) where\n\ 35 | \f = 42\n") 36 | (3, 3) 37 | rightEqual (f 38 | "module M where\n\ 39 | \f = 42\n") 40 | (1, 1) 41 | 42 | test_extractImports = do 43 | let f = fmap (head . map strip . Parse.extractImports) . parse 44 | strip imp = imp { Types._importSpan = Types.noSpan } 45 | rightEqual (f "import \"pkg\" A ()") $ (Types.makeImport "A") 46 | { Types._importPkgQualifier = Just "pkg" 47 | , Types._importEntities = Just [] 48 | } 49 | rightEqual (f "import {-# SOURCE #-} A") $ (Types.makeImport "A") 50 | { Types._importIsBoot = True } 51 | rightEqual (f "import A as B hiding (a, b)") $ (Types.makeImport "A") 52 | { Types._importAs = Just "B" 53 | , Types._importHiding = True 54 | , Types._importEntities = Just 55 | [ Right $ Types.Entity Nothing (Types.Name "a") Nothing 56 | , Right $ Types.Entity Nothing (Types.Name "b") Nothing 57 | ] 58 | } 59 | 60 | test_extensions = do 61 | let f exts = Parse.parse (map (expectRight . parseExtension) exts) "M.hs" 62 | let extract = fmap (fmap (extractEntities . fst)) 63 | apply1 leftLike (extract $ f [] "import X (pattern A)") "parse error" 64 | apply1 rightEqual (extract $ f ["PatternSynonyms"] "import X (pattern A)") 65 | [Right ("pattern", Types.Name "A", "")] 66 | apply1 rightEqual 67 | (extract $ f [] 68 | "{-# LANGUAGE PatternSynonyms #-}\nimport X (pattern A)") 69 | [Right ("pattern", Types.Name "A", "")] 70 | 71 | parseExtension :: String -> Either String Types.Extension 72 | parseExtension w = maybe (Left w) Right $ Types.parseExtension w 73 | 74 | test_comments = do 75 | let f = fmap (fmap (map extract . snd)) . Parse.parse [] "M.hs" 76 | extract (Parse.Comment (Types.SrcSpan x1 y1 x2 y2) cmt) = 77 | ((x1, y1, x2, y2), cmt) 78 | apply1 rightEqual (f "module M where\n") [] 79 | apply1 rightEqual (f "-- above\nimport X -- right\n") 80 | [((0, 1, 0, 9), "-- above"), ((1, 10, 1, 18), "-- right")] 81 | apply1 rightEqual (f "-- | above\nimport X {- right -}\n") 82 | [((0, 1, 0, 11), "-- | above"), ((1, 10, 1, 21), "{- right -}")] 83 | apply1 rightEqual (f "-- *** section\nimport X {- ^ right -}\n") 84 | [((0, 1, 0, 15), "-- *** section"), ((1, 10, 1, 23), "{- ^ right -}")] 85 | 86 | test_extractEntity = do 87 | let f = fmap extractEntities . parse 88 | extractEntities = map (fmap extractEntity) . fromMaybe [] 89 | . Types._importEntities . head . Parse.extractImports 90 | extractEntity (Types.Entity qual name list) = 91 | (fromMaybe "" qual, name, fromMaybe "" list) 92 | let n = Types.Name 93 | rightEqual (f "import X") [] 94 | rightEqual (f "import X (a, b)") 95 | [Right ("", n "a", ""), Right ("", n "b", "")] 96 | rightEqual (f "import X (type A)") [Right ("type", n "A", "")] 97 | 98 | rightEqual (f "import X (A)") [Right ("", n "A", "")] 99 | rightEqual (f "import X (A(..))") [Right ("", n "A", "(..)")] 100 | rightEqual (f "import X (A())") [Right ("", n "A", "()")] 101 | rightEqual (f "import X (A(b, c))") [Right ("", n "A", "(b, c)")] 102 | rightEqual (f "import X (A(B))") [Right ("", n "A", "(B)")] 103 | rightEqual (f "import X ((*))") [Right ("", Types.Operator "*", "")] 104 | 105 | 106 | extractEntities = map (fmap extractEntity) . fromMaybe [] 107 | . Types._importEntities . head . Parse.extractImports 108 | where 109 | extractEntity (Types.Entity qual name list) = 110 | (fromMaybe "" qual, name, fromMaybe "" list) 111 | 112 | test_qualifications = do 113 | let f = fmap (Set.toList . Parse.qualifications) . parse 114 | rightEqual (f "f = x") [] 115 | rightEqual (f "f = A.x") ["A"] 116 | rightEqual (f "f = A.B.x D.y") ["A.B", "D"] 117 | rightEqual (f "f :: A.X -> B.Y") ["A", "B"] 118 | rightEqual (f "f = x A. y") ["A"] 119 | rightEqual (f "f = (A.) x y") ["A"] 120 | rightEqual (f "f = g @A.B @C.D") ["A", "C"] 121 | 122 | test_unqualifiedValues = do 123 | let f = fmap (map unname . Set.toList . Parse.unqualifiedValues) . parse 124 | unname (Types.Name s) = s 125 | unname (Types.Operator s) = "(" <> s <> ")" 126 | -- Don't pick up imports and exports. 127 | rightEqual (f "module A (b) where\nimport C (d)\n") [] 128 | -- Don't pick up function lhs. 129 | rightEqual (f "f x = 10") [] 130 | rightEqual (f "f x = y") ["y"] 131 | rightEqual (f "x = y") ["y"] 132 | -- TODO I'd rather just "pat", but I'd need to dig deeper into 133 | -- the pattern AST which is complicated. 134 | rightEqual (f "f | x <- pat = 10") ["pat", "x"] 135 | rightEqual (f "f = 10 * 20") ["(*)"] 136 | -- instance declarations 137 | rightEqual (f "instance A B where f = x") ["x"] 138 | 139 | test_unqualifiedTypes = do 140 | let f = fmap (map unname . Set.toList . Parse.unqualifiedTypes) . parse 141 | unname (Types.Name s) = s 142 | unname (Types.Operator s) = "(" <> s <> ")" 143 | -- Also look in type signatures. 144 | rightEqual (f "f :: A -> B C") ["A", "B", "C"] 145 | rightEqual (f "instance A b where f = x") ["A"] 146 | rightEqual (f "instance A b where f = x") ["A"] 147 | -- But not type declarations. 148 | rightEqual (f "data A = B c | D e deriving (Z)") ["Z"] 149 | rightEqual (f "class A where f :: A") ["A"] 150 | 151 | apply1 :: Monad m => (a -> b -> m c) -> m a -> b -> m c 152 | apply1 f ma b = do 153 | a <- ma 154 | f a b 155 | 156 | parse :: String -> Either String Parse.Module 157 | parse = Unsafe.unsafePerformIO . fmap (fmap fst) . Parse.parse [] "M.hs" 158 | -------------------------------------------------------------------------------- /src/FixImports/Util.hs: -------------------------------------------------------------------------------- 1 | module FixImports.Util where 2 | import Prelude hiding (head) 3 | import qualified Control.Concurrent as Concurrent 4 | import qualified Control.Concurrent.MVar as MVar 5 | import qualified Control.Exception as Exception 6 | import Control.Monad 7 | 8 | import qualified Data.Char as Char 9 | import qualified Data.Function as Function 10 | import qualified Data.IntSet as IntSet 11 | import qualified Data.List as List 12 | import qualified Data.List.Split as Split 13 | import qualified Data.Map as Map 14 | import qualified Data.Set as Set 15 | import qualified Data.Text as T 16 | import qualified Data.Text.IO as Text.IO 17 | 18 | import qualified System.Directory as Directory 19 | import qualified System.Exit as Exit 20 | import System.FilePath (()) 21 | import qualified System.IO as IO 22 | import qualified System.IO.Error as IO.Error 23 | import qualified System.Process as Process 24 | 25 | 26 | -- | Copy paste from FastTags.Tag.haskellOpChar. 27 | -- 28 | -- From the haskell report: 29 | -- > varsym → ( symbol⟨:⟩ {symbol} )⟨reservedop | dashes⟩ 30 | -- > symbol → ascSymbol | uniSymbol⟨special | _ | " | '⟩ 31 | -- > uniSymbol → any Unicode symbol or punctuation 32 | haskellOpChar :: Char -> Bool 33 | haskellOpChar c = 34 | IntSet.member (Char.ord c) opChars 35 | || (IntSet.notMember (Char.ord c) exceptions 36 | && isSymbolCharacterCategory (Char.generalCategory c)) 37 | where 38 | opChars = IntSet.fromList $ map Char.ord "-!#$%&*+./<=>?@^|~:\\" 39 | exceptions = IntSet.fromList $ map Char.ord "_\"'" 40 | 41 | isSymbolCharacterCategory :: Char.GeneralCategory -> Bool 42 | isSymbolCharacterCategory cat = Set.member cat symbolCategories 43 | where 44 | symbolCategories :: Set.Set Char.GeneralCategory 45 | symbolCategories = Set.fromList 46 | [ Char.ConnectorPunctuation 47 | , Char.DashPunctuation 48 | , Char.OtherPunctuation 49 | , Char.MathSymbol 50 | , Char.CurrencySymbol 51 | , Char.ModifierSymbol 52 | , Char.OtherSymbol 53 | ] 54 | 55 | -- * list 56 | 57 | -- | List initial and final element, if any. 58 | unsnoc :: [a] -> Maybe ([a], a) 59 | unsnoc [] = Nothing 60 | unsnoc (x:xs) = Just $ go x xs 61 | where 62 | go x [] = ([], x) 63 | go x (x':xs) = let (pre, post) = go x' xs in (x:pre, post) 64 | 65 | -- | Concat a list with 'sep' in between. 66 | join :: [a] -> [[a]] -> [a] 67 | join = List.intercalate 68 | 69 | -- | Split 'xs' on 'sep', dropping 'sep' from the result. 70 | split :: (Eq a) => [a] -> [a] -> [[a]] 71 | split = Split.splitOn 72 | 73 | -- | Split where the function matches. 74 | splitWith :: (a -> Bool) -> [a] -> [[a]] 75 | splitWith f xs = map reverse (go f xs []) 76 | where 77 | go _ [] collect = [collect] 78 | go f (x:xs) collect 79 | | f x = collect : go f xs [x] 80 | | otherwise = go f xs (x:collect) 81 | 82 | head :: [a] -> Maybe a 83 | head [] = Nothing 84 | head (x:_) = Just x 85 | 86 | sortOn :: (Ord k) => (a -> k) -> [a] -> [a] 87 | sortOn key = List.sortBy (compare `Function.on` key) 88 | 89 | groupOn :: (Eq k) => (a -> k) -> [a] -> [[a]] 90 | groupOn key = List.groupBy ((==) `Function.on` key) 91 | 92 | minimumOn :: Ord k => (a -> k) -> [a] -> Maybe a 93 | minimumOn _ [] = Nothing 94 | minimumOn key xs = Just (List.foldl1' f xs) 95 | where f low x = if key x < key low then x else low 96 | 97 | -- | Like 'List.partition', but partition by two functions consecutively. 98 | partition2 :: (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a]) 99 | partition2 f1 f2 xs = (as, bs, xs3) 100 | where 101 | (as, xs2) = List.partition f1 xs 102 | (bs, xs3) = List.partition f2 xs2 103 | 104 | zipPrev :: [a] -> [(a, a)] 105 | zipPrev xs = zip xs (drop 1 xs) 106 | 107 | -- | Modify a list at the first place the predicate matches. 108 | modifyAt :: (a -> Bool) -> (a -> a) -> [a] -> Maybe [a] 109 | modifyAt match modify = go 110 | where 111 | go [] = Nothing 112 | go (x:xs) 113 | | match x = Just (modify x : xs) 114 | | otherwise = (x:) <$> go xs 115 | 116 | setmap :: (Ord k, Ord a) => [(k, a)] -> Map.Map k (Set.Set a) 117 | setmap = Map.fromAscList 118 | . map (\gs -> (fst (List.head gs), Set.fromList (map snd gs))) 119 | . groupOn fst . sortOn fst 120 | 121 | multimap :: Ord k => [(k, a)] -> Map.Map k [a] 122 | multimap = Map.fromAscList . map (\gs -> (fst (List.head gs), map snd gs)) 123 | . groupOn fst . sortOn fst 124 | 125 | partitionOn :: (a -> Maybe b) -> [a] -> ([b], [a]) 126 | partitionOn f = go 127 | where 128 | go [] = ([], []) 129 | go (x:xs) = case f x of 130 | Just b -> (b:bs, as) 131 | Nothing -> (bs, x:as) 132 | where (bs, as) = go xs 133 | 134 | uniqueOn :: Ord k => (a -> k) -> [a] -> [a] 135 | uniqueOn key xs = Map.elems $ Map.fromList $ zip (map key xs) xs 136 | 137 | -- * control 138 | 139 | ifM :: Monad m => m Bool -> m a -> m a -> m a 140 | ifM cond consequent alternative = do 141 | b <- cond 142 | if b then consequent else alternative 143 | 144 | partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) 145 | partitionM f = go [] [] 146 | where 147 | go ts fs [] = return (ts, fs) 148 | go ts fs (x:xs) = ifM (f x) (go (x:ts) fs xs) (go ts (x:fs) xs) 149 | 150 | anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool 151 | anyM _ [] = return False 152 | anyM f (x:xs) = ifM (f x) (return True) (anyM f xs) 153 | 154 | -- | If @op@ raised ENOENT, return Nothing. 155 | catchENOENT :: IO a -> IO (Maybe a) 156 | catchENOENT op = Exception.handleJust (guard . IO.Error.isDoesNotExistError) 157 | (const (return Nothing)) (fmap Just op) 158 | 159 | -- * file 160 | 161 | listDir :: FilePath -> IO [FilePath] 162 | listDir dir = fmap (map add . filter (not . (`elem` [".", ".."]))) 163 | (Directory.getDirectoryContents dir) 164 | where add = if dir == "." then id else (dir ) 165 | 166 | -- | Similar to System.Process.readProcessWithExitCode but return Text instead 167 | -- of String. 168 | readProcessWithExitCode :: FilePath -> [String] 169 | -> IO (Exit.ExitCode, T.Text, T.Text) 170 | readProcessWithExitCode cmd args = do 171 | (_, Just outh, Just errh, pid) <- 172 | Process.createProcess (Process.proc cmd args) 173 | { Process.std_out = Process.CreatePipe 174 | , Process.std_err = Process.CreatePipe 175 | } 176 | outMVar <- MVar.newEmptyMVar 177 | errMVar <- MVar.newEmptyMVar 178 | void $ Concurrent.forkIO $ 179 | MVar.putMVar outMVar =<< Text.IO.hGetContents outh 180 | void $ Concurrent.forkIO $ 181 | MVar.putMVar errMVar =<< Text.IO.hGetContents errh 182 | out <- MVar.takeMVar outMVar 183 | err <- MVar.takeMVar errMVar 184 | IO.hClose outh 185 | IO.hClose errh 186 | ex <- Process.waitForProcess pid 187 | return (ex, out, err) 188 | -------------------------------------------------------------------------------- /src/FixImports/Main.hs: -------------------------------------------------------------------------------- 1 | -- | Main file for FixImports that uses the default formatting. It reads 2 | -- a config file from the current directory. 3 | -- 4 | -- More documentation in "FixImports". 5 | {-# LANGUAGE DisambiguateRecordFields #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | module FixImports.Main (main) where 9 | import qualified Control.Exception as Exception 10 | import Control.Monad (unless, when) 11 | import qualified Data.List as List 12 | import Data.Maybe (fromMaybe) 13 | import qualified Data.Set as Set 14 | import qualified Data.Text as Text 15 | import qualified Data.Text.IO as Text.IO 16 | import qualified Data.Version as Version 17 | 18 | import qualified System.Console.GetOpt as GetOpt 19 | import qualified System.Directory as Directory 20 | import qualified System.Environment as Environment 21 | import qualified System.Exit as Exit 22 | import qualified System.IO as IO 23 | 24 | import qualified FixImports.Config as Config 25 | import qualified FixImports.FixImports as FixImports 26 | import qualified FixImports.Types as Types 27 | import qualified FixImports.Util as Util 28 | 29 | import qualified Paths_fix_imports 30 | 31 | 32 | main :: IO () 33 | main = do 34 | -- I need the module path to search for modules relative to it first. I 35 | -- could figure it out from the parsed module name, but a main module may 36 | -- not have a name. 37 | (modulePath, flags) <- parseArgs =<< Environment.getArgs 38 | (config, errors) <- 39 | fromMaybe (Config.empty, []) <$> case [fn | Config fn <- flags] of 40 | [] -> findConfig 41 | fns -> readConfig (last fns) 42 | if null errors 43 | then mainConfig config flags modulePath 44 | else do 45 | Text.IO.hPutStrLn IO.stderr $ Text.unlines errors 46 | Exit.exitFailure 47 | 48 | findConfig :: IO (Maybe (Config.Config, [Text.Text])) 49 | findConfig = firstJust . map readConfig =<< getConfigLocations 50 | 51 | getConfigLocations :: IO [FilePath] 52 | getConfigLocations = sequence 53 | [ return ".fix-imports" 54 | , Directory.getXdgDirectory Directory.XdgConfig "fix-imports" 55 | ] 56 | 57 | firstJust :: [IO (Maybe a)] -> IO (Maybe a) 58 | firstJust [] = return Nothing 59 | firstJust (x : xs) = maybe (firstJust xs) (return . Just) =<< x 60 | 61 | readConfig :: FilePath -> IO (Maybe (Config.Config, [Text.Text])) 62 | readConfig = fmap (fmap Config.parse) . Util.catchENOENT . Text.IO.readFile 63 | 64 | mainConfig :: Config.Config -> [Flag] -> FilePath -> IO () 65 | mainConfig config flags modulePath = do 66 | let (verbose, debug, includes, mbPkgCache) = extractFlags flags 67 | source <- IO.getContents 68 | config <- return $ config 69 | { Config._includes = includes ++ Config._includes config 70 | , Config._debug = debug 71 | } 72 | (result, logs) <- FixImports.fixModule config mbPkgCache modulePath source 73 | `Exception.catch` \(exc :: Exception.SomeException) -> 74 | return (Left $ "exception: " ++ show exc, []) 75 | case result of 76 | Left err -> do 77 | if Edit `elem` flags then putStrLn "0,0" else putStr source 78 | when debug $ mapM_ (Text.IO.hPutStrLn IO.stderr) logs 79 | IO.hPutStrLn IO.stderr $ "error: " ++ err 80 | Exit.exitFailure 81 | Right (FixImports.Result range imports added removed metrics) -> do 82 | if Edit `elem` flags 83 | then do 84 | putStrLn $ show (fst range) <> "," <> show (snd range) 85 | putStr imports 86 | else putStr $ FixImports.substituteImports imports range source 87 | let names = Util.join ", " . map Types.moduleName . Set.toList 88 | (addedMsg, removedMsg) = (names added, names removed) 89 | mDone <- FixImports.metric metrics "done" 90 | when debug $ mapM_ (Text.IO.hPutStrLn IO.stderr) logs 91 | Config.debug config $ Text.stripEnd $ 92 | FixImports.showMetrics (mDone : metrics) 93 | when (verbose && not (null addedMsg) || not (null removedMsg)) $ 94 | IO.hPutStrLn IO.stderr $ Util.join "; " $ filter (not . null) 95 | [ if null addedMsg then "" else "added: " ++ addedMsg 96 | , if null removedMsg then "" else "removed: " ++ removedMsg 97 | ] 98 | Exit.exitSuccess 99 | 100 | data Flag = 101 | Config FilePath | Debug | Edit | Help | Include String 102 | | PackageCache String 103 | | Verbose 104 | deriving (Eq, Show) 105 | 106 | options :: [FilePath] -> [GetOpt.OptDescr Flag] 107 | options configLocations = 108 | [ GetOpt.Option ['c'] ["config"] (GetOpt.ReqArg Config "path") $ 109 | "path to config file, otherwise will look in " 110 | <> List.intercalate ", " configLocations 111 | , GetOpt.Option [] ["debug"] (GetOpt.NoArg Debug) 112 | "print debugging info on stderr" 113 | , GetOpt.Option [] ["edit"] (GetOpt.NoArg Edit) 114 | "print delete range and new import block, rather than the whole file" 115 | , GetOpt.Option [] ["help"] (GetOpt.NoArg Help) "show usage" 116 | , GetOpt.Option ['i'] [] (GetOpt.ReqArg Include "path") 117 | "add to module include path" 118 | , GetOpt.Option [] ["package-cache"] (GetOpt.ReqArg PackageCache "path") $ 119 | "path to package.cache file, use instead of .ghc.environment or ghc-pkg" 120 | , GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose) 121 | "print added and removed modules on stderr" 122 | ] 123 | 124 | parseArgs :: [String] -> IO (String, [Flag]) 125 | parseArgs args = do 126 | configLocations <- getConfigLocations 127 | case GetOpt.getOpt GetOpt.Permute (options configLocations) args of 128 | (flags, _, _) | Help `elem` flags -> usage "" 129 | (flags, [modulePath], []) -> return (modulePath, flags) 130 | (_, _, errs@(_:_)) -> Exit.die $ List.intercalate "\n" errs 131 | (_, args@(_:_), []) -> Exit.die $ "too many args: " <> show args 132 | (_, [], []) -> Exit.die "got zero args" 133 | 134 | extractFlags :: [Flag] -> (Bool, Bool, [FilePath], Maybe FilePath) 135 | extractFlags flags = 136 | ( Verbose `elem` flags 137 | , Debug `elem` flags 138 | , "." : [p | Include p <- flags] 139 | , Util.head [p | PackageCache p <- flags] 140 | ) 141 | -- Includes always have the current directory first. 142 | 143 | usage :: String -> IO a 144 | usage msg = do 145 | name <- Environment.getProgName 146 | configLocations <- getConfigLocations 147 | unless (null msg) $ 148 | IO.hPutStr IO.stderr msg 149 | IO.hPutStr IO.stderr $ GetOpt.usageInfo (name ++ " Module.hs )) 15 | import qualified Data.Either as Either 16 | import qualified Data.List as List 17 | import qualified Data.Map as Map 18 | import qualified Data.Maybe as Maybe 19 | import qualified Data.Set as Set 20 | import qualified Data.Text as Text 21 | import qualified Data.Text.IO as Text.IO 22 | import qualified GHC.Paths 23 | 24 | import qualified System.Directory as Directory 25 | import qualified System.IO as IO 26 | 27 | import qualified FixImports.PkgCache as PkgCache 28 | import qualified FixImports.Types as Types 29 | import qualified FixImports.Util as Util 30 | 31 | 32 | -- | Map from tails of the each module in the package db to its module name. 33 | -- So @List@ and @Data.List@ will map to @Data.List@. Modules from a set 34 | -- of core packages, like base and containers, will take priority, so even if 35 | -- there's a package with @Some.Obscure.List@, @List@ will still map to 36 | -- @Data.List@. 37 | type Index = Map.Map Types.Qualification [(Package, Types.ModuleName)] 38 | 39 | -- | Package name without the version. 40 | type Package = String 41 | 42 | empty :: Index 43 | empty = Map.empty 44 | 45 | load :: Maybe FilePath -> IO (Index, Text) 46 | load (Just pkgCache) = do 47 | unitNameModules <- PkgCache.loadCache pkgCache 48 | return 49 | ( makeIndex $ map (fmap (map Types.ModuleName)) $ 50 | map snd unitNameModules 51 | , "--package-cache flag" 52 | ) 53 | load Nothing = fromGhcEnvironment >>= \case 54 | Just index -> return (index, ".ghc.environment") 55 | Nothing -> (, "global ghc-pkg") <$> fromGhcPkg 56 | 57 | showIndex :: Index -> Text 58 | showIndex index = Text.unlines 59 | [ Text.pack k <> ": " <> Text.pack (show v) 60 | | (Types.Qualification k, v) <- Map.toAscList index 61 | ] 62 | 63 | -- | I think the global package db is always under the libdir? 64 | bootPkgDb :: FilePath 65 | bootPkgDb = GHC.Paths.libdir "package.conf.d" 66 | 67 | fromGhcEnvironment :: IO (Maybe Index) 68 | fromGhcEnvironment = parseGhcEnvironment >>= \case 69 | Nothing -> return Nothing 70 | Just (pkgDbs, unitIds) -> do 71 | nameModules <- PkgCache.load (Set.fromList unitIds) 72 | (bootPkgDb : pkgDbs) 73 | return $ Just $ makeIndex $ 74 | map (fmap (map Types.ModuleName)) nameModules 75 | 76 | -- | The code to write .ghc.environment is in Cabal 77 | -- Distribution.Simple.GHC.Internal, the code to read it is copy pasted over 78 | -- into cabal-install Distribution.Client.CmdInstall. So they're not even 79 | -- thinking of being consistent with themselves, let alone anyone else. 80 | -- Too much bother. 81 | parseGhcEnvironment :: IO (Maybe ([FilePath], [PkgCache.UnitId])) 82 | parseGhcEnvironment = do 83 | envFiles <- filter (".ghc.environment." `List.isPrefixOf`) <$> 84 | Directory.listDirectory "." 85 | case envFiles of 86 | [] -> return Nothing 87 | [envFile] -> Just . parseEnvFile <$> Text.IO.readFile envFile 88 | _ -> error $ "multiple ghc env files: " <> unwords envFiles 89 | 90 | parseEnvFile :: Text -> ([FilePath], [PkgCache.UnitId]) 91 | parseEnvFile = Either.partitionEithers . mapMaybe parse . Text.lines 92 | where 93 | parse line = case Text.words line of 94 | ["package-db", path] -> Just $ Left $ Text.unpack path 95 | ["package-id", unit] -> Just $ Right unit 96 | _ -> Nothing 97 | -- clear-package-db 98 | -- global-package-db 99 | -- package-db /Users/elaforge/.cabal/store/ghc-9.2.5/package.db 100 | -- package-db dist-newstyle/packagedb/ghc-9.2.5 101 | -- package-id hlibgit2-0.18.0.16-inplace 102 | -- package-id base-4.16.4.0 103 | -- package-id bndngs-DSL-1.0.25-d82df022 104 | 105 | fromGhcPkg :: IO Index 106 | fromGhcPkg = do 107 | (_, out, err) <- Util.readProcessWithExitCode "ghc-pkg" 108 | ["field", "*", "name,exposed,exposed-modules"] 109 | unless (Text.null err) $ 110 | IO.hPutStrLn IO.stderr $ "stderr from ghc-pkg: " ++ Text.unpack err 111 | let (errors, index) = parseDump out 112 | unless (null errors) $ 113 | IO.hPutStrLn IO.stderr $ "errors parsing ghc-pkg output: " 114 | ++ List.intercalate ", " errors 115 | return index 116 | 117 | makeIndex :: [(Text, [Types.ModuleName])] -- ^ [(package, modules)] 118 | -> Index 119 | makeIndex packages = Map.fromListWith (++) 120 | [ (qual, [(Text.unpack package, mod)]) 121 | | (package, modules) <- packages 122 | , mod <- modules 123 | , qual <- moduleQualifications mod 124 | ] 125 | 126 | parseDump :: Text -> ([String], Index) 127 | parseDump text = (errors, makeIndex packages) 128 | where 129 | (errors, packages) = Either.partitionEithers $ 130 | extractSections (parseGhcPkg text) 131 | 132 | extractSections :: [(Text, [Text])] 133 | -> [Either String (Text, [Types.ModuleName])] 134 | extractSections = Maybe.mapMaybe extract . Util.splitWith ((=="name") . fst) 135 | where 136 | extract [ ("name", [name]) 137 | , ("exposed", [exposed]) 138 | , ("exposed-modules", modules) 139 | ] 140 | | exposed /= "True" = Nothing 141 | | otherwise = Just $ 142 | Right (name, map (Types.ModuleName . Text.unpack) modules) 143 | -- It may be missing exposed-modules, but that means I don't need it. 144 | extract _ = Nothing 145 | 146 | -- | Take a module name to all its possible qualifications, i.e. its list 147 | -- of suffixes. 148 | moduleQualifications :: Types.ModuleName -> [Types.Qualification] 149 | moduleQualifications = map (Types.Qualification . Util.join ".") 150 | . filter (not . null) . List.tails . Util.split "." . Types.moduleName 151 | 152 | parseGhcPkg :: Text -> [(Text, [Text])] 153 | parseGhcPkg = map (second (map uncomma . concatMap Text.words)) . parseSections 154 | where 155 | -- Somewhere in 9.2, ghc-pkg switched from space separated to comma 156 | -- separated. 157 | uncomma t = Maybe.fromMaybe t (Text.stripSuffix "," t) 158 | 159 | parseSections :: Text -> [(Text, [Text])] -- ^ [(section_name, lines)] 160 | parseSections = List.unfoldr parseSection . stripComments . Text.lines 161 | 162 | stripComments :: [Text] -> [Text] 163 | stripComments = 164 | filter (not . Text.null) . map (Text.stripEnd . fst . Text.breakOn "--") 165 | 166 | -- | Consume a "tag: xyz" plus indents until the next dedented section. 167 | parseSection :: [Text] -> Maybe ((Text, [Text]), [Text]) 168 | parseSection [] = Nothing 169 | parseSection (x:xs) = Just 170 | ( (tag, map Text.strip (Text.drop 1 rest : pre)) 171 | , post 172 | ) 173 | where 174 | (tag, rest) = Text.break (==':') x 175 | (pre, post) = span (" " `Text.isPrefixOf`) xs 176 | 177 | 178 | -- * read cache 179 | 180 | 181 | -------------------------------------------------------------------------------- /src/FixImports/FixImports_test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module FixImports.FixImports_test where 4 | import Control.Monad (unless, void) 5 | import qualified Control.Monad.Identity as Identity 6 | import qualified Control.Monad.State.Strict as State 7 | import Data.Bifunctor (bimap) 8 | import qualified Data.List as List 9 | import qualified Data.Map as Map 10 | import qualified Data.Maybe as Maybe 11 | import qualified Data.Set as Set 12 | import qualified Data.Text as Text 13 | import qualified Data.Time.Clock.POSIX as Clock.POSIX 14 | import qualified System.IO.Unsafe as Unsafe 15 | 16 | import qualified System.FilePath as FilePath 17 | 18 | import qualified FixImports.Config as Config 19 | import qualified FixImports.FixImports as FixImports 20 | import qualified FixImports.Index as Index 21 | import qualified FixImports.Types as Types 22 | 23 | import EL.Test.Global 24 | 25 | 26 | test_simple = do 27 | let run = fmap FixImports.resultImports 28 | . fixModule index ["C.hs"] (mkConfig "") "A.hs" 29 | index = Index.makeIndex 30 | [ ("pkg", ["A.B"]) 31 | , ("zpkg", ["Z"]) 32 | ] 33 | rightEqual (run "x = B.c") "import qualified A.B as B\n" 34 | rightEqual (run "x = A.B.c") "import qualified A.B\n" 35 | leftLike (run "x = Q.c") "not found: Q" 36 | -- Remove unused. 37 | rightEqual (run "import qualified A.B as B\n\nx = y") "" 38 | -- Unless it's unqualified. 39 | rightEqual (run "import A.B as B\n\nx = y") 40 | "import A.B as B\n" 41 | 42 | -- Local goes below package. 43 | rightEqual (run "x = (B.a, C.a, Z.a)") 44 | "import qualified A.B as B\n\ 45 | \import qualified Z\n\ 46 | \\n\ 47 | \import qualified C\n" 48 | 49 | -- Don't mess with imports I don't manage. 50 | rightEqual (run "import A.B hiding (mod)\n") "import A.B hiding (mod)\n" 51 | rightEqual (run "import A.B\n") "import A.B\n" 52 | -- remove redundant imports 53 | rightEqual (run "import qualified Z\nimport qualified Z\nf = Z.a") 54 | "import qualified Z\n" 55 | 56 | test_comments = do 57 | let run = fmap FixImports.resultImports 58 | . fixModule index [] (mkConfig "") "A.hs" 59 | index = Index.makeIndex [("pkg", ["A", "B"])] 60 | rightEqual (run "import A") "import A\n" 61 | -- Comments out of the edited range are not affected. 62 | rightEqual 63 | (run 64 | "-- before\n\ 65 | \module M where -- where\ 66 | \-- above\n\ 67 | \import A\n\ 68 | \-- below") 69 | "import A\n" 70 | rightEqual 71 | (run 72 | "module M where\n\ 73 | \import A\n\ 74 | \-- above1\n\ 75 | \-- above2\n\ 76 | \import B {- right -}\n") 77 | 78 | "import A\n\ 79 | \-- above1\n\ 80 | \-- above2\n\ 81 | \import B {- right -}\n" 82 | 83 | test_qualifyAs = do 84 | let run config files = fmap eResult . fixModule index files config "A.hs" 85 | config = mkConfig "qualify-as: Data.Text.Lazy as DTL" 86 | index = Index.makeIndex [("text", ["Data.Text.Lazy"]), ("pkg", ["A"])] 87 | rightEqual (run config [] "x = DTL.y") 88 | ( ["Data.Text.Lazy"] 89 | , [] 90 | , "import qualified Data.Text.Lazy as DTL\n" 91 | ) 92 | rightEqual (run config [] "import qualified Data.Text.Lazy as DTL\n") 93 | ( [] 94 | , ["Data.Text.Lazy"] 95 | , "" 96 | ) 97 | 98 | -- qualifyAs aliases are prioritized in the same way as others, so 99 | -- the local module wins: 100 | rightEqual (run config ["DTL.hs"] "x = DTL.y") 101 | (["DTL"], [], "import qualified DTL\n") 102 | 103 | -- Unless explicitly suppressed: 104 | let config2 = mkConfig $ Text.unlines 105 | [ "qualify-as: Data.Text.Lazy as DTL" 106 | , "prio-module-high: Data.Text.Lazy" 107 | ] 108 | rightEqual (run config2 ["DTL.hs"] "x = DTL.y") 109 | ( ["Data.Text.Lazy"] 110 | , [] 111 | , "import qualified Data.Text.Lazy as DTL\n" 112 | ) 113 | 114 | -- strip duplicates 115 | rightEqual (run config2 [] 116 | "import qualified Data.Text.Lazy as DTL\n\ 117 | \import qualified Data.Text.Lazy as DTL\n\ 118 | \x = DTL.y") 119 | ([], [], "import qualified Data.Text.Lazy as DTL\n") 120 | -- not confused by other imports with the same name 121 | rightEqual (run config2 [] 122 | "import qualified A as DTL\n\ 123 | \import qualified Data.Text.Lazy as DTL\n\ 124 | \x = DTL.y") 125 | ( [] 126 | , [] 127 | , "import qualified A as DTL\nimport qualified Data.Text.Lazy as DTL\n" 128 | ) 129 | 130 | test_unqualified = do 131 | let run config = fmap eResult 132 | . fixModule index ["C.hs"] (mkConfig ("unqualified: " <> config)) 133 | "A.hs" 134 | index = Index.makeIndex 135 | [ ("pkg", ["A.B"]) 136 | , ("zpkg", ["Z"]) 137 | ] 138 | rightEqual (run "A.B (c)" "x = (c, c)") 139 | ( ["A.B"] 140 | , [] 141 | , "import A.B (c)\n" 142 | ) 143 | -- Modify an existing import. 144 | rightEqual (run "A.B (c)" "import A.B (a, z)\nx = (c, c)") 145 | ( [] 146 | , [] 147 | , "import A.B (a, c, z)\n" 148 | ) 149 | -- Remove an unused one, if I'm managing it. 150 | rightEqual (run "A.B (a, c)" "import A.B (a, c)\nx = a") 151 | ( [] 152 | , [] 153 | , "import A.B (a)\n" 154 | ) 155 | -- Don't accumulate duplicates. 156 | rightEqual (run "A.B (c)" "import A.B (c)\nx = c") 157 | ([], [], "import A.B (c)\n") 158 | rightEqual (run "A.B (C)" "import A.B (C)\nx :: C") 159 | ([], [], "import A.B (C)\n") 160 | -- Don't manage it if it's not mine. 161 | rightEqual (run "A.B (c)" "import A.B (d)") 162 | ([], [], "import A.B (d)\n") 163 | -- local still goes below package 164 | rightEqual (run "C (a)" "import A.B\nimport Z\nx = a") 165 | ( ["C"] 166 | , [] 167 | , "import A.B\n\ 168 | \import Z\n\ 169 | \\n\ 170 | \import C (a)\n" 171 | ) 172 | -- Don't import when it's on the lhs. 173 | rightEqual (run "A.B (c)" "c = x") ([], [], "") 174 | rightEqual (run "A.B (())" "x = a b") 175 | (["A.B"], [], "import A.B (())\n") 176 | -- Add and remove operators 177 | rightEqual (run "A.B (())" "x = a b") 178 | (["A.B"], [], "import A.B (())\n") 179 | rightEqual (run "A.B (())" "import A.B (())\nx = a b") 180 | ([], ["A.B"], "") 181 | -- Removed unused. 182 | rightEqual (run "A.B (c)" "import A.B (c)\nx = x\n") ([], ["A.B"], "") 183 | rightEqual 184 | (run "A.B (c)" 185 | "import A.B (c)\nimport A.B (c, d)\nimport A.B (d)\nx = d\n") 186 | ([], [], "import A.B (d)\n") 187 | -- But not if it's a everything-import. 188 | rightEqual (run "A.B (c)" "import A.B\nx = x\n") ([], [], "import A.B\n") 189 | -- Ignore if it's already imported unqualified. 190 | rightEqual (run "A.B (c)" "import Z (c)\nx = c") ([], [], "import Z (c)\n") 191 | 192 | 193 | -- * implementation 194 | 195 | eResult :: FixImports.Result -> ([Types.ModuleName], [Types.ModuleName], String) 196 | eResult r = 197 | ( Set.toList (FixImports.resultAdded r) 198 | , Set.toList (FixImports.resultRemoved r) 199 | , FixImports.resultImports r 200 | ) 201 | 202 | fixModule :: Index.Index -> [FilePath] 203 | -> Config.Config -> FilePath -> String -> Either String FixImports.Result 204 | fixModule index files config modulePath source = 205 | case Unsafe.unsafePerformIO $ 206 | FixImports.parse (Config._language config) modulePath source of 207 | Left err -> Left err 208 | Right (mod, cmts) -> 209 | fst $ Identity.runIdentity $ flip State.runStateT [] $ 210 | FixImports.fixImports (pureFilesystem files) config index 211 | modulePath (FixImports.extract config mod cmts) 212 | 213 | -- | The ./ stuff is tricky, this is probably still wrong. 214 | pureFilesystem :: [FilePath] -> FixImports.Filesystem Identity.Identity 215 | pureFilesystem files = FixImports.Filesystem 216 | { _listDir = \dir -> return 217 | . Maybe.fromMaybe ([], []) . (`Map.lookup` tree) $ dir 218 | , _doesFileExist = \fn -> return . (`elem` files) . normalize $ fn 219 | , _metric = \_ _ -> 220 | return (Clock.POSIX.posixSecondsToUTCTime 0, Text.pack "metric") 221 | } 222 | where 223 | tree = filesToTree (map ("./"++) files) 224 | normalize ('.':'/':fn) = fn 225 | normalize fn = fn 226 | 227 | -- group by first element, then second, etc. 228 | filesToTree :: [FilePath] -> Map.Map FilePath ([FilePath], [FilePath]) 229 | -- ^ (dirs, files) 230 | filesToTree = Map.fromList 231 | . map (bimap (List.dropWhileEnd (=='/')) separate) . groupFst 232 | . concatMap prefixes 233 | where 234 | separate [""] = ([], []) 235 | separate subs = (unique $ map (takeWhile (/='/')) dirs, files) 236 | where (dirs, files) = List.partition ('/' `elem`) subs 237 | 238 | prefixes :: FilePath -> [(FilePath, FilePath)] 239 | prefixes = map (bimap concat concat) . drop 1 240 | . (\xs -> zip (List.inits xs) (List.tails xs)) . FilePath.splitPath 241 | 242 | mkConfig :: Text.Text -> Config.Config 243 | mkConfig content 244 | | null errs = config { Config._includes = ["."] } 245 | | otherwise = error $ "parsing " <> show content <> ": " 246 | <> unlines (map Text.unpack errs) 247 | where (config, errs) = Config.parse content 248 | 249 | -- * util 250 | 251 | type NonNull a = [a] 252 | 253 | -- | Similar to 'keyedGroupSort', but key on the fst element, and strip the 254 | -- key out of the groups. 255 | groupFst :: Ord a => [(a, b)] -> [(a, NonNull b)] 256 | groupFst xs = [(key, map snd group) | (key, group) <- keyedGroupSort fst xs] 257 | 258 | -- | Group the unsorted list into @(key x, xs)@ where all @xs@ compare equal 259 | -- after @key@ is applied to them. 260 | keyedGroupSort :: Ord key => (a -> key) -> [a] -> [(key, NonNull a)] 261 | -- ^ Sorted by key. The NonNull group is in the same order as the input. 262 | keyedGroupSort key = Map.toAscList . foldr go Map.empty 263 | where go x = Map.alter (Just . maybe [x] (x:)) (key x) 264 | 265 | unique :: Ord a => [a] -> [a] 266 | unique = Set.toList . Set.fromList 267 | -------------------------------------------------------------------------------- /src/FixImports/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} -- without it extractEntity unvar unhappy 10 | module FixImports.Parse ( 11 | -- * types 12 | Module 13 | , Comment(..) 14 | -- * parse 15 | , parse 16 | -- * extract 17 | , qualifications 18 | , unqualifieds 19 | , importRange 20 | -- ** Import 21 | , extractImports 22 | 23 | -- TESTING 24 | , unqualifiedValues, unqualifiedTypes 25 | ) where 26 | import Control.Applicative ((<|>)) 27 | import qualified Control.DeepSeq as DeepSeq 28 | import qualified Control.Monad as Monad 29 | import qualified Data.Char as Char 30 | import qualified Data.List as List 31 | import qualified Data.List.NonEmpty as NonEmpty 32 | import qualified Data.Maybe as Maybe 33 | import Data.Maybe (fromMaybe) 34 | import qualified Data.Set as Set 35 | 36 | import qualified Language.Haskell.GhclibParserEx.GHC.Parser as Parser 37 | import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as Config 38 | import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as ExSession 39 | 40 | import qualified GHC.Data.FastString as FastString 41 | import qualified GHC.Data.Strict as Strict 42 | import qualified GHC.Driver.Session as Session 43 | import qualified GHC.Driver.Ppr as Ppr 44 | import qualified GHC.Hs as Hs 45 | import qualified GHC.Hs.DocString as DocString 46 | import qualified GHC.Parser.Annotation as Annotation 47 | import qualified GHC.Parser.Lexer as Lexer 48 | import qualified GHC.Types.Error as Error 49 | import qualified GHC.Types.Name.Occurrence as Occurrence 50 | import qualified GHC.Types.Name.Reader as Reader 51 | import qualified GHC.Types.SourceText as SourceText 52 | import qualified GHC.Types.SrcLoc as SrcLoc 53 | import qualified GHC.Types.PkgQual as PkgQual 54 | import qualified GHC.Data.Bag as Bag 55 | import qualified GHC.Unit.Types as Unit.Types 56 | import qualified GHC.Utils.Error as Utils.Error 57 | import qualified Language.Haskell.Syntax.Module.Name as Name 58 | 59 | import qualified Data.Generics.Uniplate.Data as Uniplate 60 | 61 | import qualified FixImports.Types as Types 62 | import qualified FixImports.Util as Util 63 | 64 | 65 | -- * parse 66 | 67 | type Module = Hs.HsModule Hs.GhcPs 68 | 69 | type Src = String 70 | 71 | -- | makeDynFlags forces parse into IO. The reason seems to be that GHC 72 | -- puts dyn flags in a global variable. 73 | parse :: [Types.Extension] -> FilePath -> Src 74 | -> IO (Either String (Module, [Comment])) 75 | parse extensions filename src = makeDynFlags extensions filename src >>= \case 76 | Left err -> return $ Left $ "parsing pragmas: " <> err 77 | Right dynFlags -> return $ parseFile filename dynFlags src 78 | 79 | data Comment = Comment { _span :: !Types.SrcSpan, _comment :: !String } 80 | deriving (Eq, Ord, Show) 81 | 82 | instance DeepSeq.NFData Comment where rnf (Comment _ cmt) = DeepSeq.rnf cmt 83 | 84 | makeDynFlags :: [Types.Extension] -> FilePath -> Src 85 | -> IO (Either String Session.DynFlags) 86 | makeDynFlags extensions fname src = 87 | ExSession.parsePragmasIntoDynFlags defaultDynFlags 88 | (extensions ++ defaultExtensions, []) fname src 89 | where defaultExtensions = Session.languageExtensions Nothing 90 | 91 | defaultDynFlags :: Session.DynFlags 92 | defaultDynFlags = Session.defaultDynFlags Config.fakeSettings 93 | 94 | -- | Parser.parseFile seems to return an unlifted type, even though I can't 95 | -- tell from the :t or the source. But it means you can't pass its result 96 | -- to a toplevel function. Weird. 97 | parseFile :: FilePath -> Session.DynFlags -> String 98 | -> Either String (Module, [Comment]) 99 | parseFile filename dynFlags src = case Parser.parseFile filename dynFlags src of 100 | Lexer.POk state val -> Right 101 | ( SrcLoc.unLoc val 102 | -- , [] 103 | , List.sort $ map extractComment (Lexer.comment_q state) 104 | ++ case Lexer.header_comments state of 105 | Strict.Nothing -> [] 106 | Strict.Just cs -> map extractComment cs 107 | ++ importComments (SrcLoc.unLoc val) 108 | -- Lexer.annotations_comments I think is supposed to have comments 109 | -- associated with their "attached" SrcSpan, whatever that is. 110 | -- In any case, it's empty for comments in the import block at least. 111 | ) 112 | Lexer.PFailed state -> Left $ unlines $ concat 113 | [ map ("warn: "<>) (extract warns) 114 | -- Looks like errors already start with "error: ". Dunno about warns. 115 | , extract errors 116 | ] 117 | where 118 | (warns, errors) = Lexer.getPsMessages state 119 | extract = 120 | map (Ppr.showSDoc dynFlags . Utils.Error.pprLocMsgEnvelopeDefault) 121 | . Bag.bagToList . Error.getMessages 122 | 123 | -- | Simplify a comment, this means I lose all the docstring details, but 124 | -- I think it's ok. 125 | extractComment :: Hs.LEpaComment -> Comment 126 | extractComment cmt = 127 | Comment (extractRealSrcSpan (Annotation.anchor (SrcLoc.getLoc cmt))) $ 128 | case Annotation.ac_tok (SrcLoc.unLoc cmt) of 129 | Annotation.EpaDocComment doc -> case doc of 130 | DocString.MultiLineDocString _decorator cs -> 131 | mconcat $ map (DocString.unpackHDSC . SrcLoc.unLoc) $ 132 | NonEmpty.toList cs 133 | DocString.NestedDocString _decorator c -> 134 | DocString.unpackHDSC (SrcLoc.unLoc c) 135 | DocString.GeneratedDocString c -> DocString.unpackHDSC c 136 | Annotation.EpaLineComment s -> s 137 | Annotation.EpaBlockComment s -> s 138 | Annotation.EpaDocOptions s -> s 139 | Annotation.EpaEofComment -> "" 140 | 141 | -- * extract 142 | 143 | importComments :: Module -> [Comment] 144 | importComments = 145 | map extractComment 146 | . concatMap (extract . extractAnn . Annotation.ann . SrcLoc.getLoc) 147 | . Hs.hsmodImports 148 | where 149 | extractAnn = \case 150 | Annotation.EpAnn _anchor _anns comments -> comments 151 | Annotation.EpAnnNotUsed -> Annotation.emptyComments 152 | extract = \case 153 | Annotation.EpaComments prior -> prior 154 | Annotation.EpaCommentsBalanced prior following -> prior ++ following 155 | 156 | -- | Qualifications of all the qualified names in this module. 157 | qualifications :: Module -> Set.Set Types.Qualification 158 | qualifications mod = Set.fromList 159 | [ Types.Qualification $ Name.moduleNameString moduleName 160 | | Reader.Qual moduleName _occName <- Uniplate.universeBi mod 161 | ] 162 | 163 | -- | All unqualified names which are referenced in the module. This is a lot 164 | -- more complicated than 'qualifications' because this needs to omit unqualified 165 | -- names which are defined in here. 166 | unqualifieds :: Module -> Set.Set Types.Name 167 | unqualifieds mod = unqualifiedTypes mod <> unqualifiedValues mod 168 | 169 | -- | TODO: this doesn't handle type operators yet. 170 | unqualifiedTypes :: Module -> Set.Set Types.Name 171 | unqualifiedTypes mod = Set.fromList $ do 172 | hsType :: Hs.HsType Hs.GhcPs <- Uniplate.universeBi mod 173 | Reader.Unqual occName <- Uniplate.universeBi hsType 174 | let var = Occurrence.occNameString occName 175 | -- I don't want type variables, since they aren't references. I can just 176 | -- filter out lower-case, which seems to be good enough? 177 | Monad.guard $ case var of 178 | c : _ -> Char.isUpper c 179 | _ -> False 180 | return $ inferName var 181 | 182 | unqualifiedValues :: Module -> Set.Set Types.Name 183 | unqualifiedValues mod = Set.fromList $ do 184 | (Hs.FunBind { fun_matches } :: Hs.HsBindLR Hs.GhcPs Hs.GhcPs) 185 | <- Uniplate.universeBi mod 186 | let matches = map SrcLoc.unLoc $ SrcLoc.unLoc $ Hs.mg_alts fun_matches 187 | -- I think 'pats' is the binding names. 188 | -- let pats = concatMap Hs.m_pats matches 189 | let rhss = map Hs.m_grhss matches 190 | Reader.Unqual occName <- Uniplate.universeBi rhss 191 | return $ inferName $ Occurrence.occNameString occName 192 | 193 | -- | Return half-open line range of import block, starting from (0 based) line 194 | -- of first import to the line after the last one. 195 | importRange :: Module -> (Int, Int) 196 | importRange mod = 197 | get . unzip . map range 198 | . Maybe.mapMaybe (getSpan . Annotation.locA . SrcLoc.getLoc) 199 | . Hs.hsmodImports $ mod 200 | where 201 | -- This range is 1-based inclusive, and I want 0-based half-open, so 202 | -- subtract 1 from the start. 203 | get :: ([Int], [Int]) -> (Int, Int) 204 | get (starts@(_:_), ends@(_:_)) = (minimum starts - 1, maximum ends) 205 | -- No imports, pick the line after export list or module header. 206 | get _ = fromMaybe (0, 0) $ do 207 | span <- getSpan =<< 208 | (Annotation.locA . SrcLoc.getLoc <$> Hs.hsmodExports mod) 209 | <|> (Annotation.locA . SrcLoc.getLoc <$> Hs.hsmodName mod) 210 | return (SrcLoc.srcSpanEndLine span, SrcLoc.srcSpanEndLine span) 211 | range span = (SrcLoc.srcSpanStartLine span, SrcLoc.srcSpanEndLine span) 212 | getSpan (SrcLoc.RealSrcSpan span _) = Just span 213 | getSpan _ = Nothing 214 | 215 | -- ** Import 216 | 217 | extractImports :: Module -> [Types.Import] 218 | extractImports = map extractImport . Hs.hsmodImports 219 | 220 | extractImport :: Hs.LImportDecl Hs.GhcPs -> Types.Import 221 | extractImport locDecl = Types.Import 222 | { _importName = Types.ModuleName $ Name.moduleNameString $ SrcLoc.unLoc $ 223 | Hs.ideclName decl 224 | , _importPkgQualifier = case Hs.ideclPkgQual decl of 225 | PkgQual.NoRawPkgQual -> Nothing 226 | PkgQual.RawPkgQual stringLit -> 227 | Just $ FastString.unpackFS $ SourceText.sl_fs stringLit 228 | , _importIsBoot = Hs.ideclSource decl == Unit.Types.IsBoot 229 | , _importSafe = Hs.ideclSafe decl 230 | -- I don't distinguish Hs.QualifiedPost 231 | , _importQualified = Hs.ideclQualified decl /= Hs.NotQualified 232 | , _importAs = Types.Qualification . Name.moduleNameString . SrcLoc.unLoc 233 | <$> Hs.ideclAs decl 234 | , _importHiding = case Hs.ideclImportList decl of 235 | Just (Hs.EverythingBut, _) -> True 236 | _ -> False 237 | , _importEntities = case Hs.ideclImportList decl of 238 | Just (_, things) -> 239 | Just $ map (extractEntity . SrcLoc.unLoc) $ SrcLoc.unLoc things 240 | _ -> Nothing 241 | , _importSpan = extractSrcSpan $ Annotation.locA $ SrcLoc.getLoc locDecl 242 | 243 | } 244 | where decl = SrcLoc.unLoc locDecl 245 | 246 | extractSrcSpan :: SrcLoc.SrcSpan -> Types.SrcSpan 247 | extractSrcSpan (SrcLoc.RealSrcSpan span _) = extractRealSrcSpan span 248 | extractSrcSpan (SrcLoc.UnhelpfulSpan fstr) = 249 | error $ "UnhelpfulSpan: " <> show fstr 250 | -- I think GHC uses these internally, in phases after Hs.GhcPs. 251 | 252 | extractRealSrcSpan :: SrcLoc.RealSrcSpan -> Types.SrcSpan 253 | extractRealSrcSpan span = Types.SrcSpan 254 | -- GHC SrcSpan has 1-based lines, I use 0-based ones. 255 | { _startLine = SrcLoc.srcSpanStartLine span - 1 256 | , _startCol = SrcLoc.srcSpanStartCol span 257 | , _endLine = SrcLoc.srcSpanEndLine span - 1 258 | , _endCol = SrcLoc.srcSpanEndCol span 259 | } 260 | 261 | extractEntity :: Hs.IE Hs.GhcPs -> Either Types.Error Types.Entity 262 | extractEntity = fmap entity . \case 263 | -- var 264 | Hs.IEVar _ var -> Right (unvar var, Nothing) 265 | -- Constructor 266 | Hs.IEThingAbs _ var -> Right (unvar var, Nothing) 267 | -- Constructor(..) 268 | Hs.IEThingAll _ var -> Right (unvar var, Just "(..)") 269 | -- Constructor(x, y) 270 | -- What is _wildcard? 271 | Hs.IEThingWith _ var _wildcard things -> Right 272 | ( unvar var 273 | , Just $ "(" <> List.intercalate ", " (map (varStr . unvar) things) 274 | <> ")" 275 | ) 276 | -- Shouldn't happen, export only. 277 | Hs.IEModuleContents {} -> Left "IEModuleContents" 278 | Hs.IEGroup {} -> Left "IEGroup" 279 | Hs.IEDoc {} -> Left "IEDoc" 280 | Hs.IEDocNamed {} -> Left "IEDocNamed" 281 | where 282 | entity ((qual, var), list) = Types.Entity qual var list 283 | unvar var = case SrcLoc.unLoc var of 284 | Hs.IEName _ n -> (Nothing, toName n) 285 | Hs.IEPattern _ n -> (Just "pattern", toName n) 286 | Hs.IEType _ n -> (Just "type", toName n) 287 | -- It's a DataConCantHappen, so I think supposed to not happen? 288 | Hs.XIEWrappedName _ -> (Just "??", Types.Name "XIEWrappedName") 289 | varStr (Just qual, name) = qual <> " " <> Types.showName name 290 | varStr (Nothing, name) = Types.showName name 291 | toName = inferName . unRdrName . SrcLoc.unLoc 292 | 293 | inferName :: String -> Types.Name 294 | inferName var 295 | | all Util.haskellOpChar var = Types.Operator var 296 | | otherwise = Types.Name var 297 | 298 | unRdrName :: Reader.RdrName -> String 299 | unRdrName = \case 300 | Reader.Unqual occName -> Occurrence.occNameString occName 301 | Reader.Qual mod occName -> 302 | Name.moduleNameString mod <> "." <> Occurrence.occNameString occName 303 | -- TODO what is this? 304 | Reader.Orig _mod occName -> -- modName mod <> 305 | "+" <> Occurrence.occNameString occName 306 | -- TODO what is this? 307 | Reader.Exact _name -> "exact" 308 | -------------------------------------------------------------------------------- /src/FixImports/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PartialTypeSignatures #-} -- sort keys only care about Ord 5 | {-# OPTIONS_GHC -Wno-partial-type-signatures #-} 6 | -- | Parse the config file. 7 | module FixImports.Config where 8 | import Control.Monad (foldM, unless) 9 | import Data.Bifunctor (second) 10 | import qualified Data.Char as Char 11 | import qualified Data.Either as Either 12 | import qualified Data.List as List 13 | import qualified Data.Map as Map 14 | import qualified Data.Text as Text 15 | import Data.Text (Text) 16 | import qualified Data.Text.IO as Text.IO 17 | import qualified Data.Tuple as Tuple 18 | 19 | import qualified System.FilePath as FilePath 20 | import qualified System.IO as IO 21 | import qualified Text.Read as Read 22 | 23 | import qualified FixImports.Index as Index 24 | import qualified FixImports.Types as Types 25 | import qualified FixImports.Util as Util 26 | 27 | 28 | data Config = Config { 29 | -- | Additional directories to search for local modules. Taken from the 30 | -- -i flag and 'include' config line. 31 | _includes :: [FilePath] 32 | -- | These language extensions are enabled by default. 33 | , _language :: [Types.Extension] 34 | -- | Import sort order. Used by 'formatGroups'. 35 | , _order :: Order 36 | -- | Heuristics to pick the right module. Used by 'pickModule'. 37 | , _modulePriority :: Priorities 38 | -- | Map unqualified names to the module to import for them. 39 | , _unqualified :: Map.Map Types.Name Types.ModuleName 40 | -- | Map abbreviation to the complete qualification: 41 | -- > import-as: Data.Text.Lazy as DTL -> [("DTL", "Data.Text.Lazy")] 42 | , _qualifyAs :: Map.Map Types.Qualification Types.Qualification 43 | , _format :: Format 44 | , _debug :: Bool 45 | } deriving (Eq, Show) 46 | 47 | data Order = Order { 48 | _importOrder :: Priority ModulePattern 49 | -- | Put unqualified import-all imports last. 50 | , _sortUnqualifiedLast :: Bool 51 | } deriving (Eq, Show) 52 | 53 | data Priorities = Priorities { 54 | -- | Place these packages either first or last in priority. 55 | prioPackage :: Priority Index.Package 56 | -- | Place these modules either first or last in priority. 57 | , prioModule :: Priority Types.ModuleName 58 | } deriving (Eq, Show) 59 | 60 | instance Semigroup Priorities where 61 | Priorities a1 b1 <> Priorities a2 b2 = Priorities (a1<>a2) (b1<>b2) 62 | instance Monoid Priorities where 63 | mempty = Priorities mempty mempty 64 | 65 | data Priority a = Priority { high :: [a], low :: [a] } 66 | deriving (Eq, Show) 67 | 68 | instance Semigroup (Priority a) where 69 | Priority a1 b1 <> Priority a2 b2 = Priority (a1<>a2) (b1<>b2) 70 | instance Monoid (Priority a) where 71 | mempty = Priority mempty mempty 72 | 73 | data Format = Format { 74 | -- | If true, group imports by their first component. 75 | _groupImports :: Bool 76 | -- | Insert space for unqualified imports to make the modules line up. 77 | , _leaveSpaceForQualified :: Bool 78 | -- | Number of columns to wrap to. 79 | , _columns :: Int 80 | -- | How many spaces to indent a wrapped line. 81 | , _wrapIndent :: Int 82 | } deriving (Eq, Show) 83 | 84 | -- | A simple pattern: @M.@ matches M and M.*. Anything else matches exactly. 85 | type ModulePattern = String 86 | 87 | matchModule :: ModulePattern -> Types.ModuleName -> Bool 88 | matchModule pattern (Types.ModuleName mod) = case Util.unsnoc pattern of 89 | Nothing -> False 90 | Just (parent, '.') -> parent == mod || pattern `List.isPrefixOf` mod 91 | _ -> pattern == mod 92 | 93 | empty :: Config 94 | empty = Config 95 | { _includes = [] 96 | , _language = [] 97 | , _order = Order 98 | { _importOrder = Priority { high = [], low = [] } 99 | , _sortUnqualifiedLast = False 100 | } 101 | , _modulePriority = mempty 102 | , _unqualified = mempty 103 | , _qualifyAs = mempty 104 | , _format = defaultFormat 105 | , _debug = False 106 | } 107 | 108 | defaultFormat :: Format 109 | defaultFormat = Format 110 | { _groupImports = True 111 | , _leaveSpaceForQualified = False 112 | , _columns = 80 113 | , _wrapIndent = 4 114 | } 115 | 116 | -- | Parse .fix-imports file. 117 | parse :: Text -> (Config, [Text]) 118 | parse text = (config, errors) 119 | where 120 | commas = Text.intercalate ", " 121 | errors = map (".fix-imports: "<>) $ concat 122 | [ [ "duplicate fields: " <> commas duplicates | not (null duplicates) ] 123 | , [ "unrecognized fields: " <> commas unknownFields 124 | | not (null unknownFields) 125 | ] 126 | , [ "unknown language extensions: " <> commas unknownLanguage 127 | | not (null unknownLanguage) 128 | ] 129 | , [ "unqualified: " <> commas unknownUnqualified 130 | | not (null unknownUnqualified) 131 | ] 132 | , [ "qualify-as: " <> commas unknownQualifyAs 133 | | not (null unknownQualifyAs) 134 | ] 135 | , maybe [] ((:[]) . ("format: "<>)) formatError 136 | ] 137 | config = empty 138 | { _includes = getStrings "include" 139 | , _language = language 140 | , _order = Order 141 | { _importOrder = Priority 142 | { high = getStrings "import-order-first" 143 | , low = getStrings "import-order-last" 144 | } 145 | , _sortUnqualifiedLast = getBool "sort-unqualified-last" 146 | } 147 | , _modulePriority = Priorities 148 | { prioPackage = Priority 149 | { high = getStrings "prio-package-high" 150 | , low = getStrings "prio-package-low" 151 | } 152 | , prioModule = Priority 153 | { high = getModules "prio-module-high" 154 | , low = getModules "prio-module-low" 155 | } 156 | } 157 | , _unqualified = Map.fromList $ map Tuple.swap unqualified 158 | , _format = format 159 | , _qualifyAs = qualifyAs 160 | } 161 | (unknownUnqualified, unqualified) = Either.partitionEithers $ 162 | parseUnqualified (Text.unwords (get "unqualified")) 163 | (unknownLanguage, language) = parseLanguage (get "language") 164 | (unknownQualifyAs, qualifyAs) = 165 | parseQualifyAs $ Text.unwords $ get "qualify-as" 166 | (format, formatError) = case parseFormat (get "format") of 167 | Right format -> (format, Nothing) 168 | Left err -> (defaultFormat, Just err) 169 | unknownFields = Map.keys fields List.\\ valid 170 | valid = 171 | [ "format" 172 | , "import-order-first", "import-order-last" 173 | , "include" 174 | , "language" 175 | , "prio-module-high", "prio-module-low" 176 | , "prio-package-high", "prio-package-low" 177 | , "qualify-as" 178 | , "sort-unqualified-last" 179 | , "unqualified" 180 | ] 181 | fields = fmap (concatMap Text.words) $ Map.fromList sections 182 | sections = Index.parseSections text 183 | duplicates = map head $ filter ((>1) . length) $ List.group $ List.sort $ 184 | map fst sections 185 | 186 | getModules = map (Types.ModuleName . Text.unpack) . get 187 | get k = Map.findWithDefault [] k fields 188 | getStrings = map Text.unpack . get 189 | getBool k = k `Map.member` fields 190 | 191 | parseFormat :: [Text] -> Either Text Format 192 | parseFormat = foldM set defaultFormat 193 | where 194 | set fmt "leave-space-for-qualified" = Right $ 195 | fmt { _leaveSpaceForQualified = True } 196 | set fmt "no-group" = Right $ fmt { _groupImports = False } 197 | set fmt w | Just cols <- Text.stripPrefix "columns=" w = 198 | case Read.readMaybe (Text.unpack cols) of 199 | Nothing -> Left $ "non-numeric: " <> w 200 | Just cols -> Right $ fmt { _columns = cols } 201 | set _ w = Left $ "unrecognized word: " <> showt w 202 | 203 | -- | 204 | -- "A.B(c); Q(r)" -> [Right ("A.B", "c"), Right ("Q", "r")] 205 | parseUnqualified :: Text -> [Either Text (Types.ModuleName, Types.Name)] 206 | parseUnqualified = concatMap (parse . Text.break (=='(')) . Text.splitOn ";" 207 | where 208 | parse (pre, post) 209 | | Text.null pre && Text.null post = [] 210 | | Text.null pre = [Left $ "no module name before " <> showt post] 211 | | Text.null post = [Left $ "no import after " <> showt pre] 212 | | Just imports <- hasParens post = 213 | map (parseUnqualifiedImport (Text.strip pre)) 214 | (map Text.strip (Text.splitOn "," imports)) 215 | | otherwise = [Left $ "expected parens: " <> showt post] 216 | 217 | -- | 218 | -- "A.B" "(c)" -> (Types.Name "c", "A.B") 219 | -- "A.B" "((+))" -> (Types.Operator "+", "A.B") 220 | parseUnqualifiedImport :: Text -> Text 221 | -> Either Text (Types.ModuleName, Types.Name) 222 | parseUnqualifiedImport pre post = do 223 | unless (Text.all isModuleChar pre) $ 224 | Left $ "this doesn't look like a module name: " <> showt pre 225 | let module_ = Types.ModuleName (Text.unpack pre) 226 | case hasParens post of 227 | Just op 228 | | Text.all Util.haskellOpChar op -> 229 | Right (module_, Types.Operator (Text.unpack op)) 230 | | otherwise -> Left $ "non-symbols in operator: " <> showt post 231 | Nothing 232 | | Text.all (not . Util.haskellOpChar) post -> 233 | Right (module_, Types.Name (Text.unpack post)) 234 | | otherwise -> 235 | Left $ "symbol char in id, use parens: " <> showt post 236 | where 237 | isModuleChar c = Char.isLetter c || Char.isDigit c || c == '.' 238 | 239 | -- | 240 | -- "A.B as AB; C as E" -> [("AB", "A.B"), ("E", "C")] 241 | parseQualifyAs :: Text 242 | -> ([Text], Map.Map Types.Qualification Types.Qualification) 243 | parseQualifyAs field 244 | | Text.null field = ([], mempty) 245 | | otherwise = second Map.fromList . Either.partitionEithers 246 | . map (parse . Text.words) . Text.splitOn ";" $ field 247 | where 248 | parse [module_, "as", alias] = Right 249 | ( Types.Qualification (Text.unpack alias) 250 | , Types.Qualification (Text.unpack module_) 251 | ) 252 | parse ws = Left $ "stanza should look like 'ModuleName as X':" 253 | <> Text.unwords ws 254 | 255 | hasParens :: Text -> Maybe Text 256 | hasParens s 257 | | "(" `Text.isPrefixOf` s && ")" `Text.isSuffixOf` s = 258 | Just $ Text.drop 1 $ Text.dropEnd 1 s 259 | | otherwise = Nothing 260 | 261 | parseLanguage :: [Text] -> ([Text], [Types.Extension]) 262 | parseLanguage = Either.partitionEithers . map parse 263 | where parse w = maybe (Left w) Right $ Types.parseExtension $ Text.unpack w 264 | 265 | -- * pick candidates 266 | 267 | pickModule :: Priorities -> FilePath 268 | -> [(Maybe Index.Package, Types.ModuleName)] 269 | -> Maybe (Maybe Index.Package, Types.ModuleName) 270 | pickModule prios modulePath candidates = 271 | Util.minimumOn (uncurry (prioritize prios modulePath)) $ 272 | -- Don't pick myself! 273 | filter ((/= Types.pathToModule modulePath) . snd) candidates 274 | 275 | -- | The order of priority is: 276 | -- 277 | -- - high or low in 'prioModule' 278 | -- - local modules that share prefix with the module path 279 | -- - local modules to ones from packages 280 | -- - package modules high or low in 'prioPackage' 281 | -- - prefer with fewer dots, so System.IO over Data.Text.IO 282 | -- - If all else is equal alphabetize so at least the order is predictable. 283 | prioritize :: Priorities -> FilePath -> Maybe String -> Types.ModuleName -> _ 284 | prioritize prios modulePath mbPackage mod = 285 | ( modulePrio (prioModule prios) mod 286 | , localPrio mbPackage 287 | , packagePrio (prioPackage prios) mbPackage 288 | , length $ filter (=='.') $ Types.moduleName mod 289 | , Types.moduleName mod 290 | ) 291 | where 292 | localPrio Nothing = Before $ localOrder modulePath mod 293 | localPrio (Just _) = After 294 | 295 | packagePrio _ Nothing = Nothing 296 | packagePrio (Priority {high, low}) (Just pkg) = 297 | Just $ searchPrio high low pkg 298 | modulePrio (Priority {high, low}) = 299 | searchPrio (map Types.moduleName high) (map Types.moduleName low) 300 | . Types.moduleName 301 | 302 | -- | This is like Maybe, except that a present value will always sort before an 303 | -- absent one. 304 | data Before a = Before a | After deriving (Eq, Show) 305 | instance Ord a => Ord (Before a) where 306 | compare After After = EQ 307 | compare (Before _) After = LT 308 | compare After (Before _) = GT 309 | compare (Before a) (Before b) = compare a b 310 | 311 | -- | Lower numbers for modules that share more prefix with the module's path. 312 | -- A/B/Z.hs vs A.B.C -> -2 313 | -- A/Z.hs vs B -> 0 314 | localOrder :: FilePath -> Types.ModuleName -> Int 315 | localOrder modulePath mod = negate $ length $ takeWhile id $ zipWith (==) 316 | (Util.split "/" (Types.moduleToPath mod)) 317 | (Util.split "/" (FilePath.takeDirectory modulePath)) 318 | 319 | searchPrio :: [String] -> [String] -> String -> Int 320 | searchPrio high low mod = case List.findIndex (== mod) high of 321 | Just n -> - length high + n 322 | Nothing -> maybe 0 (+1) (List.findIndex (== mod) low) 323 | 324 | 325 | -- * log 326 | 327 | debug :: Config -> Text -> IO () 328 | debug config msg 329 | | _debug config = Text.IO.hPutStrLn IO.stderr msg 330 | | otherwise = return () 331 | 332 | showt :: Show a => a -> Text 333 | showt = Text.pack . show 334 | -------------------------------------------------------------------------------- /src/FixImports/FixImports.hs: -------------------------------------------------------------------------------- 1 | {- | Automatically fix the import list in a haskell module. 2 | 3 | The process is as follows: 4 | 5 | - Parse the entire file and extract the Qualification of qualified names 6 | like @A.b@, which is simple @A@. 7 | 8 | - Combine this with the modules imported to decide which imports can be 9 | removed and which ones must be added. 10 | 11 | - For added imports, guess the complete import path implied by the 12 | Qualification. This requires some heuristics: 13 | 14 | - Check local modules first. Start in the current module's directory 15 | and then try from the current directory, descending recursively. 16 | 17 | - If no local modules are found, check the package database. There is 18 | a system of package priorities so that @List@ will yield @Data.List@ 19 | from @base@ rather than @List@ from @haskell98@. After that, shorter 20 | matches are prioritized so @System.Process@ is chosen over 21 | @System.Posix.Process@. 22 | 23 | - If the module is not found at all, an error is printed on stderr and 24 | the unchanged file on stdout. 25 | 26 | - Of course the heuristics may get the wrong module, but existing 27 | imports are left alone so you can edit them by hand. 28 | 29 | - Then imports are sorted, grouped, and a new module is written to stdout 30 | with the new import block replacing the old one. 31 | 32 | - The default import formatting separates package imports from local 33 | imports, and groups them by their toplevel module name (before the 34 | first dot). Small groups are combined. They go in alphabetical order 35 | by default, but a per-project order may be defined. 36 | -} 37 | {-# LANGUAGE BangPatterns #-} 38 | {-# LANGUAGE DisambiguateRecordFields #-} 39 | {-# LANGUAGE OverloadedStrings #-} 40 | {-# LANGUAGE RankNTypes #-} 41 | {-# LANGUAGE TupleSections #-} 42 | module FixImports.FixImports where 43 | import Prelude hiding (mod) 44 | import qualified Control.Monad.State.Strict as State 45 | import qualified Control.DeepSeq as DeepSeq 46 | import Control.Monad.Trans (lift) 47 | import Data.Bifunctor (first, second) 48 | import qualified Data.Char as Char 49 | import qualified Data.Either as Either 50 | import qualified Data.List as List 51 | import qualified Data.Map as Map 52 | import Data.Map (Map) 53 | import qualified Data.Maybe as Maybe 54 | import qualified Data.Set as Set 55 | import Data.Set (Set) 56 | import qualified Data.Text as Text 57 | import qualified Data.Text.IO as Text.IO 58 | import Data.Text (Text) 59 | import qualified Data.Time.Clock as Clock 60 | import qualified Data.Tuple as Tuple 61 | import qualified Numeric 62 | import qualified System.Directory as Directory 63 | import qualified System.FilePath as FilePath 64 | import System.FilePath (()) 65 | 66 | import qualified Language.Preprocessor.Cpphs as Cpphs 67 | 68 | import qualified FixImports.Config as Config 69 | import qualified FixImports.Format as Format 70 | import qualified FixImports.Index as Index 71 | import qualified FixImports.Parse as Parse 72 | import qualified FixImports.Types as Types 73 | import qualified FixImports.Util as Util 74 | 75 | import Control.Monad 76 | 77 | 78 | -- | Look only this deep in the directory hierarchy for local modules. 79 | searchDepth :: Int 80 | searchDepth = 12 81 | 82 | data Result = Result { 83 | resultRange :: (Row, Row) 84 | , resultImports :: String 85 | , resultAdded :: Set Types.ModuleName 86 | , resultRemoved :: Set Types.ModuleName 87 | , resultMetrics :: [Metric] 88 | } deriving (Show) 89 | 90 | -- | Line number in the input file. 91 | type Row = Int 92 | 93 | type Metric = (Clock.UTCTime, Text) 94 | 95 | addMetrics :: [Metric] -> Result -> Result 96 | addMetrics ms result = result { resultMetrics = ms ++ resultMetrics result } 97 | 98 | fixModule :: Config.Config -> Maybe FilePath -> FilePath -> String 99 | -> IO (Either String Result, [Text]) 100 | fixModule config mbPkgCache modulePath source = do 101 | mStart <- metric () "start" 102 | processedSource <- cppModule modulePath source 103 | mCpp <- metric () "cpp" 104 | result <- parse (Config._language config) modulePath processedSource 105 | case result of 106 | Left err -> return (Left err, []) 107 | Right (mod, cmts) -> do 108 | mParse <- metric (mod `seq` (), cmts) "parse" 109 | (index, indexFrom) <- Index.load mbPkgCache 110 | when (Config._debug config) $ Text.IO.putStr $ 111 | "index from " <> indexFrom <> ":\n" <> Index.showIndex index 112 | mLoad <- metric () "load-index" 113 | let extracted = extract config mod cmts 114 | mExtract <- metric extracted "extract" 115 | case checkForCpp (_importRange extracted) source of 116 | [] -> fmap (fmap List.reverse) $ flip State.runStateT [] $ 117 | fmap (addMetrics [mStart, mCpp, mParse, mLoad, mExtract]) <$> 118 | fixImports ioFilesystem config index modulePath extracted 119 | cpps -> return 120 | ( Left $ "can't handle CPP directives in import block:\n" 121 | <> unlines cpps 122 | , [] 123 | ) 124 | 125 | parse :: [Types.Extension] -> FilePath -> String 126 | -> IO (Either String (Parse.Module, [Parse.Comment])) 127 | parse extensions modulePath = Parse.parse extensions modulePath 128 | 129 | -- | The parse function takes a CPP extension, but doesn't actually pay any 130 | -- attention to it, so I have to run CPP myself. The imports are fixed 131 | -- post-CPP so if you put CPP in the imports block it will be stripped out. 132 | -- It seems hard to fix imports inside CPP. 133 | cppModule :: FilePath -> String -> IO String 134 | cppModule filename = Cpphs.runCpphs options filename 135 | where 136 | options = Cpphs.defaultCpphsOptions { Cpphs.boolopts = boolOpts } 137 | boolOpts = Cpphs.defaultBoolOptions 138 | { Cpphs.macros = True 139 | , Cpphs.locations = False 140 | , Cpphs.hashline = False 141 | , Cpphs.pragma = False 142 | , Cpphs.stripEol = True 143 | , Cpphs.stripC89 = True 144 | , Cpphs.lang = True -- lex input as haskell code 145 | , Cpphs.ansi = True 146 | , Cpphs.layout = True 147 | , Cpphs.literate = False -- untested with literate code 148 | , Cpphs.warnings = False 149 | } 150 | 151 | -- | I have to get the CPP out before parsing and fixing imports, but then it's 152 | -- hard to put it back in again. Especially the main reason for CPP is 153 | -- conditional imports, which means I might not even know what to do with them. 154 | -- I suppose I could try to detect them and preserve them, but for now it's 155 | -- simpler to just abort on any CPP. At least it's better than silently 156 | -- deleting it. 157 | checkForCpp :: (Row, Row) -> String -> [String] 158 | checkForCpp (start, end) = 159 | map (\(i, line) -> show i <> ":" <> line) 160 | . filter (any (`Set.member` cppThings) . words . snd) 161 | . take (end-start) . drop start . zip [1 :: Int ..] . lines 162 | where 163 | cppThings = Set.fromList $ map ("#"<>) 164 | [ "define", "undef", "include", "if", "ifdef", "ifndef", "else" 165 | , "elif", "endif", "line", "error", "pragma" 166 | ] 167 | 168 | -- | Capture all the IO operations needed by fixImports, so I can test without 169 | -- IO. I could have used Free, but the operations are few, so it seemed 170 | -- simpler to factor them out. 171 | data Filesystem m = Filesystem { 172 | _listDir :: FilePath -> m ([FilePath], [FilePath]) -- ^ (dirs, files) 173 | , _doesFileExist :: FilePath -> m Bool 174 | , _metric :: forall a. DeepSeq.NFData a => a -> Text -> m Metric 175 | } 176 | 177 | ioFilesystem :: Filesystem IO 178 | ioFilesystem = Filesystem 179 | { _listDir = \ dir -> do 180 | fns <- Maybe.fromMaybe [] <$> Util.catchENOENT (Util.listDir dir) 181 | Util.partitionM isDir fns 182 | , _doesFileExist = Directory.doesFileExist 183 | , _metric = metric 184 | } 185 | where 186 | -- Symlinks are not directories, so I don't walk into them. 187 | isDir fn = (&&) <$> Directory.doesDirectoryExist fn 188 | <*> (not <$> Directory.pathIsSymbolicLink fn) 189 | 190 | type LogT m a = State.StateT [Text] m a 191 | 192 | debug :: Monad m => Config.Config -> Text -> LogT m () 193 | debug config msg = when (Config._debug config) $ State.modify' (msg:) 194 | -- The check is unnecessary since I check debug before printing them, but 195 | -- it'll save a thunk at least. 196 | 197 | -- | Take a parsed module along with its unparsed text. Generate a new import 198 | -- block with proper spacing, formatting, and comments. Then snip out the 199 | -- import block on the import file, and replace it. 200 | fixImports :: Monad m => Filesystem m -> Config.Config -> Index.Index 201 | -> FilePath -> Extracted -> LogT m (Either String Result) 202 | fixImports fs config index modulePath extracted = do 203 | mbNew <- mapM (findNewImport fs config modulePath index) 204 | (Set.toList (_missingImports extracted)) 205 | mNewImports <- lift $ _metric fs mbNew "find-new-imports" 206 | (imports, newUnqualImports, unusedUnqual) <- return $ 207 | fixUnqualified (_modToUnqualifieds extracted) config 208 | (_unchangedImports extracted) 209 | newUnqualImports <- lift $ mapM (locateImport fs) newUnqualImports 210 | mUnqual <- lift $ _metric fs newUnqualImports "unqualified-imports" 211 | mbExisting <- mapM (findImport fs index (Config._includes config)) imports 212 | mExistingImports <- lift $ _metric fs mbExisting "find-existing-imports" 213 | let existing = map (Types._importName . fst) imports 214 | let (notFound, importLines) = Either.partitionEithers $ 215 | zipWith mkError 216 | (map qualToMod (Set.toList (_missingImports extracted)) 217 | ++ existing) 218 | (mbNew ++ mbExisting) 219 | mkError _ (Just imp) = Right imp 220 | mkError mod Nothing = Left mod 221 | let formattedImports = 222 | Format.formatGroups (Config._format config) (Config._order config) 223 | (importLines ++ newUnqualImports) 224 | return $ case notFound of 225 | _ : _ -> Left $ "not found: " 226 | ++ Util.join ", " (map Types.moduleName notFound) 227 | [] -> Right $ Result 228 | { resultRange = _importRange extracted 229 | , resultImports = formattedImports 230 | , resultAdded = Set.fromList $ 231 | map (Types._importName . Types.importDecl) $ 232 | Maybe.catMaybes mbNew ++ newUnqualImports 233 | , resultRemoved = 234 | _unusedImports extracted <> Set.fromList unusedUnqual 235 | , resultMetrics = [mNewImports, mExistingImports, mUnqual] 236 | } 237 | where 238 | qualToMod (Types.Qualification name) = Types.ModuleName name 239 | 240 | type ImportComment = (Types.Import, [Types.Comment]) 241 | 242 | locateImport :: Monad m => Filesystem m -> ImportComment -> m Types.ImportLine 243 | locateImport fs (decl, cmts) = do 244 | isLocal <- _doesFileExist fs $ Types.moduleToPath $ Types._importName decl 245 | return $ Types.ImportLine 246 | { importDecl = decl 247 | , importComments = cmts 248 | , importSource = if isLocal then Types.Local else Types.Package 249 | } 250 | 251 | -- | Add unqualified imports. 252 | -- 253 | -- - Get unqualifieds. 254 | -- - If _unqualified non-empty, filter them to the ones in _unqualified. 255 | -- - Add or modify import lines for them. 256 | -- - Remove imports that don't appear in modToUnqualifieds. 257 | fixUnqualified :: Map Types.ModuleName (Set Types.Name) 258 | -> Config.Config -> [ImportComment] 259 | -> ([ImportComment], [ImportComment], [Types.ModuleName]) 260 | -- ^ (modified, new, removed) 261 | fixUnqualified modToUnqualifieds config imports = 262 | removeEmptyImports moduleToNames $ 263 | first (map (first stripReferences)) $ 264 | foldr addReferences (imports, []) $ 265 | filter (not . Set.null . snd) $ 266 | map (second (Set.filter (not . alreadyImported))) $ 267 | Map.toList modToUnqualifieds 268 | where 269 | -- Ignore unqualified references that are already imported, perhaps from 270 | -- some other module. 271 | alreadyImported :: Types.Name -> Bool 272 | alreadyImported name = any ((name `elem`) . importedEntities . fst) imports 273 | 274 | -- Successively modify the ImportComment list for each new reference. Keep 275 | -- existing modified imports separate from newly added ones, so they can be 276 | -- reported as adds. 277 | addReferences :: (Types.ModuleName, Set Types.Name) 278 | -> ([ImportComment], [ImportComment]) 279 | -> ([ImportComment], [ImportComment]) 280 | addReferences (moduleName, names) (existing, new) = 281 | case Util.modifyAt (matches moduleName . fst) add existing of 282 | Nothing -> (existing, (newImport, []) : new) 283 | Just modified -> (modified, new) 284 | where 285 | add = first $ Types.importModify (newEntities ++) 286 | newImport = (Types.makeImport moduleName) 287 | { Types._importEntities = Just $ map Right newEntities } 288 | newEntities = map mkEntity $ Set.toList names 289 | matches name imp = Types.importUnqualified imp 290 | && Types._importName imp == name 291 | 292 | -- Remove managed unqualified imports that are no longer referenced. 293 | stripReferences :: Types.Import -> Types.Import 294 | stripReferences imp = Types.importModify (filter keep) imp 295 | where 296 | moduleName = Types._importName imp 297 | -- Keep if it's not managed, or it is managed and referenced. 298 | keep (Types.Entity Nothing var Nothing) = 299 | not (isManaged moduleName var) 300 | || maybe False (var `Set.member`) 301 | (Map.lookup moduleName modToUnqualifieds) 302 | keep _ = True 303 | isManaged moduleName name = maybe False (name `elem`) $ 304 | Map.lookup moduleName moduleToNames 305 | moduleToNames :: Map Types.ModuleName [Types.Name] 306 | moduleToNames = Util.multimap . map Tuple.swap . Map.toList 307 | . Config._unqualified $ config 308 | mkEntity var = Types.Entity Nothing var Nothing 309 | 310 | importedEntities :: Types.Import -> [Types.Name] 311 | importedEntities = map Types._entityVar . Either.rights . Maybe.fromMaybe [] 312 | . Types._importEntities 313 | 314 | -- | Remove unqualified imports that have been made empty. 315 | removeEmptyImports :: Map Types.ModuleName names -> ([ImportComment], new) 316 | -> ([ImportComment], new, [Types.ModuleName]) 317 | removeEmptyImports moduleToNames (modified, new) = 318 | (kept, new, map (Types._importName . fst) removed) 319 | where 320 | (kept, removed) = List.partition (not . emptyImport . fst) modified 321 | emptyImport imp = Map.member (Types._importName imp) moduleToNames 322 | -- Can delete if it has an import list, but it's empty. 323 | && Types.importEmpty imp 324 | 325 | 326 | -- | Make a map from each module with unqualified imports to its unqualified 327 | -- imports that occur in the module. 328 | makeModToUnqualifieds :: Config.Config -> Parse.Module 329 | -> Map Types.ModuleName (Set Types.Name) 330 | makeModToUnqualifieds config mod 331 | | unqual == mempty = mempty 332 | | otherwise = Util.setmap $ 333 | Maybe.mapMaybe (\name -> (, name) <$> Map.lookup name unqual) $ 334 | Set.toList $ Parse.unqualifieds mod 335 | where unqual = Config._unqualified config 336 | 337 | -- | Clip out the range from the given text and replace it with the given 338 | -- lines. 339 | substituteImports :: String -> (Int, Int) -> String -> String 340 | substituteImports imports (start, end) source = 341 | unlines pre ++ imports ++ unlines post 342 | where 343 | (pre, within) = splitAt start (lines source) 344 | (_, post) = splitAt (end-start) within 345 | 346 | -- * find new imports 347 | 348 | -- | Make a new ImportLine from a ModuleName. 349 | findNewImport :: Monad m => Filesystem m -> Config.Config -> FilePath 350 | -> Index.Index -> Types.Qualification 351 | -> LogT m (Maybe Types.ImportLine) 352 | -- ^ Nothing if the module wasn't found 353 | findNewImport fs config modulePath index qual = 354 | fmap make <$> findModule fs config index modulePath qual 355 | where 356 | make (mod, source) = Types.ImportLine 357 | { importDecl = Types.setQualification qual (Types.makeImport mod) 358 | , importComments = [] 359 | , importSource = source 360 | } 361 | 362 | -- | Find the qualification and its ModuleName and whether it was a Types.Local 363 | -- or Types.Package module. Nothing if it wasn't found at all. 364 | findModule :: Monad m => Filesystem m -> Config.Config -> Index.Index 365 | -> FilePath -- ^ Path to the module being fixed. 366 | -> Types.Qualification -> LogT m (Maybe (Types.ModuleName, Types.Source)) 367 | findModule fs config index modulePath qual = do 368 | local <- map fnameToModule <$> ((++) 369 | <$> findLocalModules fs (Config._includes config) qual 370 | <*> maybe (pure []) (findLocalModules fs (Config._includes config)) 371 | qualifyAs) 372 | let package = map (first Just) $ 373 | findPackageModules qual ++ maybe [] findPackageModules qualifyAs 374 | debug config $ "findModule " <> showt qual <> " from " 375 | <> showt modulePath <> ": local " <> showt local 376 | <> "\npackage: " <> showt package 377 | let prio = Config._modulePriority config 378 | return $ case Config.pickModule prio modulePath (local++package) of 379 | Just (package, mod) -> Just 380 | (mod, if package == Nothing then Types.Local else Types.Package) 381 | Nothing -> Nothing 382 | where 383 | findPackageModules q = Map.findWithDefault [] q index 384 | fnameToModule fn = (Nothing, Types.pathToModule fn) 385 | qualifyAs = Map.lookup qual (Config._qualifyAs config) 386 | 387 | -- If it's in Config._qualifyAs, then I also search for exactly that module 388 | -- name. 389 | 390 | -- | Given A.B, look for A/B.hs, */A/B.hs, */*/A/B.hs, etc. in each of the 391 | -- include paths. 392 | findLocalModules :: Monad m => Filesystem m -> [FilePath] 393 | -> Types.Qualification -> LogT m [FilePath] 394 | findLocalModules fs includes (Types.Qualification name) = 395 | fmap concat . forM includes $ \dir -> map (stripDir dir) <$> 396 | findFiles fs searchDepth (Types.moduleToPath (Types.ModuleName name)) 397 | dir 398 | 399 | stripDir :: FilePath -> FilePath -> FilePath 400 | stripDir dir path 401 | | dir == "." = path 402 | | otherwise = dropWhile (=='/') $ drop (length dir) path 403 | 404 | findFiles :: Monad m => Filesystem m 405 | -> Int -- ^ Descend into subdirectories this many times. 406 | -> FilePath -- ^ Find files with this suffix. Can contain slashes. 407 | -> FilePath -- ^ Start from this directory. Return [] if it doesn't exist. 408 | -> LogT m [FilePath] 409 | findFiles fs depth file dir = do 410 | (subdirs, fns) <- lift $ _listDir fs dir 411 | subfns <- if depth > 0 412 | then concat <$> mapM (findFiles fs (depth-1) file) 413 | (filter isModuleDir subdirs) 414 | else return [] 415 | return $ filter sameSuffix fns ++ subfns 416 | where 417 | isModuleDir = all Char.isUpper . take 1 . FilePath.takeFileName 418 | sameSuffix fn = fn == file || ('/' : file) `List.isSuffixOf` fn 419 | 420 | 421 | -- * figure out existing imports 422 | 423 | -- | Make an existing import into an ImportLine by finding out if it's a local 424 | -- module or a package module. 425 | findImport :: Monad m => Filesystem m -> Index.Index -> [FilePath] 426 | -> ImportComment -> LogT m (Maybe Types.ImportLine) 427 | findImport fs index includes (imp, cmts) = do 428 | found <- findModuleName fs index includes (Types._importName imp) 429 | return $ case found of 430 | Nothing -> Nothing 431 | Just source -> Just $ Types.ImportLine 432 | { importDecl = imp 433 | , importComments = cmts 434 | , importSource = source 435 | } 436 | 437 | -- | True if it was found in a local directory, False if it was found in the 438 | -- ghc package db, and Nothing if it wasn't found at all. 439 | findModuleName :: Monad m => Filesystem m -> Index.Index -> [FilePath] 440 | -> Types.ModuleName -> LogT m (Maybe Types.Source) 441 | findModuleName fs index includes mod = do 442 | isLocal <- lift $ isLocalModule fs mod ("" : includes) 443 | return $ 444 | if isLocal then Just Types.Local 445 | else if isPackageModule index mod then Just Types.Package 446 | else Nothing 447 | 448 | isLocalModule :: Monad m => Filesystem m -> Types.ModuleName -> [FilePath] 449 | -> m Bool 450 | isLocalModule fs mod = 451 | Util.anyM (_doesFileExist fs . ( Types.moduleToPath mod)) 452 | 453 | isPackageModule :: Index.Index -> Types.ModuleName -> Bool 454 | isPackageModule index (Types.ModuleName name) = 455 | Map.member (Types.Qualification name) index 456 | 457 | -- * util 458 | 459 | -- | All the relevant info extracted from a module. 460 | data Extracted = Extracted { 461 | -- | References exist, but no corresponding imports. 462 | _missingImports :: Set Types.Qualification 463 | -- | Imports exist but no reference. 464 | , _unusedImports :: Set Types.ModuleName 465 | , _unchangedImports :: [ImportComment] 466 | , _importRange :: (Int, Int) 467 | , _modToUnqualifieds :: Map Types.ModuleName (Set Types.Name) 468 | } 469 | 470 | instance DeepSeq.NFData Extracted where 471 | rnf (Extracted a b c d e) = DeepSeq.rnf (a, b, c, d, e) 472 | 473 | extract :: Config.Config -> Parse.Module -> [Parse.Comment] -> Extracted 474 | extract config mod cmts = Extracted 475 | { _missingImports = missing 476 | , _unusedImports = unused 477 | , _unchangedImports = importCmts 478 | , _importRange = range 479 | , _modToUnqualifieds = makeModToUnqualifieds config mod 480 | } 481 | where 482 | unused = Set.difference (Set.fromList modules) 483 | (Set.fromList (map (Types._importName . fst) importCmts)) 484 | missing = Set.difference used imported 485 | -- If the Prelude isn't explicitly imported, it's implicitly imported, so 486 | -- if I see Prelude.x it doesn't mean to add an import. 487 | imported = Set.fromList $ prelude : qualifiedImports 488 | importCmts = 489 | [ impCmt 490 | | impCmt <- associateComments imports $ 491 | dropWhile before $ List.sort cmts 492 | , keepImport (fst impCmt) 493 | ] 494 | before = (< fst range) . Types._startLine . Parse._span 495 | range = Parse.importRange mod 496 | -- Keep unqualified imports, but only keep qualified ones if they are used. 497 | -- Prelude is considered always used if it appears, because removing it 498 | -- changes import behavour. 499 | keepImport imp = 500 | Set.member (Types.importQualification imp) (Set.insert prelude used) 501 | || not (Types._importQualified imp) 502 | prelude = Types.Qualification "Prelude" 503 | 504 | -- Get from the qualified import name back to the actual module name so 505 | -- I can return that. 506 | modules = map Types._importName imports 507 | used = Parse.qualifications mod 508 | qualifiedImports = map Types.importQualification imports 509 | imports = normalizeImports $ Parse.extractImports mod 510 | 511 | -- | Clean up redundant imports. 512 | normalizeImports :: [Types.Import] -> [Types.Import] 513 | normalizeImports imports = 514 | Util.uniqueOn key qual 515 | ++ map merge (Util.groupOn key (Util.sortOn key unqual)) 516 | where 517 | (qual, unqual) = List.partition Types._importQualified imports 518 | key imp = imp 519 | { Types._importEntities = Nothing 520 | , Types._importSpan = Types.noSpan 521 | } 522 | merge group@(imp:_) = imp 523 | { Types._importEntities = mconcat (map Types._importEntities group) } 524 | merge [] = error "groupOn postcondition" 525 | 526 | -- | Pair Imports up with the comments that apply to them. Comments 527 | -- below the last import are dropped, but there shouldn't be any of those 528 | -- because they should have been omitted from the comment block. 529 | -- 530 | -- Spaces between comments above an import will be lost, and multiple comments 531 | -- to the right of an import (e.g. commenting a complicated import list) will 532 | -- probably be messed up. TODO Fix it if it becomes a problem. 533 | associateComments :: [Types.Import] -> [Parse.Comment] -> [ImportComment] 534 | associateComments imports cmts = snd $ List.mapAccumL associate cmts imports 535 | where 536 | associate cmts imp = (after, (imp, associated)) 537 | where 538 | associated = map (Types.Comment Types.CmtAbove . Parse._comment) above 539 | ++ map (Types.Comment Types.CmtRight . Parse._comment) right 540 | -- cmts that end before the import beginning are above it 541 | (above, rest) = List.span ((< start impSpan) . end . Parse._span) cmts 542 | -- remaining cmts that start before or at the import's end are right 543 | -- of it 544 | (right, after) = List.span ((<= end impSpan) . start . Parse._span) rest 545 | impSpan = Types._importSpan imp 546 | start = Types._startLine 547 | end = Types._endLine 548 | 549 | -- * metrics 550 | 551 | metric :: DeepSeq.NFData a => a -> Text -> IO Metric 552 | metric val name = do 553 | force val 554 | flip (,) name <$> Clock.getCurrentTime 555 | 556 | showMetrics :: [Metric] -> Text 557 | showMetrics = Text.unlines . format . map diff . Util.zipPrev . Util.sortOn fst 558 | where 559 | format metricDurs = 560 | map (format1 total) (metricDurs ++ [("total", total)]) 561 | where total = sum (map snd metricDurs) 562 | format1 total (metric, dur) = Text.unwords 563 | [ justifyR 8 (showDuration dur) 564 | , justifyR 3 (percent (realToFrac dur / realToFrac total)) 565 | , "-", metric 566 | ] 567 | diff ((prev, _), (cur, metric)) = 568 | (metric, cur `Clock.diffUTCTime` prev) 569 | 570 | force :: DeepSeq.NFData a => a -> IO () 571 | force x = DeepSeq.rnf x `seq` return () 572 | 573 | percent :: Double -> Text 574 | percent = (<>"%") . showt . isInt . round . (*100) 575 | where 576 | isInt :: Int -> Int 577 | isInt = id 578 | 579 | showDuration :: Clock.NominalDiffTime -> Text 580 | showDuration = 581 | Text.pack . ($ "s") . Numeric.showFFloat (Just 2) . isDouble . realToFrac 582 | where 583 | isDouble :: Double -> Double 584 | isDouble = id 585 | 586 | justifyR :: Int -> Text -> Text 587 | justifyR width = Text.justifyRight width ' ' 588 | 589 | showt :: Show a => a -> Text 590 | showt = Text.pack . show 591 | --------------------------------------------------------------------------------