diff --git a/halberd.cabal b/halberd.cabal --- a/halberd.cabal +++ b/halberd.cabal @@ -1,5 +1,5 @@ name: halberd -version: 0.1 +version: 0.1.1 license: BSD3 license-file: LICENSE author: Erik Hesselink, Simon Meier, Tom Lokhorst, Roman Cheplyaka @@ -8,13 +8,14 @@ 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 +description: This tool uses the Haskell Suite [0] 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. + + [0] https://github.com/haskell-suite homepage: http://github.com/haskell-suite/halberd/ extra-source-files: CHANGELOG, README.md @@ -33,6 +34,9 @@ hs-source-dirs: src main-is: Halberd.hs ghc-options: -Wall + other-modules: Halberd.ChosenImports + , Halberd.CollectNames + , Language.Haskell.Exts.Utils Source-Repository head Type: git diff --git a/src/Halberd.hs b/src/Halberd.hs --- a/src/Halberd.hs +++ b/src/Halberd.hs @@ -36,7 +36,6 @@ import Halberd.ChosenImports import Halberd.CollectNames (collectUnboundNames) -import Halberd.Import import Language.Haskell.Exts.Utils main :: IO () @@ -56,10 +55,7 @@ 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 + chosenImports <- askUserChoices suggestions when (not . null $ noSuggestions) $ do putStrLn "------------- Could not find import for -------------" @@ -67,15 +63,14 @@ putStrLn $ " - " ++ prettyPrint q putStrLn "" - when (not . null $ imports) $ do + when (not . isEmpty $ chosenImports) $ do putStrLn "-------- Insert these imports into your file --------" putStrLn "" - putStrLn $ unlines (map showImport imports) + putStrLn $ unlines (showChosenImports chosenImports) where suffix = "names" type Suggestion = (QName (Scoped SrcSpan), [CanonicalSymbol]) -type Choice = (QName (Scoped SrcSpan), CanonicalSymbol) suggestedImports :: Module SrcSpanInfo -> ModuleT Symbols IO [Suggestion] suggestedImports module_ = @@ -88,18 +83,30 @@ uniques = unique *** unique unique = nubBy ((==) `on` void) -askUserChoices :: [Suggestion] -> StateT ChosenImports IO [Choice] -askUserChoices suggestions = fmap catMaybes . forM suggestions $ \(qname, modules) -> +askUserChoices :: [Suggestion] -> IO ChosenImports +askUserChoices suggestions = execStateT (go suggestions) mempty + where + go sugs = do + remaining <- resolveSuggestions sugs + case remaining of + [] -> return [] + ((qname, modules):ss) -> do + choice <- askUserChoice qname modules + modify $ insertChoice qname (snd3 choice) + go ss + +resolveSuggestions :: [Suggestion] -> StateT ChosenImports IO [Suggestion] +resolveSuggestions suggestions = fmap catMaybes . forM suggestions $ \suggestion@(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) + case hasSingleOption qname modules chosenModules of + Nothing -> return $ Just suggestion + Just choice -> do + modify $ insertChoice qname (snd3 choice) + return Nothing where alreadyChosen qname modules chosenModules = fromMaybe False $ do q <- getQualification qname @@ -107,7 +114,7 @@ return $ module_ `elem` map snd3 modules hasSingleOption _ [module_] _ = Just module_ hasSingleOption UnQual{} modules chosenModules | singleOrigName modules = - headMay $ filter ((`elem` unqualifieds chosenModules) . snd3) modules + headMay $ filter ((`Map.member` unqualifieds chosenModules) . snd3) modules hasSingleOption _ _ _ = Nothing singleOrigName = allEqual . map trd3 allEqual [] = True diff --git a/src/Halberd/ChosenImports.hs b/src/Halberd/ChosenImports.hs new file mode 100644 --- /dev/null +++ b/src/Halberd/ChosenImports.hs @@ -0,0 +1,74 @@ +module Halberd.ChosenImports where + +import Control.Monad +import Data.List +import Data.Map (Map, insertWith) +import Data.Monoid +import Language.Haskell.Exts.Annotated hiding (name) +import qualified Data.Map as Map +import qualified Distribution.ModuleName as Cabal +import qualified Distribution.Text as Cabal + +data ChosenImports = ChosenImports + { qualifieds :: Map (ModuleName ()) Cabal.ModuleName + , unqualifieds :: Map Cabal.ModuleName [Name ()] + } + +instance Monoid ChosenImports where + mempty = ChosenImports + { qualifieds = mempty + , unqualifieds = mempty + } + i1 `mappend` i2 = ChosenImports + { qualifieds = qualifieds i1 `mappend` qualifieds i2 + , unqualifieds = unqualifieds i1 `mappend` unqualifieds i2 + } + +lookupQualified :: ModuleName () -> ChosenImports -> Maybe Cabal.ModuleName +lookupQualified qualification = Map.lookup qualification . qualifieds + +insertQualified :: ModuleName () -> Cabal.ModuleName -> ChosenImports -> ChosenImports +insertQualified qualification module_ chosenImports = chosenImports + { qualifieds = Map.insert qualification module_ (qualifieds chosenImports) } + +insertUnqualified :: Cabal.ModuleName -> Name () -> ChosenImports -> ChosenImports +insertUnqualified module_ name chosenImports = chosenImports + { unqualifieds = insertWith (++) module_ [name] (unqualifieds chosenImports) } + +insertChoice :: QName a -> Cabal.ModuleName -> ChosenImports -> ChosenImports +insertChoice qname module_ = + case qname of + Qual _ qualification _ -> insertQualified (void qualification) module_ + UnQual _ name -> insertUnqualified module_ (void name) + Special _ _ -> error "impossible: insertChoice" + +isEmpty :: ChosenImports -> Bool +isEmpty ci = Map.null (qualifieds ci) && Map.null (unqualifieds ci) + +showChosenImports :: ChosenImports -> [String] +showChosenImports ci = showQualifieds (qualifieds ci) ++ showUnqualifieds (unqualifieds ci) + +showQualifieds :: Map (ModuleName ()) Cabal.ModuleName -> [String] +showQualifieds = map (uncurry showQualified) . Map.toList + +showUnqualifieds :: Map Cabal.ModuleName [Name ()] -> [String] +showUnqualifieds = map (uncurry showUnqualified) . Map.toList + +showQualified :: ModuleName () -> Cabal.ModuleName -> String +showQualified qualification modName = + intercalate " " + [ "import" + , "qualified" + , Cabal.display modName + , "as" + , prettyPrint qualification + ] +showUnqualified :: Cabal.ModuleName -> [Name ()] -> String +showUnqualified modName names = + intercalate " " + [ "import" + , Cabal.display modName + , "(" + , intercalate ", " $ map prettyPrint names + , ")" + ] diff --git a/src/Halberd/CollectNames.hs b/src/Halberd/CollectNames.hs new file mode 100644 --- /dev/null +++ b/src/Halberd/CollectNames.hs @@ -0,0 +1,120 @@ +module Halberd.CollectNames + ( collectUnboundNames + ) where + +import Control.Monad +import Data.Either +import Data.Generics +import Language.Haskell.Exts.Annotated (SrcSpan) +import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Names + +------------------------------------------------------------------------------ +-- Collecting the (unbound) names +------------------------------------------------------------------------------ + +data NameSpace = TypeSpace | ValueSpace -- DON'T CHANGE THE ORDER + deriving (Eq, Ord, Show) + +collectUnboundNames :: Module (Scoped SrcSpan) + -> ([QName (Scoped SrcSpan)], [QName (Scoped SrcSpan)]) +collectUnboundNames module_ = partitionEithers $ do + (nameSpace, qname) <- namesFromAST module_ + guard (qNameNotInScope qname) + return $ case nameSpace of + TypeSpace -> Left qname + ValueSpace -> Right qname + where + qNameNotInScope :: QName (Scoped SrcSpan) -> Bool + qNameNotInScope qname = case ann qname of + Scoped (ScopeError ENotInScope {}) _ -> True + _ -> False + + namesFromAST = everything (++) $ + mkQ [] namesFromAsst + `extQ` namesFromInstHead + `extQ` namesFromType + `extQ` namesFromExp + `extQ` namesFromFieldUpdate + +namesFromAsst :: Asst l -> [(NameSpace, QName l)] +namesFromAsst x = case x of + ClassA _ qn _ -> [(TypeSpace, qn)] + InfixA _ _ qn _ -> [(TypeSpace, qn)] + IParam _ _ _ -> [] + EqualP _ _ _ -> [] + +namesFromInstHead :: InstHead l -> [(NameSpace, QName l)] +namesFromInstHead x = case x of + IHead _ qn _ -> [(TypeSpace, qn)] + IHInfix _ _ qn _ -> [(TypeSpace, qn)] + IHParen _ _ -> [] + +namesFromType :: Type l -> [(NameSpace, QName l)] +namesFromType x = case x of + TyForall _ _ _ _ -> [] + TyFun _ _ _ -> [] + TyTuple _ _ _ -> [] + TyList _ _ -> [] + TyApp _ _ _ -> [] + TyVar _ _ -> [] + TyCon _ qn -> [(TypeSpace, qn)] + TyParen _ _ -> [] + TyInfix _ _ qn _ -> [(TypeSpace, qn)] + TyKind _ _ _ -> [] + +namesFromExp :: Exp l -> [(NameSpace, QName l)] +namesFromExp x = case x of + Var _ qn -> [(ValueSpace, qn)] + IPVar _ _ -> [] + Con _ qn -> [(ValueSpace, qn)] + Lit _ _ -> [] + InfixApp _ _ _ _ -> [] + App _ _ _ -> [] + NegApp _ _ -> [] + Lambda _ _ _ -> [] + Let _ _ _ -> [] + If _ _ _ _ -> [] + Case _ _ _ -> [] + Do _ _ -> [] + MDo _ _ -> [] + Tuple _ _ _ -> [] + TupleSection _ _ _ -> [] + List _ _ -> [] + Paren _ _ -> [] + LeftSection _ _ _ -> [] + RightSection _ _ _ -> [] + RecConstr _ qn _ -> [(ValueSpace, qn)] + RecUpdate _ _ _ -> [] + EnumFrom _ _ -> [] + EnumFromTo _ _ _ -> [] + EnumFromThen _ _ _ -> [] + EnumFromThenTo _ _ _ _ -> [] + ListComp _ _ _ -> [] + ParComp _ _ _ -> [] + ExpTypeSig _ _ _ -> [] + VarQuote _ qn -> [(ValueSpace, qn)] + TypQuote _ qn -> [(TypeSpace, qn)] + BracketExp _ _ -> [] + SpliceExp _ _ -> [] + QuasiQuote _ _ _ -> [] + XTag _ _ _ _ _ -> [] + XETag _ _ _ _ -> [] + XPcdata _ _ -> [] + XExpTag _ _ -> [] + XChildTag _ _ -> [] + CorePragma _ _ _ -> [] + SCCPragma _ _ _ -> [] + GenPragma _ _ _ _ _ -> [] + Proc _ _ _ -> [] + LeftArrApp _ _ _ -> [] + RightArrApp _ _ _ -> [] + LeftArrHighApp _ _ _ -> [] + RightArrHighApp _ _ _ -> [] + + +namesFromFieldUpdate :: FieldUpdate l -> [(NameSpace, QName l)] +namesFromFieldUpdate x = case x of + FieldUpdate _ qn _ -> [(ValueSpace, qn)] + FieldPun _ _ -> [] + FieldWildcard _ -> [] diff --git a/src/Language/Haskell/Exts/Utils.hs b/src/Language/Haskell/Exts/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Exts/Utils.hs @@ -0,0 +1,8 @@ +module Language.Haskell.Exts.Utils where + +import Control.Monad +import Language.Haskell.Exts.Annotated + +getQualification :: QName a -> Maybe (ModuleName ()) +getQualification (Qual _ q _) = Just $ void q +getQualification _ = Nothing