commit 35f60507c6dd7d522ac33a05f9ebda75b09cab1b Author: Kazu Yamamoto Date: Wed Jan 6 14:38:06 2010 +0900 initial import (v0.1) diff --git a/GHCMod.hs b/GHCMod.hs new file mode 100644 index 0000000..044fb27 --- /dev/null +++ b/GHCMod.hs @@ -0,0 +1,241 @@ +module Main where + +import Control.Exception hiding (try) +import Data.Char +import Data.List +import Language.Haskell.Exts.Extension +import Language.Haskell.Exts.Parser hiding (parse) +import Language.Haskell.Exts.Syntax +import Prelude hiding (catch) +import System.Console.GetOpt +import System.Environment +import System.IO +import System.Process +import Text.ParserCombinators.Parsec + +import Debug.Trace +infixr 0 .$. +(.$.) :: Show a => (a -> b) -> a -> b +f .$. x = trace (show x) f x + + +---------------------------------------------------------------- + +usage :: String +usage = "ghc-mod putStrLn version 0.1\n" + ++ "Usage:\n" + ++ "\t ghc-mod list\n" + ++ "\t ghc-mod browse \n" + ++ "\t ghc-mod help\n" + +---------------------------------------------------------------- + +data Options = Options { optToLisp :: Bool + } deriving Show + +defaultOptions :: Options +defaultOptions = Options { optToLisp = False + } + +argspec :: [OptDescr (Options -> Options)] +argspec = [ Option ['l'] ["tolisp"] + (NoArg (\opts -> opts { optToLisp = True })) + "print as a list of Lisp" + ] + +parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) +parseArgs spec argv + = case getOpt Permute spec argv of + (o,n,[] ) -> (foldl (flip id) defaultOptions o, n) + (_,_,errs) -> error (concat errs ++ usageInfo usage argspec) + +---------------------------------------------------------------- + +main :: IO () +main = flip catch handler $ do + args <- getArgs + let (opt,cmdArg) = parseArgs argspec args + transform = if optToLisp opt then toLisp else toPlain + ll <- case cmdArg !! 0 of + cmd | cmd == "browse" -> browseModule $ cmdArg !! 1 + | cmd == "list" -> listModules + _ -> error usage + putStr $ transform $ nub $ sort $ ll + where + handler :: ErrorCall -> IO () +-- handler _ = print usage + handler e = print e + +---------------------------------------------------------------- + +browseModule :: String -> IO [String] +browseModule mname = do + xs <- getSyntax mname + let ys = preprocess xs + return $ parseSyntax ys + +getSyntax :: String -> IO String +getSyntax mname = do + (inp,out,_,_) <- runInteractiveProcess "ghci" [] Nothing Nothing + mapM_ setFD [inp,out] + hPutStrLn inp ":set prompt \"\"" + hPutStrLn inp "1" + hPutStrLn inp $ ":browse " ++ mname + hPutStrLn inp ":set prompt \"Prelude>\"" + hPutStrLn inp ":quit" + cs <- hGetContents out + return $ unlines $ dropTailer $ dropHeader $ lines $ cs + where + isNotPrefixOf x y = not (x `isPrefixOf` y) + dropHeader xs = tail $ dropWhile (isNotPrefixOf "Prelude>") xs + dropTailer = takeWhile (isNotPrefixOf "Prelude>") + setFD h = do + hSetBinaryMode h False + hSetBuffering h LineBuffering + +parseSyntax :: String -> [String] +parseSyntax xs = do + let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts } + res = parseModuleWithMode mode xs + case res of + ParseOk x -> identifiers x +-- e -> error $ show e + _ -> [] + +---------------------------------------------------------------- + +listModules :: IO [String] +listModules = do + cs <- getDump + return $ exposedModules cs + +getDump :: IO String +getDump = do + (_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["dump"] Nothing Nothing + hGetContents hout + +exposedModules :: String -> [String] +exposedModules cs = let ls = unfoldLines cs + ns = values "name: " ls + ms = values "exposed-modules: " ls + zs = zip ns ms + xs = filter (\(nm,_) -> nm `notElem` ["ghc", "ghc-prim", "rts", "integer"]) zs + ss = map snd xs + in filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss + +values :: String -> [String] -> [String] +values tag ls = let len = length tag + fs = filter (tag `isPrefixOf`) ls + in map (drop len) fs + +---------------------------------------------------------------- + +unfoldLines :: String -> [String] +unfoldLines xs = self xs + where + splitNL = break (== '\n') + self "" = [] + self s = let (l, s') = splitNL s + in case s' of + [] -> [l] + (_:' ':s'') -> cont s'' l + (_:s'') -> l : self s'' + cont s a = let (l, s') = splitNL $ dropWhile (== ' ') s + a' = a ++ " " ++ l + in case s' of + [] -> [a'] + (_:' ':s'') -> cont s'' a' + (_:s'') -> a' : self s'' + +toLisp :: [String] -> String +toLisp ms = "(" ++ unwords quoted ++ ")\n" + where + quote x = "\"" ++ x ++ "\"" + quoted = map quote ms + +toPlain :: [String] -> String +toPlain = unlines + +---------------------------------------------------------------- + +preprocess :: String -> String +preprocess cs = case parse remove "remove" cs of + Right a -> a + Left e -> error $ show e + +modName :: Parser String +modName = do c <- oneOf ['A'..'Z'] + cs <- many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#" + return $ c:cs + +anyName :: Parser String +anyName = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#" + +manyBefore :: Show tok => GenParser tok st a -> GenParser tok st [tok] -> GenParser tok st [a] +manyBefore p anchor = manyTill p (eof <|> try anc) + where + anc = do pos <- getPosition + s <- anchor + ss <- getInput + setInput $ s ++ ss + setPosition pos + return () + +keyword :: Parser String +keyword = do ms <- modName + char '.' + return $ ms ++ ['.'] + +ghcName :: Parser String +ghcName = do keyword + try sep <|> end + where + sep = do + ws <- sepBy1 anyName (char '.') + return $ last ws + end = do + endBy1 anyName (char '.') + return "" + +nonGhcName :: Parser String +nonGhcName = do c <- anyChar -- making this func non-empty + cs <- manyBefore anyChar keyword + return $ c:cs + +remove :: Parser String +remove = do l1 <- try ghcName <|> return "" + l2 <- nonGhcName + ll <- many (do x <- ghcName + y <- nonGhcName + return $ x ++ y) + return $ concat $ l1 : l2 : ll + +---------------------------------------------------------------- + +identifiers :: Module -> [String] +identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x + where + hid = all (\c -> isAlphaNum c || elem c "_'") + +decl :: Decl -> [String] +decl (TypeSig _ [x] _) = [name x] +decl (DataDecl _ _ _ x _ y _) = name x : (map qualConDecl y) +decl (ClassDecl _ _ x _ _ y) = name x : (map classDecl y) +decl (TypeDecl _ x _ _) = [name x] +decl x = [show x] + +qualConDecl :: QualConDecl -> String +qualConDecl (QualConDecl _ _ _ x) = conDecl x + +conDecl :: ConDecl -> String +conDecl (ConDecl (Ident x) _) = x +conDecl (InfixConDecl _ (Ident x) _) = x +conDecl x = show x + +classDecl :: ClassDecl -> String +classDecl (ClsDecl x) = concat $ decl x -- xxx +classDecl x = show x + +name :: Name -> String +name (Symbol x) = x +name (Ident x) = x diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elisp/Makefile b/elisp/Makefile new file mode 100644 index 0000000..a7ec555 --- /dev/null +++ b/elisp/Makefile @@ -0,0 +1,16 @@ +SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el + +TEMPFILE = temp.el + +all: $(TEMPFILE) ghc.el + emacs -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile + +$(TEMPFILE): + @echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE) + @echo '(defun ghc-compile () (mapcar (lambda (x) (byte-compile-file x)) (list ' >> $(TEMPFILE) + @echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE) + @echo ')))' >> $(TEMPFILE) + +clean: + rm -f *.elc $(TEMPFILE) + diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el new file mode 100644 index 0000000..b4163ed --- /dev/null +++ b/elisp/ghc-comp.el @@ -0,0 +1,183 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-comp.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Sep 25, 2009 + +;;; Code: + +(require 'ghc-func) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Customize Variables +;;; + +(defvar ghc-module-command "ghc-mod") + +(defvar ghc-idle-timer-interval 30) + +;; must be sorted +(defvar ghc-reserved-keyword-for-bol '("class" "data" "default" "import" "infix" "infixl" "infixr" "instance" "main" "module" "newtype" "type")) + +;; must be sorted +(defvar ghc-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Initializer +;;; + +(defvar ghc-module-names nil) ;; completion for "import" +(defvar ghc-merged-keyword nil) ;; completion for type/func/... + +(defvar ghc-keyword-prefix "ghc-keyword-") +(defvar ghc-keyword-Prelude nil) +(defvar ghc-loaded-module nil) + +(defun ghc-comp-init () + (setq ghc-module-names (ghc-load-keyword "list")) + (setq ghc-keyword-Prelude (ghc-load-keyword "browse" "Prelude")) + (setq ghc-loaded-module '("Prelude")) + (ghc-merge-keywords) + (run-with-idle-timer ghc-idle-timer-interval 'repeat 'ghc-idle-timer)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Executing command +;;; + +(defun ghc-load-keyword (&rest args) + (when (ghc-which ghc-module-command) + (ghc-read-lisp + (lambda () + (let ((msg (mapconcat 'identity (cons ghc-module-command args) " "))) + (message "Executing \"%s\"..." msg) + (apply 'call-process-shell-command + ghc-module-command nil t nil (cons "-l" args)) + (message "Executing \"%s\"...done" msg)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Completion +;;; + +(defvar ghc-completion-buffer-name "*Completions*") + +(defun ghc-complete () + (interactive) + (if (ghc-should-scroll) + (ghc-scroll-completion-buffer) + (ghc-try-complete))) + +(defun ghc-should-scroll () + (let ((window (ghc-completion-window))) + (and (eq last-command this-command) + window (window-live-p window) (window-buffer window) + (buffer-name (window-buffer window))))) + +(defun ghc-scroll-completion-buffer () + (let ((window (ghc-completion-window))) + (with-current-buffer (window-buffer window) + (if (pos-visible-in-window-p (point-max) window) + (set-window-start window (point-min)) + (save-selected-window + (select-window window) + (scroll-up)))))) + +(defun ghc-completion-window () + (get-buffer-window ghc-completion-buffer-name 0)) + +(defun ghc-try-complete () + (let* ((end (point)) + (symbols (ghc-select-completion-symbol)) + (beg (ghc-completion-start-point)) + (pattern (buffer-substring-no-properties beg end)) + (completion (try-completion pattern symbols))) + (cond + ((eq completion t) ;; completed + ) ;; do nothing + ((null completion) ;; no completions + (ding)) + ((not (string= pattern completion)) ;; ??? + (delete-region beg end) + (insert completion) + (delete-other-windows)) + (t ;; multiple completions + (let* ((list0 (all-completions pattern symbols)) + (list (sort list0 'string<))) + (if (> (length list) 1) + (with-output-to-temp-buffer ghc-completion-buffer-name + (display-completion-list list pattern)) + (delete-other-windows))))))) + +(defun ghc-select-completion-symbol () + (cond + ((or (minibufferp) + (save-excursion + (beginning-of-line) + (looking-at "import "))) + ghc-module-names) + ((or (bolp) + (let ((end (point))) + (save-excursion + (beginning-of-line) + (not (search-forward " " end t))))) + ghc-reserved-keyword-for-bol) + (t ghc-merged-keyword))) + +(defun ghc-completion-start-point () + (save-excursion + (let ((beg (save-excursion (beginning-of-line) (point)))) + (if (search-backward " " beg t) + (1+ (point)) + beg)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Background Idle Timer +;;; + +(defun ghc-idle-timer () + (let ((mods (ghc-gather-import-modules)) + keywords) + (dolist (mod mods) + (when (and (member mod ghc-module-names) + (not (member mod ghc-loaded-module))) + (setq keywords (ghc-load-keyword "browse" mod)) + (when (or (consp keywords) (null keywords)) + (set (intern (concat ghc-keyword-prefix mod)) keywords) + (setq ghc-loaded-module (cons mod ghc-loaded-module))))) + (ghc-merge-keywords))) + +(defun ghc-gather-import-modules () + (let ((bufs (mapcar 'buffer-name (buffer-list))) + ret) + (save-excursion + (dolist (buf bufs) + (when (string-match "\\.hs$" buf) + (set-buffer buf) + (setq ret (cons (ghc-gather-import-modules-buffer) ret))))) + (ghc-uniq-lol ret))) + +(defun ghc-gather-import-modules-buffer () + (let (ret) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^import *\\([^\n ]+\\)" nil t) + (setq ret (cons (match-string-no-properties 1) ret)) + (forward-line))) + ret)) + +(defun ghc-merge-keywords () + (let* ((modkeys (mapcar 'ghc-module-keyword ghc-loaded-module)) + (keywords (cons ghc-reserved-keyword modkeys)) + (uniq-sorted (sort (ghc-uniq-lol keywords) 'string<))) + (setq ghc-merged-keyword uniq-sorted))) + +(defun ghc-module-keyword (mod) + (symbol-value (intern (concat ghc-keyword-prefix mod)))) + +(provide 'ghc-comp) diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el new file mode 100644 index 0000000..6f1fa16 --- /dev/null +++ b/elisp/ghc-doc.el @@ -0,0 +1,64 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Sep 25, 2009 + +(require 'ghc-func) +(require 'ghc-comp) + +;;; Code: + +(defun ghc-browse-document () + (interactive) + (let* ((mod0 (ghc-extract-module)) + (mod (ghc-read-module-name mod0)) + (pkg (ghc-resolve-package-name mod))) + (ghc-display-document pkg mod))) + +(defun ghc-extract-module () + (interactive) + (save-excursion + (beginning-of-line) + (when (looking-at "^import +\\([^ \n]+\\)") + (match-string-no-properties 1)))) + +(defun ghc-resolve-package-name (mod) + (with-temp-buffer + (call-process "ghc-pkg" nil t nil "find-module" "--simple-output" mod) + (goto-char (point-min)) + (when (looking-at "^\\([^-]+\\)-") + (match-string-no-properties 1)))) + +(defun ghc-resolve-document-path (pkg) + (with-temp-buffer + (call-process "ghc-pkg" nil t nil "field" pkg "haddock-html") + (goto-char (point-min)) + (when (looking-at "^haddock-html: \\([^ \n]+\\)$") + (match-string-no-properties 1)))) + +(defun ghc-display-document (pkg mod) + (when (and pkg mod) + (let* ((mod- (ghc-replace-character mod ?. ?-)) + (path (ghc-resolve-document-path pkg)) + (url (format "file://%s/%s.html" path mod-))) + (browse-url url)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar ghc-input-map nil) + +(unless ghc-input-map + (setq ghc-input-map + (if (boundp 'minibuffer-local-map) + (copy-keymap minibuffer-local-map) + (make-sparse-keymap))) + (define-key ghc-input-map "\t" 'ghc-complete)) + +(defun ghc-read-module-name (def) + (read-from-minibuffer "Module name: " def ghc-input-map)) + + +(provide 'ghc-doc) \ No newline at end of file diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el new file mode 100644 index 0000000..81f7b3d --- /dev/null +++ b/elisp/ghc-func.el @@ -0,0 +1,41 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-func.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Sep 25, 2009 + +;;; Code: + +(defun ghc-replace-character (string from to) + "Replace characters equal to FROM to TO in STRING." + (dotimes (cnt (length string) string) + (if (char-equal (aref string cnt) from) + (aset string cnt to)))) + +(defun ghc-which (cmd) + (catch 'loop + (dolist (dir exec-path) + (let ((path (expand-file-name cmd dir))) + (if (file-exists-p path) + (throw 'loop path)))))) + +(defun ghc-uniq-lol (lol) + (let ((hash (make-hash-table :test 'equal)) + ret) + (dolist (lst lol) + (dolist (key lst) + (puthash key key hash))) + (maphash (lambda (key val) (setq ret (cons key ret))) hash) + ret)) + +(defun ghc-read-lisp (func) + (with-temp-buffer + (funcall func) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error ())))) + +(provide 'ghc-func) diff --git a/elisp/ghc.el b/elisp/ghc.el new file mode 100644 index 0000000..e522ca5 --- /dev/null +++ b/elisp/ghc.el @@ -0,0 +1,46 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Sep 25, 2009 +;; Revised: + +;; Put the following code to your "~/.emacs". +;; +;; (autoload 'ghc-init "ghc" nil t) +;; (add-hook 'haskell-mode-hook (lambda () (ghc-init))) + +;;; Code: + +(defvar ghc-version "0.1") + +;; (require 'haskell-mode) +(require 'ghc-comp) +(require 'ghc-doc) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Customize Variables +;;; + +(defvar ghc-completion-key "\e\t") +(defvar ghc-document-key "\e\C-d") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Initializer +;;; + +(defvar ghc-initialized nil) + +(defun ghc-init () + (unless ghc-initialized + (define-key haskell-mode-map ghc-completion-key 'ghc-complete) + (define-key haskell-mode-map ghc-document-key 'ghc-browse-document) + (ghc-comp-init) + (setq ghc-initialized t))) + + + diff --git a/ghc-mod.cabal b/ghc-mod.cabal new file mode 100644 index 0000000..5920830 --- /dev/null +++ b/ghc-mod.cabal @@ -0,0 +1,25 @@ +-- -*- mode: Text; indent-tabs-mode: nil; -*- +Name: ghc-mod +Version: 0.1 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +License: BSD3 +Homepage: http://www.mew.org/~kazu/ +Synopsis: Extracting names from modules +Description: "ghc-mod" lists up all installed modules + or extracts names of functions, classes, + and data declarations. "ghc-mod" is a + backend for completion on Emacs. +Category: Development +Cabal-Version: >= 1.2 +Build-Type: Simple +Data-Dir: elisp +Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el +Executable ghc-mod + Main-Is: GHCMod.hs + GHC-Options: -Wall + Build-Depends: base >= 4.0, + parsec >= 2.0.0.0, + process >= 1.0, + haskell-src-exts >= 1.0 +