hindent 5.0.1 → 5.1.0

raw patch · 11 files changed

+995/−676 lines, 11 filesdep +DiffPVP ok

version bump matches the API change (PVP)

Dependencies added: Diff

API changes (from Hackage documentation)

Files

• BENCHMARKS.md +99/−0
• CHANGELOG.md +5/−0
• README.md +38/−12
• TESTS.md +287/−47
• hindent.cabal +2/−2
• src/HIndent.hs +171/−39
• src/HIndent/Comments.hs +0/−120
• src/HIndent/Pretty.hs +319/−403
• src/HIndent/Types.hs +37/−36
• src/main/Main.hs +17/−14
• src/main/Test.hs +20/−3

@@ -56,6 +56,61 @@          -> Printer () ``` +Bunch of declarations - sans comments++``` haskell+listPrinters =+  [(''[]+   ,\(typeVariable:_) _automaticPrinter ->+      (let presentVar = varE (presentVarName typeVariable)+       in lamE [varP (presentVarName typeVariable)]+               [|(let typeString = "[" ++ fst $(presentVar) ++ "]"+                  in (typeString+                     ,\xs ->+                        case fst $(presentVar) of+                          "GHC.Types.Char" ->+                            ChoicePresentation+                              "String"+                              [("String",undefined)+                              ,("List of characters",undefined)]+                          _ ->+                            ListPresentation typeString+                                             (map (snd $(presentVar)) xs)))|]))]+printComments loc' ast = do+  let correctLocation comment = comInfoLocation comment == Just loc'+      commentsWithLocation = filter correctLocation (nodeInfoComments info)+  comments <- return $ map comInfoComment commentsWithLocation++  forM_ comments $ \comment -> do+    hasNewline <- gets psNewline+    when (not hasNewline && loc' == Before) newline++    printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment+  where info = ann ast+exp' (App _ op a) =+  do (fits,st) <-+       fitsOnOneLine (spaced (map pretty (f : args)))+     if fits+        then put st+        else do pretty f+                newline+                spaces <- getIndentSpaces+                indented spaces (lined (map pretty args))+  where (f,args) = flatten op [a]+        flatten :: Exp NodeInfo+                -> [Exp NodeInfo]+                -> (Exp NodeInfo,[Exp NodeInfo])+        flatten (App _ f' a') b =+          flatten f' (a' : b)+        flatten f' as = (f',as)+infixApp :: Exp NodeInfo+         -> Exp NodeInfo+         -> QOp NodeInfo+         -> Exp NodeInfo+         -> Maybe Int64+         -> Printer ()+```+ # Complex inputs  Quasi-quotes with nested lets and operators@@ -87,4 +142,48 @@                           _ ->                             ListPresentation typeString                                              (map (snd $(presentVar)) xs)))|]))]+```++Lots of comments and operators++``` haskell+bob -- after bob+ =+    foo -- next to foo+    -- line after foo+        (bar+             foo -- next to bar foo+             bar -- next to bar+         ) -- next to the end paren of (bar)+        -- line after (bar)+        mu -- next to mu+        -- line after mu+        -- another line after mu+        zot -- next to zot+        -- line after zot+        (case casey -- after casey+               of+             Just -- after Just+              -> do+                 justice -- after justice+                  *+                     foo+                         (blah * blah + z + 2 / 4 + a - -- before a line break+                          2 * -- inside this mess+                          z /+                          2 /+                          2 /+                          aooooo /+                          aaaaa -- bob comment+                          ) ++                     (sdfsdfsd fsdfsdf) -- blah comment+                 putStrLn "")+        [1, 2, 3]+        [ 1 -- foo+        , ( 2 -- bar+          , 2.5 -- mu+           )+        , 3]++foo = 1 -- after foo ```

@@ -1,3 +1,8 @@+5.1.0:+   * Rewrote comment association, more reliable+   * Added --tab-size flag for indentation spaces+   * Fixed some miscellaneous bugs+ 5.0.1:     * Re-implement using bytestring instead of text     * Made compatible with GHC 7.8 through to GHC 8.0

@@ -1,18 +1,38 @@ # hindent [![Hackage](https://img.shields.io/hackage/v/hindent.svg?style=flat)](https://hackage.haskell.org/package/hindent) [![Build Status](https://travis-ci.org/chrisdone/hindent.png)](https://travis-ci.org/chrisdone/hindent) -Extensible Haskell pretty printer. Both a library and an-executable.+Haskell pretty printer +[Demonstration site](http://chrisdone.com/hindent/)++[Examples](https://github.com/chrisdone/hindent/blob/master/TESTS.md)+ ## Install -    $ stack install+    $ stack install hindent  ## Usage -    hindent is used in a pipeline style:+    bash-3.2$ hindent --help+    hindent --version --help --style STYLE --line-length <...> --tab-size <...> [-X<...>]* [<FILENAME>]+    Version 5.0.1+    The --style option is now ignored, but preserved for backwards-compatibility.+    Johan Tibell is the default and only style. -    $ cat path/to/sourcefile.hs | hindent > outfile.hs+hindent is used in a pipeline style +    $ cat path/to/sourcefile.hs | hindent++Configure tab size with `--tab-size`:++    $ echo 'example = case x of Just p -> foo bar' | hindent --tab-size 2; echo+    example =+      case x of+        Just p -> foo bar+    $ echo 'example = case x of Just p -> foo bar' | hindent --tab-size 4; echo+    example =+        case x of+            Just p -> foo bar+ ## Emacs  In@@ -34,19 +54,25 @@  ## Vim -The `'formatprg'` option lets you use an external program (like hindent) to-format your text. Put the following line into ~/.vim/ftplugin/haskell.vim-to set this option for Haskell files:+The `'formatprg'` option lets you use an external program (like+hindent) to format your text. Put the following line into+~/.vim/ftplugin/haskell.vim to set this option for Haskell files:      setlocal formatprg=hindent  Then you can format with hindent using `gq`. Read `:help gq` and `help 'formatprg'` for more details. -Note that unlike in emacs you have to take care of selecting a sensible buffer region as input to-hindent yourself. If that is too much trouble you can try [vim-textobj-haskell](https://github.com/gilligan/vim-textobj-haskell) which provides a text object for top level bindings.+Note that unlike in emacs you have to take care of selecting a+sensible buffer region as input to hindent yourself. If that is too+much trouble you can try+[vim-textobj-haskell](https://github.com/gilligan/vim-textobj-haskell)+which provides a text object for top level bindings.  ## Atom -Basic support is provided through [atom/hindent.coffee](https://github.com/chrisdone/hindent/blob/master/atom/hindent.coffee). Mode should be installed as package into `.atom\packages\${PACKAGE_NAME}`,-here is simple example of atom [package](https://github.com/Heather/atom-hindent).+Basic support is provided through+[atom/hindent.coffee](https://github.com/chrisdone/hindent/blob/master/atom/hindent.coffee). Mode+should be installed as package into `.atom\packages\${PACKAGE_NAME}`,+here is simple example of atom+[package](https://github.com/Heather/atom-hindent).

