hindent 4.6.1 → 4.6.2

raw patch · 13 files changed

+1164/−129 lines, 13 filesdep +containersdep +criteriondep +deepseqdep ~basedep ~haskell-src-extsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, criterion, deepseq

Dependency ranges changed: base, haskell-src-exts

API changes (from Hackage documentation)

Files

• README.md +18/−1
• hindent.cabal +17/−1
• src/HIndent.hs +24/−4
• src/HIndent/Comments.hs +93/−85
• src/HIndent/Pretty.hs +16/−15
• src/HIndent/Styles/ChrisDone.hs +48/−1
• src/HIndent/Styles/Cramer.hs +888/−0
• src/HIndent/Styles/Gibiansky.hs +13/−1
• src/HIndent/Styles/JohanTibell.hs +12/−0
• src/HIndent/Types.hs +0/−4
• src/main/Benchmark.hs +34/−0
• src/main/Main.hs +0/−16
• test/Spec.hs +1/−1

@@ -17,7 +17,7 @@      $ cat path/to/sourcefile.hs | hindent > outfile.hs -    hindent: arguments: --style [fundamental|chris-done|johan-tibell|gibiansky]+    hindent: arguments: --style [fundamental|chris-done|johan-tibell|gibiansky|cramer]  ## Emacs @@ -211,6 +211,23 @@                       putStrLn "yay"                       return 1) bill -- Etc +  where+    potato Cakes{} = 2 * x foo * bar / 5+```++### Enno Cramer++``` haskell+foo = do+    print "OK, go"+    foo (foo bar)+        (if bar then bob else pif)+        (case mu {- cool -} zot of+             Just x -> return ()+             Nothing -> do+                 putStrLn "yay"+                 return 1)+        bill -- Etc   where     potato Cakes{} = 2 * x foo * bar / 5 ```

@@ -1,5 +1,5 @@ name:                hindent-version:             4.6.1+version:             4.6.2 synopsis:            Extensible Haskell pretty printer description:         Extensible Haskell pretty printer. Both a library and an executable.                      .@@ -41,7 +41,9 @@                      HIndent.Styles.ChrisDone                      HIndent.Styles.JohanTibell                      HIndent.Styles.Gibiansky+                     HIndent.Styles.Cramer   build-depends:     base >= 4.7 && <5+                   , containers                    , data-default                    , haskell-src-exts >= 1.17                    , monad-loops@@ -83,3 +85,17 @@                    , text                    , hspec                    , directory++benchmark hindent-bench+  type: exitcode-stdio-1.0+  hs-source-dirs:    src/main+  ghc-options:       -Wall -O2 -rtsopts+  main-is:           Benchmark.hs+  build-depends:     base >= 4 && < 5+                   , hindent+                   , text+                   , haskell-src-exts+                   , ghc-prim+                   , directory+                   , criterion+                   , deepseq

