hindent 5.1.1 → 5.2.0
raw patch · 9 files changed
+526/−312 lines, 9 filesdep +pathdep +path-iodep +unix-compatPVP ok
version bump matches the API change (PVP)
Dependencies added: path, path-io, unix-compat, yaml
API changes (from Hackage documentation)
+ HIndent.Types: instance Data.Aeson.Types.FromJSON.FromJSON HIndent.Types.Config
Files
- CHANGELOG.md +7/−0
- README.md +18/−4
- TESTS.md +200/−189
- elisp/hindent.el +77/−35
- hindent.cabal +10/−1
- src/HIndent/Pretty.hs +2/−2
- src/HIndent/Types.hs +23/−9
- src/main/Main.hs +91/−72
- src/main/Path/Find.hs +98/−0
CHANGELOG.md view
@@ -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)
README.md view
@@ -12,9 +12,11 @@ ## Usage - bash-3.2$ hindent --help- hindent --version --help --style STYLE --line-length <...> --tab-size <...> [-X<...>]* [<FILENAME>]- Version 5.0.1+ $ hindent --help+ hindent --version --help --style STYLE --line-length <...> --tab-size <...> --no-force-newline [-X<...>]* [<FILENAME>]+ 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
TESTS.md view
@@ -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])
elisp/hindent.el view
@@ -19,11 +19,62 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. +;;; 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)))
hindent.cabal view
@@ -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
src/HIndent/Pretty.hs view
@@ -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 "|")
src/HIndent/Types.hs view
@@ -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 }
src/main/Main.hs view
@@ -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 "[<filename>]"))
+ src/main/Path/Find.hs view
@@ -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