@@ -13,16 +13,18 @@  ``` haskell module X where++x = 1 ```  Exports  ``` haskell module X-  (x-  ,y-  ,Z-  ,P(x, z))+  ( x+  , y+  , Z+  , P(x, z))   where ``` @@ -52,22 +54,24 @@ Lazy patterns in a lambda  ``` haskell-f = \ ~a -> undefined -- \~a yields parse error on input ‘\~’+f = \ ~a -> undefined+ -- \~a yields parse error on input ‘\~’ ```  Bang patterns in a lambda  ``` haskell-f = \ !a -> undefined -- \!a yields parse error on input ‘\!’+f = \ !a -> undefined+ -- \!a yields parse error on input ‘\!’ ```  List comprehensions  ``` haskell defaultExtensions =-  [ e-  | e@EnableExtension {} <- knownExtensions ] \\-  map EnableExtension badExtensions+    [ e+    | e@EnableExtension {} <- knownExtensions ] \\+    map EnableExtension badExtensions ```  Record indentation@@ -75,10 +79,10 @@ ``` haskell getGitProvider :: EventProvider GitRecord () getGitProvider =-  EventProvider-  { getModuleName = "Git"-  , getEvents = getRepoCommits-  }+    EventProvider+    { getModuleName = "Git"+    , getEvents = getRepoCommits+    } ```  Records again@@ -86,11 +90,11 @@ ``` haskell commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event commitToEvent gitFolderPath timezone commit =-  Event.Event-  { pluginName = getModuleName getGitProvider-  , eventIcon = "glyphicon-cog"-  , eventDate = localTimeToUTC timezone (commitDate commit)-  }+    Event.Event+    { pluginName = getModuleName getGitProvider+    , eventIcon = "glyphicon-cog"+    , eventDate = localTimeToUTC timezone (commitDate commit)+    } ```  Cases@@ -98,19 +102,18 @@ ``` haskell strToMonth :: String -> Int strToMonth month =-  case month of-    "Jan" -> 1-    "Feb" -> 2-    _ -> error $ "Unknown month " ++ month+    case month of+        "Jan" -> 1+        "Feb" -> 2+        _ -> error $ "Unknown month " ++ month ```  Operators  ``` haskell x =-  Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>-  Just thisissolong <*>-  Just stilllonger+    Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*> Just thisissolong <*>+    Just stilllonger ```  # Type signatures@@ -119,8 +122,8 @@  ``` haskell fun-  :: (Class a, Class b)-  => a -> b -> c+    :: (Class a, Class b)+    => a -> b -> c ```  Tuples@@ -134,10 +137,9 @@ Where clause  ``` haskell-sayHello :: IO () sayHello = do-  name <- getLine-  putStrLn $ greeting name+    name <- getLine+    putStrLn $ greeting name   where     greeting name = "Hello, " ++ name ++ "!" ```@@ -145,28 +147,39 @@ Guards and pattern guards  ``` haskell-f :: Int f x-  | x <- Just x-  , x <- Just x =-    case x of-      Just x -> e-  | otherwise = do e+    | x <- Just x+    , x <- Just x =+        case x of+            Just x -> e+    | otherwise = do e   where     x = y ``` +Multi-way if++``` haskell+x =+    if | x <- Just x,+         x <- Just x ->+           case x of+               Just x -> e+               Nothing -> p+       | otherwise -> e+```+ Case inside a `where` and `do`  ``` haskell g x =-  case x of-    a -> x+    case x of+        a -> x   where     foo =-      case x of-        _ -> do-          launchMissiles+        case x of+            _ -> do+                launchMissiles       where         y = 2 ```@@ -175,24 +188,251 @@  ``` haskell g x =-  let x = 1-  in x+    let x = 1+    in x   where     foo =-      let y = 2-          z = 3-      in y+        let y = 2+            z = 3+        in y ``` +Lists++``` haskell+exceptions = [InvalidStatusCode, MissingContentHeader, InternalServerError]++exceptions =+    [ InvalidStatusCode+    , MissingContentHeader+    , InternalServerError+    , InvalidStatusCode+    , MissingContentHeader+    , InternalServerError]+```++# Johan Tibell compatibility checks++Basic example from Tibbe's style++``` haskell+sayHello :: IO ()+sayHello = do+    name <- getLine+    putStrLn $ greeting name+  where+    greeting name = "Hello, " ++ name ++ "!"++filter :: (a -> Bool) -> [a] -> [a]+filter _ [] = []+filter p (x:xs)+    | p x = x : filter p xs+    | otherwise = filter p xs+```++Data declarations++``` haskell+data Tree a+    = Branch !a+             !(Tree a)+             !(Tree a)+    | Leaf++data HttpException+    = InvalidStatusCode Int+    | MissingContentHeader++data Person = Person+    { firstName :: !String -- ^ First name+    , lastName :: !String -- ^ Last name+    , age :: !Int -- ^ Age+    }+```++Spaces between deriving classes++``` haskell+-- From https://github.com/chrisdone/hindent/issues/167+data Person = Person+    { firstName :: !String -- ^ First name+    , lastName :: !String -- ^ Last name+    , age :: !Int -- ^ Age+    } deriving (Eq, Show)+```++Hanging lambdas++``` haskell+bar :: IO ()+bar =+    forM_ [1, 2, 3] $+    \n -> do+        putStrLn "Here comes a number!"+        print n++foo :: IO ()+foo =+    alloca 10 $+    \a ->+         alloca 20 $+         \b -> cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu)+```++# Comments++Comments within a declaration++``` haskell+bob -- after bob+ =+    foo -- next to foo+    -- line after foo+        (bar+             foo -- next to bar foo+             bar -- next to bar+         ) -- next to the end paren of (bar)+        -- line after (bar)+        mu -- next to mu+        -- line after mu+        -- another line after mu+        zot -- next to zot+        -- line after zot+        (case casey -- after casey+               of+             Just -- after Just+              -> do+                 justice -- after justice+                  *+                     foo+                         (blah * blah + z + 2 / 4 + a - -- before a line break+                          2 * -- inside this mess+                          z /+                          2 /+                          2 /+                          aooooo /+                          aaaaa -- bob comment+                          ) ++                     (sdfsdfsd fsdfsdf) -- blah comment+                 putStrLn "")+        [1, 2, 3]+        [ 1 -- foo+        , ( 2 -- bar+          , 2.5 -- mu+           )+        , 3]++foo = 1 -- after foo+```++Haddock comments++``` haskell+-- | Module comment.+module X where++-- | Main doc.+main :: IO ()+main = return ()++data X+    = X -- ^ X is for xylophone.+    | Y -- ^ Y is for why did I eat that pizza.++data X = X+    { field1 :: Int -- ^ Field1 is the first field.+    , field11 :: Char+      -- ^ This field comment is on its own line.+    , field2 :: Int -- ^ Field2 is the second field.+    , field3 :: Char -- ^ This is a long comment which starts next to+      -- the field but continues onto the next line, it aligns exactly+      -- with the field name.+    , field4 :: Char+      -- ^ This is a long comment which starts on the following line+      -- from from the field, lines continue at the sme column.+    }+```++Comments around regular declarations++``` haskell+-- This is some random comment.+-- | Main entry point.+main = putStrLn "Hello, World!"+ -- This is another random comment.+```+ # Behaviour checks  Unicode  ``` haskell-α = γ * "ω" -- υ+α = γ * "ω"+ -- υ ```  Empty module  ``` haskell+```++# Complex input++A complex, slow-to-print decl++``` haskell+quasiQuotes =+    [ ( ''[]+      , \(typeVariable:_) _automaticPrinter ->+             (let presentVar = varE (presentVarName typeVariable)+              in lamE+                     [varP (presentVarName typeVariable)]+                     [|(let typeString = "[" ++ fst $(presentVar) ++ "]"+                        in ( typeString+                           , \xs ->+                                  case fst $(presentVar) of+                                      "GHC.Types.Char" ->+                                          ChoicePresentation+                                              "String"+                                              [ ( "String"+                                                , StringPresentation+                                                      "String"+                                                      (concatMap+                                                           getCh+                                                           (map+                                                                (snd+                                                                     $(presentVar))+                                                                xs)))+                                              , ( "List of characters"+                                                , ListPresentation+                                                      typeString+                                                      (map (snd $(presentVar)) xs))]+                                          where getCh (CharPresentation "GHC.Types.Char" ch) =+                                                    ch+                                                getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =+                                                    ch+                                                getCh _ = ""+                                      _ ->+                                          ListPresentation+                                              typeString+                                              (map (snd $(presentVar)) xs)))|]))]+```++Random snippet from hindent itself++``` haskell+exp' (App _ op a) = do+    (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args)))+    if fits+        then put st+        else do+            pretty f+            newline+            spaces <- getIndentSpaces+            indented spaces (lined (map pretty args))+  where+    (f, args) = flatten op [a]+    flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo, [Exp NodeInfo])+    flatten (App _ f' a') b = flatten f' (a' : b)+    flatten f' as = (f', as) ```