@@ -15,25 +15,32 @@   ,johanTibell   ,fundamental   ,gibiansky+  ,cramer   -- * Testing   ,test   ,testFile   ,testAll   ,testAst+  ,defaultExtensions   )   where  import           HIndent.Comments import           HIndent.Pretty import           HIndent.Styles.ChrisDone (chrisDone)+import           HIndent.Styles.Cramer (cramer) import           HIndent.Styles.Fundamental (fundamental) import           HIndent.Styles.Gibiansky (gibiansky) import           HIndent.Styles.JohanTibell (johanTibell) import           HIndent.Types +import           Control.Applicative ((<$>)) import           Control.Monad.State.Strict import           Control.Monad.Trans.Maybe+import           Data.Function (on) import           Data.Functor.Identity+import           Data.List+import           Data.List (groupBy, intersperse) import           Data.Maybe (fromMaybe) import           Data.Monoid import qualified Data.Text.IO as ST@@ -43,9 +50,6 @@ import qualified Data.Text.Lazy.Builder as T import qualified Data.Text.Lazy.IO as T import           Language.Haskell.Exts.Annotated hiding (Style, prettyPrint, Pretty, style, parse)-import           Data.Function (on)-import           Data.List (groupBy, intersperse)-import           Control.Applicative ((<$>))  data CodeBlock = HaskellSource Text                | CPPDirectives Text@@ -228,4 +232,20 @@ -- | Styles list, useful for programmatically choosing. styles :: [Style] styles =-  [fundamental,chrisDone,johanTibell,gibiansky]+  [fundamental,chrisDone,johanTibell,gibiansky,cramer]++-- | Default extensions.+defaultExtensions :: [Extension]+defaultExtensions =+  [e | e@EnableExtension{} <- knownExtensions] \\+  map EnableExtension badExtensions++-- | Extensions which steal too much syntax.+badExtensions :: [KnownExtension]+badExtensions =+    [Arrows -- steals proc+    ,TransformListComp -- steals the group keyword+    ,XmlSyntax, RegularPatterns -- steals a-b+    ,UnboxedTuples -- breaks (#) lens operator+    -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+    ]

@@ -5,106 +5,114 @@  module HIndent.Comments where +import Control.Applicative ((<|>))+import Control.Arrow (first, second) import Control.Monad.State.Strict import Data.Data-import Data.Function+import qualified Data.Map.Strict as M import Data.Traversable import HIndent.Types import Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse) +-- Order by start of span, larger spans before smaller spans.+newtype OrderByStart =+  OrderByStart SrcSpan+  deriving (Eq)++instance Ord OrderByStart where+  compare (OrderByStart l) (OrderByStart r) =+    compare (srcSpanStartLine l)+            (srcSpanStartLine r) `mappend`+    compare (srcSpanStartColumn l)+            (srcSpanStartColumn r) `mappend`+    compare (srcSpanEndLine r)+            (srcSpanEndLine l) `mappend`+    compare (srcSpanEndColumn r)+            (srcSpanEndColumn l)++-- Order by end of span, smaller spans before larger spans.+newtype OrderByEnd =+  OrderByEnd SrcSpan+  deriving (Eq)++instance Ord OrderByEnd where+  compare (OrderByEnd l) (OrderByEnd r) =+    compare (srcSpanEndLine l)+            (srcSpanEndLine r) `mappend`+    compare (srcSpanEndColumn l)+            (srcSpanEndColumn r) `mappend`+    compare (srcSpanStartLine r)+            (srcSpanStartLine l) `mappend`+    compare (srcSpanStartColumn r)+            (srcSpanStartColumn l)+ -- | Annotate the AST with comments.-annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast)+annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast,Show (ast NodeInfo))                  => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo) annotateComments src comments =-  let-      -- Make sure to process comments top to bottom.-      reversed = reverse comments--      -- Replace source spans with node infos in the AST.-      src' = fmap (\n -> NodeInfo n []) src--      -- Add all comments to the ast.-      (cominfos, src'') = foldr processComment ([], src') reversed+  evalState (do _ <- traverse assignComment comments+                cis <- gets fst+                ast <- traverse transferComments src+                return (cis,ast))+            ([],nodeinfos)+  where+    nodeinfos :: M.Map SrcSpanInfo NodeInfo+    nodeinfos = foldr (\ssi -> M.insert ssi (NodeInfo ssi [])) M.empty src -  in -- Reverse order of comments at each node.-    (cominfos, fmap (\(NodeInfo n cs) -> NodeInfo n $ reverse cs) src'')+    -- Assign a single comment to the right AST node+    assignComment :: Comment -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) ()+    assignComment comment@(Comment _ cspan _) =+      -- Find the biggest AST node directly in front of this comment.+      case nodeBefore comment of+        -- Comments before any AST node are handled separately.+        Nothing -> modify $ first $ (:) (ComInfo comment Nothing) -  where processComment :: Comment-                       -> ([ComInfo],ast NodeInfo)-                       -> ([ComInfo],ast NodeInfo)-        -- Add in a single comment to the ast.-        processComment c@(Comment _ cspan _) (cs,ast) =-          -- Try to find the node after which this comment lies.-          case execState (traverse (collect After c) ast) Nothing of-            -- When no node is found, the comment is on its own line.-            Nothing -> (ComInfo c Nothing : cs, ast)+        Just ssi ->+          -- Comments on the same line as the AST node belong to this node.+          if sameline (srcInfoSpan ssi) cspan+             then insertComment After ssi+             else do nodeinfo <- gets ((M.! ssi) . snd)+                     case nodeinfo of+                       -- We've already collected comments for this+                       -- node and this comment is a continuation.+                       NodeInfo _ ((ComInfo c' _):_)+                         | aligned c' comment -> insertComment After ssi -            -- We found the node that this comment follows.-            -- Check whether the node is on the same line.-            Just (NodeInfo l coms)-              -- If it's on a different line than the node, but the node has an-              -- EOL comment, and the EOL comment and this comment are aligned,-              -- attach this comment to the preceding node.-              | ownLine && alignedWithPrevious -> insertedBefore+                       -- The comment does not belong to this node.+                       -- If there is a node following this comment,+                       -- assign it to that node, else keep it here,+                       -- anyway.+                       _ ->+                         case nodeAfter comment of+                           Nothing -> insertComment After ssi+                           Just ssi' -> insertComment Before ssi'+      where+        sameline :: SrcSpan -> SrcSpan -> Bool+        sameline before after = srcSpanEndLine before == srcSpanStartLine after -              -- If it's on a different line than the node, look for the following node to attach it to.-              | ownLine ->-                  case execState (traverse (collect Before c) ast) Nothing of-                    -- If we don't find a node after the comment, leave it with the previous node.-                    Nothing   -> insertedBefore-                    Just (NodeInfo node _) ->-                      (cs, evalState (traverse (insert node (ComInfo c $ Just Before)) ast) False)+        aligned :: Comment -> Comment -> Bool+        aligned (Comment _ before _) (Comment _ after _) =+          srcSpanEndLine before == srcSpanStartLine after - 1 &&+          srcSpanStartColumn before == srcSpanStartColumn after -              -- If it's on the same line, insert this comment into that node.-              | otherwise -> insertedBefore-              where-                ownLine = srcSpanStartLine cspan /= srcSpanEndLine (srcInfoSpan l)-                insertedBefore = (cs, evalState (traverse (insert l (ComInfo c $ Just After)) ast) False)-                alignedWithPrevious-                  | null coms = False-                  | otherwise = case last coms of-                      -- Require single line comment after the node.-                      ComInfo (Comment False prevSpan _) (Just After) ->-                        srcSpanStartLine prevSpan == srcSpanStartLine cspan - 1 &&-                        srcSpanStartColumn prevSpan == srcSpanStartColumn cspan-                      _       -> False+        insertComment :: ComInfoLocation -> SrcSpanInfo -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) ()+        insertComment l ssi = modify $ second $ M.adjust (addComment (ComInfo comment (Just l))) ssi -        -- For a comment, check whether the comment is after the node.-        -- If it is, store it in the state; otherwise do nothing.-        -- The location specifies where the comment should lie relative to the node.-        collect :: ComInfoLocation -> Comment -> NodeInfo -> State (Maybe NodeInfo) NodeInfo-        collect loc' c ni@(NodeInfo newL _) =-          do when (commentLocated loc' ni c)-                  (modify (maybe (Just ni)-                                 (\oldni@(NodeInfo oldL _) ->-                                    Just (if (spanTest loc' `on` srcInfoSpan) oldL newL-                                             then ni-                                             else oldni))))-             return ni+        addComment :: ComInfo -> NodeInfo -> NodeInfo+        addComment x (NodeInfo s xs) = NodeInfo s (x : xs) -        -- Insert the comment into the ast. Find the right node and add it to the-        -- comments of that node. Do nothing afterwards.-        insert :: SrcSpanInfo -> ComInfo -> NodeInfo -> State Bool NodeInfo-        insert al c ni@(NodeInfo bl cs) =-          do done <- get-             if not done && al == bl-                then do put True-                        return (ni {nodeInfoComments = c : cs})-                else return ni+    -- Transfer collected comments into the AST.+    transferComments :: SrcSpanInfo -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) NodeInfo+    transferComments ssi =+      do ni <- gets ((M.! ssi) . snd)+         -- Sometimes, there are multiple AST nodes with the same+         -- SrcSpan.  Make sure we assign comments to only one of+         -- them.+         modify $ second $ M.adjust (\(NodeInfo s _) -> NodeInfo s []) ssi+         return ni { nodeInfoComments = reverse $ nodeInfoComments ni } --- | Is the comment after the node?-commentLocated :: ComInfoLocation -> NodeInfo -> Comment -> Bool-commentLocated loc' (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) =-  spanTest loc' n c+    nodeBefore (Comment _ ss _) = fmap snd $ (OrderByEnd ss) `M.lookupLT` spansByEnd+    nodeAfter (Comment _ ss _) = fmap snd $ (OrderByStart ss) `M.lookupGT` spansByStart --- | For @After@, does the first span end before the second starts?--- For @Before@, does the first span start after the second ends?-spanTest :: ComInfoLocation -> SrcSpan -> SrcSpan -> Bool-spanTest loc' first second =-  (srcSpanStartLine after > srcSpanEndLine before) ||-  ((srcSpanStartLine after == srcSpanEndLine before) &&-   (srcSpanStartColumn after > srcSpanEndColumn before))-  where (before,after) =-          case loc' of-            After -> (first,second)-            Before -> (second,first)+    spansByStart = foldr (\ssi -> M.insert (OrderByStart $ srcInfoSpan ssi) ssi) M.empty src+    spansByEnd = foldr (\ssi -> M.insert (OrderByEnd $ srcInfoSpan ssi) ssi) M.empty src

