diff --git a/elisp/hindent.el b/elisp/hindent.el --- a/elisp/hindent.el +++ b/elisp/hindent.el @@ -44,14 +44,16 @@ (with-temp-buffer (let ((temp (current-buffer))) (with-current-buffer original - (let ((ret (call-process-region (car start-end) + (let ((ret (apply #'call-process-region + (append (list (car start-end) (cdr start-end) "hindent" - nil ; delete + nil ; delete temp ; output nil "--style" - hindent-style))) + hindent-style) + (hindent-extra-arguments))))) (cond ((= ret 1) (let ((error-string @@ -82,6 +84,13 @@ (delete-trailing-whitespace new-start new-end))) (message "Formatted.")) (message "Already formatted."))))))))))))) + +(defun hindent-extra-arguments () + "Pass in extra arguments, such as extensions and optionally +other things later." + (if (boundp 'haskell-language-extensions) + haskell-language-extensions + '())) (defun hindent-reformat-decl-or-fill (justify) "Re-format current declaration, or fill paragraph. diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 4.2.1 +version: 4.2.2 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -40,7 +40,7 @@ build-depends: base >= 4 && < 5 , hindent , text - , descriptive >= 0.0.2 && < 0.1 + , descriptive == 0.2.* , haskell-src-exts executable hindent-generate-tests diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -139,6 +139,8 @@ then do write "{-" string str write "-}" + when (1 == srcSpanStartColumn cspan) $ + modify (\s -> s {psEolComment = True}) else do write "--" string str modify (\s -> diff --git a/src/HIndent/Styles/Gibiansky.hs b/src/HIndent/Styles/Gibiansky.hs --- a/src/HIndent/Styles/Gibiansky.hs +++ b/src/HIndent/Styles/Gibiansky.hs @@ -2,49 +2,51 @@ module HIndent.Styles.Gibiansky where -import Data.Foldable -import Control.Applicative((<$>)) -import Control.Monad (unless, when, replicateM_) -import Control.Monad.State (gets, get, put) +import Data.Foldable +import Control.Applicative ((<$>)) +import Control.Monad (unless, when, replicateM_) +import Control.Monad.State (gets, get, put) +import Data.Maybe (isNothing) -import HIndent.Pretty -import HIndent.Types +import HIndent.Pretty +import HIndent.Types -import Language.Haskell.Exts.Annotated.Syntax -import Language.Haskell.Exts.SrcLoc -import Language.Haskell.Exts.Comments -import Prelude hiding (exp, all, mapM_, minimum, and, maximum) +import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.Exts.Comments +import Prelude hiding (exp, all, mapM_, minimum, and, maximum) -- | Empty state. data State = State -- | The printer style. gibiansky :: Style -gibiansky = - Style { styleName = "gibiansky" - , styleAuthor = "Andrew Gibiansky" - , styleDescription = "Andrew Gibiansky's style" - , styleInitialState = State - , styleExtenders = [ Extender imp - , Extender context - , Extender derivings - , Extender typ - , Extender exprs - , Extender rhss - , Extender guardedRhs - , Extender decls - , Extender condecls - , Extender alt - , Extender moduleHead - , Extender exportList - , Extender fieldUpdate - ] - , styleDefConfig = - defaultConfig { configMaxColumns = 100 - , configIndentSpaces = indentSpaces - , configClearEmptyLines = True - } - } +gibiansky = Style { styleName = "gibiansky" + , styleAuthor = "Andrew Gibiansky" + , styleDescription = "Andrew Gibiansky's style" + , styleInitialState = State + , styleExtenders = [ Extender imp + , Extender modl + , Extender context + , Extender derivings + , Extender typ + , Extender exprs + , Extender rhss + , Extender guardedRhs + , Extender decls + , Extender condecls + , Extender alt + , Extender moduleHead + , Extender exportList + , Extender fieldUpdate + , Extender pragmas + , Extender pat + ] + , styleDefConfig = defaultConfig { configMaxColumns = 100 + , configIndentSpaces = indentSpaces + , configClearEmptyLines = True + } + } -- | Number of spaces to indent by. indentSpaces :: Integral a => a @@ -72,22 +74,49 @@ then do put prevState multiple - else - return result + else return result -------------------------------------------------------------------------------- -- Extenders - type Extend f = forall t. t -> f NodeInfo -> Printer () +-- | Format whole modules. +modl :: Extend Module +modl _ (Module _ mayModHead pragmas imps decls) = do + onSeparateLines pragmas + unless (null pragmas) $ + unless (null imps && null decls && isNothing mayModHead) $ + newline >> newline + forM_ mayModHead $ \modHead -> do + pretty modHead + unless (null imps && null decls) (newline >> newline) + + onSeparateLines imps + unless (null imps || null decls) (newline >> newline) + onSeparateLines decls +modl _ m = prettyNoExt m + +-- | Format pragmas differently (language pragmas). +pragmas :: Extend ModulePragma +pragmas _ (LanguagePragma _ names) = do + write "{-# LANGUAGE " + inter (write ", ") $ map pretty names + write " #-}" +pragmas _ p = prettyNoExt p + +-- | Format patterns. +pat :: Extend Pat +pat _ (PTuple _ boxed pats) = writeTuple boxed pats +pat _ p = prettyNoExt p + -- | Format import statements. imp :: Extend ImportDecl imp _ ImportDecl{..} = do write "import " write $ if importQualified - then "qualified " - else " " + then "qualified " + else " " pretty importModule forM_ importAs $ \name -> do @@ -111,60 +140,60 @@ go instHeads where - go insts | length insts == 1 - = pretty $ head insts - | otherwise - = parens $ inter (comma >> space) $ map pretty insts + go insts + | length insts == 1 = pretty $ head insts + | otherwise = parens $ inter (comma >> space) $ map pretty insts -- | Format function type declarations. typ :: Extend Type - -- For contexts, check whether the context and all following function types -- are on the same line. If they are, print them on the same line; otherwise -- print the context and each argument to the function on separate lines. typ _ (TyForall _ _ (Just ctx) rest) = if all (sameLine ctx) $ collectTypes rest - then do - pretty ctx - write " => " - pretty rest - else do - col <- getColumn - pretty ctx - column (col - 3) $ do - newline - write "=> " - indented 3 $ pretty rest - -typ _ (TyTuple _ boxed types) = parens $ do - boxed' - inter (write ", ") $ map pretty types - boxed' - - where - boxed' = case boxed of - Boxed -> return () - Unboxed -> write "#" - + then do + pretty ctx + write " => " + pretty rest + else do + col <- getColumn + pretty ctx + column (col - 3) $ do + newline + write "=> " + indented 3 $ pretty rest +typ _ (TyTuple _ boxed types) = writeTuple boxed types typ _ ty@(TyFun _ from to) = -- If the function argument types are on the same line, -- put the entire function type on the same line. if all (sameLine from) $ collectTypes ty - then do - pretty from - write " -> " - pretty to - -- If the function argument types are on different lines, - -- write one argument type per line. - else do - col <- getColumn - pretty from - column (col - 3) $ do - newline - write "-> " - indented 3 $ pretty to + then do + pretty from + write " -> " + pretty to + else + -- If the function argument types are on different lines, + -- write one argument type per line. + do + col <- getColumn + pretty from + column (col - 3) $ do + newline + write "-> " + indented 3 $ pretty to typ _ t = prettyNoExt t +writeTuple :: Pretty ast => Boxed -> [ast NodeInfo] -> Printer () +writeTuple boxed vals = parens $ do + boxed' + inter (write ", ") $ map pretty vals + boxed' + where + boxed' = + case boxed of + Boxed -> return () + Unboxed -> write "#" + sameLine :: (Annotated ast, Annotated ast') => ast NodeInfo -> ast' NodeInfo -> Bool sameLine x y = line x == line y where @@ -182,9 +211,11 @@ exprs _ exp@List{} = listExpr exp exprs _ exp@(InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "$"))) _) = dollarExpr exp exprs _ exp@(InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "<*>"))) _) = applicativeExpr exp +exprs _ exp@InfixApp{} = opExpr exp exprs _ exp@Lambda{} = lambdaExpr exp exprs _ exp@Case{} = caseExpr exp exprs _ exp@LCase{} = lambdaCaseExpr exp +exprs _ exp@If{} = ifExpr exp exprs _ (RecUpdate _ exp updates) = recUpdateExpr (pretty exp) updates exprs _ (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates exprs _ (Tuple _ _ exps) = parens $ inter (write ", ") $ map pretty exps @@ -193,9 +224,9 @@ letExpr :: Exp NodeInfo -> Printer () letExpr (Let _ binds result) = do cols <- depend (write "let ") $ do - col <- getColumn - pretty binds - return $ col - 4 + col <- getColumn + pretty binds + return $ col - 4 column cols $ do newline write "in " @@ -248,8 +279,8 @@ -- and all of its arguments. Arguments are returned in reverse order. collectArgs :: Exp NodeInfo -> (Exp NodeInfo, [Exp NodeInfo]) collectArgs (App _ g y) = - let (fun, args) = collectArgs g in - (fun, y : args) + let (fun, args) = collectArgs g + in (fun, y : args) collectArgs nonApp = (nonApp, []) separateArgs :: Exp NodeInfo -> Printer () @@ -261,14 +292,13 @@ pretty fun newline indented indentSpaces $ lined $ map pretty $ reverse args - appExpr _ = error "Not an app" doExpr :: Exp NodeInfo -> Printer () doExpr (Do _ stmts) = do write "do" newline - indented 2 $ lined (map pretty stmts) + indented 2 $ onSeparateLines stmts doExpr _ = error "Not a do" listExpr :: Exp NodeInfo -> Printer () @@ -308,9 +338,10 @@ else do write " " pretty right + where needsNewline Case{} = True - needsNewline _ = False + needsNewline exp = lineDelta exp op > 0 dollarExpr _ = error "Not an application" applicativeExpr :: Exp NodeInfo -> Printer () @@ -322,12 +353,12 @@ where singleLine :: Exp NodeInfo -> Exp NodeInfo -> [Exp NodeInfo] -> Printer () singleLine first second rest = spaced - [ pretty first - , write "<$>" - , pretty second - , write "<*>" - , inter (write " <*> ") $ map pretty rest - ] + [ pretty first + , write "<$>" + , pretty second + , write "<*>" + , inter (write " <*> ") $ map pretty rest + ] multiLine :: Exp NodeInfo -> Exp NodeInfo -> [Exp NodeInfo] -> Printer () multiLine first second rest = do @@ -361,6 +392,27 @@ isAp _ = False applicativeExpr _ = error "Not an application" +opExpr :: Exp NodeInfo -> Printer () +opExpr (InfixApp _ left op right) = do + col <- getColumn + column col $ do + pretty left + + let delta = lineDelta op left + if delta == 0 + then space + else replicateM_ delta newline + + pretty op + + let delta = lineDelta right op + if delta == 0 + then space + else replicateM_ delta newline + + pretty right +opExpr exp = prettyNoExt exp + lambdaExpr :: Exp NodeInfo -> Printer () lambdaExpr (Lambda _ pats exp) = do write "\\" @@ -374,7 +426,6 @@ caseExpr :: Exp NodeInfo -> Printer () caseExpr (Case _ exp alts) = do - depend (write "case ") $ do pretty exp write " of" @@ -390,33 +441,48 @@ writeCaseAlts alts lambdaCaseExpr _ = error "Not a lambda case" +ifExpr :: Exp NodeInfo -> Printer () +ifExpr (If _ cond thenExpr elseExpr) = + depend (write "if") $ do + write " " + pretty cond + newline + write "then " + pretty thenExpr + newline + write "else " + pretty elseExpr +ifExpr _ = error "Not an if statement" writeCaseAlts :: [Alt NodeInfo] -> Printer () writeCaseAlts alts = do allSingle <- and <$> mapM isSingle alts withCaseContext True $ indented indentSpaces $ if allSingle - then do - maxPatLen <- maximum <$> mapM (patternLen . altPattern) alts - lined $ map (prettyCase $ Just maxPatLen) alts - else lined $ map (prettyCase Nothing) alts + then do + maxPatLen <- maximum <$> mapM (patternLen . altPattern) alts + lined $ map (prettyCase $ Just maxPatLen) alts + else lined $ map (prettyCase Nothing) alts + where isSingle :: Alt NodeInfo -> Printer Bool - isSingle alt' = fst <$> sandbox (do - line <- gets psLine - pretty alt' - line' <- gets psLine - return $ line == line') + isSingle alt' = fst <$> sandbox + (do + line <- gets psLine + pretty alt' + line' <- gets psLine + return $ line == line') altPattern :: Alt l -> Pat l altPattern (Alt _ p _ _) = p patternLen :: Pat NodeInfo -> Printer Int - patternLen pat = fromIntegral <$> fst <$> sandbox (do - col <- getColumn - pretty pat - col' <- getColumn - return $ col' - col) + patternLen pat = fromIntegral <$> fst <$> sandbox + (do + col <- getColumn + pretty pat + col' <- getColumn + return $ col' - col) prettyCase :: Maybe Int -> Alt NodeInfo -> Printer () prettyCase mpatlen (Alt _ p galts mbinds) = do @@ -431,7 +497,7 @@ case galts of UnGuardedRhs{} -> pretty galts - GuardedRhss{} -> indented indentSpaces $ pretty galts + GuardedRhss{} -> indented indentSpaces $ pretty galts -- Optional where clause! forM_ mbinds $ \binds -> do @@ -439,7 +505,6 @@ indented indentSpaces $ depend (write "where ") (pretty binds) - recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer () recUpdateExpr expWriter updates = do expWriter @@ -466,8 +531,8 @@ write "}" rhss :: Extend Rhs -rhss _ (UnGuardedRhs _ exp) = do - write " " +rhss _ (UnGuardedRhs rhsLoc exp) = do + write " " rhsSeparator if onNextLine exp then indented indentSpaces $ do @@ -476,24 +541,31 @@ else do space pretty exp - + where + -- Cannot use lineDelta because we need to look at rhs start line, not end line + prevLine = srcSpanStartLine . srcInfoSpan . nodeInfoSpan $ rhsLoc + curLine = astStartLine exp + emptyLines = curLine - prevLine + onNextLine Let{} = True - onNextLine _ = False + onNextLine Case{} = True + onNextLine _ = emptyLines > 0 rhss _ (GuardedRhss _ rs) = lined $ flip map rs $ \a@(GuardedRhs _ stmts exp) -> do printComments Before a - write "| " - inter (write ", ") $ map pretty stmts - write " " - rhsSeparator - write " " - pretty exp + depend (write "| ") $ do + inter (write ", ") $ map pretty stmts + rhsRest exp guardedRhs :: Extend GuardedRhs guardedRhs _ (GuardedRhs _ stmts exp) = do indented 1 $ prefixedLined "," (map (\p -> space >> pretty p) stmts) - write " " + rhsRest exp + +rhsRest :: Pretty ast => ast NodeInfo -> Printer () +rhsRest exp = do + write " " rhsSeparator write " " pretty exp @@ -504,7 +576,7 @@ write " " pretty declHead case constructors of - [] -> return () + [] -> return () [x] -> do write " = " pretty x @@ -520,17 +592,15 @@ forM_ mayDeriving $ \deriv -> do newline indented indentSpaces $ pretty deriv - decls _ (PatBind _ pat rhs mbinds) = funBody [pat] rhs mbinds decls _ (FunBind _ matches) = - lined $ flip map matches $ \match -> do - (name, pat, rhs, mbinds) <- - case match of - Match _ name pat rhs mbinds -> return (name, pat, rhs, mbinds) - InfixMatch _ left name pat rhs mbinds -> do - pretty left - write " " - return (name, pat, rhs, mbinds) + lined $ flip map matches $ \match -> do + (name, pat, rhs, mbinds) <- case match of + Match _ name pat rhs mbinds -> return (name, pat, rhs, mbinds) + InfixMatch _ left name pat rhs mbinds -> do + pretty left + write " " + return (name, pat, rhs, mbinds) pretty name write " " @@ -541,11 +611,12 @@ funBody pat rhs mbinds = do spaced $ map pretty pat - withCaseContext False $ case rhs of - UnGuardedRhs{} -> pretty rhs - GuardedRhss{} -> do - newline - indented indentSpaces $ pretty rhs + withCaseContext False $ + case rhs of + UnGuardedRhs{} -> pretty rhs + GuardedRhss{} -> do + newline + indented indentSpaces $ pretty rhs -- Process the binding group, if it exists. forM_ mbinds $ \binds -> do @@ -558,13 +629,18 @@ indented indentSpaces $ writeWhereBinds binds writeWhereBinds :: Binds NodeInfo -> Printer () -writeWhereBinds ds@(BDecls _ binds@(first:rest)) = do +writeWhereBinds ds@(BDecls _ binds) = do printComments Before ds + onSeparateLines binds +writeWhereBinds binds = prettyNoExt binds + +onSeparateLines :: (Pretty ast, Annotated ast) => [ast NodeInfo] -> Printer () +onSeparateLines vals@(first:rest) = do pretty first - forM_ (zip binds rest) $ \(prev, cur) -> do + forM_ (zip vals rest) $ \(prev, cur) -> do replicateM_ (max 1 $ lineDelta cur prev) newline pretty cur -writeWhereBinds binds = prettyNoExt binds +onSeparateLines [] = return () astStartLine :: Annotated ast => ast NodeInfo -> Int astStartLine decl = @@ -573,8 +649,8 @@ befores = filter ((== Just Before) . comInfoLocation) comments commentStartLine (Comment _ sp _) = srcSpanStartLine sp in if null befores - then startLine $ nodeInfoSpan info - else minimum $ map (commentStartLine . comInfoComment) befores + then startLine $ nodeInfoSpan info + else minimum $ map (commentStartLine . comInfoComment) befores isDoBlock :: Rhs l -> Bool isDoBlock (UnGuardedRhs _ Do{}) = True @@ -588,12 +664,11 @@ depend (pretty name >> space) $ do write "{ " case fields of - [] -> return () - [x] -> do + [] -> return () + [x] -> do pretty x eol <- gets psEolComment unless eol space - first:rest -> do pretty first newline @@ -646,6 +721,7 @@ write "," newline write ")" + where indentSpaces' = 2 * indentSpaces diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -9,6 +9,7 @@ module Main where import HIndent +import HIndent.Types import Control.Applicative import Data.List @@ -19,40 +20,57 @@ import Data.Version (showVersion) import Descriptive import Descriptive.Options -import Language.Haskell.Exts.Annotated hiding (Style) +import Language.Haskell.Exts.Annotated hiding (Style,style) import Paths_hindent (version) import System.Environment +import Text.Read -- | Main entry point. main :: IO () main = do args <- getArgs case consume options (map T.pack args) of - Left{} -> + Succeeded (style,exts) -> + T.interact + (either error T.toLazyText . + reformat style (Just exts)) + Failed (Wrap (Stopped Version) _) -> + putStrLn ("hindent " ++ showVersion version) + _ -> error (T.unpack (textDescription (describe options []))) - Right result -> - case result of - Left{} -> - putStrLn ("hindent " ++ showVersion version) - Right (style,exts) -> - T.interact - (either error T.toLazyText . - reformat style (Just exts)) +-- | Options that stop the argument parser. +data Stoppers = Version + deriving (Show) + -- | Program options. -options :: Consumer [Text] Option (Either Text (Style,[Extension])) +options :: Consumer [Text] (Option Stoppers) (Style,[Extension]) options = - fmap Left (constant "--version") <|> - (fmap Right ((,) <$> style <*> exts)) - where style = - constant "--style" *> - foldr1 (<|>) - (map (\style -> - fmap (const style) - (constant (styleName style))) - styles) + ver *> + ((,) <$> style <*> exts) + where ver = + stop (flag "version" "Print the version" Version) + style = + makeStyle <$> + (constant "--style" "Style to print with" *> + foldr1 (<|>) + (map (\s -> + fmap (const s) + (constant (styleName s) + (styleDescription s))) + styles)) <*> + lineLen exts = fmap getExtensions (many (prefix "X" "Language extension")) + lineLen = + fmap (>>= (readMaybe . T.unpack)) + (optional (arg "line-length" "Desired length of lines")) + makeStyle s mlen = + case mlen of + Nothing -> s + Just len -> + s {styleDefConfig = + (styleDefConfig s) {configMaxColumns = len}} -------------------------------------------------------------------------------- -- Extensions stuff stolen from hlint diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,11 @@ -module Main(main) where +module Main (main) where -import Control.Monad -import Control.Applicative -import Data.List (find, unfoldr, break, isPrefixOf, intercalate) +import Control.Monad +import Control.Applicative +import Data.List (find, unfoldr, break, isPrefixOf, intercalate) -import Test.Hspec -import System.Directory +import Test.Hspec +import System.Directory import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as L @@ -24,10 +24,10 @@ testStyle :: FilePath -> IO () testStyle style = do - let Just theStyle = find ((== T.pack style). HIndent.styleName) HIndent.styles + let Just theStyle = find ((== T.pack style) . HIndent.styleName) HIndent.styles testFilenames <- filter (not . isPrefixOf ".") <$> getDirectoryContents tests let expFiles = map ((expected ++) . expectedFilename) testFilenames - testFiles = map (tests++) testFilenames + testFiles = map (tests ++) testFilenames specs <- forM (zip testFiles expFiles) (uncurry $ useTestFiles theStyle) hspec $ foldl1 (>>) specs @@ -44,16 +44,24 @@ let testDecls = parsePieces testContents expDecls = parsePieces expContents when (length testDecls /= length expDecls) $ - error $ concat [ "Mismatched number of pieces in files " - , test, " (", show $ length testDecls, ")" - , " and " - , exp, " (", show $ length expDecls, ")" - ] - return $ describe ("hindent applied to chunks in " ++ test) $ foldl1 (>>) $ zipWith (mkSpec style) testDecls expDecls + error $ concat + [ "Mismatched number of pieces in files " + , test + , " (" + , show $ length testDecls + , ")" + , " and " + , exp + , " (" + , show $ length expDecls + , ")" + ] + return $ describe ("hindent applied to chunks in " ++ test) $ foldl1 (>>) $ zipWith (mkSpec style) + testDecls expDecls mkSpec :: HIndent.Style -> String -> String -> Spec mkSpec style input desired = it "works" $ - case HIndent.reformat style (L.pack input) of + case HIndent.reformat style Nothing (L.pack input) of Left err -> expectationFailure ("Error: " ++ err) Right builder -> L.unpack (L.toLazyText builder) `shouldBe` desired @@ -65,9 +73,9 @@ unfolder :: [String] -> Maybe ([String], [String]) unfolder [] = Nothing unfolder remaining = Just $ - case break pieceBreak (zip remaining (tail remaining ++ [""])) of - (nonNull, []) -> (map fst nonNull, []) - (nonNull, _:rest) -> (map fst nonNull, map fst rest) + case break pieceBreak (zip remaining (tail remaining ++ [""])) of + (nonNull, []) -> (map fst nonNull, []) + (nonNull, _:rest) -> (map fst nonNull, map fst rest) pieceBreak :: (String, String) -> Bool pieceBreak ("", "") = error "Two consecutive line breaks!"