@@ -1,5 +1,5 @@ name:                hindent-version:             5.0.1+version:             5.1.0 synopsis:            Extensible Haskell pretty printer description:         Extensible Haskell pretty printer. Both a library and an executable.                      .@@ -32,7 +32,6 @@   exposed-modules:   HIndent                      HIndent.Types                      HIndent.Pretty-                     HIndent.Comments   build-depends:     base >= 4.7 && <5                    , containers                    , haskell-src-exts >= 1.18@@ -75,6 +74,7 @@                    , deepseq                    , exceptions                    , utf8-string+                   , Diff  benchmark hindent-bench   type: exitcode-stdio-1.0

@@ -13,6 +13,7 @@   ,test   ,testFile   ,testAst+  ,testFileAst   ,defaultExtensions   ,getExtensions   )@@ -30,17 +31,19 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Unsafe as S-import           Data.Function (on)+import           Data.Either+import           Data.Function import           Data.Functor.Identity import           Data.List import           Data.Maybe import           Data.Monoid import           Data.Text (Text) import qualified Data.Text as T-import           HIndent.Comments+import           Data.Traversable hiding (mapM) import           HIndent.Pretty import           HIndent.Types import           Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse)+import           Prelude  data CodeBlock = HaskellSource ByteString                | CPPDirectives ByteString@@ -62,7 +65,7 @@           fmap (S.lazyByteString .           addPrefix prefix .           S.toLazyByteString)-          (prettyPrint config mode' m comments)+          (prettyPrint config m comments)         ParseFailed _ e -> Left e      unlines' = S.concat . intersperse "\n"@@ -160,44 +163,38 @@  -- | Print the module. prettyPrint :: Config-            -> ParseMode             -> Module SrcSpanInfo             -> [Comment]             -> Either a Builder-prettyPrint config mode' m comments =-  let (cs,ast) =-        annotateComments (fromMaybe m $ applyFixities baseFixities m) comments-      csComments = map comInfoComment cs-  in Right (runPrinterStyle-               config-               mode'--               -- For the time being, assume that all "free-floating" comments come at the beginning.-               -- If they were not at the beginning, they would be after some ast node.-               -- Thus, print them before going for the ast.-               (do mapM_ (printComment Nothing) csComments-                   pretty ast))+prettyPrint config m comments =+  let ast =+        evalState+          (collectAllComments+             (fromMaybe m (applyFixities baseFixities m)))+          comments+  in Right (runPrinterStyle config (pretty ast))  -- | Pretty print the given printable thing.-runPrinterStyle :: Config -> ParseMode -> Printer () -> Builder-runPrinterStyle config mode' m =-    maybe-        (error "Printer failed with mzero call.")-        psOutput-        (runIdentity-             (runMaybeT-                  (execStateT-                       (runPrinter m)-                       (PrintState-                            0-                            mempty-                            False-                            0-                            1-                            config-                            False-                            False-                            mode'))))+runPrinterStyle :: Config -> Printer () -> Builder+runPrinterStyle config m =+  maybe+    (error "Printer failed with mzero call.")+    psOutput+    (runIdentity+       (runMaybeT+          (execStateT+             (runPrinter m)+             (PrintState+              { psIndentLevel = 0+              , psOutput = mempty+              , psNewline = False+              , psColumn = 0+              , psLine = 1+              , psConfig = config+              , psInsideCase = False+              , psHardLimit = False+              , psEolComment = False+              }))))  -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode@@ -209,10 +206,15 @@         isDisabledExtention (DisableExtension _) = False         isDisabledExtention _ = True + -- | Test the given file. testFile :: FilePath -> IO () testFile fp  = S.readFile fp >>= test +-- | Test the given file.+testFileAst :: FilePath -> IO ()+testFileAst fp  = S.readFile fp >>= print . testAst+ -- | Test with the given style, prints to stdout. test :: ByteString -> IO () test =@@ -220,10 +222,17 @@   reformat defaultConfig Nothing  -- | Parse the source and annotate it with comments, yielding the resulting AST.-testAst :: ByteString -> Either String ([ComInfo], Module NodeInfo)+testAst :: ByteString -> Either String (Module NodeInfo) testAst x =   case parseModuleWithComments parseMode (UTF8.toString x) of-    ParseOk (m,comments) -> Right (annotateComments m comments)+    ParseOk (m,comments) ->+      Right+        (let ast =+               evalState+                 (collectAllComments+                    (fromMaybe m (applyFixities baseFixities m)))+                 comments+         in ast)     ParseFailed _ e -> Left e  -- | Default extensions.@@ -268,6 +277,129 @@ -- | Parse an extension. readExtension :: String -> Maybe Extension readExtension x =-  case classifyExtension x of+  case classifyExtension x -- Foo+       of     UnknownExtension _ -> Nothing     x' -> Just x'++--------------------------------------------------------------------------------+-- Comments++-- | Traverse the structure backwards.+traverseInOrder+  :: (Monad m, Traversable t, Functor m)+  => (b -> b -> Ordering) -> (b -> m b) -> t b -> m (t b)+traverseInOrder cmp f ast = do+  indexed <-+    fmap (zip [0 :: Integer ..] . reverse) (execStateT (traverse (modify . (:)) ast) [])+  let sorted = sortBy (\(_,x) (_,y) -> cmp x y) indexed+  results <-+    mapM+      (\(i,m) -> do+         v <- f m+         return (i, v))+      sorted+  evalStateT+    (traverse+       (const+          (do i <- gets head+              modify tail+              case lookup i results of+                Nothing -> error "traverseInOrder"+                Just x -> return x))+       ast)+    [0 ..]++-- | Collect all comments in the module by traversing the tree. Read+-- this from bottom to top.+collectAllComments :: Module SrcSpanInfo -> State [Comment] (Module NodeInfo)+collectAllComments =+    shortCircuit+        (traverseBackwards+         -- Finally, collect backwards comments which come after each node.+             (collectCommentsBy+                  (<>)+                  CommentAfterLine+                  (\nodeSpan commentSpan ->+                        fst (srcSpanStart commentSpan) >=+                        fst (srcSpanEnd nodeSpan)))) <=<+    shortCircuit+        (traverse+         -- Collect forwards comments which start at the end line of a node.+             (collectCommentsBy+                  (<>)+                  CommentSameLine+                  (\nodeSpan commentSpan ->+                        fst (srcSpanStart commentSpan) ==+                        fst (srcSpanEnd nodeSpan)))) <=<+    shortCircuit+        (traverseBackwards+         -- Collect backwards comments which are on the same line as a node.+             (collectCommentsBy+                  (<>)+                  CommentSameLine+                  (\nodeSpan commentSpan ->+                        fst (srcSpanStart commentSpan) ==+                        fst (srcSpanStart nodeSpan) &&+                        fst (srcSpanStart commentSpan) ==+                        fst (srcSpanEnd nodeSpan)))) <=<+    shortCircuit+        (traverse+         -- First, collect forwards comments for declarations which both+         -- start on column 1 and occur before the declaration.+             (collectCommentsBy+                  (<>)+                  CommentBeforeLine+                  (\nodeSpan commentSpan ->+                        (snd (srcSpanStart nodeSpan) == 1 &&+                         snd (srcSpanStart commentSpan) == 1) &&+                        fst (srcSpanStart commentSpan) <+                        fst (srcSpanStart nodeSpan)))) .+    fmap nodify+  where+    nodify s = NodeInfo s mempty+    -- Sort the comments by their end position.+    traverseBackwards =+        traverseInOrder+            (\x y ->+                  on+                      (flip compare)+                      (srcSpanEnd . srcInfoSpan . nodeInfoSpan)+                      x+                      y)+    -- Stop traversing if all comments have been consumed.+    shortCircuit m v = do+        comments <- get+        if null comments+            then return v+            else m v++-- | Collect comments by satisfying the given predicate, to collect a+-- comment means to remove it from the pool of available comments in+-- the State. This allows for a multiple pass approach.+collectCommentsBy+  :: ([NodeComment] -> [NodeComment] -> [NodeComment])+  -> (String -> NodeComment)+  -> (SrcSpan -> SrcSpan -> Bool)+  -> NodeInfo+  -> State [Comment] NodeInfo+collectCommentsBy append cons predicate nodeInfo@(NodeInfo (SrcSpanInfo nodeSpan _) _) = do+  comments <- get+  let (others,mine) =+        partitionEithers+          (map+             (\comment@(Comment _ commentSpan commentString) ->+                 if predicate nodeSpan (setFilename commentString commentSpan)+                   then Right (cons commentString)+                   else Left comment)+             comments)+  put others+  return+    (nodeInfo+     { nodeInfoComments = append (nodeInfoComments nodeInfo) mine+     })+  where+    setFilename cs sp =+      sp+      { srcSpanFilename = cs+      }

