diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,2 @@ +0.1: + * Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Erik Hesselink + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Erik Hesselink nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,90 @@ +Halberd: generating imports +========== + +Halberd is a tool to help you add missing imports to your Haskell source files. With it, you can write your source without imports, call Halberd, and just paste in the import lines. + +Currently, it tries to automatically choose an import if there is a single sensible option. If it can't, it will prompt you with a simple menu. After running, it prints the imports, which you need to copy manually. Editor integration is planned. + +The imports generated are either qualified, if the unbound function looks like `M.lookup`, or explicit, if it looks like `void`. + +Example +---------- + +As an example, say you have written the following (nonsensical and type incorrect) Haskell file called `test.hs`: + +``` haskell +main :: IO Int8 +main = do + forM_ [1,2] $ \x -> print $ M.lookup x table + liftM id $ return $ headNote "Impossible" [10] + +table :: M.Map String Int8 +table = M.fromList [("Odeca", 1), ("Hackathon",2)] +``` + +You can run Halberd on this by running `halberd test.hs`. It will prompt you with three questions: + +``` +forM_: +1) Control.Monad +2) Data.Foldable + +M.lookup: +1) Data.List +2) GHC.List +3) Prelude +4) Data.IntMap +5) Data.IntMap.Lazy +6) Data.IntMap.Strict +7) Data.Map +8) Data.Map.Lazy +9) Data.Map.Strict + +Int8: +1) Data.Int +2) Foreign +3) Foreign.Safe +4) GHC.Int +``` + +After making the choices by typing `1`, `7` and `1`, it generated the folling output: + +``` haskell +------------- Could not find import for ------------- + - headNote + +-------- Insert these imports into your file -------- + +import qualified Data.Map as M +import Control.Monad ( forM_, liftM ) +import Data.Int ( Int8 ) +``` + +As you can see, it didn't ask questions about `M.Map`, `M.fromList`, `liftM` and the second usage of `Int8`. It figured these out either because of previous choices, or because there was only a single option. + +Installation +---------- + +Halberd uses the Haskell Suite packages (`haskell-src-exts`, `haskell-packages` and `haskell-names`) for parsing, name resolution and finding exposed identifiers of packages. While these can be installed from hackage, generating databases of names for new packages currently needs a custom version of the `cabal install` executable. See the [documentation for haskell-names](https://github.com/haskell-suite/haskell-names) for more details. + +To install Halberd, just do + +``` +cabal install halberd +``` + +This will give you a `halberd` executable that takes a single argument, the file to generate imports for. By default, it only draws names from `base`. If you want to add more names, use `hs-gen-iface` from the `haskell-names` package. + +Improvements +---------- + +Halberd is still in an unfinished state. Some planned improvements are: + +* Smarter automatic choices. +* Editor integration. +* Easier installation of name databases (`haskell-names`). +* Integration with existing imports. +* Better choice UI. +* Choices based on type information (`haskell-type-exts`). + +Contributions are welcome! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/halberd.cabal b/halberd.cabal new file mode 100644 --- /dev/null +++ b/halberd.cabal @@ -0,0 +1,39 @@ +name: halberd +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Erik Hesselink, Simon Meier, Tom Lokhorst, Roman Cheplyaka +maintainer: hesselink@gmail.com +category: Development +build-type: Simple +cabal-version: >=1.8 +synopsis: A tool to generate missing import statements for Haskell modules. +description: This tool uses to determine the unbound + variables and types in your source code, and + generate import statements for them. If there are + multiple choices, it provides a simple + interactive menu for you to choose from. See the + home page for more details. +homepage: http://github.com/haskell-suite/halberd/ +extra-source-files: CHANGELOG, README.md + +executable halberd + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , haskell-packages == 0.2.* + , haskell-names == 0.2.* + , haskell-src-exts == 1.14.* + , Cabal >= 1.17 && < 1.19 + , filepath == 1.3.* + , mtl >= 2.0 && < 2.2 + , tagged >= 0.4 && < 0.8 + , safe == 0.3.* + , syb >= 0.3 && < 0.5 + hs-source-dirs: src + main-is: Halberd.hs + ghc-options: -Wall + +Source-Repository head + Type: git + Location: git://github.com/haskell-suite/halberd.git diff --git a/src/Halberd.hs b/src/Halberd.hs new file mode 100644 --- /dev/null +++ b/src/Halberd.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DoAndIfThenElse #-} + +import Control.Applicative +import Control.Arrow +import Control.Monad hiding (forM_) +import Control.Monad.State hiding (forM_) +import Data.Foldable (forM_) +import Data.Function +import Data.List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Set (Set) +import qualified Data.Set as Set +import Distribution.HaskellSuite +import qualified Distribution.InstalledPackageInfo as Cabal +import qualified Distribution.ModuleName as Cabal +import qualified Distribution.Package as Cabal +import Distribution.Simple.Compiler +import qualified Distribution.Text as Cabal +import Language.Haskell.Exts.Annotated +import Language.Haskell.Names +import Language.Haskell.Names.Imports () +import Language.Haskell.Names.Interfaces +import Safe +import System.Environment +import System.Exit +import System.IO + +import Halberd.ChosenImports +import Halberd.CollectNames (collectUnboundNames) +import Halberd.Import +import Language.Haskell.Exts.Utils + +main :: IO () +main = + do args <- getArgs + case args of + [] -> do + putStrLn "Usage: halberd " + exitFailure + (file:_) -> do + (ParseOk module_) <- parseFile file + pkgs <- concat <$> + mapM + (getInstalledPackages (Proxy :: Proxy NamesDB)) + [UserPackageDB, GlobalPackageDB, SpecificPackageDB "/Users/erik/doc/haskell-suite/.cabal-sandbox/x86_64-osx-haskell-names-0.1-packages.conf.d"] + allSuggestions <- evalModuleT (suggestedImports module_) pkgs suffix readInterface + + let (suggestions, noSuggestions) = partition (not . null . snd) allSuggestions + + choices <- flip evalStateT mempty $ askUserChoices suggestions + + let allImports = map (uncurry toImport . second snd3) choices + let imports = mergeExplicitImports allImports + + when (not . null $ noSuggestions) $ do + putStrLn "------------- Could not find import for -------------" + forM_ noSuggestions $ \(q, _) -> do + putStrLn $ " - " ++ prettyPrint q + putStrLn "" + + when (not . null $ imports) $ do + putStrLn "-------- Insert these imports into your file --------" + putStrLn "" + putStrLn $ unlines (map showImport imports) + where + suffix = "names" + +type Suggestion = (QName (Scoped SrcSpan), [CanonicalSymbol]) +type Choice = (QName (Scoped SrcSpan), CanonicalSymbol) + +suggestedImports :: Module SrcSpanInfo -> ModuleT Symbols IO [Suggestion] +suggestedImports module_ = + do (unboundTypes, unboundValues) <- uniques <$> findUnbound module_ + (valueTable, typeTable) <- mkLookupTables + let valueSuggestions = map (id &&& lookupDefinitions valueTable) unboundValues + typeSuggestions = map (id &&& lookupDefinitions typeTable ) unboundTypes + return $ valueSuggestions ++ typeSuggestions + where + uniques = unique *** unique + unique = nubBy ((==) `on` void) + +askUserChoices :: [Suggestion] -> StateT ChosenImports IO [Choice] +askUserChoices suggestions = fmap catMaybes . forM suggestions $ \(qname, modules) -> + do chosenModules <- get + if alreadyChosen qname modules chosenModules + then + return Nothing + else do + choice <- case hasSingleOption qname modules chosenModules of + Just singleOption -> return singleOption + Nothing -> askUserChoice qname modules + modify $ insertChoice qname (snd3 choice) + return $ Just (qname, choice) + where + alreadyChosen qname modules chosenModules = fromMaybe False $ + do q <- getQualification qname + module_ <- lookupQualified q chosenModules + return $ module_ `elem` map snd3 modules + hasSingleOption _ [module_] _ = Just module_ + hasSingleOption UnQual{} modules chosenModules | singleOrigName modules = + headMay $ filter ((`elem` unqualifieds chosenModules) . snd3) modules + hasSingleOption _ _ _ = Nothing + singleOrigName = allEqual . map trd3 + allEqual [] = True + allEqual (x:xs) = all (== x) xs + +askUserChoice :: MonadIO m => QName (Scoped SrcSpan) -> [CanonicalSymbol] -> m CanonicalSymbol +askUserChoice qname suggestions = liftIO $ + do putStrLn $ prettyPrint qname ++ ":" + forM_ (zip [1 :: Integer ..] suggestions) $ \(i, (_, modName, _)) -> putStrLn $ show i ++ ") " ++ Cabal.display modName + putStrLn "" + getChoice suggestions + +getChoice :: [a] -> IO a +getChoice xs = withoutOutput go + where + go = + do c <- getChar + let mi = readMay [c] + case (subtract 1) <$> mi >>= atMay xs of + Nothing -> go + Just x -> return x + withoutOutput action = + do buffering <- hGetBuffering stdin + echo <- hGetEcho stdout + hSetBuffering stdin NoBuffering + hSetEcho stdout False + result <- action + hSetBuffering stdin buffering + hSetEcho stdout echo + return result + +type CanonicalSymbol = (PackageRef, Cabal.ModuleName, OrigName) + +data PackageRef = PackageRef + { installedPackageId :: Cabal.InstalledPackageId + , sourcePackageId :: Cabal.PackageId + } deriving (Eq, Ord, Show) + +toPackageRef :: Cabal.InstalledPackageInfo_ m -> PackageRef +toPackageRef pkgInfo = + PackageRef { installedPackageId = Cabal.installedPackageId pkgInfo + , sourcePackageId = Cabal.sourcePackageId pkgInfo + } + +findUnbound :: Module SrcSpanInfo -> ModuleT Symbols IO ([QName (Scoped SrcSpan)], [QName (Scoped SrcSpan)]) +findUnbound module_ = collectUnboundNames <$> annotateModule Haskell98 [] (fmap srcInfoSpan module_) + +type LookupTable = Map String [CanonicalSymbol] + +mkLookupTables :: ModuleT Symbols IO (LookupTable, LookupTable) +mkLookupTables = + do pkgs <- getPackages + (valueDefs, typeDefs) <- + fmap mconcat $ forM pkgs $ \pkg -> + fmap mconcat $ forM (Cabal.exposedModules pkg) $ \exposedModule -> do + (Symbols values types) <- readModuleInfo (Cabal.libraryDirs pkg) exposedModule + let mkDefs qname = Set.map ((toPackageRef pkg, exposedModule,) . origName) qname + return (mkDefs values, mkDefs types) + let valueTable = toLookupTable (gUnqual . trd3) valueDefs + typeTable = toLookupTable (gUnqual . trd3) typeDefs + return (valueTable, typeTable) + where + gUnqual (OrigName _ (GName _ n)) = n + + +lookupDefinitions :: Map String [CanonicalSymbol] -> QName (Scoped SrcSpan) -> [CanonicalSymbol] +lookupDefinitions symbolTable qname = fromMaybe [] $ + do n <- unQName qname + Map.lookup n symbolTable + where + unQName (Qual _ _ n) = Just (strName n) + unQName (UnQual _ n) = Just (strName n) + unQName (Special _ _ ) = Nothing + + strName (Ident _ str) = str + strName (Symbol _ str) = str + + +toLookupTable :: Ord k => (a -> k) -> Set a -> Map k [a] +toLookupTable key = Map.fromList + . map (fst . head &&& map snd) + . groupBy ((==) `on` fst) + . sortBy (comparing fst) + . map (key &&& id) + . Set.toList + +snd3 :: (a, b, c) -> b +snd3 (_, y, _) = y + +trd3 :: (a, b, c) -> c +trd3 (_, _, z) = z