diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index c0f3615..5362ea8 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -36,6 +36,7 @@ module Language.Haskell.GhcMod ( , splits , sig , refine + , auto , modules , languages , flags diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index a283d64..421d20d 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -5,8 +5,7 @@ module Language.Haskell.GhcMod.CaseSplit ( ) where import CoreMonad (liftIO) -import Data.Function (on) -import Data.List (find, intercalate, sortBy) +import Data.List (find, intercalate) import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile) @@ -18,7 +17,7 @@ import Language.Haskell.GhcMod.Convert import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils -import Outputable (ppr, PprStyle) +import Outputable (PprStyle) import qualified TyCon as Ty import qualified Type as Ty diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index a386e7e..0b53f3b 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -81,6 +81,11 @@ instance ToString ((Int,Int,Int,Int),String) where toLisp opt x = ('(' :) . tupToString opt x . (')' :) toPlain opt x = tupToString opt x +instance ToString ((Int,Int,Int,Int),[String]) where + toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . + (' ' :) . toLisp opt s . (')' :) + toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s + instance ToString (String, (Int,Int,Int,Int),[String]) where toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index b5cef74..4c7783c 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -3,15 +3,18 @@ module Language.Haskell.GhcMod.FillSig ( sig , refine + , auto ) where import Data.Char (isSymbol) import Data.Function (on) -import Data.List (find, sortBy) -import Data.Maybe (isJust) +import Data.List (find, nub, sortBy) +import qualified Data.Map as M +import Data.Maybe (isJust, catMaybes) import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G +import qualified Name as G import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad @@ -22,7 +25,10 @@ import Outputable (PprStyle) import qualified Type as Ty import qualified HsBinds as Ty import qualified Class as Ty +import qualified Var as Ty +import qualified HsPat as Ty import qualified Language.Haskell.Exts.Annotated as HE +import Djinn.GHC ---------------------------------------------------------------- -- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE @@ -143,6 +149,7 @@ getSignatureFromHE file lineNo colNo = do return $ HEFamSignature s Open name (map cleanTyVarBind tys) HE.DataFamDecl (HE.SrcSpanInfo s _) _ (HE.DHead _ name tys) _ -> return $ HEFamSignature s Open name (map cleanTyVarBind tys) + _ -> fail "" _ -> Nothing where cleanTyVarBind (HE.KindedVar _ n _) = n cleanTyVarBind (HE.UnkindedVar _ n) = n @@ -310,3 +317,114 @@ doParen True s = if ' ' `elem` s then '(':s ++ ")" else s isSearchedVar :: Id -> G.HsExpr Id -> Bool isSearchedVar i (G.HsVar i2) = i == i2 isSearchedVar _ _ = False + + +---------------------------------------------------------------- +-- REFINE AUTOMATICALLY +---------------------------------------------------------------- + +auto :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +auto file lineNo colNo = ghandle handler body + where + body = inModuleContext file $ \dflag style -> do + opt <- options + modSum <- Gap.fileModSummary file + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs + ,tm_checked_module_info = minfo} <- G.typecheckModule p + whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do + topLevel <- getEverythingInTopLevel minfo + let (f,pats) = getPatsForVariable tcs (lineNo,colNo) + -- Remove self function to prevent recursion, and id to trim cases + filterFn = (\(n,_) -> let funName = G.getOccString n + recName = G.getOccString (G.getName f) + in not $ funName `elem` recName:notWantedFuns) + -- Find without using other functions in top-level + localBnds = M.unions $ map (\(L _ pat) -> getBindingsForPat pat) pats + lbn = filter filterFn (M.toList localBnds) + djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000 + let -- Find with the entire top-level + almostEnv = M.toList $ M.union localBnds topLevel + env = filter filterFn almostEnv + djinns <- djinn True (Just minfo) env rty (Max 10) 100000 + return (fourInts loc, map (doParen paren) $ nub (djinnsEmpty ++ djinns)) + + handler (SomeException _) = emptyResult =<< options + +-- Functions we do not want in completions +notWantedFuns :: [String] +notWantedFuns = ["id", "asTypeOf", "const"] + +-- Get all things defined in top-level +getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type) +getEverythingInTopLevel m = do + let modInfo = tyThingsToInfo (G.modInfoTyThings m) + topNames = G.modInfoTopLevelScope m + case topNames of + Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames' + let topThings' = catMaybes topThings + topInfo = tyThingsToInfo topThings' + return $ M.union modInfo topInfo + Nothing -> return modInfo + +tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type +tyThingsToInfo [] = M.empty +tyThingsToInfo (G.AnId i : xs) = M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs) +-- Getting information about constructors is not needed +-- because they will be added by djinn-ghc when traversing types +-- #if __GLASGOW_HASKELL__ >= 708 +-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)] +-- #else +-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)] +-- #endif +tyThingsToInfo (_:xs) = tyThingsToInfo xs + +-- Find the Id of the function and the pattern where the hole is located +getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id]) +getPatsForVariable tcs (lineNo, colNo) = + let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id] + in case bnd of + G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of + Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat]) + _ -> (error "This should never happen", []) + G.FunBind { Ty.fun_id = L _ funId } -> + let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) +#if __GLASGOW_HASKELL__ >= 708 + :: [G.LMatch Id (G.LHsExpr Id)] +#else + :: [G.LMatch Id] +#endif + (L _ (G.Match pats _ _):_) = m + in (funId, pats) + _ -> (error "This should never happen", []) + +getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type +getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) +getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l +getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b +getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i) +#if __GLASGOW_HASKELL__ >= 708 +getBindingsForPat (Ty.ListPat l _ _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l +#else +getBindingsForPat (Ty.ListPat l _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l +#endif +getBindingsForPat (Ty.TuplePat l _ _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l +getBindingsForPat (Ty.PArrPat l _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l +getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.ConPatIn (L _ i) d) = M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d) +getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d +getBindingsForPat _ = M.empty + +getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type +getBindingsForRecPat (Ty.PrefixCon args) = M.unions $ map (\(L _ i) -> getBindingsForPat i) args +getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = M.union (getBindingsForPat a1) (getBindingsForPat a2) +getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = getBindingsForRecFields fields + where getBindingsForRecFields [] = M.empty + getBindingsForRecFields (Ty.HsRecField { Ty.hsRecFieldArg = (L _ a) } : fs) = + M.union (getBindingsForPat a) (getBindingsForRecFields fs) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index 68b42a3..72b770e 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -256,6 +256,7 @@ nil does not display errors/warnings. (define-button-type 'find-file-button 'follow-link t + 'help-echo "mouse-2, RET: Go to definition" 'action #'find-file-button) (defun buttonize-buffer () diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el index 5d73c60..e17fb33 100644 --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -146,7 +146,25 @@ (defconst ghc-error-buffer-name "*GHC Info*") (defun ghc-display (fontify ins-func) - (let ((buf ghc-error-buffer-name)) + (ghc-display-with-name fontify ins-func ghc-error-buffer-name)) + +;; (defun ghc-display (fontify ins-func) +;; (let ((buf ghc-error-buffer-name)) +;; (with-output-to-temp-buffer buf +;; (with-current-buffer buf +;; (erase-buffer) +;; (funcall ins-func) +;; (goto-char (point-min)) +;; (if (not fontify) +;; (turn-off-haskell-font-lock) +;; (haskell-font-lock-defaults-create) +;; (turn-on-haskell-font-lock))) +;; (display-buffer buf +;; '((display-buffer-reuse-window +;; display-buffer-pop-up-window)))))) + +(defun ghc-display-with-name (fontify ins-func name) + (let ((buf name)) (with-output-to-temp-buffer buf (with-current-buffer buf (erase-buffer) diff --git a/elisp/ghc-rewrite.el b/elisp/ghc-rewrite.el index 764129e..98f765b 100644 --- a/elisp/ghc-rewrite.el +++ b/elisp/ghc-rewrite.el @@ -70,6 +70,69 @@ (cmd (format "refine %s %s %s %s\n" file ln cn expr))) (ghc-sync-process cmd))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Auto +;;; + +(defun ghc-perform-rewriting-auto (info msg) + "Replace code with new string obtained from ghc-mod from auto mode" + (let* ((current-line (line-number-at-pos)) + (begin-line (ghc-sinfo-get-beg-line info)) + (begin-line-diff (+ 1 (- begin-line current-line))) + (begin-line-pos (line-beginning-position begin-line-diff)) + (begin-pos (- (+ begin-line-pos (ghc-sinfo-get-beg-column info)) 1)) + (end-line (ghc-sinfo-get-end-line info)) + (end-line-diff (+ 1 (- end-line current-line))) + (end-line-pos (line-beginning-position end-line-diff)) + (end-pos (- (+ end-line-pos (ghc-sinfo-get-end-column info)) 1)) ) + (delete-region begin-pos end-pos) + (insert msg))) + +(defun auto-button (button) + (let ((text (buffer-substring (button-start button) (button-end button)))) + (with-current-buffer ghc-auto-buffer + (ghc-perform-rewriting-auto ghc-auto-info text)))) + +(define-button-type 'auto-button + 'follow-link t + 'help-echo "mouse-2, RET: Insert this completion" + 'action #'auto-button) + +(defun ghc-show-auto-messages (info) + (let ((buf (current-buffer))) + (setq ghc-auto-info info) + (setq ghc-auto-buffer buf) + (ghc-display nil + (lambda () + (insert "Possible completions:\n") + (mapc + (lambda (x) + (let* ((ins1 (insert "- ")) + (pos-begin (point)) + (ins (insert x)) + (pos-end (point)) + (ins3 (insert "\n"))) + (make-button pos-begin pos-end :type 'auto-button))) + (ghc-sinfo-get-info info)))))) + +(defun ghc-auto () + "Try to automatically fill the contents of a hole" + (interactive) + (let ((info (ghc-obtain-auto))) + (if (null info) + (message "No automatic completions found") + (if (= (length (ghc-sinfo-get-info info)) 1) + (ghc-perform-rewriting-auto info (first (ghc-sinfo-get-info info))) + (ghc-show-auto-messages info))))) + +(defun ghc-obtain-auto () + (let* ((ln (int-to-string (line-number-at-pos))) + (cn (int-to-string (1+ (current-column)))) + (file (buffer-file-name)) + (cmd (format "auto %s %s %s\n" file ln cn))) + (ghc-sync-process cmd))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Initial code from signature diff --git a/elisp/ghc.el b/elisp/ghc.el index 3440b70..4b21304 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -75,7 +75,8 @@ (defvar ghc-deeper-key "\C-c>") (defvar ghc-case-split-key "\C-c\C-s") (defvar ghc-initial-sig-key "\C-c\C-g") -(defvar ghc-refine-key "\C-c\C-r") +(defvar ghc-refine-key "\C-c\C-f") +(defvar ghc-auto-key "\C-c\C-a") (defvar ghc-prev-hole-key "\C-c\ep") (defvar ghc-next-hole-key "\C-c\en") @@ -113,6 +114,7 @@ (define-key haskell-mode-map ghc-case-split-key 'ghc-case-split) (define-key haskell-mode-map ghc-initial-sig-key 'ghc-initial-code-from-signature) (define-key haskell-mode-map ghc-refine-key 'ghc-refine) + (define-key haskell-mode-map ghc-auto-key 'ghc-auto) (define-key haskell-mode-map ghc-prev-hole-key 'ghc-goto-prev-hole) (define-key haskell-mode-map ghc-next-hole-key 'ghc-goto-next-hole) (ghc-comp-init) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9c7accb..602025b 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -107,6 +107,7 @@ Library , split , haskell-src-exts , text + , djinn-ghc >= 0.0.2.1 if impl(ghc >= 7.8) Build-Depends: Cabal >= 1.18 else @@ -191,6 +192,7 @@ Test-Suite spec , split , haskell-src-exts , text + , djinn-ghc >= 0.0.2.1 if impl(ghc >= 7.8) Build-Depends: Cabal >= 1.18 else diff --git a/src/GHCMod.hs b/src/GHCMod.hs index f38f888..8903d17 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -41,6 +41,7 @@ usage = progVersion ++ "\t ghc-mod split" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod sig" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod refine" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod auto" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod find \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod root\n" @@ -125,6 +126,7 @@ main = flip E.catches handlers $ do "split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4) "sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4) "refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5 + "auto" -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4) "find" -> nArgs 1 $ findSymbol cmdArg1 "lint" -> nArgs 1 $ withFile lint cmdArg1 "root" -> rootInfo diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 745a03c..04f68f8 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -131,6 +131,7 @@ loop set mvar = do "split" -> doSplit set arg "sig" -> doSig set arg "refine" -> doRefine set arg + "auto" -> doAuto set arg "boot" -> bootIt set "browse" -> browseIt set arg "quit" -> return ("quit", False, set) @@ -271,6 +272,16 @@ doRefine set fileArg = do ret <- refine file (read line) (read column) expr return (ret, True, set') +doAuto :: IOish m + => Set FilePath + -> FilePath + -> GhcModT m (String, Bool, Set FilePath) +doAuto set fileArg = do + let [file, line, column] = words fileArg + set' <- newFileSet set file + ret <- auto file (read line) (read column) + return (ret, True, set') + ---------------------------------------------------------------- bootIt :: IOish m