@@ -1,120 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-}---- | Comment handling.--module HIndent.Comments where--import           Control.Arrow (first, second)-import           Control.Monad.State.Strict-import           Data.Data-import qualified Data.Foldable-import qualified Data.Map.Strict as M-import           Data.Monoid-import           Data.Traversable-import           HIndent.Types-import           Language.Haskell.Exts hiding (Style,prettyPrint,Pretty,style,parse)-import           Prelude---- 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,Show (ast NodeInfo))-                 => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo)-annotateComments src comments =-  evalState (do _ <- traverse assignComment comments-                cis <- gets fst-                ast <- traverse transferComments src-                return (cis,ast))-            ([],nodeinfos)-  where-    nodeinfos :: M.Map SrcSpanInfo NodeInfo-    nodeinfos = Data.Foldable.foldr (\ssi -> M.insert ssi (NodeInfo ssi [])) M.empty 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)--        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--                       -- 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--        aligned :: Comment -> Comment -> Bool-        aligned (Comment _ before _) (Comment _ after _) =-          srcSpanEndLine before == srcSpanStartLine after - 1 &&-          srcSpanStartColumn before == srcSpanStartColumn after--        insertComment :: ComInfoLocation -> SrcSpanInfo -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) ()-        insertComment l ssi = modify $ second $ M.adjust (addComment (ComInfo comment (Just l))) ssi--        addComment :: ComInfo -> NodeInfo -> NodeInfo-        addComment x (NodeInfo s xs) = NodeInfo s (x : xs)--    -- 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 }--    nodeBefore (Comment _ ss _) = fmap snd $ (OrderByEnd ss) `M.lookupLT` spansByEnd-    nodeAfter (Comment _ ss _) = fmap snd $ (OrderByStart ss) `M.lookupGT` spansByStart--    spansByStart = Data.Foldable.foldr (\ssi -> M.insert (OrderByStart $ srcInfoSpan ssi) ssi) M.empty src-    spansByEnd = Data.Foldable.foldr (\ssi -> M.insert (OrderByEnd $ srcInfoSpan ssi) ssi) M.empty src

