hindent 5.0.0 → 5.0.1

raw patch · 32 files changed

+1451/−1467 lines, 32 filesdep +bytestringdep +exceptionsdep +utf8-stringdep ~basedep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, exceptions, utf8-string

Dependency ranges changed: base, mtl

API changes (from Hackage documentation)

Files

• BENCHMARKS.md +90/−0
• CHANGELOG.md +35/−0
• LICENSE +0/−24
• LICENSE.md +28/−0
• TESTS.md +198/−0
• benchmarks/BigDeclarations.hs +0/−17
• hindent.cabal +27/−23
• src/HIndent.hs +143/−112
• src/HIndent/Comments.hs +12/−10
• src/HIndent/Pretty.hs +685/−308
• src/HIndent/Styles/JohanTibell.hs +0/−586
• src/HIndent/Types.hs +5/−29
• src/main/Benchmark.hs +34/−20
• src/main/Main.hs +19/−44
• src/main/Markdone.hs +113/−0
• src/main/Test.hs +62/−0
• src/main/TestGenerate.hs +0/−90
• test/Spec.hs +0/−92
• test/johan-tibell/expected/1.exp +0/−6
• test/johan-tibell/expected/2.exp +0/−6
• test/johan-tibell/expected/3.exp +0/−6
• test/johan-tibell/expected/4.exp +0/−7
• test/johan-tibell/expected/5.exp +0/−9
• test/johan-tibell/expected/6.exp +0/−21
• test/johan-tibell/expected/7.exp +0/−8
• test/johan-tibell/tests/1.test +0/−6
• test/johan-tibell/tests/2.test +0/−5
• test/johan-tibell/tests/3.test +0/−6
• test/johan-tibell/tests/4.test +0/−7
• test/johan-tibell/tests/5.test +0/−7
• test/johan-tibell/tests/6.test +0/−15
• test/johan-tibell/tests/7.test +0/−3

@@ -0,0 +1,90 @@+# Large inputs++Bunch of declarations++``` 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+    -- 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+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++``` 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)))|]))]+```

@@ -0,0 +1,35 @@+5.0.1:+    * Re-implement using bytestring instead of text+    * Made compatible with GHC 7.8 through to GHC 8.0+    * Added test suite and benchmarks in TESTS.md and BENCHMARKS.md++5.0.0:+	* Drop support for styles++4.6.4++	* Copy/delete file instead of renaming++4.4.6++	* Fix whole module printer+	* Accept a filename to reformat++4.4.5++	* Fix bug in infix patterns++4.4.2++	* Bunch of Gibiansky style fixes.+	* Support CPP.+	* Tibell style fixes.++4.3.8++	* Fixed: bug in printing operators in statements.++4.5.4++	* Improvements to Tibell style.+	* 6x speed up on rendering operators.

@@ -1,24 +0,0 @@-Copyright (c) 2014, hindent-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.-    * Redistributions in binary form must reproduce the above copyright-      notice, this list of conditions and the following disclaimer in the-      documentation and/or other materials provided with the distribution.-    * Neither the name of hindent nor the-      names of its contributors may be used to endorse or promote products-      derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,28 @@+Copyright (c) 2014, Chris Done++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++* Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+* Neither the name of hindent nor the names of its contributors may be+ used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL CHRIS DONE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,198 @@+# Introduction++This file is a test suite. Each section maps to an HSpec test, and+each line that is followed by a Haskell code fence is tested to make+sure re-formatting that code snippet produces the same result.++You can browse through this document to see what HIndent's style is+like, or contribute additional sections to it, or regression tests.++# Modules++Module header++``` haskell+module X where+```++Exports++``` haskell+module X+  (x+  ,y+  ,Z+  ,P(x, z))+  where+```++## Imports++Import lists++``` haskell+import Data.Text+import Data.Text+import qualified Data.Text as T+import qualified Data.Text (a, b, c)+import Data.Text (a, b, c)+import Data.Text hiding (a, b, c)+```++# Declarations++Type declaration++``` haskell+type EventSource a = (AddHandler a, a -> IO ())+```++# Expressions++Lazy patterns in a lambda++``` haskell+f = \ ~a -> undefined -- \~a yields parse error on input ‘\~’+```++Bang patterns in a lambda++``` haskell+f = \ !a -> undefined -- \!a yields parse error on input ‘\!’+```++List comprehensions++``` haskell+defaultExtensions =+  [ e+  | e@EnableExtension {} <- knownExtensions ] \\+  map EnableExtension badExtensions+```++Record indentation++``` haskell+getGitProvider :: EventProvider GitRecord ()+getGitProvider =+  EventProvider+  { getModuleName = "Git"+  , getEvents = getRepoCommits+  }+```++Records again++``` haskell+commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event+commitToEvent gitFolderPath timezone commit =+  Event.Event+  { pluginName = getModuleName getGitProvider+  , eventIcon = "glyphicon-cog"+  , eventDate = localTimeToUTC timezone (commitDate commit)+  }+```++Cases++``` haskell+strToMonth :: String -> Int+strToMonth month =+  case month of+    "Jan" -> 1+    "Feb" -> 2+    _ -> error $ "Unknown month " ++ month+```++Operators++``` haskell+x =+  Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>+  Just thisissolong <*>+  Just stilllonger+```++# Type signatures++Class constraints++``` haskell+fun+  :: (Class a, Class b)+  => a -> b -> c+```++Tuples++``` haskell+fun :: (a, b, c) -> (a, b)+```++# Function declarations++Where clause++``` haskell+sayHello :: IO ()+sayHello = do+  name <- getLine+  putStrLn $ greeting name+  where+    greeting name = "Hello, " ++ name ++ "!"+```++Guards and pattern guards++``` haskell+f :: Int+f x+  | x <- Just x+  , x <- Just x =+    case x of+      Just x -> e+  | otherwise = do e+  where+    x = y+```++Case inside a `where` and `do`++``` haskell+g x =+  case x of+    a -> x+  where+    foo =+      case x of+        _ -> do+          launchMissiles+      where+        y = 2+```++Let inside a `where`++``` haskell+g x =+  let x = 1+  in x+  where+    foo =+      let y = 2+          z = 3+      in y+```++# Behaviour checks++Unicode++``` haskell+α = γ * "ω" -- υ+```++Empty module++``` haskell+```

@@ -1,17 +0,0 @@-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)))|]))]

@@ -1,25 +1,26 @@ name:                hindent-version:             5.0.0+version:             5.0.1 synopsis:            Extensible Haskell pretty printer description:         Extensible Haskell pretty printer. Both a library and an executable.                      .                      See the Github page for usage\/explanation: <https://github.com/chrisdone/hindent> license:             BSD3 stability:           Unstable-license-file:        LICENSE+license-file:        LICENSE.md author:              Chris Done, Andrew Gibiansky, Tobias Pflug, Pierre Radermecker maintainer:          chrisdone@gmail.com-copyright:           2014 Chris Done+copyright:           2014 Chris Done, 2015 Andrew Gibiansky category:            Development build-type:          Simple cabal-version:       >=1.8 homepage: http://www.github.com/chrisdone/hindent bug-reports: https://github.com/chrisdone/hindent/issues data-files:          elisp/hindent.el-extra-source-files:  README.md-                     benchmarks/BigDeclarations.hs-                     test/johan-tibell/expected/*.exp-                     test/johan-tibell/tests/*.test+extra-source-files:+ README.md+ CHANGELOG.md+ BENCHMARKS.md+ TESTS.md  source-repository head     type:           git@@ -32,14 +33,16 @@                      HIndent.Types                      HIndent.Pretty                      HIndent.Comments-                     HIndent.Styles.JohanTibell   build-depends:     base >= 4.7 && <5                    , containers                    , haskell-src-exts >= 1.18                    , monad-loops                    , mtl-                   , text+                   , bytestring+                   , utf8-string                    , transformers+                   , exceptions+                   , text  executable hindent   hs-source-dirs:    src/main@@ -47,44 +50,45 @@   main-is:           Main.hs   build-depends:     base >= 4 && < 5                    , hindent-                   , text+                   , bytestring+                   , utf8-string                    , descriptive >= 0.7 && < 0.10                    , haskell-src-exts                    , ghc-prim                    , directory--executable hindent-generate-tests-  hs-source-dirs:    src/main-  ghc-options:       -Wall -O2-  main-is:           TestGenerate.hs-  build-depends:     base >= 4 && < 5-                   , hindent                    , text-                   , directory -test-suite hspec+test-suite hindent-test   type: exitcode-stdio-1.0-  hs-source-dirs: test-  main-is: Spec.hs+  hs-source-dirs: src/main/+  main-is: Test.hs+  other-modules: Markdone   build-depends:     base >= 4 && <5                    , hindent                    , haskell-src-exts                    , monad-loops                    , mtl-                   , text+                   , bytestring+                   , utf8-string                    , hspec                    , directory+                   , deepseq+                   , exceptions+                   , utf8-string  benchmark hindent-bench   type: exitcode-stdio-1.0   hs-source-dirs:    src/main   ghc-options:       -Wall -O2 -rtsopts   main-is:           Benchmark.hs+  other-modules: Markdone   build-depends:     base >= 4 && < 5                    , hindent-                   , text+                   , bytestring+                   , utf8-string                    , haskell-src-exts                    , ghc-prim                    , directory                    , criterion                    , deepseq+                   , exceptions

