diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -25,4 +25,6 @@ setTargetFile file load LoadAllTargets liftIO readLog - options = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt + options + | expandSplice opt = ["-w:"] ++ ghcOpts opt + | otherwise = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt diff --git a/GHCApi.hs b/GHCApi.hs --- a/GHCApi.hs +++ b/GHCApi.hs @@ -31,20 +31,23 @@ dflags <- getSessionDynFlags let opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts - (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs + (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags opt dflags' $ idirs setSessionDynFlags dflags'' return readLog ---------------------------------------------------------------- -setFlags :: DynFlags -> [FilePath] -> DynFlags -setFlags d idirs = d' +setFlags :: Options -> DynFlags -> [FilePath] -> DynFlags +setFlags opt d idirs + | expandSplice opt = dopt_set d' Opt_D_dump_splices + | otherwise = d' where d' = d { packageFlags = ghcPackage : packageFlags d , importPaths = idirs , ghcLink = NoLink , hscTarget = HscInterpreted + , flags = flags d } ghcPackage :: PackageFlag diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -35,6 +35,7 @@ ++ "\t ghc-mod flag [-l]\n" ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [ ...]\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" + ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod lint [-h opt] \n" @@ -43,14 +44,6 @@ ---------------------------------------------------------------- -defaultOptions :: Options -defaultOptions = Options { - outputStyle = PlainStyle - , hlintOpts = [] - , ghcOpts = [] - , operators = False - } - argspec :: [OptDescr (Options -> Options)] argspec = [ Option "l" ["tolisp"] (NoArg (\opts -> opts { outputStyle = LispStyle })) @@ -91,6 +84,8 @@ "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) + "expand" -> withFile (checkSyntax opt { expandSplice = True }) + (safelist cmdArg 1) "type" -> withFile (typeExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1) "info" -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -5,10 +5,20 @@ data OutputStyle = LispStyle | PlainStyle data Options = Options { - outputStyle :: OutputStyle - , hlintOpts :: [String] - , ghcOpts :: [String] - , operators :: Bool + outputStyle :: OutputStyle + , hlintOpts :: [String] + , ghcOpts :: [String] + , operators :: Bool + , expandSplice :: Bool + } + +defaultOptions :: Options +defaultOptions = Options { + outputStyle = PlainStyle + , hlintOpts = [] + , ghcOpts = [] + , operators = False + , expandSplice = False } ---------------------------------------------------------------- diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -114,6 +114,10 @@ (goto-char (point-max)) (insert "\n"))) (insert "\n" (match-string 1 data) " = undefined\n")) + ((string-match "Pattern match(es) are non-exhaustive" data) + (let* ((fn (ghc-get-function-name)) + (arity (ghc-get-function-arity fn))) + (ghc-insert-underscore fn arity))) ((string-match "Found:\0[ ]*\\([^\0]+\\)\0Why not:\0[ ]*\\([^\0]+\\)" data) (let ((old (match-string 1 data)) (new (match-string 2 data))) @@ -123,6 +127,39 @@ (search-backward old nil t) (delete-region (point) end)) (insert new)))))))) + +(defun ghc-get-function-name () + (save-excursion + (beginning-of-line) + (when (looking-at "\\([^ ]+\\) ") + (match-string 1)))) + +(defun ghc-get-function-arity (fn) + (when fn + (save-excursion + (let ((regex (format "^%s *::" (regexp-quote fn)))) + (when (re-search-backward regex nil t) + (ghc-get-function-arity0)))))) + +(defun ghc-get-function-arity0 () + (let ((end (save-excursion (end-of-line) (point))) + (arity 0)) + (while (search-forward "->" end t) + (setq arity (1+ arity))) + arity)) + +(defun ghc-insert-underscore (fn ar) + (when fn + (let ((arity (or ar 1))) + (save-excursion + (goto-char (point-max)) + (re-search-backward (format "^%s *::" (regexp-quote fn))) + (forward-line) + (re-search-forward "^$" nil t) + (insert fn) + (dotimes (i arity) + (insert " _")) + (insert " = error \"" fn "\""))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -12,26 +12,12 @@ (defun ghc-show-info (&optional ask) (interactive "P") - (if (not (ghc-which ghc-module-command)) - (message "%s not found" ghc-module-command) - (let ((modname (or (ghc-find-module-name) "Main"))) - (ghc-show-info0 ask modname)))) - -(defun ghc-show-info0 (ask modname) - (let* ((expr0 (ghc-things-at-point)) + (let* ((modname (or (ghc-find-module-name) "Main")) + (expr0 (ghc-things-at-point)) (expr (if ask (ghc-read-expression expr0) expr0)) - (cdir default-directory) (file (buffer-file-name)) - (buf (get-buffer-create ghc-error-buffer-name))) - (with-current-buffer buf - (erase-buffer) - (insert - (with-temp-buffer - (cd cdir) - (apply 'call-process ghc-module-command nil t nil - `(,@(ghc-make-ghc-options) "info" ,file ,modname ,expr)) - (buffer-substring (point-min) (1- (point-max)))))) - (display-buffer buf))) + (cmds (list "info" file modname expr))) + (ghc-display-information cmds))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -128,6 +114,41 @@ (goto-char (point-min)) (while (search-forward "[Char]" nil t) (replace-match "String")))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Expanding Template Haskell +;;; + +(defun ghc-expand-th () + (interactive) + (let* ((file (buffer-file-name)) + (cmds (list "expand" file))) + (ghc-display-information cmds))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Display +;;; + +(defun ghc-display-information (cmds) + (interactive) + (if (not (ghc-which ghc-module-command)) + (message "%s not found" ghc-module-command) + (let ((cdir default-directory) + (buf (get-buffer-create ghc-error-buffer-name))) + (with-current-buffer buf + (erase-buffer) + (insert + (with-temp-buffer + (cd cdir) + (apply 'call-process ghc-module-command nil t nil + (append (ghc-make-ghc-options) cmds)) + (buffer-substring (point-min) (1- (point-max))))) + (goto-char (point-min)) + (haskell-font-lock-defaults-create) + (turn-on-haskell-font-lock)) + (display-buffer buf)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -16,7 +16,7 @@ ;;; Code: -(defconst ghc-version "1.10.9") +(defconst ghc-version "1.10.10") ;; (eval-when-compile ;; (require 'haskell-mode)) @@ -52,6 +52,7 @@ (defvar ghc-check-key "\C-x\C-s") (defvar ghc-toggle-key "\C-c\C-c") (defvar ghc-module-key "\C-c\C-m") +(defvar ghc-expand-key "\C-c\C-e") (defvar ghc-hoogle-key (format "\C-c%c" (ghc-find-C-h))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -70,6 +71,7 @@ (define-key haskell-mode-map ghc-document-key 'ghc-browse-document) (define-key haskell-mode-map ghc-type-key 'ghc-show-type) (define-key haskell-mode-map ghc-info-key 'ghc-show-info) + (define-key haskell-mode-map ghc-expand-key 'ghc-expand-th) (define-key haskell-mode-map ghc-import-key 'ghc-import-module) (define-key haskell-mode-map ghc-previous-key 'flymake-goto-prev-error) (define-key haskell-mode-map ghc-next-key 'flymake-goto-next-error) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 1.10.9 +Version: 1.10.10 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3