diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +# Floskell 0.11.0 (2023-10-01) + +* Fix alignment of non-ASCII identifiers +* Fix extra whitespace generated for preprocessor directives at top/bottom of files +* Fix runtime blow-up with large number of pattern guards +* Add support for manual formatting / hiding regions of code from the formatter +* Add support for multi-line preprocessor directives +* Add support for hsc2hs #enum directives +* Add support for shebang lines +* Add support for building with aeson-2.2.0.0 and optparse-applicative-0.18.1.0 + # Floskell 0.10.8 (2023-08-12) * Add support for building with GHC-9.6.2 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -224,6 +224,18 @@ #endif ``` +### Manual Formatting and Hiding Code + +Floskell can be told to not change the formatting of a section of code +by enclosing the section with `floskell-disable` and `floskell-enable` +comments. The comments must be on a line of their own and can use the +`--` and `{- -}` syntax. + +As Floskell will simply copy anything between these comments to the +output and not attempt to parse the contents, this mechanism can also +be used to hide constructs from Floskell that the parser does not +support. + ## Customization diff --git a/TEST.md b/TEST.md --- a/TEST.md +++ b/TEST.md @@ -871,6 +871,80 @@ f = () ``` +## Preprocessor Directives + +Preprocessor directives are accepted and retained. + +``` haskell + #include + instance Monoid Penalty where + mempty = 0 + + #if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + #endif + + #define FOO 1 + #undef FOO + + #warning "WARNING" + #error "ERROR" +``` + +Multiline directives + +``` haskell + #define FOO \ + bar + + #if FOO \ + && BAR + foo = bar + #endif +``` + +Support for Hsc2hs #enum + +``` haskell + #enum CInt, \ + , fs = CTL_FS \ + , hw = CTL_HW \ + , kern = CTL_KERN \ + , net = CTL_NET \ + , vfs = CTL_VFS \ + , mem = CTL_VM +``` + +## Ignored Lines + +Ignore lines nested in `floskell-disable` and `floskell-enable` + +``` haskell +-- floskell-disable +This is ignored. +-- floskell-enable + +{- floskell-disable -} +And so is this. +{- floskell-enable -} +``` + +Ignore shebang lines + +``` haskell + #! /usr/bin/env nix-shell + #! nix-shell -p ghcid + #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [ shower ])" + #! nix-shell -i "ghcid -c 'ghci -Wall' -T':!pkill --full ghc\\ .\\*./Main.hs' -T main" + + module Main where + + import Shower + + main :: IO () + main = printer "Hello" +``` + ## Indentation and Line Prefixes Preserving indentation and line prefixes so that Floskell can be run diff --git a/floskell.cabal b/floskell.cabal --- a/floskell.cabal +++ b/floskell.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: floskell -version: 0.10.8 +version: 0.11.0 license: BSD3 license-file: LICENSE.md copyright: @@ -57,9 +57,10 @@ ghc-options: -Wall build-depends: base >=4.9 && <4.19, - aeson >=0.11.3.0 && <2.2, + aeson >=0.11.3.0 && <2.3, attoparsec >=0.13.1.0 && <0.15, - bytestring >=0.10.8.1 && <0.12, + attoparsec-aeson >=2.1.0.0 && <2.3, + bytestring >=0.10.8.1 && <0.13, containers >=0.5.7.1 && <0.7, data-default >=0.7.1.1 && <0.8, directory >=1.2.6.2 && <1.4, @@ -67,10 +68,9 @@ haskell-src-exts >=1.19 && <1.24, monad-dijkstra >=0.1.1 && <0.2, mtl >=2.2.1 && <2.4, - text >=1.2.2.2 && <2.1, + text >=1.2.2.2 && <2.2, transformers >=0.5.2.0 && <0.7, - unordered-containers >=0.2.8.0 && <0.3, - utf8-string >=1.0.1.1 && <1.1 + unordered-containers >=0.2.8.0 && <0.3 executable floskell main-is: Main.hs @@ -83,12 +83,13 @@ base >=4.9 && <4.19, floskell -any, aeson-pretty >=0.8.2 && <0.9, - bytestring >=0.10.8.1 && <0.12, + ansi-wl-pprint >=0.6.6 && <1.1, + bytestring >=0.10.8.1 && <0.13, directory >=1.2.6.2 && <1.4, ghc-prim >=0.5.0.0 && <0.11, haskell-src-exts >=1.19 && <1.24, - optparse-applicative >=0.12.1.0 && <0.18, - text >=1.2.2.2 && <2.1 + optparse-applicative >=0.12.1.0 && <0.19, + text >=1.2.2.2 && <2.2 test-suite floskell-test type: exitcode-stdio-1.0 @@ -100,13 +101,12 @@ build-depends: base >=4.9 && <4.19, floskell -any, - bytestring >=0.10.8.1 && <0.12, - deepseq >=1.4.2.0 && <1.5, + bytestring >=0.10.8.1 && <0.13, + deepseq >=1.4.2.0 && <1.6, exceptions >=0.8.3 && <0.12, haskell-src-exts >=1.19 && <1.24, - hspec >=2.2.4 && <2.11, - text >=1.2.2.2 && <2.1, - utf8-string >=1.0.1.1 && <1.1 + hspec >=2.2.4 && <2.12, + text >=1.2.2.2 && <2.2 benchmark floskell-bench type: exitcode-stdio-1.0 @@ -118,11 +118,10 @@ build-depends: base >=4.9 && <4.19, floskell -any, - bytestring >=0.10.8.1 && <0.12, + bytestring >=0.10.8.1 && <0.13, criterion >=1.1.1.0 && <1.7, - deepseq >=1.4.2.0 && <1.5, + deepseq >=1.4.2.0 && <1.6, exceptions >=0.8.3 && <0.11, ghc-prim >=0.5.0.0 && <0.11, haskell-src-exts >=1.19 && <1.24, - text >=1.2.2.2 && <2.1, - utf8-string >=1.0.1.1 && <1.1 + text >=1.2.2.2 && <2.2 diff --git a/src/Floskell.hs b/src/Floskell.hs --- a/src/Floskell.hs +++ b/src/Floskell.hs @@ -24,29 +24,28 @@ , defaultExtensions ) where -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Lazy.UTF8 as UTF8 import Data.List import Data.Maybe #if __GLASGOW_HASKELL__ <= 802 import Data.Monoid #endif +import Data.Text.Lazy ( Text ) +import qualified Data.Text.Lazy as TL -import qualified Floskell.Buffer as Buffer +import qualified Floskell.Buffer as Buffer import Floskell.Comments import Floskell.Config import Floskell.ConfigFile -import Floskell.Fixities ( builtinFixities ) -import Floskell.Pretty ( pretty ) -import Floskell.Styles ( Style(..), styles ) +import Floskell.Fixities ( builtinFixities ) +import Floskell.Pretty ( pretty ) +import Floskell.Styles ( Style(..), styles ) import Floskell.Types import Language.Haskell.Exts hiding ( Comment, Pretty, Style, parse, prettyPrint, style ) -import qualified Language.Haskell.Exts as Exts +import qualified Language.Haskell.Exts as Exts -data CodeBlock = HaskellSource Int [ByteString] | CPPDirectives [ByteString] +data CodeBlock = HaskellSource Int [Text] | CPPDirectives [Text] deriving ( Show, Eq ) trimBy :: (a -> Bool) -> [a] -> ([a], [a], [a]) @@ -60,63 +59,54 @@ suffix = reverse suffix' -findLinePrefix :: (Char -> Bool) -> [ByteString] -> ByteString +findLinePrefix :: (Char -> Bool) -> [Text] -> Text findLinePrefix _ [] = "" -findLinePrefix f (x : xs') = go (L8.takeWhile f x) xs' +findLinePrefix f (x : xs') = go (TL.takeWhile f x) xs' where - go prefix xs = if all (prefix `L8.isPrefixOf`) xs + go prefix xs = if all (prefix `TL.isPrefixOf`) xs then prefix - else go (L8.take (L8.length prefix - 1) prefix) xs + else go (TL.take (TL.length prefix - 1) prefix) xs -findIndent :: (Char -> Bool) -> [ByteString] -> ByteString +findIndent :: (Char -> Bool) -> [Text] -> Text findIndent _ [] = "" -findIndent f (x : xs') = go (L8.takeWhile f x) $ filter (not . L8.all f) xs' +findIndent f (x : xs') = go (TL.takeWhile f x) $ filter (not . TL.all f) xs' where - go indent xs = if all (indent `L8.isPrefixOf`) xs + go indent xs = if all (indent `TL.isPrefixOf`) xs then indent - else go (L8.take (L8.length indent - 1) indent) xs + else go (TL.take (TL.length indent - 1) indent) xs -preserveVSpace :: Monad m - => ([ByteString] -> m [ByteString]) - -> [ByteString] - -> m [ByteString] +preserveVSpace :: Monad m => ([Text] -> m [Text]) -> [Text] -> m [Text] preserveVSpace format input = do output <- format input' return $ prefix ++ output ++ suffix where - (prefix, input', suffix) = trimBy L8.null input + (prefix, input', suffix) = trimBy TL.null input -preservePrefix :: Monad m - => (Int -> [ByteString] -> m [ByteString]) - -> [ByteString] - -> m [ByteString] +preservePrefix :: Monad m => (Int -> [Text] -> m [Text]) -> [Text] -> m [Text] preservePrefix format input = do output <- format (prefixLength prefix) input' return $ map (prefix <>) output where prefix = findLinePrefix allowed input - input' = map (L8.drop $ L8.length prefix) input + input' = map (TL.drop $ TL.length prefix) input allowed c = c == ' ' || c == '\t' || c == '>' - prefixLength = sum . map (\c -> if c == '\t' then 8 else 1) . L8.unpack + prefixLength = sum . map (\c -> if c == '\t' then 8 else 1) . TL.unpack -preserveIndent :: Monad m - => (Int -> [ByteString] -> m [ByteString]) - -> [ByteString] - -> m [ByteString] +preserveIndent :: Monad m => (Int -> [Text] -> m [Text]) -> [Text] -> m [Text] preserveIndent format input = do output <- format (prefixLength prefix) input' - return $ map (prefix <>) output + return $ map (\l -> if TL.null l then l else prefix <> l) output where prefix = findIndent allowed input - input' = map (L8.drop $ L8.length prefix) input + input' = map (TL.drop $ TL.length prefix) input allowed c = c == ' ' || c == '\t' - prefixLength = sum . map (\c -> if c == '\t' then 8 else 1) . L8.unpack + prefixLength = sum . map (\c -> if c == '\t' then 8 else 1) . TL.unpack withReducedLineLength :: Int -> Config -> Config withReducedLineLength offset config = config { cfgPenalty = penalty } @@ -127,13 +117,12 @@ } -- | Format the given source. -reformat - :: AppConfig -> Maybe FilePath -> ByteString -> Either String ByteString -reformat config mfilepath input = fmap (L8.intercalate "\n") +reformat :: AppConfig -> Maybe FilePath -> Text -> Either String Text +reformat config mfilepath input = fmap (TL.intercalate "\n") . preserveVSpace (preservePrefix (reformatLines mode cfg)) $ - L8.split '\n' input + TL.split (== '\n') input where - mode = case readExtensions $ UTF8.toString input of + mode = case readExtensions $ TL.unpack input of Nothing -> mode' Just (Nothing, exts') -> mode' { extensions = exts' ++ extensions mode' } @@ -151,38 +140,29 @@ cfg = safeConfig . styleConfig $ appStyle config -reformatLines - :: ParseMode -> Config -> Int -> [ByteString] -> Either String [ByteString] -reformatLines mode config indent = format . filterPreprocessorDirectives +reformatLines :: ParseMode -> Config -> Int -> [Text] -> Either String [Text] +reformatLines mode config indent = preserveVSpace (preserveIndent format) where - config' = withReducedLineLength indent config - - format (code, comments) = - preserveVSpace (preserveIndent (reformatBlock mode config' comments)) - code + format indent' = + reformatBlock mode (withReducedLineLength (indent + indent') config) + . filterCommentLike -- | Format a continuous block of code without CPP directives. -reformatBlock :: ParseMode - -> Config - -> [Comment] - -> Int - -> [ByteString] - -> Either String [ByteString] -reformatBlock mode config cpp indent lines = +reformatBlock + :: ParseMode -> Config -> ([Text], [Comment]) -> Either String [Text] +reformatBlock mode config (lines, cpp) = 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 + case prettyPrint (pretty ast) config of Nothing -> Left "Printer failed with mzero call." - Just output -> Right $ L8.lines output + Just output -> Right $ TL.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 + code = TL.unpack $ TL.intercalate "\n" lines makeComment (Exts.Comment inline span text) = Comment (if inline then InlineComment else LineComment) span text @@ -194,34 +174,8 @@ 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 (`L8.isPrefixOf` src) - [ "#if" - , "#end" - , "#else" - , "#define" - , "#undef" - , "#elif" - , "#include" - , "#error" - , "#warning" - ] - -prettyPrint :: Printer a -> Config -> Maybe ByteString -prettyPrint printer = fmap (Buffer.toLazyByteString . psBuffer . snd) +prettyPrint :: Printer a -> Config -> Maybe Text +prettyPrint printer = fmap (Buffer.toLazyText . psBuffer . snd) . execPrinter printer . initialPrintState -- | Default extensions. diff --git a/src/Floskell/Buffer.hs b/src/Floskell/Buffer.hs --- a/src/Floskell/Buffer.hs +++ b/src/Floskell/Buffer.hs @@ -1,5 +1,5 @@ --- | An outout buffer for ByteStrings that keeps track of line and --- column numbers. +-- | An outout buffer for Text that keeps track of line and column +-- numbers. module Floskell.Buffer ( Buffer , empty @@ -7,13 +7,14 @@ , write , line , column - , toLazyByteString + , toLazyText ) where -import qualified Data.ByteString as BS -import Data.ByteString.Builder ( Builder ) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder ( Builder ) +import qualified Data.Text.Lazy.Builder as TB data Buffer = Buffer { bufferData :: !Builder -- ^ The current output. @@ -30,17 +31,17 @@ , bufferColumn = 0 } --- | Append a ByteString to the output buffer. It is an error for the +-- | Append a Text to the output buffer. It is an error for the -- string to contain newlines. -write :: BS.ByteString -> Buffer -> Buffer +write :: Text -> Buffer -> Buffer write str buf = buf { bufferData = newBufferData , bufferDataNoSpace = - if BS.all (== 32) str then bufferData buf else newBufferData - , bufferColumn = bufferColumn buf + BS.length str + if T.all (== ' ') str then bufferData buf else newBufferData + , bufferColumn = bufferColumn buf + T.length str } where - newBufferData = bufferData buf `mappend` BB.byteString str + newBufferData = bufferData buf `mappend` TB.fromText str -- | Append a newline to the output buffer. newline :: Buffer -> Buffer @@ -50,7 +51,7 @@ , bufferColumn = 0 } where - newBufferData = bufferDataNoSpace buf `mappend` BB.char7 '\n' + newBufferData = bufferDataNoSpace buf `mappend` TB.singleton '\n' -- | Return the current line number, counting from 0. line :: Buffer -> Int @@ -60,6 +61,6 @@ column :: Buffer -> Int column = bufferColumn --- | Return the contents of the output buffer as a lazy ByteString. -toLazyByteString :: Buffer -> BL.ByteString -toLazyByteString = BB.toLazyByteString . bufferData +-- | Return the contents of the output buffer as a lazy Text. +toLazyText :: Buffer -> TL.Text +toLazyText = TB.toLazyText . bufferData diff --git a/src/Floskell/Comments.hs b/src/Floskell/Comments.hs --- a/src/Floskell/Comments.hs +++ b/src/Floskell/Comments.hs @@ -1,17 +1,32 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + -- | Comment handling. -module Floskell.Comments ( annotateWithComments ) where +module Floskell.Comments ( filterCommentLike, annotateWithComments ) where import Control.Arrow ( first, second ) import Control.Monad.State.Strict import Data.Foldable ( traverse_ ) -import Data.List ( isPrefixOf ) +import Data.List ( foldl', isPrefixOf ) import qualified Data.Map.Strict as M +import Data.Text.Lazy ( Text ) +import qualified Data.Text.Lazy as TL import Floskell.Types import Language.Haskell.Exts.SrcLoc ( SrcSpanInfo(..) ) +data FilterMode = Normal | CppContinuation | Unformatted + deriving ( Eq, Ord, Enum, Show ) + +data FilterState = FilterState { stMode :: !FilterMode + , stLines :: [Text] + , stComments :: [Comment] + } + deriving ( Show ) + -- Order by start of span, larger spans before smaller spans. newtype OrderByStart = OrderByStart SrcSpan deriving ( Eq ) @@ -33,6 +48,80 @@ `mappend` compare (srcSpanEndColumn l) (srcSpanEndColumn r) `mappend` compare (srcSpanStartLine r) (srcSpanStartLine l) `mappend` compare (srcSpanStartColumn r) (srcSpanStartColumn l) + +-- | Remove comment-like blocks from input source, replacing them with +-- blank likes to keep SrcSpan information intact. +filterCommentLike :: [Text] -> ([Text], [Comment]) +filterCommentLike = finish . foldl' go start . zip [ 1 .. ] + where + start = FilterState Normal [] [] + + go s@FilterState{..} (n, l) = case stMode of + Normal -> if + | isShebangLine l -> addComment s Normal IgnoredLine n l + | isCppLine l -> + let newMode = + if isCppContinuation l then CppContinuation else Normal + in + addComment s newMode PreprocessorDirective n l + | isBeginIgnore l -> addComment s Unformatted IgnoredLine n l + | otherwise -> addLine s l + + CppContinuation -> + let newMode = + if isCppContinuation l then CppContinuation else Normal + in + addComment s newMode PreprocessorDirective n l + + Unformatted -> + let newMode = if isEndIgnore l then Normal else Unformatted + in + addComment s newMode IgnoredLine n l + + finish s = (reverse $ stLines s, reverse $ stComments s) + + addLine s@FilterState{..} l = s { stLines = l : stLines } + + addComment s@FilterState{..} mode t n l = + s { stMode = mode + , stLines = "" : stLines + , stComments = makeComment t n l : stComments + } + + makeComment t n l = + Comment t + (SrcSpan "" n 1 n (fromIntegral $ TL.length l + 1)) + (TL.unpack l) + + isShebangLine = TL.isPrefixOf "#!" + + isCppLine src = + any (`TL.isPrefixOf` src) + [ "#define" + , "#elif" + , "#else" + , "#end" + , "#enum" + , "#error" + , "#if" + , "#include" + , "#undef" + , "#warning" + ] + + isCppContinuation = TL.isSuffixOf "\\" + + isBeginIgnore src = any (`TL.isPrefixOf` src) + [ "-- floskell-begin-disable-region" + , "-- floskell-disable" + , "{- floskell-disable" + ] + + isEndIgnore src = any (`TL.isPrefixOf` src) + [ "-- floskell-end-disable-region" + , "-- floskell-enable" + , "{- floskell-enable" + ] onSameLine :: SrcSpan -> SrcSpan -> Bool onSameLine ss ss' = srcSpanEndLine ss == srcSpanStartLine ss' diff --git a/src/Floskell/Config.hs b/src/Floskell/Config.hs --- a/src/Floskell/Config.hs +++ b/src/Floskell/Config.hs @@ -35,18 +35,17 @@ import Data.Aeson ( FromJSON(..), ToJSON(..), genericParseJSON, genericToJSON ) -import qualified Data.Aeson as JSON -import Data.Aeson.Types as JSON +import qualified Data.Aeson as JSON +import Data.Aeson.Types as JSON ( Options(..), camelTo2, typeMismatch ) -import Data.ByteString ( ByteString ) -import Data.Default ( Default(..) ) -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 ) +import Data.Default ( Default(..) ) +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 Data.Text ( Text ) +import qualified Data.Text as T import GHC.Generics @@ -71,7 +70,7 @@ data Layout = Flex | Vertical | TryOneline deriving ( Eq, Ord, Bounded, Enum, Show, Generic ) -data ConfigMapKey = ConfigMapKey !(Maybe ByteString) !(Maybe LayoutContext) +data ConfigMapKey = ConfigMapKey !(Maybe Text) !(Maybe LayoutContext) deriving ( Eq, Ord, Show ) data ConfigMap a = @@ -120,71 +119,71 @@ } data IndentConfig = - IndentConfig { cfgIndentOnside :: !Int - , cfgIndentDeriving :: !Int - , cfgIndentWhere :: !Int - , cfgIndentApp :: !Indent - , cfgIndentCase :: !Indent - , cfgIndentClass :: !Indent - , cfgIndentDo :: !Indent + IndentConfig { cfgIndentOnside :: !Int + , cfgIndentDeriving :: !Int + , cfgIndentWhere :: !Int + , cfgIndentApp :: !Indent + , cfgIndentCase :: !Indent + , cfgIndentClass :: !Indent + , cfgIndentDo :: !Indent , cfgIndentExportSpecList :: !Indent - , cfgIndentIf :: !Indent + , cfgIndentIf :: !Indent , cfgIndentImportSpecList :: !Indent - , cfgIndentLet :: !Indent - , cfgIndentLetBinds :: !Indent - , cfgIndentLetIn :: !Indent - , cfgIndentMultiIf :: !Indent - , cfgIndentTypesig :: !Indent - , cfgIndentWhereBinds :: !Indent + , cfgIndentLet :: !Indent + , cfgIndentLetBinds :: !Indent + , cfgIndentLetIn :: !Indent + , cfgIndentMultiIf :: !Indent + , cfgIndentTypesig :: !Indent + , cfgIndentWhereBinds :: !Indent } deriving ( Generic ) instance Default IndentConfig where - def = IndentConfig { cfgIndentOnside = 4 - , cfgIndentDeriving = 4 - , cfgIndentWhere = 2 - , cfgIndentApp = IndentBy 4 - , cfgIndentCase = IndentBy 4 - , cfgIndentClass = IndentBy 4 - , cfgIndentDo = IndentBy 4 + def = IndentConfig { cfgIndentOnside = 4 + , cfgIndentDeriving = 4 + , cfgIndentWhere = 2 + , cfgIndentApp = IndentBy 4 + , cfgIndentCase = IndentBy 4 + , cfgIndentClass = IndentBy 4 + , cfgIndentDo = IndentBy 4 , cfgIndentExportSpecList = IndentBy 4 - , cfgIndentIf = IndentBy 4 + , cfgIndentIf = IndentBy 4 , cfgIndentImportSpecList = IndentBy 4 - , cfgIndentLet = IndentBy 4 - , cfgIndentLetBinds = IndentBy 4 - , cfgIndentLetIn = IndentBy 4 - , cfgIndentMultiIf = IndentBy 4 - , cfgIndentTypesig = IndentBy 4 - , cfgIndentWhereBinds = IndentBy 2 + , cfgIndentLet = IndentBy 4 + , cfgIndentLetBinds = IndentBy 4 + , cfgIndentLetIn = IndentBy 4 + , cfgIndentMultiIf = IndentBy 4 + , cfgIndentTypesig = IndentBy 4 + , cfgIndentWhereBinds = IndentBy 2 } data LayoutConfig = - LayoutConfig { cfgLayoutApp :: !Layout - , cfgLayoutConDecls :: !Layout - , cfgLayoutDeclaration :: !Layout + LayoutConfig { cfgLayoutApp :: !Layout + , cfgLayoutConDecls :: !Layout + , cfgLayoutDeclaration :: !Layout , cfgLayoutExportSpecList :: !Layout - , cfgLayoutIf :: !Layout + , cfgLayoutIf :: !Layout , cfgLayoutImportSpecList :: !Layout - , cfgLayoutInfixApp :: !Layout - , cfgLayoutLet :: !Layout - , cfgLayoutListComp :: !Layout - , cfgLayoutRecord :: !Layout - , cfgLayoutType :: !Layout + , cfgLayoutInfixApp :: !Layout + , cfgLayoutLet :: !Layout + , cfgLayoutListComp :: !Layout + , cfgLayoutRecord :: !Layout + , cfgLayoutType :: !Layout } deriving ( Generic ) instance Default LayoutConfig where - def = LayoutConfig { cfgLayoutApp = Flex - , cfgLayoutConDecls = Flex - , cfgLayoutDeclaration = Flex + def = LayoutConfig { cfgLayoutApp = Flex + , cfgLayoutConDecls = Flex + , cfgLayoutDeclaration = Flex , cfgLayoutExportSpecList = Flex - , cfgLayoutIf = Flex + , cfgLayoutIf = Flex , cfgLayoutImportSpecList = Flex - , cfgLayoutInfixApp = Flex - , cfgLayoutLet = Flex - , cfgLayoutListComp = Flex - , cfgLayoutRecord = Flex - , cfgLayoutType = Flex + , cfgLayoutInfixApp = Flex + , cfgLayoutLet = Flex + , cfgLayoutListComp = Flex + , cfgLayoutRecord = Flex + , cfgLayoutType = Flex } newtype OpConfig = OpConfig { unOpConfig :: ConfigMap Whitespace } @@ -228,7 +227,8 @@ , cfgOptionAlignSumTypeDecl :: !Bool , cfgOptionFlexibleOneline :: !Bool , cfgOptionPreserveVerticalSpace :: !Bool - , cfgOptionDeclNoBlankLines :: !(Set DeclarationConstruct) + , cfgOptionDeclNoBlankLines + :: !(Set DeclarationConstruct) , cfgOptionAlignLetBindsAndInExpr :: !Bool } deriving ( Generic ) @@ -310,7 +310,7 @@ (cfgMapFind ctx key config) { wsSpaces = ws } m -cfgMapFind :: LayoutContext -> ByteString -> ConfigMap a -> a +cfgMapFind :: LayoutContext -> Text -> ConfigMap a -> a cfgMapFind ctx key ConfigMap{..} = let value = cfgMapDefault value' = Map.findWithDefault value @@ -325,10 +325,10 @@ in value''' -cfgOpWs :: LayoutContext -> ByteString -> OpConfig -> Whitespace +cfgOpWs :: LayoutContext -> Text -> OpConfig -> Whitespace cfgOpWs ctx op = cfgMapFind ctx op . unOpConfig -cfgGroupWs :: LayoutContext -> ByteString -> GroupConfig -> Whitespace +cfgGroupWs :: LayoutContext -> Text -> GroupConfig -> Whitespace cfgGroupWs ctx op = cfgMapFind ctx op . unGroupConfig inWs :: Location -> WsLoc -> Bool @@ -418,20 +418,19 @@ keyToText :: ConfigMapKey -> T.Text keyToText (ConfigMapKey Nothing Nothing) = "default" -keyToText (ConfigMapKey (Just n) Nothing) = T.decodeUtf8 n +keyToText (ConfigMapKey (Just n) Nothing) = n keyToText (ConfigMapKey Nothing (Just l)) = "* in " `T.append` layoutToText l keyToText (ConfigMapKey (Just n) (Just l)) = - T.decodeUtf8 n `T.append` " in " `T.append` layoutToText l + n `T.append` " in " `T.append` layoutToText l textToKey :: T.Text -> Maybe ConfigMapKey textToKey t = case T.splitOn " in " t of [ "default" ] -> Just (ConfigMapKey Nothing Nothing) [ "*", "*" ] -> Just (ConfigMapKey Nothing Nothing) - [ name ] -> Just (ConfigMapKey (Just (T.encodeUtf8 name)) Nothing) - [ name, "*" ] -> Just (ConfigMapKey (Just (T.encodeUtf8 name)) Nothing) + [ name ] -> Just (ConfigMapKey (Just name) Nothing) + [ name, "*" ] -> Just (ConfigMapKey (Just name) Nothing) [ "*", layout ] -> ConfigMapKey Nothing . Just <$> textToLayout layout - [ name, layout ] -> ConfigMapKey (Just (T.encodeUtf8 name)) . Just - <$> textToLayout layout + [ name, layout ] -> ConfigMapKey (Just name) . Just <$> textToLayout layout _ -> Nothing instance ToJSON a => ToJSON (ConfigMap a) where diff --git a/src/Floskell/ConfigFile.hs b/src/Floskell/ConfigFile.hs --- a/src/Floskell/ConfigFile.hs +++ b/src/Floskell/ConfigFile.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Floskell.ConfigFile ( AppConfig(..) @@ -29,18 +28,11 @@ 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 ) - -#if MIN_VERSION_aeson(2,0,0) -import qualified Data.Aeson.KeyMap as Map -#else -import qualified Data.Aeson.Parser as JSON ( json' ) -import qualified Data.HashMap.Lazy as Map -#endif - import Data.List ( inits ) import qualified Data.Text as T @@ -60,6 +52,14 @@ , getHomeDirectory, getXdgDirectory ) import System.FilePath ( joinPath, splitDirectories, takeDirectory ) + +{- floskell-disable -} +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as Map +#else +import qualified Data.HashMap.Lazy as Map +#endif +{- floskell-enable -} data AppConfig = AppConfig { appStyle :: Style , appLanguage :: Language diff --git a/src/Floskell/Pretty.hs b/src/Floskell/Pretty.hs --- a/src/Floskell/Pretty.hs +++ b/src/Floskell/Pretty.hs @@ -12,13 +12,12 @@ import Control.Monad.State.Strict ( get, gets, modify ) 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 Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Floskell.Buffer as Buffer import Floskell.Config @@ -101,20 +100,19 @@ -- | Pretty print a syntax tree with annotated comments pretty :: (Annotated ast, Pretty ast) => ast NodeInfo -> Printer () pretty ast = do - printComments Before ast + printCommentsBefore True ast prettyPrint ast - printComments After ast + printCommentsAfter ast prettyOnside :: (Annotated ast, Pretty ast) => ast NodeInfo -> Printer () prettyOnside ast = do - eol <- gets psEolComment - when eol newline + closeEolComment nl <- gets psNewline if nl then do - printComments Before ast + printCommentsBefore True ast onside $ prettyPrint ast - printComments After ast + printCommentsAfter ast else onside $ pretty ast -- | Compare two AST nodes ignoring the annotation @@ -143,75 +141,73 @@ to -- | Pretty print a comment. -printComment :: Int -> (Comment, SrcSpan) -> Printer () -printComment correction (Comment{..}, nextSpan) = do +printComment :: Int -> Comment -> Printer () +printComment correction Comment{..} = do col <- getNextColumn let padding = max 0 $ srcSpanStartColumn commentSpan + correction - col - 1 case commentType of PreprocessorDirective -> do - nl <- gets psNewline - unless nl newline + ensureNewline column 0 $ string commentText modify (\s -> s { psEolComment = True }) InlineComment -> do - write $ BS.replicate padding 32 + write $ T.replicate padding " " write "{-" string commentText write "-}" - when (srcSpanEndLine commentSpan /= srcSpanStartLine nextSpan) $ - modify (\s -> s { psEolComment = True }) LineComment -> do - write $ BS.replicate padding 32 + write $ T.replicate padding " " write "--" string commentText modify (\s -> s { psEolComment = True }) - --- | Print comments of a node. -printComments :: Annotated ast => Location -> ast NodeInfo -> Printer () -printComments = printCommentsInternal True - --- | Print comments of a node, but do not force newline before leading comments. -printComments' :: Annotated ast => Location -> ast NodeInfo -> Printer () -printComments' = printCommentsInternal False - -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 + IgnoredLine -> do + ensureNewline + column 0 $ string commentText + modify (\s -> s { psEolComment = True }) +printCommentsBefore :: Annotated ast => Bool -> ast NodeInfo -> Printer () +printCommentsBefore nlBefore ast = unless (null comments) $ suppressOnside $ do + when nlBefore ensureNewline col <- getNextColumn - let correction = case loc of - Before -> col - srcSpanStartColumn ssi + 1 - After -> col - srcSpanEndColumn ssi + 1 - forM_ (zip comments (tail (map commentSpan comments ++ [ ssi ]))) $ - printComment correction - - -- Write newline before restoring onside indent. - eol <- gets psEolComment - when (loc == Before && eol && onside' > 0) newline - when nl $ modify $ \s -> s { psOnside = onside' } + printCommentsInternal (col - srcSpanStartColumn (nodeSpan ast) + 1) + comments + let distance = srcSpanStartLine (nodeSpan ast) + - srcSpanEndLine (commentSpan (last comments)) + when (distance > 0) $ do + ensureNewline + replicateM_ (distance - 1) newline where - ssi = nodeSpan ast + comments = nodeInfoLeadingComments $ ann ast - comments = filterComments loc ast +printCommentsAfter :: Annotated ast => ast NodeInfo -> Printer () +printCommentsAfter ast = unless (null comments) $ suppressOnside $ do + let distance = srcSpanStartLine (commentSpan (head comments)) + - srcSpanEndLine (nodeSpan ast) + when (distance > 0) $ do + ensureNewline + replicateM_ (distance - 1) newline + col <- getNextColumn + printCommentsInternal (col - srcSpanEndColumn (nodeSpan ast) + 1) comments + where + comments = nodeInfoTrailingComments $ ann ast - notSameLine comment = srcSpanEndLine ssi - < srcSpanStartLine (commentSpan comment) +printCommentsInternal :: Int -> [Comment] -> Printer () +printCommentsInternal correction comments = do + printComment correction (head comments) + forM_ (zip (tail comments) (map (srcSpanEndLine . commentSpan) comments)) $ + \(comment, prevLine) -> do + let nextLine = srcSpanStartLine $ commentSpan comment + replicateM_ (nextLine - prevLine) newline + printComment correction comment -- | Return the configuration name of an operator -opName :: QOp a -> ByteString +opName :: QOp a -> Text opName op = case op of (QVarOp _ qname) -> opName' qname (QConOp _ qname) -> opName' qname -- | Return the configuration name of an operator -opName' :: QName a -> ByteString +opName' :: QName a -> Text opName' (Qual _ _ name) = opName'' name opName' (UnQual _ name) = opName'' name opName' (Special _ (FunCon _)) = "->" @@ -219,9 +215,9 @@ opName' (Special _ _) = "" -- | Return the configuration name of an operator -opName'' :: Name a -> ByteString +opName'' :: Name a -> Text opName'' (Ident _ _) = "``" -opName'' (Symbol _ str) = BS8.pack str +opName'' (Symbol _ str) = T.pack str lineDelta :: Annotated ast => ast NodeInfo -> ast NodeInfo -> Int lineDelta prev next = nextLine - prevLine @@ -262,16 +258,16 @@ linedOnside :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () linedOnside = linedFn prettyOnside -listVOpLen :: LayoutContext -> ByteString -> Printer Int +listVOpLen :: LayoutContext -> Text -> 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 + else T.length sep + if wsSpace After ws then 1 else 0 listVinternal :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString + -> Text -> [ast NodeInfo] -> Printer () listVinternal ctx sep xs = case xs of @@ -283,22 +279,22 @@ let itemCol = if nl && length xs > 1 then col + delta else col sepCol = itemCol - delta column itemCol $ do - printComments' Before x + printCommentsBefore False x cut $ prettyPrint x - printComments After x + printCommentsAfter x -- `column sepCol` must not be within `column itemCol`, or the -- former can suppress onside for the latter. forM_ xs' $ \x' -> do - column itemCol $ printComments Before x' + column itemCol $ printCommentsBefore True x' column sepCol $ operatorV ctx sep column itemCol $ cut $ prettyPrint x' - column itemCol $ printComments After x' + column itemCol $ printCommentsAfter x' listH :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString - -> ByteString - -> ByteString + -> Text + -> Text + -> Text -> [ast NodeInfo] -> Printer () listH _ open close _ [] = do @@ -310,9 +306,9 @@ listV :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString - -> ByteString - -> ByteString + -> Text + -> Text + -> Text -> [ast NodeInfo] -> Printer () listV ctx open close sep xs = groupV ctx open close $ do @@ -325,9 +321,9 @@ list :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString - -> ByteString - -> ByteString + -> Text + -> Text + -> Text -> [ast NodeInfo] -> Printer () list ctx open close sep xs = oneline hor <|> ver @@ -338,14 +334,14 @@ listH' :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString + -> Text -> [ast NodeInfo] -> Printer () listH' ctx sep = inter (operatorH ctx sep) . map pretty listV' :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString + -> Text -> [ast NodeInfo] -> Printer () listV' ctx sep xs = @@ -353,7 +349,7 @@ list' :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString + -> Text -> [ast NodeInfo] -> Printer () list' ctx sep xs = oneline hor <|> ver @@ -364,9 +360,9 @@ listAutoWrap :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString - -> ByteString - -> ByteString + -> Text + -> Text + -> Text -> [ast NodeInfo] -> Printer () listAutoWrap _ open close _ [] = do @@ -378,7 +374,7 @@ listAutoWrap' :: (Annotated ast, Pretty ast) => LayoutContext - -> ByteString + -> Text -> [ast NodeInfo] -> Printer () listAutoWrap' _ _ [] = return () @@ -386,23 +382,23 @@ 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 + else T.length sep + if wsSpace After ws then 1 else 0 col <- getNextColumn pretty x go (col - correction) xs where go _ [] = return () go col [ x' ] = do - printComments Before x' + printCommentsBefore True x' column col $ operator ctx sep prettyPrint x' - printComments After x' + printCommentsAfter x' go col (x' : xs') = do - printComments Before x' + printCommentsBefore True x' cut $ do column col $ operator ctx sep prettyPrint x' - printComments After x' + printCommentsAfter x' go col xs' measure :: Printer a -> Printer (Maybe Int) @@ -412,7 +408,7 @@ return $ case execPrinter (oneline p) s' of Nothing -> Nothing Just (_, s'') -> Just . (\x -> x - psIndentLevel s) . fromIntegral - . BL.length . Buffer.toLazyByteString $ psBuffer s'' + . TL.length . Buffer.toLazyText $ psBuffer s'' measure' :: Printer a -> Printer (Maybe [Int]) measure' p = fmap (: []) <$> measure p @@ -554,7 +550,7 @@ prettySimpleDecl :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2) => ast1 NodeInfo - -> ByteString + -> Text -> ast2 NodeInfo -> Printer () prettySimpleDecl lhs op rhs = withLayout cfgLayoutDeclaration flex vertical @@ -614,7 +610,7 @@ -> Type NodeInfo -> Printer () prettyTypesig ctx names ty = do - inter comma $ map pretty names + listAutoWrap' ctx "," names atTabStop stopRecordField withIndentConfig cfgIndentTypesig align indentby where @@ -625,7 +621,7 @@ nl <- gets psNewline when nl $ do delta <- listVOpLen ctx "->" - write $ BS.replicate delta 32 + write $ T.replicate delta " " pretty ty prettyApp :: (Annotated ast1, Annotated ast2, Pretty ast1, Pretty ast2) @@ -646,7 +642,7 @@ prettyInfixApp :: (Annotated ast, Pretty ast, Annotated op, HSE.Pretty (op NodeInfo)) - => (op NodeInfo -> ByteString) + => (op NodeInfo -> Text) -> LayoutContext -> (ast NodeInfo, [(op NodeInfo, ast NodeInfo)]) -> Printer () @@ -666,9 +662,9 @@ pretty arg prettyOp op = do - printComments Before op + printCommentsBefore True op prettyHSE op - printComments After op + printCommentsAfter op prettyRecord :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2) => (ast2 NodeInfo -> Printer (Maybe Int)) @@ -693,8 +689,7 @@ -> Printer () prettyRecordFields len ctx fields = withLayout cfgLayoutRecord flex vertical where - flex = groupH ctx "{" "}" $ inter (operatorH ctx ",") $ - map prettyOnside fields + flex = groupH ctx "{" "}" $ listAutoWrap' ctx "," fields vertical = groupV ctx "{" "}" $ withComputedTabStop stopRecordField @@ -702,10 +697,10 @@ (fmap (fmap pure) . len) fields $ listVinternal ctx "," fields -prettyPragma :: ByteString -> Printer () -> Printer () +prettyPragma :: Text -> Printer () -> Printer () prettyPragma name = prettyPragma' name . Just -prettyPragma' :: ByteString -> Maybe (Printer ()) -> Printer () +prettyPragma' :: Text -> Maybe (Printer ()) -> Printer () prettyPragma' name mp = do write "{-# " write name @@ -930,7 +925,7 @@ mtyvarbinds' mcontext' ty) = depend "pattern" $ do - inter comma $ map pretty names + listAutoWrap' Declaration "," names operator Declaration "::" mapM_ prettyForall mtyvarbinds mayM_ mcontext pretty @@ -940,7 +935,7 @@ #elif MIN_VERSION_haskell_src_exts(1,20,0) prettyPrint (PatSynSig _ names mtyvarbinds mcontext mcontext' ty) = depend "pattern" $ do - inter comma $ map pretty names + listAutoWrap' Declaration "," names operator Declaration "::" mapM_ prettyForall mtyvarbinds mayM_ mcontext pretty @@ -1006,7 +1001,7 @@ else prettyPragma "DEPRECATED" $ forM_ deprecations $ \(names, str) -> do unless (null names) $ do - inter comma $ map pretty names + listAutoWrap' Other "," names space string (show str) @@ -1015,7 +1010,7 @@ then prettyPragma' "WARNING" Nothing else prettyPragma "WARNING" $ forM_ warnings $ \(names, str) -> do unless (null names) $ do - inter comma $ map pretty names + listAutoWrap' Other "," names space string (show str) @@ -1035,14 +1030,14 @@ mayM_ mactivation $ withPostfix space pretty pretty qname operator Declaration "::" - inter comma $ map pretty types + listAutoWrap' Declaration "," types prettyPrint (SpecInlineSig _ inline mactivation qname types) = prettyPragma name $ do mayM_ mactivation $ withPostfix space pretty pretty qname operator Declaration "::" - inter comma $ map pretty types + listAutoWrap' Declaration "," types where name = if inline then "SPECIALISE INLINE" else "SPECIALISE NOINLINE" @@ -1273,7 +1268,7 @@ (opName'' name) (prettyHSE $ VarOp noNodeInfo name) id - inter spaceOrNewline $ map pretty pats + inter spaceOrNewline $ map (cut . pretty) pats vertical = do pretty pat @@ -1304,13 +1299,13 @@ where flex = do operatorSectionR Pattern "|" $ write "|" - inter comma $ map pretty stmts + listAutoWrap' Pattern "," stmts operator Declaration "=" pretty expr vertical = do operatorSectionR Pattern "|" $ write "|" - inter comma $ map pretty stmts + list' Pattern "," stmts operatorV Declaration "=" pretty expr @@ -1477,9 +1472,7 @@ prettyV (TyForall _ mtyvarbinds mcontext ty) = do forM_ mtyvarbinds $ \tyvarbinds -> do - write "forall " - inter space $ map pretty tyvarbinds - withOperatorFormattingV Type "." (write "." >> space) id + prettyForall tyvarbinds forM_ mcontext $ \context -> do case context of (CxSingle _ asst) -> pretty asst @@ -1616,17 +1609,17 @@ write $ if nl && alignP then "in " else "in " prettyOnside expr - vertical = withIndentAfter - cfgIndentLet - (do - write "let" - withIndent cfgIndentLetBinds $ - pretty (CompactBinds binds)) - (do - newline - alignP <- getOption cfgOptionAlignLetBindsAndInExpr - write $ if alignP then "in " else "in" - withIndent cfgIndentLetIn $ pretty expr) + vertical = + withIndentAfter cfgIndentLet + (do + write "let" + withIndent cfgIndentLetBinds $ + pretty (CompactBinds binds)) + (do + newline + alignP <- getOption cfgOptionAlignLetBindsAndInExpr + write $ if alignP then "in " else "in" + withIndent cfgIndentLetIn $ pretty expr) prettyPrint (If _ expr expr' expr'') = withLayout cfgLayoutIf flex vertical where @@ -2192,13 +2185,13 @@ instance Pretty ModulePragma where prettyPrint (LanguagePragma _ names) = - prettyPragma "LANGUAGE" . inter comma $ map pretty names + prettyPragma "LANGUAGE" $ listAutoWrap' Other "," names prettyPrint (OptionsPragma _ mtool str) = prettyPragma name $ string (trim str) where name = case mtool of - Just tool -> "OPTIONS_" `mappend` BS8.pack (HSE.prettyPrint tool) + Just tool -> "OPTIONS_" `mappend` T.pack (HSE.prettyPrint tool) Nothing -> "OPTIONS" trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ') @@ -2249,10 +2242,10 @@ prettyPrint (VarFormula _ name) = pretty name prettyPrint (AndFormula _ booleanformulas) = - inter comma $ map pretty booleanformulas + listAutoWrap' Expression "," booleanformulas prettyPrint (OrFormula _ booleanformulas) = - inter (operator Expression "|") $ map pretty booleanformulas + listAutoWrap' Expression "|" booleanformulas prettyPrint (ParenFormula _ booleanformula) = parens $ pretty booleanformula @@ -2292,7 +2285,7 @@ instance Pretty GuardedAlt where prettyPrint (GuardedAlt (GuardedRhs _ stmts expr)) = cut $ do operatorSectionR Pattern "|" $ write "|" - inter comma $ map pretty stmts + listAutoWrap' Expression "," stmts operator Expression "->" pretty expr diff --git a/src/Floskell/Printers.hs b/src/Floskell/Printers.hs --- a/src/Floskell/Printers.hs +++ b/src/Floskell/Printers.hs @@ -4,6 +4,7 @@ ( getConfig , getOption , cut + , closeEolComment , oneline , ignoreOneline -- * Basic printing @@ -12,6 +13,7 @@ , int , space , newline + , ensureNewline , blankline , spaceOrNewline -- * Tab stops @@ -34,6 +36,7 @@ , aligned , indented , onside + , suppressOnside , depend , depend' , parens @@ -60,13 +63,11 @@ 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.List ( intersperse ) import qualified Data.Map.Strict as Map import Data.Monoid ( (<>) ) +import Data.Text ( Text ) +import qualified Data.Text as T import qualified Floskell.Buffer as Buffer import Floskell.Config @@ -124,7 +125,7 @@ ignoreOneline = withOutputRestriction Anything -- | Write out a string, updating the current position information. -write :: ByteString -> Printer () +write :: Text -> Printer () write x = do closeEolComment write' x @@ -133,10 +134,10 @@ state <- get let indentLevel = psIndentLevel state out = if psNewline state - then BS.replicate indentLevel 32 <> x' + then T.replicate indentLevel " " <> x' else x' buffer = psBuffer state - newCol = Buffer.column buffer + BS.length out + newCol = Buffer.column buffer + T.length out guard $ psOutputRestriction state == Anything || newCol < penaltyMaxLineLength (cfgPenalty (psConfig state)) penalty <- linePenalty False newCol @@ -146,7 +147,7 @@ -- | Write a string. string :: String -> Printer () -string = write . BL.toStrict . BB.toLazyByteString . BB.stringUtf8 +string = write . T.pack -- | Write an integral. int :: Int -> Printer () @@ -171,6 +172,12 @@ , psEolComment = False }) +-- | Output a newline if not at the start of a line +ensureNewline :: Printer () +ensureNewline = do + nl <- gets psNewline + unless nl newline + blankline :: Printer () blankline = newline >> newline @@ -197,7 +204,7 @@ mayM_ mstop $ \stop -> do col <- getNextColumn let padding = max 0 (stop - col) - write (BS.replicate padding 32) + write (T.replicate padding " ") mayM_ :: Maybe a -> (a -> Printer ()) -> Printer () mayM_ Nothing _ = return () @@ -300,7 +307,7 @@ level <- gets psIndentLevel column (level + i) p --- | Increase indentation level b n spaces for the given printer, but +-- | Increase indentation level by n spaces for the given printer, but -- ignore increase when computing further indentations. onside :: Printer a -> Printer a onside p = do @@ -308,7 +315,16 @@ onsideIndent <- getConfig (cfgIndentOnside . cfgIndent) withIndentation (\(l, _) -> (l, onsideIndent)) p -depend :: ByteString -> Printer a -> Printer a +-- | Temporarily ignore any onside identation. +suppressOnside :: Printer () -> Printer () +suppressOnside printer = do + nl <- gets psNewline + onsideIndent <- gets psOnside + when nl $ modify $ \s -> s { psOnside = 0 } + printer + modify $ \s -> s { psOnside = onsideIndent } + +depend :: Text -> Printer a -> Printer a depend kw = depend' (write kw) depend' :: Printer () -> Printer a -> Printer a @@ -334,7 +350,7 @@ p write "]" -group :: LayoutContext -> ByteString -> ByteString -> Printer () -> Printer () +group :: LayoutContext -> Text -> Text -> Printer () -> Printer () group ctx open close p = do force <- getConfig (wsForceLinebreak . cfgGroupWs ctx open . cfgGroup) if force then vert else oneline hor <|> vert @@ -343,7 +359,7 @@ vert = groupV ctx open close p -groupH :: LayoutContext -> ByteString -> ByteString -> Printer () -> Printer () +groupH :: LayoutContext -> Text -> Text -> Printer () -> Printer () groupH ctx open close p = do ws <- getConfig (cfgGroupWs ctx open . cfgGroup) write open @@ -352,7 +368,7 @@ when (wsSpace After ws) space write close -groupV :: LayoutContext -> ByteString -> ByteString -> Printer () -> Printer () +groupV :: LayoutContext -> Text -> Text -> Printer () -> Printer () groupV ctx open close p = aligned $ do ws <- getConfig (cfgGroupWs ctx open . cfgGroup) write open @@ -361,21 +377,21 @@ if wsLinebreak After ws then newline else when (wsSpace After ws) space write close -operator :: LayoutContext -> ByteString -> Printer () +operator :: LayoutContext -> Text -> Printer () operator ctx op = withOperatorFormatting ctx op (write op) id -operatorH :: LayoutContext -> ByteString -> Printer () +operatorH :: LayoutContext -> Text -> Printer () operatorH ctx op = withOperatorFormattingH ctx op (write op) id -operatorV :: LayoutContext -> ByteString -> Printer () +operatorV :: LayoutContext -> Text -> Printer () operatorV ctx op = withOperatorFormattingV ctx op (write op) id -alignOnOperator :: LayoutContext -> ByteString -> Printer a -> Printer a +alignOnOperator :: LayoutContext -> Text -> Printer a -> Printer a alignOnOperator ctx op p = withOperatorFormatting ctx op (write op) (aligned . (*> p)) withOperatorFormatting :: LayoutContext - -> ByteString + -> Text -> Printer () -> (Printer () -> Printer a) -> Printer a @@ -388,7 +404,7 @@ vert = withOperatorFormattingV ctx op opp fn withOperatorFormattingH :: LayoutContext - -> ByteString + -> Text -> Printer () -> (Printer () -> Printer a) -> Printer a @@ -400,24 +416,26 @@ when (wsSpace After ws) space withOperatorFormattingV :: LayoutContext - -> ByteString + -> Text -> Printer () -> (Printer () -> Printer a) -> Printer a withOperatorFormattingV ctx op opp fn = do ws <- getConfig (cfgOpWs ctx op . cfgOp) - if wsLinebreak Before ws then newline else when (wsSpace Before ws) space + if wsLinebreak Before ws + then ensureNewline + else when (wsSpace Before ws) space fn $ do opp if wsLinebreak After ws then newline else when (wsSpace After ws) space -operatorSectionL :: LayoutContext -> ByteString -> Printer () -> Printer () +operatorSectionL :: LayoutContext -> Text -> Printer () -> Printer () operatorSectionL ctx op opp = do ws <- getConfig (cfgOpWs ctx op . cfgOp) when (wsSpace Before ws) space opp -operatorSectionR :: LayoutContext -> ByteString -> Printer () -> Printer () +operatorSectionR :: LayoutContext -> Text -> Printer () -> Printer () operatorSectionR ctx op opp = do ws <- getConfig (cfgOpWs ctx op . cfgOp) opp diff --git a/src/Floskell/Styles.hs b/src/Floskell/Styles.hs --- a/src/Floskell/Styles.hs +++ b/src/Floskell/Styles.hs @@ -22,35 +22,35 @@ defaultConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions } where cfgIndent = - IndentConfig { cfgIndentOnside = 2 - , cfgIndentDeriving = 2 - , cfgIndentWhere = 2 - , cfgIndentApp = Align - , cfgIndentCase = IndentBy 2 - , cfgIndentClass = IndentBy 2 - , cfgIndentDo = Align - , cfgIndentIf = IndentBy 3 - , cfgIndentLet = Align - , cfgIndentLetBinds = Align - , cfgIndentLetIn = Align - , cfgIndentMultiIf = IndentBy 2 - , cfgIndentTypesig = Align - , cfgIndentWhereBinds = Align + IndentConfig { cfgIndentOnside = 2 + , cfgIndentDeriving = 2 + , cfgIndentWhere = 2 + , cfgIndentApp = Align + , cfgIndentCase = IndentBy 2 + , cfgIndentClass = IndentBy 2 + , cfgIndentDo = Align + , cfgIndentIf = IndentBy 3 + , cfgIndentLet = Align + , cfgIndentLetBinds = Align + , cfgIndentLetIn = Align + , cfgIndentMultiIf = IndentBy 2 + , cfgIndentTypesig = Align + , cfgIndentWhereBinds = Align , cfgIndentExportSpecList = IndentBy 2 , cfgIndentImportSpecList = AlignOrIndentBy 7 } - cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline - , cfgLayoutConDecls = Vertical - , cfgLayoutDeclaration = TryOneline + cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline + , cfgLayoutConDecls = Vertical + , cfgLayoutDeclaration = TryOneline , cfgLayoutExportSpecList = TryOneline - , cfgLayoutIf = Vertical + , cfgLayoutIf = Vertical , cfgLayoutImportSpecList = Flex - , cfgLayoutInfixApp = TryOneline - , cfgLayoutLet = Vertical - , cfgLayoutListComp = Flex - , cfgLayoutRecord = Vertical - , cfgLayoutType = TryOneline + , cfgLayoutInfixApp = TryOneline + , cfgLayoutLet = Vertical + , cfgLayoutListComp = Flex + , cfgLayoutRecord = Vertical + , cfgLayoutType = TryOneline } cfgOp = @@ -111,35 +111,35 @@ } cfgIndent = - IndentConfig { cfgIndentOnside = 4 - , cfgIndentDeriving = 4 - , cfgIndentWhere = 2 - , cfgIndentApp = Align - , cfgIndentCase = IndentBy 4 - , cfgIndentClass = IndentBy 4 - , cfgIndentDo = IndentBy 4 - , cfgIndentIf = Align - , cfgIndentLet = Align - , cfgIndentLetBinds = Align - , cfgIndentLetIn = IndentBy 4 - , cfgIndentMultiIf = IndentBy 4 - , cfgIndentTypesig = Align - , cfgIndentWhereBinds = IndentBy 2 + IndentConfig { cfgIndentOnside = 4 + , cfgIndentDeriving = 4 + , cfgIndentWhere = 2 + , cfgIndentApp = Align + , cfgIndentCase = IndentBy 4 + , cfgIndentClass = IndentBy 4 + , cfgIndentDo = IndentBy 4 + , cfgIndentIf = Align + , cfgIndentLet = Align + , cfgIndentLetBinds = Align + , cfgIndentLetIn = IndentBy 4 + , cfgIndentMultiIf = IndentBy 4 + , cfgIndentTypesig = Align + , cfgIndentWhereBinds = IndentBy 2 , cfgIndentExportSpecList = IndentBy 4 , cfgIndentImportSpecList = AlignOrIndentBy 17 } - cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline - , cfgLayoutConDecls = TryOneline - , cfgLayoutDeclaration = Flex + cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline + , cfgLayoutConDecls = TryOneline + , cfgLayoutDeclaration = Flex , cfgLayoutExportSpecList = TryOneline - , cfgLayoutIf = TryOneline + , cfgLayoutIf = TryOneline , cfgLayoutImportSpecList = Flex - , cfgLayoutInfixApp = Flex - , cfgLayoutLet = TryOneline - , cfgLayoutListComp = TryOneline - , cfgLayoutRecord = TryOneline - , cfgLayoutType = TryOneline + , cfgLayoutInfixApp = Flex + , cfgLayoutLet = TryOneline + , cfgLayoutListComp = TryOneline + , cfgLayoutRecord = TryOneline + , cfgLayoutType = TryOneline } cfgOp = @@ -225,35 +225,35 @@ } cfgIndent = - IndentConfig { cfgIndentOnside = 2 - , cfgIndentDeriving = 2 - , cfgIndentWhere = 2 - , cfgIndentApp = IndentBy 2 - , cfgIndentCase = IndentBy 2 - , cfgIndentClass = IndentBy 2 - , cfgIndentDo = IndentBy 2 - , cfgIndentIf = Align - , cfgIndentLet = Align - , cfgIndentLetBinds = Align - , cfgIndentLetIn = Align - , cfgIndentMultiIf = IndentBy 2 - , cfgIndentTypesig = Align - , cfgIndentWhereBinds = IndentBy 2 + IndentConfig { cfgIndentOnside = 2 + , cfgIndentDeriving = 2 + , cfgIndentWhere = 2 + , cfgIndentApp = IndentBy 2 + , cfgIndentCase = IndentBy 2 + , cfgIndentClass = IndentBy 2 + , cfgIndentDo = IndentBy 2 + , cfgIndentIf = Align + , cfgIndentLet = Align + , cfgIndentLetBinds = Align + , cfgIndentLetIn = Align + , cfgIndentMultiIf = IndentBy 2 + , cfgIndentTypesig = Align + , cfgIndentWhereBinds = IndentBy 2 , cfgIndentExportSpecList = IndentBy 4 , cfgIndentImportSpecList = Align } - cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline - , cfgLayoutConDecls = Vertical - , cfgLayoutDeclaration = Flex + cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline + , cfgLayoutConDecls = Vertical + , cfgLayoutDeclaration = Flex , cfgLayoutExportSpecList = TryOneline - , cfgLayoutIf = Vertical + , cfgLayoutIf = Vertical , cfgLayoutImportSpecList = Flex - , cfgLayoutInfixApp = TryOneline - , cfgLayoutLet = Vertical - , cfgLayoutListComp = TryOneline - , cfgLayoutRecord = TryOneline - , cfgLayoutType = TryOneline + , cfgLayoutInfixApp = TryOneline + , cfgLayoutLet = Vertical + , cfgLayoutListComp = TryOneline + , cfgLayoutRecord = TryOneline + , cfgLayoutType = TryOneline } cfgOp = @@ -298,35 +298,35 @@ defaultConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions } where cfgIndent = - IndentConfig { cfgIndentOnside = 4 - , cfgIndentDeriving = 4 - , cfgIndentWhere = 2 - , cfgIndentApp = IndentBy 4 - , cfgIndentCase = IndentBy 4 - , cfgIndentClass = IndentBy 4 - , cfgIndentDo = IndentBy 4 - , cfgIndentIf = IndentBy 4 - , cfgIndentLet = Align - , cfgIndentLetBinds = Align - , cfgIndentLetIn = Align - , cfgIndentMultiIf = IndentBy 2 - , cfgIndentTypesig = Align - , cfgIndentWhereBinds = IndentBy 2 + IndentConfig { cfgIndentOnside = 4 + , cfgIndentDeriving = 4 + , cfgIndentWhere = 2 + , cfgIndentApp = IndentBy 4 + , cfgIndentCase = IndentBy 4 + , cfgIndentClass = IndentBy 4 + , cfgIndentDo = IndentBy 4 + , cfgIndentIf = IndentBy 4 + , cfgIndentLet = Align + , cfgIndentLetBinds = Align + , cfgIndentLetIn = Align + , cfgIndentMultiIf = IndentBy 2 + , cfgIndentTypesig = Align + , cfgIndentWhereBinds = IndentBy 2 , cfgIndentExportSpecList = IndentBy 2 , cfgIndentImportSpecList = AlignOrIndentBy 7 } - cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline - , cfgLayoutConDecls = Vertical - , cfgLayoutDeclaration = TryOneline + cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline + , cfgLayoutConDecls = Vertical + , cfgLayoutDeclaration = TryOneline , cfgLayoutExportSpecList = TryOneline - , cfgLayoutIf = Vertical + , cfgLayoutIf = Vertical , cfgLayoutImportSpecList = Flex - , cfgLayoutInfixApp = TryOneline - , cfgLayoutLet = Vertical - , cfgLayoutListComp = Flex - , cfgLayoutRecord = Vertical - , cfgLayoutType = TryOneline + , cfgLayoutInfixApp = TryOneline + , cfgLayoutLet = Vertical + , cfgLayoutListComp = Flex + , cfgLayoutRecord = Vertical + , cfgLayoutType = TryOneline } cfgOp = diff --git a/src/Floskell/Types.hs b/src/Floskell/Types.hs --- a/src/Floskell/Types.hs +++ b/src/Floskell/Types.hs @@ -78,14 +78,14 @@ -- | The state of the pretty printer. data PrintState = - PrintState { psBuffer :: !Buffer -- ^ Output buffer - , 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. + PrintState { psBuffer :: !Buffer -- ^ Output buffer + , 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 - , psTypeLayout :: !TypeLayout + , psTypeLayout :: !TypeLayout } psLine :: PrintState -> Int @@ -101,7 +101,8 @@ initialPrintState config = PrintState Buffer.empty 0 0 Map.empty config False Anything TypeFree -data CommentType = InlineComment | LineComment | PreprocessorDirective +data CommentType = + InlineComment | LineComment | PreprocessorDirective | IgnoredLine deriving ( Show ) data Comment = Comment { commentType :: !CommentType @@ -112,8 +113,8 @@ -- | Information for each node in the AST. data NodeInfo = - NodeInfo { nodeInfoSpan :: !SrcSpan -- ^ Location info from the parser. - , nodeInfoLeadingComments :: ![Comment] -- ^ Leading comments 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 ) diff --git a/src/main/Benchmark.hs b/src/main/Benchmark.hs --- a/src/main/Benchmark.hs +++ b/src/main/Benchmark.hs @@ -9,20 +9,20 @@ import Criterion import Criterion.Main -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Lazy.UTF8 as UTF8 -import qualified Data.Text as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TIO import Floskell -import Language.Haskell.Exts ( Language(Haskell2010) ) +import Language.Haskell.Exts ( Language(Haskell2010) ) import Markdone -- | Main benchmarks. main :: IO () main = do - bytes <- L8.readFile "BENCHMARK.md" + bytes <- TIO.readFile "BENCHMARK.md" !forest <- fmap force (parse (tokenize bytes)) defaultMain [ bgroup (T.unpack $ styleName style) $ toCriterion (AppConfig style @@ -37,11 +37,11 @@ toCriterion :: AppConfig -> [Markdone] -> [Benchmark] toCriterion config = go where - go (Section name children : next) = bgroup (L8.unpack name) (go children) + go (Section name children : next) = bgroup (TL.unpack name) (go children) : go next go (PlainText desc : CodeFence lang code : next) = if lang == "haskell" - then bench (UTF8.toString desc) + then bench (TL.unpack desc) (nf (either error id . reformat config (Just "BENCHMARK.md")) code) : go next else 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,27 +4,29 @@ -- | Main entry point to floskell. module Main ( main ) where -import Control.Applicative ( many, optional ) -import Control.Exception ( catch, throw ) +import Control.Applicative ( many, optional ) +import Control.Exception ( catch, throw ) -import qualified Data.Aeson.Encode.Pretty as JSON ( encodePretty ) -import qualified Data.ByteString.Lazy as BL -import Data.List ( sort ) -import Data.Maybe ( isJust ) -import Data.Monoid ( (<>) ) -import qualified Data.Text as T -import Data.Version ( showVersion ) +import qualified Data.Aeson.Encode.Pretty as JSON ( encodePretty ) +import qualified Data.ByteString.Lazy as BL +import Data.List ( sort ) +import Data.Maybe ( isJust ) +import Data.Monoid ( (<>) ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TIO +import Data.Version ( showVersion ) import Floskell ( AppConfig(..), Style(..), defaultAppConfig, findAppConfig , readAppConfig, reformat, setExtensions, setFixities , setLanguage, setStyle, styles ) -import Floskell.ConfigFile ( showFixity ) -import Floskell.Fixities ( packageFixities ) +import Floskell.ConfigFile ( showFixity ) +import Floskell.Fixities ( packageFixities ) -import Foreign.C.Error ( Errno(..), eXDEV ) +import Foreign.C.Error ( Errno(..), eXDEV ) -import GHC.IO.Exception ( ioe_errno ) +import GHC.IO.Exception ( ioe_errno ) import Language.Haskell.Exts ( Extension(..), knownExtensions, knownLanguages ) @@ -33,9 +35,8 @@ ( ParseError(..), abortOption, argument, execParser, footerDoc , fullDesc, header, help, helper, hidden, info, long, metavar , option, progDesc, short, str, switch ) -import qualified Options.Applicative.Help.Pretty as PP -import Paths_floskell ( version ) +import Paths_floskell ( version ) import System.Directory ( copyFile, copyPermissions, getTemporaryDirectory, removeFile @@ -43,6 +44,8 @@ import System.IO ( FilePath, hClose, hFlush, openTempFile, stdout ) +import qualified Text.PrettyPrint.ANSI.Leijen as PP + -- | Program options. data Options = Options { optStyle :: Maybe String , optLanguage :: Maybe String @@ -137,15 +140,15 @@ -- | Reformat stdin according to Style, Language, and Extensions. reformatStdin :: AppConfig -> IO () -reformatStdin config = BL.interact $ reformatByteString config Nothing +reformatStdin config = TIO.interact $ reformatText config Nothing -- | Reformat a file according to Style, Language, and Extensions. reformatFile :: AppConfig -> FilePath -> IO () reformatFile config file = do - text <- BL.readFile file + text <- TIO.readFile file tmpDir <- getTemporaryDirectory (fp, h) <- openTempFile tmpDir "floskell.hs" - BL.hPutStr h $ reformatByteString config (Just file) text + TIO.hPutStr h $ reformatText config (Just file) text hFlush h hClose h let exdev e = if ioe_errno e == Just ((\(Errno a) -> a) eXDEV) @@ -154,11 +157,9 @@ copyPermissions file fp renameFile fp file `catch` exdev --- | Reformat a ByteString according to Style, Language, and Extensions. -reformatByteString - :: AppConfig -> Maybe FilePath -> BL.ByteString -> BL.ByteString -reformatByteString config mpath text = - either error id $ reformat config mpath text +-- | Reformat a Text according to Style, Language, and Extensions. +reformatText :: AppConfig -> Maybe FilePath -> TL.Text -> TL.Text +reformatText config mpath text = either error id $ reformat config mpath text -- | Update the program configuration from the program options. mergeAppConfig :: AppConfig -> Options -> AppConfig diff --git a/src/main/Markdone.hs b/src/main/Markdone.hs --- a/src/main/Markdone.hs +++ b/src/main/Markdone.hs @@ -13,27 +13,23 @@ import Control.DeepSeq import Control.Monad.Catch -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.Text.Lazy ( Text ) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.IO as TIO import Data.Typeable import GHC.Generics -- | A markdone token. -data Token = Heading !Int !ByteString - | PlainLine !ByteString - | BeginFence !ByteString - | EndFence +data Token = Heading !Int !Text | PlainLine !Text | BeginFence !Text | EndFence deriving ( Show ) -- | A markdone document. -data Markdone = Section !ByteString ![Markdone] - | CodeFence !ByteString !ByteString - | PlainText !ByteString +data Markdone = + Section !Text ![Markdone] | CodeFence !Text !Text | PlainText !Text deriving ( Show, Generic ) instance NFData Markdone @@ -45,18 +41,18 @@ instance Exception MarkdownError -- | Tokenize the bytestring. -tokenize :: ByteString -> [Token] -tokenize = map token . L8.lines +tokenize :: Text -> [Token] +tokenize = map token . TL.lines where token line - | L8.isPrefixOf "#" line = let (hashes, title) = L8.span (== '#') line + | TL.isPrefixOf "#" line = let (hashes, title) = TL.span (== '#') line in - Heading (fromIntegral $ L8.length hashes) - (L8.dropWhile isSpace title) - | L8.isPrefixOf "```" line = + Heading (fromIntegral $ TL.length hashes) + (TL.dropWhile isSpace title) + | TL.isPrefixOf "```" line = if line == "```" then EndFence - else BeginFence (L8.dropWhile (\c -> c == '`' || c == ' ') line) + else BeginFence (TL.dropWhile (\c -> c == '`' || c == ' ') line) | otherwise = PlainLine line -- | Parse into a forest. @@ -84,7 +80,7 @@ case rest' of (EndFence : rest'') -> fmap (CodeFence label - (L8.intercalate "\n" + (TL.intercalate "\n" (map getPlain content)) :) (go level rest'') @@ -96,7 +92,7 @@ _ -> False) (PlainLine p : rest) in - fmap (PlainText (L8.intercalate "\n" (map getPlain content)) :) + fmap (PlainText (TL.intercalate "\n" (map getPlain content)) :) (go level rest') [] -> return [] _ -> throwM ExpectedSection @@ -104,16 +100,17 @@ getPlain (PlainLine x) = x getPlain _ = "" -print :: [Markdone] -> B.Builder -print = mconcat . map (go (0 :: Int)) +print :: [Markdone] -> TB.Builder +print = mconcat . map (go 0) where go level = \case (Section heading children) -> let level' = level + 1 in - B.byteString (S8.replicate level' '#') <> B.char7 ' ' - <> B.lazyByteString heading <> B.byteString "\n" + TB.fromLazyText (TL.replicate level' "#") <> TB.singleton ' ' + <> TB.fromLazyText heading <> TB.fromString "\n" <> mconcat (map (go level') children) - (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" + (CodeFence lang code) -> + TB.fromString "``` " <> TB.fromLazyText lang <> TB.singleton '\n' + <> TB.fromLazyText code <> TB.fromString "\n```\n" + (PlainText text) -> TB.fromLazyText text <> TB.fromString "\n" diff --git a/src/main/Test.hs b/src/main/Test.hs --- a/src/main/Test.hs +++ b/src/main/Test.hs @@ -5,43 +5,43 @@ -- | Test the pretty printer. module Main where -import Control.Applicative ( (<|>) ) -import Control.Monad ( forM_, guard ) +import Control.Applicative ( (<|>) ) +import Control.Monad ( forM_, guard ) -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Builder as B ( toLazyByteString ) -import qualified Data.ByteString.Lazy.UTF8 as UTF8 -import Data.Maybe ( mapMaybe ) -import qualified Data.Text as T +import Data.Maybe ( mapMaybe ) +import qualified Data.Text as T +import Data.Text.Lazy ( Text ) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB ( toLazyText ) +import qualified Data.Text.Lazy.IO as TIO import Floskell -import Language.Haskell.Exts ( Language(Haskell2010) ) +import Language.Haskell.Exts ( Language(Haskell2010) ) -import Markdone ( Markdone(..) ) -import qualified Markdone as MD +import Markdone ( Markdone(..) ) +import qualified Markdone as MD -import System.Environment ( getArgs ) +import System.Environment ( getArgs ) import Test.Hspec data TestTree = - TestSection String [TestTree] | TestSnippet ByteString | TestMismatchMarker + TestSection String [TestTree] | TestSnippet Text | TestMismatchMarker -- | Prints a string without quoting and escaping. -newtype Readable = Readable ByteString +newtype Readable = Readable Text deriving ( Eq ) instance Show Readable where - show (Readable x) = "\n" ++ UTF8.toString x + show (Readable x) = "\n" ++ TL.unpack x -- | Version of 'shouldBe' that prints strings in a readable way, -- better for our use-case. -shouldBeReadable :: ByteString -> ByteString -> Expectation +shouldBeReadable :: Text -> Text -> Expectation shouldBeReadable x y = Readable x `shouldBe` Readable y -haskell :: ByteString +haskell :: Text haskell = "haskell" referenceFile :: Style -> String @@ -51,19 +51,18 @@ loadMarkdone :: String -> IO [Markdone] loadMarkdone filename = do - bytes <- L.readFile filename + bytes <- TIO.readFile filename MD.parse (MD.tokenize bytes) saveMarkdone :: String -> [Markdone] -> IO () saveMarkdone filename doc = - L.writeFile filename . B.toLazyByteString $ MD.print doc + TIO.writeFile filename . TB.toLazyText $ MD.print doc -- | Extract code snippets from a Markdone document. -extractSnippets :: ByteString -> [Markdone] -> [TestTree] +extractSnippets :: Text -> [Markdone] -> [TestTree] extractSnippets lang = mapMaybe convert where - convert (Section name children) = - return $ TestSection (UTF8.toString name) $ + convert (Section name children) = return $ TestSection (TL.unpack name) $ extractSnippets lang children convert (CodeFence l c) = do guard $ l == lang @@ -80,7 +79,8 @@ disabled style path = lookup (Just style, path) disabledTests <|> lookup (Nothing :: Maybe T.Text, path) disabledTests where - disabledTests = [] + disabledTests = + [] #if MIN_VERSION_haskell_src_exts(1,21,0) #else ++ [ ((Nothing, [ 2, 3, 4, 1 ]), "requires haskell-src-exts >=1.21.0") @@ -134,7 +134,7 @@ tree <- loadSnippets $ referenceFile style return (name, style, tree) -reformatSnippet :: Style -> ByteString -> Either String ByteString +reformatSnippet :: Style -> Text -> Either String Text reformatSnippet style = reformat (AppConfig style Haskell2010 defaultExtensions []) (Just "TEST.md") @@ -144,7 +144,7 @@ where fmt (CodeFence lang code) = if lang == haskell - then CodeFence lang $ either (UTF8.fromString . ("-- " ++) . show) id $ + then CodeFence lang $ either (TL.pack . ("-- " ++) . show) id $ reformatSnippet style code else CodeFence lang code fmt (Section heading children) = diff --git a/styles/base.md b/styles/base.md --- a/styles/base.md +++ b/styles/base.md @@ -642,12 +642,12 @@ foo = Point { x = 1, y = 2 } foo = Point { x = 1 -- the one - , y, .. } + , y, .. } foo = bar { x = 1 } foo = bar { x = 1 -- the one - , y, .. } + , y, .. } ``` ### Let, If, MultiIf, and Case @@ -777,9 +777,9 @@ Long types allow linebreaks. ``` haskell -newtype MyMonadT a b m - = MyMonad { runMyMonad :: StateT ([ ( a, a -> b ) ]) - (ReaderT a (ExceptT [ IM.IntMap b ]) (WriterT [ IS.IntSet x ] m)) } +newtype MyMonadT a b m = MyMonad { runMyMonad :: StateT ([ ( a, a -> b ) ]) + (ReaderT a (ExceptT [ IM.IntMap b ]) + (WriterT [ IS.IntSet x ] m)) } ``` Promoted types. @@ -869,7 +869,7 @@ ``` haskell data Foo = Foo { fooBar :: Text - -- ^A comment, long enough to end up on its own line, or at least I hope so. + -- ^A comment, long enough to end up on its own line, or at least I hope so. } deriving ( Eq ) ``` @@ -930,6 +930,80 @@ f :: () -- f = () +``` + +## Preprocessor Directives + +Preprocessor directives are accepted and retained. + +``` haskell + #include + instance Monoid Penalty where + mempty = 0 + + #if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + #endif + + #define FOO 1 + #undef FOO + + #warning "WARNING" + #error "ERROR" +``` + +Multiline directives + +``` haskell + #define FOO \ + bar + + #if FOO \ + && BAR + foo = bar + #endif +``` + +Support for Hsc2hs #enum + +``` haskell + #enum CInt, \ + , fs = CTL_FS \ + , hw = CTL_HW \ + , kern = CTL_KERN \ + , net = CTL_NET \ + , vfs = CTL_VFS \ + , mem = CTL_VM +``` + +## Ignored Lines + +Ignore lines nested in `floskell-disable` and `floskell-enable` + +``` haskell +-- floskell-disable +This is ignored. +-- floskell-enable + +{- floskell-disable -} +And so is this. +{- floskell-enable -} +``` + +Ignore shebang lines + +``` haskell + #! /usr/bin/env nix-shell + #! nix-shell -p ghcid + #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [ shower ])" + #! nix-shell -i "ghcid -c 'ghci -Wall' -T':!pkill --full ghc\\ .\\*./Main.hs' -T main" + + module Main where + + import Shower + + main :: IO () + main = printer "Hello" ``` ## Indentation and Line Prefixes diff --git a/styles/chris-done.md b/styles/chris-done.md --- a/styles/chris-done.md +++ b/styles/chris-done.md @@ -997,6 +997,80 @@ f = () ``` +## Preprocessor Directives + +Preprocessor directives are accepted and retained. + +``` haskell + #include + instance Monoid Penalty where + mempty = 0 + + #if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + #endif + + #define FOO 1 + #undef FOO + + #warning "WARNING" + #error "ERROR" +``` + +Multiline directives + +``` haskell + #define FOO \ + bar + + #if FOO \ + && BAR + foo = bar + #endif +``` + +Support for Hsc2hs #enum + +``` haskell + #enum CInt, \ + , fs = CTL_FS \ + , hw = CTL_HW \ + , kern = CTL_KERN \ + , net = CTL_NET \ + , vfs = CTL_VFS \ + , mem = CTL_VM +``` + +## Ignored Lines + +Ignore lines nested in `floskell-disable` and `floskell-enable` + +``` haskell +-- floskell-disable +This is ignored. +-- floskell-enable + +{- floskell-disable -} +And so is this. +{- floskell-enable -} +``` + +Ignore shebang lines + +``` haskell + #! /usr/bin/env nix-shell + #! nix-shell -p ghcid + #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [ shower ])" + #! nix-shell -i "ghcid -c 'ghci -Wall' -T':!pkill --full ghc\\ .\\*./Main.hs' -T main" + + module Main where + + import Shower + + main :: IO () + main = printer "Hello" +``` + ## Indentation and Line Prefixes Preserving indentation and line prefixes so that Floskell can be run diff --git a/styles/cramer.md b/styles/cramer.md --- a/styles/cramer.md +++ b/styles/cramer.md @@ -973,6 +973,80 @@ f = () ``` +## Preprocessor Directives + +Preprocessor directives are accepted and retained. + +``` haskell + #include + instance Monoid Penalty where + mempty = 0 + + #if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + #endif + + #define FOO 1 + #undef FOO + + #warning "WARNING" + #error "ERROR" +``` + +Multiline directives + +``` haskell + #define FOO \ + bar + + #if FOO \ + && BAR + foo = bar + #endif +``` + +Support for Hsc2hs #enum + +``` haskell + #enum CInt, \ + , fs = CTL_FS \ + , hw = CTL_HW \ + , kern = CTL_KERN \ + , net = CTL_NET \ + , vfs = CTL_VFS \ + , mem = CTL_VM +``` + +## Ignored Lines + +Ignore lines nested in `floskell-disable` and `floskell-enable` + +``` haskell +-- floskell-disable +This is ignored. +-- floskell-enable + +{- floskell-disable -} +And so is this. +{- floskell-enable -} +``` + +Ignore shebang lines + +``` haskell + #! /usr/bin/env nix-shell + #! nix-shell -p ghcid + #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [ shower ])" + #! nix-shell -i "ghcid -c 'ghci -Wall' -T':!pkill --full ghc\\ .\\*./Main.hs' -T main" + + module Main where + + import Shower + + main :: IO () + main = printer "Hello" +``` + ## Indentation and Line Prefixes Preserving indentation and line prefixes so that Floskell can be run diff --git a/styles/gibiansky.md b/styles/gibiansky.md --- a/styles/gibiansky.md +++ b/styles/gibiansky.md @@ -964,6 +964,80 @@ f = () ``` +## Preprocessor Directives + +Preprocessor directives are accepted and retained. + +``` haskell + #include + instance Monoid Penalty where + mempty = 0 + + #if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + #endif + + #define FOO 1 + #undef FOO + + #warning "WARNING" + #error "ERROR" +``` + +Multiline directives + +``` haskell + #define FOO \ + bar + + #if FOO \ + && BAR + foo = bar + #endif +``` + +Support for Hsc2hs #enum + +``` haskell + #enum CInt, \ + , fs = CTL_FS \ + , hw = CTL_HW \ + , kern = CTL_KERN \ + , net = CTL_NET \ + , vfs = CTL_VFS \ + , mem = CTL_VM +``` + +## Ignored Lines + +Ignore lines nested in `floskell-disable` and `floskell-enable` + +``` haskell +-- floskell-disable +This is ignored. +-- floskell-enable + +{- floskell-disable -} +And so is this. +{- floskell-enable -} +``` + +Ignore shebang lines + +``` haskell + #! /usr/bin/env nix-shell + #! nix-shell -p ghcid + #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [ shower ])" + #! nix-shell -i "ghcid -c 'ghci -Wall' -T':!pkill --full ghc\\ .\\*./Main.hs' -T main" + + module Main where + + import Shower + + main :: IO () + main = printer "Hello" +``` + ## Indentation and Line Prefixes Preserving indentation and line prefixes so that Floskell can be run diff --git a/styles/johan-tibell.md b/styles/johan-tibell.md --- a/styles/johan-tibell.md +++ b/styles/johan-tibell.md @@ -521,10 +521,10 @@ {-# DEPRECATED #-} {-# DEPRECATED foo "use bar instead" #-} -{-# DEPRECATED foo, bar, baz "no longer supported" #-} +{-# DEPRECATED foo,bar,baz "no longer supported" #-} {-# WARNING #-} {-# WARNING foo "use bar instead" #-} -{-# WARNING foo, bar, baz "no longer supported" #-} +{-# WARNING foo,bar,baz "no longer supported" #-} {-# INLINE foo #-} {-# INLINE [3] foo #-} {-# INLINE [~3] foo #-} @@ -1026,6 +1026,80 @@ f :: () -- f = () +``` + +## Preprocessor Directives + +Preprocessor directives are accepted and retained. + +``` haskell + #include + instance Monoid Penalty where + mempty = 0 + + #if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + #endif + + #define FOO 1 + #undef FOO + + #warning "WARNING" + #error "ERROR" +``` + +Multiline directives + +``` haskell + #define FOO \ + bar + + #if FOO \ + && BAR + foo = bar + #endif +``` + +Support for Hsc2hs #enum + +``` haskell + #enum CInt, \ + , fs = CTL_FS \ + , hw = CTL_HW \ + , kern = CTL_KERN \ + , net = CTL_NET \ + , vfs = CTL_VFS \ + , mem = CTL_VM +``` + +## Ignored Lines + +Ignore lines nested in `floskell-disable` and `floskell-enable` + +``` haskell +-- floskell-disable +This is ignored. +-- floskell-enable + +{- floskell-disable -} +And so is this. +{- floskell-enable -} +``` + +Ignore shebang lines + +``` haskell + #! /usr/bin/env nix-shell + #! nix-shell -p ghcid + #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [ shower ])" + #! nix-shell -i "ghcid -c 'ghci -Wall' -T':!pkill --full ghc\\ .\\*./Main.hs' -T main" + + module Main where + + import Shower + + main :: IO () + main = printer "Hello" ``` ## Indentation and Line Prefixes