@@ -1,5 +1,6 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables, PatternGuards #-}  -- | Haskell indenter. @@ -8,98 +9,100 @@    reformat   ,prettyPrint   ,parseMode-  -- * Style-  ,Style(..)-  ,johanTibell   -- * Testing   ,test   ,testFile-  ,testAll   ,testAst   ,defaultExtensions+  ,getExtensions   )   where -import           HIndent.Comments-import           HIndent.Pretty-import           HIndent.Styles.JohanTibell (johanTibell)-import           HIndent.Types--import           Control.Applicative ((<$>)) import           Control.Monad.State.Strict import           Control.Monad.Trans.Maybe+import           Data.ByteString (ByteString)+import qualified Data.ByteString as S+import           Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Lazy as L+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.Functor.Identity import           Data.List-import           Data.List (groupBy, intersperse)-import           Data.Maybe (fromMaybe)+import           Data.Maybe import           Data.Monoid-import qualified Data.Text.IO as ST-import           Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T hiding (singleton)-import           Data.Text.Lazy.Builder (Builder)-import qualified Data.Text.Lazy.Builder as T-import qualified Data.Text.Lazy.IO as T+import           Data.Text (Text)+import qualified Data.Text as T+import           HIndent.Comments+import           HIndent.Pretty+import           HIndent.Types import           Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse) -data CodeBlock = HaskellSource Text-               | CPPDirectives Text+data CodeBlock = HaskellSource ByteString+               | CPPDirectives ByteString   deriving (Show, Eq)  -- | Format the given source.-reformat :: Style -> Maybe [Extension] -> Text -> Either String Builder-reformat style mexts x =-  mconcat . intersperse "\n" <$> mapM processBlock (cppSplitBlocks x)+reformat :: Config -> Maybe [Extension] -> ByteString -> Either String Builder+reformat config mexts x =+  fmap (mconcat . intersperse "\n") (mapM processBlock (cppSplitBlocks x))   where     processBlock :: CodeBlock -> Either String Builder-    processBlock (CPPDirectives text) = Right $ T.fromLazyText text+    processBlock (CPPDirectives text) = Right $ S.byteString text     processBlock (HaskellSource text) =-      let lines = lines' text-          prefix = findPrefix lines-          code = T.unpack $ unlines' $ map (stripPrefix prefix) lines-      in case parseModuleWithComments mode' code of+      let ls = S8.lines text+          prefix = findPrefix ls+          code = unlines' (map (stripPrefix prefix) ls)+      in case parseModuleWithComments mode' (UTF8.toString code) of         ParseOk (m, comments) ->-          T.fromLazyText <$> addPrefix prefix <$> T.toLazyText <$> prettyPrint mode' style m comments+          fmap (S.lazyByteString .+          addPrefix prefix .+          S.toLazyByteString)+          (prettyPrint config mode' m comments)         ParseFailed _ e -> Left e -    lines' = T.split (== '\n')-    unlines' = mconcat . intersperse "\n"+    unlines' = S.concat . intersperse "\n"+    unlines'' = L.concat . intersperse "\n" -    addPrefix :: Text -> Text -> Text-    addPrefix prefix = unlines' . map (prefix <>) . lines'+    addPrefix :: ByteString -> L8.ByteString -> L8.ByteString+    addPrefix prefix = unlines'' . map (L8.fromStrict prefix <>) . L8.lines -    stripPrefix :: Text -> Text -> Text+    stripPrefix :: ByteString -> ByteString -> ByteString     stripPrefix prefix line =-      if T.null (T.dropWhile (== '\n') line)+      if S.null (S8.dropWhile (== '\n') line)       then line-      else fromMaybe (error "Missing expected prefix") . T.stripPrefix prefix $ line+      else fromMaybe (error "Missing expected prefix") . s8_stripPrefix prefix $ line -    findPrefix :: [Text] -> Text+    findPrefix :: [ByteString] -> ByteString     findPrefix = takePrefix False . findSmallestPrefix . dropNewlines -    dropNewlines :: [Text] -> [Text]-    dropNewlines = filter (not . T.null . T.dropWhile (== '\n'))+    dropNewlines :: [ByteString] -> [ByteString]+    dropNewlines = filter (not . S.null . S8.dropWhile (== '\n')) -    takePrefix :: Bool -> Text -> Text+    takePrefix :: Bool -> ByteString -> ByteString     takePrefix bracketUsed txt =-      case T.uncons txt of+      case S8.uncons txt of         Nothing -> ""         Just ('>', txt') -> if not bracketUsed-                              then T.cons '>' (takePrefix True txt')+                              then S8.cons '>' (takePrefix True txt')                               else ""         Just (c, txt') -> if c == ' ' || c == '\t'-                            then T.cons c (takePrefix bracketUsed txt')+                            then S8.cons c (takePrefix bracketUsed txt')                             else ""  -    findSmallestPrefix :: [Text] -> Text+    findSmallestPrefix :: [ByteString] -> ByteString     findSmallestPrefix [] = ""     findSmallestPrefix ("":_) = ""     findSmallestPrefix (p:ps) =-      let first = T.head p-          startsWithChar c x  = T.length x > 0 && T.head x == c+      let first = S8.head p+          startsWithChar c x  = S8.length x > 0 && S8.head x == c       in if all (startsWithChar first) ps-           then T.cons first (findSmallestPrefix (T.tail p : map T.tail ps))+           then S8.cons first (findSmallestPrefix (S.tail p : map S.tail ps))            else ""      mode' =@@ -120,67 +123,81 @@ -- > #endif -- -- will become five blocks, one for each CPP line and one for each pair of declarations.-cppSplitBlocks :: Text -> [CodeBlock]+cppSplitBlocks :: ByteString -> [CodeBlock] cppSplitBlocks inp =-  modifyLast (inBlock (`T.append` trailing)) .+  modifyLast (inBlock (<> trailing)) .   map (classify . mconcat . intersperse "\n") .-  groupBy ((==) `on` cppLine) .-  T.lines $ inp+  groupBy ((==) `on` cppLine) . S8.lines $+  inp   where-    cppLine :: Text -> Bool-    cppLine src = any (`T.isPrefixOf` src) ["#if", "#end", "#else", "#define", "#undef", "#elif"]--    classify :: Text -> CodeBlock-    classify text = if cppLine text-                    then CPPDirectives text-                    else HaskellSource text-+    cppLine :: ByteString -> Bool+    cppLine src =+      any+        (`S8.isPrefixOf` src)+        ["#if", "#end", "#else", "#define", "#undef", "#elif"]+    classify :: ByteString -> CodeBlock+    classify text =+      if cppLine text+        then CPPDirectives text+        else HaskellSource text     -- Hack to work around some parser issues in haskell-src-exts: Some pragmas     -- need to have a newline following them in order to parse properly, so we include     -- the trailing newline in the code block if it existed.-    trailing :: Text-    trailing = if T.isSuffixOf "\n" inp then "\n" else ""-+    trailing+      :: ByteString+    trailing =+      if S8.isSuffixOf "\n" inp+        then "\n"+        else ""     modifyLast :: (a -> a) -> [a] -> [a]-    modifyLast _ []  = []+    modifyLast _ [] = []     modifyLast f [x] = [f x]     modifyLast f (x:xs) = x : modifyLast f xs--    inBlock :: (Text -> Text) -> CodeBlock -> CodeBlock+    inBlock :: (ByteString -> ByteString) -> CodeBlock -> CodeBlock     inBlock f (HaskellSource txt) = HaskellSource (f txt)     inBlock _ dir = dir + -- | Print the module.-prettyPrint :: ParseMode-            -> Style+prettyPrint :: Config+            -> ParseMode             -> Module SrcSpanInfo             -> [Comment]             -> Either a Builder-prettyPrint mode' style m comments =+prettyPrint config mode' m comments =   let (cs,ast) =         annotateComments (fromMaybe m $ applyFixities baseFixities m) comments       csComments = map comInfoComment cs-  in case style of-      style@(Style { styleCommentPreprocessor = preprocessor }) ->-        Right (runPrinterStyle-                  mode'-                  style-                  -- 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 comments <- preprocessor (reverse csComments)-                      mapM_ (printComment Nothing) comments-                      pretty ast))+  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))+ -- | Pretty print the given printable thing.-runPrinterStyle :: ParseMode -> Style -> (forall s. Printer s ()) -> Builder-runPrinterStyle mode' (Style _name _author _desc st extenders config preprocessor) m =-  maybe (error "Printer failed with mzero call.")+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 st extenders config False False mode' preprocessor))))+             (runMaybeT+                  (execStateT+                       (runPrinter m)+                       (PrintState+                            0+                            mempty+                            False+                            0+                            1+                            config+                            False+                            False+                            mode'))))  -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode@@ -193,42 +210,27 @@         isDisabledExtention _ = True  -- | Test the given file.-testFile :: FilePath -> Style -> IO ()-testFile fp style = T.readFile fp >>= test style+testFile :: FilePath -> IO ()+testFile fp  = S.readFile fp >>= test  -- | Test with the given style, prints to stdout.-test :: Style -> Text -> IO ()-test style =-  either error (T.putStrLn . T.toLazyText) .-  reformat style Nothing---- | Test with all styles, prints to stdout.-testAll :: Text -> IO ()-testAll i =-  forM_ styles-        (\style ->-           do ST.putStrLn ("-- " <> styleName style <> ":")-              test style i-              ST.putStrLn "")+test :: ByteString -> IO ()+test =+  either error (L8.putStrLn . S.toLazyByteString) .+  reformat defaultConfig Nothing  -- | Parse the source and annotate it with comments, yielding the resulting AST.-testAst :: Text -> Either String ([ComInfo], Module NodeInfo)+testAst :: ByteString -> Either String ([ComInfo], Module NodeInfo) testAst x =-  case parseModuleWithComments parseMode-                               (T.unpack x) of-    ParseOk (m,comments) ->-      Right (annotateComments m comments)+  case parseModuleWithComments parseMode (UTF8.toString x) of+    ParseOk (m,comments) -> Right (annotateComments m comments)     ParseFailed _ e -> Left e --- | Styles list, useful for programmatically choosing.-styles :: [Style]-styles =-  [johanTibell]- -- | Default extensions. defaultExtensions :: [Extension] defaultExtensions =-  [e | e@EnableExtension{} <- knownExtensions] \\+  [ e+  | e@EnableExtension {} <- knownExtensions ] \\   map EnableExtension badExtensions  -- | Extensions which steal too much syntax.@@ -240,3 +242,32 @@     ,UnboxedTuples -- breaks (#) lens operator     -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break     ]+++s8_stripPrefix :: ByteString -> ByteString -> Maybe ByteString+s8_stripPrefix bs1@(S.PS _ _ l1) bs2+   | bs1 `S.isPrefixOf` bs2 = Just (S.unsafeDrop l1 bs2)+   | otherwise = Nothing++--------------------------------------------------------------------------------+-- Extensions stuff stolen from hlint++-- | Consume an extensions list from arguments.+getExtensions :: [Text] -> [Extension]+getExtensions = foldl f defaultExtensions . map T.unpack+  where f _ "Haskell98" = []+        f a ('N':'o':x)+          | Just x' <- readExtension x =+            delete x' a+        f a x+          | Just x' <- readExtension x =+            x' :+            delete x' a+        f _ x = error $ "Unknown extension: " ++ x++-- | Parse an extension.+readExtension :: String -> Maybe Extension+readExtension x =+  case classifyExtension x of+    UnknownExtension _ -> Nothing+    x' -> Just x'

@@ -5,14 +5,16 @@  module HIndent.Comments where -import Control.Applicative ((<|>))-import Control.Arrow (first, second)-import Control.Monad.State.Strict-import Data.Data+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.Traversable-import HIndent.Types-import Language.Haskell.Exts hiding (Style,prettyPrint,Pretty,style,parse)+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 =@@ -57,7 +59,7 @@             ([],nodeinfos)   where     nodeinfos :: M.Map SrcSpanInfo NodeInfo-    nodeinfos = foldr (\ssi -> M.insert ssi (NodeInfo ssi [])) M.empty src+    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) ()@@ -114,5 +116,5 @@     nodeBefore (Comment _ ss _) = fmap snd $ (OrderByEnd ss) `M.lookupLT` spansByEnd     nodeAfter (Comment _ ss _) = fmap snd $ (OrderByStart ss) `M.lookupGT` spansByStart -    spansByStart = foldr (\ssi -> M.insert (OrderByStart $ srcInfoSpan ssi) ssi) M.empty src-    spansByEnd = foldr (\ssi -> M.insert (OrderByEnd $ srcInfoSpan ssi) ssi) M.empty src+    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

