Merge pull request #299 from serras/master

Automatic completion using Djinn

Language/Haskell/GhcMod.hs

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

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)
-import Data.List (find, intercalate, sortBy)
 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
 

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]

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.List (find, nub, sortBy)
-import Data.Maybe (isJust)
+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)

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

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)

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

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)

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

src/GHCMod.hs

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

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