Merge pull request #299 from serras/master
Automatic completion using Djinn
This commit is contained in:
Kazu Yamamoto
commit
235b4965f9
|
|
@ -36,6 +36,7 @@ module Language.Haskell.GhcMod (
|
|||
, splits
|
||||
, sig
|
||||
, refine
|
||||
, auto
|
||||
, modules
|
||||
, languages
|
||||
, flags
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ usage = progVersion
|
|||
++ "\t ghc-mod split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
||||
++ "\t ghc-mod sig" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
||||
++ "\t ghc-mod refine" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
|
||||
++ "\t ghc-mod auto" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
||||
++ "\t ghc-mod find <symbol>\n"
|
||||
++ "\t ghc-mod lint [-h opt] <HaskellFile>\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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue