floskell 0.9.0 → 0.10.0

raw patch · 21 files changed

+1908/−1038 lines, 21 filesdep +attoparsecdep −monad-loopsdep ~exceptionsdep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec

Dependencies removed: monad-loops

Dependency ranges changed: exceptions, haskell-src-exts

API changes (from Hackage documentation)

Files

• CHANGELOG.md +21/−1
• README.md +52/−0
• TEST.md +84/−0
• floskell.cabal +46/−46
• src/Floskell.hs +168/−149
• src/Floskell/Attoparsec.hs +41/−0
• src/Floskell/Buffer.hs +5/−7
• src/Floskell/Comments.hs +61/−66
• src/Floskell/Config.hs +96/−34
• src/Floskell/ConfigFile.hs +221/−0
• src/Floskell/Fixities.hs +176/−0
• src/Floskell/Imports.hs +84/−0
• src/Floskell/Pretty.hs +489/−351
• src/Floskell/Printers.hs +78/−80
• src/Floskell/Styles.hs +95/−67
• src/Floskell/Types.hs +48/−37
• src/main/Benchmark.hs +14/−14
• src/main/Main.hs +60/−144
• src/main/Markdone.hs +18/−17
• src/main/Test.hs +45/−25
• stack.yaml +6/−0

@@ -1,3 +1,23 @@-# Floskell 1.0.0+# Floskell 0.10.0 (2019-05-03)++* Updated to haskell-src-exts-1.21.0, with support for `DerivingVia` and `TypeInType`+* Support for custom fixity declarations (with common libraries built in)+* More control over sorting and formatting of imports+* More control over formatting of type signatures+* New option to align `=` with `|` in data declarations+* New option to allow `do`, `case`, and lambda in `try-oneline` layouts+* New option to avoid vertical space between declarations+* New option to tabstop-align right-hand-side of function match clauses+* Improved handling of CPP directives+* Improved positioning of comments+* Better error messages for JSON syntax errors in configuration file+* Many formatting fixes++Incompatible changes:++* `formatting/layout/typesig` has been removed in favor of+  `formatting/layout/type`++# Floskell 0.9.0 (2019-01-25)  * Initial release

@@ -168,6 +168,58 @@ tuple = (1,2) ``` +### Preprocessor Directives (CPP)++Floskell, in general, supports Haskell source with conditional+compilation directives using the `CPP` language extensions.  However,+due to the way this support is implemented, some care must be taken to+not confuse the Haskell source parser.++Floskell treats conditional compilation directives as if they were+simply comments.  As a consequence, the input must still be valid+Haskell when all preprocessor lines are removed.  This is relevant+when using `#if`/`#else`/`#endif` sequences, as Floskell will see both+the if- and else-block in sequence.  For example, the following cannot+be processed with Floskell, as the first declaration of `prettyPrint`+ends with an incomplete `do` block:++```haskell+#if MIN_VERSION_haskell_src_exts(1,21,0)+    prettyPrint (GadtDecl _ name _ _ mfielddecls ty) = do+#else+    prettyPrint (GadtDecl _ name mfielddecls ty) = do+#endif+        pretty name+        operator Declaration "::"+        mayM_ mfielddecls $ \decls -> do+            prettyRecordFields len Declaration decls+            operator Type "->"+        pretty ty+```++Instead, some of the contents of the `do` block have to be duplicated,+so that the contents of the `#if` are valid Haskell on their own.++```haskell+#if MIN_VERSION_haskell_src_exts(1,21,0)+    prettyPrint (GadtDecl _ name _ _ mfielddecls ty) = do+        pretty name+        operator Declaration "::"+        mayM_ mfielddecls $ \decls -> do+            prettyRecordFields len Declaration decls+            operator Type "->"+        pretty ty+#else+    prettyPrint (GadtDecl _ name mfielddecls ty) = do+        pretty name+        operator Declaration "::"+        mayM_ mfielddecls $ \decls -> do+            prettyRecordFields len Declaration decls+            operator Type "->"+        pretty ty+#endif+```+  ## Customization 

@@ -242,6 +242,13 @@   IntNil :: List Int   IntCons :: { val :: Int } -> List Int   deriving (Eq, Ord, Show)++newtype Penalty = Penalty Int+  deriving (Eq, Ord)+  deriving stock (Read, Show)+  deriving newtype (Num)+  deriving anyclass (FromJSON, ToJSON)+  deriving (Semigroup, Monoid) via M.Sum Int ```  ### ClassDecl and InstDecl@@ -459,6 +466,7 @@ ### Var, Con, Lit, Tuple, UnboxedSum, List, and ExpTypeSig  ``` haskell+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnboxedSums #-} @@ -478,6 +486,10 @@ foo = (1 -- the one  , 2) +foo = (1,)+foo = (,2)+foo = (,2,)+ foo = (# #) foo = (# 1, 2 #) foo = (# 1 -- the one@@ -694,6 +706,18 @@   some expression ``` +## Patterns++Long function pattern matches allow linebreaks.++``` haskell+doThing+  (Constructor field1 field2 field3)+  (Constructor field1 field2 field3)+  (Constructor field1 field2 field3)+  = undefined+```+ ## Onside  Indent within onside started on non-empty line should still not stack.@@ -747,4 +771,64 @@   if condition -- comment     then this     else that+```++## Comments++Don't be too eager in assigning comments to the following AST node.++``` haskell+data Foo = Foo+  { fooBar :: Text+  -- ^A comment, long enough to end up on its own line, or at least I hope so.+  } deriving (Eq)+```++Keep comments together and aligned.++``` haskell+-- block+-- one+data Foo = Foo  -- some+                -- comments+         | Quux -- more+                -- comments+-- block+-- two+```++Only comments.++``` haskell+-- some comment+```++Make sure no comments are dropped from operators or argument.++``` haskell+foo = some -- comment 1+      -- comment 2+      %~ -- comment 3+      argument -- comment 4+```++## Indentation and Line Prefixes++Preserving indentation and line prefixes so that Floskell can be run+on individual declarations and quoted haskell code.++``` haskell+    data Enum =+     One   -- Foo+     | Two   -- Bar+     | Three -- Baz+```++``` haskell+>+>    data Enum =+>     One   -- Foo+>     | Two   -- Bar+>     | Three -- Baz+> ```

@@ -1,5 +1,5 @@ name:                floskell-version:             0.9.0+version:             0.10.0 synopsis:            A flexible Haskell source code pretty printer description:         A flexible Haskell source code pretty printer.                      .@@ -21,6 +21,7 @@                      CHANGELOG.md                      BENCHMARK.md                      TEST.md+                     stack.yaml  source-repository head     type:           git@@ -30,43 +31,46 @@   hs-source-dirs:    src/   ghc-options:       -Wall   exposed-modules:   Floskell+                     Floskell.Attoparsec                      Floskell.Buffer                      Floskell.Comments                      Floskell.Config+                     Floskell.ConfigFile+                     Floskell.Fixities+                     Floskell.Imports                      Floskell.Pretty                      Floskell.Printers                      Floskell.Styles                      Floskell.Types-  build-depends:     base >= 4.7 && <5-                   , aeson-                   , containers-                   , unordered-containers-                   , data-default-                   , haskell-src-exts >= 1.20-                   , monad-loops-                   , monad-dijkstra-                   , mtl-                   , bytestring-                   , utf8-string-                   , transformers-                   , text+  build-depends:     base >=4.9 && <4.13+                   , aeson >=0.11.3.0 && <1.5+                   , attoparsec >=0.13.1.0 && <0.14+                   , bytestring >=0.10.8.1 && <0.11+                   , containers >=0.5.7.1 && <0.7+                   , data-default >=0.7.1.1 && <0.8+                   , directory >=1.2.6.2 && <1.4+                   , filepath >=1.4.1.0 && <1.5+                   , haskell-src-exts >= 1.19 && <1.22+                   , monad-dijkstra >=0.1.1 && <0.2+                   , mtl >=2.2.1 && <2.3+                   , text >=1.2.2.2 && <1.3+                   , transformers >=0.5.2.0 && <0.6+                   , unordered-containers >=0.2.8.0 && <0.3+                   , utf8-string >=1.0.1.1 && <1.1  executable floskell   hs-source-dirs:    src/main   ghc-options:       -Wall -Wno-missing-home-modules -optP-Wno-nonportable-include-path   main-is:           Main.hs-  build-depends:     base >= 4 && < 5+  build-depends:     base >=4.9 && <4.13                    , floskell-                   , aeson-                   , aeson-pretty-                   , bytestring-                   , optparse-applicative-                   , haskell-src-exts-                   , ghc-prim-                   , directory-                   , filepath-                   , unordered-containers-                   , text+                   , aeson-pretty >=0.8.2 && <0.9+                   , bytestring >=0.10.8.1 && <0.11+                   , directory >=1.2.6.2 && <1.4+                   , ghc-prim >=0.5.0.0 && <0.6+                   , haskell-src-exts >= 1.19 && <1.22+                   , optparse-applicative >=0.12.1.0 && <0.15+                   , text >=1.2.2.2 && <1.3  test-suite floskell-test   type: exitcode-stdio-1.0@@ -74,18 +78,15 @@   ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N   main-is:           Test.hs   other-modules:     Markdone-  build-depends:     base >= 4 && <5+  build-depends:     base >=4.9 && <4.13                    , floskell-                   , haskell-src-exts-                   , monad-loops-                   , mtl-                   , bytestring-                   , utf8-string-                   , hspec-                   , directory-                   , text-                   , deepseq-                   , exceptions+                   , bytestring >=0.10.8.1 && <0.11+                   , deepseq >=1.4.2.0 && <1.5+                   , exceptions >=0.8.3 && <0.12+                   , haskell-src-exts >= 1.19 && <1.22+                   , hspec >=2.2.4 && <2.8+                   , text >=1.2.2.2 && <1.3+                   , utf8-string >=1.0.1.1 && <1.1  benchmark floskell-bench   type: exitcode-stdio-1.0@@ -93,14 +94,13 @@   ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N   main-is:           Benchmark.hs   other-modules:     Markdone-  build-depends:     base >= 4 && < 5+  build-depends:     base >=4.9 && <4.13                    , floskell-                   , bytestring-                   , utf8-string-                   , haskell-src-exts-                   , ghc-prim-                   , directory-                   , criterion-                   , deepseq-                   , exceptions-                   , text+                   , bytestring >=0.10.8.1 && <0.11+                   , criterion >=1.1.1.0 && <1.6+                   , deepseq >=1.4.2.0 && <1.5+                   , exceptions >=0.8.3 && <0.11+                   , ghc-prim >=0.5.0.0 && <0.6+                   , haskell-src-exts >= 1.19 && < 1.22+                   , text >=1.2.2.2 && <1.3+                   , utf8-string >=1.0.1.1 && <1.1

@@ -4,9 +4,18 @@  -- | Haskell indenter. module Floskell-    ( -- * Formatting functions.-      reformat-    , prettyPrint+    ( -- * Configuration+      AppConfig(..)+    , defaultAppConfig+    , findAppConfig+    , findAppConfigIn+    , readAppConfig+    , setStyle+    , setLanguage+    , setExtensions+    , setFixities+      -- * Formatting functions.+    , reformat       -- * Style     , Style(..)     , styles@@ -14,135 +23,189 @@     , defaultExtensions     ) where -import           Data.ByteString            ( ByteString )-import qualified Data.ByteString            as S-import qualified Data.ByteString.Char8      as S8-import qualified Data.ByteString.Internal   as S-import qualified Data.ByteString.Lazy       as L+import           Data.ByteString.Lazy       ( ByteString ) 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 qualified Data.ByteString.Lazy.UTF8  as UTF8 import           Data.List-import qualified Data.Map.Strict            as Map import           Data.Maybe import           Data.Monoid  import qualified Floskell.Buffer            as Buffer import           Floskell.Comments-import           Floskell.Pretty            ( pretty, printComment )-import           Floskell.Styles            ( styles )+import           Floskell.Config+import           Floskell.ConfigFile+import           Floskell.Fixities          ( builtinFixities )+import           Floskell.Pretty            ( pretty )+import           Floskell.Styles            ( Style(..), styles ) import           Floskell.Types  import           Language.Haskell.Exts-                 hiding ( Pretty, Style, parse, prettyPrint, style )+                 hiding ( Comment, Pretty, Style, parse, prettyPrint, style ) import qualified Language.Haskell.Exts      as Exts -data CodeBlock = HaskellSource Int ByteString | CPPDirectives ByteString+data CodeBlock = HaskellSource Int [ByteString] | CPPDirectives [ByteString]     deriving ( Show, Eq ) --- | Format the given source.-reformat :: Style-         -> Language-         -> [Extension]-         -> Maybe FilePath-         -> ByteString-         -> Either String L.ByteString-reformat style language langextensions mfilepath x = preserveTrailingNewline x-    . mconcat . intersperse "\n" <$> mapM processBlock (cppSplitBlocks x)+trimBy :: (a -> Bool) -> [a] -> ([a], [a], [a])+trimBy f xs = (prefix, middle, suffix)   where-    processBlock :: CodeBlock -> Either String L.ByteString-    processBlock (CPPDirectives text) = Right $ L.fromStrict text-    processBlock (HaskellSource offset text) =-        let ls = S8.lines text-            prefix = findPrefix ls-            code = unlines' (map (stripPrefix prefix) ls)-            exts = readExtensions (UTF8.toString code)-            mode'' = case exts of-                Nothing -> mode'-                Just (Nothing, exts') ->-                    mode' { extensions = exts' ++ extensions mode' }-                Just (Just lang, exts') ->-                    mode' { baseLanguage = lang-                          , extensions   = exts' ++ extensions mode'-                          }-        in-            case parseModuleWithComments mode'' (UTF8.toString code) of-                ParseOk (m, comments) ->-                    fmap (addPrefix prefix) (prettyPrint style m comments)-                ParseFailed loc e -> Left $-                    Exts.prettyPrint (loc { srcLine = srcLine loc + offset })-                    ++ ": " ++ e+    (prefix, xs') = span f xs -    unlines' = S.concat . intersperse "\n"+    (suffix', middle') = span f $ reverse xs' -    unlines'' = L.concat . intersperse "\n"+    middle = reverse middle' -    addPrefix :: ByteString -> L8.ByteString -> L8.ByteString-    addPrefix prefix = unlines'' . map (L8.fromStrict prefix <>) . L8.lines+    suffix = reverse suffix' -    stripPrefix :: ByteString -> ByteString -> ByteString-    stripPrefix prefix line = if S.null (S8.dropWhile (== '\n') line)-                              then line-                              else fromMaybe (error "Missing expected prefix")-                                  . s8_stripPrefix prefix $ line+findLinePrefix :: (Char -> Bool) -> [ByteString] -> ByteString+findLinePrefix _ [] = ""+findLinePrefix f (x : xs') = go (L8.takeWhile f x) xs'+  where+    go prefix xs = if all (prefix `L8.isPrefixOf`) xs+                   then prefix+                   else go (L8.take (L8.length prefix - 1) prefix) xs -    findPrefix :: [ByteString] -> ByteString-    findPrefix = takePrefix False . findSmallestPrefix . dropNewlines+findIndent :: (Char -> Bool) -> [ByteString] -> ByteString+findIndent _ [] = ""+findIndent f (x : xs') = go (L8.takeWhile f x) $ filter (not . L8.all f) xs'+  where+    go indent xs = if all (indent `L8.isPrefixOf`) xs+                   then indent+                   else go (L8.take (L8.length indent - 1) indent) xs -    dropNewlines :: [ByteString] -> [ByteString]-    dropNewlines = filter (not . S.null . S8.dropWhile (== '\n'))+preserveVSpace :: Monad m+               => ([ByteString] -> m [ByteString])+               -> [ByteString]+               -> m [ByteString]+preserveVSpace format input = do+    output <- format input'+    return $ prefix ++ output ++ suffix+  where+    (prefix, input', suffix) = trimBy L8.null input -    takePrefix :: Bool -> ByteString -> ByteString-    takePrefix bracketUsed txt = case S8.uncons txt of-        Nothing -> ""-        Just ('>', txt') ->-            if not bracketUsed then S8.cons '>' (takePrefix True txt') else ""-        Just (c, txt') -> if c == ' ' || c == '\t'-                          then S8.cons c (takePrefix bracketUsed txt')-                          else ""+preservePrefix :: Monad m+               => (Int -> [ByteString] -> m [ByteString])+               -> [ByteString]+               -> m [ByteString]+preservePrefix format input = do+    output <- format (prefixLength prefix) input'+    return $ map (prefix <>) output+  where+    prefix = findLinePrefix allowed input -    findSmallestPrefix :: [ByteString] -> ByteString-    findSmallestPrefix [] = ""-    findSmallestPrefix ("" : _) = ""-    findSmallestPrefix (p : ps) =-        let first = S8.head p-            startsWithChar c x = S8.length x > 0 && S8.head x == c-        in-            if all (startsWithChar first) ps-            then S8.cons first (findSmallestPrefix (S.tail p : map S.tail ps))-            else ""+    input' = map (L8.drop $ L8.length prefix) input +    allowed c = c == ' ' || c == '\t' || c == '>'++    prefixLength = sum . map (\c -> if c == '\t' then 8 else 1) . L8.unpack++preserveIndent :: Monad m+               => (Int -> [ByteString] -> m [ByteString])+               -> [ByteString]+               -> m [ByteString]+preserveIndent format input = do+    output <- format (prefixLength prefix) input'+    return $ map (prefix <>) output+  where+    prefix = findIndent allowed input++    input' = map (L8.drop $ L8.length prefix) input++    allowed c = c == ' ' || c == '\t'++    prefixLength = sum . map (\c -> if c == '\t' then 8 else 1) . L8.unpack++withReducedLineLength :: Int -> Config -> Config+withReducedLineLength offset config = config { cfgPenalty = penalty }+  where+    penalty = (cfgPenalty config) { penaltyMaxLineLength =+                                        penaltyMaxLineLength (cfgPenalty config)+                                        - offset+                                  }++-- | Format the given source.+reformat+    :: AppConfig -> Maybe FilePath -> ByteString -> Either String ByteString+reformat config mfilepath input = fmap (L8.intercalate "\n")+    . preserveVSpace (preservePrefix (reformatLines mode cfg)) $+    L8.split '\n' input+  where+    mode = case readExtensions $ UTF8.toString input of+        Nothing -> mode'+        Just (Nothing, exts') ->+            mode' { extensions = exts' ++ extensions mode' }+        Just (Just lang, exts') ->+            mode' { baseLanguage = lang+                  , extensions   = exts' ++ extensions mode'+                  }+     mode' = defaultParseMode { parseFilename = fromMaybe "<stdin>" mfilepath-                             , baseLanguage  = language-                             , extensions    = langextensions+                             , baseLanguage  = appLanguage config+                             , extensions    = appExtensions config+                             , fixities      =+                                   Just $ appFixities config ++ builtinFixities                              } -    preserveTrailingNewline x x' = if not (S8.null x) && S8.last x == '\n'-                                       && not (L8.null x') && L8.last x' /= '\n'-                                   then x' <> "\n"-                                   else x'+    cfg = styleConfig $ appStyle config --- | Break a Haskell code string into chunks, using CPP as a delimiter.--- Lines that start with '#if', '#end', or '#else' are their own chunks, and--- also act as chunk separators. For example, the code------ > #ifdef X--- > x = X--- > y = Y--- > #else--- > x = Y--- > y = X--- > #endif------ will become five blocks, one for each CPP line and one for each pair of declarations.-cppSplitBlocks :: ByteString -> [CodeBlock]-cppSplitBlocks = map (classify . unlines') . groupBy ((==) `on` (cppLine . snd))-    . zip [ 0 .. ] . S8.lines+reformatLines+    :: ParseMode -> Config -> Int -> [ByteString] -> Either String [ByteString]+reformatLines mode config indent = format . filterPreprocessorDirectives   where-    cppLine :: ByteString -> Bool+    config' = withReducedLineLength indent config++    format (code, comments) =+        preserveVSpace (preserveIndent (reformatBlock mode config' comments))+                       code++-- | Format a continuous block of code without CPP directives.+reformatBlock :: ParseMode+              -> Config+              -> [Comment]+              -> Int+              -> [ByteString]+              -> Either String [ByteString]+reformatBlock mode config cpp indent lines =+    case parseModuleWithComments mode code of+        ParseOk (m, comments') ->+            let comments = map makeComment comments'+                ast = annotateWithComments m (mergeComments comments cpp)+            in+                case prettyPrint (pretty ast) config' of+                    Nothing -> Left "Printer failed with mzero call."+                    Just output -> Right $ L8.lines output+        ParseFailed loc e -> Left $+            Exts.prettyPrint (loc { srcLine = srcLine loc }) ++ ": " ++ e+  where+    code = UTF8.toString $ L8.intercalate "\n" lines++    config' = withReducedLineLength indent config++    makeComment (Exts.Comment inline span text) =+        Comment (if inline then InlineComment else LineComment) span text++    mergeComments xs [] = xs+    mergeComments [] ys = ys+    mergeComments xs@(x : xs') ys@(y : ys') =+        if srcSpanStartLine (commentSpan x) < srcSpanStartLine (commentSpan y)+        then x : mergeComments xs' ys+        else y : mergeComments xs ys'++-- | Remove CPP directives from input source, retur+filterPreprocessorDirectives :: [ByteString] -> ([ByteString], [Comment])+filterPreprocessorDirectives lines = (code, comments)+  where+    code = map (\l -> if cppLine l then "" else l) lines++    comments = map makeComment . filter (cppLine . snd) $ zip [ 1 .. ] lines++    makeComment (n, l) =+        Comment PreprocessorDirective+                (SrcSpan "" n 1 n (fromIntegral $ L8.length l + 1))+                (L8.unpack l)+     cppLine src =-        any (`S8.isPrefixOf` src)+        any (`L8.isPrefixOf` src)             [ "#if"             , "#end"             , "#else"@@ -154,47 +217,9 @@             , "#warning"             ] -    unlines' :: [(Int, ByteString)] -> (Int, ByteString)-    unlines' [] = (0, "")-    unlines' xs@((line, _) : _) = (line, S8.unlines $ map snd xs)--    classify :: (Int, ByteString) -> CodeBlock-    classify (ofs, text) =-        if cppLine text then CPPDirectives text else HaskellSource ofs text---- | Print the module.-prettyPrint :: Style-            -> Module SrcSpanInfo-            -> [Comment]-            -> Either a L.ByteString-prettyPrint style m comments =-    let (cs, ast) =-            annotateComments (fromMaybe m $ applyFixities baseFixities m)-                             comments-        csComments = map comInfoComment cs-    in-        Right (runPrinterStyle 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-                                    mapM_ (printComment Nothing)-                                          (reverse csComments)-                                    pretty ast))---- | Pretty print the given printable thing.-runPrinterStyle :: Style -> Printer () -> L.ByteString-runPrinterStyle (Style _name _author _desc st) m =-    maybe (error "Printer failed with mzero call.")-          (Buffer.toLazyByteString . psBuffer)-          (snd <$> execPrinter m-                               (PrintState Buffer.empty-                                           0-                                           0-                                           Map.empty-                                           st-                                           False-                                           Anything))+prettyPrint :: Printer a -> Config -> Maybe ByteString+prettyPrint printer = fmap (Buffer.toLazyByteString . psBuffer . snd)+    . execPrinter printer . initialPrintState  -- | Default extensions. defaultExtensions :: [Extension]@@ -214,9 +239,3 @@     , DoRec -- same     , TypeApplications -- since GHC 8 and haskell-src-exts-1.19     ]---- ,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

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}++module Floskell.Attoparsec ( Position, parseOnly ) where++import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString            as B+import           Data.Semigroup             as Sem+import           Data.Word                  ( Word8 )++data Position = Position { posLine :: !Int, posColumn :: !Int }+    deriving ( Eq, Ord, Show )++instance Sem.Semigroup Position where+    (Position l c) <> (Position l' c') =+        Position (l + l') (if l' > 0 then c' else c + c')++instance Monoid Position where+    mempty = Position 0 0++#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif++advance :: Position -> Word8 -> Position+advance (Position l _) 10 = Position (l + 1) 0+advance (Position l c) _ = Position l (c + 1)++position :: B.ByteString -> Position+position = B.foldl' advance mempty++positionAt :: B.ByteString -> B.ByteString -> Position+positionAt l r = position $ B.take (B.length l - B.length r) l++parseOnly :: AP.Parser a -> B.ByteString -> Either String a+parseOnly p b = case AP.feed (AP.parse p b) B.empty of+    AP.Done _ x -> Right x+    AP.Fail r _ err -> Left $ parseError (positionAt b r) err+    AP.Partial _ -> error "impossible"+  where+    parseError (Position l c) err = err ++ ", at line " ++ show (l + 1)+        ++ ", column " ++ show c

@@ -15,13 +15,11 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy    as BL -import           Data.Int                ( Int64 )- data Buffer =     Buffer { bufferData        :: !Builder -- ^ The current output.            , bufferDataNoSpace :: !Builder -- ^ The current output without trailing spaces.-           , bufferLine        :: !Int64   -- ^ Current line number.-           , bufferColumn      :: !Int64   -- ^ Current column number.+           , bufferLine        :: !Int     -- ^ Current line number.+           , bufferColumn      :: !Int     -- ^ Current column number.            }  -- | An empty output buffer.@@ -39,7 +37,7 @@     buf { bufferData        = newBufferData         , bufferDataNoSpace =               if BS.all (== 32) str then bufferData buf else newBufferData-        , bufferColumn      = bufferColumn buf + fromIntegral (BS.length str)+        , bufferColumn      = bufferColumn buf + BS.length str         }   where     newBufferData = bufferData buf `mappend` BB.byteString str@@ -55,11 +53,11 @@     newBufferData = bufferDataNoSpace buf `mappend` BB.char7 '\n'  -- | Return the current line number, counting from 0.-line :: Buffer -> Int64+line :: Buffer -> Int line = bufferLine  -- | Return the column number, counting from 0.-column :: Buffer -> Int64+column :: Buffer -> Int column = bufferColumn  -- | Return the contents of the output buffer as a lazy ByteString.

@@ -1,16 +1,16 @@ -- | Comment handling.-module Floskell.Comments where+module Floskell.Comments ( annotateWithComments ) where -import           Control.Arrow              ( first, second )+import           Control.Arrow                ( first, second ) import           Control.Monad.State.Strict -import           Data.Foldable              ( traverse_ )-import qualified Data.Map.Strict            as M+import           Data.Foldable                ( traverse_ )+import           Data.List                    ( isPrefixOf )+import qualified Data.Map.Strict              as M  import           Floskell.Types -import           Language.Haskell.Exts-                 hiding ( Pretty, Style, parse, prettyPrint, style )+import           Language.Haskell.Exts.SrcLoc ( SrcSpanInfo(..) )  -- Order by start of span, larger spans before smaller spans. newtype OrderByStart = OrderByStart SrcSpan@@ -34,84 +34,79 @@         `mappend` compare (srcSpanStartLine r) (srcSpanStartLine l)         `mappend` compare (srcSpanStartColumn r) (srcSpanStartColumn l) +onSameLine :: SrcSpan -> SrcSpan -> Bool+onSameLine ss ss' = srcSpanEndLine ss == srcSpanStartLine ss'++isAfterComment :: Comment -> Bool+isAfterComment (Comment PreprocessorDirective _ str) = "#endif" `isPrefixOf` str+isAfterComment (Comment _ _ str) =+    take 1 (dropWhile (== ' ') $ dropWhile (== '-') str) == "^"++isAlignedWith :: Comment -> Comment -> Bool+isAlignedWith (Comment _ before _) (Comment _ after _) =+    srcSpanEndLine before == srcSpanStartLine after - 1+    && srcSpanStartColumn before == srcSpanStartColumn after+ -- | Annotate the AST with comments.-annotateComments :: Traversable ast-                 => ast SrcSpanInfo-                 -> [Comment]-                 -> ([ComInfo], ast NodeInfo)-annotateComments src comments =+annotateWithComments+    :: Traversable ast => ast SrcSpanInfo -> [Comment] -> ast NodeInfo+annotateWithComments src comments =     evalState (do                    traverse_ assignComment comments-                   cis <- gets fst-                   ast <- traverse transferComments src-                   return (cis, ast))-              ([], nodeinfos)+                   traverse transferComments src)+              nodeinfos   where-    nodeinfos :: M.Map SrcSpanInfo NodeInfo-    nodeinfos = foldr (\ssi -> M.insert ssi (NodeInfo ssi [])) M.empty src+    nodeinfos :: M.Map SrcSpanInfo ([Comment], [Comment])+    nodeinfos = foldr (\ssi -> M.insert ssi ([], [])) M.empty src      -- Assign a single comment to the right AST node-    assignComment :: Comment-                  -> State ([ComInfo], M.Map SrcSpanInfo NodeInfo) ()-    assignComment comment@(Comment _ cspan _) =-        -- Find the biggest AST node directly in front of this comment.-        case nodeBefore comment of-            -- Comments before any AST node are handled separately.-            Nothing -> modify $ first $ (:) (ComInfo comment Nothing)--            Just ssi ->-                -- Comments on the same line as the AST node belong to this node.-                if sameline (srcInfoSpan ssi) cspan-                then insertComment After ssi-                else do-                    nodeinfo <- gets ((M.! ssi) . snd)-                    case nodeinfo of-                        -- We've already collected comments for this-                        -- node and this comment is a continuation.-                        NodeInfo _ (ComInfo c' _ : _)-                            | aligned c' comment -> insertComment After ssi+    assignComment+        :: Comment -> State (M.Map SrcSpanInfo ([Comment], [Comment])) ()+    assignComment comment@(Comment _ cspan _) = case surrounding comment of+        (Nothing, Nothing) -> error "No target nodes for comment"+        (Just before, Nothing) -> insertComment After before+        (Nothing, Just after) -> insertComment Before after+        (Just before, Just after) ->+            if srcInfoSpan before `onSameLine` cspan || isAfterComment comment+            then insertComment After before+            else do+                cmts <- gets (M.! before)+                case cmts of+                    -- We've already collected comments for this+                    -- node and this comment is a continuation.+                    (_, c' : _)+                        | c' `isAlignedWith` comment ->+                            insertComment After before -                        -- The comment does not belong to this node.-                        -- If there is a node following this comment,-                        -- assign it to that node, else keep it here,-                        -- anyway.-                        _ -> case nodeAfter comment of-                            Nothing -> insertComment After ssi-                            Just ssi' -> insertComment Before ssi'+                    -- The comment does not belong to this node.+                    -- If there is a node following this comment,+                    -- assign it to that node, else keep it here,+                    -- anyway.+                    _ -> insertComment Before after       where-        sameline :: SrcSpan -> SrcSpan -> Bool-        sameline before after = srcSpanEndLine before == srcSpanStartLine after--        aligned :: Comment -> Comment -> Bool-        aligned (Comment _ before _) (Comment _ after _) =-            srcSpanEndLine before == srcSpanStartLine after - 1-            && srcSpanStartColumn before == srcSpanStartColumn after-         insertComment :: Location                       -> SrcSpanInfo-                      -> State ([ComInfo], M.Map SrcSpanInfo NodeInfo) ()-        insertComment l ssi = modify $ second $-            M.adjust (addComment (ComInfo comment (Just l))) ssi--        addComment :: ComInfo -> NodeInfo -> NodeInfo-        addComment x (NodeInfo s xs) = NodeInfo s (x : xs)+                      -> State (M.Map SrcSpanInfo ([Comment], [Comment])) ()+        insertComment Before ssi = modify $ M.adjust (first (comment :)) ssi+        insertComment After ssi = modify $ M.adjust (second (comment :)) ssi      -- Transfer collected comments into the AST.-    transferComments :: SrcSpanInfo-                     -> State ([ComInfo], M.Map SrcSpanInfo NodeInfo) NodeInfo+    transferComments+        :: SrcSpanInfo+        -> State (M.Map SrcSpanInfo ([Comment], [Comment])) NodeInfo     transferComments ssi = do-        ni <- gets ((M.! ssi) . snd)+        (c, c') <- gets (M.! ssi)         -- Sometimes, there are multiple AST nodes with the same         -- SrcSpan.  Make sure we assign comments to only one of         -- them.-        modify $ second $ M.adjust (\(NodeInfo s _) -> NodeInfo s []) ssi-        return ni { nodeInfoComments = reverse $ nodeInfoComments ni }+        modify $ M.insert ssi ([], [])+        return $ NodeInfo (srcInfoSpan ssi) (reverse c) (reverse c') -    nodeBefore (Comment _ ss _) =-        fmap snd $ OrderByEnd ss `M.lookupLT` spansByEnd+    surrounding (Comment _ ss _) = (nodeBefore ss, nodeAfter ss) -    nodeAfter (Comment _ ss _) =-        fmap snd $ OrderByStart ss `M.lookupGT` spansByStart+    nodeBefore ss = fmap snd $ OrderByEnd ss `M.lookupLT` spansByEnd++    nodeAfter ss = fmap snd $ OrderByStart ss `M.lookupGT` spansByStart      spansByStart = foldr (\ssi -> M.insert (OrderByStart $ srcInfoSpan ssi) ssi)                          M.empty

@@ -17,10 +17,14 @@     , LayoutConfig(..)     , OpConfig(..)     , GroupConfig(..)+    , ImportsGroupOrder(..)+    , ImportsGroup(..)+    , SortImportsRule(..)+    , DeclarationConstruct(..)     , OptionConfig(..)-    , FlexConfig(..)-    , defaultFlexConfig-    , safeFlexConfig+    , Config(..)+    , defaultConfig+    , safeConfig     , cfgMapFind     , cfgOpWs     , cfgGroupWs@@ -39,6 +43,8 @@ import qualified Data.HashMap.Lazy  as HashMap import           Data.Map.Strict    ( Map ) import qualified Data.Map.Strict    as Map+import           Data.Set           ( Set )+import qualified Data.Set           as Set import qualified Data.Text          as T import qualified Data.Text.Encoding as T ( decodeUtf8, encodeUtf8 ) @@ -95,6 +101,7 @@                 , cfgAlignImportModule :: !Bool                 , cfgAlignImportSpec   :: !Bool                 , cfgAlignLetBinds     :: !Bool+                , cfgAlignMatches      :: !Bool                 , cfgAlignRecordFields :: !Bool                 , cfgAlignWhere        :: !Bool                 }@@ -107,6 +114,7 @@                       , cfgAlignImportModule = False                       , cfgAlignImportSpec   = False                       , cfgAlignLetBinds     = False+                      , cfgAlignMatches      = False                       , cfgAlignRecordFields = False                       , cfgAlignWhere        = False                       }@@ -126,6 +134,7 @@                  , cfgIndentLetBinds :: !Indent                  , cfgIndentLetIn :: !Indent                  , cfgIndentMultiIf :: !Indent+                 , cfgIndentTypesig :: !Indent                  , cfgIndentWhereBinds :: !Indent                  }     deriving ( Generic )@@ -145,6 +154,7 @@                        , cfgIndentLetBinds = IndentBy 4                        , cfgIndentLetIn = IndentBy 4                        , cfgIndentMultiIf = IndentBy 4+                       , cfgIndentTypesig = IndentBy 4                        , cfgIndentWhereBinds = IndentBy 2                        } @@ -159,7 +169,7 @@                  , cfgLayoutLet :: !Layout                  , cfgLayoutListComp :: !Layout                  , cfgLayoutRecord :: !Layout-                 , cfgLayoutTypesig :: !Layout+                 , cfgLayoutType :: !Layout                  }     deriving ( Generic ) @@ -174,7 +184,7 @@                        , cfgLayoutLet = Flex                        , cfgLayoutListComp = Flex                        , cfgLayoutRecord = Flex-                       , cfgLayoutTypesig = Flex+                       , cfgLayoutType = Flex                        }  newtype OpConfig = OpConfig { unOpConfig :: ConfigMap Whitespace }@@ -195,44 +205,66 @@                                 , cfgMapOverrides = Map.empty                                 } -data OptionConfig = OptionConfig { cfgOptionSortPragmas           :: !Bool-                                 , cfgOptionSplitLanguagePragmas  :: !Bool-                                 , cfgOptionSortImports           :: !Bool-                                 , cfgOptionSortImportLists       :: !Bool-                                 , cfgOptionPreserveVerticalSpace :: !Bool+data ImportsGroupOrder =+    ImportsGroupKeep | ImportsGroupSorted | ImportsGroupGrouped+    deriving ( Generic )++data ImportsGroup = ImportsGroup { importsPrefixes :: ![String]+                                 , importsOrder    :: !ImportsGroupOrder                                  }     deriving ( Generic ) +data SortImportsRule =+    NoImportSort | SortImportsByPrefix | SortImportsByGroups ![ImportsGroup]++data DeclarationConstruct = DeclModule | DeclClass | DeclInstance | DeclWhere+    deriving ( Eq, Ord, Generic )++data OptionConfig =+    OptionConfig { cfgOptionSortPragmas           :: !Bool+                 , cfgOptionSplitLanguagePragmas  :: !Bool+                 , cfgOptionSortImports           :: !SortImportsRule+                 , cfgOptionSortImportLists       :: !Bool+                 , cfgOptionAlignSumTypeDecl      :: !Bool+                 , cfgOptionFlexibleOneline       :: !Bool+                 , cfgOptionPreserveVerticalSpace :: !Bool+                 , cfgOptionDeclNoBlankLines      :: !(Set DeclarationConstruct)+                 }+    deriving ( Generic )+ instance Default OptionConfig where     def = OptionConfig { cfgOptionSortPragmas           = False                        , cfgOptionSplitLanguagePragmas  = False-                       , cfgOptionSortImports           = False+                       , cfgOptionSortImports           = NoImportSort                        , cfgOptionSortImportLists       = False+                       , cfgOptionAlignSumTypeDecl      = False+                       , cfgOptionFlexibleOneline       = False                        , cfgOptionPreserveVerticalSpace = False+                       , cfgOptionDeclNoBlankLines      = Set.empty                        } -data FlexConfig = FlexConfig { cfgPenalty :: !PenaltyConfig-                             , cfgAlign   :: !AlignConfig-                             , cfgIndent  :: !IndentConfig-                             , cfgLayout  :: !LayoutConfig-                             , cfgOp      :: !OpConfig-                             , cfgGroup   :: !GroupConfig-                             , cfgOptions :: !OptionConfig-                             }+data Config = Config { cfgPenalty :: !PenaltyConfig+                     , cfgAlign   :: !AlignConfig+                     , cfgIndent  :: !IndentConfig+                     , cfgLayout  :: !LayoutConfig+                     , cfgOp      :: !OpConfig+                     , cfgGroup   :: !GroupConfig+                     , cfgOptions :: !OptionConfig+                     }     deriving ( Generic ) -instance Default FlexConfig where-    def = FlexConfig { cfgPenalty = def-                     , cfgAlign   = def-                     , cfgIndent  = def-                     , cfgLayout  = def-                     , cfgOp      = def-                     , cfgGroup   = def-                     , cfgOptions = def-                     }+instance Default Config where+    def = Config { cfgPenalty = def+                 , cfgAlign   = def+                 , cfgIndent  = def+                 , cfgLayout  = def+                 , cfgOp      = def+                 , cfgGroup   = def+                 , cfgOptions = def+                 } -defaultFlexConfig :: FlexConfig-defaultFlexConfig =+defaultConfig :: Config+defaultConfig =     def { cfgOp = OpConfig ((unOpConfig def) { cfgMapOverrides =                                                    Map.fromList opWsOverrides                                              })@@ -248,8 +280,8 @@           )         ] -safeFlexConfig :: FlexConfig -> FlexConfig-safeFlexConfig cfg = cfg { cfgGroup = group, cfgOp = op }+safeConfig :: Config -> Config+safeConfig cfg = cfg { cfgGroup = group, cfgOp = op }   where     group = GroupConfig $         updateOverrides (unGroupConfig $ cfgGroup cfg)@@ -445,14 +477,44 @@ instance FromJSON GroupConfig where     parseJSON = genericParseJSON (recordOptions 0) +instance ToJSON ImportsGroupOrder where+    toJSON = genericToJSON (enumOptions 12)++instance FromJSON ImportsGroupOrder where+    parseJSON = genericParseJSON (enumOptions 12)++instance ToJSON ImportsGroup where+    toJSON = genericToJSON (recordOptions 7)++instance FromJSON ImportsGroup where+    parseJSON x@JSON.Array{} =+        ImportsGroup <$> parseJSON x <*> pure ImportsGroupKeep+    parseJSON x = genericParseJSON (recordOptions 7) x++instance ToJSON SortImportsRule where+    toJSON NoImportSort = toJSON False+    toJSON SortImportsByPrefix = toJSON True+    toJSON (SortImportsByGroups xs) = toJSON xs++instance FromJSON SortImportsRule where+    parseJSON (JSON.Bool False) = return NoImportSort+    parseJSON (JSON.Bool True) = return SortImportsByPrefix+    parseJSON v = SortImportsByGroups <$> parseJSON v++instance ToJSON DeclarationConstruct where+    toJSON = genericToJSON (enumOptions 4)++instance FromJSON DeclarationConstruct where+    parseJSON = genericParseJSON (enumOptions 4)+ instance ToJSON OptionConfig where     toJSON = genericToJSON (recordOptions 9)  instance FromJSON OptionConfig where     parseJSON = genericParseJSON (recordOptions 9) -instance ToJSON FlexConfig where+instance ToJSON Config where     toJSON = genericToJSON (recordOptions 3) -instance FromJSON FlexConfig where+instance FromJSON Config where     parseJSON = genericParseJSON (recordOptions 3)