@@ -9,55 +9,10 @@ -- | Pretty printing.  module HIndent.Pretty-  (-  -- * Printing-    Pretty-  , pretty-  , prettyNoExt-  -- * Insertion-  , write-  , newline-  , space-  , comma-  , int-  , string-  -- * Common node types-  , withCtx-  , printComment-  , printComments-  , withCaseContext-  , rhsSeparator-  -- * Interspersing-  , inter-  , spaced-  , lined-  , prefixedLined-  , commas-  -- * Wrapping-  , parens-  , brackets-  , braces-  -- * Indentation-  , indented-  , indentedBlock-  , column-  , getColumn-  , getLineNum-  , depend-  , dependBind-  , swing-  , swingBy-  , getIndentSpaces-  , getColumnLimit-  -- * Predicates-  , nullBinds-  -- * Sandboxing-  , sandbox-  -- * Fallback-  , pretty'-  )+  (pretty)   where +import           Control.Applicative import           Control.Monad.State.Strict hiding (state) import qualified Data.ByteString.Builder as S import qualified Data.Foldable@@ -69,7 +24,6 @@ import           Data.Typeable import           HIndent.Types import qualified Language.Haskell.Exts as P-import           Language.Haskell.Exts.Comments import           Language.Haskell.Exts.SrcLoc import           Language.Haskell.Exts.Syntax import           Prelude hiding (exp)@@ -81,71 +35,53 @@ class (Annotated ast,Typeable ast) => Pretty ast where   prettyInternal :: ast NodeInfo -> Printer () --- | Pretty print using extenders.-pretty :: (Pretty ast)+-- | Pretty print including comments.+pretty :: (Pretty ast,Show (ast NodeInfo))        => ast NodeInfo -> Printer () pretty a = do-    printComments Before a-    depend (prettyNoExt a) (printComments After a)---- | Run the basic printer for the given node without calling an--- extension hook for this node, but do allow extender hooks in child--- nodes. Also auto-inserts comments.-prettyNoExt :: (Pretty ast)-            => ast NodeInfo -> Printer ()-prettyNoExt = prettyInternal---- | Print comments of a node.-printComments :: (Pretty ast)-              => ComInfoLocation -> ast NodeInfo -> Printer ()-printComments loc' ast = do-  let correctLocation comment = comInfoLocation comment == Just loc'-      commentsWithLocation = filter correctLocation (nodeInfoComments info)-  comments <- return $ map comInfoComment commentsWithLocation--  forM_ comments $ \comment -> do-    -- Preceeding comments must have a newline before them.-    hasNewline <- gets psNewline-    when (not hasNewline && loc' == Before) newline--    printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment-  where info = ann ast---- | Pretty print a comment.-printComment :: MonadState (PrintState) m => Maybe SrcSpan -> Comment -> m ()-printComment mayNodespan (Comment inline cspan str) =-  do -- Insert proper amount of space before comment.-     -- This maintains alignment. This cannot force comments-     -- to go before the left-most possible indent (specified by depends).-     case mayNodespan of-       Just nodespan ->-         do let neededSpaces = srcSpanStartColumn cspan --                               max 1 (srcSpanEndColumn nodespan)-            replicateM_ neededSpaces space-       Nothing -> return ()--     if inline-        then do write "{-"-                string str-                write "-}"-                when (1 == srcSpanStartColumn cspan) $-                  modify (\s -> s {psEolComment = True})-        else do write "--"-                string str-                modify (\s ->-                          s {psEolComment = True})+  mapM_+    (\c' -> do+       case c' of+         CommentBeforeLine c -> do+           write ("--" ++ c)+           newline+         _ -> return ())+    comments+  prettyInternal a+  mapM_+    (\(i,c') -> do+       case c' of+         CommentSameLine c -> do+           write (" --" ++ c)+           modify+             (\s ->+                 s+                 { psEolComment = True+                 })+         CommentAfterLine c -> do+           when (i == 0) newline+           write ("--" ++ c)+           modify+             (\s ->+                 s+                 { psEolComment = True+                 })+         _ -> return ())+    (zip [0 :: Int ..] comments)+  where+    comments = nodeInfoComments (ann a)  -- | Pretty print using HSE's own printer. The 'P.Pretty' class here -- is HSE's.-pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo),MonadState (PrintState) m)-        => ast NodeInfo -> m ()+pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo))+        => ast NodeInfo -> Printer () pretty' = write . P.prettyPrint . fmap nodeInfoSpan  -------------------------------------------------------------------------------- -- * Combinators  -- | Increase indentation level by n spaces for the given printer.-indented :: MonadState (PrintState) m => Int64 -> m a -> m a+indented :: Int64 -> Printer a -> Printer a indented i p =   do level <- gets psIndentLevel      modify (\s -> s {psIndentLevel = level + i})@@ -153,38 +89,40 @@      modify (\s -> s {psIndentLevel = level})      return m -indentedBlock :: MonadState (PrintState) m => m a -> m a+indentedBlock :: Printer a -> Printer a indentedBlock p =   do indentSpaces <- getIndentSpaces      indented indentSpaces p  -- | Print all the printers separated by spaces.-spaced :: MonadState (PrintState) m => [m ()] -> m ()+spaced :: [Printer ()] -> Printer () spaced = inter space  -- | Print all the printers separated by commas.-commas :: MonadState (PrintState) m => [m ()] -> m ()-commas = inter comma+commas :: [Printer ()] -> Printer ()+commas = inter (do comma; space)  -- | Print all the printers separated by sep.-inter :: MonadState (PrintState) m => m () -> [m ()] -> m ()+inter :: Printer () -> [Printer ()] -> Printer () inter sep ps =-  foldr (\(i,p) next ->-           depend (do p-                      if i < length ps-                         then sep-                         else return ())-                  next)-        (return ())-        (zip [1 ..] ps)+  foldr+    (\(i,p) next ->+        depend+          (do p+              if i < length ps+                then sep+                else return ())+          next)+    (return ())+    (zip [1 ..] ps)  -- | Print all the printers separated by newlines.-lined :: MonadState (PrintState) m => [m ()] -> m ()+lined :: [Printer ()] -> Printer () lined ps = sequence_ (intersperse newline ps)  -- | Print all the printers separated newlines and optionally a line -- prefix.-prefixedLined :: MonadState (PrintState) m => String -> [m ()] -> m ()+prefixedLined :: String -> [Printer ()] -> Printer () prefixedLined pref ps' =   case ps' of     [] -> return ()@@ -200,7 +138,7 @@  -- | Set the (newline-) indent level to the given column for the given -- printer.-column :: MonadState (PrintState) m => Int64 -> m a -> m a+column :: Int64 -> Printer a -> Printer a column i p =   do level <- gets psIndentLevel      modify (\s -> s {psIndentLevel = i})@@ -208,23 +146,14 @@      modify (\s -> s {psIndentLevel = level})      return m --- | Get the current indent level.-getColumn :: MonadState (PrintState) m => m Int64-getColumn = gets psColumn---- | Get the current line number.-getLineNum :: MonadState (PrintState) m => m Int64-getLineNum = gets psLine- -- | Output a newline.-newline :: MonadState (PrintState) m => m ()+newline :: Printer () newline =   do write "\n"      modify (\s -> s {psNewline = True})  -- | Set the context to a case context, where RHS is printed with -> .-withCaseContext :: MonadState (PrintState) m-                => Bool -> m a -> m a+withCaseContext :: Bool -> Printer a -> Printer a withCaseContext bool pr =   do original <- gets psInsideCase      modify (\s -> s {psInsideCase = bool})@@ -233,8 +162,7 @@      return result  -- | Get the current RHS separator, either = or -> .-rhsSeparator :: MonadState (PrintState) m-             => m ()+rhsSeparator :: Printer () rhsSeparator =   do inCase <- gets psInsideCase      if inCase@@ -243,7 +171,7 @@  -- | Make the latter's indentation depend upon the end column of the -- former.-depend :: MonadState (PrintState) m => m () -> m b -> m b+depend :: Printer () -> Printer b -> Printer b depend maker dependent =   do state' <- get      maker@@ -253,20 +181,8 @@         then column col dependent         else dependent --- | Make the latter's indentation depend upon the end column of the--- former.-dependBind :: MonadState (PrintState) m => m a -> (a -> m b) -> m b-dependBind maker dependent =-  do state' <- get-     v <- maker-     st <- get-     col <- gets psColumn-     if psLine state' /= psLine st || psColumn state' /= psColumn st-        then column col (dependent v)-        else (dependent v)- -- | Wrap in parens.-parens :: MonadState (PrintState) m => m a -> m a+parens :: Printer a -> Printer a parens p =   depend (write "(")          (do v <- p@@ -274,7 +190,7 @@              return v)  -- | Wrap in braces.-braces :: MonadState (PrintState) m => m a -> m a+braces :: Printer a -> Printer a braces p =   depend (write "{")          (do v <- p@@ -282,7 +198,7 @@              return v)  -- | Wrap in brackets.-brackets :: MonadState (PrintState) m => m a -> m a+brackets :: Printer a -> Printer a brackets p =   depend (write "[")          (do v <- p@@ -290,31 +206,34 @@              return v)  -- | Write a space.-space :: MonadState (PrintState) m => m ()+space :: Printer () space = write " "  -- | Write a comma.-comma :: MonadState (PrintState) m => m ()+comma :: Printer () comma = write ","  -- | Write an integral.-int :: (MonadState (PrintState) m)-    => Integer -> m ()+int :: Integer -> Printer () int = write . show  -- | Write out a string, updating the current position information.-write :: MonadState (PrintState) m => String -> m ()+write :: String -> Printer () write x =   do eol <- gets psEolComment-     when (eol && x /= "\n") newline+     hardFail <- gets psHardLimit+     let addingNewline = eol && x /= "\n"+     when addingNewline newline      state <- get-     let clearEmpty =-           configClearEmptyLines (psConfig state)-         writingNewline = x == "\n"+     when+       hardFail+       (guard+          (additionalLines == 0 &&+           (psColumn state < configMaxColumns (psConfig state))))+     let writingNewline = x == "\n"          out :: String          out =-           if psNewline state &&-              not (clearEmpty && writingNewline)+           if psNewline state && not writingNewline               then (replicate (fromIntegral (psIndentLevel state))                                ' ') <>                    x@@ -322,8 +241,8 @@      modify (\s ->                s {psOutput = psOutput state <> S.stringUtf8 out                  ,psNewline = False-                 ,psEolComment = False                  ,psLine = psLine state + fromIntegral additionalLines+                 ,psEolComment= False                  ,psColumn =                     if additionalLines > 0                        then fromIntegral (length (concat (take 1 (reverse srclines))))@@ -333,23 +252,17 @@           length (filter (== '\n') x)  -- | Write a string.-string :: MonadState (PrintState) m => String -> m ()+string :: String -> Printer () string = write  -- | Indent spaces, e.g. 2.-getIndentSpaces :: MonadState (PrintState) m => m Int64+getIndentSpaces :: Printer Int64 getIndentSpaces =   gets (configIndentSpaces . psConfig) --- | Column limit, e.g. 80-getColumnLimit :: MonadState (PrintState) m => m Int64-getColumnLimit =-  gets (configMaxColumns . psConfig)- -- | Play with a printer and then restore the state to what it was -- before.-sandbox :: MonadState s m-        => m a -> m (a,s)+sandbox :: Printer a -> Printer (a,PrintState) sandbox p =   do orig <- get      a <- p@@ -357,13 +270,8 @@      put orig      return (a,new) --- | No binds?-nullBinds :: Binds NodeInfo -> Bool-nullBinds (BDecls _ x) = null x-nullBinds (IPBinds _ x) = null x- -- | Render a type with a context, or not.-withCtx :: (Pretty ast)+withCtx :: (Pretty ast,Show (ast NodeInfo))         => Maybe (ast NodeInfo) -> Printer b -> Printer b withCtx Nothing m = m withCtx (Just ctx) m =@@ -385,14 +293,14 @@ swing a b =   do orig <- gets psIndentLevel      a-     (fits,st) <- fitsOnOneLine (do space-                                    b)-     if fits-        then put st-        else do newline-                indentSpaces <- getIndentSpaces-                _ <- column (orig + indentSpaces) b-                return ()+     mst <- fitsOnOneLine (do space+                              b)+     case mst of+       Just st -> put st+       Nothing -> do newline+                     indentSpaces <- getIndentSpaces+                     _ <- column (orig + indentSpaces) b+                     return ()  -- | Swing the second printer below and indented with respect to the first by -- the specified amount.@@ -510,29 +418,28 @@ -- | Do after lambda should swing. exp (Lambda _ pats (Do l stmts)) =   do-     (fits,st) <--       fitsOnOneLine-         (do write "\\"-             spaced (map pretty pats)-             write " -> "-             pretty (Do l stmts))-     if fits-        then put st-        else swing (do write "\\"-                       spaced (map pretty pats)-                       write " -> do")-                    (lined (map pretty stmts))+     mst <-+          fitsOnOneLine+            (do write "\\"+                spaced (map pretty pats)+                write " -> "+                pretty (Do l stmts))+     case mst of+       Nothing -> swing (do write "\\"+                            spaced (map pretty pats)+                            write " -> do")+                         (lined (map pretty stmts))+       Just st -> put st -- | Space out tuples. exp (Tuple _ boxed exps) =   depend (write (case boxed of                    Unboxed -> "(#"                    Boxed -> "("))-         (do single <- isSingleLiner p-             underflow <- fmap not (isOverflow p)-             if single && underflow-                then p-                else prefixedLined ","-                                   (map (depend space . pretty) exps)+         (do mst <- fitsOnOneLine p+             case mst of+               Nothing -> prefixedLined ","+                                        (map (depend space . pretty) exps)+               Just st -> put st              write (case boxed of                       Unboxed -> "#)"                       Boxed -> ")"))@@ -571,32 +478,33 @@             _ ->               depend (write str)                      (pretty e)--- | App algorithm similar to ChrisDone algorithm, but with no--- parent-child alignment.-exp (App _ op a) =-  do (fits,st) <--       fitsOnOneLine (spaced (map pretty (f : args)))-     if fits-        then put st-        else do pretty f-                newline-                spaces <- getIndentSpaces-                indented spaces (lined (map pretty args))-  where (f,args) = flatten op [a]-        flatten :: Exp NodeInfo-                -> [Exp NodeInfo]-                -> (Exp NodeInfo,[Exp NodeInfo])-        flatten (App _ f' a') b =-          flatten f' (a' : b)-        flatten f' as = (f',as)+-- | Render on one line, or otherwise render the op with the arguments+-- listed line by line.+exp (App _ op arg) = do+  let flattened = flatten op ++ [arg]+  mst <- fitsOnOneLine (spaced (map pretty flattened))+  case mst of+    Nothing -> do+      let (f:args) = flattened+      pretty f+      newline+      spaces <- getIndentSpaces+      indented spaces (lined (map pretty args))+    Just st -> put st+  where+    flatten (App label' op' arg') = flatten op' ++ [amap (addComments label') arg']+    flatten x = [x]+    addComments n1 n2 =+      n2+      { nodeInfoComments = nub (nodeInfoComments n2 ++ nodeInfoComments n1)+      } -- | Space out commas in list. exp (List _ es) =-  do single <- isSingleLiner p-     underflow <- fmap not (isOverflow p)-     if single && underflow-        then p-        else brackets (prefixedLined ","-                                     (map (depend space . pretty) es))+  do mst <- fitsOnOneLine p+     case mst of+       Nothing -> brackets (prefixedLined ","+                                          (map (depend space . pretty) es))+       Just st -> put st   where p =           brackets (inter (write ", ")                           (map pretty es))@@ -701,20 +609,41 @@ exp (MultiIf _ alts) =   withCaseContext     True-    (depend (write "if ")-            (lined (map (\p ->-                           do write "| "-                              pretty p)-                        alts)))+    (depend+       (write "if ")+       (lined+          (map+             (\p -> do+                write "| "+                prettyG p)+             alts)))+  where+    prettyG (GuardedRhs _ stmts e) = do+      indented+        1+        (do (lined (map+                         (\(i,p) -> do+                            unless (i == 1)+                                   space+                            pretty p+                            unless (i == length stmts)+                                   (write ","))+                         (zip [1..] stmts))))+      swing (write " " >> rhsSeparator) (pretty e) exp (Lit _ lit) = prettyInternal lit+exp (Var _ q) = case q of+                  Special _ Cons{} -> parens (pretty q)+                  _ -> pretty q+exp (IPVar _ q) = pretty q+exp (Con _ q) = case q of+                  Special _ Cons{} -> parens (pretty q)+                  _ -> pretty q+ exp x@XTag{} = pretty' x exp x@XETag{} = pretty' x exp x@XPcdata{} = pretty' x exp x@XExpTag{} = pretty' x exp x@XChildTag{} = pretty' x-exp x@Var{} = pretty' x-exp x@IPVar{} = pretty' x-exp x@Con{} = pretty' x exp x@CorePragma{} = pretty' x exp x@SCCPragma{} = pretty' x exp x@GenPragma{} = pretty' x@@ -731,6 +660,9 @@   error "FIXME: No implementation for ParComp." exp (OverloadedLabel _ label) = string ('#' : label) +instance Pretty IPName where+ prettyInternal = pretty'+ instance Pretty Stmt where   prettyInternal =     stmt@@ -843,7 +775,7 @@  instance Pretty Deriving where   prettyInternal (Deriving _ heads) =-    do write "deriving"+    do write " deriving"        space        let heads' =              if length heads == 1@@ -955,17 +887,6 @@ instance Pretty GuardedRhs where   prettyInternal  =     guardedRhs-    {-case x of-      GuardedRhs _ stmts e ->-        do indented 1-                    (do prefixedLined-                          ","-                          (map (\p ->-                                  do space-                                     pretty p)-                               stmts))-           swing (write " " >> rhsSeparator >> write " ")-                 (pretty e)-}  instance Pretty InjectivityInfo where   prettyInternal x = pretty' x@@ -1088,23 +1009,6 @@                (do space                    pretty var) -instance Pretty SpecialCon where-  prettyInternal s =-    case s of-      UnitCon _ -> write "()"-      ListCon _ -> write "[]"-      FunCon _ -> write "->"-      TupleCon _ Boxed i ->-        string ("(" ++-                replicate (i - 1) ',' ++-                ")")-      TupleCon _ Unboxed i ->-        string ("(#" ++-                replicate (i - 1) ',' ++-                "#)")-      Cons _ -> write ":"-      UnboxedSingleCon _ -> write "(##)"- instance Pretty Overlap where   prettyInternal (Overlap _) = write "{-# OVERLAP #-}"   prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}"@@ -1121,23 +1025,24 @@   prettyInternal x =     case x of       Module _ mayModHead pragmas imps decls ->-        inter (do newline-                  newline)-              (mapMaybe (\(isNull,r) ->-                           if isNull-                              then Nothing-                              else Just r)-                        [(null pragmas,inter newline (map pretty pragmas))-                        ,(case mayModHead of-                            Nothing -> (True,return ())-                            Just modHead -> (False,pretty modHead))-                        ,(null imps,inter newline (map pretty imps))-                        ,(null decls-                         ,interOf newline-                                  (map (\case-                                          r@TypeSig{} -> (1,pretty r)-                                          r -> (2,pretty r))-                                       decls))])+        do inter (do newline+                     newline)+                 (mapMaybe (\(isNull,r) ->+                              if isNull+                                 then Nothing+                                 else Just r)+                           [(null pragmas,inter newline (map pretty pragmas))+                           ,(case mayModHead of+                               Nothing -> (True,return ())+                               Just modHead -> (False,pretty modHead))+                           ,(null imps,inter newline (map pretty imps))+                           ,(null decls+                            ,interOf newline+                                     (map (\case+                                             r@TypeSig{} -> (1,pretty r)+                                             r -> (2,pretty r))+                                          decls))])+           newline         where interOf i ((c,p):ps) =                 case ps of                   [] -> p@@ -1210,11 +1115,35 @@   prettyInternal x = pretty' x  instance Pretty Name where-  prettyInternal = pretty'+  prettyInternal = pretty' -- Var  instance Pretty QName where-  prettyInternal = pretty'+  prettyInternal =+    \case+      Qual _ m n -> do+        pretty m+        write "."+        pretty n+      UnQual _ n -> pretty n+      Special _ c -> pretty c +instance Pretty SpecialCon where+  prettyInternal s =+    case s of+      UnitCon _ -> write "()"+      ListCon _ -> write "[]"+      FunCon _ -> write "->"+      TupleCon _ Boxed i ->+        string ("(" +++                replicate (i - 1) ',' +++                ")")+      TupleCon _ Unboxed i ->+        string ("(#" +++                replicate (i - 1) ',' +++                "#)")+      Cons _ -> write ":"+      UnboxedSingleCon _ -> write "(##)"+ instance Pretty QOp where   prettyInternal = pretty' @@ -1263,7 +1192,7 @@                           (map pretty es))  instance Pretty ExportSpec where-  prettyInternal = pretty'+  prettyInternal x = string " " >> pretty' x  -- Do statements need to handle infix expression indentation specially because -- do x *@@ -1301,12 +1230,12 @@                 -> (Exp NodeInfo -> Printer ())                 -> Printer () dependOrNewline left right f =-  do (fits,st) <- fitsOnOneLine renderDependent-     if fits-        then put st-        else do left-                newline-                (f right)+  do msg <- fitsOnOneLine renderDependent+     case msg of+       Nothing -> do left+                     newline+                     (f right)+       Just st -> put st   where renderDependent = depend left (f right)  -- | Handle do and case specially and also space out guards more.@@ -1320,20 +1249,20 @@      swingBy indentation              (write "do")              (lined (map pretty dos))-rhs (UnGuardedRhs _ e) =-  do (fits,st) <--       fitsOnOneLine-         (do write " "-             rhsSeparator-             write " "-             pretty e)-     if fits-        then put st-        else swing (write " " >> rhsSeparator)-                    (pretty e)+rhs (UnGuardedRhs _ e) = do+  msg <-+    fitsOnOneLine+      (do write " "+          rhsSeparator+          write " "+          pretty e)+  case msg of+    Nothing -> swing (write " " >> rhsSeparator) (pretty e)+    Just st -> put st rhs (GuardedRhss _ gas) =   do newline-     indented 2+     n <- getIndentSpaces+     indented n               (lined (map (\p ->                              do write "|"                                 pretty p)@@ -1355,32 +1284,35 @@      write (if inCase then " -> " else " = ")      swing (write "do")             (lined (map pretty dos))-guardedRhs (GuardedRhs _ stmts e) =-  do (fits,st) <--       fitsOnOneLine-         (indented 1-                   (do prefixedLined-                         ","-                         (map (\p ->-                                 do space-                                    pretty p)-                              stmts)))-     put st-     if fits-        then do (fits',st') <--                  fitsOnOneLine-                    (do write " "-                        rhsSeparator-                        write " "-                        pretty e)-                if fits'-                   then put st'-                   else swingIt-        else swingIt-  where swingIt =-          swing (write " " >> rhsSeparator)-                 (pretty e)-+guardedRhs (GuardedRhs _ stmts e) = do+    mst <- fitsOnOneLine printStmts+    case mst of+      Just st -> do+        put st+        mst' <-+          fitsOnOneLine+            (do write " "+                rhsSeparator+                write " "+                pretty e)+        case mst' of+          Just st' -> put st'+          Nothing -> swingIt+      Nothing -> do+        printStmts+        swingIt+  where+    printStmts =+      indented+        1+        (do prefixedLined+              ","+              (map+                 (\p -> do+                    space+                    pretty p)+                 stmts))+    swingIt = swing (write " " >> rhsSeparator) (pretty e)  match :: Match NodeInfo -> Printer () match (Match _ name pats rhs' mbinds) =@@ -1404,13 +1336,13 @@ -- | Format contexts with spaces and commas between class constraints. context :: Context NodeInfo -> Printer () context ctx@(CxTuple _ asserts) =-  do (fits,st) <--       fitsOnOneLine-         (parens (inter (comma >> space)-                        (map pretty asserts)))-     if fits-        then put st-        else prettyNoExt ctx+  do mst <-+          fitsOnOneLine+            (parens (inter (comma >> space)+                           (map pretty asserts)))+     case mst of+       Nothing -> prettyInternal ctx+       Just st -> put st context ctx = case ctx of                 CxSingle _ a -> pretty a                 CxTuple _ as ->@@ -1418,7 +1350,7 @@                                         (map pretty as))                 CxEmpty _ -> parens (return ()) -unboxParens :: MonadState (PrintState) m => m a -> m a+unboxParens :: Printer a -> Printer a unboxParens p =   depend (write "(# ")          (do v <- p@@ -1497,19 +1429,20 @@ --     -> IO () -- decl' (TypeSig _ names ty') =-  do small <- isSmall (declTy ty')-     if small-        then depend (do inter (write ", ")-                              (map pretty names)-                        write " :: ")-                    (declTy ty')-        else do inter (write ", ")-                      (map pretty names)-                newline-                indentSpaces <- getIndentSpaces-                indented indentSpaces-                         (depend (write ":: ")-                                 (declTy ty'))+  do mst <- fitsOnOneLine (declTy ty')+     case mst of+       Just{} -> depend (do inter (write ", ")+                                  (map pretty names)+                            write " :: ")+                          (declTy ty')+       Nothing -> do inter (write ", ")+                           (map pretty names)+                     newline+                     indentSpaces <- getIndentSpaces+                     indented indentSpaces+                              (depend (write ":: ")+                                      (declTy ty'))+   where declTy dty =           case dty of             TyForall _ mbinds mctx ty ->@@ -1532,14 +1465,14 @@         collapseFaps (TyFun _ arg result) = arg : collapseFaps result         collapseFaps e = [e]         prettyTy ty =-          do small <- isSmall (pretty ty)-             if small-                then pretty ty-                else case collapseFaps ty of-                       [] -> pretty ty-                       tys ->-                         prefixedLined "-> "-                                       (map pretty tys)+          do mst <- fitsOnOneLine (pretty ty)+             case mst of+               Nothing -> case collapseFaps ty of+                            [] -> pretty ty+                            tys ->+                              prefixedLined "-> "+                                            (map pretty tys)+               Just st -> put st decl' (PatBind _ pat rhs' mbinds) =   withCaseContext False $     do pretty pat@@ -1586,13 +1519,13 @@ conDecl x = case x of               ConDecl _ name bangty ->                 depend (do pretty name-                           space)+                           unless (null bangty) space)                        (lined (map pretty bangty))               InfixConDecl l a f b ->                 pretty (ConDecl l f [a,b])               RecDecl _ name fields ->                 depend (do pretty name-                           write " ")+                           space)                        (do depend (write "{")                                   (prefixedLined ","                                                  (map pretty fields))@@ -1611,8 +1544,8 @@                        (prefixedLined ","                                       (map (depend space . pretty) fields))                 newline-                write "} ")-recDecl r = prettyNoExt r+                write "}")+recDecl r = prettyInternal r  recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer () recUpdateExpr expWriter updates = do@@ -1637,33 +1570,16 @@ isRecord _ = False  -- | Does printing the given thing overflow column limit? (e.g. 80)-isOverflow :: MonadState (PrintState) m => m a -> m Bool-isOverflow p =-  do (_,st) <- sandbox p-     columnLimit <- getColumnLimit-     return (psColumn st > columnLimit)---- | Does printing the given thing overflow column limit? (e.g. 80)-fitsOnOneLine :: MonadState (PrintState) m => m a -> m (Bool,PrintState)+fitsOnOneLine :: Printer a -> Printer (Maybe PrintState) fitsOnOneLine p =-  do line <- gets psLine-     (_,st) <- sandbox p-     columnLimit <- getColumnLimit-     return (psLine st == line && psColumn st < columnLimit,st)---- | Is the given expression a single-liner when printed?-isSingleLiner :: MonadState (PrintState) m-              => m a -> m Bool-isSingleLiner p =-  do line <- gets psLine-     (_,st) <- sandbox p-     return (psLine st == line)--isSmall :: MonadState PrintState m => m a -> m Bool-isSmall p =-  do overflows <- isOverflow p-     oneLine <- isSingleLiner p-     return (not overflows && oneLine)+  do st <- get+     put st { psHardLimit = True}+     ok <- fmap (const True) p <|> return False+     st' <- get+     put st+     return (if ok+                then Just st' { psHardLimit = psHardLimit st }+                else Nothing)  bindingGroup :: Binds NodeInfo -> Printer () bindingGroup binds =@@ -1680,25 +1596,25 @@          -> Maybe Int64          -> Printer () infixApp e a op b indent =-  do (fits,st) <--       fitsOnOneLine-         (spaced (map (\link ->-                         case link of-                           OpChainExp e' -> pretty e'-                           OpChainLink qop -> pretty qop)-                      (flattenOpChain e)))-     if fits-        then put st-        else do prettyWithIndent a-                space-                pretty op-                newline-                case indent of-                  Nothing -> prettyWithIndent b-                  Just col ->-                    do indentSpaces <- getIndentSpaces-                       column (col + indentSpaces)-                              (prettyWithIndent b)+  do msg <-+          fitsOnOneLine+            (spaced (map (\link ->+                            case link of+                              OpChainExp e' -> pretty e'+                              OpChainLink qop -> pretty qop)+                         (flattenOpChain e)))+     case msg of+       Nothing -> do prettyWithIndent a+                     space+                     pretty op+                     newline+                     case indent of+                       Nothing -> prettyWithIndent b+                       Just col ->+                         do indentSpaces <- getIndentSpaces+                            column (col + indentSpaces)+                                   (prettyWithIndent b)+       Just st -> put st   where prettyWithIndent e' =           case e' of             (InfixApp _ a' op' b') ->

@@ -13,20 +13,16 @@   ,Config(..)   ,defaultConfig   ,NodeInfo(..)-  ,ComInfo(..)-  ,ComInfoLocation(..)+  ,NodeComment(..)   ) where  import Control.Applicative import Control.Monad import Control.Monad.State.Strict (MonadState(..),StateT) import Control.Monad.Trans.Maybe-import Data.Data+import Data.ByteString.Builder import Data.Functor.Identity import Data.Int (Int64)-import Data.ByteString.Builder-import Language.Haskell.Exts.Comments-import Language.Haskell.Exts.Parser import Language.Haskell.Exts.SrcLoc  -- | A pretty printing monad.@@ -35,47 +31,52 @@   deriving (Applicative,Monad,Functor,MonadState PrintState,MonadPlus,Alternative)  -- | The state of the pretty printer.-data PrintState =-  PrintState {psIndentLevel :: !Int64 -- ^ Current indentation level.-             ,psOutput :: !Builder -- ^ The current output.-             ,psNewline :: !Bool -- ^ Just outputted a newline?-             ,psColumn :: !Int64 -- ^ Current column.-             ,psLine :: !Int64 -- ^ Current line number.-             ,psConfig :: !Config -- ^ Config which styles may or may not pay attention to.-             ,psEolComment :: !Bool -- ^ An end of line comment has just been outputted.-             ,psInsideCase :: !Bool -- ^ Whether we're in a case statement, used for Rhs printing.-             ,psParseMode :: !ParseMode -- ^ Mode used to parse the original AST.-             }+data PrintState = PrintState+  { psIndentLevel :: !Int64+    -- ^ Current indentation level, i.e. every time there's a+    -- new-line, output this many spaces.+  , psOutput :: !Builder+    -- ^ The current output bytestring builder.+  , psNewline :: !Bool+    -- ^ Just outputted a newline?+  , psColumn :: !Int64+    -- ^ Current column.+  , psLine :: !Int64+    -- ^ Current line number.+  , psConfig :: !Config+    -- ^ Configuration of max colums and indentation style.+  , psInsideCase :: !Bool+    -- ^ Whether we're in a case statement, used for Rhs printing.+  , psHardLimit :: !Bool+    -- ^ Bail out if we exceed current column.+  , psEolComment :: !Bool+  }  -- | Configurations shared among the different styles. Styles may pay -- attention to or completely disregard this configuration. data Config =   Config {configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally.          ,configIndentSpaces :: !Int64 -- ^ How many spaces to indent?-         ,configClearEmptyLines :: !Bool  -- ^ Remove spaces on lines that are otherwise empty?          }  -- | Default style configuration. defaultConfig :: Config defaultConfig =   Config {configMaxColumns = 80-         ,configIndentSpaces = 2-         ,configClearEmptyLines = False}---- | Information for each node in the AST.-data NodeInfo =-  NodeInfo {nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.-           ,nodeInfoComments :: ![ComInfo] -- ^ Comments which are attached to this node.-           }-  deriving (Typeable,Show,Data)+         ,configIndentSpaces = 4} --- | Comment relative locations.-data ComInfoLocation = Before | After-  deriving (Show,Typeable,Data,Eq)+data NodeComment+  = CommentSameLine String+  | CommentAfterLine String+  | CommentBeforeLine String+  deriving (Show,Ord,Eq) --- | Comment with some more info.-data ComInfo =-  ComInfo {comInfoComment :: !Comment                -- ^ The normal comment type.-          ,comInfoLocation :: !(Maybe ComInfoLocation) -- ^ Where the comment lies relative to the node.-          }-  deriving (Show,Typeable,Data)+-- | Information for each node in the AST.+data NodeInfo = NodeInfo+  { nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.+  , nodeInfoComments :: ![NodeComment] -- ^ Comment attached to this node.+  }+instance Show NodeInfo where+  show (NodeInfo _ []) = ""+  show (NodeInfo _ s) =+    "{- " ++ show s ++ " -}"

@@ -9,26 +9,27 @@  module Main where -import           HIndent-import           HIndent.Types+import           Control.Applicative+import           Control.Exception import qualified Data.ByteString as S import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Lazy.Char8 as L8-import           Control.Applicative+import           Data.Maybe import           Data.Text (Text) import qualified Data.Text as T import           Data.Version (showVersion) import           Descriptive import           Descriptive.Options+import           Foreign.C.Error+import           GHC.IO.Exception+import           HIndent+import           HIndent.Types import           Language.Haskell.Exts hiding (Style,style) import           Paths_hindent (version) import           System.Directory import           System.Environment import           System.IO import           Text.Read-import           Control.Exception-import           GHC.IO.Exception-import           Foreign.C.Error  -- | Main entry point. main :: IO ()@@ -93,17 +94,19 @@             (optional                  (constant "--style" "Style to print with" () *>                   anyString "STYLE")) <*>-        lineLen+        lineLen <*> tabsize     exts = fmap getExtensions (many (prefix "X" "Language extension"))+    tabsize =+        fmap+            (>>= (readMaybe . T.unpack))+            (optional (arg "tab-size" "Tab size, default: 4"))     lineLen =         fmap             (>>= (readMaybe . T.unpack))             (optional (arg "line-length" "Desired length of lines"))-    makeStyle s mlen =-        case mlen of-            Nothing -> s-            Just len ->-                s-                { configMaxColumns = len-                }+    makeStyle s mlen tabs =+        s+        { configMaxColumns = fromMaybe (configMaxColumns s) mlen+        , configIndentSpaces = fromMaybe (configIndentSpaces s) tabs+        }     file = fmap (fmap T.unpack) (optional (anyString "[<filename>]"))

@@ -4,6 +4,8 @@  module Main where +import           Data.Algorithm.Diff+import           Data.Algorithm.DiffOutput import qualified Data.ByteString as S import           Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L@@ -11,6 +13,7 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.UTF8 as LUTF8 import qualified Data.ByteString.UTF8 as UTF8+import           Data.Function import           Data.Monoid import           HIndent import           HIndent.Types@@ -54,9 +57,23 @@ -- | Version of 'shouldBe' that prints strings in a readable way, -- better for our use-case. shouldBeReadable :: ByteString -> ByteString -> Expectation-shouldBeReadable x y = shouldBe (Readable x) (Readable y)+shouldBeReadable x y = shouldBe (Readable x (Just (diff y x))) (Readable y Nothing)  -- | Prints a string without quoting and escaping.-newtype Readable = Readable ByteString deriving (Eq)+data Readable = Readable+  { readableString :: ByteString+  , readableDiff :: (Maybe String)+  }+instance Eq Readable where+  (==) = on (==) readableString instance Show Readable where-  show (Readable x) = "\n" ++ LUTF8.toString x+  show (Readable x d') =+    "\n" +++    LUTF8.toString x +++    (case d' of+       Just d -> "\nThe diff:\n" ++ d+       Nothing -> "")++-- | A diff display.+diff :: ByteString -> ByteString -> String+diff x y = ppDiff (on (getGroupedDiff) (lines . LUTF8.toString) x y)