@@ -14,10 +14,6 @@     Pretty   , pretty   , prettyNoExt-  -- * User state-  ,getState-  ,putState-  ,modifyState   -- * Insertion   , write   , newline@@ -62,27 +58,20 @@   )   where -import           Control.Monad.Trans.Maybe-import           Data.Functor.Identity-import           HIndent.Types--import           Language.Haskell.Exts.Comments import           Control.Monad.State.Strict hiding (state)+import qualified Data.ByteString.Builder as S+import qualified Data.Foldable+import           Data.Foldable (traverse_) import           Data.Int import           Data.List import           Data.Maybe-import           Data.Foldable (traverse_)-import           Data.Monoid hiding (Alt)-import           Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import           Data.Text.Lazy.Builder (Builder)-import qualified Data.Text.Lazy.Builder as T-import           Data.Text.Lazy.Builder.Int+import           Data.Monoid ((<>)) import           Data.Typeable+import           HIndent.Types import qualified Language.Haskell.Exts as P-import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Exts.Comments import           Language.Haskell.Exts.SrcLoc+import           Language.Haskell.Exts.Syntax import           Prelude hiding (exp)  --------------------------------------------------------------------------------@@ -90,47 +79,29 @@  -- | Pretty printing class. class (Annotated ast,Typeable ast) => Pretty ast where-  prettyInternal :: MonadState (PrintState s) m => ast NodeInfo -> m ()+  prettyInternal :: ast NodeInfo -> Printer ()  -- | Pretty print using extenders.-pretty :: (Pretty ast,MonadState (PrintState s) m)-       => ast NodeInfo -> m ()-pretty a =-  do st <- get-     case st of-       PrintState{psExtenders = es,psUserState = s} ->-         do-           printComments Before a-           depend-             (case listToMaybe (mapMaybe (makePrinter s) es) of-                Just (Printer m) ->-                  modify (\s' ->-                            fromMaybe s'-                                      (runIdentity (runMaybeT (execStateT m s'))))-                Nothing -> prettyNoExt a)-             (printComments After a)-  where makePrinter _ (Extender f) =-          case cast a of-            Just v -> Just (f v)-            Nothing -> Nothing-        makePrinter s (CatchAll f) = f s a+pretty :: (Pretty ast)+       => 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,MonadState (PrintState s) m)-            => ast NodeInfo -> m ()+prettyNoExt :: (Pretty ast)+            => ast NodeInfo -> Printer () prettyNoExt = prettyInternal  -- | Print comments of a node.-printComments :: (Pretty ast,MonadState (PrintState s) m)-              => ComInfoLocation -> ast NodeInfo -> m ()+printComments :: (Pretty ast)+              => ComInfoLocation -> ast NodeInfo -> Printer () printComments loc' ast = do-  preprocessor <- gets psCommentPreprocessor-   let correctLocation comment = comInfoLocation comment == Just loc'       commentsWithLocation = filter correctLocation (nodeInfoComments info)-  comments <- preprocessor $ map comInfoComment commentsWithLocation+  comments <- return $ map comInfoComment commentsWithLocation    forM_ comments $ \comment -> do     -- Preceeding comments must have a newline before them.@@ -140,9 +111,8 @@     printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment   where info = ann ast - -- | Pretty print a comment.-printComment :: MonadState (PrintState s) m => Maybe SrcSpan -> Comment -> m ()+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@@ -167,27 +137,15 @@  -- | Pretty print using HSE's own printer. The 'P.Pretty' class here -- is HSE's.-pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo),Functor ast,MonadState (PrintState s) m)+pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo),MonadState (PrintState) m)         => ast NodeInfo -> m ()-pretty' = write . T.fromText . T.pack . P.prettyPrint . fmap nodeInfoSpan+pretty' = write . P.prettyPrint . fmap nodeInfoSpan  -------------------------------------------------------------------------------- -- * Combinators --- | Get the user state.-getState :: Printer s s-getState = gets psUserState---- | Put the user state.-putState :: s -> Printer s ()-putState s' = modifyState (const s')---- | Modify the user state.-modifyState :: (s -> s) -> Printer s ()-modifyState f = modify (\s -> s {psUserState = f (psUserState s)})- -- | Increase indentation level by n spaces for the given printer.-indented :: MonadState (PrintState s) m => Int64 -> m a -> m a+indented :: MonadState (PrintState) m => Int64 -> m a -> m a indented i p =   do level <- gets psIndentLevel      modify (\s -> s {psIndentLevel = level + i})@@ -195,21 +153,21 @@      modify (\s -> s {psIndentLevel = level})      return m -indentedBlock :: MonadState (PrintState s) m => m a -> m a+indentedBlock :: MonadState (PrintState) m => m a -> m a indentedBlock p =   do indentSpaces <- getIndentSpaces      indented indentSpaces p  -- | Print all the printers separated by spaces.-spaced :: MonadState (PrintState s) m => [m ()] -> m ()+spaced :: MonadState (PrintState) m => [m ()] -> m () spaced = inter space  -- | Print all the printers separated by commas.-commas :: MonadState (PrintState s) m => [m ()] -> m ()+commas :: MonadState (PrintState) m => [m ()] -> m () commas = inter comma  -- | Print all the printers separated by sep.-inter :: MonadState (PrintState s) m => m () -> [m ()] -> m ()+inter :: MonadState (PrintState) m => m () -> [m ()] -> m () inter sep ps =   foldr (\(i,p) next ->            depend (do p@@ -221,28 +179,28 @@         (zip [1 ..] ps)  -- | Print all the printers separated by newlines.-lined :: MonadState (PrintState s) m => [m ()] -> m ()+lined :: MonadState (PrintState) m => [m ()] -> m () lined ps = sequence_ (intersperse newline ps)  -- | Print all the printers separated newlines and optionally a line -- prefix.-prefixedLined :: MonadState (PrintState s) m => Text -> [m ()] -> m ()+prefixedLined :: MonadState (PrintState) m => String -> [m ()] -> m () prefixedLined pref ps' =   case ps' of     [] -> return ()     (p:ps) ->       do p          indented (fromIntegral-                     (T.length pref *+                     (length pref *                       (-1)))                   (mapM_ (\p' ->                             do newline-                               depend (write (T.fromText pref)) p')+                               depend (write pref) p')                          ps)  -- | Set the (newline-) indent level to the given column for the given -- printer.-column :: MonadState (PrintState s) m => Int64 -> m a -> m a+column :: MonadState (PrintState) m => Int64 -> m a -> m a column i p =   do level <- gets psIndentLevel      modify (\s -> s {psIndentLevel = i})@@ -251,21 +209,21 @@      return m  -- | Get the current indent level.-getColumn :: MonadState (PrintState s) m => m Int64+getColumn :: MonadState (PrintState) m => m Int64 getColumn = gets psColumn  -- | Get the current line number.-getLineNum :: MonadState (PrintState s) m => m Int64+getLineNum :: MonadState (PrintState) m => m Int64 getLineNum = gets psLine  -- | Output a newline.-newline :: MonadState (PrintState s) m => m ()+newline :: MonadState (PrintState) m => m () newline =   do write "\n"      modify (\s -> s {psNewline = True})  -- | Set the context to a case context, where RHS is printed with -> .-withCaseContext :: MonadState (PrintState s) m+withCaseContext :: MonadState (PrintState) m                 => Bool -> m a -> m a withCaseContext bool pr =   do original <- gets psInsideCase@@ -275,7 +233,7 @@      return result  -- | Get the current RHS separator, either = or -> .-rhsSeparator :: MonadState (PrintState s) m+rhsSeparator :: MonadState (PrintState) m              => m () rhsSeparator =   do inCase <- gets psInsideCase@@ -285,7 +243,7 @@  -- | Make the latter's indentation depend upon the end column of the -- former.-depend :: MonadState (PrintState s) m => m () -> m b -> m b+depend :: MonadState (PrintState) m => m () -> m b -> m b depend maker dependent =   do state' <- get      maker@@ -297,7 +255,7 @@  -- | Make the latter's indentation depend upon the end column of the -- former.-dependBind :: MonadState (PrintState s) m => m a -> (a -> m b) -> m b+dependBind :: MonadState (PrintState) m => m a -> (a -> m b) -> m b dependBind maker dependent =   do state' <- get      v <- maker@@ -308,7 +266,7 @@         else (dependent v)  -- | Wrap in parens.-parens :: MonadState (PrintState s) m => m a -> m a+parens :: MonadState (PrintState) m => m a -> m a parens p =   depend (write "(")          (do v <- p@@ -316,7 +274,7 @@              return v)  -- | Wrap in braces.-braces :: MonadState (PrintState s) m => m a -> m a+braces :: MonadState (PrintState) m => m a -> m a braces p =   depend (write "{")          (do v <- p@@ -324,7 +282,7 @@              return v)  -- | Wrap in brackets.-brackets :: MonadState (PrintState s) m => m a -> m a+brackets :: MonadState (PrintState) m => m a -> m a brackets p =   depend (write "[")          (do v <- p@@ -332,20 +290,20 @@              return v)  -- | Write a space.-space :: MonadState (PrintState s) m => m ()+space :: MonadState (PrintState) m => m () space = write " "  -- | Write a comma.-comma :: MonadState (PrintState s) m => m ()+comma :: MonadState (PrintState) m => m () comma = write ","  -- | Write an integral.-int :: (Integral n, MonadState (PrintState s) m)-    => n -> m ()-int = write . decimal+int :: (MonadState (PrintState) m)+    => Integer -> m ()+int = write . show  -- | Write out a string, updating the current position information.-write :: MonadState (PrintState s) m => Builder -> m ()+write :: MonadState (PrintState) m => String -> m () write x =   do eol <- gets psEolComment      when (eol && x /= "\n") newline@@ -353,40 +311,38 @@      let clearEmpty =            configClearEmptyLines (psConfig state)          writingNewline = x == "\n"+         out :: String          out =            if psNewline state &&               not (clearEmpty && writingNewline)-              then T.fromText-                     (T.replicate (fromIntegral (psIndentLevel state))-                                  " ") <>+              then (replicate (fromIntegral (psIndentLevel state))+                               ' ') <>                    x               else x-         out' = T.toLazyText out      modify (\s ->-               s {psOutput = psOutput state <> out+               s {psOutput = psOutput state <> S.stringUtf8 out                  ,psNewline = False                  ,psEolComment = False-                 ,psLine = psLine state + additionalLines+                 ,psLine = psLine state + fromIntegral additionalLines                  ,psColumn =                     if additionalLines > 0-                       then LT.length (LT.concat (take 1 (reverse srclines)))-                       else psColumn state + LT.length out'})-  where x' = T.toLazyText x-        srclines = LT.lines x'+                       then fromIntegral (length (concat (take 1 (reverse srclines))))+                       else psColumn state + fromIntegral (length out)})+  where srclines = lines x         additionalLines =-          LT.length (LT.filter (== '\n') x')+          length (filter (== '\n') x)  -- | Write a string.-string :: MonadState (PrintState s) m =>String -> m ()-string = write . T.fromText . T.pack+string :: MonadState (PrintState) m => String -> m ()+string = write  -- | Indent spaces, e.g. 2.-getIndentSpaces :: MonadState (PrintState s) m => m Int64+getIndentSpaces :: MonadState (PrintState) m => m Int64 getIndentSpaces =   gets (configIndentSpaces . psConfig)  -- | Column limit, e.g. 80-getColumnLimit :: MonadState (PrintState s) m => m Int64+getColumnLimit :: MonadState (PrintState) m => m Int64 getColumnLimit =   gets (configMaxColumns . psConfig) @@ -407,9 +363,8 @@ nullBinds (IPBinds _ x) = null x  -- | Render a type with a context, or not.-withCtx :: (MonadState (PrintState s) m-           ,Pretty ast)-        => Maybe (ast NodeInfo) -> m b -> m b+withCtx :: (Pretty ast)+        => Maybe (ast NodeInfo) -> Printer b -> Printer b withCtx Nothing m = m withCtx (Just ctx) m =   do pretty ctx@@ -418,7 +373,7 @@      m  -- | Maybe render an overlap definition.-maybeOverlap :: MonadState (PrintState s) m => Maybe (Overlap NodeInfo) -> m ()+maybeOverlap ::  Maybe (Overlap NodeInfo) -> Printer () maybeOverlap =   maybe (return ())         (\p ->@@ -426,17 +381,22 @@            space)  -- | Swing the second printer below and indented with respect to the first.-swing :: MonadState (PrintState s) m => m () -> m b -> m b+swing :: Printer () -> Printer b -> Printer () swing a b =   do orig <- gets psIndentLevel      a-     newline-     indentSpaces <- getIndentSpaces-     column (orig + indentSpaces) b+     (fits,st) <- fitsOnOneLine (do space+                                    b)+     if fits+        then put st+        else 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.-swingBy :: MonadState (PrintState s) m => Int64 -> m () -> m b -> m b+swingBy :: Int64 -> Printer() -> Printer b -> Printer b swingBy i a b =   do orig <- gets psIndentLevel      a@@ -447,13 +407,8 @@ -- * Instances  instance Pretty Context where-  prettyInternal ctx =-    case ctx of-      CxSingle _ a -> pretty a-      CxTuple _ as ->-        parens (prefixedLined ","-                              (map pretty as))-      CxEmpty _ -> parens (return ())+  prettyInternal  =+    context  instance Pretty Pat where   prettyInternal x =@@ -530,7 +485,7 @@       PVar{} -> pretty' x  -- | Pretty print a name for being an infix operator.-prettyInfixOp :: MonadState (PrintState s) m => QName NodeInfo -> m ()+prettyInfixOp ::  QName NodeInfo -> Printer () prettyInfixOp x =   case x of     Qual _ mn n ->@@ -544,79 +499,89 @@     Special _ s -> pretty s  instance Pretty Type where-  prettyInternal x =-    case x of-      TyForall _ mbinds ctx ty ->-        depend (case mbinds of-                  Nothing -> return ()-                  Just ts ->-                    do write "forall "-                       spaced (map pretty ts)-                       write ". ")-               (withCtx ctx (pretty ty))-      TyFun _ a b ->-        depend (do pretty a-                   write " -> ")-               (pretty b)-      TyTuple _ boxed tys ->-        depend (write (case boxed of-                         Unboxed -> "(#"-                         Boxed -> "("))-               (do commas (map pretty tys)-                   write (case boxed of-                            Unboxed -> "#)"-                            Boxed -> ")"))-      TyList _ t -> brackets (pretty t)-      TyParArray _ t ->-        brackets (do write ":"-                     pretty t-                     write ":")-      TyApp _ f a -> spaced [pretty f,pretty a]-      TyVar _ n -> pretty n-      TyCon _ p -> pretty p-      TyParen _ e -> parens (pretty e)-      TyInfix _ a op b ->-        depend (do pretty a-                   space)-               (depend (do prettyInfixOp op-                           space)-                       (pretty b))-      TyKind _ ty k ->-        parens (do pretty ty-                   write " :: "-                   pretty k)-      TyBang _ bangty unpackty right ->-        do pretty unpackty-           pretty bangty-           pretty right-      TyEquals _ left right ->-        do pretty left-           write " ~ "-           pretty right-      ty@TyPromoted{} -> pretty' ty-      TySplice{} -> error "FIXME: No implementation for TySplice."-      TyWildCard _ name ->-        case name of-          Nothing -> write "_"-          Just n ->-            do write "_"-               pretty n+  prettyInternal  =+    typ  instance Pretty Exp where   prettyInternal = exp  -- | Render an expression.-exp :: MonadState (PrintState s) m => Exp NodeInfo -> m ()-exp (ExprHole {}) = write "_"-exp (InfixApp _ a op b) =-  depend (do pretty a-             space-             pretty op-             space)-         (do pretty b)+exp :: Exp NodeInfo -> Printer ()+-- | 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))+-- | 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)+             write (case boxed of+                      Unboxed -> "#)"+                      Boxed -> ")"))+  where p = inter (write ", ") (map pretty exps)+-- | Space out tuples.+exp (TupleSection _ boxed mexps) =+  depend (write (case boxed of+                   Unboxed -> "(#"+                   Boxed -> "("))+         (do inter (write ", ") (map (maybe (return ()) pretty) mexps)+             write (case boxed of+                      Unboxed -> "#)"+                      Boxed -> ")"))+-- | Infix apps, same algorithm as ChrisDone at the moment.+exp e@(InfixApp _ a op b) =+  infixApp e a op b Nothing+-- | If bodies are indented 4 spaces. Handle also do-notation.+exp (If _ if' then' else') =+  do depend (write "if ")+            (pretty if')+     newline+     indentSpaces <- getIndentSpaces+     indented indentSpaces+              (do branch "then " then'+                  newline+                  branch "else " else')+     -- Special handling for do.+  where branch str e =+          case e of+            Do _ stmts ->+              do write str+                 write "do"+                 newline+                 indentSpaces <- getIndentSpaces+                 indented indentSpaces (lined (map pretty stmts))+            _ ->+              depend (write str)+                     (pretty e)+-- | App algorithm similar to ChrisDone algorithm, but with no+-- parent-child alignment. exp (App _ op a) =-  swing (do pretty f)-        (lined (map pretty args))+  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]@@ -624,29 +589,55 @@         flatten (App _ f' a') b =           flatten f' (a' : b)         flatten f' as = (f',as)+-- | 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))+  where p =+          brackets (inter (write ", ")+                          (map pretty es))+exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates+exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates+exp (Let _ binds e) =+  depend (write "let ")+         (do pretty binds+             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 (TypeApp _ _) = error "FIXME: No implementation for TypeApp"+exp (ExprHole {}) = write "_" exp (NegApp _ e) =   depend (write "-")          (pretty e) exp (Lambda _ ps e) =-  depend (write "\\")-         (do spaced (map pretty ps)-             swing (write " -> ")-                   (pretty e))-exp (Let _ binds e) =-  do depend (write "let ")-            (pretty binds)-     newline-     depend (write "in ")-            (pretty e)-exp (If _ p t e) =-  do depend (write "if ")-            (do pretty p-                newline-                depend (write "then ")-                       (pretty t)-                newline-                depend (write "else ")-                       (pretty e))+  depend+    (write "\\")+    (do spaced+          (map+             (\(i,x) -> do+                case (i, x) of+                  (0,PIrrPat {}) -> space+                  (0,PBangPat {}) -> space+                  _ -> return ()+                pretty x)+             (zip [0 :: Int ..] ps))+        swing (write " ->") (pretty e)) exp (Paren _ e) = parens (pretty e) exp (Case _ e alts) =   do depend (write "case ")@@ -660,26 +651,6 @@ exp (MDo _ stmts) =   depend (write "mdo ")          (lined (map pretty stmts))-exp (Tuple _ boxed exps) =-  depend (write (case boxed of-                   Unboxed -> "(#"-                   Boxed -> "("))-         (do prefixedLined ","-                           (map pretty exps)-             write (case boxed of-                      Unboxed -> "#)"-                      Boxed -> ")"))-exp (TupleSection _ boxed mexps) =-  depend (write (case boxed of-                   Unboxed -> "(#"-                   Boxed -> "("))-         (do commas (map (maybe (return ()) pretty) mexps)-             write (case boxed of-                      Unboxed -> "#)"-                      Boxed -> ")"))-exp (List _ es) =-  brackets (prefixedLined ","-                          (map pretty es)) exp (LeftSection _ e op) =   parens (depend (do pretty e                      space)@@ -688,16 +659,6 @@   parens (depend (do pretty e                      space)                  (pretty op))-exp (RecConstr _ n fs) =-  depend (do pretty n-             space)-         (braces (prefixedLined ","-                                (map (indentedBlock . pretty) fs)))-exp (RecUpdate _ n fs) =-  depend (do pretty n-             space)-         (braces (prefixedLined ","-                                (map (indentedBlock . pretty) fs))) exp (EnumFrom _ e) =   brackets (do pretty e                write " ..")@@ -716,14 +677,6 @@                    (depend (do pretty t                                write " .. ")                            (pretty f)))-exp (ListComp _ e 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 " :: ")@@ -776,20 +729,11 @@ exp x@ParArrayComp{} = pretty' x exp ParComp{} =   error "FIXME: No implementation for ParComp."+exp (OverloadedLabel _ label) = string ('#' : label)  instance Pretty Stmt where-  prettyInternal x =-    case x of-      Generator _ p e ->-        depend (do pretty p-                   write " <- ")-               (pretty e)-      Qualifier _ e -> pretty e-      LetStmt _ binds ->-        depend (write "let ")-               (pretty binds)-      RecStmt{} ->-        error "FIXME: No implementation for RecStmt."+  prettyInternal =+    stmt  instance Pretty QualStmt where   prettyInternal x =@@ -807,13 +751,13 @@         error "FIXME: No implementation for GroupByUsing."  instance Pretty Decl where-  prettyInternal = decl+  prettyInternal = decl'  -- | Render a declaration.-decl :: MonadState (PrintState s) m => Decl NodeInfo -> m ()-decl (PatBind _ pat rhs mbinds) =+decl ::  Decl NodeInfo -> Printer ()+decl (PatBind _ pat rhs' mbinds) =   do pretty pat-     withCaseContext False (pretty rhs)+     withCaseContext False (pretty rhs')      case mbinds of        Nothing -> return ()        Just binds ->@@ -850,11 +794,11 @@      unless (null (fromMaybe [] decls))             (do newline                 indentedBlock (lined (map pretty (fromMaybe [] decls))))-decl (TypeDecl _ typehead typ) =+decl (TypeDecl _ typehead typ') =   depend (write "type ")          (depend (pretty typehead)                  (depend (write " = ")-                         (pretty typ)))+                         (pretty typ')))  decl TypeFamDecl{} =   error "FIXME: No implementation for TypeFamDecl."@@ -946,12 +890,12 @@     case x of       BangedTy _ -> write "!"       LazyTy _ -> write "~"-      NoStrictAnnot _ -> pure ()+      NoStrictAnnot _ -> return ()  instance Pretty Unpackedness where   prettyInternal (Unpack _) = write "{-# UNPACK -#}"   prettyInternal (NoUnpack _) = write "{-# NOUNPACK -#}"-  prettyInternal (NoUnpackPragma _) = pure ()+  prettyInternal (NoUnpackPragma _) = return ()  instance Pretty Binds where   prettyInternal x =@@ -990,20 +934,7 @@  instance Pretty ConDecl where   prettyInternal x =-    case x of-      ConDecl _ name bangty ->-        depend (do pretty name-                   space)-               (lined (map pretty bangty))-      InfixConDecl l a f b ->-        pretty (ConDecl l f [a,b])-      RecDecl _ name fields ->-        depend (do pretty name-                   write " ")-               (do depend (write "{")-                          (prefixedLined ","-                                         (map pretty fields))-                   write "}")+    conDecl x  instance Pretty FieldDecl where   prettyInternal (FieldDecl _ names ty) =@@ -1016,14 +947,15 @@     case x of       FieldUpdate _ n e ->         swing (do pretty n-                  write " = ")-              (pretty e)+                  write " =")+               (pretty e)       FieldPun _ n -> pretty n       FieldWildcard _ -> write ".."  instance Pretty GuardedRhs where-  prettyInternal x =-    case x of+  prettyInternal  =+    guardedRhs+    {-case x of       GuardedRhs _ stmts e ->         do indented 1                     (do prefixedLined@@ -1033,7 +965,7 @@                                      pretty p)                                stmts))            swing (write " " >> rhsSeparator >> write " ")-                 (pretty e)+                 (pretty e)-}  instance Pretty InjectivityInfo where   prettyInternal x = pretty' x@@ -1050,20 +982,20 @@       _ -> pretty' i  instance Pretty Match where-  prettyInternal x =-    case x of-      Match _ name pats rhs mbinds ->+  prettyInternal = match+    {-case x of+      Match _ name pats rhs' mbinds ->         do depend (do pretty name                       space)                   (spaced (map pretty pats))-           withCaseContext False (pretty rhs)+           withCaseContext False (pretty rhs')            case mbinds of              Nothing -> return ()              Just binds ->                do newline                   indentedBlock (depend (write "where ")                                         (pretty binds))-      InfixMatch _ pat1 name pats rhs mbinds ->+      InfixMatch _ pat1 name pats rhs' mbinds ->         do depend (do pretty pat1                       space                       case name of@@ -1072,13 +1004,13 @@                         Symbol _ s -> string s)                   (do space                       spaced (map pretty pats))-           withCaseContext False (pretty rhs)+           withCaseContext False (pretty rhs')            case mbinds of              Nothing -> return ()              Just binds ->                do newline                   indentedBlock (depend (write "where ")-                                        (pretty binds))+                                        (pretty binds))-}  instance Pretty PatField where   prettyInternal x =@@ -1102,18 +1034,8 @@                        (pretty d))  instance Pretty Rhs where-  prettyInternal x =-    case x of-      UnGuardedRhs _ e -> do-        (swing (write " " >> rhsSeparator >> write " ")-               (pretty e))-      GuardedRhss _ gas ->-        do newline-           indented 2-                    (lined (map (\p ->-                                   do write "|"-                                      pretty p)-                                gas))+  prettyInternal =+    rhs  instance Pretty Splice where   prettyInternal x =@@ -1138,15 +1060,15 @@     case x of       -- Base cases       IHCon _ name -> pretty name-      IHInfix _ typ name ->-        depend (pretty typ)+      IHInfix _ typ' name ->+        depend (pretty typ')                (do space                    prettyInfixOp name)       -- Recursive application-      IHApp _ ihead typ ->+      IHApp _ ihead typ' ->         depend (pretty ihead)                (do space-                   pretty typ)+                   pretty typ')       -- Wrapping in parens       IHParen _ h -> parens (pretty h) @@ -1321,7 +1243,7 @@  instance Pretty ModuleName where   prettyInternal (ModuleName _ name) =-    write (T.fromString name)+    write name  instance Pretty ImportSpecList where   prettyInternal = pretty'@@ -1342,3 +1264,458 @@  instance Pretty ExportSpec where   prettyInternal = pretty'++-- Do statements need to handle infix expression indentation specially because+-- do x *+--    y+-- is two invalid statements, not one valid infix op.+stmt :: Stmt NodeInfo -> Printer ()+stmt (Qualifier _ e@(InfixApp _ a op b)) =+  do col <- fmap (psColumn . snd)+                 (sandbox (write ""))+     infixApp e a op b (Just col)+stmt (Generator _ p e) =+  do indentSpaces <- getIndentSpaces+     pretty p+     indented indentSpaces+              (dependOrNewline+                 (write " <- ")+                 e+                 pretty)+stmt x = case x of+           Generator _ p e ->+             depend (do pretty p+                        write " <- ")+                    (pretty e)+           Qualifier _ e -> pretty e+           LetStmt _ binds ->+             depend (write "let ")+                    (pretty binds)+           RecStmt{} ->+             error "FIXME: No implementation for RecStmt."++-- | Make the right hand side dependent if it fits on one line,+-- otherwise send it to the next line.+dependOrNewline :: Printer ()+                -> Exp NodeInfo+                -> (Exp NodeInfo -> Printer ())+                -> Printer ()+dependOrNewline left right f =+  do (fits,st) <- fitsOnOneLine renderDependent+     if fits+        then put st+        else do left+                newline+                (f right)+  where renderDependent = depend left (f right)++-- | Handle do and case specially and also space out guards more.+rhs :: Rhs NodeInfo -> Printer ()+rhs (UnGuardedRhs _ (Do _ dos)) =+  do inCase <- gets psInsideCase+     write (if inCase then " -> " else " = ")+     indentSpaces <- getIndentSpaces+     let indentation | inCase = indentSpaces+                     | otherwise = max 2 indentSpaces+     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 (GuardedRhss _ gas) =+  do newline+     indented 2+              (lined (map (\p ->+                             do write "|"+                                pretty p)+                          gas))++-- | Implement dangling right-hand-sides.+guardedRhs :: GuardedRhs NodeInfo -> Printer ()+-- | Handle do specially.++guardedRhs (GuardedRhs _ stmts (Do _ dos)) =+  do indented 1+              (do prefixedLined+                    ","+                    (map (\p ->+                            do space+                               pretty p)+                         stmts))+     inCase <- gets psInsideCase+     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)+++match :: Match NodeInfo -> Printer ()+match (Match _ name pats rhs' mbinds) =+  do depend (do pretty name+                space)+            (spaced (map pretty pats))+     withCaseContext False (pretty rhs')+     Data.Foldable.forM_ mbinds bindingGroup+match (InfixMatch _ pat1 name pats rhs' mbinds) =+  do depend (do pretty pat1+                space+                case name of+                  Ident _ i ->+                    string ("`" ++ i ++ "`")+                  Symbol _ s -> string s)+            (do space+                spaced (map pretty pats))+     withCaseContext False (pretty rhs')+     Data.Foldable.forM_ mbinds bindingGroup++-- | 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+context ctx = case ctx of+                CxSingle _ a -> pretty a+                CxTuple _ as ->+                  parens (prefixedLined ","+                                        (map pretty as))+                CxEmpty _ -> parens (return ())++unboxParens :: MonadState (PrintState) m => m a -> m a+unboxParens p =+  depend (write "(# ")+         (do v <- p+             write " #)"+             return v)++typ :: Type NodeInfo -> Printer ()+typ (TyTuple _ Boxed types) = parens $ inter (write ", ") $ map pretty types+typ (TyTuple _ Unboxed types) = unboxParens $ inter (write ", ") $ map pretty types+typ x = case x of+          TyForall _ mbinds ctx ty ->+            depend (case mbinds of+                      Nothing -> return ()+                      Just ts ->+                        do write "forall "+                           spaced (map pretty ts)+                           write ". ")+                   (withCtx ctx (pretty ty))+          TyFun _ a b ->+            depend (do pretty a+                       write " -> ")+                   (pretty b)+          TyTuple _ boxed tys ->+            depend (write (case boxed of+                             Unboxed -> "(#"+                             Boxed -> "("))+                   (do commas (map pretty tys)+                       write (case boxed of+                                Unboxed -> "#)"+                                Boxed -> ")"))+          TyList _ t -> brackets (pretty t)+          TyParArray _ t ->+            brackets (do write ":"+                         pretty t+                         write ":")+          TyApp _ f a -> spaced [pretty f,pretty a]+          TyVar _ n -> pretty n+          TyCon _ p -> pretty p+          TyParen _ e -> parens (pretty e)+          TyInfix _ a op b ->+            depend (do pretty a+                       space)+                   (depend (do prettyInfixOp op+                               space)+                           (pretty b))+          TyKind _ ty k ->+            parens (do pretty ty+                       write " :: "+                       pretty k)+          TyBang _ bangty unpackty right ->+            do pretty unpackty+               pretty bangty+               pretty right+          TyEquals _ left right ->+            do pretty left+               write " ~ "+               pretty right+          ty@TyPromoted{} -> pretty' ty+          TySplice{} -> error "FIXME: No implementation for TySplice."+          TyWildCard _ name ->+            case name of+              Nothing -> write "_"+              Just n ->+                do write "_"+                   pretty n+          _ -> error ("FIXME: No implementation for " ++ show x)++-- | Specially format records. Indent where clauses only 2 spaces.+decl' :: Decl NodeInfo -> Printer ()+-- | Pretty print type signatures like+--+-- foo :: (Show x, Read x)+--     => (Foo -> Bar)+--     -> Maybe Int+--     -> (Char -> X -> Y)+--     -> 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'))+  where declTy dty =+          case dty of+            TyForall _ mbinds mctx ty ->+              do case mbinds of+                   Nothing -> return ()+                   Just ts ->+                     do write "forall "+                        spaced (map pretty ts)+                        write ". "+                        newline+                 case mctx of+                   Nothing -> prettyTy ty+                   Just ctx ->+                     do pretty ctx+                        newline+                        indented (-3)+                                 (depend (write "=> ")+                                         (prettyTy ty))+            _ -> prettyTy dty+        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)+decl' (PatBind _ pat rhs' mbinds) =+  withCaseContext False $+    do pretty pat+       pretty rhs'+       Data.Foldable.forM_ mbinds bindingGroup++-- | Handle records specially for a prettier display (see guide).+decl' (DataDecl _ dataornew ctx dhead condecls@[_] mderivs)+  | any isRecord condecls =+    do depend (do pretty dataornew+                  unless (null condecls) space)+              (withCtx ctx+                       (do pretty dhead+                           multiCons condecls))+       case mderivs of+         Nothing -> return ()+         Just derivs -> pretty derivs+  where multiCons xs =+          depend (write " =")+                 (inter (write "|")+                        (map (depend space . qualConDecl) xs))+decl' e = decl e++-- | Use special record display, used by 'dataDecl' in a record scenario.+qualConDecl :: QualConDecl NodeInfo -> Printer ()+qualConDecl x =+  case x of+    QualConDecl _ tyvars ctx d ->+      depend (unless (null (fromMaybe [] tyvars))+                     (do write "forall "+                         spaced (map pretty (fromMaybe [] tyvars))+                         write ". "))+             (withCtx ctx (recDecl d))++-- | Fields are preceded with a space.+conDecl :: ConDecl NodeInfo -> Printer ()+conDecl (RecDecl _ name fields) =+  depend (do pretty name+             write " ")+         (do depend (write "{")+                    (prefixedLined ","+                                   (map (depend space . pretty) fields))+             write "}")+conDecl x = case x of+              ConDecl _ name bangty ->+                depend (do pretty name+                           space)+                       (lined (map pretty bangty))+              InfixConDecl l a f b ->+                pretty (ConDecl l f [a,b])+              RecDecl _ name fields ->+                depend (do pretty name+                           write " ")+                       (do depend (write "{")+                                  (prefixedLined ","+                                                 (map pretty fields))+                           write "}")++-- | Record decls are formatted like: Foo+-- { bar :: X+-- }+recDecl :: ConDecl NodeInfo -> Printer ()+recDecl (RecDecl _ name fields) =+  do pretty name+     indentSpaces <- getIndentSpaces+     newline+     column indentSpaces+            (do depend (write "{")+                       (prefixedLined ","+                                      (map (depend space . pretty) fields))+                newline+                write "} ")+recDecl r = prettyNoExt r++recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer ()+recUpdateExpr expWriter updates = do+    expWriter+    newline+    mapM_+      (\(i,x) -> do+         if i == 0+           then write "{ "+           else write ", "+         pretty x+         newline)+      (zip [0::Int ..] updates)+    write "}"++--------------------------------------------------------------------------------+-- Predicates++-- | Is the decl a record?+isRecord :: QualConDecl t -> Bool+isRecord (QualConDecl _ _ _ RecDecl{}) = True+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 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)++bindingGroup :: Binds NodeInfo -> Printer ()+bindingGroup binds =+  do newline+     indented 2+              (do write "where"+                  newline+                  indented 2 (pretty binds))++infixApp :: Exp NodeInfo+         -> Exp NodeInfo+         -> QOp NodeInfo+         -> Exp NodeInfo+         -> 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)+  where prettyWithIndent e' =+          case e' of+            (InfixApp _ a' op' b') ->+              infixApp e' a' op' b' indent+            _ -> pretty e'++-- | A link in a chain of operator applications.+data OpChainLink l+  = OpChainExp (Exp l)+  | OpChainLink (QOp l)+  deriving (Show)++-- | Flatten a tree of InfixApp expressions into a chain of operator+-- links.+flattenOpChain :: Exp l -> [OpChainLink l]+flattenOpChain (InfixApp _ left op right) =+  flattenOpChain left <>+  [OpChainLink op] <>+  flattenOpChain right+flattenOpChain e = [OpChainExp e]

@@ -1,586 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---- | Stub module for Johan Tibell's style.------ Documented here: <https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md>------ Questions:------ How to indent after a guarded alt/rhs?--- How to indent let?--- How to indent large ADT constructors types?--module HIndent.Styles.JohanTibell where--import Control.Monad hiding (forM_)-import Control.Monad.State.Class-import Data.Foldable (forM_)-import Data.Int-import Data.Maybe-import Data.Monoid-import HIndent.Pretty-import HIndent.Types-import Language.Haskell.Exts.Syntax-import Prelude hiding (exp)------------------------------------------------------------------------------------- Style configuration---- | A short function name.-shortName :: Int64-shortName = 10---- | Empty state.-data State =-  State---- | The printer style.-johanTibell :: Style-johanTibell =-  Style {styleName = "johan-tibell"-        ,styleAuthor = "Chris Done"-        ,styleDescription = "Style modeled from Johan's style guide here: <https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md>"-        ,styleInitialState = State-        ,styleExtenders =-           [Extender decl-           ,Extender match-           ,Extender context-           ,Extender typ-           ,Extender conDecl-           ,Extender exp-           ,Extender guardedRhs-           ,Extender rhs-           ,Extender stmt-           ,Extender fieldupdate-           ]-        ,styleDefConfig =-           defaultConfig {configMaxColumns = 80-                         ,configIndentSpaces = 4}-        ,styleCommentPreprocessor = return}------------------------------------------------------------------------------------- Extenders---- Do statements need to handle infix expression indentation specially because--- do x *---    y--- is two invalid statements, not one valid infix op.-stmt :: Stmt NodeInfo -> Printer s ()-stmt (Qualifier _ e@(InfixApp _ a op b)) =-  do col <- fmap (psColumn . snd)-                 (sandbox (write ""))-     infixApp e a op b (Just col)-stmt (Generator _ p e) =-  do indentSpaces <- getIndentSpaces-     pretty p-     indented indentSpaces-              (dependOrNewline-                 (write " <- ")-                 e-                 pretty)-stmt e = prettyNoExt e---- | Make the right hand side dependent if it fits on one line,--- otherwise send it to the next line.-dependOrNewline :: Printer t ()-                -> Exp NodeInfo-                -> (Exp NodeInfo -> Printer t ())-                -> Printer t ()-dependOrNewline left right f =-  do (fits,st) <- fitsOnOneLine renderDependent-     if fits-        then put st-        else do left-                newline-                (f right)-  where renderDependent = depend left (f right)---- | Handle do and case specially and also space out guards more.-rhs :: Rhs NodeInfo -> Printer s ()-rhs (UnGuardedRhs _ (Do _ dos)) =-  do inCase <- gets psInsideCase-     write (if inCase then " -> " else " = ")-     indentSpaces <- getIndentSpaces-     let indentation | inCase = indentSpaces-                     | otherwise = max 4 indentSpaces-     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 >> write " ")-                   (pretty e)-rhs (GuardedRhss _ gas) =-  do newline-     indented 2-              (lined (map (\p ->-                             do write "|"-                                pretty p)-                          gas))---- | Implement dangling right-hand-sides.-guardedRhs :: GuardedRhs NodeInfo -> Printer s ()--- | Handle do specially.--guardedRhs (GuardedRhs _ stmts (Do _ dos)) =-  do indented 1-              (do prefixedLined-                    ","-                    (map (\p ->-                            do space-                               pretty p)-                         stmts))-     inCase <- gets psInsideCase-     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 >> write " ")-                (pretty e)----- | Expression customizations.-exp :: Exp NodeInfo -> Printer s ()--- | 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))--- | 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)-             write (case boxed of-                      Unboxed -> "#)"-                      Boxed -> ")"))-  where p = inter (write ", ") (map pretty exps)--- | Space out tuples.-exp (TupleSection _ boxed mexps) =-  depend (write (case boxed of-                   Unboxed -> "(#"-                   Boxed -> "("))-         (do inter (write ", ") (map (maybe (return ()) pretty) mexps)-             write (case boxed of-                      Unboxed -> "#)"-                      Boxed -> ")"))--- | Infix apps, same algorithm as ChrisDone at the moment.-exp e@(InfixApp _ a op b) =-  infixApp e a op b Nothing--- | If bodies are indented 4 spaces. Handle also do-notation.-exp (If _ if' then' else') =-  do depend (write "if ")-            (pretty if')-     newline-     indentSpaces <- getIndentSpaces-     indented indentSpaces-              (do branch "then " then'-                  newline-                  branch "else " else')-     -- Special handling for do.-  where branch str e =-          case e of-            Do _ stmts ->-              do write str-                 write "do"-                 newline-                 indentSpaces <- getIndentSpaces-                 indented indentSpaces (lined (map pretty stmts))-            _ ->-              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)--- | 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))-  where p =-          brackets (inter (write ", ")-                          (map pretty es))-exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates-exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates-exp (Let _ binds e) =-  depend (write "let ")-         (do pretty binds-             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 ()-match (Match _ name pats rhs' mbinds) =-  do depend (do pretty name-                space)-            (spaced (map pretty pats))-     withCaseContext False (pretty rhs')-     forM_ mbinds bindingGroup-match (InfixMatch _ pat1 name pats rhs' mbinds) =-  do depend (do pretty pat1-                space-                case name of-                  Ident _ i ->-                    string ("`" ++ i ++ "`")-                  Symbol _ s -> string s)-            (do space-                spaced (map pretty pats))-     withCaseContext False (pretty rhs')-     forM_ mbinds bindingGroup---- | Format contexts with spaces and commas between class constraints.-context :: Context NodeInfo -> Printer s ()-context ctx@(CxTuple _ asserts) =-  do (fits,st) <--       fitsOnOneLine-         (parens (inter (comma >> space)-                        (map pretty asserts)))-     if fits-        then put st-        else prettyNoExt ctx-context ctx = prettyNoExt ctx--unboxParens :: MonadState (PrintState s) m => m a -> m a-unboxParens p =-  depend (write "(# ")-         (do v <- p-             write " #)"-             return v)--typ :: Type NodeInfo -> Printer s ()-typ (TyTuple _ Boxed types) = parens $ inter (write ", ") $ map pretty types-typ (TyTuple _ Unboxed types) = unboxParens $ inter (write ", ") $ map pretty types-typ ty = prettyNoExt ty---- | Specially format records. Indent where clauses only 2 spaces.-decl :: Decl NodeInfo -> Printer s ()--- | Pretty print type signatures like------ foo :: (Show x, Read x)---     => (Foo -> Bar)---     -> Maybe Int---     -> (Char -> X -> Y)---     -> 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'))-  where declTy dty =-          case dty of-            TyForall _ mbinds mctx ty ->-              do case mbinds of-                   Nothing -> return ()-                   Just ts ->-                     do write "forall "-                        spaced (map pretty ts)-                        write ". "-                        newline-                 case mctx of-                   Nothing -> prettyTy ty-                   Just ctx ->-                     do pretty ctx-                        newline-                        indented (-3)-                                 (depend (write "=> ")-                                         (prettyTy ty))-            _ -> prettyTy dty-        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)-decl (PatBind _ pat rhs' mbinds) =-  withCaseContext False $-    do pretty pat-       pretty rhs'-       forM_ mbinds bindingGroup---- | Handle records specially for a prettier display (see guide).-decl (DataDecl _ dataornew ctx dhead condecls@[_] mderivs)-  | any isRecord condecls =-    do depend (do pretty dataornew-                  unless (null condecls) space)-              (withCtx ctx-                       (do pretty dhead-                           multiCons condecls))-       case mderivs of-         Nothing -> return ()-         Just derivs -> pretty derivs-  where multiCons xs =-          depend (write " =")-                 (inter (write "|")-                        (map (depend space . qualConDecl) xs))-decl e = prettyNoExt e---- | Use special record display, used by 'dataDecl' in a record scenario.-qualConDecl :: QualConDecl NodeInfo -> Printer s ()-qualConDecl x =-  case x of-    QualConDecl _ tyvars ctx d ->-      depend (unless (null (fromMaybe [] tyvars))-                     (do write "forall "-                         spaced (map pretty (fromMaybe [] tyvars))-                         write ". "))-             (withCtx ctx (recDecl d))---- | Fields are preceded with a space.-conDecl :: ConDecl NodeInfo -> Printer s ()-conDecl (RecDecl _ name fields) =-  depend (do pretty name-             write " ")-         (do depend (write "{")-                    (prefixedLined ","-                                   (map (depend space . pretty) fields))-             write "}")-conDecl e = prettyNoExt e---- | Record decls are formatted like: Foo--- { bar :: X--- }-recDecl :: ConDecl NodeInfo -> Printer s ()-recDecl (RecDecl _ name fields) =-  do pretty name-     indentSpaces <- getIndentSpaces-     newline-     column indentSpaces-            (do depend (write "{")-                       (prefixedLined ","-                                      (map (depend space . pretty) fields))-                newline-                write "} ")-recDecl r = prettyNoExt r--recUpdateExpr :: Printer s () -> [FieldUpdate NodeInfo] -> Printer s ()-recUpdateExpr expWriter updates = do-  expWriter-  newline-  indentSpaces <- getIndentSpaces-  write "{ "-  -- -2 because the "{ " moved us 2 chars to the right.-  indented (indentSpaces -2) $ do-    prefixedLined ", " $ map pretty updates-    newline-  write "}"------------------------------------------------------------------------------------- Predicates---- | Is the decl a record?-isRecord :: QualConDecl t -> Bool-isRecord (QualConDecl _ _ _ RecDecl{}) = True-isRecord _ = False---- | Does printing the given thing overflow column limit? (e.g. 80)-isOverflow :: MonadState (PrintState s) 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 s) m => m a -> m (Bool,PrintState s)-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 s) m-              => m a -> m Bool-isSingleLiner p =-  do line <- gets psLine-     (_,st) <- sandbox p-     return (psLine st == line)---- | Is the expression "short"? Used for app heads.-isShort :: (Pretty ast)-        => ast NodeInfo -> Printer s (Bool)-isShort p =-  do line <- gets psLine-     orig <- fmap (psColumn . snd) (sandbox (write ""))-     (_,st) <- sandbox (pretty p)-     return (psLine st == line &&-             (psColumn st < orig + shortName))---- | Is an expression flat?-isFlat :: Exp NodeInfo -> Printer s Bool-isFlat (Lambda _ _ e) = isFlat e-isFlat (App _ a b) =-  return (isName a && isName b)-  where isName (Var{}) = True-        isName _ = False-isFlat (NegApp _ a) = isFlat a-isFlat VarQuote{} = return True-isFlat TypQuote{} = return True-isFlat (List _ []) = return True-isFlat Var{} = return True-isFlat Lit{} = return True-isFlat Con{} = return True-isFlat (LeftSection _ e _) = isFlat e-isFlat (RightSection _ _ e) = isFlat e-isFlat _ = return False---- | rhs on field update on the same line as lhs.-fieldupdate :: FieldUpdate NodeInfo -> Printer s ()-fieldupdate e =-  case e of-    FieldUpdate _ n e' -> do pretty n-                             write " = "-                             pretty e'-    _ -> prettyNoExt e--isSmall :: MonadState (PrintState t) m => m a -> m Bool-isSmall p =-  do overflows <- isOverflow p-     oneLine <- isSingleLiner p-     return (not overflows && oneLine)--bindingGroup :: Binds NodeInfo -> Printer s ()-bindingGroup binds =-  do newline-     indented 2-              (do write "where"-                  newline-                  indented 2 (pretty binds))--infixApp :: Exp NodeInfo-         -> Exp NodeInfo-         -> QOp NodeInfo-         -> Exp NodeInfo-         -> Maybe Int64-         -> Printer s ()-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)-  where prettyWithIndent e' =-          case e' of-            (InfixApp _ a' op' b') ->-              infixApp e' a' op' b' indent-            _ -> pretty e'---- | A link in a chain of operator applications.-data OpChainLink l-  = OpChainExp (Exp l)-  | OpChainLink (QOp l)-  deriving (Show)---- | Flatten a tree of InfixApp expressions into a chain of operator--- links.-flattenOpChain :: Exp l -> [OpChainLink l]-flattenOpChain (InfixApp _ left op right) =-  flattenOpChain left <>-  [OpChainLink op] <>-  flattenOpChain right-flattenOpChain e = [OpChainExp e]

@@ -10,8 +10,6 @@ module HIndent.Types   (Printer(..)   ,PrintState(..)-  ,Extender(..)-  ,Style(..)   ,Config(..)   ,defaultConfig   ,NodeInfo(..)@@ -26,50 +24,28 @@ import Data.Data import Data.Functor.Identity import Data.Int (Int64)-import Data.Text (Text)-import Data.Text.Lazy.Builder (Builder)+import Data.ByteString.Builder import Language.Haskell.Exts.Comments import Language.Haskell.Exts.Parser import Language.Haskell.Exts.SrcLoc  -- | A pretty printing monad.-newtype Printer s a =-  Printer {runPrinter :: StateT (PrintState s) (MaybeT Identity) a}-  deriving (Applicative,Monad,Functor,MonadState (PrintState s),MonadPlus,Alternative)+newtype Printer a =+  Printer {runPrinter :: StateT PrintState (MaybeT Identity) a}+  deriving (Applicative,Monad,Functor,MonadState PrintState,MonadPlus,Alternative)  -- | The state of the pretty printer.-data PrintState s =+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.-             ,psUserState :: !s -- ^ User state.-             ,psExtenders :: ![Extender s] -- ^ Extenders.              ,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.-             ,psCommentPreprocessor :: forall m. MonadState (PrintState s) m => [Comment] -> m [Comment] -- ^ Preprocessor applied to comments on an AST before printing.              }---- | 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.-data Extender s where-  Extender :: forall s a. (Typeable a) => (a -> Printer s ()) -> Extender s-  CatchAll :: forall s. (forall a. Typeable a => s -> a -> Maybe (Printer s ())) -> Extender s---- | A printer style.-data Style =-  forall s. Style {styleName :: !Text -- ^ Name of the style, used in the commandline interface.-                  ,styleAuthor :: !Text -- ^ Author of the printer (as opposed to the author of the style).-                  ,styleDescription :: !Text -- ^ Description of the style.-                  ,styleInitialState :: !s -- ^ User state, if needed.-                  ,styleExtenders :: ![Extender s] -- ^ Extenders to the printer.-                  ,styleDefConfig :: !Config -- ^ Default config to use for this style.-                  ,styleCommentPreprocessor :: forall s' m. MonadState (PrintState s') m => [Comment] -> m [Comment] -- ^ Preprocessor to use for comments.-                  }  -- | Configurations shared among the different styles. Styles may pay -- attention to or completely disregard this configuration.

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}  -- | Benchmark the pretty printer.@@ -7,28 +8,41 @@ 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 qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Builder as L+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.ByteString.UTF8 as UTF8 import           HIndent+import           HIndent.Types+import           Markdone  -- | 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]])]+main = do+    bytes <- S.readFile "BENCHMARKS.md"+    !forest <- fmap force (parse (tokenize bytes))+    defaultMain (toCriterion forest) --- | Setup the environment for the benchmarks.-setupEnv :: IO Text-setupEnv = do-  bigDecls <- LT.readFile "benchmarks/BigDeclarations.hs"-  let !decls = force bigDecls-  return decls+-- | Convert the Markdone document to Criterion benchmarks.+toCriterion :: [Markdone] -> [Benchmark]+toCriterion = go+  where+    go (Section name children:next) =+      bgroup (S8.unpack name) (go children) : go next+    go (PlainText desc:CodeFence lang code:next) =+      if lang == "haskell"+        then (bench+                (UTF8.toString desc)+                (nf+                   (either error L.toLazyByteString .+                    reformat+                      HIndent.Types.defaultConfig+                      (Just defaultExtensions))+                   code)) :+             go next+        else go next+    go (PlainText {}:next) = go next+    go (CodeFence {}:next) = go next+    go [] = []+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -10,17 +11,15 @@  import           HIndent import           HIndent.Types-+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.List import           Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Lazy.Builder as T-import qualified Data.Text.Lazy.IO as T import           Data.Version (showVersion) import           Descriptive import           Descriptive.Options-import           GHC.Tuple import           Language.Haskell.Exts hiding (Style,style) import           Paths_hindent (version) import           System.Directory@@ -39,15 +38,14 @@         Succeeded (style,exts,mfilepath) ->             case mfilepath of                 Just filepath -> do-                    text <- T.readFile filepath+                    text <- S.readFile filepath                     tmpDir <- getTemporaryDirectory                     (fp,h) <- openTempFile tmpDir "hindent.hs"-                    T.hPutStrLn-                        h-                        (either-                             error-                             T.toLazyText-                             (reformat style (Just exts) text))+                    L8.putStrLn+                                   (either+                                        error+                                        S.toLazyByteString+                                        (reformat style (Just exts) text))                     hFlush h                     hClose h                     let exdev e =@@ -60,14 +58,15 @@                                 else throw e                     renameFile fp filepath `catch` exdev                 Nothing ->-                    T.interact-                        (either error T.toLazyText . reformat style (Just exts))+                    L8.interact+                           (either error S.toLazyByteString . reformat style (Just exts) . L8.toStrict)         Failed (Wrap (Stopped Version) _) ->             putStrLn ("hindent " ++ showVersion version)         Failed (Wrap (Stopped Help) _) -> putStrLn help         _ -> error help   where +help :: [Char] help =     "hindent " ++     T.unpack (textDescription (describe options [])) ++@@ -81,15 +80,16 @@  -- | Program options. options :: Monad m-        => Consumer [Text] (Option Stoppers) m (Style,[Extension],Maybe FilePath)+        => Consumer [Text] (Option Stoppers) m (Config,[Extension],Maybe FilePath) options = ver *> ((,,) <$> style <*> exts <*> file)   where-    ver = stop (flag "version" "Print the version" Version) *>-          stop (flag "help" "Show help" Help)+    ver =+        stop (flag "version" "Print the version" Version) *>+        stop (flag "help" "Show help" Help)     style =         makeStyle <$>         fmap-            (const johanTibell)+            (const defaultConfig)             (optional                  (constant "--style" "Style to print with" () *>                   anyString "STYLE")) <*>@@ -104,31 +104,6 @@             Nothing -> s             Just len ->                 s-                { styleDefConfig = (styleDefConfig s)-                  { configMaxColumns = len-                  }+                { configMaxColumns = len                 }     file = fmap (fmap T.unpack) (optional (anyString "[<filename>]"))------------------------------------------------------------------------------------- Extensions stuff stolen from hlint---- | Consume an extensions list from arguments.-getExtensions :: [Text] -> [Extension]-getExtensions = foldl f defaultExtensions . map T.unpack-  where f _ "Haskell98" = []-        f a ('N':'o':x)-          | Just x' <- readExtension x =-            delete x' a-        f a x-          | Just x' <- readExtension x =-            x' :-            delete x' a-        f _ x = error $ "Unknown extension: " ++ x---- | Parse an extension.-readExtension :: String -> Maybe Extension-readExtension x =-  case classifyExtension x of-    UnknownExtension _ -> Nothing-    x' -> Just x'

@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- | A subset of markdown that only supports @#headings@ and code+-- fences.+--+-- All content must be in section headings with proper hierarchy,+-- anything else is rejected.++module Markdone where++import           Control.DeepSeq+import           Control.Monad.Catch+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import           Data.Char+import           Data.Typeable+import           GHC.Generics++-- | A markdone token.+data Token+  = Heading !Int+            !ByteString+  | PlainLine !ByteString+  | BeginFence !ByteString+  | EndFence+  deriving (Show)++-- | A markdone document.+data Markdone+  = Section !ByteString+            ![Markdone]+  | CodeFence !ByteString+              !ByteString+  | PlainText !ByteString+  deriving (Show,Generic)+instance NFData Markdone++-- | Parse error.+data MarkdownError = NoFenceEnd | ExpectedSection+  deriving (Typeable,Show)+instance Exception MarkdownError++-- | Tokenize the bytestring.+tokenize :: ByteString -> [Token]+tokenize = map token . S8.lines+  where+    token line =+      if S8.isPrefixOf "#" line+        then let (hashes,title) = S8.span (== '#') line+             in Heading (S8.length hashes) (S8.dropWhile isSpace title)+        else if S8.isPrefixOf "```" line+               then if line == "```"+                      then EndFence+                      else BeginFence+                             (S8.dropWhile+                                (\c ->+                                    c == '`' || c == ' ')+                                line)+               else PlainLine line++-- | Parse into a forest.+parse :: (Functor m,MonadThrow m) => [Token] -> m [Markdone]+parse = go (0 :: Int)+  where+    go level =+      \case+        (Heading n label:rest) ->+          let (children,rest') =+                span+                  (\case+                     Heading nextN _ -> nextN > n+                     _ -> True)+                  rest+          in do childs <- go (level + 1) children+                siblings <- go level rest'+                return (Section label childs : siblings)+        (BeginFence label:rest)+          | level > 0 ->+            let (content,rest') =+                  (span+                     (\case+                        PlainLine {} -> True+                        _ -> False)+                     rest)+            in case rest' of+                 (EndFence:rest'') ->+                   fmap+                     (CodeFence+                        label+                        (S8.intercalate "\n" (map getPlain content)) :)+                     (go level rest'')+                 _ -> throwM NoFenceEnd+        PlainLine p:rest+          | level > 0 ->+            let (content,rest') =+                  (span+                     (\case+                        PlainLine {} -> True+                        _ -> False)+                     (PlainLine p : rest))+            in fmap+                 (PlainText+                    (S8.intercalate+                       "\n"+                       (filter (not . S8.null) (map getPlain content))) :)+                 (go level rest')+        [] -> return []+        _ -> throwM ExpectedSection+    getPlain (PlainLine x) = x+    getPlain _ = ""

@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Test the pretty printer.++module Main where++import qualified Data.ByteString as S+import           Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Builder as L+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.Monoid+import           HIndent+import           HIndent.Types+import           Markdone+import           Test.Hspec++-- | Main benchmarks.+main :: IO ()+main = do+    bytes <- S.readFile "TESTS.md"+    forest <- parse (tokenize bytes)+    hspec (toSpec forest)++-- -- | Convert the Markdone document to Spec benchmarks.+toSpec :: [Markdone] -> Spec+toSpec = go+  where+    go (Section name children:next) = do+        describe (UTF8.toString name) (go children)+        go next+    go (PlainText desc:CodeFence lang code:next) =+      if lang == "haskell"+        then do+          it+            (UTF8.toString desc)+            (shouldBeReadable+               (either+                  (("-- " <>) . L8.pack)+                  L.toLazyByteString+                  (reformat+                     HIndent.Types.defaultConfig+                     (Just defaultExtensions)+                     code))+               (L.fromStrict code))+          go next+        else go next+    go (PlainText {}:next) = go next+    go (CodeFence {}:next) = go next+    go [] = return ()++-- | 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)++-- | Prints a string without quoting and escaping.+newtype Readable = Readable ByteString deriving (Eq)+instance Show Readable where+  show (Readable x) = "\n" ++ LUTF8.toString x

