diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/TEST.md b/TEST.md --- a/TEST.md +++ b/TEST.md @@ -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 +> ``` diff --git a/floskell.cabal b/floskell.cabal --- a/floskell.cabal +++ b/floskell.cabal @@ -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 diff --git a/src/Floskell.hs b/src/Floskell.hs --- a/src/Floskell.hs +++ b/src/Floskell.hs @@ -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 "" 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 diff --git a/src/Floskell/Attoparsec.hs b/src/Floskell/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/src/Floskell/Attoparsec.hs @@ -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 diff --git a/src/Floskell/Buffer.hs b/src/Floskell/Buffer.hs --- a/src/Floskell/Buffer.hs +++ b/src/Floskell/Buffer.hs @@ -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. diff --git a/src/Floskell/Comments.hs b/src/Floskell/Comments.hs --- a/src/Floskell/Comments.hs +++ b/src/Floskell/Comments.hs @@ -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 diff --git a/src/Floskell/Config.hs b/src/Floskell/Config.hs --- a/src/Floskell/Config.hs +++ b/src/Floskell/Config.hs @@ -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) diff --git a/src/Floskell/ConfigFile.hs b/src/Floskell/ConfigFile.hs new file mode 100644 --- /dev/null +++ b/src/Floskell/ConfigFile.hs @@ -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 diff --git a/src/Floskell/Fixities.hs b/src/Floskell/Fixities.hs new file mode 100644 --- /dev/null +++ b/src/Floskell/Fixities.hs @@ -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 + [ "%@~" + , ".@~" + , ".~" + , "+~" + , "*~" + , "-~" + , "//~" + , "^~" + , "^^~" + , "**~" + , "&&~" + , "<>~" + , "||~" + , "%~" + , "<.~" + , "?~" + , "=" + , "||=" + , "%=" + , "<.=" + , "?=" + , "", "`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 + [ "%%@~" + , "<%@~" + , "<<%@~" + , "%%~" + , "<+~" + , "<*~" + , "<-~" + , "~" + , "<%~" + , "<<%~" + , "<<.~" + , "<=" + , "<%=" + , "<<%=" + , "<<.=" + , "<" ] + -- 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_ 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 [ ":-" ] diff --git a/src/Floskell/Imports.hs b/src/Floskell/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Floskell/Imports.hs @@ -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 diff --git a/src/Floskell/Pretty.hs b/src/Floskell/Pretty.hs --- a/src/Floskell/Pretty.hs +++ b/src/Floskell/Pretty.hs @@ -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) #-} diff --git a/src/Floskell/Printers.hs b/src/Floskell/Printers.hs --- a/src/Floskell/Printers.hs +++ b/src/Floskell/Printers.hs @@ -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 diff --git a/src/Floskell/Styles.hs b/src/Floskell/Styles.hs --- a/src/Floskell/Styles.hs +++ b/src/Floskell/Styles.hs @@ -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. diff --git a/src/Floskell/Types.hs b/src/Floskell/Types.hs --- a/src/Floskell/Types.hs +++ b/src/Floskell/Types.hs @@ -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 diff --git a/src/main/Benchmark.hs b/src/main/Benchmark.hs --- a/src/main/Benchmark.hs +++ b/src/main/Benchmark.hs @@ -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 diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -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 diff --git a/src/main/Markdone.hs b/src/main/Markdone.hs --- a/src/main/Markdone.hs +++ b/src/main/Markdone.hs @@ -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" diff --git a/src/main/Test.hs b/src/main/Test.hs --- a/src/main/Test.hs +++ b/src/main/Test.hs @@ -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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-13.6 +packages: +- '.' +extra-deps: +- haskell-src-exts-1.21.0 +- monad-dijkstra-0.1.1.2