initial import (v0.1)

This commit is contained in:
Kazu Yamamoto 2010-01-06 14:38:06 +09:00
commit 35f60507c6
8 changed files with 618 additions and 0 deletions

241
GHCMod.hs Normal file
View File

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

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

16
elisp/Makefile Normal file
View File

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

183
elisp/ghc-comp.el Normal file
View File

@ -0,0 +1,183 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-comp.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; 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)

64
elisp/ghc-doc.el Normal file
View File

@ -0,0 +1,64 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; 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)

41
elisp/ghc-func.el Normal file
View File

@ -0,0 +1,41 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-func.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; 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)

46
elisp/ghc.el Normal file
View File

@ -0,0 +1,46 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; 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)))

25
ghc-mod.cabal Normal file
View File

@ -0,0 +1,25 @@
-- -*- mode: Text; indent-tabs-mode: nil; -*-
Name: ghc-mod
Version: 0.1
Author: Kazu Yamamoto <kazu@Mew.org>
Maintainer: Kazu Yamamoto <kazu@Mew.org>
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