@@ -1,90 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Main(main) where--import Control.Monad-import Control.Applicative-import Data.List (find, unfoldr, isPrefixOf, intercalate)--import System.Directory-import System.Environment-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as L--import qualified HIndent--testDir, expectedDir :: String-testDir = "tests"-expectedDir = "expected"---- This executable generates a test suite for a style using a test suite--- from a previous style. Given arguments `from` and `to` which are style names,--- it will take all the input files for `from`, create identical input files for `to`,--- run each block in the input files through the `to` style, and generate expectation files matching the output.-main :: IO ()-main = do-  args <- getArgs-  case args of-    [from, to] -> generateTests from to-    _          -> putStrLn "Two arguments required: source tests and destination tests."--generateTests :: String -> String -> IO ()-generateTests from to = do-  --  Find the source and destination styles.-  let Just toStyle = findStyle (T.pack to)--  --  Get all the test and expectation files for the original test suite.-  testFilenamesFrom <- filter (not . isPrefixOf ".") <$> getDirectoryContents (tests from)--  -- Verify the target directories exist.-  createDirectoryIfMissing True $ tests to-  createDirectoryIfMissing True $ expected to--  -- Copy test files to the new style test directory.-  forM_ testFilenamesFrom $ \filename ->-    copyFile (tests from ++ filename) (tests to ++ filename)--  -- Generate expectation files for the new style test directory.-  forM_ testFilenamesFrom $ \filename -> do-    let dstFilename = expected to ++ expectedFilename filename-    contents <- expectationFileContents toStyle <$> readFile (tests to ++ filename)-    writeFile dstFilename contents--  where-    findStyle style = find ((== style). HIndent.styleName) [HIndent.johanTibell]-    tests style = "test/" ++ style ++ "/" ++ testDir ++ "/"-    expected style = "test/" ++ style ++ "/" ++ expectedDir ++ "/"-    expectedFilename filename = take (length filename - 4) filename ++ "exp"--expectationFileContents :: HIndent.Style -> String -> String-expectationFileContents style contents =-  let testDecls = parsePieces contents-      fmt input = L.unpack $ L.toLazyText $ case HIndent.reformat style Nothing $ L.pack input of-                                              Left err      -> error err-                                              Right builder -> builder-      outputs = map (replaceEmptyNewlines . fmt) testDecls-  in intercalate "\n" outputs-  where-    replaceEmptyNewlines = unlines . map replaceNewline . lines-    replaceNewline "" = ">"-    replaceNewline x = x--parsePieces :: String -> [String]-parsePieces str = map (intercalate "\n" . map mkNewlines) pieces-  where-    pieces = unfoldr unfolder (lines str)--    unfolder :: [String] -> Maybe ([String], [String])-    unfolder [] = Nothing-    unfolder remaining = Just $-     case break pieceBreak (zip remaining (tail remaining ++ [""]))  of-       (nonNull, [])     -> (map fst nonNull, [])-       (nonNull, _:rest) -> (map fst nonNull, map fst rest)--    pieceBreak :: (String, String) -> Bool-    pieceBreak ("", "") = error "Two consecutive line breaks!"-    pieceBreak (line, next) = null line && head next /= ' '--    mkNewlines :: String -> String-    mkNewlines ">" = ""-    mkNewlines x = x

