packages feed

halberd 0.1 → 0.1.1

raw patch · 5 files changed

+235/−22 lines, 5 files

Files

halberd.cabal view
@@ -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 <https://github.com/haskell-suite-                     the Haskell Suite> 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
src/Halberd.hs view
@@ -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
+ src/Halberd/ChosenImports.hs view
@@ -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+      , ")"+      ]
+ src/Halberd/CollectNames.hs view
@@ -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 _    -> []
+ src/Language/Haskell/Exts/Utils.hs view
@@ -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