diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,4 @@ +.cabal-sandbox/ +cabal.sandbox.config dist README.xhtml diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,22 +1,37 @@ FORMATTED_FILES = Setup.hs src testsuite/src -FORMATTER_UTILITY = dist/build/haskell-formatter/haskell-formatter +FORMATTER_UTILITY = cabal run -- FORMATTER_ARGUMENTS = --force --input {} --output {} -GENERATED_FILES = dist README.xhtml -all: +.PHONY : all build test document format sandbox clean + +all : build test document format + +build : + cabal install --only-dependencies --enable-tests -j cabal configure --enable-tests - cabal build + cabal build -j - cabal test +test : build + cabal test -j + cabal check +document : build README.xhtml cabal haddock --internal - rst2html --strict README.rst README.xhtml +%.xhtml : %.rst + rst2html --strict $< $@ + +format : build # Use "xargs" instead of "-exec", since # 1. the call should fail if any "-exec" fails and # 2. the behavior of multiple "{}" is undefined for a standard "find". find $(FORMATTED_FILES) -type f -name '*.hs' -print0 | \ xargs -n 1 -0 -I {} $(FORMATTER_UTILITY) $(FORMATTER_ARGUMENTS) -clean: - rm -fr $(GENERATED_FILES) +sandbox : + cabal sandbox init + $(MAKE) build + +clean : + cabal clean + cabal sandbox delete diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -2,32 +2,47 @@ Haskell Formatter ================= -Introduction -============ - The Haskell Formatter formats Haskell source code. It is strict in that it fundamentally rearranges code. Installation ============ +Run + :: $ cabal install haskell-formatter +to create an executable, which is referred to as ``haskell-formatter`` in the following. On Linux, for example, you should now be able to call it as + +:: + + $ ~/.cabal/bin/haskell-formatter --help + +In case of issues with dependencies, try to use a Cabal sandbox. For convenience, this can be done by + +:: + + $ make sandbox + Usage ===== Basics ------ -For example, source code is read from ``Input.hs``, formatted, and written to ``Output.hs`` by +Read source code from ``Input.hs``, format it, and write it to ``Output.hs`` by :: $ haskell-formatter --input Input.hs --output Output.hs -If the input or output file is not given, it defaults to the corresponding standard stream. +If the input or output file is not given, it defaults to the corresponding standard stream. This allows commands like +:: + + $ haskell-formatter < Input.hs + For more help about the usage, call :: @@ -43,7 +58,7 @@ $ haskell-formatter --style my_style.yaml --input Input.hs --output Output.hs -uses ``my_style.yaml`` as a style file. Such a file generally follows the `YAML format `_. The following is an `example style file `_, which at the same time shows the available keys with their default values. +uses ``my_style.yaml`` as a style file. Such files are in the `YAML format `_. The following is an `example style file `_, which at the same time shows the available keys with their default values. .. GitHub does currently not allow to include files with the reStructuredText directive ``include`` (https://github.com/github/markup/issues/172). @@ -62,13 +77,16 @@ # Reference: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777 ribbons_per_line: 1 + # More than this number of empty lines in succession are merged. + successive_empty_lines_limit: 1 + # Indentation lengths in characters. indentations: - class: 8 # "class" and "instance" declarations. - do: 3 # "do" notation. - case: 4 # Body of "case" expressions. - let: 4 # Declarations in "let" expressions. - where: 6 # Declarations in "where" clauses. + class: 8 # "class" and "instance" declarations. + do: 3 # "do" notation. + case: 4 # Body of "case" expressions. + let: 4 # Declarations in "let" expressions. + where: 6 # Declarations in "where" clauses. onside: 2 # Continuation lines which would otherwise be offside. # Decides which parts of the code to sort. @@ -82,7 +100,7 @@ Related Projects ================ -The following interesting projects aim at formatting Haskell code, too. +You may like to have a look at the following projects, which aim at formatting Haskell code, too. * `hindent `_ * `stylish-haskell `_ diff --git a/haskell-formatter.cabal b/haskell-formatter.cabal --- a/haskell-formatter.cabal +++ b/haskell-formatter.cabal @@ -1,5 +1,5 @@ name: haskell-formatter -version: 0.1.0 +version: 1.0.0 synopsis: Haskell source code formatter homepage: https://github.com/evolutics/haskell-formatter bug-reports: https://github.com/evolutics/haskell-formatter/issues @@ -7,7 +7,7 @@ license-file: LICENSE author: Benjamin Fischer maintainer: Benjamin Fischer -copyright: (C) 2014 Benjamin Fischer +copyright: (C) 2014–2015 Benjamin Fischer category: Development build-type: Simple cabal-version: >= 1.8 @@ -49,7 +49,7 @@ Language.Haskell.Formatter.Process.FormatActualCode, Language.Haskell.Formatter.Process.FormatComments, Language.Haskell.Formatter.Process.Formatter, - Language.Haskell.Formatter.Process.LineShifting, + Language.Haskell.Formatter.Process.LineTool, Language.Haskell.Formatter.Process.Note, Language.Haskell.Formatter.Result, Language.Haskell.Formatter.Source, @@ -60,13 +60,13 @@ Language.Haskell.Formatter.Toolkit.Visit build-depends: - base == 4.6.*, - containers == 0.5.*, - haskell-src-exts == 1.15.*, - scientific == 0.3.*, - text == 1.1.*, - unordered-containers == 0.2.*, - yaml == 0.8.* + base >= 4.6 && < 4.8, + containers >= 0.5, + haskell-src-exts == 1.16.*, + scientific >= 0.3, + text >= 1.0, + unordered-containers >= 0.2, + yaml >= 0.8 hs-source-dirs: src/library @@ -77,11 +77,11 @@ main-is: Main.hs build-depends: - base == 4.6.*, - directory == 1.2.*, - filepath == 1.3.*, + base >= 4.6 && < 4.8, + directory >= 1.2, + filepath >= 1.3, haskell-formatter, - optparse-applicative == 0.10.* + optparse-applicative >= 0.10 hs-source-dirs: src/executable @@ -100,16 +100,16 @@ Language.Haskell.Formatter.Toolkit.TestTool build-depends: - base == 4.6.*, - containers == 0.5.*, - directory-tree == 0.12.*, - doctest == 0.9.*, - filemanip == 0.3.*, - filepath == 1.3.*, + base >= 4.6 && < 4.8, + containers >= 0.5, + directory-tree >= 0.11, + doctest >= 0.9, + filemanip >= 0.3, + filepath >= 1.3, haskell-formatter, - hlint == 1.9.*, - tasty == 0.9.*, - tasty-hunit == 0.9.* + hlint >= 1.9, + tasty >= 0.9, + tasty-hunit >= 0.8 hs-source-dirs: testsuite/src diff --git a/src/library/Language/Haskell/Formatter.hs b/src/library/Language/Haskell/Formatter.hs --- a/src/library/Language/Haskell/Formatter.hs +++ b/src/library/Language/Haskell/Formatter.hs @@ -2,13 +2,12 @@ Description : Haskell source code formatter -} module Language.Haskell.Formatter - (Configuration.Configuration(..), Configuration.defaultConfiguration, - Error.Error, Error.isAssertionError, Main.defaultFormat, Main.format, - StreamName.createStreamName, StreamName.standardInput, - StreamName.StreamName, Style.Indentation, Style.Style(..)) + (module Configuration, Error.Error, Error.isAssertionError, + Main.defaultFormat, Main.format, StreamName.createStreamName, + StreamName.standardInput, StreamName.StreamName, module Style) where -import qualified Language.Haskell.Formatter.Configuration as Configuration +import Language.Haskell.Formatter.Configuration as Configuration hiding (check) import qualified Language.Haskell.Formatter.Error as Error import qualified Language.Haskell.Formatter.Main as Main -import qualified Language.Haskell.Formatter.Style as Style +import Language.Haskell.Formatter.Style as Style hiding (check) import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName diff --git a/src/library/Language/Haskell/Formatter/CommentCore.hs b/src/library/Language/Haskell/Formatter/CommentCore.hs --- a/src/library/Language/Haskell/Formatter/CommentCore.hs +++ b/src/library/Language/Haskell/Formatter/CommentCore.hs @@ -8,6 +8,7 @@ import qualified Data.Char as Char import qualified Data.Monoid as Monoid import qualified Language.Haskell.Formatter.Internal.Newline as Newline +import qualified Language.Haskell.Formatter.Toolkit.ListTool as ListTool data CommentCore = CommentCore{kind :: Kind, content :: String} deriving (Eq, Ord) @@ -41,6 +42,5 @@ ('^' : _) -> AfterActualCode _ -> None where unwrappedContent - = Monoid.mappend (dropWhile Char.isSpace deformable) rigid - (deformable, rigid) = splitAt spaceLimit $ content comment + = ListTool.dropWhileAtMost Char.isSpace spaceLimit $ content comment spaceLimit = 1 diff --git a/src/library/Language/Haskell/Formatter/Configuration.hs b/src/library/Language/Haskell/Formatter/Configuration.hs --- a/src/library/Language/Haskell/Formatter/Configuration.hs +++ b/src/library/Language/Haskell/Formatter/Configuration.hs @@ -2,7 +2,9 @@ Description : Overall configuration -} module Language.Haskell.Formatter.Configuration - (Configuration(..), defaultConfiguration, check) where + (Configuration, configurationStyle, configurationStreamName, + defaultConfiguration, check) + where import qualified Language.Haskell.Formatter.Result as Result import qualified Language.Haskell.Formatter.Source as Source import qualified Language.Haskell.Formatter.Style as Style diff --git a/src/library/Language/Haskell/Formatter/ExactCode.hs b/src/library/Language/Haskell/Formatter/ExactCode.hs --- a/src/library/Language/Haskell/Formatter/ExactCode.hs +++ b/src/library/Language/Haskell/Formatter/ExactCode.hs @@ -14,6 +14,9 @@ where rawActualCode = actualCode exact rawComments = comments exact +instance Location.Portioned ExactCode where + getPortion = Location.getPortion . actualCode + create :: Source.Module Location.SrcSpanInfo -> [Source.Comment] -> ExactCode create rawActualCode rawComments = ExactCode{actualCode = rawActualCode, comments = rawComments} diff --git a/src/library/Language/Haskell/Formatter/Internal/StyleFileFormat.hs b/src/library/Language/Haskell/Formatter/Internal/StyleFileFormat.hs --- a/src/library/Language/Haskell/Formatter/Internal/StyleFileFormat.hs +++ b/src/library/Language/Haskell/Formatter/Internal/StyleFileFormat.hs @@ -16,6 +16,9 @@ ("ribbons_per_line", MapTree.Leaf . TreeFormat.SingleFloating $ \ value style -> style{Formatter.ribbonsPerLine = value}), + ("successive_empty_lines_limit", + MapTree.Leaf . TreeFormat.LimitedInteger $ + \ value style -> style{Formatter.successiveEmptyLinesLimit = value}), ("indentations", MapTree.Node $ Map.fromList diff --git a/src/library/Language/Haskell/Formatter/Location.hs b/src/library/Language/Haskell/Formatter/Location.hs --- a/src/library/Language/Haskell/Formatter/Location.hs +++ b/src/library/Language/Haskell/Formatter/Location.hs @@ -19,15 +19,15 @@ import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName import Prelude hiding (getLine) -class (Enum a) => Natural a where +class Enum a => Natural a where base :: a - plus :: (Integral b) => b -> a -> a + plus :: Integral b => b -> a -> a plus difference natural = toEnum $ fromIntegral difference + fromEnum natural - minus :: (Num b) => a -> a -> b + minus :: Num b => a -> a -> b minus minuend = fromIntegral . Function.on (-) fromEnum minuend class Portioned a where @@ -57,13 +57,13 @@ instance Portioned SrcLoc.SrcSpanInfo where getPortion = SrcLoc.srcInfoSpan -instance (Portioned a) => Portioned (Syntax.Module a) where +instance Portioned a => Portioned (Syntax.Module a) where getPortion = getPortion . Syntax.ann instance Portioned Comments.Comment where getPortion (Comments.Comment _ commentPortion _) = commentPortion -streamName :: (SrcLoc.SrcInfo a) => a -> StreamName.StreamName +streamName :: SrcLoc.SrcInfo a => a -> StreamName.StreamName streamName = StreamName.createStreamName . SrcLoc.fileName getLine :: SrcLoc.SrcLoc -> Line @@ -116,10 +116,10 @@ hasSingleLine = lineCount == 1 startColumn = getStartColumn startPosition -getStartLine :: (SrcLoc.SrcInfo a) => a -> Line +getStartLine :: SrcLoc.SrcInfo a => a -> Line getStartLine = getLine . SrcLoc.getPointLoc -getStartColumn :: (SrcLoc.SrcInfo a) => a -> Column +getStartColumn :: SrcLoc.SrcInfo a => a -> Column getStartColumn = getColumn . SrcLoc.getPointLoc getEndLine :: SrcLoc.SrcSpan -> Line diff --git a/src/library/Language/Haskell/Formatter/Process/AttachComments.hs b/src/library/Language/Haskell/Formatter/Process/AttachComments.hs --- a/src/library/Language/Haskell/Formatter/Process/AttachComments.hs +++ b/src/library/Language/Haskell/Formatter/Process/AttachComments.hs @@ -14,6 +14,7 @@ import qualified Language.Haskell.Formatter.ExactCode as ExactCode import qualified Language.Haskell.Formatter.Location as Location import qualified Language.Haskell.Formatter.Process.Code as Code +import qualified Language.Haskell.Formatter.Process.LineTool as LineTool import qualified Language.Haskell.Formatter.Process.Note as Note import qualified Language.Haskell.Formatter.Result as Result import qualified Language.Haskell.Formatter.Source as Source @@ -22,6 +23,11 @@ data Assignment = Assignment (Map.Map Location.SrcSpan Note.CommentNote) deriving (Eq, Ord, Show) +data CodeGap = InfiniteLower Location.SrcSpan + | FiniteGap Location.SrcSpan Location.SrcSpan + | InfiniteUpper Location.SrcSpan + deriving (Eq, Ord, Show) + instance Monoid.Monoid Assignment where mempty = Assignment Map.empty mappend (Assignment left) (Assignment right) = Assignment merged @@ -31,47 +37,60 @@ Style.Style -> ExactCode.ExactCode -> Result.Result Code.CommentableCode attachComments _ exact - = if Map.null unassigned then return commentable else - Result.fatalAssertionError message - where (Assignment unassigned, commentable) = spread assignment locatable - assignment = assignForCode exact - locatable = ExactCode.actualCode exact + = do assignment <- assignForCode exact + let (Assignment unassigned, commentable) = spread assignment locatable + if Map.null unassigned then return commentable else + Result.fatalAssertionError message + where locatable = ExactCode.actualCode exact message = "Attaching the comments failed with an unassigned rest." -spread :: Assignment -> Code.LocatableCode -> (Assignment, Code.CommentableCode) -spread (Assignment assignment) locatable = (Assignment unassigned, commentable) - where (unassigned, commentable) - = Traversable.mapAccumL move assignment locatable - move rest nestedPortion = (rest', note) - where (maybeNote, rest') = Map.updateLookupWithKey remove portion rest - remove = const . const Nothing - portion = Location.getPortion nestedPortion - note = Foldable.fold maybeNote - -assignForCode :: ExactCode.ExactCode -> Assignment +assignForCode :: ExactCode.ExactCode -> Result.Result Assignment assignForCode exact - = Monoid.mappend (Monoid.mconcat untilLast) assignedAfterLast - where ((maybeLast, afterLast), untilLast) - = Traversable.mapAccumL move base orderedPortions - move (maybeLower, rest) upper = ((Just upper, rest'), assignment) - where (comments, rest') = span ((<= upper) . Location.getPortion) rest - assignment = assignComments maybeLower upper boxes - boxes = createComments comments + = case unassigned of + [] -> return $ Monoid.mconcat assignments + (_ : _) -> Result.fatalAssertionError message + where ((_, unassigned), assignments) + = Traversable.mapAccumL move base maybeOrderedPortions + move (maybeLower, rest) maybeUpper = ((maybeUpper, rest'), assignment) + where (rest', assignment) + = case maybeUpper of + Nothing -> case maybeLower of + Nothing -> (rest, Monoid.mempty) + Just lower -> ([], + assign + (InfiniteUpper lower) + rest) + Just upper -> (greaterUpper, assign gap lessEqualUpper) + where (lessEqualUpper, greaterUpper) + = span ((<= upper) . Location.getPortion) rest + gap + = case maybeLower of + Nothing -> InfiniteLower upper + Just lower -> FiniteGap lower upper + assign gap = assignComments gap . createComments startLine endLine + where (startLine, endLine) + = case gap of + InfiniteLower upper -> (pred Location.base, + Location.getStartLine upper) + FiniteGap lower upper -> (Location.getEndLine lower, + Location.getStartLine upper) + InfiniteUpper lower -> (Location.getEndLine lower, + codeEndLine) + codeEndLine = Location.getEndLine $ Location.getPortion exact base = (Nothing, orderedComments) (orderedPortions, orderedComments) = orderByStartEnd exact - assignedAfterLast = Foldable.foldMap assignLast maybeLast - assignLast = flip assignAfter lastBoxes - lastBoxes = createComments afterLast + maybeOrderedPortions + = Monoid.mappend (fmap Just orderedPortions) [Nothing] + message = "Assigning the comments failed with an unexpected rest." -assignComments :: - Maybe Location.SrcSpan -> - Location.SrcSpan -> [Note.CommentBox] -> Assignment -assignComments Nothing upper comments = assignBefore upper comments -assignComments (Just lower) upper comments +assignComments :: CodeGap -> [Note.CommentBox] -> Assignment +assignComments (InfiniteLower upper) comments = assignBefore upper comments +assignComments (FiniteGap lower upper) comments = Monoid.mappend assignedAfter assignedBefore where assignedAfter = assignAfter lower after - (after, _, before) = divideComments comments - assignedBefore = assignBefore upper before + (after, spaces, before) = divideComments comments + assignedBefore = assignBefore upper $ Monoid.mappend spaces before +assignComments (InfiniteUpper lower) comments = assignAfter lower comments assignBefore :: Location.SrcSpan -> [Note.CommentBox] -> Assignment assignBefore portion = flip (assignSingleton portion) [] @@ -104,24 +123,28 @@ divide after spaces (Note.EmptyLine : unwrapped) = divide after (Monoid.mappend spaces [Note.EmptyLine]) unwrapped -createComments :: [Source.Comment] -> [Note.CommentBox] -createComments = concat . snd . Traversable.mapAccumL create Nothing - where create maybeEndLine comment = (Just endLine', comments) +createComments :: + Location.Line -> + Location.Line -> [Source.Comment] -> [Note.CommentBox] +createComments gapStartLine gapEndLine comments + = Monoid.mappend (concat untilLast) lastBoxes + where (lastEndLine, untilLast) + = Traversable.mapAccumL create gapStartLine comments + create endLine comment = (endLine', boxes) where endLine' = Location.getEndLine portion portion = Location.getPortion comment - comments = Monoid.mappend emptyLines actualComments - emptyLines - = case maybeEndLine of - Nothing -> [] - Just endLine -> replicate emptyLineCount Note.EmptyLine - where emptyLineCount = pred lineDistance - lineDistance - = Location.minus startLine endLine :: Int + boxes = Monoid.mappend emptyLines actualComments + emptyLines = createEmptyLines endLine startLine startLine = Location.getStartLine portion actualComments = [Note.ActualComment indentedComment] indentedComment = Note.createIndentedComment core Location.base core = Source.commentCore comment + lastBoxes = createEmptyLines lastEndLine gapEndLine +createEmptyLines :: Location.Line -> Location.Line -> [Note.CommentBox] +createEmptyLines endLine startLine = replicate emptyLineCount Note.EmptyLine + where emptyLineCount = LineTool.countEmptyLines endLine startLine + orderByStartEnd :: ExactCode.ExactCode -> ([Location.SrcSpan], [Source.Comment]) orderByStartEnd exact = (orderedPortions, orderedComments) where orderedPortions = fmap Location.getPortion nestedPortions @@ -130,3 +153,13 @@ orderedComments = List.sortBy (Function.on compare Location.getPortion) comments comments = ExactCode.comments exact + +spread :: Assignment -> Code.LocatableCode -> (Assignment, Code.CommentableCode) +spread (Assignment assignment) locatable = (Assignment unassigned, commentable) + where (unassigned, commentable) + = Traversable.mapAccumL move assignment locatable + move rest nestedPortion = (rest', note) + where (maybeNote, rest') = Map.updateLookupWithKey remove portion rest + remove = const . const Nothing + portion = Location.getPortion nestedPortion + note = Foldable.fold maybeNote diff --git a/src/library/Language/Haskell/Formatter/Process/Code.hs b/src/library/Language/Haskell/Formatter/Process/Code.hs --- a/src/library/Language/Haskell/Formatter/Process/Code.hs +++ b/src/library/Language/Haskell/Formatter/Process/Code.hs @@ -2,7 +2,7 @@ Description : Syntax tree types -} module Language.Haskell.Formatter.Process.Code - (LocatableCode, CommentableCode, LocatableCommentableCode, + (LocatableCode, CommentableCode, LocatableCommentableCode, tryZipCode, tryZipLocationsComments, dropComments, dropLocations) where import qualified Language.Haskell.Formatter.Location as Location @@ -17,21 +17,25 @@ type LocatableCommentableCode = Source.Module Note.LocationCommentNote -tryZipLocationsComments :: - LocatableCode -> - CommentableCode -> - Result.Result LocatableCommentableCode -tryZipLocationsComments locatable commentable +tryZipCode :: + (a -> b -> c) -> + Source.Module a -> + Source.Module b -> Result.Result (Source.Module c) +tryZipCode merge left right = case maybeZipped of Nothing -> Result.fatalAssertionError message where message = "The code notes could not be zipped." Just zipped -> return zipped where maybeZipped - = if isActualCodeSame then maybeLocatableCommentable else Nothing - isActualCodeSame = locatable Source.=~= commentable - maybeLocatableCommentable - = Visit.halfZipWith Note.createLocationCommentNote locatable - commentable + = if isActualCodeSame then Visit.halfZipWith merge left right else + Nothing + isActualCodeSame = left Source.=~= right + +tryZipLocationsComments :: + LocatableCode -> + CommentableCode -> + Result.Result LocatableCommentableCode +tryZipLocationsComments = tryZipCode Note.createLocationCommentNote dropComments :: LocatableCommentableCode -> LocatableCode dropComments = fmap Note.locationNote diff --git a/src/library/Language/Haskell/Formatter/Process/CodeOrdering.hs b/src/library/Language/Haskell/Formatter/Process/CodeOrdering.hs --- a/src/library/Language/Haskell/Formatter/Process/CodeOrdering.hs +++ b/src/library/Language/Haskell/Formatter/Process/CodeOrdering.hs @@ -15,10 +15,11 @@ Code.LocatableCommentableCode orderImportDeclarations = replaceImportDeclarations $ Visit.orderByKey key where key - (Syntax.ImportDecl _ moduleName isQualified isWithSource package alias - entitiesList) - = (moduleNameKey moduleName, isQualified, isWithSource, package, - fmap moduleNameKey alias, fmap entitiesListKey entitiesList) + (Syntax.ImportDecl _ moduleName isQualified isWithSource isSafe + package alias entitiesList) + = (moduleNameKey moduleName, isQualified, isWithSource, isSafe, + package, fmap moduleNameKey alias, + fmap entitiesListKey entitiesList) moduleNameKey (Syntax.ModuleName _ name) = name entitiesListKey (Syntax.ImportSpecList _ isHiding entities) = (isHiding, fmap importEntityKey entities) @@ -36,7 +37,7 @@ where importDeclarations' = function importDeclarations importEntityKey :: Syntax.ImportSpec a -> [String] -importEntityKey (Syntax.IVar _ name) = rootNameKey name +importEntityKey (Syntax.IVar _ _ name) = rootNameKey name importEntityKey (Syntax.IAbs _ name) = rootNameKey name importEntityKey (Syntax.IThingAll _ name) = rootNameKey name importEntityKey (Syntax.IThingWith _ name entities) diff --git a/src/library/Language/Haskell/Formatter/Process/DetachComments.hs b/src/library/Language/Haskell/Formatter/Process/DetachComments.hs --- a/src/library/Language/Haskell/Formatter/Process/DetachComments.hs +++ b/src/library/Language/Haskell/Formatter/Process/DetachComments.hs @@ -13,7 +13,7 @@ import qualified Language.Haskell.Formatter.ExactCode as ExactCode import qualified Language.Haskell.Formatter.Location as Location import qualified Language.Haskell.Formatter.Process.Code as Code -import qualified Language.Haskell.Formatter.Process.LineShifting as LineShifting +import qualified Language.Haskell.Formatter.Process.LineTool as LineTool import qualified Language.Haskell.Formatter.Process.Note as Note import qualified Language.Haskell.Formatter.Result as Result import qualified Language.Haskell.Formatter.Source as Source @@ -45,21 +45,21 @@ Result.Result ExactCode.ExactCode detachComments _ locatableCommentable = return $ ExactCode.create locatable' comments - where locatable' = LineShifting.shiftCode shifter locatable + where locatable' = LineTool.shiftCode shifter locatable shifter = reservationShifter reservation reservation = reserveForCode locatableCommentable locatable = Code.dropComments locatableCommentable comments = createComments stream reservation stream = Location.streamName $ Location.getPortion locatable' -reservationShifter :: Reservation -> LineShifting.Shifter +reservationShifter :: Reservation -> LineTool.Shifter reservationShifter (Reservation reservation) - = LineShifting.createShifter $ fmap commentsShift reservation + = LineTool.createShifter $ fmap commentsShift reservation -commentsShift :: [Note.CommentBox] -> LineShifting.Shift +commentsShift :: [Note.CommentBox] -> LineTool.Shift commentsShift = sum . fmap commentShift -commentShift :: Note.CommentBox -> LineShifting.Shift +commentShift :: Note.CommentBox -> LineTool.Shift commentShift (Note.ActualComment comment) = CommentCore.wrappedLineCount $ Note.commentCore comment commentShift Note.EmptyLine = 1 @@ -92,7 +92,7 @@ Note.EmptyLine -> [] accumulateReservation :: - (Monoid.Monoid m) => + Monoid.Monoid m => (Location.Line -> [Note.CommentBox] -> m) -> Reservation -> m accumulateReservation create (Reservation reservation) = accumulation diff --git a/src/library/Language/Haskell/Formatter/Process/FormatActualCode.hs b/src/library/Language/Haskell/Formatter/Process/FormatActualCode.hs --- a/src/library/Language/Haskell/Formatter/Process/FormatActualCode.hs +++ b/src/library/Language/Haskell/Formatter/Process/FormatActualCode.hs @@ -21,25 +21,6 @@ where locatableCommentable' = prepare style locatableCommentable commentable = Code.dropLocations locatableCommentable' -prepare :: - Style.Style -> - Code.LocatableCommentableCode -> Code.LocatableCommentableCode -prepare style = Visit.compose preparations - where preparations - = [preparation | (isApplied, preparation) <- applications, - isApplied style] - applications - = [(Style.orderImportDeclarations, - CodeOrdering.orderImportDeclarations), - (Style.orderImportEntities, orderImportEntities)] - -orderImportEntities :: - Code.LocatableCommentableCode -> - Code.LocatableCommentableCode -orderImportEntities - = CodeOrdering.orderRootImportEntities . - CodeOrdering.orderNestedImportEntities - prettyPrint :: Style.Style -> Code.LocatableCommentableCode -> Result.Result Code.LocatableCode @@ -59,7 +40,7 @@ where message = "Formatting the actual code failed to zip." Just locatable' -> return locatable' -defaultPrettyPrint :: (Source.Pretty a) => Style.Style -> a -> String +defaultPrettyPrint :: Source.Pretty a => Style.Style -> a -> String defaultPrettyPrint = Applicative.liftA2 Source.prettyPrintStyleMode renderingStyle mode @@ -76,3 +57,22 @@ Source.letIndent = Style.letIndentation style, Source.whereIndent = Style.whereIndentation style, Source.onsideIndent = Style.onsideIndentation style} + +prepare :: + Style.Style -> + Code.LocatableCommentableCode -> Code.LocatableCommentableCode +prepare style = Visit.compose preparations + where preparations + = [preparation | (isApplied, preparation) <- applications, + isApplied style] + applications + = [(Style.orderImportDeclarations, + CodeOrdering.orderImportDeclarations), + (Style.orderImportEntities, orderImportEntities)] + +orderImportEntities :: + Code.LocatableCommentableCode -> + Code.LocatableCommentableCode +orderImportEntities + = CodeOrdering.orderRootImportEntities . + CodeOrdering.orderNestedImportEntities diff --git a/src/library/Language/Haskell/Formatter/Process/FormatComments.hs b/src/library/Language/Haskell/Formatter/Process/FormatComments.hs --- a/src/library/Language/Haskell/Formatter/Process/FormatComments.hs +++ b/src/library/Language/Haskell/Formatter/Process/FormatComments.hs @@ -3,7 +3,11 @@ -} module Language.Haskell.Formatter.Process.FormatComments (formatComments) where import qualified Data.Function as Function +import qualified Data.Monoid as Monoid +import qualified Language.Haskell.Formatter.ExactCode as ExactCode import qualified Language.Haskell.Formatter.Location as Location +import qualified Language.Haskell.Formatter.Process.AttachComments + as AttachComments import qualified Language.Haskell.Formatter.Process.Code as Code import qualified Language.Haskell.Formatter.Process.Note as Note import qualified Language.Haskell.Formatter.Result as Result @@ -15,8 +19,64 @@ Style.Style -> Code.LocatableCommentableCode -> Result.Result Code.LocatableCommentableCode -formatComments _ = return . indentToLineStart . mergeConsecutiveEmptyLines +formatComments style locatableCommentable + = do locatableCommentable' <- mergeImpliedComments style locatableCommentable + return . indentToLineStart $ + mergeSuccessiveEmptyLines style locatableCommentable' +mergeImpliedComments :: + Style.Style -> + Code.LocatableCommentableCode -> + Result.Result Code.LocatableCommentableCode +mergeImpliedComments style locatableCommentable + = do impliedCommentable <- commentsImpliedByLocations style locatable + commentable' <- commentsDifference style commentable impliedCommentable + Code.tryZipLocationsComments locatable commentable' + where locatable = Code.dropComments locatableCommentable + commentable = Code.dropLocations locatableCommentable + +commentsImpliedByLocations :: + Style.Style -> + Code.LocatableCode -> + Result.Result Code.CommentableCode +commentsImpliedByLocations style locatable + = AttachComments.attachComments style exact + where exact = ExactCode.create locatable comments + comments = [] + +commentsDifference :: + Style.Style -> + Code.CommentableCode -> + Code.CommentableCode -> + Result.Result Code.CommentableCode +commentsDifference style = Code.tryZipCode minus + where minus mixed implied + = Note.createCommentNote commentsBefore commentsAfter + where commentsBefore = difference Note.commentsBefore + difference getComments + = Function.on (boxesDifference style) getComments mixed + implied + commentsAfter + = reverse . difference $ reverse . Note.commentsAfter + +boxesDifference :: + Style.Style -> + [Note.CommentBox] -> [Note.CommentBox] -> [Note.CommentBox] +boxesDifference style mixed implied = Monoid.mappend difference mixedRest + where difference = replicate differenceCount Note.EmptyLine + differenceCount + = if mixedCount <= impliedCount then 0 else + clip mixedCount - impliedCount + mixedCount = length mixedEmptyLines + (mixedEmptyLines, mixedRest) = span isEmptyLine mixed + impliedCount = length implied + clip = min successiveEmptyLinesLimit + successiveEmptyLinesLimit = Style.successiveEmptyLinesLimit style + +isEmptyLine :: Note.CommentBox -> Bool +isEmptyLine (Note.ActualComment _) = False +isEmptyLine Note.EmptyLine = True + indentToLineStart :: Code.LocatableCommentableCode -> Code.LocatableCommentableCode indentToLineStart locatableCommentable = locatableCommentable' @@ -33,11 +93,13 @@ indent = const $ Location.getStartColumn lineStart' startPosition = Location.getPointLoc . Location.getPortion -mergeConsecutiveEmptyLines :: - Code.LocatableCommentableCode -> - Code.LocatableCommentableCode -mergeConsecutiveEmptyLines +mergeSuccessiveEmptyLines :: + Style.Style -> + Code.LocatableCommentableCode -> + Code.LocatableCommentableCode +mergeSuccessiveEmptyLines style = fmap . Note.replaceCommentNote $ Note.replaceCommentBoxes merge - where merge = ListTool.mergeConsecutiveElements isMerged - isMerged (Note.ActualComment _) = False - isMerged Note.EmptyLine = True + where merge + = ListTool.mergeLongerSuccessions isEmptyLine + successiveEmptyLinesLimit + successiveEmptyLinesLimit = Style.successiveEmptyLinesLimit style diff --git a/src/library/Language/Haskell/Formatter/Process/LineShifting.hs b/src/library/Language/Haskell/Formatter/Process/LineShifting.hs deleted file mode 100644 --- a/src/library/Language/Haskell/Formatter/Process/LineShifting.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-| -Description : Shifting lines of code --} -module Language.Haskell.Formatter.Process.LineShifting - (Shifter, Shift, createShifter, shiftCode) where -import qualified Data.Map.Strict as Map -import qualified Language.Haskell.Formatter.Location as Location -import qualified Language.Haskell.Formatter.Process.Code as Code - -data Shifter = Shifter (Map.Map Location.Line Shift) - deriving (Eq, Ord, Show) - -type Shift = Int - -createShifter :: Map.Map Location.Line Shift -> Shifter -createShifter relativeShifter = Shifter absoluteShifter - where (_, absoluteShifter) = Map.mapAccum accumulate noShift relativeShifter - accumulate absoluteShift relativeShift - = (absoluteShift', absoluteShift') - where absoluteShift' = absoluteShift + relativeShift - -noShift :: Shift -noShift = 0 - -shiftCode :: Shifter -> Code.LocatableCode -> Code.LocatableCode -shiftCode shifter = fmap $ shiftNestedPortion shifter - where shiftNestedPortion = Location.replaceNestedPortionLines . shiftLine - -shiftLine :: Shifter -> Location.Line -> Location.Line -shiftLine shifter line = Location.plus shift line - where shift = lookupShift line shifter - -lookupShift :: Location.Line -> Shifter -> Shift -lookupShift line (Shifter shifter) - = case Map.lookupLE line shifter of - Nothing -> noShift - Just (_, shift) -> shift diff --git a/src/library/Language/Haskell/Formatter/Process/LineTool.hs b/src/library/Language/Haskell/Formatter/Process/LineTool.hs new file mode 100644 --- /dev/null +++ b/src/library/Language/Haskell/Formatter/Process/LineTool.hs @@ -0,0 +1,41 @@ +{-| +Description : Working with lines of code +-} +module Language.Haskell.Formatter.Process.LineTool + (Shifter, Shift, countEmptyLines, createShifter, shiftCode) where +import qualified Data.Map.Strict as Map +import qualified Language.Haskell.Formatter.Location as Location +import qualified Language.Haskell.Formatter.Process.Code as Code + +data Shifter = Shifter (Map.Map Location.Line Shift) + deriving (Eq, Ord, Show) + +type Shift = Int + +countEmptyLines :: Location.Line -> Location.Line -> Int +countEmptyLines endLine startLine = pred lineDifference + where lineDifference = Location.minus startLine endLine + +createShifter :: Map.Map Location.Line Shift -> Shifter +createShifter relativeShifter = Shifter absoluteShifter + where (_, absoluteShifter) = Map.mapAccum accumulate noShift relativeShifter + accumulate absoluteShift relativeShift + = (absoluteShift', absoluteShift') + where absoluteShift' = absoluteShift + relativeShift + +noShift :: Shift +noShift = 0 + +shiftCode :: Shifter -> Code.LocatableCode -> Code.LocatableCode +shiftCode shifter = fmap $ shiftNestedPortion shifter + where shiftNestedPortion = Location.replaceNestedPortionLines . shiftLine + +shiftLine :: Shifter -> Location.Line -> Location.Line +shiftLine shifter line = Location.plus shift line + where shift = lookupShift line shifter + +lookupShift :: Location.Line -> Shifter -> Shift +lookupShift line (Shifter shifter) + = case Map.lookupLE line shifter of + Nothing -> noShift + Just (_, shift) -> shift diff --git a/src/library/Language/Haskell/Formatter/Style.hs b/src/library/Language/Haskell/Formatter/Style.hs --- a/src/library/Language/Haskell/Formatter/Style.hs +++ b/src/library/Language/Haskell/Formatter/Style.hs @@ -2,7 +2,11 @@ Description : Parametrization of formatting -} module Language.Haskell.Formatter.Style - (Style(..), Indentation, defaultStyle, check) where + (Style, lineLengthLimit, ribbonsPerLine, successiveEmptyLinesLimit, + classIndentation, doIndentation, caseIndentation, letIndentation, + whereIndentation, onsideIndentation, orderImportDeclarations, + orderImportEntities, Indentation, defaultStyle, check) + where import qualified Data.Maybe as Maybe import qualified Language.Haskell.Formatter.Error as Error import qualified Language.Haskell.Formatter.Internal.Newline as Newline @@ -10,6 +14,7 @@ import qualified Language.Haskell.Formatter.Source as Source data Style = Style{lineLengthLimit :: Int, ribbonsPerLine :: Float, + successiveEmptyLinesLimit :: Int, classIndentation :: Indentation, doIndentation :: Indentation, caseIndentation :: Indentation, letIndentation :: Indentation, @@ -27,6 +32,7 @@ defaultStyle :: Style defaultStyle = Style{lineLengthLimit = 80, ribbonsPerLine = 1, + successiveEmptyLinesLimit = 1, classIndentation = Source.classIndent mode, doIndentation = Source.doIndent mode, caseIndentation = Source.caseIndent mode, @@ -51,8 +57,9 @@ createChecks :: Style -> [Check] createChecks style = concat - [[lineLengthLimitCheck, ribbonsPerLineCheck], indentationChecks, - [onsideLessCheck]] + [[lineLengthLimitCheck, ribbonsPerLineCheck, + successiveEmptyLinesLimitCheck], + indentationChecks, [onsideLessCheck]] where lineLengthLimitCheck = createCheck (rawLineLengthLimit > 0) ["The line length limit must be positive, but it is ", @@ -63,6 +70,12 @@ ["The ribbons per line ratio must be at least 1, but it is ", show rawRibbonsPerLine, "."] rawRibbonsPerLine = ribbonsPerLine style + successiveEmptyLinesLimitCheck + = createCheck (rawSuccessiveEmptyLinesLimit >= 0) + ["The successive empty lines limit must not be negative, ", + "but it is ", show rawSuccessiveEmptyLinesLimit, "."] + rawSuccessiveEmptyLinesLimit = successiveEmptyLinesLimit style + indentationChecks = fmap checkIndentation indentations checkIndentation (indentation, name) = createCheck (indentation > 0) diff --git a/src/library/Language/Haskell/Formatter/Toolkit/ListTool.hs b/src/library/Language/Haskell/Formatter/Toolkit/ListTool.hs --- a/src/library/Language/Haskell/Formatter/Toolkit/ListTool.hs +++ b/src/library/Language/Haskell/Formatter/Toolkit/ListTool.hs @@ -2,13 +2,12 @@ Description : List utilities -} module Language.Haskell.Formatter.Toolkit.ListTool - (maybeLast, mergeConsecutiveElements, takeEvery, concatenateRuns, - concatenateShiftedRuns) + (maybeLast, dropWhileAtMost, mergeLongerSuccessions, takeEvery, + concatenateRuns, concatenateShiftedRuns) where import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Monoid as Monoid -import qualified Data.Word as Word {-| The last element, or 'Nothing' if there is none. @@ -17,39 +16,47 @@ maybeLast :: [a] -> Maybe a maybeLast = Maybe.listToMaybe . reverse -{-| @mergeConsecutiveElements i l@ keeps only the first element of consecutive - elements of @l@ satisfying the predicate @i@. +{-| @dropWhileAtMost p l@ is like @dropWhile p@, but drops at most @l@ elements. - >>> mergeConsecutiveElements Data.Char.isSpace " ab c d\LF e " - " ab c d\ne " --} -mergeConsecutiveElements :: (a -> Bool) -> [a] -> [a] -mergeConsecutiveElements isMerged = snd . List.foldl' merge (False, []) - where merge (isConsecutive, list) element = (isConsecutive', list') - where isConsecutive' = isMerged element - list' = Monoid.mappend list merged - merged - = if isConsecutive' && isConsecutive then [] else [element] + >>> dropWhileAtMost (== ' ') 2 " a bc " + " a bc " -} +dropWhileAtMost :: (a -> Bool) -> Int -> [a] -> [a] +dropWhileAtMost predicate limit list + = Monoid.mappend (dropWhile predicate deformable) rigid + where (deformable, rigid) = splitAt limit list +{-| @mergeLongerSuccessions p c l@ keeps only the first @c@ elements of + successive elements of @l@ satisfying the predicate @p@. + + >>> mergeLongerSuccessions Data.Char.isSpace 2 " ab c d\LF e " + " ab c d\n e " -} +mergeLongerSuccessions :: (a -> Bool) -> Int -> [a] -> [a] +mergeLongerSuccessions predicate count = snd . List.foldl' merge (0, []) + where merge (successionLength, list) element + = if predicate element then + if successionLength < count then (succ successionLength, extended) + else (count, list) + else (0, extended) + where extended = Monoid.mappend list [element] + {-| @takeEvery p l@ takes every @p@th element of @l@ from the first one. >>> takeEvery 2 "apple" "ape" prop> takeEvery 1 l == l -} -takeEvery :: Word.Word -> [a] -> [a] +takeEvery :: Int -> [a] -> [a] takeEvery _ [] = [] -takeEvery period list@(first : _) - = first : takeEvery period (drop (fromIntegral period) list) +takeEvery period list@(first : _) = first : takeEvery period (drop period list) {-| @concatenateRuns p l@ repeatedly concatenates @p@ lists of @l@. >>> concatenateRuns 2 ["a", "b", "c", "d", "e"] ["ab","cd","e"] -} -concatenateRuns :: Word.Word -> [[a]] -> [[a]] +concatenateRuns :: Int -> [[a]] -> [[a]] concatenateRuns _ [] = [] concatenateRuns period lists = concat run : concatenateRuns period rest - where (run, rest) = splitAt (fromIntegral period) lists + where (run, rest) = splitAt period lists {-| @concatenateShiftedRuns p s l@ first takes @s@ lists of @l@, followed by repeatedly concatenating @p@ lists. @@ -57,11 +64,11 @@ >>> concatenateShiftedRuns 2 1 ["a", "b", "c", "d", "e"] ["a","bc","de"] - prop> p == 0 || concatenateShiftedRuns p 0 l == concatenateRuns p l -} -concatenateShiftedRuns :: Word.Word -> Word.Word -> [[a]] -> [[a]] + prop> p <= 0 || concatenateShiftedRuns p 0 l == concatenateRuns p l -} +concatenateShiftedRuns :: Int -> Int -> [[a]] -> [[a]] concatenateShiftedRuns period shift lists = case shift of 0 -> concatenateUnshifted lists _ -> concat shifted : concatenateUnshifted unshifted - where (shifted, unshifted) = splitAt (fromIntegral shift) lists + where (shifted, unshifted) = splitAt shift lists where concatenateUnshifted = concatenateRuns period diff --git a/src/library/Language/Haskell/Formatter/Toolkit/Splitter.hs b/src/library/Language/Haskell/Formatter/Toolkit/Splitter.hs --- a/src/library/Language/Haskell/Formatter/Toolkit/Splitter.hs +++ b/src/library/Language/Haskell/Formatter/Toolkit/Splitter.hs @@ -27,14 +27,14 @@ ["0","1"] >>> separate ["pine", "pineapple"] "0pineapple1" ["0","apple1"] -} -separate :: (Eq a) => [[a]] -> [a] -> [[a]] +separate :: Eq a => [[a]] -> [a] -> [[a]] separate = split . createSplitter Drop where createSplitter rawDelimiterPolicy rawDelimiterQueue = Splitter{delimiterPolicy = rawDelimiterPolicy, delimiterQueue = rawDelimiterQueue} {-| @split s l@ splits @l@ according to the strategy @s@. -} -split :: (Eq a) => Splitter a -> [a] -> [[a]] +split :: Eq a => Splitter a -> [a] -> [[a]] split splitter list = case delimiterPolicy splitter of Drop -> ListTool.takeEvery period parts @@ -48,7 +48,7 @@ {-| @rawSplit s l@ splits @l@ on the sublists @s@, keeping the separators. prop> odd . length $ separate ["apple", "pine"] l -} -rawSplit :: (Eq a) => [[a]] -> [a] -> [[a]] +rawSplit :: Eq a => [[a]] -> [a] -> [[a]] rawSplit delimiters = move [] [] where move parts left [] = Monoid.mappend parts [left] move parts left right@(first : rest) @@ -67,6 +67,6 @@ Just ("\r\n","pine") >>> stripFirstPrefix ["apple"] "pineapple" Nothing -} -stripFirstPrefix :: (Eq a) => [[a]] -> [a] -> Maybe ([a], [a]) +stripFirstPrefix :: Eq a => [[a]] -> [a] -> Maybe ([a], [a]) stripFirstPrefix prefixes list = Visit.findJust strip prefixes where strip prefix = (,) prefix Applicative.<$> List.stripPrefix prefix list diff --git a/src/library/Language/Haskell/Formatter/Toolkit/Visit.hs b/src/library/Language/Haskell/Formatter/Toolkit/Visit.hs --- a/src/library/Language/Haskell/Formatter/Toolkit/Visit.hs +++ b/src/library/Language/Haskell/Formatter/Toolkit/Visit.hs @@ -18,11 +18,11 @@ findJust function = Foldable.asum . fmap function {-| @compose f@ returns the function composition of the elements of @f@. -} -compose :: (Foldable.Foldable t) => t (a -> a) -> a -> a +compose :: Foldable.Foldable t => t (a -> a) -> a -> a compose = Monoid.appEndo . Foldable.foldMap Monoid.Endo {-| @orderByKey k l@ orders @l@ by the sort keys generated by @k@. -} -orderByKey :: (Ord b) => (a -> b) -> [a] -> [a] +orderByKey :: Ord b => (a -> b) -> [a] -> [a] orderByKey = List.sortBy . Ord.comparing {-| @halfZipWith m b e@ zips the elements of @b@ and @e@ with @m@, using the @@ -40,7 +40,7 @@ {-| Like 'Traversable.mapAccumL', but with a function to create the base. -} mapAccumulateLeftWithCreation :: - (Traversable.Traversable t) => + Traversable.Traversable t => (a -> b -> (a, c)) -> (b -> a) -> t b -> (Maybe a, t c) mapAccumulateLeftWithCreation process createBase diff --git a/testsuite/resources/examples/default_style.yaml b/testsuite/resources/examples/default_style.yaml --- a/testsuite/resources/examples/default_style.yaml +++ b/testsuite/resources/examples/default_style.yaml @@ -9,13 +9,16 @@ # Reference: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777 ribbons_per_line: 1 +# More than this number of empty lines in succession are merged. +successive_empty_lines_limit: 1 + # Indentation lengths in characters. indentations: - class: 8 # "class" and "instance" declarations. - do: 3 # "do" notation. - case: 4 # Body of "case" expressions. - let: 4 # Declarations in "let" expressions. - where: 6 # Declarations in "where" clauses. + class: 8 # "class" and "instance" declarations. + do: 3 # "do" notation. + case: 4 # Body of "case" expressions. + let: 4 # Declarations in "let" expressions. + where: 6 # Declarations in "where" clauses. onside: 2 # Continuation lines which would otherwise be offside. # Decides which parts of the code to sort. diff --git a/testsuite/src/Language/Haskell/Formatter/Toolkit/FileTesting.hs b/testsuite/src/Language/Haskell/Formatter/Toolkit/FileTesting.hs --- a/testsuite/src/Language/Haskell/Formatter/Toolkit/FileTesting.hs +++ b/testsuite/src/Language/Haskell/Formatter/Toolkit/FileTesting.hs @@ -16,7 +16,7 @@ fileTestForest = folderTestForest readFile folderTestForest :: - (Monoid.Monoid a) => + Monoid.Monoid a => (FilePath -> IO a) -> (Either Exception.IOException (Map.Map FilePath a) -> [Tasty.TestTree])