@@ -1,92 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Main (main) where--import           Control.Monad-import           Control.Applicative-import           Data.List (find, unfoldr, break, isPrefixOf, intercalate)--import           Test.Hspec-import           System.Directory-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as L--import Language.Haskell.Exts.Extension--import qualified HIndent--styles :: [FilePath]-styles = ["johan-tibell"]--testDir, expectedDir :: String-testDir = "tests"-expectedDir = "expected"--main :: IO ()-main = forM_ styles testStyle--testStyle :: FilePath -> IO ()-testStyle style = do-  let Just theStyle = find ((== T.pack style) . HIndent.styleName) [HIndent.johanTibell]-  testFilenames <- filter (not . isPrefixOf ".") <$> getDirectoryContents tests-  let expFiles = map ((expected ++) . expectedFilename) testFilenames-      testFiles = map (tests ++) testFilenames-  specs <- forM (zip testFiles expFiles) (uncurry $ useTestFiles theStyle)-  hspec $ foldl1 (>>) specs--  where-    tests = "test/" ++ style ++ "/" ++ testDir ++ "/"-    expected = "test/" ++ style ++ "/" ++ expectedDir ++ "/"--    expectedFilename filename = take (length filename - 4) filename ++ "exp"--useTestFiles :: HIndent.Style -> FilePath -> FilePath -> IO Spec-useTestFiles style test exp = do-  testContents <- readFile test-  expContents <- readFile exp-  let testDecls = parsePieces testContents-      expDecls = parsePieces expContents-  when (length testDecls /= length expDecls) $-    error $ concat-              [ "Mismatched number of pieces in files "-              , test-              , " ("-              , show $ length testDecls-              , ")"-              , " and "-              , exp-              , " ("-              , show $ length expDecls-              , ")"-              ]-  return $ describe ("hindent applied to chunks in " ++ test) $ foldl1 (>>) $ zipWith (mkSpec style)-                                                                                testDecls expDecls--mkSpec :: HIndent.Style -> String -> String -> Spec-mkSpec style input desired = it "works" $-  case HIndent.reformat style (Just exts) (L.pack input) of-    Left err      -> expectationFailure ("Error: " ++ err)-    Right builder -> L.unpack (L.toLazyText builder) `shouldBe` desired-  where exts =-          glasgowExts ++-          map EnableExtension [TemplateHaskell,DataKinds, MultiWayIf]--parsePieces :: String -> [String]-parsePieces str = map (intercalate "\n" . map mkNewlines) pieces-  where-    pieces = unfoldr unfolder (lines str)--    unfolder :: [String] -> Maybe ([String], [String])-    unfolder [] = Nothing-    unfolder remaining = Just $-      case break pieceBreak (zip remaining (tail remaining ++ [""])) of-        (nonNull, [])     -> (map fst nonNull, [])-        (nonNull, _:rest) -> (map fst nonNull, map fst rest)--    pieceBreak :: (String, String) -> Bool-    pieceBreak ("", "") = error $ "Two consecutive line breaks in:\n" ++ str-    pieceBreak (line, next) = null line && head next /= ' '--    mkNewlines :: String -> String-    mkNewlines ">" = ""-    mkNewlines x = x