@@ -284,7 +284,7 @@      maker      st <- get      col <- gets psColumn-     if state' /= st+     if psLine state' /= psLine st || psColumn state' /= psColumn st         then column col dependent         else dependent @@ -296,7 +296,7 @@      v <- maker      st <- get      col <- gets psColumn-     if state' /= st+     if psLine state' /= psLine st || psColumn state' /= psColumn st         then column col (dependent v)         else (dependent v) @@ -573,7 +573,7 @@            pretty right       TyEquals _ left right ->         do pretty left-           write " == "+           write " ~ "            pretty right       ty@TyPromoted{} -> pretty' ty       TySplice{} -> error "FIXME: No implementation for TySplice."@@ -702,18 +702,13 @@                                write " .. ")                            (pretty f))) exp (ListComp _ e qstmt) =-  brackets (depend (do pretty e-                       unless (null qstmt)-                              (write " |"))-                   (do space-                       prefixedLined-                         ","-                         (map (\(i,x) ->-                                 depend (if i == 0-                                            then return ()-                                            else space)-                                        (pretty x))-                              (zip [0 :: Integer ..] qstmt))))+  brackets (do pretty e+               unless (null qstmt)+                      (do newline+                          indented (-1)+                                   (write "|")+                          prefixedLined ","+                                        (map pretty qstmt))) exp (ExpTypeSig _ e t) =   depend (do pretty e              write " :: ")@@ -1267,6 +1262,12 @@     write "'"     string rep     write "'#"+  -- We print the original notation (because HSE doesn't track Hex+  -- vs binary vs decimal notation).+  prettyInternal (Int _l _i originalString) =+    string originalString+  prettyInternal (Frac _l _r originalString) =+    string originalString   prettyInternal x = pretty' x  instance Pretty Name where