@@ -0,0 +1,221 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Floskell.ConfigFile+    ( AppConfig(..)+    , defaultAppConfig+    , findAppConfig+    , findAppConfigIn+    , readAppConfig+    , showStyle+    , showLanguage+    , showExtension+    , showFixity+    , lookupStyle+    , lookupLanguage+    , lookupExtension+    , lookupFixity+    , setStyle+    , setLanguage+    , setExtensions+    , setFixities+    ) where++import           Control.Applicative        ( (<|>) )++import           Data.Aeson+                 ( (.:?), (.=), FromJSON(..), ToJSON(..) )+import qualified Data.Aeson                 as JSON+import qualified Data.Aeson.Parser          as JSON ( json' )+import qualified Data.Aeson.Types           as JSON ( typeMismatch )+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString            as BS+import           Data.Char                  ( isLetter, isSpace )+import qualified Data.HashMap.Lazy          as HashMap+import           Data.List                  ( inits )+import qualified Data.Text                  as T++import           Floskell.Attoparsec        ( parseOnly )+import           Floskell.Styles            ( Style(..), styles )++import           GHC.Generics               ( Generic )++import           Language.Haskell.Exts+                 ( Extension(..), Fixity(..), Language(..), classifyExtension+                 , classifyLanguage )+import qualified Language.Haskell.Exts      as HSE++import           System.Directory+                 ( XdgDirectory(..), doesFileExist, findFileWith+                 , getAppUserDataDirectory, getCurrentDirectory+                 , getHomeDirectory, getXdgDirectory )+import           System.FilePath+                 ( joinPath, splitDirectories, takeDirectory )++data AppConfig = AppConfig { appStyle      :: Style+                           , appLanguage   :: Language+                           , appExtensions :: [Extension]+                           , appFixities   :: [Fixity]+                           }+    deriving ( Generic )++instance ToJSON AppConfig where+    toJSON AppConfig{..} =+        JSON.object [ "style" .= showStyle appStyle+                    , "language" .= showLanguage appLanguage+                    , "extensions" .= map showExtension appExtensions+                    , "fixities" .= map showFixity appFixities+                    , "formatting" .= styleConfig appStyle+                    ]++instance FromJSON AppConfig where+    parseJSON (JSON.Object o) = do+        style <- maybe (appStyle defaultAppConfig) lookupStyle <$> o .:? "style"+        language <- maybe (appLanguage defaultAppConfig) lookupLanguage+            <$> o .:? "language"+        extensions <- maybe (appExtensions defaultAppConfig)+                            (map lookupExtension) <$> o .:? "extensions"+        fixities <- maybe (appFixities defaultAppConfig) (map lookupFixity)+            <$> o .:? "fixities"+        let fmt = styleConfig style+        fmt' <- maybe fmt (updateConfig fmt) <$> o .:? "formatting"+        let style' = style { styleConfig = fmt' }+        return $ AppConfig style' language extensions fixities+      where+        updateConfig cfg v = case JSON.fromJSON $ mergeJSON (toJSON cfg) v of+            JSON.Error e -> error e+            JSON.Success x -> x++        mergeJSON JSON.Null r = r+        mergeJSON l JSON.Null = l+        mergeJSON (JSON.Object l) (JSON.Object r) =+            JSON.Object (HashMap.unionWith mergeJSON l r)+        mergeJSON _ r = r++    parseJSON v = JSON.typeMismatch "AppConfig" v++-- | Default program configuration.+defaultAppConfig :: AppConfig+defaultAppConfig = AppConfig (head styles) Haskell2010 [] []++-- | Show name of a style.+showStyle :: Style -> String+showStyle = T.unpack . styleName++-- | Show a Haskell language name.+showLanguage :: Language -> String+showLanguage = show++-- | Show a Haskell language extension.+showExtension :: Extension -> String+showExtension (EnableExtension x) = show x+showExtension (DisableExtension x) = "No" ++ show x+showExtension (UnknownExtension x) = x++-- | Show a fixity declaration.+showFixity :: Fixity -> String+showFixity (Fixity assoc prec op) =+    showAssoc assoc ++ " " ++ show prec ++ " " ++ showOp op+  where+    showAssoc (HSE.AssocNone _) = "infix"+    showAssoc (HSE.AssocLeft _) = "infixl"+    showAssoc (HSE.AssocRight _) = "infixr"++    showOp (HSE.UnQual _ (HSE.Symbol _ symbol)) = symbol+    showOp (HSE.UnQual _ (HSE.Ident _ ident)) = "`" ++ ident ++ "`"+    showOp _ = error "Operator in fixity list not supported"++-- | Lookup a style by name.+lookupStyle :: String -> Style+lookupStyle name = case filter ((== T.pack name) . styleName) styles of+    [] -> error $ "Unknown style: " ++ name+    x : _ -> x++-- | Lookup a language by name.+lookupLanguage :: String -> Language+lookupLanguage name = case classifyLanguage name of+    UnknownLanguage _ -> error $ "Unknown language: " ++ name+    x -> x++-- | Lookup an extension by name.+lookupExtension :: String -> Extension+lookupExtension name = case classifyExtension name of+    UnknownExtension _ -> error $ "Unkown extension: " ++ name+    x -> x++-- | Parse a fixity declaration.+lookupFixity :: String -> Fixity+lookupFixity decl =+    let (assoc, decl') = break isSpace $ dropWhile isSpace decl+        (prec, decl'') = break isSpace $ dropWhile isSpace decl'+        (op, _) = break isSpace $ dropWhile isSpace decl''+    in+        Fixity (readAssoc assoc) (read prec) (readOp op)+  where+    readAssoc "infix" = HSE.AssocNone ()+    readAssoc "infixl" = HSE.AssocLeft ()+    readAssoc "infixr" = HSE.AssocRight ()+    readAssoc assoc = error $ "Unknown associativity: " ++ assoc++    readOp op = HSE.UnQual () $ case op of+        '(' : op' -> HSE.Symbol () (init op')+        '`' : op' -> HSE.Ident () (init op')+        c : _ -> if isLetter c then HSE.Ident () op else HSE.Symbol () op+        _ -> error "Missing operator in infix declaration"++-- | Try to find a configuration file based on current working+-- directory, or in one of the application configuration directories.+findAppConfig :: IO (Maybe FilePath)+findAppConfig = getCurrentDirectory >>= findAppConfigIn++findAppConfigIn :: FilePath -> IO (Maybe FilePath)+findAppConfigIn src = do+    isFile <- doesFileExist src+    let startFrom = if isFile then takeDirectory src else src++    dotfilePaths <- sequence [ getHomeDirectory, getXdgDirectory XdgConfig "" ]+    dotfileConfig <- findFileWith doesFileExist dotfilePaths ".floskell.json"+    userPaths <- sequence [ getAppUserDataDirectory "floskell"+                          , getXdgDirectory XdgConfig "floskell"+                          ]+    userConfig <- findFileWith doesFileExist userPaths "config.json"+    let localPaths =+            map joinPath . reverse . drop 1 . inits . splitDirectories $+            startFrom+    localConfig <- findFileWith doesFileExist localPaths "floskell.json"+    return $ localConfig <|> userConfig <|> dotfileConfig++-- | Load a configuration file.+readAppConfig :: FilePath -> IO AppConfig+readAppConfig file = do+    text <- BS.readFile file+    either (error . (++) (file ++ ": ")) return $ eitherDecodeStrict text++setStyle :: AppConfig -> Maybe String -> AppConfig+setStyle cfg mbStyle =+    cfg { appStyle = maybe (appStyle cfg) lookupStyle mbStyle }++setLanguage :: AppConfig -> Maybe String -> AppConfig+setLanguage cfg mbLanguage =+    cfg { appLanguage = maybe (appLanguage cfg) lookupLanguage mbLanguage }++setExtensions :: AppConfig -> [String] -> AppConfig+setExtensions cfg exts =+    cfg { appExtensions = appExtensions cfg ++ map lookupExtension exts }++setFixities :: AppConfig -> [String] -> AppConfig+setFixities cfg fixities =+    cfg { appFixities = appFixities cfg ++ map lookupFixity fixities }++eitherDecodeStrict :: FromJSON a => BS.ByteString -> Either String a+eitherDecodeStrict i = case parseOnly jsonEOF' i of+    Right x -> case JSON.fromJSON x of+        JSON.Error e -> Left e+        JSON.Success x' -> Right x'+    Left e -> Left e+  where+    jsonEOF' = JSON.json' <* skipSpace <* AP.endOfInput++    skipSpace =+        AP.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09

@@ -0,0 +1,176 @@+-- DO NOT EDIT+-- Edit and run scripts/update-fixities to update the list of builtin fixities+module Floskell.Fixities ( builtinFixities, packageFixities ) where++import           Language.Haskell.Exts.Fixity+                 ( Fixity, baseFixities, infix_, infixl_, infixr_ )++builtinFixities :: [Fixity]+builtinFixities = concatMap snd packageFixities++packageFixities :: [(String, [Fixity])]+packageFixities = [ ("base", baseFixities)+                  , ("aeson", aesonFixities)+                  , ("conduit", conduitFixities)+                  , ("lens", lensFixities)+                  , ("pipes", pipesFixities)+                  , ("servant", servantFixities)+                  ]++aesonFixities :: [Fixity]+aesonFixities =+    -- Data/Aeson/Types/ToJSON.hs+    infixr_ 8 [ ".=" ]+    -- Data/Aeson/Encoding/Internal.hs+    ++ infixr_ 6 [ ">*<" ] ++ infixr_ 6 [ "><" ]+    -- Data/Aeson/TH.hs+    ++ infixr_ 6 [ "<^>" ] ++ infixr_ 4 [ "<%>" ]++conduitFixities :: [Fixity]+conduitFixities =+    -- src/Data/Conduit/Internal/Conduit.hs+    infixr_ 0 [ "$$" ] ++ infixl_ 1 [ "$=" ] ++ infixr_ 2 [ "=$" ]+    ++ infixr_ 2 [ "=$=" ] ++ infixr_ 0 [ "$$+" ] ++ infixr_ 0 [ "$$++" ]+    ++ infixr_ 0 [ "$$+-" ] ++ infixl_ 1 [ "$=+" ] ++ infixr_ 2 [ ".|" ]+    ++ infixr_ 0 [ "=$$+" ] ++ infixr_ 0 [ "=$$++" ] ++ infixr_ 0 [ "=$$+-" ]+    -- src/Data/Conduit/Internal/Pipe.hs+    ++ infixr_ 9 [ "<+<" ] ++ infixl_ 9 [ ">+>" ]++lensFixities :: [Fixity]+lensFixities =+    -- src/System/FilePath/Lens.hs+    infixr_ 4 [ "</>~", "<</>~", "<<</>~", "<.>~", "<<.>~", "<<<.>~" ]+    ++ infix_ 4 [ "</>=", "<</>=", "<<</>=", "<.>=", "<<.>=", "<<<.>=" ]+    -- src/Data/Bits/Lens.hs+    ++ infixr_ 4 [ ".|.~", ".&.~", "<.|.~", "<.&.~", "<<.|.~", "<<.&.~" ]+    ++ infix_ 4 [ ".|.=", ".&.=", "<.|.=", "<.&.=", "<<.|.=", "<<.&.=" ]+    -- src/Control/Lens/Fold.hs+    ++ infixl_ 8 [ "^..", "^?", "^?!", "^@..", "^@?", "^@?!" ]+    -- src/Control/Lens/Indexed.hs+    ++ infixr_ 9 [ "<.>", "<.", ".>" ]+    -- src/Control/Lens/Setter.hs+    ++ infixr_ 4+               [ "%@~"+               , ".@~"+               , ".~"+               , "+~"+               , "*~"+               , "-~"+               , "//~"+               , "^~"+               , "^^~"+               , "**~"+               , "&&~"+               , "<>~"+               , "||~"+               , "%~"+               , "<.~"+               , "?~"+               , "<?~"+               ]+    ++ infix_ 4+              [ "%@="+              , ".@="+              , ".="+              , "+="+              , "*="+              , "-="+              , "//="+              , "^="+              , "^^="+              , "**="+              , "&&="+              , "<>="+              , "||="+              , "%="+              , "<.="+              , "?="+              , "<?="+              ] ++ infixr_ 2 [ "<~" ]+    -- src/Control/Lens/Cons.hs+    ++ infixr_ 5 [ "<|", "`cons`" ] ++ infixl_ 5 [ "|>", "`snoc`" ]+    ++ infixr_ 5 [ ":<" ] ++ infixl_ 5 [ ":>" ]+    -- src/Control/Lens/Plated.hs+    ++ infixr_ 9 [ "..." ]+    -- src/Control/Lens/Getter.hs+    ++ infixl_ 8 [ "^.", "^@." ]+    -- src/Control/Lens/Zoom.hs+    ++ infixr_ 2 [ "`zoom`", "`magnify`" ]+    -- src/Control/Lens/Lens.hs+    ++ infixl_ 8 [ "^#" ]+    ++ infixr_ 4+               [ "%%@~"+               , "<%@~"+               , "<<%@~"+               , "%%~"+               , "<+~"+               , "<*~"+               , "<-~"+               , "<//~"+               , "<^~"+               , "<^^~"+               , "<**~"+               , "<&&~"+               , "<||~"+               , "<<>~"+               , "<%~"+               , "<<%~"+               , "<<.~"+               , "<<?~"+               , "<#~"+               , "#~"+               , "#%~"+               , "<#%~"+               , "#%%~"+               ]+    ++ infix_ 4+              [ "%%@="+              , "<%@="+              , "<<%@="+              , "%%="+              , "<+="+              , "<*="+              , "<-="+              , "<//="+              , "<^="+              , "<^^="+              , "<**="+              , "<&&="+              , "<||="+              , "<<>="+              , "<%="+              , "<<%="+              , "<<.="+              , "<<?="+              , "<#="+              , "#="+              , "#%="+              , "<#%="+              , "#%%="+              ] ++ infixr_ 2 [ "<<~" ] ++ infixl_ 1 [ "??", "&~" ]+    ++ infixl_ 1 [ "&" ] ++ infixl_ 1 [ "<&>" ]+    -- src/Control/Lens/Review.hs+    ++ infixr_ 8 [ "#" ]+    -- src/Control/Lens/Traversal.hs+    ++ infixl_ 5 [ "`failing`" ]++pipesFixities :: [Fixity]+pipesFixities =+    -- src/Pipes.hs+    infixl_ 4 [ "<~" ] ++ infixr_ 4 [ "~>" ] ++ infixl_ 5 [ "~<" ]+    ++ infixr_ 5 [ ">~" ] ++ infixl_ 7 [ ">->" ] ++ infixr_ 7 [ "<-<" ]+    -- src/Pipes/Core.hs+    ++ infixl_ 3 [ "//>" ] ++ infixr_ 3 [ "<\\\\" ]+    ++ infixr_ 4 [ "/>/", ">\\\\" ] ++ infixl_ 4 [ "\\<\\", "//<" ]+    ++ infixl_ 5 [ "\\>\\" ] ++ infixr_ 5 [ "/</" ] ++ infixl_ 6 [ "<<+" ]+    ++ infixr_ 6 [ "+>>" ] ++ infixl_ 7 [ ">+>", ">>~" ]+    ++ infixr_ 7 [ "<+<", "~<<" ] ++ infixl_ 8 [ "<~<" ] ++ infixr_ 8 [ ">~>" ]++servantFixities :: [Fixity]+servantFixities =+    -- src/Servant/API/Sub.hs+    infixr_ 4 [ ":>" ]+    -- src/Servant/API/Alternative.hs+    ++ infixr_ 3 [ ":<|>" ]+    -- src/Servant/API/Generic.hs+    ++ infixl_ 0 [ ":-" ]

@@ -0,0 +1,84 @@+{-# LANGUAGE TupleSections #-}++module Floskell.Imports ( sortImports, groupImports, splitImports ) where++import           Control.Monad.Trans.State    ( State, execState, gets, modify )++import           Data.Function                ( on )+import           Data.List+                 ( groupBy, inits, intercalate, sortOn, sortOn, unfoldr )+import qualified Data.Map                     as M+import           Data.Monoid                  ( First(..) )++import           Floskell.Config+                 ( ImportsGroup(..), ImportsGroupOrder(..) )++import           Language.Haskell.Exts.Syntax ( ImportDecl(..), ModuleName(..) )++moduleName :: ImportDecl a -> String+moduleName i = case importModule i of+    (ModuleName _ s) -> s++splitOn :: Char -> String -> [String]+splitOn c = unfoldr go+  where+    go [] = Nothing+    go x = Just $ drop 1 <$> break (== c) x++modulePrefixes :: String -> [String]+modulePrefixes = map (intercalate ".") . reverse . inits . splitOn '.'++data St a = St { stIndex  :: M.Map String Int+               , stGroups :: M.Map Int (ImportsGroup, [ImportDecl a])+               , stRest   :: [ImportDecl a]+               }++commonPrefixLength :: Eq a => [[a]] -> Int+commonPrefixLength = go 0+  where+    go l [] = l+    go l ([] : _) = l+    go l ((x : xs) : ys) =+        if all ((== [ x ]) . take 1) ys then go (l + 1) (xs : ys) else l++sortImports :: [ImportDecl a] -> [ImportDecl a]+sortImports = sortOn moduleName++groupImports :: Int -> [ImportDecl a] -> [[ImportDecl a]]+groupImports n = groupBy ((==) `on` prefix n)+  where+    prefix l = take 1 . drop l . splitOn '.' . moduleName++lookupFirst :: Ord a => [a] -> M.Map a b -> Maybe b+lookupFirst ks m = getFirst . mconcat $ map (First . (`M.lookup` m)) ks++placeImport :: ImportDecl a -> State (St a) ()+placeImport i = do+    idx <- gets (lookupFirst (modulePrefixes $ moduleName i) . stIndex)+    case idx of+        Just idx' -> modify $ \s -> s { stGroups = placeAt idx' (stGroups s) }+        Nothing -> modify $ \s -> s { stRest = stRest s ++ [ i ] }+  where+    placeAt = M.adjust (fmap (++ [ i ]))++splitImports :: [ImportsGroup] -> [ImportDecl a] -> [[ImportDecl a]]+splitImports groups imports = extract $+    execState (mapM_ placeImport imports) initial+  where+    initial = St { stIndex  = M.fromList . concat $+                       zipWith (\n g -> map (, n) (importsPrefixes g))+                               [ 0 .. ]+                               groups+                 , stGroups = M.fromList $+                       zipWith (\n g -> (n, (g, []))) [ 0 .. ] groups+                 , stRest   = []+                 }++    extract s = filter (not . null) $+        concatMap maybeSortAndGroup (M.elems $ stGroups s) ++ [ stRest s ]++    maybeSortAndGroup (g, is) = case importsOrder g of+        ImportsGroupKeep -> [ is ]+        ImportsGroupSorted -> [ sortImports is ]+        ImportsGroupGrouped -> groupImports (commonPrefixLength $+                                             importsPrefixes g) $ sortImports is

@@ -1,34 +1,33 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Floskell.Pretty where+module Floskell.Pretty ( Pretty(..), pretty ) where -import           Control.Applicative            ( (<|>) )+import           Control.Applicative          ( (<|>) ) import           Control.Monad                  ( forM_, guard, replicateM_, unless, void, when )-import           Control.Monad.State.Strict     ( get, gets, modify )--import           Data.ByteString                ( ByteString )-import qualified Data.ByteString                as BS-import qualified Data.ByteString.Char8          as BS8-import qualified Data.ByteString.Lazy           as BL+import           Control.Monad.State.Strict   ( get, gets, modify ) -import           Data.List                      ( groupBy, sortBy, sortOn )-import           Data.Maybe                     ( catMaybes, fromMaybe )+import           Data.Bool                    ( bool )+import           Data.ByteString              ( ByteString )+import qualified Data.ByteString              as BS+import qualified Data.ByteString.Char8        as BS8+import qualified Data.ByteString.Lazy         as BL+import           Data.List                    ( groupBy, sortBy, sortOn )+import           Data.Maybe                   ( catMaybes, fromMaybe )+import qualified Data.Set                     as Set -import qualified Floskell.Buffer                as Buffer+import qualified Floskell.Buffer              as Buffer import           Floskell.Config+import           Floskell.Imports+                 ( groupImports, sortImports, splitImports ) import           Floskell.Printers- import           Floskell.Types -import           Language.Haskell.Exts.Comments ( Comment(..) )-import qualified Language.Haskell.Exts.Pretty   as HSE--import           Language.Haskell.Exts.SrcLoc-                 ( SrcSpan(..), noSrcSpan, srcInfoSpan )+import qualified Language.Haskell.Exts.Pretty as HSE import           Language.Haskell.Exts.Syntax  -- | Like `span`, but comparing adjacent items.@@ -60,7 +59,9 @@            => (ast NodeInfo -> Maybe (ast NodeInfo, ast NodeInfo))            -> ast NodeInfo            -> [ast NodeInfo]-flattenApp fn = go . amap (\info -> info { nodeInfoComments = [] })+flattenApp fn = go . amap (\info -> info { nodeInfoLeadingComments  = []+                                         , nodeInfoTrailingComments = []+                                         })   where     go x = case fn x of         Just (lhs, rhs) -> let lhs' = go $ copyComments Before x lhs@@ -74,7 +75,9 @@     => (ast1 NodeInfo -> Maybe (ast1 NodeInfo, ast2 NodeInfo, ast1 NodeInfo))     -> ast1 NodeInfo     -> (ast1 NodeInfo, [(ast2 NodeInfo, ast1 NodeInfo)])-flattenInfix fn = go . amap (\info -> info { nodeInfoComments = [] })+flattenInfix fn = go . amap (\info -> info { nodeInfoLeadingComments  = []+                                           , nodeInfoTrailingComments = []+                                           })   where     go x = case fn x of         Just (lhs, op, rhs) ->@@ -84,27 +87,25 @@                 (lhs', ops ++ (op, lhs'') : ops')         Nothing -> (x, []) --- | Syntax shortcut for Pretty Printers.-type PrettyPrinter f = f NodeInfo -> Printer ()- -- | Pretty printing prettyHSE using haskell-src-exts pretty printer-prettyHSE :: HSE.Pretty (ast NodeInfo) => PrettyPrinter ast+prettyHSE :: HSE.Pretty (ast NodeInfo) => ast NodeInfo -> Printer () prettyHSE ast = string $ HSE.prettyPrint ast  -- | Type class for pretty-printable types. class Pretty ast where-    prettyPrint :: PrettyPrinter ast-    default prettyPrint :: HSE.Pretty (ast NodeInfo) => PrettyPrinter ast+    prettyPrint :: ast NodeInfo -> Printer ()+    default prettyPrint+        :: HSE.Pretty (ast NodeInfo) => ast NodeInfo -> Printer ()     prettyPrint = prettyHSE  -- | Pretty print a syntax tree with annotated comments-pretty :: (Annotated ast, Pretty ast) => PrettyPrinter ast+pretty :: (Annotated ast, Pretty ast) => ast NodeInfo -> Printer () pretty ast = do     printComments Before ast     prettyPrint ast     printComments After ast -prettyOnside :: (Annotated ast, Pretty ast) => PrettyPrinter ast+prettyOnside :: (Annotated ast, Pretty ast) => ast NodeInfo -> Printer () prettyOnside ast = do     eol <- gets psEolComment     when eol newline@@ -116,23 +117,15 @@             printComments After ast         else onside $ pretty ast --- | Empty NodeInfo-noNodeInfo :: NodeInfo-noNodeInfo = NodeInfo noSrcSpan []- -- | Compare two AST nodes ignoring the annotation-compareAST :: (Functor ast, Ord (ast ()))-           => ast NodeInfo-           -> ast NodeInfo-           -> Ordering+compareAST+    :: (Functor ast, Ord (ast ())) => ast NodeInfo -> ast NodeInfo -> Ordering compareAST a b = void a `compare` void b --- | Return comments with matching location.-filterComments :: Annotated a-               => (Maybe Location -> Bool)-               -> a NodeInfo-               -> [ComInfo]-filterComments f = filter (f . comInfoLocation) . nodeInfoComments . ann+-- | Return leading comments.+filterComments :: Annotated a => Location -> a NodeInfo -> [Comment]+filterComments Before = nodeInfoLeadingComments . ann+filterComments After = nodeInfoTrailingComments . ann  -- | Copy comments from one AST node to another. copyComments :: (Annotated ast1, Annotated ast2)@@ -140,63 +133,73 @@              -> ast1 NodeInfo              -> ast2 NodeInfo              -> ast2 NodeInfo-copyComments loc from to = amap updateComments to-  where-    updateComments info =-        info { nodeInfoComments = oldComments ++ newComments }--    oldComments = filterComments (/= Just loc) to--    newComments = filterComments (== Just loc) from+copyComments Before from to =+    amap (\n ->+          n { nodeInfoLeadingComments = nodeInfoLeadingComments $ ann from })+         to+copyComments After from to =+    amap (\n ->+          n { nodeInfoTrailingComments = nodeInfoTrailingComments $ ann from })+         to  -- | Pretty print a comment.-printComment :: Maybe SrcSpan -> Comment -> Printer ()-printComment mayNodespan (Comment inline cspan str) = do-    -- Insert proper amount of space before comment.-    -- This maintains alignment. This cannot force comments-    -- to go before the left-most possible indent (specified by depends).-    case mayNodespan of-        Just nodespan -> do-            let neededSpaces = srcSpanStartColumn cspan-                    - max 1 (srcSpanEndColumn nodespan)-            replicateM_ neededSpaces space-        Nothing -> return ()--    if inline-        then do+printComment :: Int -> Comment -> Printer ()+printComment correction Comment{..} = do+    col <- getNextColumn+    let padding = max 0 $ srcSpanStartColumn commentSpan + correction - col+    case commentType of+        PreprocessorDirective -> do+            nl <- gets psNewline+            unless nl newline+            column 0 $ string commentText+            modify (\s -> s { psEolComment = True })+        InlineComment -> do+            write $ BS.replicate padding 32             write "{-"-            string str+            string commentText             write "-}"-            when (1 == srcSpanStartColumn cspan) $+            when (1 == srcSpanStartColumn commentSpan) $                 modify (\s -> s { psEolComment = True })-        else do+        LineComment -> do+            write $ BS.replicate padding 32             write "--"-            string str+            string commentText             modify (\s -> s { psEolComment = True })  -- | Print comments of a node. printComments :: Annotated ast => Location -> ast NodeInfo -> Printer ()-printComments loc' ast = do-    let correctLocation comment = comInfoLocation comment == Just loc'-        commentsWithLocation = filter correctLocation (nodeInfoComments info)-        comments = map comInfoComment commentsWithLocation+printComments = printCommentsInternal True -    unless (null comments) $ do-        -- Preceeding comments must have a newline before them, but not break onside indent.-        nl <- gets psNewline-        onside' <- gets psOnside-        when nl $ modify $ \s -> s { psOnside = 0 }-        when (loc' == Before && not nl) newline+-- | Print comments of a node, but do not force newline before leading comments.+printComments' :: Annotated ast => Location -> ast NodeInfo -> Printer ()+printComments' = printCommentsInternal False -        forM_ comments $ printComment (Just $ srcInfoSpan $ nodeInfoSpan info)+printCommentsInternal+    :: Annotated ast => Bool -> Location -> ast NodeInfo -> Printer ()+printCommentsInternal nlBefore loc ast = unless (null comments) $ do+    let firstComment = head comments+    -- Preceeding comments must have a newline before them, but not break onside indent.+    nl <- gets psNewline+    onside' <- gets psOnside+    when nl $ modify $ \s -> s { psOnside = 0 }+    when (loc == Before && not nl && nlBefore) newline+    when (loc == After && not nl && notSameLine firstComment) newline -        -- Write newline before restoring onside indent.-        eol <- gets psEolComment-        when (loc' == Before && eol && onside' > 0) newline-        when nl $ modify $ \s -> s { psOnside = onside' }+    col <- getNextColumn+    forM_ comments $ printComment (col - srcSpanEndColumn ssi)++    -- Write newline before restoring onside indent.+    eol <- gets psEolComment+    when (loc == Before && eol && onside' > 0) newline+    when nl $ modify $ \s -> s { psOnside = onside' }   where-    info = ann ast+    ssi = nodeSpan ast +    comments = filterComments loc ast++    notSameLine comment = srcSpanEndLine ssi+        < srcSpanStartLine (commentSpan comment)+ -- | Return the configuration name of an operator opName :: QOp a -> ByteString opName op = case op of@@ -205,14 +208,17 @@  -- | Return the configuration name of an operator opName' :: QName a -> ByteString-opName' (Qual _ _ (Ident _ _)) = "``"-opName' (Qual _ _ (Symbol _ _)) = ""-opName' (UnQual _ (Ident _ _)) = "``"-opName' (UnQual _ (Symbol _ str)) = BS8.pack str+opName' (Qual _ _ name) = opName'' name+opName' (UnQual _ name) = opName'' name opName' (Special _ (FunCon _)) = "->" opName' (Special _ (Cons _)) = ":" opName' (Special _ _) = "" +-- | Return the configuration name of an operator+opName'' :: Name a -> ByteString+opName'' (Ident _ _) = "``"+opName'' (Symbol _ str) = BS8.pack str+ lineDelta :: Annotated ast => ast NodeInfo -> ast NodeInfo -> Int lineDelta prev next = nextLine - prevLine   where@@ -220,19 +226,15 @@      nextLine = minimum (nextNodeLine : nextCommentLines) -    prevNodeLine = srcSpanEndLine $ annSrcSpan prev--    nextNodeLine = srcSpanStartLine $ annSrcSpan next--    annSrcSpan = srcInfoSpan . nodeInfoSpan . ann+    prevNodeLine = srcSpanEndLine $ nodeSpan prev -    prevCommentLines = map (srcSpanEndLine . commentSrcSpan) $-        filterComments (== Just After) prev+    nextNodeLine = srcSpanStartLine $ nodeSpan next -    nextCommentLines = map (srcSpanStartLine . commentSrcSpan) $-        filterComments (== Just Before) next+    prevCommentLines = map (srcSpanEndLine . commentSpan) $+        filterComments After prev -    commentSrcSpan = (\(Comment _ sp _) -> sp) . comInfoComment+    nextCommentLines = map (srcSpanStartLine . commentSpan) $+        filterComments Before next  linedFn :: Annotated ast         => (ast NodeInfo -> Printer ())@@ -256,39 +258,35 @@ linedOnside :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () linedOnside = linedFn prettyOnside +listVOpLen :: LayoutContext -> ByteString -> Printer Int+listVOpLen ctx sep = do+    ws <- getConfig (cfgOpWs ctx sep . cfgOp)+    return $ if wsLinebreak After ws+             then 0+             else BS.length sep + if wsSpace After ws then 1 else 0+ listVinternal :: (Annotated ast, Pretty ast)               => LayoutContext               -> ByteString               -> [ast NodeInfo]               -> Printer ()-listVinternal ctx sep xs = aligned $ do-    ws <- getConfig (cfgOpWs ctx sep . cfgOp)-    nl <- gets psNewline-    col <- getNextColumn-    let correction = if wsLinebreak After ws || length xs < 2-                     then 0-                     else BS.length sep + if wsSpace After ws then 1 else 0-        extraIndent = if nl then correction else 0-        itemCol = col + fromIntegral extraIndent-        sepCol = itemCol - fromIntegral correction-    case xs of-        [] -> newline-        (x : xs') -> column itemCol $ do-            cut $ do-                printCommentsSimple Before x-                cut . onside $ prettyPrint x-                printCommentsSimple After x+listVinternal ctx sep xs = case xs of+    [] -> newline+    (x : xs') -> do+        nl <- gets psNewline+        col <- getNextColumn+        delta <- listVOpLen ctx sep+        let itemCol = if nl && length xs > 1 then col + delta else col+            sepCol = itemCol - delta+        column itemCol $ do+            printComments' Before x+            cut . onside $ prettyPrint x+            printComments After x             forM_ xs' $ \x' -> do                 printComments Before x'                 column sepCol $ operatorV ctx sep                 cut . onside $ prettyPrint x'                 printComments After x'-  where-    printCommentsSimple loc ast =-        let comments = map comInfoComment $ filterComments (== Just loc) ast-        in-            forM_ comments $-            printComment (Just . srcInfoSpan . nodeInfoSpan $ ann ast)  listH :: (Annotated ast, Pretty ast)       => LayoutContext@@ -344,7 +342,8 @@        -> ByteString        -> [ast NodeInfo]        -> Printer ()-listV' = listVinternal+listV' ctx sep xs =+    if length xs > 1 then listVinternal ctx sep xs else mapM_ pretty xs  list' :: (Annotated ast, Pretty ast)       => LayoutContext@@ -368,43 +367,58 @@     write open     write close -listAutoWrap ctx open close sep (x : xs) =-    aligned . groupH ctx open close . aligned $ do-        ws <- getConfig (cfgOpWs ctx sep . cfgOp)-        let correction = if wsLinebreak After ws-                         then 0-                         else BS.length sep + if wsSpace After ws then 1 else 0-        col <- getNextColumn-        pretty x-        forM_ xs $ \x' -> do-            printComments Before x'-            cut $ do-                column (col - fromIntegral correction) $ operator ctx sep-                prettyPrint x'-                printComments After x'+listAutoWrap ctx open close sep xs =+    aligned . groupH ctx open close $ listAutoWrap' ctx sep xs +listAutoWrap' :: (Annotated ast, Pretty ast)+              => LayoutContext+              -> ByteString+              -> [ast NodeInfo]+              -> Printer ()+listAutoWrap' _ _ [] = return ()+listAutoWrap' ctx sep (x : xs) = aligned $ do+    ws <- getConfig (cfgOpWs ctx sep . cfgOp)+    let correction = if wsLinebreak After ws+                     then 0+                     else BS.length sep + if wsSpace After ws then 1 else 0+    col <- getNextColumn+    pretty x+    forM_ xs $ \x' -> do+        printComments Before x'+        cut $ do+            column (col - correction) $ operator ctx sep+            prettyPrint x'+            printComments After x'+ measure :: Printer a -> Printer (Maybe Int) measure p = do     s <- get     let s' = s { psBuffer = Buffer.empty, psEolComment = False }     return $ case execPrinter (oneline p) s' of         Nothing -> Nothing-        Just (_, s'') -> Just . fromIntegral . (\x -> x - psIndentLevel s)+        Just (_, s'') -> Just . (\x -> x - psIndentLevel s) . fromIntegral             . BL.length . Buffer.toLazyByteString $ psBuffer s'' -measureDecl :: Decl NodeInfo -> Printer (Maybe [Int])-measureDecl (PatBind _ pat _ Nothing) = fmap (: []) <$> measure (pretty pat)-measureDecl (FunBind _ matches) = sequence <$> traverse measureMatch matches+measure' :: Printer a -> Printer (Maybe [Int])+measure' p = fmap (: []) <$> measure p++measureMatch :: Match NodeInfo -> Printer (Maybe [Int])+measureMatch (Match _ name pats _ Nothing) = measure' (prettyApp name pats)+measureMatch (InfixMatch _ pat name pats _ Nothing) = measure' go   where-    measureMatch (Match _ name pats _ Nothing) = measure $ do-        pretty name-        space-        inter space $ map pretty pats-    measureMatch (InfixMatch _ pat name pats _ Nothing) = measure $ do+    go = do         pretty pat-        pretty $ VarOp noNodeInfo name-        inter space $ map pretty pats-    measureMatch _ = return Nothing+        withOperatorFormatting Pattern+                               (opName'' name)+                               (prettyHSE $ VarOp noNodeInfo name)+                               id+        inter spaceOrNewline $ map pretty pats+measureMatch _ = return Nothing++measureDecl :: Decl NodeInfo -> Printer (Maybe [Int])+measureDecl (PatBind _ pat _ Nothing) = measure' (pretty pat)+measureDecl (FunBind _ matches) =+    fmap concat . sequence <$> traverse measureMatch matches measureDecl _ = return Nothing  measureClassDecl :: ClassDecl NodeInfo -> Printer (Maybe [Int])@@ -416,7 +430,7 @@ measureInstDecl _ = return Nothing  measureAlt :: Alt NodeInfo -> Printer (Maybe [Int])-measureAlt (Alt _ pat _ Nothing) = fmap (: []) <$> measure (pretty pat)+measureAlt (Alt _ pat _ Nothing) = measure' (pretty pat) measureAlt _ = return Nothing  withComputedTabStop :: TabStop@@ -447,25 +461,6 @@ moduleName :: ModuleName a -> String moduleName (ModuleName _ s) = s -nameLength :: Name a -> Int-nameLength (Ident _ i) = length i-nameLength (Symbol _ s) = 2 + length s--qnameLength :: QName a -> Int-qnameLength (Qual _ mname name) = length (moduleName mname) + nameLength name-    + 1-qnameLength (UnQual _ name) = nameLength name-qnameLength (Special _ con) = case con of-    UnitCon _ -> 2-    ListCon _ -> 2-    FunCon _ -> 2-    TupleCon _ boxed n -> 2 + n + case boxed of-        Boxed -> 2-        Unboxed -> 0-    Cons _ -> 1-    UnboxedSingleCon _ -> 5-    ExprHole _ -> 1- prettyPragmas :: [ModulePragma NodeInfo] -> Printer () prettyPragmas ps = do     splitP <- getOption cfgOptionSplitLanguagePragmas@@ -495,24 +490,20 @@                     else Nothing     withTabStops [ (stopImportModule, alignModule)                  , (stopImportSpec, alignSpec)-                 ] $ if sortP-                     then inter blankline . map lined . groupBy samePrefix $-                         sortOn (moduleName . importModule) is-                     else lined is+                 ] $ case sortP of+        NoImportSort -> lined is+        SortImportsByPrefix -> prettyGroups . groupImports 0 $ sortImports is+        SortImportsByGroups groups -> prettyGroups $ splitImports groups is   where-    samePrefix left right = prefix left == prefix right--    prefix = takeWhile (/= '.') . moduleName . importModule+    prettyGroups = inter blankline . map (inter newline . map (cut . pretty))  skipBlank :: Annotated ast           => (ast NodeInfo -> ast NodeInfo -> Bool)           -> ast NodeInfo           -> ast NodeInfo           -> Bool-skipBlank skip a b = skip a b && null (comments After a)-    && null (comments Before b)-  where-    comments loc = filterComments (== Just loc)+skipBlank skip a b = skip a b && null (filterComments After a)+    && null (filterComments Before b)  skipBlankAfterDecl :: Decl a -> Bool skipBlankAfterDecl a = case a of@@ -546,9 +537,13 @@  prettyDecls :: (Annotated ast, Pretty ast)             => (ast NodeInfo -> ast NodeInfo -> Bool)+            -> DeclarationConstruct             -> [ast NodeInfo]             -> Printer ()-prettyDecls fn = inter blankline . map lined . runs fn+prettyDecls fn dc = inter sep . map lined . runs fn+  where+    sep = bool blankline newline . Set.member dc+        =<< getOption cfgOptionDeclNoBlankLines  prettySimpleDecl :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2)                  => ast1 NodeInfo@@ -568,12 +563,38 @@         pretty rhs  prettyConDecls :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()-prettyConDecls condecls = withLayout cfgLayoutConDecls flex vertical+prettyConDecls condecls = do+    alignedConDecls <- getOption cfgOptionAlignSumTypeDecl+    if alignedConDecls && length condecls > 1+        then withLayout cfgLayoutDeclaration flex' vertical'+        else withLayout cfgLayoutDeclaration flex vertical   where-    flex = listH' Declaration "|" condecls+    flex = do+        operator Declaration "="+        withLayout cfgLayoutConDecls flexDecls verticalDecls -    vertical = listV' Declaration "|" condecls+    flex' = withLayout cfgLayoutConDecls flexDecls' verticalDecls' +    vertical = do+        operatorV Declaration "="+        withLayout cfgLayoutConDecls flexDecls verticalDecls++    vertical' = withLayout cfgLayoutConDecls flexDecls' verticalDecls'++    flexDecls = listAutoWrap' Declaration "|" condecls++    flexDecls' = horizontalDecls' <|> verticalDecls'++    horizontalDecls' = do+        operatorH Declaration "="+        listH' Declaration "|" condecls++    verticalDecls = listV' Declaration "|" condecls++    verticalDecls' = do+        withOperatorFormattingV Declaration "|" (write "=") id+        listV' Declaration "|" condecls+ prettyForall :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () prettyForall vars = do     write "forall "@@ -585,37 +606,21 @@               -> [ast NodeInfo]               -> Type NodeInfo               -> Printer ()-prettyTypesig ctx names ty = withLayout cfgLayoutTypesig flex vertical+prettyTypesig ctx names ty = do+    inter comma $ map pretty names+    atTabStop stopRecordField+    withIndentConfig cfgIndentTypesig align indentby   where-    flex = do-        inter comma $ map pretty names-        atTabStop stopRecordField+    align = alignOnOperator ctx "::" $ pretty ty++    indentby i = indentedBy i $ do         operator ctx "::"+        nl <- gets psNewline+        when nl $ do+            delta <- listVOpLen ctx "->"+            write $ BS.replicate delta 32         pretty ty -    vertical = do-        inter comma $ map pretty names-        atTabStop stopRecordField-        alignOnOperator ctx "::" $ pretty' ty--    pretty' (TyForall _ mtyvarbinds mcontext ty') = do-        forM_ mtyvarbinds $ \tyvarbinds -> do-            write "forall "-            inter space $ map pretty tyvarbinds-            withOperatorFormattingV Type "." (write "." >> space) id-        forM_ mcontext $ \context -> do-            case context of-                (CxSingle _ asst) -> pretty asst-                (CxTuple _ assts) -> list Type "(" ")" "," assts-                (CxEmpty _) -> write "()"-            operatorV Type "=>"-        pretty' ty'-    pretty' (TyFun _ ty' ty'') = do-        pretty ty'-        operatorV Type "->"-        pretty' ty''-    pretty' ty' = pretty ty'- prettyApp :: (Annotated ast1, Annotated ast2, Pretty ast1, Pretty ast2)           => ast1 NodeInfo           -> [ast2 NodeInfo]@@ -632,26 +637,32 @@         pretty fn         withIndent cfgIndentApp $ linedOnside args -prettyInfixApp :: (Annotated ast, Pretty ast, HSE.Pretty (op NodeInfo))-               => (op NodeInfo -> ByteString)-               -> LayoutContext-               -> (ast NodeInfo, [(op NodeInfo, ast NodeInfo)])-               -> Printer ()+prettyInfixApp+    :: (Annotated ast, Pretty ast, Annotated op, HSE.Pretty (op NodeInfo))+    => (op NodeInfo -> ByteString)+    -> LayoutContext+    -> (ast NodeInfo, [(op NodeInfo, ast NodeInfo)])+    -> Printer () prettyInfixApp nameFn ctx (lhs, args) =     withLayout cfgLayoutInfixApp flex vertical   where     flex = do         pretty lhs         forM_ args $ \(op, arg) -> cut $ do-            withOperatorFormatting ctx (nameFn op) (prettyHSE op) id+            withOperatorFormatting ctx (nameFn op) (prettyOp op) id             pretty arg      vertical = do         pretty lhs         forM_ args $ \(op, arg) -> do-            withOperatorFormattingV ctx (nameFn op) (prettyHSE op) id+            withOperatorFormattingV ctx (nameFn op) (prettyOp op) id             pretty arg +    prettyOp op = do+        printComments Before op+        prettyHSE op+        printComments After op+ prettyRecord :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2)              => (ast2 NodeInfo -> Printer (Maybe Int))              -> LayoutContext@@ -704,7 +715,7 @@         catMaybes [ ifNotEmpty prettyPragmas pragmas                   , pretty <$> mhead                   , ifNotEmpty prettyImports imports-                  , ifNotEmpty (prettyDecls skipBlankDecl) decls+                  , ifNotEmpty (prettyDecls skipBlankDecl DeclModule) decls                   ]       where         ifNotEmpty f xs = if null xs then Nothing else Just (f xs)@@ -764,14 +775,13 @@         atTabStop stopImportSpec         withLayout cfgLayoutImportSpecList (flex specs') (vertical specs')       where-        flex imports = do-            when hiding $ write " hiding"-            space+        flex imports = withIndentFlex cfgIndentImportSpecList $ do+            when hiding $ write "hiding "             listAutoWrap Other "(" ")" "," imports          vertical imports = withIndent cfgIndentImportSpecList $ do             when hiding $ write "hiding "-            listAutoWrap Other "(" ")" "," imports+            listV Other "(" ")" "," imports  instance Pretty ImportSpec @@ -803,18 +813,9 @@         depend' (pretty dataornew) $ do             mapM_ pretty mcontext             pretty declhead-            unless (null qualcondecls) $-                withLayout cfgLayoutDeclaration flex vertical+            unless (null qualcondecls) $ prettyConDecls qualcondecls         mapM_ pretty derivings-      where-        flex = do-            operator Declaration "="-            prettyConDecls qualcondecls -        vertical = do-            operatorV Declaration "="-            prettyConDecls qualcondecls-     prettyPrint (GDataDecl _                            dataornew                            mcontext@@ -845,16 +846,8 @@     prettyPrint (DataInsDecl _ dataornew ty qualcondecls derivings) = do         depend' (pretty dataornew >> write " instance") $ do             pretty ty-            withLayout cfgLayoutDeclaration flex vertical-        mapM_ pretty derivings-      where-        flex = do-            operator Declaration "="             prettyConDecls qualcondecls--        vertical = do-            operatorV Declaration "="-            prettyConDecls qualcondecls+        mapM_ pretty derivings      prettyPrint (GDataInsDecl _ dataornew ty mkind gadtdecls derivings) = do         depend' (pretty dataornew >> write " instance") $ do@@ -880,7 +873,7 @@                                                             cfgAlignClass                                                             measureClassDecl                                                             decls $-                prettyDecls skipBlankClassDecl decls+                prettyDecls skipBlankClassDecl DeclClass decls      prettyPrint (InstDecl _ moverlap instrule minstdecls) = do         depend "instance" $ do@@ -890,18 +883,25 @@             write " where"             withIndent cfgIndentClass $                 withComputedTabStop stopRhs cfgAlignClass measureInstDecl decls $-                prettyDecls skipBlankInstDecl decls+                prettyDecls skipBlankInstDecl DeclInstance decls +#if MIN_VERSION_haskell_src_exts(1,20,0)     prettyPrint (DerivDecl _ mderivstrategy moverlap instrule) =         depend "deriving" $ do             mayM_ mderivstrategy $ withPostfix space pretty             write "instance "             mayM_ moverlap $ withPostfix space pretty             pretty instrule+#else+    prettyPrint (DerivDecl _ moverlap instrule) = depend "deriving" $ do+        write "instance "+        mayM_ moverlap $ withPostfix space pretty+        pretty instrule+#endif      prettyPrint (InfixDecl _ assoc mint ops) = onside $ do         pretty assoc-        mayM_ mint $ withPrefix space (int . fromIntegral)+        mayM_ mint $ withPrefix space int         space         inter comma $ map prettyHSE ops @@ -914,6 +914,22 @@     prettyPrint (TypeSig _ names ty) =         onside $ prettyTypesig Declaration names ty +#if MIN_VERSION_haskell_src_exts(1,21,0)+    prettyPrint (PatSynSig _+                           names+                           mtyvarbinds+                           mcontext+                           mtyvarbinds'+                           mcontext'+                           ty) = depend "pattern" $ do+        inter comma $ map pretty names+        operator Declaration "::"+        mapM_ prettyForall mtyvarbinds+        mayM_ mcontext pretty+        mapM_ prettyForall mtyvarbinds'+        mayM_ mcontext' pretty+        pretty ty+#elif MIN_VERSION_haskell_src_exts(1,20,0)     prettyPrint (PatSynSig _ names mtyvarbinds mcontext mcontext' ty) =         depend "pattern" $ do             inter comma $ map pretty names@@ -922,8 +938,20 @@             mayM_ mcontext pretty             mayM_ mcontext' pretty             pretty ty+#else+    prettyPrint (PatSynSig _ name mtyvarbinds mcontext mcontext' ty) =+        depend "pattern" $ do+            pretty name+            operator Declaration "::"+            mapM_ prettyForall mtyvarbinds+            mayM_ mcontext pretty+            mayM_ mcontext' pretty+            pretty ty+#endif -    prettyPrint (FunBind _ matches) = linedOnside matches+    prettyPrint (FunBind _ matches) =+        withComputedTabStop stopRhs cfgAlignMatches measureMatch matches $+        linedOnside matches      prettyPrint (PatBind _ pat rhs mbinds) = do         onside $ do@@ -1058,7 +1086,7 @@         write "where"         withIndent cfgIndentWhereBinds $             withComputedTabStop stopRhs cfgAlignWhere measureDecl decls $-            prettyDecls skipBlankDecl decls+            prettyDecls skipBlankDecl DeclWhere decls      prettyPrint (IPBinds _ ipbinds) = withIndentBy cfgIndentWhere $ do         write "where"@@ -1125,18 +1153,9 @@     prettyPrint (InsData _ dataornew ty qualcondecls derivings) =         depend' (pretty dataornew) $ do             pretty ty-            unless (null qualcondecls) $-                withLayout cfgLayoutDeclaration flex vertical+            unless (null qualcondecls) $ prettyConDecls qualcondecls             mapM_ pretty derivings-      where-        flex = do-            operator Declaration "="-            prettyConDecls qualcondecls -        vertical = do-            operatorV Declaration "="-            prettyConDecls qualcondecls-     prettyPrint (InsGData _ dataornew ty mkind gadtdecls derivings) = do         depend' (pretty dataornew) $ do             pretty ty@@ -1149,14 +1168,31 @@         mapM_ pretty derivings  instance Pretty Deriving where+#if MIN_VERSION_haskell_src_exts(1,20,0)     prettyPrint (Deriving _ mderivstrategy instrules) =         withIndentBy cfgIndentDeriving $ do             write "deriving "-            mayM_ mderivstrategy $ withPostfix space pretty+            prettyStratBefore             case instrules of                 [ i@IRule{} ] -> pretty i                 [ IParen _ i ] -> listAutoWrap Other "(" ")" "," [ i ]                 _ -> listAutoWrap Other "(" ")" "," instrules+            prettyStratAfter+      where+        (prettyStratBefore, prettyStratAfter) = case mderivstrategy of+#if MIN_VERSION_haskell_src_exts(1,21,0)+            Just x@DerivVia{} -> (return (), space *> pretty x)+#endif+            Just x -> (pretty x <* space, return ())+            _ -> (return (), return ())+#else+    prettyPrint (Deriving _ instrules) = withIndentBy cfgIndentDeriving $ do+        write "deriving "+        case instrules of+            [ i@IRule{} ] -> pretty i+            [ IParen _ i ] -> listAutoWrap Other "(" ")" "," [ i ]+            _ -> listAutoWrap Other "(" ")" "," instrules+#endif  instance Pretty ConDecl where     prettyPrint (ConDecl _ name types) = do@@ -1189,6 +1225,15 @@         pretty condecl  instance Pretty GadtDecl where+#if MIN_VERSION_haskell_src_exts(1,21,0)+    prettyPrint (GadtDecl _ name _ _ mfielddecls ty) = do+        pretty name+        operator Declaration "::"+        mayM_ mfielddecls $ \decls -> do+            prettyRecordFields len Declaration decls+            operator Type "->"+        pretty ty+#else     prettyPrint (GadtDecl _ name mfielddecls ty) = do         pretty name         operator Declaration "::"@@ -1196,29 +1241,41 @@             prettyRecordFields len Declaration decls             operator Type "->"         pretty ty+#endif       where         len (FieldDecl _ names _) = measure $ inter comma $ map pretty names  instance Pretty Match where     prettyPrint (Match _ name pats rhs mbinds) = do         onside $ do-            pretty name-            unless (null pats) $ do-                space-                inter space $ map pretty pats+            prettyApp name pats             atTabStop stopRhs             pretty rhs         mapM_ pretty mbinds      prettyPrint (InfixMatch _ pat name pats rhs mbinds) = do         onside $ do-            pretty pat-            pretty $ VarOp noNodeInfo name-            inter space $ map pretty pats+            withLayout cfgLayoutInfixApp flex vertical             atTabStop stopRhs             pretty rhs         mapM_ pretty mbinds+      where+        flex = do+            pretty pat+            withOperatorFormatting Pattern+                                   (opName'' name)+                                   (prettyHSE $ VarOp noNodeInfo name)+                                   id+            inter spaceOrNewline $ map pretty pats +        vertical = do+            pretty pat+            withOperatorFormattingV Pattern+                                    (opName'' name)+                                    (prettyHSE $ VarOp noNodeInfo name)+                                    id+            linedOnside pats+ instance Pretty Rhs where     prettyPrint (UnGuardedRhs _ expr) =         cut $ withLayout cfgLayoutDeclaration flex vertical@@ -1282,7 +1339,10 @@      prettyPrint (InfixA _ ty qname ty') = do         pretty ty-        pretty $ QVarOp noNodeInfo qname+        withOperatorFormatting Type+                               (opName' qname)+                               (prettyHSE $ QVarOp noNodeInfo qname)+                               id         pretty ty'      prettyPrint (IParam _ ipname ty) = prettyTypesig Declaration [ ipname ] ty@@ -1299,74 +1359,126 @@         mapM_ pretty mname  instance Pretty Type where-    prettyPrint (TyForall _ mtyvarbinds mcontext ty) = do-        mapM_ prettyForall mtyvarbinds-        mapM_ pretty mcontext-        pretty ty+    prettyPrint t = do+        layout <- gets psTypeLayout+        case layout of+            TypeFree -> withLayout cfgLayoutType flex vertical+            TypeFlex -> prettyF t+            TypeVertical -> prettyV t+      where+        flex = withTypeLayout TypeFlex $ prettyF t -    prettyPrint (TyFun _ ty ty') = do-        pretty ty-        operator Type "->"-        pretty ty'+        vertical = withTypeLayout TypeVertical $ prettyV t -    prettyPrint (TyTuple _ boxed tys) = case boxed of-        Unboxed -> list Type "(#" "#)" "," tys-        Boxed -> list Type "(" ")" "," tys+        withTypeLayout :: TypeLayout -> Printer () -> Printer ()+        withTypeLayout l p = do+            layout <- gets psTypeLayout+            modify $ \s -> s { psTypeLayout = l }+            p+            modify $ \s -> s { psTypeLayout = layout } -    prettyPrint (TyUnboxedSum _ tys) = list Type "(#" "#)" "|" tys+        prettyF (TyForall _ mtyvarbinds mcontext ty) = do+            mapM_ prettyForall mtyvarbinds+            mapM_ pretty mcontext+            pretty ty -    prettyPrint (TyList _ ty) = group Type "[" "]" $ pretty ty+        prettyF (TyFun _ ty ty') = do+            pretty ty+            operator Type "->"+            pretty ty' -    prettyPrint (TyParArray _ ty) = group Type "[:" ":]" $ pretty ty+        prettyF (TyTuple _ boxed tys) = case boxed of+            Unboxed -> list Type "(#" "#)" "," tys+            Boxed -> list Type "(" ")" "," tys -    prettyPrint (TyApp _ ty ty') = do-        pretty ty-        space-        pretty ty'+#if MIN_VERSION_haskell_src_exts(1,20,0)+        prettyF (TyUnboxedSum _ tys) = list Type "(#" "#)" "|" tys+#endif -    prettyPrint (TyVar _ name) = pretty name+        prettyF (TyList _ ty) = group Type "[" "]" $ pretty ty -    prettyPrint (TyCon _ qname) = pretty qname+        prettyF (TyParArray _ ty) = group Type "[:" ":]" $ pretty ty -    prettyPrint (TyParen _ ty) = parens $ pretty ty+        prettyF (TyApp _ ty ty') = do+            pretty ty+            space+            pretty ty' -    prettyPrint (TyInfix _ ty op ty') = do-        pretty ty-        withOperatorFormatting Type opname (prettyHSE op) id-        pretty ty'-      where-        opname = opName' $ case op of-            PromotedName _ qname -> qname-            UnpromotedName _ qname -> qname+        prettyF (TyVar _ name) = pretty name -    prettyPrint (TyKind _ ty kind) = do-        pretty ty-        operator Type "::"-        pretty kind+        prettyF (TyCon _ qname) = pretty qname -    prettyPrint t@(TyPromoted _ _promoted) = prettyHSE t+        prettyF (TyParen _ ty) = parens . withTypeLayout TypeFree $ pretty ty -    prettyPrint (TyEquals _ ty ty') = do-        pretty ty-        operator Type "~"-        pretty ty'+#if MIN_VERSION_haskell_src_exts(1,20,0)+        prettyF (TyInfix _ ty op ty') = do+            pretty ty+            withOperatorFormatting Type opname (prettyHSE op) id+            pretty ty'+          where+            opname = opName' $ case op of+                PromotedName _ qname -> qname+                UnpromotedName _ qname -> qname+#else+        prettyF (TyInfix _ ty qname ty') = do+            pretty ty+            withOperatorFormatting Type (opName' qname) (prettyHSE qname) id+            pretty ty'+#endif -    prettyPrint (TySplice _ splice) = pretty splice+        prettyF (TyKind _ ty kind) = do+            pretty ty+            operator Type "::"+            pretty kind -    prettyPrint (TyBang _ bangtype unpackedness ty) = do-        pretty unpackedness-        pretty bangtype-        pretty ty+        prettyF ty@(TyPromoted _ _promoted) = prettyHSE ty -    prettyPrint t@(TyWildCard _ _mname) = prettyHSE t+        prettyF (TyEquals _ ty ty') = do+            pretty ty+            operator Type "~"+            pretty ty' -    prettyPrint (TyQuasiQuote _ str str') = do-        write "["-        string str-        write "|"-        string str'-        write "|]"+        prettyF (TySplice _ splice) = pretty splice +        prettyF (TyBang _ bangtype unpackedness ty) = do+            pretty unpackedness+            pretty bangtype+            pretty ty++        prettyF ty@(TyWildCard _ _mname) = prettyHSE ty++        prettyF (TyQuasiQuote _ str str') = do+            write "["+            string str+            write "|"+            string str'+            write "|]"++#if MIN_VERSION_haskell_src_exts(1,21,0)+        prettyF (TyStar _) = write "*"+#endif++        prettyV (TyForall _ mtyvarbinds mcontext ty) = do+            forM_ mtyvarbinds $ \tyvarbinds -> do+                write "forall "+                inter space $ map pretty tyvarbinds+                withOperatorFormattingV Type "." (write "." >> space) id+            forM_ mcontext $ \context -> do+                case context of+                    (CxSingle _ asst) -> pretty asst+                    (CxTuple _ assts) -> list Type "(" ")" "," assts+                    (CxEmpty _) -> write "()"+                operatorV Type "=>"+            prettyV ty++        prettyV (TyFun _ ty ty') = do+            pretty ty+            operatorV Type "->"+            prettyV ty'++        prettyV ty = prettyF ty++#if !MIN_VERSION_haskell_src_exts(1,21,0) instance Pretty Kind where     prettyPrint (KindStar _) = write "*" @@ -1387,6 +1499,7 @@     prettyPrint (KindTuple _ kinds) = list Type "'(" ")" "," kinds      prettyPrint (KindList _ kind) = group Type "'[" "]" $ pretty kind+#endif  instance Pretty TyVarBind where     prettyPrint (KindedVar _ name kind) = parens $ do@@ -1402,6 +1515,11 @@         operator Type "="         pretty ty' +flexibleOneline :: Printer a -> Printer a+flexibleOneline p = do+    allowOneline <- getOption cfgOptionFlexibleOneline+    if allowOneline then ignoreOneline p else p+ instance Pretty Exp where     prettyPrint (Var _ qname) = pretty qname @@ -1439,8 +1557,9 @@         write "\\"         maybeSpace         inter space $ map pretty pats-        operator Expression "->"-        pretty expr+        flexibleOneline $ do+            operator Expression "->"+            pretty expr       where         maybeSpace = case pats of             PIrrPat{} : _ -> space@@ -1456,11 +1575,15 @@             write "in "             prettyOnside expr -        vertical = withIndentFlat cfgIndentLet "let" $ do-            withIndent cfgIndentLetBinds $ pretty (CompactBinds binds)-            newline-            write "in"-            withIndent cfgIndentLetIn $ pretty expr+        vertical = withIndentAfter cfgIndentLet+                                   (do+                                        write "let"+                                        withIndent cfgIndentLetBinds $+                                            pretty (CompactBinds binds))+                                   (do+                                        newline+                                        write "in"+                                        withIndent cfgIndentLetIn $ pretty expr)      prettyPrint (If _ expr expr' expr'') = withLayout cfgLayoutIf flex vertical       where@@ -1474,14 +1597,17 @@             write "else "             prettyOnside expr'' -        vertical = withIndentFlat cfgIndentIf "if " $ do-            prettyOnside expr-            newline-            write "then "-            prettyOnside expr'-            newline-            write "else "-            prettyOnside expr''+        vertical = withIndentAfter cfgIndentIf+                                   (do+                                        write "if "+                                        prettyOnside expr)+                                   (do+                                        newline+                                        write "then "+                                        prettyOnside expr'+                                        newline+                                        write "else "+                                        prettyOnside expr'')      prettyPrint (MultiIf _ guardedrhss) = do         write "if"@@ -1493,15 +1619,15 @@         write " of"         if null alts             then write " { }"-            else withIndent cfgIndentCase $-                withComputedTabStop stopRhs cfgAlignCase measureAlt alts $+            else flexibleOneline . withIndent cfgIndentCase+                . withComputedTabStop stopRhs cfgAlignCase measureAlt alts $                 lined alts -    prettyPrint (Do _ stmts) = do+    prettyPrint (Do _ stmts) = flexibleOneline $ do         write "do"         withIndent cfgIndentDo $ linedOnside stmts -    prettyPrint (MDo _ stmts) = do+    prettyPrint (MDo _ stmts) = flexibleOneline $ do         write "mdo"         withIndent cfgIndentDo $ linedOnside stmts @@ -1509,13 +1635,16 @@         Boxed -> list Expression "(" ")" "," exprs         Unboxed -> list Expression "(#" "#)" "," exprs +#if MIN_VERSION_haskell_src_exts(1,20,0)     prettyPrint (UnboxedSum _ before after expr) = group Expression "(#" "#)"         . inter space $ replicate before (write "|") ++ [ pretty expr ]         ++ replicate after (write "|")+#endif      prettyPrint (TupleSection _ boxed mexprs) = case boxed of-        Boxed -> list Expression "(" ")" "," $ map MayAst mexprs-        Unboxed -> list Expression "(#" "#)" "," $ map MayAst mexprs+        Boxed -> list Expression "(" ")" "," $ map (MayAst noNodeInfo) mexprs+        Unboxed -> list Expression "(#" "#)" "," $+            map (MayAst noNodeInfo) mexprs      prettyPrint (List _ exprs) = list Expression "[" "]" "," exprs @@ -1693,13 +1822,13 @@         prettyPragma "GENERATED" $             inter space                   [ string $ show str-                  , int $ fromIntegral a+                  , int a                   , write ":"-                  , int $ fromIntegral b+                  , int b                   , write "-"-                  , int $ fromIntegral c+                  , int c                   , write ":"-                  , int $ fromIntegral d+                  , int d                   ]         space         pretty expr@@ -1730,7 +1859,7 @@         operator Expression ">>-"         pretty expr' -    prettyPrint (LCase _ alts) = do+    prettyPrint (LCase _ alts) = flexibleOneline $ do         write "\\case"         if null alts             then write " { }"@@ -1738,6 +1867,10 @@                 withComputedTabStop stopRhs cfgAlignCase measureAlt alts $                 lined alts +#if !MIN_VERSION_haskell_src_exts(1,20,0)+    prettyPrint (ExprHole _) = write "_"+#endif+ instance Pretty Alt where     prettyPrint (Alt _ pat rhs mbinds) = do         onside $ do@@ -1764,7 +1897,7 @@     prettyPrint (PNPlusK _ name integer) = do         pretty name         operator Pattern "+"-        int integer+        int $ fromIntegral integer      prettyPrint p@(PInfixApp _ _ qname _) =         prettyInfixApp opName Pattern $ flattenInfix flattenPInfixApp p@@ -1781,9 +1914,11 @@         Boxed -> list Pattern "(" ")" "," pats         Unboxed -> list Pattern "(#" "#)" "," pats +#if MIN_VERSION_haskell_src_exts(1,20,0)     prettyPrint (PUnboxedSum _ before after pat) = group Pattern "(#" "#)"         . inter space $ replicate before (write "|") ++ [ pretty pat ]         ++ replicate after (write "|")+#endif      prettyPrint (PList _ pats) = list Pattern "[" "]" "," pats @@ -1843,7 +1978,9 @@         inter space $ map pretty rpats         write "%>" +#if MIN_VERSION_haskell_src_exts(1,20,0)     prettyPrint (PSplice _ splice) = pretty splice+#endif      prettyPrint (PQuasiQuote _ str str') = do         write "[$"@@ -2034,11 +2171,11 @@         parens $ prettyTypesig Declaration [ name ] ty  instance Pretty Activation where-    prettyPrint (ActiveFrom _ pass) = brackets . int $ fromIntegral pass+    prettyPrint (ActiveFrom _ pass) = brackets $ int pass      prettyPrint (ActiveUntil _ pass) = brackets $ do         write "~"-        int $ fromIntegral pass+        int pass  instance Pretty Annotation where     prettyPrint (Ann _ name expr) = do@@ -2068,7 +2205,9 @@     prettyPrint (ParenFormula _ booleanformula) = parens $ pretty booleanformula  -- Stick with HSE+#if MIN_VERSION_haskell_src_exts(1,20,0) instance Pretty DerivStrategy+#endif  instance Pretty DataOrNew @@ -2126,18 +2265,17 @@     prettyPrint (CompactBinds (IPBinds _ ipbinds)) =         aligned $ linedOnside ipbinds -newtype MayAst a l = MayAst (Maybe (a l))+data MayAst a l = MayAst l (Maybe (a l))  instance Functor a => Functor (MayAst a) where-    fmap _ (MayAst Nothing) = MayAst Nothing-    fmap f (MayAst (Just x)) = MayAst . Just $ fmap f x+    fmap f (MayAst l x) = MayAst (f l) (fmap (fmap f) x)  instance Annotated a => Annotated (MayAst a) where-    ann (MayAst Nothing) = undefined-    ann (MayAst (Just x)) = ann x+    ann (MayAst l x) = maybe l ann x -    amap _ (MayAst Nothing) = MayAst Nothing-    amap f (MayAst (Just x)) = MayAst . Just $ amap f x+    amap f (MayAst l x) = MayAst (f l) (fmap (amap f) x)  instance (Annotated a, Pretty a) => Pretty (MayAst a) where-    prettyPrint (MayAst x) = mapM_ pretty x+    prettyPrint (MayAst _ x) = mapM_ pretty x++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

@@ -5,13 +5,13 @@     , getOption     , cut     , oneline+    , ignoreOneline       -- * Basic printing     , write     , string     , int     , space     , newline-    , linebreak     , blankline     , spaceOrNewline       -- * Tab stops@@ -21,8 +21,10 @@     , mayM_     , withPrefix     , withPostfix+    , withIndentConfig     , withIndent-    , withIndentFlat+    , withIndentFlex+    , withIndentAfter     , withIndentBy     , withLayout     , inter@@ -31,6 +33,7 @@     , column     , aligned     , indented+    , indentedBy     , onside     , depend     , depend'@@ -56,17 +59,14 @@     ) where  import           Control.Applicative        ( (<|>) )- import           Control.Monad              ( guard, unless, when ) import           Control.Monad.Search       ( cost, winner )- import           Control.Monad.State.Strict ( get, gets, modify )  import           Data.ByteString            ( ByteString ) import qualified Data.ByteString            as BS import qualified Data.ByteString.Builder    as BB import qualified Data.ByteString.Lazy       as BL-import           Data.Int                   ( Int64 ) import           Data.List                  ( intersperse ) import qualified Data.Map.Strict            as Map import           Data.Monoid                ( (<>) )@@ -76,25 +76,24 @@ import           Floskell.Types  -- | Query part of the pretty printer config-getConfig :: (FlexConfig -> b) -> Printer b-getConfig f = f <$> gets psUserState+getConfig :: (Config -> b) -> Printer b+getConfig f = f <$> gets psConfig  -- | Query pretty printer options-getOption :: (OptionConfig -> Bool) -> Printer Bool+getOption :: (OptionConfig -> a) -> Printer a getOption f = getConfig (f . cfgOptions)  -- | Line penalty calculation-linePenalty :: Bool -> Int64 -> Printer Penalty+linePenalty :: Bool -> Int -> Printer Penalty linePenalty eol col = do     indentLevel <- gets psIndentLevel     config <- getConfig cfgPenalty     let maxcol = penaltyMaxLineLength config     let pLinebreak = onlyIf eol $ penaltyLinebreak config-    let pIndent = fromIntegral indentLevel * (penaltyIndent config)-    let pOverfull = onlyIf (col > fromIntegral maxcol) $ penaltyOverfull config-            * fromIntegral (col - fromIntegral maxcol)-            + penaltyOverfullOnce config-    return . fromIntegral $ pLinebreak + pIndent + pOverfull+    let pIndent = indentLevel * penaltyIndent config+    let pOverfull = onlyIf (col > maxcol) $ penaltyOverfull config+            * (col - maxcol) + penaltyOverfullOnce config+    return . Penalty $ pLinebreak + pIndent + pOverfull   where     onlyIf cond penalty = if cond then penalty else 0 @@ -106,37 +105,43 @@ cut :: Printer a -> Printer a cut = winner +closeEolComment :: Printer ()+closeEolComment = do+    eol <- gets psEolComment+    when eol newline+ withOutputRestriction :: OutputRestriction -> Printer a -> Printer a withOutputRestriction r p = do     orig <- gets psOutputRestriction-    modify $ \s -> s { psOutputRestriction = max orig r }+    modify $ \s -> s { psOutputRestriction = r }     result <- p     modify $ \s -> s { psOutputRestriction = orig }     return result  oneline :: Printer a -> Printer a oneline p = do-    eol <- gets psEolComment-    when eol $ newline+    closeEolComment     withOutputRestriction NoOverflowOrLinebreak p +ignoreOneline :: Printer a -> Printer a+ignoreOneline = withOutputRestriction Anything+ -- | Write out a string, updating the current position information. write :: ByteString -> Printer () write x = do-    eol <- gets psEolComment-    when eol newline+    closeEolComment     write' x   where     write' x' = do         state <- get-        let indentLevel = fromIntegral (psIndentLevel state)+        let indentLevel = psIndentLevel state             out = if psNewline state                   then BS.replicate indentLevel 32 <> x'                   else x'             buffer = psBuffer state-            newCol = Buffer.column buffer + fromIntegral (BS.length out)+            newCol = Buffer.column buffer + BS.length out         guard $ psOutputRestriction state == Anything || newCol-            < fromIntegral (penaltyMaxLineLength (cfgPenalty (psUserState state)))+            < penaltyMaxLineLength (cfgPenalty (psConfig state))         penalty <- linePenalty False newCol         when (penalty /= mempty) $ cost mempty penalty         modify (\s ->@@ -147,7 +152,7 @@ string = write . BL.toStrict . BB.toLazyByteString . BB.stringUtf8  -- | Write an integral.-int :: Integer -> Printer ()+int :: Int -> Printer () int = string . show  -- | Write a space.@@ -169,9 +174,6 @@                     , psEolComment = False                     }) -linebreak :: Printer ()-linebreak = return () <|> newline- blankline :: Printer () blankline = newline >> newline @@ -184,9 +186,7 @@     oldstops <- gets psTabStops     modify $ \s ->         s { psTabStops =-                foldr (\(k, v) ->-                       Map.alter (const $ fmap (\x -> col + fromIntegral x) v)-                                 k)+                foldr (\(k, v) -> Map.alter (const $ fmap (\x -> col + x) v) k)                       (psTabStops s)                       stops           }@@ -199,7 +199,7 @@     mstop <- gets (Map.lookup tabstop . psTabStops)     mayM_ mstop $ \stop -> do         col <- getNextColumn-        let padding = max 0 $ fromIntegral (stop - col)+        let padding = max 0 (stop - col)         write (BS.replicate padding 32)  mayM_ :: Maybe a -> (a -> Printer ()) -> Printer ()@@ -212,40 +212,48 @@ withPostfix :: Applicative f => f a -> (x -> f b) -> x -> f b withPostfix post f x = f x <* post -withIndent :: (IndentConfig -> Indent) -> Printer a -> Printer a-withIndent fn p = do+withIndentConfig+    :: (IndentConfig -> Indent) -> Printer a -> (Int -> Printer a) -> Printer a+withIndentConfig fn align indentby = do     cfg <- getConfig (fn . cfgIndent)     case cfg of         Align -> align         IndentBy i -> indentby i         AlignOrIndentBy i -> align <|> indentby i++withIndent :: (IndentConfig -> Indent) -> Printer a -> Printer a+withIndent fn p = withIndentConfig fn align indentby   where     align = do         space         aligned p -    indentby i = indent i $ do+    indentby i = indentedBy i $ do         newline         p -withIndentFlat :: (IndentConfig -> Indent)-               -> ByteString-               -> Printer a-               -> Printer a-withIndentFlat fn kw p = do-    cfg <- getConfig (fn . cfgIndent)-    case cfg of-        Align -> align-        IndentBy i -> indentby i-        AlignOrIndentBy i -> align <|> indentby i+withIndentFlex :: (IndentConfig -> Indent) -> Printer a -> Printer a+withIndentFlex fn p = withIndentConfig fn align indentby   where+    align = do+        space+        aligned p++    indentby i = indentedBy i $ do+        spaceOrNewline+        p++withIndentAfter+    :: (IndentConfig -> Indent) -> Printer () -> Printer a -> Printer a+withIndentAfter fn before p = withIndentConfig fn align indentby+  where     align = aligned $ do-        write kw+        withIndentation id before         p      indentby i = do-        write kw-        indent i p+        withIndentation id before+        indentedBy i p  withIndentBy :: (IndentConfig -> Int) -> Printer a -> Printer a withIndentBy fn = withIndent (IndentBy . fn)@@ -262,31 +270,27 @@ inter x = sequence_ . intersperse x  -- | Get the column for the next printed character.-getNextColumn :: Printer Int64+getNextColumn :: Printer Int getNextColumn = do     st <- get     return $ if psEolComment st              then psIndentLevel st + psOnside st              else max (psColumn st) (psIndentLevel st) +withIndentation :: ((Int, Int) -> (Int, Int)) -> Printer a -> Printer a+withIndentation f p = do+    prevIndent <- gets psIndentLevel+    prevOnside <- gets psOnside+    let (newIndent, newOnside) = f (prevIndent, prevOnside)+    modify (\s -> s { psIndentLevel = newIndent, psOnside = newOnside })+    r <- p+    modify (\s -> s { psIndentLevel = prevIndent, psOnside = prevOnside })+    return r+ -- | Set the (newline-) indent level to the given column for the given -- printer.-column :: Int64 -> Printer a -> Printer a-column i p = do-    level <- gets psIndentLevel-    onside' <- gets psOnside-    modify (\s -> s { psIndentLevel = i-                    , psOnside      = if i > level then 0 else onside'-                    })-    m <- p-    modify (\s -> s { psIndentLevel = level, psOnside = onside' })-    return m---- | Increase indentation level by n spaces for the given printer.-indent :: Int -> Printer a -> Printer a-indent i p = do-    level <- gets psIndentLevel-    column (level + fromIntegral i) p+column :: Int -> Printer a -> Printer a+column i = withIndentation $ \(l, o) -> (i, if i > l then 0 else o)  aligned :: Printer a -> Printer a aligned p = do@@ -298,21 +302,21 @@ indented :: Printer a -> Printer a indented p = do     i <- getConfig (cfgIndentOnside . cfgIndent)-    indent i p+    indentedBy i p +-- | Increase indentation level by n spaces for the given printer.+indentedBy :: Int -> Printer a -> Printer a+indentedBy i p = do+    level <- gets psIndentLevel+    column (level + i) p+ -- | Increase indentation level b n spaces for the given printer, but -- ignore increase when computing further indentations. onside :: Printer a -> Printer a onside p = do-    eol <- gets psEolComment-    when eol newline+    closeEolComment     onsideIndent <- getConfig (cfgIndentOnside . cfgIndent)-    level <- gets psIndentLevel-    onside' <- gets psOnside-    modify (\s -> s { psOnside = fromIntegral onsideIndent })-    m <- p-    modify (\s -> s { psIndentLevel = level, psOnside = onside' })-    return m+    withIndentation (\(l, _) -> (l, onsideIndent)) p  depend :: ByteString -> Printer a -> Printer a depend kw = depend' (write kw)@@ -407,9 +411,7 @@                         -> Printer a withOperatorFormattingH ctx op opp fn = do     ws <- getConfig (cfgOpWs ctx op . cfgOp)-    nl <- gets psNewline-    eol <- gets psEolComment-    when (wsSpace Before ws && not nl && not eol) space+    when (wsSpace Before ws) space     fn $ do         opp         when (wsSpace After ws) space@@ -421,11 +423,7 @@                         -> Printer a withOperatorFormattingV ctx op opp fn = do     ws <- getConfig (cfgOpWs ctx op . cfgOp)-    nl <- gets psNewline-    eol <- gets psEolComment-    if wsLinebreak Before ws-        then newline-        else when (wsSpace Before ws && not nl && not eol) space+    if wsLinebreak Before ws then newline else when (wsSpace Before ws) space     fn $ do         opp         if wsLinebreak After ws then newline else when (wsSpace After ws) space

@@ -1,16 +1,25 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module Floskell.Styles ( styles ) where+module Floskell.Styles ( Style(..), styles ) where  import qualified Data.Map        as Map+import qualified Data.Set        as Set+import           Data.Text       ( Text )  import           Floskell.Config-import           Floskell.Types -chrisDoneCfg :: FlexConfig-chrisDoneCfg = safeFlexConfig $-    defaultFlexConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions }+-- | A printer style.+data Style =+    Style { styleName        :: !Text   -- ^ Name of the style, used in the commandline interface.+          , styleAuthor      :: !Text   -- ^ Author of the style definition.+          , styleDescription :: !Text   -- ^ Description of the style.+          , styleConfig      :: !Config -- ^ Style definition.+          }++chrisDoneCfg :: Config+chrisDoneCfg = safeConfig $+    defaultConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions }   where     cfgIndent =         IndentConfig { cfgIndentOnside = 2@@ -25,9 +34,10 @@                      , cfgIndentLetBinds = Align                      , cfgIndentLetIn = Align                      , cfgIndentMultiIf = IndentBy 2+                     , cfgIndentTypesig = Align                      , cfgIndentWhereBinds = Align                      , cfgIndentExportSpecList = IndentBy 2-                     , cfgIndentImportSpecList = IndentBy 7+                     , cfgIndentImportSpecList = AlignOrIndentBy 7                      }      cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline@@ -35,12 +45,12 @@                              , cfgLayoutDeclaration = TryOneline                              , cfgLayoutExportSpecList = TryOneline                              , cfgLayoutIf = Vertical-                             , cfgLayoutImportSpecList = TryOneline+                             , cfgLayoutImportSpecList = Flex                              , cfgLayoutInfixApp = TryOneline                              , cfgLayoutLet = Vertical                              , cfgLayoutListComp = Flex                              , cfgLayoutRecord = Vertical-                             , cfgLayoutTypesig = TryOneline+                             , cfgLayoutType = TryOneline                              }      cfgOp =@@ -51,7 +61,7 @@     opWsOverrides =         [ (ConfigMapKey (Just ",") Nothing, Whitespace WsNone WsBefore False)         , ( ConfigMapKey (Just "record") Nothing-          , Whitespace WsAfter WsAfter False+          , Whitespace WsAfter WsNone False           )         , ( ConfigMapKey (Just ".") (Just Type)           , Whitespace WsAfter WsAfter False@@ -71,20 +81,23 @@      cfgOptions = OptionConfig { cfgOptionSortPragmas           = False                               , cfgOptionSplitLanguagePragmas  = False-                              , cfgOptionSortImports           = False+                              , cfgOptionSortImports           = NoImportSort                               , cfgOptionSortImportLists       = False+                              , cfgOptionAlignSumTypeDecl      = True+                              , cfgOptionFlexibleOneline       = False                               , cfgOptionPreserveVerticalSpace = False+                              , cfgOptionDeclNoBlankLines      = Set.empty                               } -cramerCfg :: FlexConfig-cramerCfg = safeFlexConfig $-    defaultFlexConfig { cfgAlign-                      , cfgIndent-                      , cfgLayout-                      , cfgOp-                      , cfgGroup-                      , cfgOptions-                      }+cramerCfg :: Config+cramerCfg = safeConfig $+    defaultConfig { cfgAlign+                  , cfgIndent+                  , cfgLayout+                  , cfgOp+                  , cfgGroup+                  , cfgOptions+                  }   where     cfgAlign = AlignConfig { cfgAlignLimits       = (10, 25)                            , cfgAlignCase         = False@@ -92,6 +105,7 @@                            , cfgAlignImportModule = True                            , cfgAlignImportSpec   = True                            , cfgAlignLetBinds     = False+                           , cfgAlignMatches      = False                            , cfgAlignRecordFields = True                            , cfgAlignWhere        = False                            }@@ -109,6 +123,7 @@                      , cfgIndentLetBinds = Align                      , cfgIndentLetIn = IndentBy 4                      , cfgIndentMultiIf = IndentBy 4+                     , cfgIndentTypesig = Align                      , cfgIndentWhereBinds = IndentBy 2                      , cfgIndentExportSpecList = IndentBy 4                      , cfgIndentImportSpecList = AlignOrIndentBy 17@@ -119,12 +134,12 @@                              , cfgLayoutDeclaration = Flex                              , cfgLayoutExportSpecList = TryOneline                              , cfgLayoutIf = TryOneline-                             , cfgLayoutImportSpecList = TryOneline+                             , cfgLayoutImportSpecList = Flex                              , cfgLayoutInfixApp = Flex                              , cfgLayoutLet = TryOneline                              , cfgLayoutListComp = TryOneline                              , cfgLayoutRecord = TryOneline-                             , cfgLayoutTypesig = TryOneline+                             , cfgLayoutType = TryOneline                              }      cfgOp =@@ -176,22 +191,26 @@           )         ] -    cfgOptions = OptionConfig { cfgOptionSortPragmas           = True-                              , cfgOptionSplitLanguagePragmas  = True-                              , cfgOptionSortImports           = True-                              , cfgOptionSortImportLists       = True-                              , cfgOptionPreserveVerticalSpace = True-                              }+    cfgOptions =+        OptionConfig { cfgOptionSortPragmas           = True+                     , cfgOptionSplitLanguagePragmas  = True+                     , cfgOptionSortImports           = SortImportsByPrefix+                     , cfgOptionSortImportLists       = True+                     , cfgOptionAlignSumTypeDecl      = False+                     , cfgOptionFlexibleOneline       = False+                     , cfgOptionPreserveVerticalSpace = True+                     , cfgOptionDeclNoBlankLines      = Set.empty+                     } -gibianskyCfg :: FlexConfig-gibianskyCfg = safeFlexConfig $-    defaultFlexConfig { cfgAlign-                      , cfgIndent-                      , cfgLayout-                      , cfgOp-                      , cfgGroup-                      , cfgOptions-                      }+gibianskyCfg :: Config+gibianskyCfg = safeConfig $+    defaultConfig { cfgAlign+                  , cfgIndent+                  , cfgLayout+                  , cfgOp+                  , cfgGroup+                  , cfgOptions+                  }   where     cfgAlign = AlignConfig { cfgAlignLimits       = (10, 25)                            , cfgAlignCase         = True@@ -199,6 +218,7 @@                            , cfgAlignImportModule = True                            , cfgAlignImportSpec   = False                            , cfgAlignLetBinds     = False+                           , cfgAlignMatches      = False                            , cfgAlignRecordFields = False                            , cfgAlignWhere        = False                            }@@ -216,9 +236,10 @@                      , cfgIndentLetBinds = Align                      , cfgIndentLetIn = Align                      , cfgIndentMultiIf = IndentBy 2+                     , cfgIndentTypesig = Align                      , cfgIndentWhereBinds = IndentBy 2                      , cfgIndentExportSpecList = IndentBy 4-                     , cfgIndentImportSpecList = IndentBy 4+                     , cfgIndentImportSpecList = Align                      }      cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline@@ -231,7 +252,7 @@                              , cfgLayoutLet = Vertical                              , cfgLayoutListComp = TryOneline                              , cfgLayoutRecord = TryOneline-                             , cfgLayoutTypesig = TryOneline+                             , cfgLayoutType = TryOneline                              }      cfgOp =@@ -242,7 +263,7 @@     opWsOverrides =         [ (ConfigMapKey (Just ",") Nothing, Whitespace WsAfter WsBefore False)         , ( ConfigMapKey (Just "record") Nothing-          , Whitespace WsAfter WsAfter False+          , Whitespace WsAfter WsNone False           )         , ( ConfigMapKey (Just ".") (Just Type)           , Whitespace WsAfter WsAfter False@@ -262,14 +283,17 @@      cfgOptions = OptionConfig { cfgOptionSortPragmas           = False                               , cfgOptionSplitLanguagePragmas  = False-                              , cfgOptionSortImports           = False+                              , cfgOptionSortImports           = NoImportSort                               , cfgOptionSortImportLists       = False+                              , cfgOptionAlignSumTypeDecl      = False+                              , cfgOptionFlexibleOneline       = False                               , cfgOptionPreserveVerticalSpace = False+                              , cfgOptionDeclNoBlankLines      = Set.empty                               } -johanTibellCfg :: FlexConfig-johanTibellCfg = safeFlexConfig $-    defaultFlexConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions }+johanTibellCfg :: Config+johanTibellCfg = safeConfig $+    defaultConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions }   where     cfgIndent =         IndentConfig { cfgIndentOnside = 4@@ -284,9 +308,10 @@                      , cfgIndentLetBinds = Align                      , cfgIndentLetIn = Align                      , cfgIndentMultiIf = IndentBy 2+                     , cfgIndentTypesig = Align                      , cfgIndentWhereBinds = IndentBy 2                      , cfgIndentExportSpecList = IndentBy 2-                     , cfgIndentImportSpecList = IndentBy 7+                     , cfgIndentImportSpecList = AlignOrIndentBy 7                      }      cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline@@ -294,12 +319,12 @@                              , cfgLayoutDeclaration = TryOneline                              , cfgLayoutExportSpecList = TryOneline                              , cfgLayoutIf = Vertical-                             , cfgLayoutImportSpecList = TryOneline+                             , cfgLayoutImportSpecList = Flex                              , cfgLayoutInfixApp = TryOneline                              , cfgLayoutLet = Vertical                              , cfgLayoutListComp = Flex                              , cfgLayoutRecord = Vertical-                             , cfgLayoutTypesig = TryOneline+                             , cfgLayoutType = TryOneline                              }      cfgOp =@@ -345,45 +370,48 @@      cfgOptions = OptionConfig { cfgOptionSortPragmas           = False                               , cfgOptionSplitLanguagePragmas  = False-                              , cfgOptionSortImports           = False+                              , cfgOptionSortImports           = NoImportSort                               , cfgOptionSortImportLists       = False+                              , cfgOptionAlignSumTypeDecl      = True+                              , cfgOptionFlexibleOneline       = True                               , cfgOptionPreserveVerticalSpace = False+                              , cfgOptionDeclNoBlankLines      = Set.empty                               }  -- | Base style definition. base :: Style-base = Style { styleName         = "base"-             , styleAuthor       = "Enno Cramer"-             , styleDescription  = "Configurable formatting style"-             , styleInitialState = safeFlexConfig defaultFlexConfig+base = Style { styleName        = "base"+             , styleAuthor      = "Enno Cramer"+             , styleDescription = "Configurable formatting style"+             , styleConfig      = safeConfig defaultConfig              }  chrisDone :: Style-chrisDone = Style { styleName         = "chris-done"-                  , styleAuthor       = "Chris Done"-                  , styleDescription  = "Chris Done's style"-                  , styleInitialState = chrisDoneCfg+chrisDone = Style { styleName        = "chris-done"+                  , styleAuthor      = "Chris Done"+                  , styleDescription = "Chris Done's style"+                  , styleConfig      = chrisDoneCfg                   }  cramer :: Style-cramer = Style { styleName         = "cramer"-               , styleAuthor       = "Enno Cramer"-               , styleDescription  = "Enno Cramer's style"-               , styleInitialState = cramerCfg+cramer = Style { styleName        = "cramer"+               , styleAuthor      = "Enno Cramer"+               , styleDescription = "Enno Cramer's style"+               , styleConfig      = cramerCfg                }  gibiansky :: Style-gibiansky = Style { styleName         = "gibiansky"-                  , styleAuthor       = "Andrew Gibiansky"-                  , styleDescription  = "Andrew Gibiansky's style"-                  , styleInitialState = gibianskyCfg+gibiansky = Style { styleName        = "gibiansky"+                  , styleAuthor      = "Andrew Gibiansky"+                  , styleDescription = "Andrew Gibiansky's style"+                  , styleConfig      = gibianskyCfg                   }  johanTibell :: Style-johanTibell = Style { styleName         = "johan-tibell"-                    , styleAuthor       = "Johan Tibell"-                    , styleDescription  = "Johan Tibell's style"-                    , styleInitialState = johanTibellCfg+johanTibell = Style { styleName        = "johan-tibell"+                    , styleAuthor      = "Johan Tibell"+                    , styleDescription = "Johan Tibell's style"+                    , styleConfig      = johanTibellCfg                     }  -- | Styles list, useful for programmatically choosing.

@@ -4,6 +4,7 @@ -- | All types. module Floskell.Types     ( OutputRestriction(..)+    , TypeLayout(..)     , Penalty(..)     , TabStop(..)     , Printer(..)@@ -13,37 +14,40 @@     , psLine     , psColumn     , psNewline-    , Style(..)-    , FlexConfig(..)+    , initialPrintState+    , Config(..)+    , SrcSpan(..)+    , CommentType(..)+    , Comment(..)     , NodeInfo(..)-    , ComInfo(..)+    , noNodeInfo+    , nodeSpan     , Location(..)     ) where  import           Control.Applicative import           Control.Monad- import           Control.Monad.Search                  ( MonadSearch, Search, runSearchBest ) import           Control.Monad.State.Strict                  ( MonadState(..), StateT, execStateT, runStateT ) -import           Data.Int                       ( Int64 )-import           Data.Map.Strict                ( Map )--import           Data.Semigroup                 as Sem-import           Data.Text                      ( Text )+import qualified Data.Map.Strict              as Map+import           Data.Semigroup               as Sem -import           Floskell.Buffer                ( Buffer )-import qualified Floskell.Buffer                as Buffer-import           Floskell.Config                ( FlexConfig(..), Location(..) )+import           Floskell.Buffer              ( Buffer )+import qualified Floskell.Buffer              as Buffer+import           Floskell.Config              ( Config(..), Location(..) ) -import           Language.Haskell.Exts.Comments-import           Language.Haskell.Exts.SrcLoc+import           Language.Haskell.Exts.SrcLoc ( SrcSpan(..), mkSrcSpan, noLoc )+import           Language.Haskell.Exts.Syntax ( Annotated(..) )  data OutputRestriction = Anything | NoOverflow | NoOverflowOrLinebreak     deriving ( Eq, Ord, Show ) +data TypeLayout = TypeFree | TypeFlex | TypeVertical+    deriving ( Eq, Ord, Show )+ newtype Penalty = Penalty Int     deriving ( Eq, Ord, Num, Show ) @@ -55,8 +59,8 @@  instance Monoid Penalty where     mempty = 0-#if !(MIN_VERSION_base(4,11,0)) +#if !(MIN_VERSION_base(4,11,0))     mappend = (<>) #endif @@ -75,41 +79,48 @@ -- | The state of the pretty printer. data PrintState =     PrintState { psBuffer :: !Buffer -- ^ Output buffer-               , psIndentLevel :: !Int64 -- ^ Current indentation level.-               , psOnside :: !Int64 -- ^ Extra indentation is necessary with next line break.-               , psTabStops :: !(Map TabStop Int64) -- ^ Tab stops for alignment.-               , psUserState :: !FlexConfig -- ^ User state.+               , psIndentLevel :: !Int -- ^ Current indentation level.+               , psOnside :: !Int -- ^ Extra indentation is necessary with next line break.+               , psTabStops :: !(Map.Map TabStop Int) -- ^ Tab stops for alignment.+               , psConfig :: !Config -- ^ Style definition.                , psEolComment :: !Bool -- ^ An end of line comment has just been outputted.-               , psOutputRestriction :: OutputRestriction+               , psOutputRestriction :: !OutputRestriction+               , psTypeLayout :: !TypeLayout                } -psLine :: PrintState -> Int64+psLine :: PrintState -> Int psLine = Buffer.line . psBuffer -psColumn :: PrintState -> Int64+psColumn :: PrintState -> Int psColumn = Buffer.column . psBuffer  psNewline :: PrintState -> Bool psNewline = (== 0) . Buffer.column . psBuffer --- | A printer style.-data Style =-    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 :: !FlexConfig -- ^ User state, if needed.-          }+initialPrintState :: Config -> PrintState+initialPrintState config =+    PrintState Buffer.empty 0 0 Map.empty config False Anything TypeFree +data CommentType = InlineComment | LineComment | PreprocessorDirective+    deriving ( Show )++data Comment = Comment { commentType :: !CommentType+                       , commentSpan :: !SrcSpan+                       , commentText :: !String+                       }+    deriving ( Show )+ -- | Information for each node in the AST. data NodeInfo =-    NodeInfo { nodeInfoSpan     :: !SrcSpanInfo -- ^ Location info from the parser.-             , nodeInfoComments :: ![ComInfo] -- ^ Comments which are attached to this node.+    NodeInfo { nodeInfoSpan :: !SrcSpan               -- ^ Location info from the parser.+             , nodeInfoLeadingComments :: ![Comment]  -- ^ Leading comments attached to this node.+             , nodeInfoTrailingComments :: ![Comment] -- ^ Trailing comments attached to this node.              }     deriving ( Show ) --- | Comment with some more info.-data ComInfo =-    ComInfo { comInfoComment  :: !Comment          -- ^ The normal comment type.-            , comInfoLocation :: !(Maybe Location) -- ^ Where the comment lies relative to the node.-            }-    deriving ( Show )+-- | Empty NodeInfo+noNodeInfo :: NodeInfo+noNodeInfo = NodeInfo (mkSrcSpan noLoc noLoc) [] []++nodeSpan :: Annotated ast => ast NodeInfo -> SrcSpan+nodeSpan = nodeInfoSpan . ann

@@ -9,40 +9,40 @@ import           Criterion import           Criterion.Main -import qualified Data.ByteString       as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.UTF8  as UTF8-import qualified Data.Text             as T+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Lazy.UTF8  as UTF8+import qualified Data.Text                  as T  import           Floskell -import           Language.Haskell.Exts ( Language(Haskell2010) )+import           Language.Haskell.Exts      ( Language(Haskell2010) )  import           Markdone  -- | Main benchmarks. main :: IO () main = do-    bytes <- S.readFile "BENCHMARK.md"+    bytes <- L8.readFile "BENCHMARK.md"     !forest <- fmap force (parse (tokenize bytes))     defaultMain [ bgroup (T.unpack $ styleName style) $-                    toCriterion style forest+                    toCriterion (AppConfig style+                                           Haskell2010+                                           defaultExtensions+                                           [])+                                forest                 | style <- styles                 ]  -- | Convert the Markdone document to Criterion benchmarks.-toCriterion :: Style -> [Markdone] -> [Benchmark]-toCriterion style = go+toCriterion :: AppConfig -> [Markdone] -> [Benchmark]+toCriterion config = go   where-    go (Section name children : next) = bgroup (S8.unpack name) (go children)+    go (Section name children : next) = bgroup (L8.unpack name) (go children)         : go next     go (PlainText desc : CodeFence lang code : next) =         if lang == "haskell"         then bench (UTF8.toString desc)-                   (nf (either error id . reformat style-                                                   Haskell2010-                                                   defaultExtensions-                                                   (Just "BENCHMARK.md"))+                   (nf (either error id . reformat config (Just "BENCHMARK.md"))                        code) : go next         else go next     go (PlainText{} : next) = go next

@@ -4,35 +4,30 @@ -- | Main entry point to floskell. module Main ( main ) where -import           Control.Applicative             ( (<|>), many, optional )+import           Control.Applicative             ( many, optional ) import           Control.Exception               ( catch, throw ) -import           Data.Aeson-                 ( (.:?), (.=), FromJSON(..), ToJSON(..) )-import qualified Data.Aeson                      as JSON import qualified Data.Aeson.Encode.Pretty        as JSON ( encodePretty )-import qualified Data.Aeson.Types                as JSON ( typeMismatch )-import qualified Data.ByteString                 as BS import qualified Data.ByteString.Lazy            as BL-import qualified Data.HashMap.Lazy               as HashMap-import           Data.List                       ( inits, sort )+import           Data.List                       ( sort ) import           Data.Maybe                      ( isJust ) import           Data.Monoid                     ( (<>) )- import qualified Data.Text                       as T import           Data.Version                    ( showVersion ) -import           Floskell                        ( reformat, styles )-import           Floskell.Types-                 ( Style(styleName, styleInitialState) )+import           Floskell+                 ( AppConfig(..), Style(..), defaultAppConfig, findAppConfig+                 , readAppConfig, reformat, setExtensions, setFixities+                 , setLanguage, setStyle, styles )+import           Floskell.ConfigFile             ( showFixity )+import           Floskell.Fixities               ( packageFixities )  import           Foreign.C.Error                 ( Errno(..), eXDEV )  import           GHC.IO.Exception                ( ioe_errno )  import           Language.Haskell.Exts-                 ( Extension(..), Language(..), classifyExtension-                 , classifyLanguage, knownExtensions, knownLanguages )+                 ( Extension(..), knownExtensions, knownLanguages )  import           Options.Applicative                  ( ParseError(..), abortOption, argument, execParser, footerDoc@@ -43,69 +38,22 @@ import           Paths_floskell                  ( version )  import           System.Directory-                 ( XdgDirectory(..), copyFile, copyPermissions, doesFileExist-                 , findFileWith, getAppUserDataDirectory, getCurrentDirectory-                 , getHomeDirectory, getTemporaryDirectory, getXdgDirectory-                 , removeFile, renameFile )-import           System.FilePath                 ( joinPath, splitDirectories )+                 ( copyFile, copyPermissions, getTemporaryDirectory, removeFile+                 , renameFile ) import           System.IO-                 ( FilePath, hClose, hFlush, openTempFile )+                 ( FilePath, hClose, hFlush, openTempFile, stdout )  -- | Program options.-data Options = Options { optStyle       :: Maybe String-                       , optLanguage    :: Maybe String-                       , optExtensions  :: [String]-                       , optConfig      :: Maybe FilePath-                       , optPrintConfig :: Bool-                       , optFiles       :: [FilePath]+data Options = Options { optStyle         :: Maybe String+                       , optLanguage      :: Maybe String+                       , optExtensions    :: [String]+                       , optFixities      :: [String]+                       , optConfig        :: Maybe FilePath+                       , optPrintConfig   :: Bool+                       , optPrintFixities :: Bool+                       , optFiles         :: [FilePath]                        } --- | Program configuration.-data Config = Config { cfgStyle      :: Style-                     , cfgLanguage   :: Language-                     , cfgExtensions :: [Extension]-                     }--instance ToJSON Config where-    toJSON Config{..} = JSON.object [ "style" .= styleName cfgStyle-                                    , "language" .= show cfgLanguage-                                    , "extensions" .= map showExt cfgExtensions-                                    , "formatting" .= styleInitialState cfgStyle-                                    ]-      where-        showExt (EnableExtension x) = show x-        showExt (DisableExtension x) = "No" ++ show x-        showExt (UnknownExtension x) = x--instance FromJSON Config where-    parseJSON (JSON.Object o) = do-        style <- maybe (cfgStyle defaultConfig) lookupStyle <$> o .:? "style"-        language <- maybe (cfgLanguage defaultConfig) lookupLanguage-            <$> o .:? "language"-        extensions <- maybe (cfgExtensions defaultConfig) (map lookupExtension)-            <$> o .:? "extensions"-        let flex = styleInitialState style-        flex' <- maybe flex (updateFlexConfig flex) <$> o .:? "formatting"-        let style' = style { styleInitialState = flex' }-        return $ Config style' language extensions-      where-        updateFlexConfig cfg v =-            case JSON.fromJSON $ mergeJSON (toJSON cfg) v of-                JSON.Error e -> error e-                JSON.Success x -> x--        mergeJSON JSON.Null r = r-        mergeJSON l JSON.Null = l-        mergeJSON (JSON.Object l) (JSON.Object r) =-            JSON.Object (HashMap.unionWith mergeJSON l r)-        mergeJSON _ r = r--    parseJSON v = JSON.typeMismatch "Config" v---- | Default program configuration.-defaultConfig :: Config-defaultConfig = Config (head styles) Haskell2010 []- -- | Main entry point. main :: IO () main = do@@ -113,14 +61,17 @@     mconfig <- case optConfig opts of         Just c -> return $ Just c         Nothing ->-            if isJust (optStyle opts) then return Nothing else findConfig+            if isJust (optStyle opts) then return Nothing else findAppConfig     baseConfig <- case mconfig of-        Just path -> readConfig path-        Nothing -> return defaultConfig-    let config = mergeConfig baseConfig opts-    if optPrintConfig opts-        then BL.putStr $ JSON.encodePretty config-        else run config (optFiles opts)+        Just path -> readAppConfig path+        Nothing -> return defaultAppConfig+    let config = mergeAppConfig baseConfig opts+    if optPrintFixities opts+        then PP.displayIO stdout . PP.renderPretty 1.0 80 $+            docFixities packageFixities <> PP.linebreak+        else if optPrintConfig opts+             then BL.putStr $ JSON.encodePretty config+             else run config (optFiles opts)   where     parser = info (helper <*> versioner <*> options)                   (fullDesc@@ -143,10 +94,15 @@         <*> many (option str                          (long "extension" <> short 'X' <> metavar "EXTENSION"                           <> help "Enable or disable language extensions"))+        <*> many (option str+                         (long "fixity" <> short 'F' <> metavar "FIXITY"+                          <> help "Add fixity declaration"))         <*> optional (option str                              (long "config" <> short 'c' <> metavar "FILE"                               <> help "Configuration file"))         <*> switch (long "print-config" <> help "Print configuration")+        <*> switch (long "print-fixities"+                    <> help "Print all built-in fixity declarations")         <*> many (argument str                            (metavar "FILES"                             <> help "Input files (will be replaced)"))@@ -166,25 +122,30 @@                                               . PP.punctuate PP.comma                                               . map PP.text $ sort xs) +    docFixities = PP.vcat . PP.punctuate PP.linebreak+        . map (uncurry docPackageFixities)++    docPackageFixities p fs = PP.text (p ++ ":")+        PP.<$$> (PP.indent 2 . PP.fillSep . PP.punctuate PP.comma+                 . map (PP.text . showFixity) $ sort fs)+ -- | Reformat files or stdin based on provided configuration.-run :: Config -> [FilePath] -> IO ()-run Config{..} files = case files of-    [] -> reformatStdin cfgStyle cfgLanguage cfgExtensions-    _ -> mapM_ (reformatFile cfgStyle cfgLanguage cfgExtensions) files+run :: AppConfig -> [FilePath] -> IO ()+run config files = case files of+    [] -> reformatStdin config+    _ -> mapM_ (reformatFile config) files  -- | Reformat stdin according to Style, Language, and Extensions.-reformatStdin :: Style -> Language -> [Extension] -> IO ()-reformatStdin style language extensions = BL.interact $-    reformatByteString style language extensions Nothing . BL.toStrict+reformatStdin :: AppConfig -> IO ()+reformatStdin config = BL.interact $ reformatByteString config Nothing  -- | Reformat a file according to Style, Language, and Extensions.-reformatFile :: Style -> Language -> [Extension] -> FilePath -> IO ()-reformatFile style language extensions file = do-    text <- BS.readFile file+reformatFile :: AppConfig -> FilePath -> IO ()+reformatFile config file = do+    text <- BL.readFile file     tmpDir <- getTemporaryDirectory     (fp, h) <- openTempFile tmpDir "floskell.hs"-    BL.hPutStr h $-        reformatByteString style language extensions (Just file) text+    BL.hPutStr h $ reformatByteString config (Just file) text     hFlush h     hClose h     let exdev e = if ioe_errno e == Just ((\(Errno a) -> a) eXDEV)@@ -194,58 +155,13 @@     renameFile fp file `catch` exdev  -- | Reformat a ByteString according to Style, Language, and Extensions.-reformatByteString :: Style-                   -> Language-                   -> [Extension]-                   -> Maybe FilePath-                   -> BS.ByteString-                   -> BL.ByteString-reformatByteString style language extensions mpath text =-    either error id $ reformat style language extensions mpath text---- | Try to find a configuration file based on current working--- directory, or in one of the application configuration directories.-findConfig :: IO (Maybe FilePath)-findConfig = do-    dotfilePaths <- sequence [ getHomeDirectory, getXdgDirectory XdgConfig "" ]-    dotfileConfig <- findFileWith doesFileExist dotfilePaths ".floskell.json"-    userPaths <- sequence [ getAppUserDataDirectory "floskell"-                          , getXdgDirectory XdgConfig "floskell"-                          ]-    userConfig <- findFileWith doesFileExist userPaths "config.json"-    localPaths <- map joinPath . reverse . drop 1 . inits . splitDirectories-        <$> getCurrentDirectory-    localConfig <- findFileWith doesFileExist localPaths "floskell.json"-    return $ localConfig <|> userConfig <|> dotfileConfig---- | Load a configuration file.-readConfig :: FilePath -> IO Config-readConfig file = do-    text <- BS.readFile file-    either (error . (++) (file ++ ": ")) return $ JSON.eitherDecodeStrict text+reformatByteString+    :: AppConfig -> Maybe FilePath -> BL.ByteString -> BL.ByteString+reformatByteString config mpath text =+    either error id $ reformat config mpath text  -- | Update the program configuration from the program options.-mergeConfig :: Config -> Options -> Config-mergeConfig cfg@Config{..} Options{..} =-    cfg { cfgStyle      = maybe cfgStyle lookupStyle optStyle-        , cfgLanguage   = maybe cfgLanguage lookupLanguage optLanguage-        , cfgExtensions = cfgExtensions ++ map lookupExtension optExtensions-        }---- | Lookup a style by name.-lookupStyle :: String -> Style-lookupStyle name = case filter ((== T.pack name) . styleName) styles of-    [] -> error $ "Unknown style: " ++ name-    x : _ -> x---- | Lookup a language by name.-lookupLanguage :: String -> Language-lookupLanguage name = case classifyLanguage name of-    UnknownLanguage _ -> error $ "Unknown language: " ++ name-    x -> x---- | Lookup an extension by name.-lookupExtension :: String -> Extension-lookupExtension name = case classifyExtension name of-    UnknownExtension _ -> error $ "Unkown extension: " ++ name-    x -> x+mergeAppConfig :: AppConfig -> Options -> AppConfig+mergeAppConfig cfg Options{..} =+    cfg `setStyle` optStyle `setLanguage` optLanguage+    `setExtensions` optExtensions `setFixities` optFixities

@@ -13,11 +13,12 @@ import           Control.DeepSeq import           Control.Monad.Catch -import           Data.ByteString         ( ByteString )-import           Data.ByteString.Builder as B-import qualified Data.ByteString.Char8   as S8+import           Data.ByteString.Builder    as B+import qualified Data.ByteString.Char8      as S8+import           Data.ByteString.Lazy       ( ByteString )+import qualified Data.ByteString.Lazy.Char8 as L8 import           Data.Char-import           Data.Monoid             ( (<>) )+import           Data.Monoid                ( (<>) ) import           Data.Typeable  import           GHC.Generics@@ -45,17 +46,17 @@  -- | Tokenize the bytestring. tokenize :: ByteString -> [Token]-tokenize = map token . S8.lines+tokenize = map token . L8.lines   where     token line-        | S8.isPrefixOf "#" line =-            let (hashes, title) = S8.span (== '#') line-            in-                Heading (S8.length hashes) (S8.dropWhile isSpace title)-        | S8.isPrefixOf "```" line =+        | L8.isPrefixOf "#" line = let (hashes, title) = L8.span (== '#') line+                                   in+                                       Heading (fromIntegral $ L8.length hashes)+                                               (L8.dropWhile isSpace title)+        | L8.isPrefixOf "```" line =             if line == "```"             then EndFence-            else BeginFence (S8.dropWhile (\c -> c == '`' || c == ' ') line)+            else BeginFence (L8.dropWhile (\c -> c == '`' || c == ' ') line)         | otherwise = PlainLine line  -- | Parse into a forest.@@ -83,7 +84,7 @@                     case rest' of                         (EndFence : rest'') ->                             fmap (CodeFence label-                                            (S8.intercalate "\n"+                                            (L8.intercalate "\n"                                                             (map getPlain                                                                  content)) :)                                  (go level rest'')@@ -95,7 +96,7 @@                                                  _ -> False)                                             (PlainLine p : rest)                 in-                    fmap (PlainText (S8.intercalate "\n" (map getPlain content)) :)+                    fmap (PlainText (L8.intercalate "\n" (map getPlain content)) :)                          (go level rest')         [] -> return []         _ -> throwM ExpectedSection@@ -111,8 +112,8 @@             let level' = level + 1             in                 B.byteString (S8.replicate level' '#') <> B.char7 ' '-                <> B.byteString heading <> B.byteString "\n"+                <> B.lazyByteString heading <> B.byteString "\n"                 <> mconcat (map (go level') children)-        (CodeFence lang code) -> B.byteString "``` " <> B.byteString lang-            <> B.char7 '\n' <> B.byteString code <> B.byteString "\n```\n"-        (PlainText text) -> B.byteString text <> B.byteString "\n"+        (CodeFence lang code) -> B.byteString "``` " <> B.lazyByteString lang+            <> B.char7 '\n' <> B.lazyByteString code <> B.byteString "\n```\n"+        (PlainText text) -> B.lazyByteString text <> B.byteString "\n"

@@ -1,16 +1,17 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  -- | Test the pretty printer. module Main where +import           Control.Applicative          ( (<|>) ) import           Control.Monad                ( forM_, guard ) -import           Data.ByteString              ( ByteString )-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.UTF8         as UTF8+import qualified Data.ByteString.Lazy.Builder as B+import qualified Data.ByteString.Lazy.UTF8    as UTF8 import           Data.Maybe                   ( mapMaybe ) import qualified Data.Text                    as T @@ -50,12 +51,12 @@  loadMarkdone :: String -> IO [Markdone] loadMarkdone filename = do-    bytes <- S.readFile filename+    bytes <- L.readFile filename     MD.parse (MD.tokenize bytes)  saveMarkdone :: String -> [Markdone] -> IO () saveMarkdone filename doc =-    S.writeFile filename $ L.toStrict $ L.toLazyByteString $ MD.print doc+    L.writeFile filename . B.toLazyByteString $ MD.print doc  -- | Extract code snippets from a Markdone document. extractSnippets :: ByteString -> [Markdone] -> [TestTree]@@ -75,29 +76,47 @@     doc <- loadMarkdone filename     return $ extractSnippets haskell doc --- | Some styles are broken and will fail the idempotency test.-expectedFailures :: [(T.Text, [Int])]-expectedFailures = []+disabled :: T.Text -> [Int] -> Maybe String+disabled style path = lookup (Just style, path) disabledTests+    <|> lookup (Nothing :: Maybe T.Text, path) disabledTests+  where+    disabledTests = []+#if MIN_VERSION_haskell_src_exts(1,21,0)+#else+        ++ [ ((Nothing, [ 2, 3, 4, 1 ]), "requires haskell-src-exts >=1.21.0")+           ]+#if MIN_VERSION_haskell_src_exts(1,20,0)+#else+        ++ [ ((Nothing, [ 2, 3, 6, 1 ]), "requires haskell-src-exts >=1.20.0")+           , ((Nothing, [ 2, 3, 11, 1 ]), "requires haskell-src-exts >=1.20.0")+           , ((Nothing, [ 2, 3, 12, 1 ]), "requires haskell-src-exts >=1.20.0")+           , ((Nothing, [ 2, 4, 1, 1 ]), "requires haskell-src-exts >=1.20.0")+           , ((Nothing, [ 2, 4, 9, 1 ]), "requires haskell-src-exts >=1.20.0")+           ]+#endif+#endif  -- | Convert the Markdone document to Spec benchmarks. toSpec :: Style -> [Int] -> [TestTree] -> [TestTree] -> Spec toSpec style path inp ref =     forM_ (zip3 [ 1 :: Int .. ] inp (ref ++ repeat TestMismatchMarker)) $ \case         (n, TestSection title children, TestSection _ children') ->-            describe title $ toSpec style (path ++ [ n ]) children children'-        (n, TestSnippet code, TestSnippet code') -> do-            let path' = (styleName style, path ++ [ n ])-            it (name n "formats as expected") $-                case reformatSnippet style code of-                    Left e -> error e-                    Right b -> b `shouldBeReadable` code'-            it (name n "formatting is idempotent") $-                if path' `elem` expectedFailures-                then pending-                else case reformatSnippet style-                                          code >>= reformatSnippet style of-                    Left e -> error e-                    Right b -> b `shouldBeReadable` code'+            describe (title ++ show (path ++ [ n ])) $+            toSpec style (path ++ [ n ]) children children'+        (n, TestSnippet code, TestSnippet code') ->+            case disabled (styleName style) (path ++ [ n ]) of+                Just msg -> it "Disabled" $ pendingWith msg+                Nothing -> do+                    it (name n "formats as expected") $+                        case reformatSnippet style code of+                            Left e -> error e+                            Right b -> b `shouldBeReadable` code'+                    it (name n "formatting is idempotent") $+                        case reformatSnippet style code of+                            Left e -> error e+                            Right b -> case reformatSnippet style b of+                                Left e -> error e+                                Right b' -> b' `shouldBeReadable` b         (n, _, _) -> error $ name n "structure mismatch in reference file"   where     name n desc = "Snippet " ++ show n ++ " - " ++ desc@@ -116,8 +135,9 @@         return (name, style, tree)  reformatSnippet :: Style -> ByteString -> Either String ByteString-reformatSnippet style code = L.toStrict-    <$> reformat style Haskell2010 defaultExtensions (Just "TEST.md") code+reformatSnippet style =+    reformat (AppConfig style Haskell2010 defaultExtensions [])+             (Just "TEST.md")  regenerate :: Style -> [Markdone] -> [Markdone] regenerate style = map fmt

@@ -0,0 +1,6 @@+resolver: lts-13.6+packages:+- '.'+extra-deps:+- haskell-src-exts-1.21.0+- monad-dijkstra-0.1.1.2