@@ -1,6 +0,0 @@-getGitProvider :: EventProvider GitRecord ()-getGitProvider = -    EventProvider-    { getModuleName = "Git"-    , getEvents = getRepoCommits-    }

@@ -1,6 +0,0 @@-strToMonth :: String -> Int-strToMonth month = -    case month of-        "Jan" -> 1-        "Feb" -> 2-        _ -> error $ "Unknown month " ++ month

@@ -1,6 +0,0 @@-sayHello :: IO ()-sayHello = do-    name <- getLine-    putStrLn $ greeting name-  where-    greeting name = "Hello, " ++ name ++ "!"

@@ -1,7 +0,0 @@-commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event-commitToEvent gitFolderPath timezone commit = -    Event.Event-    { pluginName = getModuleName getGitProvider-    , eventIcon = "glyphicon-cog"-    , eventDate = localTimeToUTC timezone (commitDate commit)-    }

@@ -1,9 +0,0 @@-fun-    :: (Class a, Class b)-    => a -> b -> c--fun :: (a, b, c) -> (a, b)--fun-    :: (Class a, Class b)-    => a -> (# d, e #) -> c

@@ -1,21 +0,0 @@-f :: Int-f x-  | x <- Just x-  , x <- Just x = -      case x of-          Just x -> e-  | otherwise = do-      e-  where-    x = y--g x = -    case x of-        a -> x-  where-    foo = -        case x of-            _ -> do-                launchMissiles-      where-        y = 2

@@ -1,8 +0,0 @@-g x = -    let x = 1-    in x-  where-    foo = -        let y = 2-            z = 3-        in y

@@ -1,6 +0,0 @@-getGitProvider :: EventProvider GitRecord ()-getGitProvider = EventProvider-    {-        getModuleName = "Git",-        getEvents = getRepoCommits-    }

@@ -1,5 +0,0 @@-strToMonth :: String -> Int-strToMonth month = case month of-    "Jan" -> 1-    "Feb" -> 2-    _ -> error $ "Unknown month " ++ month

@@ -1,6 +0,0 @@-sayHello :: IO ()-sayHello = do-    name <- getLine-    putStrLn $ greeting name-    where-        greeting name = "Hello, " ++ name ++ "!"

@@ -1,7 +0,0 @@-commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event-commitToEvent gitFolderPath timezone commit = Event.Event-    {-        pluginName = getModuleName getGitProvider,-        eventIcon = "glyphicon-cog",-        eventDate = localTimeToUTC timezone (commitDate commit)-    }

@@ -1,7 +0,0 @@-fun :: (Class a,Class b)-    => a -> b -> c--fun :: (a,b,c) -> (a,b)--fun :: (Class a, Class b)-    => a ->(# d,e #)-> c

@@ -1,15 +0,0 @@-f :: Int-f x | x <- Just x-    , x <- Just x = case x of-         Just x -> e-  | otherwise = do-    e-  where-    x = y--g x = case x of a -> x-  where-    foo = case x of-        _ -> do launchMissiles-      where-        y = 2

@@ -1,3 +0,0 @@-g x = let x = 1 in x-  where-    foo = let y = 2; z = 3 in y