diff --git a/elisp/hindent.el b/elisp/hindent.el --- a/elisp/hindent.el +++ b/elisp/hindent.el @@ -2,6 +2,10 @@ ;; Copyright (c) 2014 Chris Done. All rights reserved. +;; Author: Chris Done +;; URL: https://github.com/chrisdone/hindent +;; Package-Requires: ((cl-lib "0.5")) + ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) @@ -17,12 +21,15 @@ ;;; Code: +(require 'cl-lib) + (defcustom hindent-style "fundamental" "The style to use for formatting." :group 'haskell :type 'string) +;;;###autoload (defun hindent/reformat-decl () "Re-format the current declaration by parsing and pretty printing it. Comments are preserved, although placement may be @@ -145,3 +152,5 @@ (looking-at "{-# ")))))) (provide 'hindent) + +;;; hindent.el ends here diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 3.8 +version: 3.9 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -7,7 +7,7 @@ license: BSD3 stability: Unstable license-file: LICENSE -author: Chris Done +author: Chris Done, Andrew Gibiansky, Tobias Pflug, Pierre Radermecker maintainer: chrisdone@gmail.com copyright: 2014 Chris Done category: Development diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -22,10 +22,10 @@ where import HIndent.Pretty -import HIndent.Styles.ChrisDone -import HIndent.Styles.Fundamental -import HIndent.Styles.Gibiansky -import HIndent.Styles.JohanTibell +import HIndent.Styles.ChrisDone (chrisDone) +import HIndent.Styles.Fundamental (fundamental) +import HIndent.Styles.Gibiansky (gibiansky) +import HIndent.Styles.JohanTibell (johanTibell) import HIndent.Types import Control.Monad.State.Strict @@ -40,6 +40,7 @@ import qualified Data.Text.Lazy.IO as T import Data.Traversable import Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse) +import Data.Maybe (fromMaybe) -- | Format the given source. reformat :: Style -> Text -> Either String Builder @@ -48,7 +49,7 @@ (T.unpack x) of ParseOk (mod,comments) -> let (cs,ast) = - annotateComments mod comments + annotateComments (fromMaybe mod $ applyFixities baseFixities mod) comments in Right (prettyPrint style -- For the time being, assume that all "free-floating" comments come at the beginning. diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -113,8 +113,7 @@ -- | Pretty print a comment. printComment :: Maybe SrcSpan -> ComInfo -> Printer () printComment mayNodespan (ComInfo (Comment inline cspan str) own) = - do col <- getColumn - when own newline + do when own newline -- Insert proper amount of space before comment. -- This maintains alignment. This cannot force comments -- to go before the left-most possible indent (specified by depends). @@ -278,8 +277,12 @@ do eol <- gets psEolComment when (eol && x /= "\n") newline state <- get - let out = - if psNewline state + let clearEmpty = + configClearEmptyLines (psConfig state) + writingNewline = x == "\n" + out = + if psNewline state && + not (clearEmpty && writingNewline) then T.fromText (T.replicate (fromIntegral (psIndentLevel state)) " ") <> @@ -1108,9 +1111,9 @@ do case mayModHead of Nothing -> return () Just modHead -> pretty' modHead - forM_ pragmas pretty - forM_ imps pretty - forM_ decls pretty + inter newline (map pretty pragmas) + inter newline (map pretty imps) + inter newline (map pretty decls) XmlPage{} -> error "FIXME: No implementation for XmlPage." XmlHybrid{} -> diff --git a/src/HIndent/Styles/ChrisDone.hs b/src/HIndent/Styles/ChrisDone.hs --- a/src/HIndent/Styles/ChrisDone.hs +++ b/src/HIndent/Styles/ChrisDone.hs @@ -50,8 +50,8 @@ ,Extender stmt ,Extender decl] ,styleDefConfig = - Config {configMaxColumns = 80 - ,configIndentSpaces = 2}} + defaultConfig {configMaxColumns = 80 + ,configIndentSpaces = 2}} -------------------------------------------------------------------------------- -- Extenders 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 @@ -3,8 +3,9 @@ module HIndent.Styles.Gibiansky (gibiansky) where import Data.Foldable -import Control.Monad (unless, when) +import Control.Monad (unless, when, replicateM_, void) import Control.Monad.State (gets, get, put) +import Debug.Trace import HIndent.Pretty import HIndent.Types @@ -34,11 +35,36 @@ , Extender guardedAlts ] , styleDefConfig = - Config { configMaxColumns = 100 - , configIndentSpaces = 2 - } + defaultConfig { configMaxColumns = maxColumns + , configIndentSpaces = indentSpaces + , configClearEmptyLines = True + } } +-- | Number of spaces to indent by. +indentSpaces :: Integral a => a +indentSpaces = 2 + +-- | Printer to indent one level. +indentOnce :: Printer () +indentOnce = replicateM_ indentSpaces $ write " " + +-- | Max number of columns per line. +maxColumns :: Integral a => a +maxColumns = 100 + +attemptSingleLine :: Printer a -> Printer a -> Printer () +attemptSingleLine single multiple = do + -- Try printing on one line. + prevState <- get + void single + + -- If it doesn't fit, reprint on multiple lines. + col <- getColumn + when (col > maxColumns) $ do + put prevState + void multiple + -------------------------------------------------------------------------------- -- Extenders @@ -134,6 +160,9 @@ exprs _ exp@App{} = appExpr exp exprs _ exp@Do{} = doExpr exp exprs _ exp@List{} = listExpr exp +exprs _ exp@(InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "$"))) _) = dollarExpr exp +exprs _ exp@(InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "<*>"))) _) = applicativeExpr exp +exprs _ exp@Lambda{} = lambdaExpr exp exprs _ exp = prettyNoExt exp letExpr :: Exp NodeInfo -> Printer () @@ -160,16 +189,7 @@ doExpr _ = error "Not a do" listExpr :: Exp NodeInfo -> Printer () -listExpr (List _ els) = do - -- Try printing list on one line. - prevState <- get - singleLineList els - - -- If it doesn't fit, reprint on multiple lines. - col <- getColumn - when (col > configMaxColumns (psConfig prevState)) $ do - put prevState - multiLineList els +listExpr (List _ els) = attemptSingleLine (singleLineList els) (multiLineList els) listExpr _ = error "Not a list" singleLineList :: [Exp NodeInfo] -> Printer () @@ -192,6 +212,82 @@ newline write "]" +dollarExpr :: Exp NodeInfo -> Printer () +dollarExpr (InfixApp _ left op right) = do + pretty left + write " " + pretty op + if needsNewline right + then do + newline + depend indentOnce $ pretty right + else do + write " " + pretty right + where + needsNewline Case{} = True + needsNewline _ = False +dollarExpr _ = error "Not an application" + +applicativeExpr :: Exp NodeInfo -> Printer () +applicativeExpr exp@InfixApp{} = + case applicativeArgs of + Just (first:second:rest) -> + attemptSingleLine (singleLine first second rest) (multiLine first second rest) + _ -> prettyNoExt exp + 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 + ] + + multiLine :: Exp NodeInfo -> Exp NodeInfo -> [Exp NodeInfo] -> Printer () + multiLine first second rest = do + pretty first + depend (write " ") $ do + write "<$> " + pretty second + forM_ rest $ \val -> do + newline + write "<*> " + pretty val + + applicativeArgs :: Maybe [Exp NodeInfo] + applicativeArgs = collectApplicativeExps exp + + collectApplicativeExps :: Exp NodeInfo -> Maybe [Exp NodeInfo] + collectApplicativeExps (InfixApp _ left op right) + | isFmap op = return [left, right] + | isAp op = do + start <- collectApplicativeExps left + return $ start ++ [right] + | otherwise = Nothing + collectApplicativeExps x = return [x] + + isFmap :: QOp NodeInfo -> Bool + isFmap (QVarOp _ (UnQual _ (Symbol _ "<$>"))) = True + isFmap _ = False + + isAp :: QOp NodeInfo -> Bool + isAp (QVarOp _ (UnQual _ (Symbol _ "<*>"))) = True + isAp _ = False +applicativeExpr _ = error "Not an application" + +lambdaExpr :: Exp NodeInfo -> Printer () +lambdaExpr (Lambda _ pats exp) = do + write "\\" + spaced $ map pretty pats + write " ->" + attemptSingleLine (write " " >> pretty exp) $ do + newline + indentOnce + pretty exp +lambdaExpr _ = error "Not a lambda" + rhss :: Extend Rhs rhss _ (UnGuardedRhs _ exp) = do write " = " @@ -219,19 +315,50 @@ forM_ mayDeriving $ \deriv -> do newline - indented 2 $ pretty deriv -decls _ (PatBind _ pat Nothing rhs mbinds) = do - pretty pat + indented indentSpaces $ pretty deriv + +decls _ (PatBind _ pat Nothing rhs mbinds) = funBody [pat] rhs mbinds +decls _ (FunBind _ matches) = + forM_ 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 " " + funBody pat rhs mbinds +decls _ decl = prettyNoExt decl + +funBody :: [Pat NodeInfo] -> Rhs NodeInfo -> Maybe (Binds NodeInfo) -> Printer () +funBody pat rhs mbinds = do + spaced $ map pretty pat pretty rhs - indentSpaces <- getIndentSpaces + + -- Process the binding group, if it exists. forM_ mbinds $ \binds -> do newline + -- Add an extra newline after do blocks. when (isDoBlock rhs) newline indented indentSpaces $ do write "where" newline - indented indentSpaces $ pretty binds -decls _ decl = prettyNoExt decl + indented indentSpaces $ writeWhereBinds binds + +writeWhereBinds :: Binds NodeInfo -> Printer () +writeWhereBinds (BDecls _ binds@(first:rest)) = do + pretty first + forM_ (zip binds rest) $ \(prev, cur) -> do + let prevLine = srcSpanEndLine . srcInfoSpan . nodeInfoSpan . ann $ prev + curLine = startLine . nodeInfoSpan . ann $ cur + emptyLines = curLine - prevLine + replicateM_ (traceShowId emptyLines) newline + pretty cur +writeWhereBinds binds = prettyNoExt binds isDoBlock :: Rhs l -> Bool isDoBlock (UnGuardedRhs _ Do{}) = True diff --git a/src/HIndent/Styles/JohanTibell.hs b/src/HIndent/Styles/JohanTibell.hs --- a/src/HIndent/Styles/JohanTibell.hs +++ b/src/HIndent/Styles/JohanTibell.hs @@ -53,8 +53,8 @@ ,Extender alts ,Extender guardedAlt] ,styleDefConfig = - Config {configMaxColumns = 80 - ,configIndentSpaces = 4}} + defaultConfig {configMaxColumns = 80 + ,configIndentSpaces = 4}} -------------------------------------------------------------------------------- -- Extenders diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -12,6 +12,7 @@ ,Extender(..) ,Style(..) ,Config(..) + ,defaultConfig ,NodeInfo(..) ,ComInfo(..)) where @@ -70,12 +71,18 @@ data Config = Config {configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally. ,configIndentSpaces :: !Int64 -- ^ How many spaces to indent? + ,configClearEmptyLines :: !Bool -- ^ Remove spaces on lines that are otherwise empty? } instance Default Config where def = Config {configMaxColumns = 80 - ,configIndentSpaces = 2} + ,configIndentSpaces = 2 + ,configClearEmptyLines = False} + +-- | Default style configuration. +defaultConfig :: Config +defaultConfig = def -- | Information for each node in the AST. data NodeInfo = diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -5,12 +5,14 @@ module Main where +import HIndent + import Data.List import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as T import qualified Data.Text.Lazy.IO as T -import HIndent -import HIndent.Types +import Data.Version (showVersion) +import Paths_hindent (version) import System.Environment -- | Main entry point. @@ -22,6 +24,7 @@ T.interact (either error T.toLazyText . reformat style) + ["--version"] -> putStrLn $ "hindent " ++ showVersion version _ -> error ("arguments: --style [" ++ intercalate "|" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -43,6 +43,8 @@ expContents <- readFile exp let testDecls = parsePieces testContents expDecls = parsePieces expContents + when (length testDecls /= length expDecls) $ + error $ "Mismatched number of pieces in files " ++ test ++ " and " ++ exp return $ describe ("hindent applied to chunks in " ++ test) $ foldl1 (>>) $ zipWith (mkSpec style) testDecls expDecls mkSpec :: HIndent.Style -> String -> String -> Spec @@ -64,4 +66,5 @@ (nonNull, _:rest) -> (map fst nonNull, map fst rest) pieceBreak :: (String, String) -> Bool + pieceBreak ("", "") = error "Two consecutive line breaks!" pieceBreak (line, next) = null line && head next /= ' '