diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +5.2.0: + * Default tab-width is now 2 + * Supports .hindent.yaml file to specify alt tab-width and max + column + * Put last paren of export list on a new line + * Implement tab-size support in Emacs Lisp + 5.1.1: * Preserve spaces between groups of imports (fixes #200) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,9 +12,11 @@ ## Usage - bash-3.2$ hindent --help - hindent --version --help --style STYLE --line-length <...> --tab-size <...> [-X<...>]* [] - Version 5.0.1 + $ hindent --help + hindent --version --help --style STYLE --line-length <...> --tab-size <...> --no-force-newline [-X<...>]* [] + Version 5.1.1 + Default --tab-size is 2. Specify --tab-size 4 if you prefer that. + -X to pass extensions e.g. -XMagicHash etc. The --style option is now ignored, but preserved for backwards-compatibility. Johan Tibell is the default and only style. @@ -22,7 +24,7 @@ $ cat path/to/sourcefile.hs | hindent -Configure tab size with `--tab-size`: +The default tab size is `2`. Configure tab size with `--tab-size`: $ echo 'example = case x of Just p -> foo bar' | hindent --tab-size 2; echo example = @@ -32,6 +34,18 @@ example = case x of Just p -> foo bar + +## Customization + +Create a `.hindent.yaml` file in your project directory or in your +`~/` home directory. The following fields are accepted and are the +default: + +``` yaml +tab-size: 2 +line-length: 80 +force-trailing-newline: true +``` ## Emacs diff --git a/TESTS.md b/TESTS.md --- a/TESTS.md +++ b/TESTS.md @@ -59,11 +59,11 @@ ``` haskell instance C a where - foobar = do - x y - k p -``` + foobar = do + x y + k p +``` # Expressions Lazy patterns in a lambda @@ -84,63 +84,63 @@ ``` haskell defaultExtensions = - [ e - | e@EnableExtension {} <- knownExtensions ] \\ - map EnableExtension badExtensions -``` + [ e + | e@EnableExtension {} <- knownExtensions ] \\ + map EnableExtension badExtensions +``` Record indentation ``` haskell getGitProvider :: EventProvider GitRecord () getGitProvider = - EventProvider - { getModuleName = "Git" - , getEvents = getRepoCommits - } -``` + EventProvider + { getModuleName = "Git" + , getEvents = getRepoCommits + } +``` Records again ``` haskell commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event commitToEvent gitFolderPath timezone commit = - Event.Event - { pluginName = getModuleName getGitProvider - , eventIcon = "glyphicon-cog" - , eventDate = localTimeToUTC timezone (commitDate commit) - } -``` + Event.Event + { pluginName = getModuleName getGitProvider + , eventIcon = "glyphicon-cog" + , eventDate = localTimeToUTC timezone (commitDate commit) + } +``` Cases ``` haskell strToMonth :: String -> Int strToMonth month = - case month of - "Jan" -> 1 - "Feb" -> 2 - _ -> error $ "Unknown month " ++ month -``` + case month of + "Jan" -> 1 + "Feb" -> 2 + _ -> error $ "Unknown month " ++ month +``` Operators ``` haskell x = - Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*> Just thisissolong <*> - Just stilllonger -``` + Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*> Just thisissolong <*> + Just stilllonger +``` # Type signatures Class constraints ``` haskell fun - :: (Class a, Class b) - => a -> b -> c -``` + :: (Class a, Class b) + => a -> b -> c +``` Tuples ``` haskell @@ -153,8 +153,8 @@ ``` haskell sayHello = do - name <- getLine - putStrLn $ greeting name + name <- getLine + putStrLn $ greeting name where greeting name = "Hello, " ++ name ++ "!" ``` @@ -163,11 +163,11 @@ ``` haskell f x - | x <- Just x - , x <- Just x = - case x of - Just x -> e - | otherwise = do e + | x <- Just x + , x <- Just x = + case x of + Just x -> e + | otherwise = do e where x = y ``` @@ -176,25 +176,25 @@ ``` haskell x = - if | x <- Just x, - x <- Just x -> - case x of - Just x -> e - Nothing -> p - | otherwise -> e -``` + if | x <- Just x, + x <- Just x -> + case x of + Just x -> e + Nothing -> p + | otherwise -> e +``` Case inside a `where` and `do` ``` haskell g x = - case x of - a -> x + case x of + a -> x where foo = - case x of - _ -> do - launchMissiles + case x of + _ -> do + launchMissiles where y = 2 ``` @@ -203,29 +203,29 @@ ``` haskell g x = - let x = 1 - in x + let x = 1 + in x where foo = - let y = 2 - z = 3 - in y -``` + let y = 2 + z = 3 + in y +``` Lists ``` haskell exceptions = [InvalidStatusCode, MissingContentHeader, InternalServerError] exceptions = - [ InvalidStatusCode - , MissingContentHeader - , InternalServerError - , InvalidStatusCode - , MissingContentHeader - , InternalServerError] -``` + [ InvalidStatusCode + , MissingContentHeader + , InternalServerError + , InvalidStatusCode + , MissingContentHeader + , InternalServerError] +``` # Johan Tibell compatibility checks Basic example from Tibbe's style @@ -233,67 +233,67 @@ ``` haskell sayHello :: IO () sayHello = do - name <- getLine - putStrLn $ greeting name + name <- getLine + putStrLn $ greeting name where greeting name = "Hello, " ++ name ++ "!" filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) - | p x = x : filter p xs - | otherwise = filter p xs -``` + | p x = x : filter p xs + | otherwise = filter p xs +``` Data declarations ``` haskell data Tree a - = Branch !a - !(Tree a) - !(Tree a) - | Leaf + = Branch !a + !(Tree a) + !(Tree a) + | Leaf data HttpException - = InvalidStatusCode Int - | MissingContentHeader + = InvalidStatusCode Int + | MissingContentHeader data Person = Person - { firstName :: !String -- ^ First name - , lastName :: !String -- ^ Last name - , age :: !Int -- ^ Age - } -``` + { firstName :: !String -- ^ First name + , lastName :: !String -- ^ Last name + , age :: !Int -- ^ Age + } +``` Spaces between deriving classes ``` haskell -- From https://github.com/chrisdone/hindent/issues/167 data Person = Person - { firstName :: !String -- ^ First name - , lastName :: !String -- ^ Last name - , age :: !Int -- ^ Age - } deriving (Eq, Show) -``` + { firstName :: !String -- ^ First name + , lastName :: !String -- ^ Last name + , age :: !Int -- ^ Age + } deriving (Eq, Show) +``` Hanging lambdas ``` haskell bar :: IO () bar = - forM_ [1, 2, 3] $ - \n -> do - putStrLn "Here comes a number!" - print n + forM_ [1, 2, 3] $ + \n -> do + putStrLn "Here comes a number!" + print n foo :: IO () foo = - alloca 10 $ - \a -> - alloca 20 $ - \b -> cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu) -``` + alloca 10 $ + \a -> + alloca 20 $ + \b -> cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu) +``` # Comments Comments within a declaration @@ -301,41 +301,41 @@ ``` haskell bob -- after bob = - foo -- next to foo - -- line after foo - (bar - foo -- next to bar foo - bar -- next to bar - ) -- next to the end paren of (bar) - -- line after (bar) - mu -- next to mu - -- line after mu - -- another line after mu - zot -- next to zot - -- line after zot - (case casey -- after casey - of - Just -- after Just - -> do - justice -- after justice - * - foo - (blah * blah + z + 2 / 4 + a - -- before a line break - 2 * -- inside this mess - z / - 2 / - 2 / - aooooo / - aaaaa -- bob comment - ) + - (sdfsdfsd fsdfsdf) -- blah comment - putStrLn "") - [1, 2, 3] - [ 1 -- foo - , ( 2 -- bar - , 2.5 -- mu - ) - , 3] + foo -- next to foo + -- line after foo + (bar + foo -- next to bar foo + bar -- next to bar + ) -- next to the end paren of (bar) + -- line after (bar) + mu -- next to mu + -- line after mu + -- another line after mu + zot -- next to zot + -- line after zot + (case casey -- after casey + of + Just -- after Just + -> do + justice -- after justice + * + foo + (blah * blah + z + 2 / 4 + a - -- before a line break + 2 * -- inside this mess + z / + 2 / + 2 / + aooooo / + aaaaa -- bob comment + ) + + (sdfsdfsd fsdfsdf) -- blah comment + putStrLn "") + [1, 2, 3] + [ 1 -- foo + , ( 2 -- bar + , 2.5 -- mu + ) + , 3] foo = 1 -- after foo ``` @@ -351,23 +351,23 @@ main = return () data X - = X -- ^ X is for xylophone. - | Y -- ^ Y is for why did I eat that pizza. + = X -- ^ X is for xylophone. + | Y -- ^ Y is for why did I eat that pizza. data X = X - { field1 :: Int -- ^ Field1 is the first field. - , field11 :: Char - -- ^ This field comment is on its own line. - , field2 :: Int -- ^ Field2 is the second field. - , field3 :: Char -- ^ This is a long comment which starts next to - -- the field but continues onto the next line, it aligns exactly - -- with the field name. - , field4 :: Char - -- ^ This is a long comment which starts on the following line - -- from from the field, lines continue at the sme column. - } -``` + { field1 :: Int -- ^ Field1 is the first field. + , field11 :: Char + -- ^ This field comment is on its own line. + , field2 :: Int -- ^ Field2 is the second field. + , field3 :: Char -- ^ This is a long comment which starts next to + -- the field but continues onto the next line, it aligns exactly + -- with the field name. + , field4 :: Char + -- ^ This is a long comment which starts on the following line + -- from from the field, lines continue at the sme column. + } +``` Comments around regular declarations ``` haskell @@ -384,13 +384,13 @@ ``` haskell -- https://github.com/chrisdone/hindent/issues/186 trans One e n = - M.singleton - (Query Unmarked (Mark NonExistent)) -- The goal of this is to fail always - (emptyImage - { notPresent = S.singleton (TransitionResult Two (Just A) n) - }) -``` + M.singleton + (Query Unmarked (Mark NonExistent)) -- The goal of this is to fail always + (emptyImage + { notPresent = S.singleton (TransitionResult Two (Just A) n) + }) +``` sheyll explicit forall in instances #218 ``` haskell @@ -438,6 +438,20 @@ import HelloWorld ``` +radupopescu `deriving` keyword not aligned with pipe symbol for type declarations + +``` haskell +data Stuffs + = Things + | This + | That + deriving (Show) + +data Simple = + Simple + deriving (Show) +``` + # Behaviour checks Unicode @@ -467,54 +481,51 @@ ``` haskell quasiQuotes = - [ ( ''[] - , \(typeVariable:_) _automaticPrinter -> - (let presentVar = varE (presentVarName typeVariable) - in lamE - [varP (presentVarName typeVariable)] - [|(let typeString = "[" ++ fst $(presentVar) ++ "]" - in ( typeString - , \xs -> - case fst $(presentVar) of - "GHC.Types.Char" -> - ChoicePresentation - "String" - [ ( "String" - , StringPresentation - "String" - (concatMap - getCh - (map - (snd - $(presentVar)) - xs))) - , ( "List of characters" - , ListPresentation - typeString - (map (snd $(presentVar)) xs))] - where getCh (CharPresentation "GHC.Types.Char" ch) = - ch - getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) = - ch - getCh _ = "" - _ -> - ListPresentation - typeString - (map (snd $(presentVar)) xs)))|]))] + [ ( ''[] + , \(typeVariable:_) _automaticPrinter -> + (let presentVar = varE (presentVarName typeVariable) + in lamE + [varP (presentVarName typeVariable)] + [|(let typeString = "[" ++ fst $(presentVar) ++ "]" + in ( typeString + , \xs -> + case fst $(presentVar) of + "GHC.Types.Char" -> + ChoicePresentation + "String" + [ ( "String" + , StringPresentation + "String" + (concatMap + getCh + (map (snd $(presentVar)) xs))) + , ( "List of characters" + , ListPresentation + typeString + (map (snd $(presentVar)) xs))] + where getCh (CharPresentation "GHC.Types.Char" ch) = + ch + getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) = + ch + getCh _ = "" + _ -> + ListPresentation + typeString + (map (snd $(presentVar)) xs)))|]))] ``` Random snippet from hindent itself ``` haskell exp' (App _ op a) = do - (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args))) - if fits - then put st - else do - pretty f - newline - spaces <- getIndentSpaces - indented spaces (lined (map pretty args)) + (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args))) + if fits + then put st + else do + pretty f + newline + spaces <- getIndentSpaces + indented spaces (lined (map pretty args)) where (f, args) = flatten op [a] flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo, [Exp NodeInfo]) diff --git a/elisp/hindent.el b/elisp/hindent.el --- a/elisp/hindent.el +++ b/elisp/hindent.el @@ -19,11 +19,62 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . +;;; Commentary: + +;; Provides a minor mode and commands for easily using the "hindent" +;; program to reformat Haskell code. + +;; Add `hindent-mode' to your `haskell-mode-hook' and use the provided +;; keybindings as needed. Set `hindent-reformat-buffer-on-save' to +;; `t' globally or in local variables to have your code automatically +;; reformatted. + ;;; Code: (require 'cl-lib) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization properties + +(defcustom hindent-style + nil + "The style to use for formatting. + +This customization is deprecated and ignored." + :group 'haskell + :type 'string + :safe #'stringp) + +(defcustom hindent-process-path + "hindent" + "Location where the hindent executable is located." + :group 'haskell + :type 'string + :safe #'stringp) + +(defcustom hindent-line-length + 80 + "Optionally override the line length." + :group 'haskell + :type '(choice (const :tag "Default: 80" 80) + (integer :tag "Override" 120)) + :safe (lambda (val) (or (integerp val) (not val)))) + +(defcustom hindent-tab-size + 2 + "Optionally override the tab size." + :group 'haskell + :type '(choice (const :tag "Default: 2" 2) + (integer :tag "Override" 4)) + :safe (lambda (val) (or (integerp val) (not val)))) + +(defcustom hindent-reformat-buffer-on-save nil + "Set to t to run `hindent-reformat-buffer' when a buffer in +`hindent-mode' is saved." + :group 'haskell + :safe #'booleanp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Minor mode (defvar hindent-mode-map @@ -44,32 +95,15 @@ :keymap hindent-mode-map :lighter " HI" :group 'haskell - :require 'hindent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Customization properties - -(defcustom hindent-style - "fundamental" - "The style to use for formatting." - :group 'haskell - :type 'string - :safe #'stringp) - -(defcustom hindent-process-path - "hindent" - "Location where the hindent executable is located." - :group 'haskell - :type 'string - :safe #'stringp) + :require 'hindent + (if hindent-mode + (add-hook 'before-save-hook 'hindent--before-save nil t) + (remove-hook 'before-save-hook 'hindent--before-save t))) -(defcustom hindent-line-length - nil - "Optionally override the line length of the formatting style." - :group 'haskell - :type '(choice (const :tag "From style" nil) - (integer :tag "Override" 80)) - :safe (lambda (val) (or (integerp val) (not val)))) +(defun hindent--before-save () + "Optionally reformat the buffer on save." + (when hindent-reformat-buffer-on-save + (hindent-reformat-buffer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Interactive functions @@ -84,7 +118,7 @@ (when start-end (let ((beg (car start-end)) (end (cdr start-end))) - (hindent-reformat-region beg end))))) + (hindent-reformat-region beg end t))))) ;;;###autoload (defun hindent-reformat-buffer () @@ -108,19 +142,20 @@ (hindent/reformat-decl))) ;;;###autoload -(defun hindent-reformat-region (beg end) +(defun hindent-reformat-region (beg end &optional drop-newline) "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) + (hindent-reformat-region-as-is beg end drop-newline) (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)) + (point-max) + drop-newline) (delete-region (point-min) (1+ column)) (buffer-substring (point-min) (point-max))))) @@ -137,7 +172,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal library -(defun hindent-reformat-region-as-is (beg end) +(defun hindent-reformat-region-as-is (beg end &optional drop-newline) "Reformat the given region as-is. This is the place where hindent is actually called." @@ -152,13 +187,15 @@ hindent-process-path nil ; delete temp ; output - nil - "--style" - hindent-style) + nil) (when hindent-line-length (list "--line-length" (number-to-string hindent-line-length))) + (when hindent-tab-size + (list "--tab-size" + (number-to-string + hindent-tab-size))) (hindent-extra-arguments))))) (cond ((= ret 1) @@ -172,8 +209,13 @@ (message "language pragma") (error error-string)))) ((= ret 0) - (let ((new-str (with-current-buffer temp - (buffer-string)))) + (let* ((last-decl (= end (point-max))) + (new-str (with-current-buffer temp + (when (and drop-newline (not last-decl)) + (goto-char (point-max)) + (when (looking-back "\n") + (delete-backward-char 1))) + (buffer-string)))) (if (not (string= new-str orig-str)) (let ((line (line-number-at-pos)) (col (current-column))) diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 5.1.1 +version: 5.2.0 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -42,11 +42,13 @@ , transformers , exceptions , text + , yaml executable hindent hs-source-dirs: src/main ghc-options: -Wall -O2 main-is: Main.hs + other-modules: Path.Find build-depends: base >= 4 && < 5 , hindent , bytestring @@ -56,6 +58,13 @@ , ghc-prim , directory , text + , yaml + , unix-compat + , deepseq + , path + , path-io + , transformers + , exceptions test-suite hindent-test type: exitcode-stdio-1.0 diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -779,7 +779,7 @@ instance Pretty Deriving where prettyInternal (Deriving _ heads) = - do write " deriving" + do write "deriving" space let heads' = if length heads == 1 @@ -1513,7 +1513,7 @@ multiCons condecls)) case mderivs of Nothing -> return () - Just derivs -> pretty derivs + Just derivs -> space >> pretty derivs where multiCons xs = depend (write " =") (inter (write "|") diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} @@ -16,14 +17,17 @@ ,NodeComment(..) ) where -import Control.Applicative -import Control.Monad -import Control.Monad.State.Strict (MonadState(..),StateT) -import Control.Monad.Trans.Maybe -import Data.ByteString.Builder -import Data.Functor.Identity -import Data.Int (Int64) -import Language.Haskell.Exts.SrcLoc +import Control.Applicative +import Control.Monad +import Control.Monad.State.Strict (MonadState(..),StateT) +import Control.Monad.Trans.Maybe +import Data.ByteString.Builder +import Data.Functor.Identity +import Data.Int (Int64) +import Data.Maybe +import Data.Yaml (FromJSON(..)) +import qualified Data.Yaml as Y +import Language.Haskell.Exts.SrcLoc -- | A pretty printing monad. newtype Printer a = @@ -60,12 +64,22 @@ , configTrailingNewline :: !Bool -- ^ End with a newline. } +instance FromJSON Config where + parseJSON (Y.Object v) = + Config <$> + fmap (fromMaybe (configMaxColumns defaultConfig)) (v Y..:? "line-length") <*> + fmap (fromMaybe (configIndentSpaces defaultConfig)) (v Y..:? "tab-size") <*> + fmap + (fromMaybe (configTrailingNewline defaultConfig)) + (v Y..:? "force-trailing-newline") + parseJSON _ = fail "Expected Object for Config value" + -- | Default style configuration. defaultConfig :: Config defaultConfig = Config { configMaxColumns = 80 - , configIndentSpaces = 4 + , configIndentSpaces = 2 , configTrailingNewline = True } diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -6,7 +6,6 @@ -- | Main entry point to hindent. -- -- hindent - module Main where import Control.Applicative @@ -18,102 +17,122 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Version (showVersion) +import qualified Data.Yaml as Y import Descriptive import Descriptive.Options import Foreign.C.Error import GHC.IO.Exception import HIndent import HIndent.Types -import Language.Haskell.Exts hiding (Style,style) +import Language.Haskell.Exts hiding (Style, style) +import Path +import qualified Path.Find as Path +import qualified Path.IO as Path import Paths_hindent (version) -import System.Directory +import qualified System.Directory as IO import System.Environment -import System.IO +import qualified System.IO as IO import Text.Read -- | Main entry point. main :: IO () main = do - args <- getArgs - case consume options (map T.pack args) of - Succeeded (style, exts, mfilepath) -> - case mfilepath of - Just filepath -> do - text <- S.readFile filepath - tmpDir <- getTemporaryDirectory - (fp, h) <- openTempFile tmpDir "hindent.hs" - case reformat style (Just exts) text of - Left e -> error (filepath ++ ": " ++ e) - Right out -> do - L8.hPutStr h (S.toLazyByteString out) - hFlush h - hClose h - let exdev e = - if ioe_errno e == - Just ((\(Errno a) -> a) eXDEV) - then copyFile fp filepath >> - removeFile fp - else throw e - renameFile fp filepath `catch` exdev - Nothing -> - L8.interact - (either error S.toLazyByteString . - reformat style (Just exts) . L8.toStrict) - Failed (Wrap (Stopped Version) _) -> - putStrLn ("hindent " ++ showVersion version) - Failed (Wrap (Stopped Help) _) -> putStrLn help - _ -> error help - where - + args <- getArgs + config <- getConfig + case consume (options config) (map T.pack args) of + Succeeded (style, exts, mfilepath) -> + case mfilepath of + Just filepath -> do + text <- S.readFile filepath + tmpDir <- IO.getTemporaryDirectory + (fp, h) <- IO.openTempFile tmpDir "hindent.hs" + case reformat style (Just exts) text of + Left e -> error (filepath ++ ": " ++ e) + Right out -> do + L8.hPutStr h (S.toLazyByteString out) + IO.hFlush h + IO.hClose h + let exdev e = + if ioe_errno e == Just ((\(Errno a) -> a) eXDEV) + then IO.copyFile fp filepath >> IO.removeFile fp + else throw e + IO.renameFile fp filepath `catch` exdev + Nothing -> + L8.interact + (either error S.toLazyByteString . reformat style (Just exts) . L8.toStrict) + Failed (Wrap (Stopped Version) _) -> + putStrLn ("hindent " ++ showVersion version) + Failed (Wrap (Stopped Help) _) -> putStrLn (help defaultConfig) + _ -> error (help defaultConfig) +-- | Read config from a config file, or return 'defaultConfig'. +getConfig :: IO Config +getConfig = do + cur <- Path.getCurrentDir + homeDir <- Path.getHomeDir + mfile <- + Path.findFileUp cur ((== ".hindent.yaml") . toFilePath . filename) (Just homeDir) + case mfile of + Nothing -> return defaultConfig + Just file -> do + result <- Y.decodeFileEither (toFilePath file) + case result of + Left e -> error (show e) + Right config -> return config -help :: [Char] -help = - "hindent " ++ - T.unpack (textDescription (describe options [])) ++ - "\nVersion " ++ showVersion version ++ "\n" ++ - "-X to pass extensions e.g. -XMagicHash etc.\n" ++ - "The --style option is now ignored, but preserved for backwards-compatibility.\n" ++ - "Johan Tibell is the default and only style." +-- | Help text. +help :: Config -> String +help config = + "hindent " ++ + T.unpack (textDescription (describe (options config) [])) ++ + "\nVersion " ++ + showVersion version ++ + "\n" ++ + "Default --tab-size is 2. Specify --tab-size 4 if you prefer that.\n" ++ + "-X to pass extensions e.g. -XMagicHash etc.\n" ++ + "The --style option is now ignored, but preserved for backwards-compatibility.\n" ++ + "Johan Tibell is the default and only style." -- | Options that stop the argument parser. -data Stoppers = Version | Help - deriving (Show) +data Stoppers + = Version + | Help + deriving (Show) -- | Program options. -options :: Monad m - => Consumer [Text] (Option Stoppers) m (Config,[Extension],Maybe FilePath) -options = ver *> ((,,) <$> style <*> exts <*> file) +options + :: Monad m + => Config -> Consumer [Text] (Option Stoppers) m (Config, [Extension], Maybe FilePath) +options config = ver *> ((,,) <$> style <*> exts <*> file) where ver = - stop (flag "version" "Print the version" Version) *> - stop (flag "help" "Show help" Help) + stop (flag "version" "Print the version" Version) *> + stop (flag "help" "Show help" Help) style = - makeStyle <$> - fmap - (const defaultConfig) - (optional - (constant "--style" "Style to print with" () *> - anyString "STYLE")) <*> - lineLen <*> - tabsize <*> - trailingNewline + makeStyle <$> + fmap + (const config) + (optional + (constant "--style" "Style to print with" () *> anyString "STYLE")) <*> + lineLen <*> + tabsize <*> + trailingNewline exts = fmap getExtensions (many (prefix "X" "Language extension")) tabsize = - fmap - (>>= (readMaybe . T.unpack)) - (optional (arg "tab-size" "Tab size, default: 4")) + fmap + (>>= (readMaybe . T.unpack)) + (optional (arg "tab-size" "Tab size, default: 4")) lineLen = - fmap - (>>= (readMaybe . T.unpack)) - (optional (arg "line-length" "Desired length of lines")) + fmap + (>>= (readMaybe . T.unpack)) + (optional (arg "line-length" "Desired length of lines")) trailingNewline = - optional - (constant "--no-force-newline" "Don't force a trailing newline" False) + optional + (constant "--no-force-newline" "Don't force a trailing newline" False) makeStyle s mlen tabs trailing = - s - { configMaxColumns = fromMaybe (configMaxColumns s) mlen - , configIndentSpaces = fromMaybe (configIndentSpaces s) tabs - , configTrailingNewline = fromMaybe (configTrailingNewline s) trailing - } + s + { configMaxColumns = fromMaybe (configMaxColumns s) mlen + , configIndentSpaces = fromMaybe (configIndentSpaces s) tabs + , configTrailingNewline = fromMaybe (configTrailingNewline s) trailing + } file = fmap (fmap T.unpack) (optional (anyString "[]")) diff --git a/src/main/Path/Find.hs b/src/main/Path/Find.hs new file mode 100644 --- /dev/null +++ b/src/main/Path/Find.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} + +-- | Finding files. + +-- Lifted from Stack. + +module Path.Find + (findFileUp + ,findDirUp + ,findFiles + ,findInParents) + where + +import Control.Exception (evaluate) +import Control.DeepSeq (force) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import System.IO.Error (isPermissionError) +import Data.List +import Path +import Path.IO hiding (findFiles) +import System.PosixCompat.Files (getSymbolicLinkStatus, isSymbolicLink) + +-- | Find the location of a file matching the given predicate. +findFileUp :: (MonadIO m,MonadThrow m) + => Path Abs Dir -- ^ Start here. + -> (Path Abs File -> Bool) -- ^ Predicate to match the file. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs File)) -- ^ Absolute file path. +findFileUp = findPathUp snd + +-- | Find the location of a directory matching the given predicate. +findDirUp :: (MonadIO m,MonadThrow m) + => Path Abs Dir -- ^ Start here. + -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path. +findDirUp = findPathUp fst + +-- | Find the location of a path matching the given predicate. +findPathUp :: (MonadIO m,MonadThrow m) + => (([Path Abs Dir],[Path Abs File]) -> [Path Abs t]) + -- ^ Choose path type from pair. + -> Path Abs Dir -- ^ Start here. + -> (Path Abs t -> Bool) -- ^ Predicate to match the path. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs t)) -- ^ Absolute path. +findPathUp pathType dir p upperBound = + do entries <- listDir dir + case find p (pathType entries) of + Just path -> return (Just path) + Nothing | Just dir == upperBound -> return Nothing + | parent dir == dir -> return Nothing + | otherwise -> findPathUp pathType (parent dir) p upperBound + +-- | Find files matching predicate below a root directory. +-- +-- NOTE: this skips symbolic directory links, to avoid loops. This may +-- not make sense for all uses of file finding. +-- +-- TODO: write one of these that traverses symbolic links but +-- efficiently ignores loops. +findFiles :: Path Abs Dir -- ^ Root directory to begin with. + -> (Path Abs File -> Bool) -- ^ Predicate to match files. + -> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse. + -> IO [Path Abs File] -- ^ List of matching files. +findFiles dir p traversep = + do (dirs,files) <- catchJust (\ e -> if isPermissionError e + then Just () + else Nothing) + (listDir dir) + (\ _ -> return ([], [])) + filteredFiles <- evaluate $ force (filter p files) + filteredDirs <- filterM (fmap not . isSymLink) dirs + subResults <- + forM filteredDirs + (\entry -> + if traversep entry + then findFiles entry p traversep + else return []) + return (concat (filteredFiles : subResults)) + +isSymLink :: Path Abs t -> IO Bool +isSymLink = fmap isSymbolicLink . getSymbolicLinkStatus . toFilePath + +-- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until +-- it finds a 'Just' or reaches the root directory. +findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a) +findInParents f path = do + mres <- f path + case mres of + Just res -> return (Just res) + Nothing -> do + let next = parent path + if next == path + then return Nothing + else findInParents f next