diff --git a/elisp/hindent.el b/elisp/hindent.el --- a/elisp/hindent.el +++ b/elisp/hindent.el @@ -23,6 +23,32 @@ (require 'cl-lib) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Minor mode + +(defvar hindent-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap indent-region] #'hindent-reformat-region) + (define-key map [remap fill-paragraph] #'hindent-reformat-decl-or-fill) + map) + "Keymap for `hindent-mode'.") + +;;;###autoload +(define-minor-mode hindent-mode + "Indent code with the hindent program. + +Provide the following keybindings: + +\\{hindent-mode-map}" + :init-value nil + :keymap hindent-mode-map + :lighter " HI" + :group 'haskell + :require 'hindent) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization properties + (defcustom hindent-style "fundamental" "The style to use for formatting." @@ -37,68 +63,29 @@ :type 'string :safe #'stringp) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Interactive functions + ;;;###autoload -(defun hindent/reformat-decl () +(defun hindent-reformat-decl () "Re-format the current declaration by parsing and pretty printing it. Comments are preserved, although placement may be funky." (interactive) (let ((start-end (hindent-decl-points))) (when start-end - (let ((original (current-buffer)) - (orig-str (buffer-substring-no-properties (car start-end) - (cdr start-end)))) - (with-temp-buffer - (let ((temp (current-buffer))) - (with-current-buffer original - (let ((ret (apply #'call-process-region - (append (list (car start-end) - (cdr start-end) - hindent-process-path - nil ; delete - temp ; output - nil - "--style" - hindent-style) - (hindent-extra-arguments))))) - (cond - ((= ret 1) - (let ((error-string - (with-current-buffer temp - (let ((string (progn (goto-char (point-min)) - (buffer-substring (line-beginning-position) - (line-end-position))))) - string)))) - (if (string= error-string "hindent: Parse error: EOF") - (message "language pragma") - (error error-string)))) - ((= ret 0) - (let ((new-str (with-current-buffer temp - (buffer-string)))) - (if (not (string= new-str orig-str)) - (let ((line (line-number-at-pos)) - (col (current-column))) - (delete-region (car start-end) - (cdr start-end)) - (let ((new-start (point))) - (insert new-str) - (let ((new-end (point))) - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (+ (line-beginning-position) col)) - (when (looking-back "^[ ]+") - (back-to-indentation)) - (delete-trailing-whitespace new-start new-end))) - (message "Formatted.")) - (message "Already formatted."))))))))))))) + (let ((beg (car start-end)) + (end (cdr start-end))) + (hindent-reformat-region beg end))))) -(defun hindent-extra-arguments () - "Pass in extra arguments, such as extensions and optionally -other things later." - (if (boundp 'haskell-language-extensions) - haskell-language-extensions - '())) +;;;###autoload +(defun hindent-reformat-buffer () + "Reformat the whole buffer." + (interactive) + (hindent-reformat-region (point-min) + (point-max))) +;;;###autoload (defun hindent-reformat-decl-or-fill (justify) "Re-format current declaration, or fill paragraph. @@ -112,6 +99,86 @@ (fill-paragraph justify t) (hindent/reformat-decl))) +;;;###autoload +(defun hindent-reformat-region (beg end) + "Reformat the given region, accounting for indentation." + (interactive "r") + (if (= (save-excursion (goto-char beg) + (line-beginning-position)) + beg) + (hindent-reformat-region-as-is beg end) + (let* ((column (- beg (line-beginning-position))) + (string (buffer-substring-no-properties beg end)) + (new-string (with-temp-buffer + (insert (make-string column ? ) string) + (hindent-reformat-region-as-is (point-min) + (point-max)) + (delete-region (point-min) (1+ column)) + (buffer-substring (point-min) + (point-max))))) + (save-excursion + (goto-char beg) + (delete-region beg end) + (insert new-string))))) + +;;;###autoload +(defun hindent/reformat-decl () + "See `hindent-reformat-decl'." + (hindent-reformat-decl)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal library + +(defun hindent-reformat-region-as-is (beg end) + "Reformat the given region as-is. + +This is the place where hindent is actually called." + (let* ((original (current-buffer)) + (orig-str (buffer-substring-no-properties beg end))) + (with-temp-buffer + (let ((temp (current-buffer))) + (with-current-buffer original + (let ((ret (apply #'call-process-region + (append (list beg + end + hindent-process-path + nil ; delete + temp ; output + nil + "--style" + hindent-style) + (hindent-extra-arguments))))) + (cond + ((= ret 1) + (let ((error-string + (with-current-buffer temp + (let ((string (progn (goto-char (point-min)) + (buffer-substring (line-beginning-position) + (line-end-position))))) + string)))) + (if (string= error-string "hindent: Parse error: EOF") + (message "language pragma") + (error error-string)))) + ((= ret 0) + (let ((new-str (with-current-buffer temp + (buffer-string)))) + (if (not (string= new-str orig-str)) + (let ((line (line-number-at-pos)) + (col (current-column))) + (delete-region beg + end) + (let ((new-start (point))) + (insert new-str) + (let ((new-end (point))) + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (+ (line-beginning-position) col)) + (when (looking-back "^[ ]+") + (back-to-indentation)) + (delete-trailing-whitespace new-start new-end))) + (message "Formatted.")) + (message "Already formatted."))))))))))) + (defun hindent-decl-points (&optional use-line-comments) "Get the start and end position of the current declaration. This assumes that declarations start at column zero @@ -136,33 +203,38 @@ ;; Otherwise we just do our line-based hack. (t (save-excursion - (let ((start (or (cl-letf - (((symbol-function 'jump) #'(lambda () - (search-backward-regexp "^[^ \n]" nil t 1) - (cond - ((save-excursion (goto-char (line-beginning-position)) - (looking-at "|]")) - (jump)) - (t (unless (or (looking-at "^-}$") - (looking-at "^{-$")) - (point))))))) - (goto-char (line-end-position)) - (jump)) - 0)) - (end (progn (goto-char (1+ (point))) - (or (cl-letf - (((symbol-function 'jump) #'(lambda () - (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) - (cond - ((save-excursion (goto-char (line-beginning-position)) - (looking-at "|]")) - (jump)) - (t (forward-char -1) - (search-backward-regexp "[^\n ]" nil t) - (forward-char) - (point))))))) - (jump)) - (point-max))))) + (let ((start + (or (cl-letf + (((symbol-function 'jump) + #'(lambda () + (search-backward-regexp "^[^ \n]" nil t 1) + (cond + ((save-excursion (goto-char (line-beginning-position)) + (looking-at "|]")) + (jump)) + (t (unless (or (looking-at "^-}$") + (looking-at "^{-$")) + (point))))))) + (goto-char (line-end-position)) + (jump)) + 0)) + (end + (progn + (goto-char (1+ (point))) + (or (cl-letf + (((symbol-function 'jump) + #'(lambda () + (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) + (cond + ((save-excursion (goto-char (line-beginning-position)) + (looking-at "|]")) + (jump)) + (t (forward-char -1) + (search-backward-regexp "[^\n ]" nil t) + (forward-char) + (point))))))) + (jump)) + (point-max))))) (cons start end)))))) (defun hindent-in-comment () @@ -185,49 +257,12 @@ (not (save-excursion (goto-char (line-beginning-position)) (looking-at "{-# ")))))) -(defun hindent-reformat-region () - (interactive) - (save-excursion - (save-restriction - (if (> (point) (mark)) - (exchange-point-and-mark)) - (while (< (point) (mark)) - (hindent/reformat-decl) - (let ((dpoints (hindent-decl-points))) - (if dpoints ;; if we're in a comment hindent-decl-points returns nil - (goto-char (min (mark) (+ 1 (cdr dpoints)))) - (forward-line 1))) - ;; might be on a blank line (which associates with the previous decl - (if (search-forward-regexp "^[\\s-]*[^\\]" (mark) t) - nil - (goto-char (mark))))))) - -(defun hindent-reformat-buffer () - (interactive) - (save-excursion - (save-restriction - (mark-whole-buffer) - (hindent-reformat-region)))) - -(defvar hindent-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap indent-region] #'hindent-reformat-region) - (define-key map [remap fill-paragraph] #'hindent-reformat-decl-or-fill) - map) - "Keymap for `hindent-mode'.") - -;;;###autoload -(define-minor-mode hindent-mode - "Indent code with the hindent program. - -Provide the following keybindings: - -\\{hindent-mode-map}" - :init-value nil - :keymap hindent-mode-map - :lighter " HI" - :group 'haskell - :require 'hindent) +(defun hindent-extra-arguments () + "Pass in extra arguments, such as extensions and optionally +other things later." + (if (boundp 'haskell-language-extensions) + haskell-language-extensions + '())) (provide 'hindent) diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 4.5.5 +version: 4.5.6 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -60,6 +60,7 @@ , haskell-src-exts >= 1.16 , applicative-quoters , ghc-prim + , directory executable hindent-generate-tests hs-source-dirs: src/main diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -1181,18 +1182,33 @@ prettyInternal x = case x of Module _ mayModHead pragmas imps decls -> - do case mayModHead of - Nothing -> return () - Just modHead -> do - pretty modHead - unless (null pragmas && null imps && null decls) $ newline - inter newline (map pretty pragmas) - inter newline (map pretty imps) - inter newline (map pretty decls) - XmlPage{} -> - error "FIXME: No implementation for XmlPage." - XmlHybrid{} -> - error "FIXME: No implementation for XmlHybrid." + inter (do newline + newline) + (mapMaybe (\(isNull,r) -> + if isNull + then Nothing + else Just r) + [(null pragmas,inter newline (map pretty pragmas)) + ,(case mayModHead of + Nothing -> (True,return ()) + Just modHead -> (False,pretty modHead)) + ,(null imps,inter newline (map pretty imps)) + ,(null decls + ,interOf newline + (map (\case + r@TypeSig{} -> (1,pretty r) + r -> (2,pretty r)) + decls))]) + where interOf i ((c,p):ps) = + case ps of + [] -> p + _ -> + do p + replicateM_ c i + interOf i ps + interOf _ [] = return () + XmlPage{} -> error "FIXME: No implementation for XmlPage." + XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid." instance Pretty Bracket where prettyInternal x = diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -24,7 +24,9 @@ import GHC.Tuple import Language.Haskell.Exts.Annotated hiding (Style,style) import Paths_hindent (version) +import System.Directory import System.Environment +import System.IO import Text.Read -- | Main entry point. @@ -32,10 +34,20 @@ main = do args <- getArgs case consume options (map T.pack args) of - Succeeded (style,exts) -> - T.interact - (either error T.toLazyText . - reformat style (Just exts)) + Succeeded (style,exts,mfilepath) -> + case mfilepath of + Just filepath -> + do text <- T.readFile filepath + tmpDir <- getTemporaryDirectory + (fp,h) <- openTempFile tmpDir "hindent.hs" + T.hPutStrLn + h + (either error T.toLazyText (reformat style (Just exts) text)) + hFlush h + hClose h + renameFile fp filepath + Nothing -> + T.interact (either error T.toLazyText . reformat style (Just exts)) Failed (Wrap (Stopped Version) _) -> putStrLn ("hindent " ++ showVersion version) _ -> @@ -47,10 +59,10 @@ -- | Program options. options :: Monad m - => Consumer [Text] (Option Stoppers) m (Style,[Extension]) + => Consumer [Text] (Option Stoppers) m (Style,[Extension],Maybe FilePath) options = ver *> - [i|(,) style exts|] + [i|(,,) style exts file|] where ver = stop (flag "version" "Print the version" Version) style = @@ -73,6 +85,7 @@ Just len -> s {styleDefConfig = (styleDefConfig s) {configMaxColumns = len}} + file = fmap (fmap T.unpack) (optional (anyString "[]")) -------------------------------------------------------------------------------- -- Extensions stuff stolen from hlint