@@ -51,7 +51,8 @@            ,Extender rhs            ,Extender contextualGuardedRhs            ,Extender stmt-           ,Extender decl]+           ,Extender decl+           ,Extender types]         ,styleDefConfig =            defaultConfig {configMaxColumns = 80                          ,configIndentSpaces = 2}@@ -60,6 +61,22 @@ -------------------------------------------------------------------------------- -- Extenders +types :: Type NodeInfo -> Printer s ()+types (TyTuple _ boxed tys) =+        depend (write (case boxed of+                         Unboxed -> "(#"+                         Boxed -> "("))+               (do (fits,_) <- fitsOnOneLine p+                   if fits+                      then p+                      else prefixedLined ","+                                         (map pretty tys)+                   write (case boxed of+                            Unboxed -> "#)"+                            Boxed -> ")"))+        where p = commas (map pretty tys)+types e = prettyNoExt e+ -- | Pretty print type signatures like -- -- foo :: (Show x,Read x)@@ -69,6 +86,15 @@ --     -> IO () -- decl :: Decl NodeInfo -> Printer s ()+decl (TypeDecl _ head ty) =+  do write "type "+     pretty head+     write " = "+     (fits,st) <- fitsOnOneLine (pretty ty)+     if fits+        then put st+        else do newline+                indented 2 (pretty ty) decl (TypeSig _ names ty') =   do (fitting,st) <- isSmallFitting dependent      if fitting@@ -303,6 +329,27 @@              let overflow = psColumn st > columnLimit                  single = psLine st == line              return (not overflow && single)+exp (ListComp _ e qstmt) =+  brackets (do pretty e+               unless (null qstmt) (do (ok,st) <- sandbox oneLiner+                                       if ok+                                          then put st+                                          else lined))+  where oneLiner = do line <- gets psLine+                      write "|"+                      commas (map pretty qstmt)+                      st <- get+                      columnLimit <- getColumnLimit+                      let overflow = psColumn st > columnLimit+                          single = psLine st == line+                      return (not overflow && single)+        lined =+          do newline+             indented (-1)+                      (write "|")+             prefixedLined+               ","+               (map pretty qstmt) exp e = prettyNoExt e  --------------------------------------------------------------------------------

@@ -0,0 +1,888 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Enno Cramer's Style.++module HIndent.Styles.Cramer (cramer) where++import Control.Monad (forM_, replicateM_, unless, when)+import Control.Monad.State.Strict (MonadState, get, gets, put)++import Data.List (intersperse, sortOn)+import Data.Maybe (catMaybes, isJust, mapMaybe)++import Language.Haskell.Exts.Annotated.Syntax+import Language.Haskell.Exts.Comments+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts (prettyPrint)++import HIndent.Pretty hiding (inter, spaced)+import HIndent.Types++-- | Line breaking mode for syntactical constructs.+data LineBreak+  = Free    -- ^ Break whenever+  | Single  -- ^ Force single line (if possible)+  | Multi   -- ^ Force multiple lines+  deriving (Eq,Enum,Show)++-- | Printer state.+data State =+  State {cramerLineBreak :: LineBreak     -- ^ Current line breaking mode+        ,cramerLangPragmaLength :: Int    -- ^ Padding length for pragmas+        ,cramerModuleImportLength :: Int  -- ^ Padding length for module imports+        ,cramerRecordFieldLength :: Int   -- ^ Padding length for record fields+        }+  deriving (Show)++-- | Syntax shortcut for Extenders.+type Extend f = f NodeInfo -> Printer State ()++-- | Style definition.+cramer :: Style+cramer =+  Style {styleName = "cramer"+        ,styleAuthor = "Enno Cramer"+        ,styleDescription = "Enno Cramer's style"+        ,styleInitialState =+           State {cramerLineBreak = Free+                 ,cramerLangPragmaLength = 0+                 ,cramerModuleImportLength = 0+                 ,cramerRecordFieldLength = 0}+        ,styleExtenders =+           [Extender extModule+           ,Extender extModulePragma+           ,Extender extModuleHead+           ,Extender extExportSpecList+           ,Extender extImportDecl+           ,Extender extDecl+           ,Extender extDeclHead+           ,Extender extConDecl+           ,Extender extFieldDecl+           ,Extender extDeriving+           ,Extender extRhs+           ,Extender extContext+           ,Extender extType+           ,Extender extPat+           ,Extender extExp+           ,Extender extStmt+           ,Extender extMatch+           ,Extender extBinds+           ,Extender extFieldUpdate]+        ,styleDefConfig =+           defaultConfig {configMaxColumns = 80+                         ,configIndentSpaces = 4+                         ,configClearEmptyLines = True}+        ,styleCommentPreprocessor = return}++--------------------------------------------------------------------------------+-- Helper++-- | Return an ast node's SrcSpan.+nodeSrcSpan :: Annotated a => a NodeInfo -> SrcSpan+nodeSrcSpan = srcInfoSpan . nodeInfoSpan . ann++-- | Turn a Name into a String+nameStr :: Name a -> String+nameStr (Ident _ s) = s+nameStr (Symbol _ s) = "(" ++ s ++ ")"++-- | The difference between current column and indent level to force a+-- line break in reduceIndent.+maxDependOverhead :: Integral a => a+maxDependOverhead = 20++-- | Extract the name as a String from a ModuleName+moduleName :: ModuleName a -> String+moduleName (ModuleName _ s) = s++-- | Extract the names of a ModulePragma+pragmaNames :: ModulePragma a -> [String]+pragmaNames (LanguagePragma _ names) = map nameStr names+pragmaNames _ = []++-- | Return whether a data type has only empty constructors.+isEnum :: Decl NodeInfo -> Bool+isEnum (DataDecl _ (DataType _) Nothing (DHead _ _) constructors _) =+  all isSimple constructors+  where isSimple (QualConDecl _ Nothing Nothing (ConDecl _ _ [])) = True+        isSimple _ = False+isEnum _ = False++-- | Return whether a data type has only zero or one constructor.+isSingletonType :: Decl NodeInfo -> Bool+isSingletonType (DataDecl _ _ Nothing (DHead _ _) [] _) = True+isSingletonType (DataDecl _ _ Nothing (DHead _ _) [ _ ] _) = True+isSingletonType _ = False++-- | If the given String is smaller than the given length, pad on+-- right with spaces until the length matches.+padRight :: Int -> String -> String+padRight l s = take (max l (length s)) (s ++ repeat ' ')++-- | Return comments with matching location.+filterComments :: Annotated a => (Maybe ComInfoLocation -> Bool) -> a NodeInfo -> [ComInfo]+filterComments f = filter (f . comInfoLocation) . nodeInfoComments . ann++-- | Copy comments marked After from one AST node to another.+copyComments :: (Annotated ast1,Annotated ast2)+             => ComInfoLocation+             -> ast1 NodeInfo+             -> ast2 NodeInfo+             -> ast2 NodeInfo+copyComments loc from to = amap updateComments to+  where updateComments info = info { nodeInfoComments = oldComments ++ newComments }+        oldComments = filterComments (/= Just loc) to+        newComments = filterComments (== Just loc) from++-- | Return the number of line breaks between AST nodes.+lineDelta+  :: (Annotated ast1,Annotated ast2)+  => ast1 NodeInfo -> ast2 NodeInfo -> Int+lineDelta prev next = nextLine - prevLine+  where prevLine = maximum (prevNodeLine : prevCommentLines)+        nextLine = minimum (nextNodeLine : nextCommentLines)+        prevNodeLine = srcSpanEndLine . nodeSrcSpan $ prev+        nextNodeLine = srcSpanStartLine . nodeSrcSpan $ next+        prevCommentLines =+          map (srcSpanEndLine . commentSrcSpan) $+          filterComments (== Just After) prev+        nextCommentLines =+          map (srcSpanStartLine . commentSrcSpan) $+          filterComments (== Just Before) next+        commentSrcSpan = annComment . comInfoComment+        annComment (Comment _ sp _) = sp++-- | Specialized forM_ for Maybe.+maybeM_ :: Monad m+        => Maybe a -> (a -> m ()) -> m ()+maybeM_ = forM_++-- | Simplified HIndent.Pretty.inter that does not modify the indent level.+inter :: MonadState (PrintState s) m+      => m () -> [m ()] -> m ()+inter sep = sequence_ . intersperse sep++-- | Simplified HIndent.Pretty.spaced that does not modify the indent level.+spaced :: MonadState (PrintState s) m+       => [m ()] -> m ()+spaced = inter space++-- | Indent one level.+indentFull :: MonadState (PrintState s) m+           => m a -> m a+indentFull p = getIndentSpaces >>= flip indented p++-- | Indent a half level.+indentHalf :: MonadState (PrintState s) m+           => m a -> m a+indentHalf p = getIndentSpaces >>= flip indented p . (`div` 2)++-- | Set indentation level to current column.+align :: MonadState (PrintState s) m+      => m a -> m a+align p =+  do col <- getColumn+     indent <- gets psIndentLevel+     column (max col indent) p++-- | Update the line breaking mode and restore afterwards.+withLineBreak+  :: LineBreak -> Printer State a -> Printer State a+withLineBreak lb p =+  do old <- gets (cramerLineBreak . psUserState)+     modifyState $ \s -> s {cramerLineBreak = lb}+     result <- p+     modifyState $ \s -> s {cramerLineBreak = old}+     return result++-- | Use the first printer if it fits on a single line within the+-- column limit, otherwise use the second.+attemptSingleLine+  :: Printer State a -> Printer State a -> Printer State a+attemptSingleLine single multi =+  do prevState <- get+     case cramerLineBreak . psUserState $ prevState of+       Single -> single+       Multi -> multi+       Free ->+         do result <- withLineBreak Single single+            col <- getColumn+            row <- getLineNum+            if row == psLine prevState &&+               col <= configMaxColumns (psConfig prevState)+               then return result+               else do put prevState+                       multi++-- | Same as attemptSingleLine, but execute the second printer in Multi+-- mode.  Used in type signatures to force either a single line or+-- have each `->` on a line by itself.+attemptSingleLineType+  :: Printer State a -> Printer State a -> Printer State a+attemptSingleLineType single multi =+  attemptSingleLine single+                    (withLineBreak Multi multi)++-- | Format a list-like structure on a single line.+listSingleLine :: Pretty a+               => String+               -> String+               -> String+               -> [a NodeInfo]+               -> Printer State ()+listSingleLine open close _ [] =+  do string open+     space+     string close+listSingleLine open close sep xs =+  do string open+     space+     inter (string sep >> space) $ map pretty xs+     space+     string close++-- | Format a list-like structure with each element on a line by+-- itself.+listMultiLine+  :: Pretty a+  => String -> String -> String -> [a NodeInfo] -> Printer State ()+listMultiLine open close _ [] =+  align $+  do string open+     newline+     string close+listMultiLine open close sep xs =+  align $+  do string open+     space+     inter (newline >> string sep >> space) $ map pretty xs+     newline+     string close++-- | Format a list-like structure on a single line, if possible, or+-- each element on a line by itself.+listAttemptSingleLine :: Pretty a+                      => String+                      -> String+                      -> String+                      -> [a NodeInfo]+                      -> Printer State ()+listAttemptSingleLine open close sep xs =+  attemptSingleLine (listSingleLine open close sep xs)+                    (listMultiLine open close sep xs)++-- | Format a list-like structure, automatically breaking lines when+-- the next separator and item do not fit within the column limit.+listAutoWrap+  :: Pretty a+  => String -> String -> String -> [a NodeInfo] -> Printer State ()+listAutoWrap open close sep ps =+  align $+  do string open+     unless (null ps) $+       do space+          pretty $ head ps+          forM_ (map (\p -> string sep >> space >> pretty p)+                     (tail ps)) $+            \p ->+              do fits <- fitsColumnLimit p+                 unless fits newline+                 p+          space+     string close+  where fitsColumnLimit p =+          fmap fst . sandbox $+          do _ <- p+             col <- getColumn+             limit <- gets (configMaxColumns . psConfig)+             return $ col < limit++-- | Like `inter newline . map pretty`, but preserve empty lines+-- between elements.+preserveLineSpacing+  :: (Pretty ast,Annotated ast)+  => [ast NodeInfo] -> Printer State ()+preserveLineSpacing [] = return ()+preserveLineSpacing asts@(first:rest) =+  do pretty first+     forM_ (zip asts rest) $+       \(prev,cur) ->+         do replicateM_ (max 1 $ lineDelta prev cur)+                        newline+            pretty cur++-- | `reduceIndent short long printer` produces either `short printer`+-- or `newline >> indentFull (long printer)`, depending on whether the+-- current column is sufficiently near to the current indentation depth.+--+-- The function is used to avoid overly big dependent indentation by+-- heuristically breaking and non-dependently indenting.+reduceIndent :: (Printer State () -> Printer State ())+             -> (Printer State () -> Printer State ())+             -> Printer State ()+             -> Printer State ()+reduceIndent short long printer =+  do linebreak <- gets (cramerLineBreak . psUserState)+     case linebreak of+       Single -> single+       Multi -> multi+       Free ->+         do curCol <- getColumn+            curIndent <- gets psIndentLevel+            indentSpaces <- gets (configIndentSpaces . psConfig)+            if (curCol - curIndent - indentSpaces) < maxDependOverhead+               then single+               else multi+  where single = short printer+        multi = newline >> indentFull (long printer)++--------------------------------------------------------------------------------+-- Printer for reused syntactical constructs++whereBinds :: Binds NodeInfo -> Printer State ()+whereBinds binds =+  do newline+     indentHalf $+       do write "where"+          newline+          indentHalf $ pretty binds++rhsExpr :: Exp NodeInfo -> Printer State ()+-- No line break before do+rhsExpr expr@Do{} =+  do space+     rhsSeparator+     space+     pretty expr+rhsExpr expr =+  do space+     rhsSeparator+     attemptSingleLine single multi+  where single = space >> pretty expr+        multi = reduceIndent (\p -> space >> p) id (pretty expr)++guardedRhsExpr+  :: GuardedRhs NodeInfo -> Printer State ()+guardedRhsExpr (GuardedRhs _ guards expr) =+  depend (write "| ") $+  do inter (write ", ") $ map pretty guards+     rhsExpr expr++-- | Pretty print a name for being an infix operator.+prettyInfixOp :: MonadState (PrintState s) m+              => QName NodeInfo -> m ()+prettyInfixOp op =+  case op of+    Qual{} ->+      do write "`"+         pretty' op+         write "`"+    UnQual _ n ->+      case n of+        Ident _ i -> string ("`" ++ i ++ "`")+        Symbol _ s -> string s+    Special _ s -> pretty s++tupleExpr+  :: Pretty ast+  => Boxed -> [ast NodeInfo] -> Printer State ()+tupleExpr boxed exprs = attemptSingleLine single multi+  where single =+          do string open+             inter (write ", ") $ map pretty exprs+             string close+        multi = listMultiLine open close "," exprs+        (open,close) =+          case boxed of+            Unboxed -> ("(#","#)")+            Boxed -> ("(",")")++listExpr :: Pretty ast+         => [ast NodeInfo] -> Printer State ()+listExpr [] = write "[]"+listExpr xs = listAttemptSingleLine "[" "]" "," xs++recordExpr+  :: (Pretty ast,Pretty ast')+  => ast NodeInfo -> [ast' NodeInfo] -> Printer State ()+recordExpr expr updates =+  do pretty expr+     space+     listAttemptSingleLine "{" "}" "," updates++ifExpr :: (Printer State () -> Printer State ())+       -> Exp NodeInfo+       -> Exp NodeInfo+       -> Exp NodeInfo+       -> Printer State ()+ifExpr indent cond true false = attemptSingleLine single multi+  where single = spaced [if',then',else']+        multi =+          align $+          do if'+             indent $+               do newline+                  then'+                  newline+                  else'+        if' = write "if " >> pretty cond+        then' = write "then " >> pretty true+        else' = write "else " >> pretty false++letExpr+  :: Binds NodeInfo -> Printer State () -> Printer State ()+letExpr binds expr =+  align $+  do depend (write "let ") $ pretty binds+     newline+     write "in"+     expr++infixExpr :: Exp NodeInfo -> Printer State ()+-- No line break before do+infixExpr (InfixApp _ arg1 op arg2@Do{}) =+  spaced [pretty arg1,pretty op,pretty arg2]+-- Try to preserve existing line break before and after infix ops+infixExpr (InfixApp _ arg1 op arg2)+  | deltaBefore /= 0 && deltaAfter /= 0 =+    align $ inter newline [pretty arg1,pretty op,pretty arg2]+  | deltaBefore /= 0 || deltaAfter /= 0 =+    pretty arg1 >>+    spaceOrIndent+      deltaBefore+      (pretty op >>+       spaceOrIndent deltaAfter+                     (pretty arg2))+  | otherwise = attemptSingleLine single multi+  where single = spaced [pretty arg1,pretty op,pretty arg2]+        multi =+          do pretty arg1+             space+             pretty op+             newline+             indentFull $ pretty arg2+        spaceOrIndent delta p =+          if delta > 0+             then newline >> indentFull p+             else space >> p+        deltaBefore = lineDelta arg1 op+        deltaAfter = lineDelta op arg2+infixExpr _ = error "not an InfixApp"++applicativeExpr :: Exp NodeInfo+                -> [(QOp NodeInfo,Exp NodeInfo)]+                -> Printer State ()+applicativeExpr ctor args = attemptSingleLine single multi+  where single = spaced (pretty ctor : map prettyArg args)+        multi =+          do pretty ctor+             depend space $ inter newline $ map prettyArg args+        prettyArg (op,arg) = pretty op >> space >> pretty arg++typeSig :: Type NodeInfo -> Printer State ()+typeSig ty =+  attemptSingleLineType (write ":: " >> pretty ty)+                        (align $ write ":: " >> pretty ty)++typeInfixExpr+  :: Type NodeInfo -> Printer State ()+-- As HIndent does not know about operator precedence, preserve+-- existing line breaks, but do not add new ones.+typeInfixExpr (TyInfix _ arg1 op arg2)+  | deltaBefore /= 0 && deltaAfter /= 0 =+    align $ inter newline [pretty arg1,prettyInfixOp op,pretty arg2]+  | deltaBefore /= 0 || deltaAfter /= 0 =+    pretty arg1 >>+    spaceOrIndent+      deltaBefore+      (prettyInfixOp op >>+       spaceOrIndent deltaAfter+                     (pretty arg2))+  | otherwise = spaced [pretty arg1,prettyInfixOp op,pretty arg2]+  where spaceOrIndent delta p =+          if delta > 0+             then newline >> indentFull p+             else space >> p+        deltaBefore = lineDelta arg1 op+        deltaAfter = lineDelta op arg2+typeInfixExpr _ = error "not a TyInfix"++--------------------------------------------------------------------------------+-- Extenders++extModule :: Extend Module+extModule (Module _ mhead pragmas imports decls) =+  do modifyState $ \s -> s {cramerLangPragmaLength = pragLen+                           ,cramerModuleImportLength = modLen}+     inter (newline >> newline) $+       catMaybes [unless' (null pragmas) $ preserveLineSpacing pragmas+                 ,pretty <$> mhead+                 ,unless' (null imports) $ preserveLineSpacing imports+                 ,unless' (null decls) $+                  do forM_ (init decls) $+                       \decl ->+                         do pretty decl+                            newline+                            unless (skipNewline decl) newline+                     pretty (last decls)]+  where pragLen = maximum $ map length $ concatMap pragmaNames pragmas+        modLen = maximum $ map (length . moduleName . importModule) imports+        unless' cond expr =+          if not cond+             then Just expr+             else Nothing+        skipNewline TypeSig{} = True+        skipNewline _ = False+extModule other = prettyNoExt other++-- Align closing braces of pragmas+extModulePragma :: Extend ModulePragma+extModulePragma (LanguagePragma _ names) =+  do namelen <- gets (cramerLangPragmaLength . psUserState)+     forM_ names $+       \name ->+         do write "{-# LANGUAGE "+            string $ padRight namelen $ nameStr name+            write " #-}"+-- Avoid increasing whitespace after OPTIONS string+extModulePragma (OptionsPragma _ mtool opt) =+  do write "{-# OPTIONS"+     maybeM_ mtool $ \tool -> do write "_"+                                 string $ prettyPrint tool+     space+     string $ trim opt+     write " #-}"+  where trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ')+extModulePragma other = prettyNoExt other++-- Empty or single item export list on one line, otherwise one item+-- per line with parens and comma aligned+extModuleHead :: Extend ModuleHead+extModuleHead (ModuleHead _ name mwarn mexports) =+  do mapM_ pretty mwarn+     write "module "+     pretty name+     maybeM_ mexports $ \exports -> pretty exports+     write " where"++-- Align export list, one item per line+extExportSpecList :: Extend ExportSpecList+extExportSpecList (ExportSpecList _ exports) =+  case exports of+    [] -> write " ( )"+    [e]+      | not (hasComments e) -> write " ( " >> pretty e >> write " )"+    (first:rest) ->+      do newline+         indentFull $+           do write "( "+              commentCol <- getColumn+              align $ prettyExportSpec "" commentCol first+              forM_ rest $+                \export ->+                  do newline+                     prettyExportSpec ", " commentCol export+              newline+              write ")"+  where hasComments = any (not . null . nodeInfoComments)+        printCommentsSimple loc ast =+          let rawComments = filterComments (== Just loc) ast+          in do preprocessor <- gets psCommentPreprocessor+                comments <- preprocessor $ map comInfoComment rawComments+                forM_ comments $+                  printComment (Just $ nodeSrcSpan ast)+        prettyExportSpec prefix col spec =+          do column col $ printCommentsSimple Before spec+             string prefix+             prettyNoExt spec+             printCommentsSimple After spec++-- Align import statements+extImportDecl :: Extend ImportDecl+extImportDecl ImportDecl{..} =+  do if importQualified+        then write "import qualified "+        else write "import           "+     namelen <- gets (cramerModuleImportLength . psUserState)+     if isJust importAs || isJust importSpecs+        then string $ padRight namelen $ moduleName importModule+        else string $ moduleName importModule+     maybeM_ importAs $+       \name ->+         do write " as "+            pretty name+     maybeM_ importSpecs $+       \(ImportSpecList _ importHiding specs) ->+         do space+            when importHiding $ write "hiding "+            listAutoWrap "(" ")" "," $ sortOn prettyPrint specs++extDecl :: Extend Decl+-- No dependent indentation for type decls+extDecl (TypeDecl _ declhead ty) =+  do write "type "+     pretty declhead+     write " = "+     indentFull $ pretty ty+-- Fix whitespace before 'where' in class decl+extDecl (ClassDecl _ mcontext declhead fundeps mdecls) =+  do depend (write "class ") $+       depend (maybeCtx mcontext) $+         depend (pretty declhead) $+           depend (unless (null fundeps) $+               write " | " >> inter (write ", ") (map pretty fundeps)) $+             when (isJust mdecls) $ write " where"+     maybeM_ mdecls $+       \decls ->+         do newline+            indentFull $ lined $ map pretty decls+-- Align data constructors+extDecl decl@(DataDecl _ dataOrNew mcontext declHead constructors mderiv) =+  do mapM_ pretty mcontext+     pretty dataOrNew+     space+     pretty declHead+     write " ="+     if isEnum decl || isSingletonType decl+        then attemptSingleLine single multi+        else multi+     maybeM_ mderiv $ \deriv -> indentFull $ newline >> pretty deriv+  where single =+          do space+             inter (write " | ") $ map pretty constructors+        multi =+          reduceIndent+            (depend space . indented (-2))+            (\p -> write "  " >> p)+            (inter (newline >> write "| ") $ map pretty constructors)+-- Type signature either on a single line or split at arrows, aligned with '::'+extDecl (TypeSig _ names ty) =+  do inter (write ", ") $ map pretty names+     space+     typeSig ty+-- Half-indent for where clause, half-indent binds+extDecl (PatBind _ pat rhs mbinds) =+  do pretty pat+     withCaseContext False $ pretty rhs+     maybeM_ mbinds whereBinds+extDecl other = prettyNoExt other++-- Do not modify indent level+extDeclHead :: Extend DeclHead+extDeclHead (DHApp _ dhead var) =+    do pretty dhead+       space+       pretty var+extDeclHead other = prettyNoExt other++extConDecl :: Extend ConDecl+-- No extra space after empty constructor+extConDecl (ConDecl _ name []) = pretty name+extConDecl (ConDecl _ name tys) = attemptSingleLine single multi+    where single = spaced $ pretty name : map pretty tys+          multi = depend (pretty name >> space) $ lined $ map pretty tys+-- Align record fields+extConDecl (RecDecl _ name fields) =+  do modifyState $ \s -> s {cramerRecordFieldLength = fieldLen}+     pretty name+     space+     case fields of+       [] -> write "{ }"+       [_] -> listAttemptSingleLine "{" "}" "," fields+       _ -> listMultiLine "{" "}" "," fields+  where fieldLen = maximum $ map (length . nameStr) fnames+        fnames =+          mapMaybe (\(FieldDecl _ ns _) ->+                      case ns of+                        [n] -> Just n+                        _ -> Nothing)+                   fields+extConDecl other = prettyNoExt other++extFieldDecl :: Extend FieldDecl+extFieldDecl (FieldDecl _ [name] ty) =+  do namelen <- gets (cramerRecordFieldLength . psUserState)+     string $ padRight namelen $ nameStr name+     space+     typeSig ty+extFieldDecl other = prettyNoExt other++-- Derived instances separated by comma and space, no line breaking+extDeriving :: Extend Deriving+extDeriving (Deriving _ instHeads) =+  do write "deriving "+     case instHeads of+       [x] -> pretty x+       xs -> parens $ inter (write ", ") $ map pretty xs++extRhs :: Extend Rhs+extRhs (UnGuardedRhs _ expr) = rhsExpr expr+extRhs (GuardedRhss _ [rhs]) = space >> guardedRhsExpr rhs+extRhs (GuardedRhss _ rhss) =+  forM_ rhss $+  \rhs ->+    do newline+       indentFull $ guardedRhsExpr rhs++-- Type constraints on a single line+extContext :: Extend Context+extContext (CxTuple _ ctxs) = parens $ inter (write ", ") $ map pretty ctxs+extContext other = prettyNoExt other++extType :: Extend Type+extType (TyForall _ mforall mcontext ty) = attemptSingleLine single multi+  where single =+          do maybeM_ mforall $ \vars -> prettyForall vars >> space+             maybeM_ mcontext $ \context -> pretty context >> write " => "+             pretty ty+        multi =+          do maybeM_ mforall $ \vars -> prettyForall vars >> newline+             maybeM_ mcontext $+               \context -> pretty context >> newline >> write "=> "+             pretty ty+        prettyForall vars =+          do write "forall "+             spaced $ map pretty vars+             write "."+-- Type signature should line break at each arrow if necessary+extType (TyFun _ from to) =+  attemptSingleLineType (pretty from >> write " -> " >> pretty to)+                        (pretty from >> newline >> write "-> " >> pretty to)+-- Parentheses reset forced line breaking+extType (TyParen _ ty) = withLineBreak Free $ parens $ pretty ty+-- Tuple types on one line, with space after comma+extType (TyTuple _ boxed tys) = withLineBreak Free $ tupleExpr boxed tys+-- Infix application+extType expr@TyInfix{} = typeInfixExpr expr+extType other = prettyNoExt other++extPat :: Extend Pat+-- Infix application with space around operator+extPat (PInfixApp _ arg1 op arg2) =+  do pretty arg1+     space+     prettyInfixOp op+     space+     pretty arg2+-- Tuple patterns on one line, with space after comma+extPat (PTuple _ boxed pats) = withLineBreak Single $ tupleExpr boxed pats+-- List patterns on one line, with space after comma+extPat (PList _ pats) = withLineBreak Single $ listExpr pats+extPat other = prettyNoExt other++extExp :: Extend Exp+-- Function application on a single line or align arguments+extExp expr@(App _ fun arg) = attemptSingleLine single multi+  where single = pretty fun >> space >> pretty arg+        multi =+          pretty fun' >> space >> align (lined $ map pretty $ reverse args')+        (fun',args') = collectArgs expr+        collectArgs+          :: Exp NodeInfo -> (Exp NodeInfo,[Exp NodeInfo])+        collectArgs app@(App _ g y) =+          let (f,args) = collectArgs g+          in (f,copyComments After app y : args)+        collectArgs nonApp = (nonApp,[])+-- Infix application on a single line or indented rhs+extExp expr@InfixApp{} =+  if all (isApplicativeOp . fst) opArgs && isFmap (fst $ head opArgs)+     then applicativeExpr firstArg opArgs+     else infixExpr expr+  where (firstArg,opArgs) = collectOpExps expr+        collectOpExps+          :: Exp NodeInfo -> (Exp NodeInfo,[(QOp NodeInfo,Exp NodeInfo)])+        collectOpExps app@(InfixApp _ left op right) =+          let (ctorLeft,argsLeft) = collectOpExps left+              (ctorRight,argsRight) = collectOpExps right+          in (ctorLeft,argsLeft ++ [(op,copyComments After app ctorRight)] ++ argsRight)+        collectOpExps e = (e,[])+        isApplicativeOp :: QOp NodeInfo -> Bool+        isApplicativeOp (QVarOp _ (UnQual _ (Symbol _ s))) =+          head s == '<' && last s == '>'+        isApplicativeOp _ = False+        isFmap :: QOp NodeInfo -> Bool+        isFmap (QVarOp _ (UnQual _ (Symbol _ "<$>"))) = True+        isFmap _ = False+-- No space after lambda+extExp (Lambda _ pats expr) =+  do write "\\"+     maybeSpace+     spaced $ map pretty pats+     write " ->"+     -- No line break before do+     case expr of+       Do{} -> single+       _ -> attemptSingleLine single multi+  where single = space >> pretty expr+        multi = newline >> indentFull (pretty expr)+        maybeSpace =+          case pats of+            PBangPat{}:_ -> space+            PIrrPat{}:_ -> space+            _ -> return ()+-- If-then-else on one line or newline and indent before then and else+extExp (If _ cond true false) = ifExpr id cond true false+-- Newline before in+extExp (Let _ binds expr@Do{}) = letExpr binds $ space >> pretty expr+extExp (Let _ binds expr) = letExpr binds $ newline >> indentFull (pretty expr)+-- Tuples on a single line (no space inside parens but after comma) or+-- one element per line with parens and comma aligned+extExp (Tuple _ boxed exprs) = tupleExpr boxed exprs+-- List on a single line or one item per line with aligned brackets and comma+extExp (List _ exprs) = listExpr exprs+-- Record construction and update on a single line or one line per+-- field with aligned braces and comma+extExp (RecConstr _ qname updates) = recordExpr qname updates+extExp (RecUpdate _ expr updates) = recordExpr expr updates+-- Line break and indent after do+extExp (Do _ stmts) =+  do write "do"+     newline+     indentFull $ preserveLineSpacing stmts+extExp (ListComp _ e qstmt) =+  brackets (do space+               pretty e+               unless (null qstmt)+                      (do newline+                          indented (-1)+                                   (write "|")+                          prefixedLined ","+                                        (map (\x -> do space+                                                       pretty x+                                                       space)+                                             qstmt)))+-- Type signatures like toplevel decl+extExp (ExpTypeSig _ expr ty) =+  do pretty expr+     space+     typeSig ty+extExp other = prettyNoExt other++extStmt :: Extend Stmt+extStmt (Qualifier _ (If _ cond true false)) = ifExpr indentFull cond true false+extStmt other = prettyNoExt other++extMatch :: Extend Match+-- Indent where same as for top level decl+extMatch (Match _ name pats rhs mbinds) =+  do pretty name+     space+     spaced $ map pretty pats+     withCaseContext False $ pretty rhs+     maybeM_ mbinds whereBinds+extMatch other = prettyNoExt other++-- Preserve empty lines between bindings+extBinds :: Extend Binds+extBinds (BDecls _ decls) = preserveLineSpacing decls+extBinds other = prettyNoExt other++-- No line break after equal sign+extFieldUpdate :: Extend FieldUpdate+extFieldUpdate (FieldUpdate _ qname expr) =+  do pretty qname+     write " = "+     pretty expr+extFieldUpdate other = prettyNoExt other

@@ -4,7 +4,7 @@ module HIndent.Styles.Gibiansky where  import           Data.Foldable-import           Control.Applicative ((<$>))+-- import           Control.Applicative ((<$>)) import           Data.Maybe import           Data.List (unfoldr, isPrefixOf) import           Control.Monad.Trans.Maybe@@ -411,6 +411,18 @@ exprs (RecUpdate _ exp updates) = recUpdateExpr updates (pretty exp) (map prettyCommentCallbacks updates) exprs (RecConstr _ qname updates) = recUpdateExpr updates (pretty qname) (map prettyCommentCallbacks updates) exprs (Tuple _ _ exps) = parens $ inter (write ", ") $ map pretty exps+exprs (ListComp _ e qstmt) =+  brackets (do space+               pretty e+               unless (null qstmt)+                      (do newline+                          indented (-1)+                                   (write "|")+                          prefixedLined ","+                                        (map (\x -> do space+                                                       pretty x+                                                       space)+                                             qstmt))) exprs exp = prettyNoExt exp  multiIfExpr :: Exp NodeInfo -> Printer State ()

@@ -257,6 +257,18 @@              newline              indented (-4) (depend (write "in ")                                    (pretty e)))+exp (ListComp _ e qstmt) =+  brackets (do space+               pretty e+               unless (null qstmt)+                      (do newline+                          indented (-1)+                                   (write "|")+                          prefixedLined ","+                                        (map (\x -> do space+                                                       pretty x+                                                       space)+                                             qstmt))) exp e = prettyNoExt e  match :: Match NodeInfo -> Printer s ()

@@ -54,10 +54,6 @@              ,psCommentPreprocessor :: forall m. MonadState (PrintState s) m => [Comment] -> m [Comment] -- ^ Preprocessor applied to comments on an AST before printing.              } -instance Eq (PrintState s) where-  PrintState ilevel out newline col line _ _ _ eolc inc _pm _ == PrintState ilevel' out' newline' col' line' _ _ _ eolc' inc' _pm' _ =-    (ilevel,out,newline,col,line,eolc, inc) == (ilevel',out',newline',col',line',eolc', inc')- -- | A printer extender. Takes as argument the user state that the -- printer was run with, and the current node to print. Use -- 'prettyNoExt' to fallback to the built-in printer.

@@ -0,0 +1,34 @@+{-# LANGUAGE BangPatterns #-}++-- | Benchmark the pretty printer.++module Main where++import           Control.DeepSeq+import           Criterion+import           Criterion.Main+import           Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.IO as LT+import qualified Data.Text.Lazy.Builder as T+import           HIndent++-- | Main benchmarks.+main :: IO ()+main =+  defaultMain+    [env setupEnv+         (\ ~bigDecls ->+             bgroup "Main"+                    [bgroup "BigDeclarations"+                            [bench ("HIndent.reformat: " +++                                    show (styleName style))+                                   (nf (either error T.toLazyText .+                                        reformat style (Just defaultExtensions))+                                       bigDecls)|style <- styles]])]++-- | Setup the environment for the benchmarks.+setupEnv :: IO Text+setupEnv = do+  bigDecls <- LT.readFile "benchmarks/BigDeclarations.hs"+  let !decls = force bigDecls+  return decls

@@ -108,19 +108,3 @@   case classifyExtension x of     UnknownExtension _ -> Nothing     x' -> Just x'---- | Default extensions.-defaultExtensions :: [Extension]-defaultExtensions =-  [e | e@EnableExtension{} <- knownExtensions] \\-  map EnableExtension badExtensions---- | Extensions which steal too much syntax.-badExtensions :: [KnownExtension]-badExtensions =-    [Arrows -- steals proc-    ,TransformListComp -- steals the group keyword-    ,XmlSyntax, RegularPatterns -- steals a-b-    ,UnboxedTuples -- breaks (#) lens operator-    -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break-    ]

@@ -15,7 +15,7 @@ import qualified HIndent  styles :: [FilePath]-styles = ["fundamental", "gibiansky", "chris-done", "johan-tibell"]+styles = ["fundamental", "gibiansky", "chris-done", "johan-tibell", "cramer"]  testDir, expectedDir :: String testDir = "tests"