hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #299 from serras/master

Browse Source 
Automatic completion using Djinn
This commit is contained in:
Kazu Yamamoto 2014-08-06 20:39:56 +09:00
commit 235b4965f9
11 changed files with 229 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Language/Haskell/GhcMod.hs
View File

@ -36,6 +36,7 @@ module Language.Haskell.GhcMod (
, splits
, sig
, refine
, auto
, modules
, languages
, flags

5
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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

5
Language/Haskell/GhcMod/Convert.hs
View File

@ -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]

122
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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)

1
elisp/ghc-check.el
View File

@ -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 ()

20
elisp/ghc-func.el
View File

@ -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)

63
elisp/ghc-rewrite.el
View File

@ -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

4
elisp/ghc.el
View File

@ -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)

2
ghc-mod.cabal
View File

@ -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

2
src/GHCMod.hs
View File

@ -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

11
src/GHCModi.hs
View File

@ -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