Format Ormolu with Ormolu

This commit is contained in:
mrkkrp 2019-10-03 15:48:56 +02:00 committed by Mark Karpov
parent c386de89bd
commit 480d6edfb3
44 changed files with 1645 additions and 1545 deletions

View File

@ -33,7 +33,7 @@ jobs:
name: Check formatting
command: |
./format.sh
git diff --exit-code --color=always
nix-shell -p "(import ./nix/nixpkgs/default.nix).git" --command "git diff --exit-code --color=always"
- run:
name: Generate Haddocks
command: nix-build --attr ormolu.doc

View File

@ -41,10 +41,14 @@ let
}) haskellPackages;
in {
ormolu = haskellPackages.ormolu;
locales = pkgs.glibcLocales;
ormoluShell = haskellPackages.shellFor {
packages = ps: [ ps.ormolu ];
buildInputs = [ haskellPackages.cabal-install haskellPackages.ghcid ];
packages = ps: [
ps.ormolu
];
buildInputs = [
haskellPackages.cabal-install
haskellPackages.ghcid
];
};
inherit ormoluOverlay ormoluCompiler;
hackage = ormolizedPackages false;

View File

@ -1,10 +1,11 @@
#!/usr/bin/env bash
#!/usr/bin/env nix-shell
#!nix-shell -p "(import ./default.nix {}).ormolu" -i bash --pure
#
# Format Ormolu using current version of Ormolu.
set -e
export LANG="en_US.UTF-8"
export LANG="C.UTF-8"
nix run -f default.nix ormolu locales -c ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
nix run -f default.nix ormolu locales -c ormolu --mode inplace $(find tests -type f -name "*.hs")
ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
ormolu --mode inplace $(find tests -type f -name "*.hs")

View File

@ -1,24 +1,25 @@
-- | A formatter for Haskell source code.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
-- | A formatter for Haskell source code.
module Ormolu
( ormolu
, ormoluFile
, ormoluStdin
, Config (..)
, defaultConfig
, DynOption (..)
, OrmoluException (..)
, withPrettyOrmoluExceptions
( ormolu,
ormoluFile,
ormoluStdin,
Config (..),
defaultConfig,
DynOption (..),
OrmoluException (..),
withPrettyOrmoluExceptions,
)
where
import qualified CmdLineParser as GHC
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import Data.Text (Text)
import qualified Data.Text as T
import Debug.Trace
import Ormolu.Config
import Ormolu.Diff
@ -27,10 +28,8 @@ import Ormolu.Parser
import Ormolu.Parser.Result
import Ormolu.Printer
import Ormolu.Utils (showOutputable)
import System.IO (hGetContents, stdin)
import qualified CmdLineParser as GHC
import qualified Data.Text as T
import qualified SrcLoc as GHC
import System.IO (hGetContents, stdin)
-- | Format a 'String', return formatted version as 'Text'.
--
@ -42,13 +41,15 @@ import qualified SrcLoc as GHC
-- side-effects though.
-- * Takes file name just to use it in parse error messages.
-- * Throws 'OrmoluException'.
ormolu
:: MonadIO m
=> Config -- ^ Ormolu configuration
-> FilePath -- ^ Location of source file
-> String -- ^ Input to format
-> m Text
ormolu ::
MonadIO m =>
-- | Ormolu configuration
Config ->
-- | Location of source file
FilePath ->
-- | Input to format
String ->
m Text
ormolu cfg path str = do
(ws, result0) <-
parseModule' cfg OrmoluParsingFailed path str
@ -82,7 +83,8 @@ ormolu cfg path str = do
let txt2 = printModule result1
in case diffText txt txt2 pathRendered of
Nothing -> return ()
Just (loc, l, r) -> liftIO $
Just (loc, l, r) ->
liftIO $
throwIO (OrmoluNonIdempotentOutput loc l r)
return txt
@ -91,12 +93,14 @@ ormolu cfg path str = do
--
-- > ormoluFile cfg path =
-- > liftIO (readFile path) >>= ormolu cfg path
ormoluFile
:: MonadIO m
=> Config -- ^ Ormolu configuration
-> FilePath -- ^ Location of source file
-> m Text -- ^ Resulting rendition
ormoluFile ::
MonadIO m =>
-- | Ormolu configuration
Config ->
-- | Location of source file
FilePath ->
-- | Resulting rendition
m Text
ormoluFile cfg path =
liftIO (readFile path) >>= ormolu cfg path
@ -104,11 +108,12 @@ ormoluFile cfg path =
--
-- > ormoluStdin cfg =
-- > liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"
ormoluStdin
:: MonadIO m
=> Config -- ^ Ormolu configuration
-> m Text -- ^ Resulting rendition
ormoluStdin ::
MonadIO m =>
-- | Ormolu configuration
Config ->
-- | Resulting rendition
m Text
ormoluStdin cfg =
liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"
@ -116,15 +121,17 @@ ormoluStdin cfg =
-- Helpers
-- | A wrapper around 'parseModule'.
parseModule'
:: MonadIO m
=> Config -- ^ Ormolu configuration
-> (GHC.SrcSpan -> String -> OrmoluException)
-- ^ How to obtain 'OrmoluException' to throw when parsing fails
-> FilePath -- ^ File name to use in errors
-> String -- ^ Actual input for the parser
-> m ([GHC.Warn], ParseResult)
parseModule' ::
MonadIO m =>
-- | Ormolu configuration
Config ->
-- | How to obtain 'OrmoluException' to throw when parsing fails
(GHC.SrcSpan -> String -> OrmoluException) ->
-- | File name to use in errors
FilePath ->
-- | Actual input for the parser
String ->
m ([GHC.Warn], ParseResult)
parseModule' cfg mkException path str = do
(ws, r) <- parseModule cfg path str
case r of
@ -132,9 +139,9 @@ parseModule' cfg mkException path str = do
Right x -> return (ws, x)
-- | Pretty-print a 'GHC.Warn'.
showWarn :: GHC.Warn -> String
showWarn (GHC.Warn reason l) = unlines
[ showOutputable reason
, showOutputable l
showWarn (GHC.Warn reason l) =
unlines
[ showOutputable reason,
showOutputable l
]

View File

@ -3,52 +3,51 @@
{-# LANGUAGE RecordWildCards #-}
-- | Configuration options used by the tool.
module Ormolu.Config
( Config (..)
, defaultConfig
, DynOption (..)
, dynOptionToLocatedStr
( Config (..),
defaultConfig,
DynOption (..),
dynOptionToLocatedStr,
)
where
import qualified SrcLoc as GHC
-- | Ormolu configuration.
data Config = Config
{ cfgDynOptions :: ![DynOption]
-- ^ Dynamic options to pass to GHC parser
, cfgUnsafe :: !Bool
-- ^ Do formatting faster but without automatic detection of defects
, cfgDebug :: !Bool
-- ^ Output information useful for debugging
, cfgTolerateCpp :: !Bool
-- ^ Do not fail if CPP pragma is present (still doesn't handle CPP but
data Config
= Config
{ -- | Dynamic options to pass to GHC parser
cfgDynOptions :: ![DynOption],
-- | Do formatting faster but without automatic detection of defects
cfgUnsafe :: !Bool,
-- | Output information useful for debugging
cfgDebug :: !Bool,
-- | Do not fail if CPP pragma is present (still doesn't handle CPP but
-- useful for formatting of files that enable the extension without
-- actually containing CPP macros)
, cfgCheckIdempotency :: !Bool
-- ^ Checks if re-formatting the result is idempotent.
} deriving (Eq, Show)
cfgTolerateCpp :: !Bool,
-- | Checks if re-formatting the result is idempotent.
cfgCheckIdempotency :: !Bool
}
deriving (Eq, Show)
-- | Default 'Config'.
defaultConfig :: Config
defaultConfig = Config
{ cfgDynOptions = []
, cfgUnsafe = False
, cfgDebug = False
, cfgTolerateCpp = False
, cfgCheckIdempotency = False
{ cfgDynOptions = [],
cfgUnsafe = False,
cfgDebug = False,
cfgTolerateCpp = False,
cfgCheckIdempotency = False
}
-- | A wrapper for dynamic options.
newtype DynOption = DynOption
newtype DynOption
= DynOption
{ unDynOption :: String
} deriving (Eq, Ord, Show)
}
deriving (Eq, Ord, Show)
-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
dynOptionToLocatedStr :: DynOption -> GHC.Located String
dynOptionToLocatedStr (DynOption o) = GHC.L GHC.noSrcSpan o

View File

@ -3,11 +3,10 @@
{-# LANGUAGE RecordWildCards #-}
-- | Diffing GHC ASTs modulo span positions.
module Ormolu.Diff
( Diff(..)
, diffParseResult
, diffText
( Diff (..),
diffParseResult,
diffText,
)
where
@ -15,19 +14,20 @@ import BasicTypes (SourceText)
import Data.ByteString (ByteString)
import Data.Generics
import Data.Text (Text)
import qualified Data.Text as T
import qualified FastString as GHC
import GHC
import Ormolu.Imports (sortImports)
import Ormolu.Parser.Result
import Ormolu.Utils
import qualified Data.Text as T
import qualified FastString as GHC
import qualified SrcLoc as GHC
-- | Result of comparing two 'ParseResult's.
data Diff
= Same -- ^ Two parse results are the same
| Different [SrcSpan] -- ^ Two parse results differ
= -- | Two parse results are the same
Same
| -- | Two parse results differ
Different [SrcSpan]
instance Semigroup Diff where
Same <> a = a
@ -38,21 +38,21 @@ instance Monoid Diff where
mempty = Same
-- | Return 'Diff' of two 'ParseResult's.
diffParseResult :: ParseResult -> ParseResult -> Diff
diffParseResult
ParseResult { prCommentStream = cstream0
, prParsedSource = ps0
ParseResult
{ prCommentStream = cstream0,
prParsedSource = ps0
}
ParseResult { prCommentStream = cstream1
, prParsedSource = ps1
ParseResult
{ prCommentStream = cstream1,
prParsedSource = ps1
} =
matchIgnoringSrcSpans cstream0 cstream1 <>
matchIgnoringSrcSpans ps0 ps1
matchIgnoringSrcSpans cstream0 cstream1
<> matchIgnoringSrcSpans ps0 ps1
-- | Compare two values for equality disregarding differences in 'SrcSpan's
-- and the ordering of import lists.
matchIgnoringSrcSpans :: Data a => a -> a -> Diff
matchIgnoringSrcSpans = genericQuery
where
@ -60,24 +60,27 @@ matchIgnoringSrcSpans = genericQuery
genericQuery x y
-- NOTE 'ByteString' implement 'Data' instance manually and does not
-- implement 'toConstr', so we have to deal with it in a special way.
| Just x' <- cast x, Just y' <- cast y =
| Just x' <- cast x,
Just y' <- cast y =
if x' == (y' :: ByteString)
then Same
else Different []
| typeOf x == typeOf y, toConstr x == toConstr y =
mconcat $ gzipWithQ
| typeOf x == typeOf y,
toConstr x == toConstr y =
mconcat $
gzipWithQ
( genericQuery
`extQ` srcSpanEq
`extQ` hsModuleEq
`extQ` sourceTextEq
`extQ` hsDocStringEq
`ext2Q` forLocated)
x y
`ext2Q` forLocated
)
x
y
| otherwise = Different []
srcSpanEq :: SrcSpan -> GenericQ Diff
srcSpanEq _ _ = Same
hsModuleEq :: HsModule GhcPs -> GenericQ Diff
hsModuleEq hs0 hs1' =
case cast hs1' :: Maybe (HsModule GhcPs) of
@ -86,10 +89,8 @@ matchIgnoringSrcSpans = genericQuery
matchIgnoringSrcSpans
hs0 {hsmodImports = sortImports (hsmodImports hs0)}
hs1 {hsmodImports = sortImports (hsmodImports hs1)}
sourceTextEq :: SourceText -> GenericQ Diff
sourceTextEq _ _ = Same
hsDocStringEq :: HsDocString -> GenericQ Diff
hsDocStringEq str0 str1' =
case cast str1' :: Maybe HsDocString of
@ -98,14 +99,12 @@ matchIgnoringSrcSpans = genericQuery
if splitDocString str0 == splitDocString str1
then Same
else Different []
forLocated
:: (Data e0, Data e1)
=> GenLocated e0 e1
-> GenericQ Diff
forLocated ::
(Data e0, Data e1) =>
GenLocated e0 e1 ->
GenericQ Diff
forLocated x@(L mspn _) y =
maybe id appendSpan (cast mspn) (genericQuery x y)
appendSpan :: SrcSpan -> Diff -> Diff
appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
where
@ -115,17 +114,20 @@ matchIgnoringSrcSpans = genericQuery
-- | Diff two texts and return the location they start to differ, alongside
-- with excerpts around that location.
diffText
:: Text -- ^ Text before
-> Text -- ^ Text after
-> FilePath -- ^ Path to use to construct 'GHC.RealSrcLoc'
-> Maybe (GHC.RealSrcLoc, Text, Text)
diffText ::
-- | Text before
Text ->
-- | Text after
Text ->
-- | Path to use to construct 'GHC.RealSrcLoc'
FilePath ->
Maybe (GHC.RealSrcLoc, Text, Text)
diffText left right fp =
case go (0, 0, 0) left right of
Nothing -> Nothing
Just (row, col, loc) -> Just (
GHC.mkRealSrcLoc (GHC.mkFastString fp) row col,
Just (row, col, loc) ->
Just
( GHC.mkRealSrcLoc (GHC.mkFastString fp) row col,
getSpan loc left,
getSpan loc right
)
@ -136,8 +138,10 @@ diffText left right fp =
(Nothing, Nothing) ->
Nothing
-- first chars are the same, adjust position and recurse
(Just (c1, r1), Just (c2, r2)) | c1 == c2 ->
let (row', col', loc') = if c1 == '\n'
(Just (c1, r1), Just (c2, r2))
| c1 == c2 ->
let (row', col', loc') =
if c1 == '\n'
then (row + 1, 0, loc + 1)
else (row, col + 1, loc + 1)
in go (row', col', loc') r1 r2

View File

@ -1,54 +1,55 @@
{-# LANGUAGE LambdaCase #-}
-- | 'OrmoluException' type and surrounding definitions.
module Ormolu.Exception
( OrmoluException (..)
, withPrettyOrmoluExceptions
( OrmoluException (..),
withPrettyOrmoluExceptions,
)
where
import Control.Exception
import Data.Text (Text)
import qualified GHC
import Ormolu.Utils (showOutputable)
import qualified Outputable as GHC
import System.Exit (ExitCode (..), exitWith)
import System.IO
import qualified GHC
import qualified Outputable as GHC
-- | Ormolu exception representing all cases when Ormolu can fail.
data OrmoluException
= OrmoluCppEnabled FilePath
-- ^ Ormolu does not work with source files that use CPP
| OrmoluParsingFailed GHC.SrcSpan String
-- ^ Parsing of original source code failed
| OrmoluOutputParsingFailed GHC.SrcSpan String
-- ^ Parsing of formatted source code failed
| OrmoluASTDiffers FilePath [GHC.SrcSpan]
-- ^ Original and resulting ASTs differ
| OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
-- ^ Formatted source code is not idempotent
= -- | Ormolu does not work with source files that use CPP
OrmoluCppEnabled FilePath
| -- | Parsing of original source code failed
OrmoluParsingFailed GHC.SrcSpan String
| -- | Parsing of formatted source code failed
OrmoluOutputParsingFailed GHC.SrcSpan String
| -- | Original and resulting ASTs differ
OrmoluASTDiffers FilePath [GHC.SrcSpan]
| -- | Formatted source code is not idempotent
OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
deriving (Eq, Show)
instance Exception OrmoluException where
displayException = \case
OrmoluCppEnabled path -> unlines
[ "CPP is not supported:"
, withIndent path
OrmoluCppEnabled path ->
unlines
[ "CPP is not supported:",
withIndent path
]
OrmoluParsingFailed s e ->
showParsingErr "Parsing of source code failed:" s [e]
OrmoluOutputParsingFailed s e ->
showParsingErr "Parsing of formatted code failed:" s [e] ++
"Please, consider reporting the bug.\n"
OrmoluASTDiffers path ss -> unlines $
showParsingErr "Parsing of formatted code failed:" s [e]
++ "Please, consider reporting the bug.\n"
OrmoluASTDiffers path ss ->
unlines $
[ "AST of input and AST of formatted code differ."
]
++ ( fmap withIndent $ case fmap (\s -> "at " ++ showOutputable s) ss of
[] -> ["in " ++ path]
xs -> xs) ++
[ "Please, consider reporting the bug." ]
xs -> xs
)
++ ["Please, consider reporting the bug."]
OrmoluNonIdempotentOutput loc left right ->
showParsingErr "Formatting is not idempotent:" loc
["before: " ++ show left, "after: " ++ show right]
@ -56,10 +57,10 @@ instance Exception OrmoluException where
-- | Inside this wrapper 'OrmoluException' will be caught and displayed
-- nicely using 'displayException'.
withPrettyOrmoluExceptions
:: IO a -- ^ Action that may throw the exception
-> IO a
withPrettyOrmoluExceptions ::
-- | Action that may throw the exception
IO a ->
IO a
withPrettyOrmoluExceptions m = m `catch` h
where
h :: OrmoluException -> IO a
@ -78,14 +79,14 @@ withPrettyOrmoluExceptions m = m `catch` h
-- Helpers
-- | Show a parse error.
showParsingErr :: GHC.Outputable a => String -> a -> [String] -> String
showParsingErr msg spn err = unlines $
[ msg
, withIndent (showOutputable spn)
] ++ map withIndent err
showParsingErr msg spn err =
unlines $
[ msg,
withIndent (showOutputable spn)
]
++ map withIndent err
-- | Indent with 2 spaces for readability.
withIndent :: String -> String
withIndent txt = " " ++ txt

View File

@ -2,9 +2,8 @@
{-# LANGUAGE RankNTypes #-}
-- | Manipulations on import lists.
module Ormolu.Imports
( sortImports
( sortImports,
)
where
@ -19,17 +18,16 @@ import Ormolu.Utils (notImplemented)
-- | Sort imports by module name. This also sorts explicit import lists for
-- each declaration.
sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
where
sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs
sortImportLists decl =
decl { ideclHiding = second (fmap sortLies) <$> ideclHiding decl
decl
{ ideclHiding = second (fmap sortLies) <$> ideclHiding decl
}
-- | Compare two @'LImportDecl' 'GhcPs'@ things.
compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
compareIdecl (L _ m0) (L _ m1) =
case (isPrelude n0, isPrelude n1) of
@ -43,12 +41,10 @@ compareIdecl (L _ m0) (L _ m1) =
isPrelude = (== "Prelude") . moduleNameString
-- | Sort located import or export.
sortLies :: [LIE GhcPs] -> [LIE GhcPs]
sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)
-- | Sort imports\/exports inside of 'IEThingWith'.
sortThings :: IE GhcPs -> IE GhcPs
sortThings = \case
IEThingWith NoExt x w xs fl ->
@ -56,12 +52,10 @@ sortThings = \case
other -> other
-- | Compare two located imports or exports.
compareIE :: IE GhcPs -> IE GhcPs -> Ordering
compareIE = compareIewn `on` getIewn
-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
getIewn :: IE GhcPs -> IEWrappedName RdrName
getIewn = \case
IEVar NoExt x -> unLoc x
@ -75,7 +69,6 @@ getIewn = \case
XIE NoExt -> notImplemented "XIE"
-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y
compareIewn (IEName _) (IEPattern _) = LT

View File

@ -3,51 +3,54 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Parser for Haskell source code.
module Ormolu.Parser
( parseModule
, manualExts
( parseModule,
manualExts,
)
where
import qualified CmdLineParser as GHC
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.List (isPrefixOf, foldl', (\\))
import Data.List ((\\), foldl', isPrefixOf)
import Data.Maybe (catMaybes)
import qualified DynFlags as GHC
import qualified FastString as GHC
import GHC hiding (IE, parseModule, parser)
import GHC.LanguageExtensions.Type (Extension (..))
import GHC.Paths (libdir)
import qualified HeaderInfo as GHC
import qualified Lexer as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import qualified CmdLineParser as GHC
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified HeaderInfo as GHC
import qualified Lexer as GHC
import qualified Outputable as GHC
import qualified Parser as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
-- | Parse a complete module from string.
parseModule
:: MonadIO m
=> Config -- ^ Ormolu configuration
-> FilePath -- ^ File name (only for source location annotations)
-> String -- ^ Input for parser
-> m ( [GHC.Warn]
, Either (SrcSpan, String) ParseResult
parseModule ::
MonadIO m =>
-- | Ormolu configuration
Config ->
-- | File name (only for source location annotations)
FilePath ->
-- | Input for parser
String ->
m
( [GHC.Warn],
Either (SrcSpan, String) ParseResult
)
parseModule Config {..} path input' = liftIO $ do
let (input, extraComments) = stripLinePragmas path input'
(ws, dynFlags) <- ghcWrapper $ do
dynFlags0 <- initDynFlagsPure path input
(dynFlags1, _, ws) <- GHC.parseDynamicFilePragma
(dynFlags1, _, ws) <-
GHC.parseDynamicFilePragma
dynFlags0
(dynOptionToLocatedStr <$> cfgDynOptions)
return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)
@ -62,34 +65,33 @@ parseModule Config {..} path input' = liftIO $ do
GHC.POk pstate pmod ->
let (comments, exts) = mkCommentStream extraComments pstate
in Right ParseResult
{ prParsedSource = pmod
, prAnns = mkAnns pstate
, prCommentStream = comments
, prExtensions = exts
{ prParsedSource = pmod,
prAnns = mkAnns pstate,
prCommentStream = comments,
prExtensions = exts
}
return (ws, r)
-- | Extensions that are not enabled automatically and should be activated
-- by user.
manualExts :: [Extension]
manualExts =
[ Arrows -- steals proc
, Cpp -- forbidden
, BangPatterns -- makes certain patterns with ! fail
, PatternSynonyms -- steals the pattern keyword
, RecursiveDo -- steals the rec keyword
, StaticPointers -- steals static keyword
, TransformListComp -- steals the group keyword
, UnboxedTuples -- breaks (#) lens operator
, MagicHash -- screws {-# these things #-}
, TypeApplications -- steals (@) operator on some cases
, AlternativeLayoutRule
, AlternativeLayoutRuleTransitional
, MonadComprehensions
, UnboxedSums
, UnicodeSyntax -- gives special meanings to operators like (→)
, TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
[ Arrows, -- steals proc
Cpp, -- forbidden
BangPatterns, -- makes certain patterns with ! fail
PatternSynonyms, -- steals the pattern keyword
RecursiveDo, -- steals the rec keyword
StaticPointers, -- steals static keyword
TransformListComp, -- steals the group keyword
UnboxedTuples, -- breaks (#) lens operator
MagicHash, -- screws {-# these things #-}
TypeApplications, -- steals (@) operator on some cases
AlternativeLayoutRule,
AlternativeLayoutRuleTransitional,
MonadComprehensions,
UnboxedSums,
UnicodeSyntax, -- gives special meanings to operators like (→)
TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
-- apparently interferes with QuasiQuotes in
-- weird ways
]
@ -106,12 +108,14 @@ manualExts =
-- environment files. However this only works if there is no invocation of
-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets
-- #15513, #15541.
initDynFlagsPure
:: GHC.GhcMonad m
=> FilePath -- ^ Module path
-> String -- ^ Module contents
-> m GHC.DynFlags -- ^ Dynamic flags for that module
initDynFlagsPure ::
GHC.GhcMonad m =>
-- | Module path
FilePath ->
-- | Module contents
String ->
-- | Dynamic flags for that module
m GHC.DynFlags
initDynFlagsPure fp input = do
-- I was told we could get away with using the 'unsafeGlobalDynFlags'. as
-- long as 'parseDynamicFilePragma' is impure there seems to be no reason
@ -122,14 +126,14 @@ initDynFlagsPure fp input = do
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
-- Prevent parsing of .ghc.environment.* "package environment files"
(dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
(dflags3, _, _) <-
GHC.parseDynamicFlagsCmdLine
dflags2
[GHC.noLoc "-hide-all-packages"]
_ <- GHC.setSessionDynFlags dflags3
return dflags3
-- | Default runner of 'GHC.Ghc' action in 'IO'.
ghcWrapper :: GHC.Ghc a -> IO a
ghcWrapper act =
let GHC.FlushOut flushOut = GHC.defaultFlushOut
@ -137,13 +141,17 @@ ghcWrapper act =
`finally` flushOut
-- | Run a 'GHC.P' computation.
runParser
:: GHC.P a -- ^ Computation to run
-> GHC.DynFlags -- ^ Dynamic flags
-> FilePath -- ^ Module path
-> String -- ^ Module contents
-> GHC.ParseResult a -- ^ Parse result
runParser ::
-- | Computation to run
GHC.P a ->
-- | Dynamic flags
GHC.DynFlags ->
-- | Module path
FilePath ->
-- | Module contents
String ->
-- | Parse result
GHC.ParseResult a
runParser parser flags filename input = GHC.unP parser parseState
where
location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
@ -152,7 +160,6 @@ runParser parser flags filename input = GHC.unP parser parseState
-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into
-- comments.
stripLinePragmas :: FilePath -> String -> (String, [Located String])
stripLinePragmas path = unlines' . unzip . findLines path . lines
where
@ -185,7 +192,6 @@ getPragma s@(x:xs)
-- | Enable all language extensions that we think should be enabled by
-- default for ease of use.
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
where

View File

@ -1,36 +1,33 @@
-- | Ormolu-specific representation of GHC annotations.
module Ormolu.Parser.Anns
( Anns (..)
, emptyAnns
, mkAnns
, lookupAnns
( Anns (..),
emptyAnns,
mkAnns,
lookupAnns,
)
where
import Data.Map.Strict (Map)
import Data.Maybe (mapMaybe)
import SrcLoc
import qualified Data.Map.Strict as M
import Data.Maybe (mapMaybe)
import qualified GHC
import qualified Lexer as GHC
import SrcLoc
-- | Ormolu-specific representation of GHC annotations.
newtype Anns = Anns (Map RealSrcSpan [GHC.AnnKeywordId])
deriving (Eq)
-- | Empty 'Anns'.
emptyAnns :: Anns
emptyAnns = Anns M.empty
-- | Create 'Anns' from 'GHC.PState'.
mkAnns
:: GHC.PState
-> Anns
mkAnns pstate = Anns $
mkAnns ::
GHC.PState ->
Anns
mkAnns pstate =
Anns $
M.fromListWith (++) (mapMaybe f (GHC.annotations pstate))
where
f ((spn, kid), _) =
@ -39,10 +36,11 @@ mkAnns pstate = Anns $
UnhelpfulSpan _ -> Nothing
-- | Lookup 'GHC.AnnKeywordId's corresponding to a given 'SrcSpan'.
lookupAnns
:: SrcSpan -- ^ Span to lookup with
-> Anns -- ^ Collection of annotations
-> [GHC.AnnKeywordId]
lookupAnns ::
-- | Span to lookup with
SrcSpan ->
-- | Collection of annotations
Anns ->
[GHC.AnnKeywordId]
lookupAnns (RealSrcSpan rspn) (Anns m) = M.findWithDefault [] rspn m
lookupAnns (UnhelpfulSpan _) _ = []

View File

@ -5,82 +5,79 @@
{-# LANGUAGE TupleSections #-}
-- | Functions for working with comment stream.
module Ormolu.Parser.CommentStream
( CommentStream (..)
, Comment (..)
, mkCommentStream
, isPrevHaddock
, isMultilineComment
, showCommentStream
( CommentStream (..),
Comment (..),
mkCommentStream,
isPrevHaddock,
isMultilineComment,
showCommentStream,
)
where
import Data.Char (isSpace)
import Data.Data (Data)
import Data.Either (partitionEithers)
import Data.List (isPrefixOf, sortOn, dropWhileEnd)
import Data.List (dropWhileEnd, isPrefixOf, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
import qualified GHC
import qualified Lexer as GHC
import Ormolu.Parser.Pragma
import Ormolu.Utils (showOutputable)
import SrcLoc
import qualified Data.List.NonEmpty as NE
import qualified GHC
import qualified Lexer as GHC
-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
-- beginning of corresponding spans.
newtype CommentStream = CommentStream [RealLocated Comment]
deriving (Eq, Data, Semigroup, Monoid)
-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
newtype Comment = Comment (NonEmpty String)
deriving (Eq, Show, Data)
-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of
-- extensions here, which is not sorted in any way. The pragma comment are
-- removed from the 'CommentStream'.
mkCommentStream
:: [Located String] -- ^ Extra comments to include
-> GHC.PState -- ^ Parser state to use for comment extraction
-> (CommentStream, [Pragma])
-- ^ Comment stream and a set of extracted pragmas
mkCommentStream ::
-- | Extra comments to include
[Located String] ->
-- | Parser state to use for comment extraction
GHC.PState ->
-- | Comment stream and a set of extracted pragmas
(CommentStream, [Pragma])
mkCommentStream extraComments pstate =
( CommentStream $
-- NOTE It's easier to normalize pragmas right when we construct comment
-- streams. Because this way we need to do it only once and when we
-- perform checking later they'll automatically match.
mkComment <$> sortOn (realSrcSpanStart . getLoc) comments
, pragmas
mkComment <$> sortOn (realSrcSpanStart . getLoc) comments,
pragmas
)
where
(comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
rawComments = mapMaybe toRealSpan $
extraComments ++
mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate) ++
concatMap (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
rawComments =
mapMaybe toRealSpan $
extraComments
++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
++ concatMap (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
(GHC.annotations_comments pstate)
-- | Test whether a 'Comment' looks like a Haddock following a definition,
-- i.e. something starting with @-- ^@.
isPrevHaddock :: Comment -> Bool
isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
-- | Is this comment multiline-style?
isMultilineComment :: Comment -> Bool
isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
-- | Pretty-print a 'CommentStream'.
showCommentStream :: CommentStream -> String
showCommentStream (CommentStream xs) = unlines $
showCommentStream (CommentStream xs) =
unlines $
showComment <$> xs
where
showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
@ -91,9 +88,9 @@ showCommentStream (CommentStream xs) = unlines $
-- | Normalize comment string. Sometimes one multi-line comment is turned
-- into several lines for subsequent outputting with correct indentation for
-- each line.
mkComment :: RealLocated String -> RealLocated Comment
mkComment (L l s) = L l . Comment . fmap dropTrailing $
mkComment (L l s) =
L l . Comment . fmap dropTrailing $
if "{-" `isPrefixOf` s
then case NE.nonEmpty (lines s) of
Nothing -> s :| []
@ -110,7 +107,6 @@ mkComment (L l s) = L l . Comment . fmap dropTrailing $
startIndent = srcSpanStartCol l - 1
-- | Get a 'String' from 'GHC.AnnotationComment'.
unAnnotationComment :: GHC.AnnotationComment -> Maybe String
unAnnotationComment = \case
GHC.AnnDocCommentNext _ -> Nothing -- @-- |@
@ -132,10 +128,9 @@ toRealSpan _ = Nothing
-- | If a given comment is a pragma, return it in parsed form in 'Right'.
-- Otherwise return the original comment unchanged.
partitionComments
:: RealLocated String
-> Either (RealLocated String) Pragma
partitionComments ::
RealLocated String ->
Either (RealLocated String) Pragma
partitionComments input =
case parsePragma (unLoc input) of
Nothing -> Left input

View File

@ -1,38 +1,39 @@
-- | A module for parsing of pragmas from comments.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | A module for parsing of pragmas from comments.
module Ormolu.Parser.Pragma
( Pragma (..)
, parsePragma
( Pragma (..),
parsePragma,
)
where
import Control.Monad
import Data.Char (toLower, isSpace)
import Data.Char (isSpace, toLower)
import Data.List
import qualified EnumSet as ES
import FastString (mkFastString, unpackFS)
import Module (newSimpleUnitId, ComponentId (..))
import qualified Lexer as L
import Module (ComponentId (..), newSimpleUnitId)
import SrcLoc
import StringBuffer
import qualified EnumSet as ES
import qualified Lexer as L
-- | Ormolu's representation of pragmas.
data Pragma
= PragmaLanguage [String] -- ^ Language pragma
| PragmaOptionsGHC String -- ^ GHC options pragma
| PragmaOptionsHaddock String -- ^ Haddock options pragma
= -- | Language pragma
PragmaLanguage [String]
| -- | GHC options pragma
PragmaOptionsGHC String
| -- | Haddock options pragma
PragmaOptionsHaddock String
deriving (Show, Eq)
-- | Extract a pragma from a comment if possible, or return 'Nothing'
-- otherwise.
parsePragma
:: String -- ^ Comment to try to parse
-> Maybe Pragma
parsePragma ::
-- | Comment to try to parse
String ->
Maybe Pragma
parsePragma input = do
inputNoPrefix <- stripPrefix "{-#" input
guard ("#-}" `isSuffixOf` input)
@ -49,7 +50,6 @@ parsePragma input = do
-- | Assuming the input consists of a series of tokens from a language
-- pragma, return the set of enabled extensions.
parseExtensions :: String -> Maybe [String]
parseExtensions str = tokenize str >>= go
where
@ -59,7 +59,6 @@ parseExtensions str = tokenize str >>= go
_ -> Nothing
-- | Tokenize a given input using GHC's lexer.
tokenize :: String -> Maybe [L.Token]
tokenize input =
case L.unP pLexer parseState of
@ -70,14 +69,13 @@ tokenize input =
buffer = stringToStringBuffer input
parseState = L.mkPStatePure parserFlags buffer location
parserFlags = L.ParserFlags
{ L.pWarningFlags = ES.empty
, L.pExtensionFlags = ES.empty
, L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString ""))
, L.pExtsBitmap = 0xffffffffffffffff
{ L.pWarningFlags = ES.empty,
L.pExtensionFlags = ES.empty,
L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),
L.pExtsBitmap = 0xffffffffffffffff
}
-- | Haskell lexer.
pLexer :: L.P [L.Token]
pLexer = go
where

View File

@ -1,10 +1,9 @@
-- | A type for result of parsing.
{-# LANGUAGE RecordWildCards #-}
-- | A type for result of parsing.
module Ormolu.Parser.Result
( ParseResult (..)
, prettyPrintParseResult
( ParseResult (..),
prettyPrintParseResult,
)
where
@ -14,24 +13,24 @@ import Ormolu.Parser.CommentStream
import Ormolu.Parser.Pragma (Pragma)
-- | A collection of data that represents a parsed module in Ormolu.
data ParseResult = ParseResult
{ prParsedSource :: ParsedSource
-- ^ 'ParsedSource' from GHC
, prAnns :: Anns
-- ^ Ormolu-specfic representation of annotations
, prCommentStream :: CommentStream
-- ^ Comment stream
, prExtensions :: [Pragma]
-- ^ Extensions enabled in that module
data ParseResult
= ParseResult
{ -- | 'ParsedSource' from GHC
prParsedSource :: ParsedSource,
-- | Ormolu-specfic representation of annotations
prAnns :: Anns,
-- | Comment stream
prCommentStream :: CommentStream,
-- | Extensions enabled in that module
prExtensions :: [Pragma]
}
-- | Pretty-print a 'ParseResult'.
prettyPrintParseResult :: ParseResult -> String
prettyPrintParseResult ParseResult {..} = unlines
[ "parse result:"
, " comment stream:"
, showCommentStream prCommentStream
prettyPrintParseResult ParseResult {..} =
unlines
[ "parse result:",
" comment stream:",
showCommentStream prCommentStream
-- XXX extend as needed
]

View File

@ -3,9 +3,8 @@
{-# LANGUAGE RecordWildCards #-}
-- | Pretty-printer for Haskell AST.
module Ormolu.Printer
( printModule
( printModule,
)
where
@ -16,10 +15,11 @@ import Ormolu.Printer.Meat.Module
import Ormolu.Printer.SpanStream
-- | Render a module.
printModule
:: ParseResult -- ^ Result of parsing
-> Text -- ^ Resulting rendition
printModule ::
-- | Result of parsing
ParseResult ->
-- | Resulting rendition
Text
printModule ParseResult {..} =
runR (p_hsModule prExtensions prParsedSource)
(mkSpanStream prParsedSource)

View File

@ -5,51 +5,56 @@
-- | Printing combinators. The definitions here are presented in such an
-- order so you can just go through the Haddocks and by the end of the file
-- you should have a pretty good idea how to program rendering logic.
module Ormolu.Printer.Combinators
( -- * The 'R' monad
R
, runR
, getAnns
, getEnclosingSpan
R,
runR,
getAnns,
getEnclosingSpan,
-- * Combinators
-- ** Basic
, txt
, atom
, space
, newline
, inci
, located
, located'
, switchLayout
, Layout (..)
, vlayout
, getLayout
, breakpoint
, breakpoint'
txt,
atom,
space,
newline,
inci,
located,
located',
switchLayout,
Layout (..),
vlayout,
getLayout,
breakpoint,
breakpoint',
-- ** Formatting lists
, sep
, sepSemi
, canUseBraces
, useBraces
, dontUseBraces
sep,
sepSemi,
canUseBraces,
useBraces,
dontUseBraces,
-- ** Wrapping
, BracketStyle (..)
, sitcc
, backticks
, banana
, braces
, brackets
, parens
, parensHash
, pragmaBraces
, pragma
BracketStyle (..),
sitcc,
backticks,
banana,
braces,
brackets,
parens,
parensHash,
pragmaBraces,
pragma,
-- ** Literals
, comma
comma,
-- ** Comments
, HaddockStyle (..)
, setLastCommentSpan
, getLastCommentSpan
HaddockStyle (..),
setLastCommentSpan,
getLastCommentSpan,
)
where
@ -70,12 +75,13 @@ import SrcLoc
-- Roughly, the rule for using 'located' is that every time there is a
-- 'Located' wrapper, it should be “discharged” with a corresponding
-- 'located' invocation.
located
:: Data a
=> Located a -- ^ Thing to enter
-> (a -> R ()) -- ^ How to render inner value
-> R ()
located ::
Data a =>
-- | Thing to enter
Located a ->
-- | How to render inner value
(a -> R ()) ->
R ()
located loc f = do
let withRealLocated (L l a) g =
case l of
@ -93,12 +99,13 @@ located loc f = do
withRealLocated loc spitFollowingComments
-- | A version of 'located' with arguments flipped.
located'
:: Data a
=> (a -> R ()) -- ^ How to render inner value
-> Located a -- ^ Thing to enter
-> R ()
located' ::
Data a =>
-- | How to render inner value
(a -> R ()) ->
-- | Thing to enter
Located a ->
R ()
located' = flip located
-- | Set layout according to combination of given 'SrcSpan's for a given.
@ -107,15 +114,15 @@ located' = flip located
-- provided by GHC AST. It is relatively rare that this one is needed.
--
-- Given empty list this function will set layout to single line.
switchLayout
:: [SrcSpan] -- ^ Span that controls layout
-> R () -- ^ Computation to run with changed layout
-> R ()
switchLayout ::
-- | Span that controls layout
[SrcSpan] ->
-- | Computation to run with changed layout
R () ->
R ()
switchLayout spans' = enterLayout (spansLayout spans')
-- | Which layout combined spans result in?
spansLayout :: [SrcSpan] -> Layout
spansLayout = \case
[] -> SingleLine
@ -128,7 +135,6 @@ spansLayout = \case
-- multiline.
--
-- > breakpoint = vlayout space newline
breakpoint :: R ()
breakpoint = vlayout space newline
@ -136,7 +142,6 @@ breakpoint = vlayout space newline
-- layout.
--
-- > breakpoint' = vlayout (return ()) newline
breakpoint' :: R ()
breakpoint' = vlayout (return ()) newline
@ -144,12 +149,14 @@ breakpoint' = vlayout (return ()) newline
-- Formatting lists
-- | Render a collection of elements inserting a separator between them.
sep
:: R () -- ^ Separator
-> (a -> R ()) -- ^ How to render an element
-> [a] -- ^ Elements to render
-> R ()
sep ::
-- | Separator
R () ->
-- | How to render an element
(a -> R ()) ->
-- | Elements to render
[a] ->
R ()
sep s f xs = sequence_ (intersperse s (f <$> xs))
-- | Render a collection of elements layout-sensitively using given printer,
@ -161,11 +168,12 @@ sep s f xs = sequence_ (intersperse s (f <$> xs))
--
-- > dontUseBraces $ sepSemi txt ["foo", "bar"]
-- > == vlayout (txt "foo; bar") (txt "foo\nbar")
sepSemi
:: (a -> R ()) -- ^ How to render an element
-> [a] -- ^ Elements to render
-> R ()
sepSemi ::
-- | How to render an element
(a -> R ()) ->
-- | Elements to render
[a] ->
R ()
sepSemi f xs = vlayout singleLine multiLine
where
singleLine = do
@ -178,8 +186,7 @@ sepSemi f xs = vlayout singleLine multiLine
txt "{ "
sep (txt "; ") (dontUseBraces . f) xs'
txt " }"
else
sep (txt "; ") f xs'
else sep (txt "; ") f xs'
multiLine =
sep newline (dontUseBraces . f) xs
@ -187,13 +194,13 @@ sepSemi f xs = vlayout singleLine multiLine
-- Wrapping
-- | 'BracketStyle' controlling how closing bracket is rendered.
data BracketStyle
= N -- ^ Normal
| S -- ^ Shifted one level
= -- | Normal
N
| -- | Shifted one level
S
-- | Surround given entity by backticks.
backticks :: R () -> R ()
backticks m = do
txt "`"
@ -201,32 +208,26 @@ backticks m = do
txt "`"
-- | Surround given entity by banana brackets (i.e., from arrow notation.)
banana :: R () -> R ()
banana = brackets_ True "(|" "|)" N
-- | Surround given entity by curly braces @{@ and @}@.
braces :: BracketStyle -> R () -> R ()
braces = brackets_ False "{" "}"
-- | Surround given entity by square brackets @[@ and @]@.
brackets :: BracketStyle -> R () -> R ()
brackets = brackets_ False "[" "]"
-- | Surround given entity by parentheses @(@ and @)@.
parens :: BracketStyle -> R () -> R ()
parens = brackets_ False "(" ")"
-- | Surround given entity by @(# @ and @ #)@.
parensHash :: BracketStyle -> R () -> R ()
parensHash = brackets_ True "(#" "#)"
-- | Braces as used for pragmas: @{-#@ and @#-}@.
pragmaBraces :: R () -> R ()
pragmaBraces m = sitcc $ do
txt "{-#"
@ -236,25 +237,30 @@ pragmaBraces m = sitcc $ do
inci (txt "#-}")
-- | Surround the body with a pragma name and 'pragmaBraces'.
pragma
:: Text -- ^ Pragma text
-> R () -- ^ Pragma body
-> R ()
pragma ::
-- | Pragma text
Text ->
-- | Pragma body
R () ->
R ()
pragma pragmaText body = pragmaBraces $ do
txt pragmaText
breakpoint
body
-- | A helper for defining wrappers like 'parens' and 'braces'.
brackets_
:: Bool -- ^ Insert breakpoints around brackets
-> Text -- ^ Opening bracket
-> Text -- ^ Closing bracket
-> BracketStyle -- ^ Bracket style
-> R () -- ^ Inner expression
-> R ()
brackets_ ::
-- | Insert breakpoints around brackets
Bool ->
-- | Opening bracket
Text ->
-- | Closing bracket
Text ->
-- | Bracket style
BracketStyle ->
-- | Inner expression
R () ->
R ()
brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
where
singleLine = do
@ -277,6 +283,5 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
-- Literals
-- | Print @,@.
comma :: R ()
comma = txt ","

View File

@ -3,33 +3,32 @@
-- | Helpers for formatting of comments. This is low-level code, use
-- "Ormolu.Printer.Combinators" unless you know what you are doing.
module Ormolu.Printer.Comments
( spitPrecedingComments
, spitFollowingComments
, spitRemainingComments
( spitPrecedingComments,
spitFollowingComments,
spitRemainingComments,
)
where
import Control.Monad
import Data.Coerce (coerce)
import Data.Data (Data)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Ormolu.Parser.CommentStream
import Ormolu.Printer.Internal
import Ormolu.Utils (isModule)
import SrcLoc
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
----------------------------------------------------------------------------
-- Top-level
-- | Output all preceding comments for an element at given location.
spitPrecedingComments
:: Data a
=> RealLocated a -- ^ AST element to attach comments to
-> R ()
spitPrecedingComments ::
Data a =>
-- | AST element to attach comments to
RealLocated a ->
R ()
spitPrecedingComments ref = do
r <- getLastCommentSpan
case r of
@ -46,17 +45,16 @@ spitPrecedingComments ref = do
when (needsNewlineBefore (getLoc ref) lastSpn) newline
-- | Output all comments following an element at given location.
spitFollowingComments
:: Data a
=> RealLocated a -- ^ AST element of attach comments to
-> R ()
spitFollowingComments ::
Data a =>
-- | AST element of attach comments to
RealLocated a ->
R ()
spitFollowingComments ref = do
trimSpanStream (getLoc ref)
void $ handleCommentSeries (spitFollowingComment ref)
-- | Output all remaining comments in the comment stream.
spitRemainingComments :: R ()
spitRemainingComments = void $ handleCommentSeries spitRemainingComment
@ -64,12 +62,14 @@ spitRemainingComments = void $ handleCommentSeries spitRemainingComment
-- Single-comment functions
-- | Output a single preceding comment for an element at given location.
spitPrecedingComment
:: Data a
=> RealLocated a -- ^ AST element to attach comments to
-> Maybe RealSrcSpan -- ^ Location of last comment in the series
-> R Bool -- ^ Are we done?
spitPrecedingComment ::
Data a =>
-- | AST element to attach comments to
RealLocated a ->
-- | Location of last comment in the series
Maybe RealSrcSpan ->
-- | Are we done?
R Bool
spitPrecedingComment (L ref a) mlastSpn = do
let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
withPoppedComment p $ \l comment -> do
@ -91,12 +91,14 @@ spitPrecedingComment (L ref a) mlastSpn = do
-- | Output a comment that follows element at given location immediately on
-- the same line, if there is any.
spitFollowingComment
:: Data a
=> RealLocated a -- ^ AST element to attach comments to
-> Maybe RealSrcSpan -- ^ Location of last comment in the series
-> R Bool -- ^ Are we done?
spitFollowingComment ::
Data a =>
-- | AST element to attach comments to
RealLocated a ->
-- | Location of last comment in the series
Maybe RealSrcSpan ->
-- | Are we done?
R Bool
spitFollowingComment (L ref a) mlastSpn = do
mnSpn <- nextEltSpan
-- Get first enclosing span that is not equal to reference span, i.e. it's
@ -104,7 +106,8 @@ spitFollowingComment (L ref a) mlastSpn = do
meSpn <- getEnclosingSpan (/= ref)
withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->
if theSameLinePost l ref && not (isModule a)
then if isMultilineComment comment
then
if isMultilineComment comment
then space >> spitCommentNow l comment
else spitCommentPending OnTheSameLine l comment
else do
@ -113,10 +116,11 @@ spitFollowingComment (L ref a) mlastSpn = do
spitCommentPending OnNextLine l comment
-- | Output a single remaining comment from the comment stream.
spitRemainingComment
:: Maybe RealSrcSpan -- ^ Location of last comment in the series
-> R Bool -- ^ Are we done?
spitRemainingComment ::
-- | Location of last comment in the series
Maybe RealSrcSpan ->
-- | Are we done?
R Bool
spitRemainingComment mlastSpn =
withPoppedComment (const True) $ \l comment -> do
when (needsNewlineBefore l mlastSpn) newline
@ -127,12 +131,12 @@ spitRemainingComment mlastSpn =
-- Helpers
-- | Output series of comments.
handleCommentSeries
:: (Maybe RealSrcSpan -> R Bool)
-- ^ Given location of previous comment, output the next comment
handleCommentSeries ::
-- | Given location of previous comment, output the next comment
-- returning 'True' if we're done
-> R Bool -- ^ Whether we printed any comments
(Maybe RealSrcSpan -> R Bool) ->
-- | Whether we printed any comments
R Bool
handleCommentSeries f = go False
where
go gotSome = do
@ -143,11 +147,13 @@ handleCommentSeries f = go False
-- | Try to pop a comment using given predicate and if there is a comment
-- matching the predicate, print it out.
withPoppedComment
:: (RealLocated Comment -> Bool) -- ^ Comment predicate
-> (RealSrcSpan -> Comment -> R ()) -- ^ Printing function
-> R Bool -- ^ Are we done?
withPoppedComment ::
-- | Comment predicate
(RealLocated Comment -> Bool) ->
-- | Printing function
(RealSrcSpan -> Comment -> R ()) ->
-- | Are we done?
R Bool
withPoppedComment p f = do
r <- popComment p
case r of
@ -156,11 +162,12 @@ withPoppedComment p f = do
-- | Determine if we need to insert a newline between current comment and
-- last printed comment.
needsNewlineBefore
:: RealSrcSpan -- ^ Current comment span
-> Maybe RealSrcSpan -- ^ Last printed comment span
-> Bool
needsNewlineBefore ::
-- | Current comment span
RealSrcSpan ->
-- | Last printed comment span
Maybe RealSrcSpan ->
Bool
needsNewlineBefore l mlastSpn =
case mlastSpn of
Nothing -> False
@ -168,32 +175,38 @@ needsNewlineBefore l mlastSpn =
srcSpanStartLine l > srcSpanEndLine lastSpn + 1
-- | Is the preceding comment and AST element are on the same line?
theSameLinePre
:: RealSrcSpan -- ^ Current comment span
-> RealSrcSpan -- ^ AST element location
-> Bool
theSameLinePre ::
-- | Current comment span
RealSrcSpan ->
-- | AST element location
RealSrcSpan ->
Bool
theSameLinePre l ref =
srcSpanEndLine l == srcSpanStartLine ref
-- | Is the following comment and AST element are on the same line?
theSameLinePost
:: RealSrcSpan -- ^ Current comment span
-> RealSrcSpan -- ^ AST element location
-> Bool
theSameLinePost ::
-- | Current comment span
RealSrcSpan ->
-- | AST element location
RealSrcSpan ->
Bool
theSameLinePost l ref =
srcSpanStartLine l == srcSpanEndLine ref
-- | Determine if given comment follows AST element.
commentFollowsElt
:: RealSrcSpan -- ^ Location of AST element
-> Maybe RealSrcSpan -- ^ Location of next AST element
-> Maybe RealSrcSpan -- ^ Location of enclosing AST element
-> Maybe RealSrcSpan -- ^ Location of last comment in the series
-> RealLocated Comment -- ^ Comment to test
-> Bool
commentFollowsElt ::
-- | Location of AST element
RealSrcSpan ->
-- | Location of next AST element
Maybe RealSrcSpan ->
-- | Location of enclosing AST element
Maybe RealSrcSpan ->
-- | Location of last comment in the series
Maybe RealSrcSpan ->
-- | Comment to test
RealLocated Comment ->
Bool
commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
-- A comment follows a AST element if all 4 conditions are satisfied:
goesAfter
@ -205,8 +218,8 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
goesAfter =
realSrcSpanStart l >= realSrcSpanEnd ref
-- 2) The comment logically belongs to the element, four cases:
logicallyFollows
= theSameLinePost l ref -- a) it's on the same line
logicallyFollows =
theSameLinePost l ref -- a) it's on the same line
|| isPrevHaddock comment -- b) it's a Haddock string starting with -- ^
|| continuation -- c) it's a continuation of a comment block
|| lastInEnclosing -- d) it's the last element in the enclosing construct
@ -233,13 +246,13 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
let startColumn = srcLocCol . realSrcSpanStart
in if startColumn espn > startColumn ref
then True
else abs (startColumn espn - startColumn l)
else
abs (startColumn espn - startColumn l)
>= abs (startColumn ref - startColumn l)
continuation =
case mlastSpn of
Nothing -> False
Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l
lastInEnclosing =
case meSpn of
-- When there is no enclosing element, return false
@ -255,7 +268,6 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
in insideParent && nextOutsideParent
-- | Output a 'Comment' immediately. This is a low-level printing function.
spitCommentNow :: RealSrcSpan -> Comment -> R ()
spitCommentNow spn comment = do
sitcc
@ -269,7 +281,6 @@ spitCommentNow spn comment = do
-- | Output a 'Comment' at the end of correct line or after it depending on
-- 'CommentPosition'. Used for comments that may potentially follow on the
-- same line as something we just rendered, but not immediately after it.
spitCommentPending :: CommentPosition -> RealSrcSpan -> Comment -> R ()
spitCommentPending position spn comment = do
let wrapper = case position of

View File

@ -7,40 +7,43 @@
-- functions are the low-level building blocks and should not be used on
-- their own. The 'R' monad is re-exported from "Ormolu.Printer.Combinators"
-- as well.
module Ormolu.Printer.Internal
( -- * The 'R' monad
R
, runR
R,
runR,
-- * Internal functions
, txt
, atom
, space
, newline
, isLineDirty
, inci
, sitcc
, Layout (..)
, enterLayout
, vlayout
, getLayout
txt,
atom,
space,
newline,
isLineDirty,
inci,
sitcc,
Layout (..),
enterLayout,
vlayout,
getLayout,
-- * Helpers for braces
, useBraces
, dontUseBraces
, canUseBraces
useBraces,
dontUseBraces,
canUseBraces,
-- * Special helpers for comment placement
, CommentPosition (..)
, registerPendingCommentLine
, trimSpanStream
, nextEltSpan
, popComment
, getEnclosingSpan
, withEnclosingSpan
, HaddockStyle (..)
, setLastCommentSpan
, getLastCommentSpan
CommentPosition (..),
registerPendingCommentLine,
trimSpanStream,
nextEltSpan,
popComment,
getEnclosingSpan,
withEnclosingSpan,
HaddockStyle (..),
setLastCommentSpan,
getLastCommentSpan,
-- * Annotations
, getAnns
getAnns,
)
where
@ -50,6 +53,8 @@ import Data.Bool (bool)
import Data.Coerce
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder
import GHC
import Ormolu.Parser.Anns
@ -58,109 +63,116 @@ import Ormolu.Printer.SpanStream
import Ormolu.Utils (showOutputable)
import Outputable (Outputable)
import SrcLoc
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
----------------------------------------------------------------------------
-- The 'R' monad
-- | The 'R' monad hosts combinators that allow us to describe how to render
-- AST.
newtype R a = R (ReaderT RC (State SC) a)
deriving (Functor, Applicative, Monad)
-- | Reader context of 'R'. This should be used when we control rendering by
-- enclosing certain expressions with wrappers.
data RC = RC
{ rcIndent :: !Int
-- ^ Indentation level, as the column index we need to start from after
data RC
= RC
{ -- | Indentation level, as the column index we need to start from after
-- a newline if we break lines
, rcLayout :: Layout
-- ^ Current layout
, rcEnclosingSpans :: [RealSrcSpan]
-- ^ Spans of enclosing elements of AST
, rcAnns :: Anns
-- ^ Collection of annotations
, rcCanUseBraces :: Bool
-- ^ If the last expression in the layout can use braces
rcIndent :: !Int,
-- | Current layout
rcLayout :: Layout,
-- | Spans of enclosing elements of AST
rcEnclosingSpans :: [RealSrcSpan],
-- | Collection of annotations
rcAnns :: Anns,
-- | If the last expression in the layout can use braces
rcCanUseBraces :: Bool
}
-- | State context of 'R'.
data SC = SC
{ scColumn :: !Int
-- ^ Index of the next column to render
, scBuilder :: Builder
-- ^ Rendered source code so far
, scSpanStream :: SpanStream
-- ^ Span stream
, scCommentStream :: CommentStream
-- ^ Comment stream
, scPendingComments :: ![(CommentPosition, Int, Text)]
-- ^ Pending comment lines (in reverse order) to be inserted before next
data SC
= SC
{ -- | Index of the next column to render
scColumn :: !Int,
-- | Rendered source code so far
scBuilder :: Builder,
-- | Span stream
scSpanStream :: SpanStream,
-- | Comment stream
scCommentStream :: CommentStream,
-- | Pending comment lines (in reverse order) to be inserted before next
-- newline, 'Int' is the indentation level
, scDirtyLine :: !Bool
-- ^ Whether the current line is “dirty”, that is, already contains
scPendingComments :: ![(CommentPosition, Int, Text)],
-- | Whether the current line is “dirty”, that is, already contains
-- atoms that can have comments attached to them
, scRequestedDelimiter :: !RequestedDelimiter
-- ^ Whether to output a space before the next output
, scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
-- ^ Span of last output comment
scDirtyLine :: !Bool,
-- | Whether to output a space before the next output
scRequestedDelimiter :: !RequestedDelimiter,
-- | Span of last output comment
scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
}
-- | Make sure next output is delimited by one of the following.
data RequestedDelimiter
= RequestedSpace -- ^ A space
| RequestedNewline -- ^ A newline
| RequestedNothing -- ^ Nothing
| AfterNewline -- ^ We just output a newline
| VeryBeginning -- ^ We haven't printed anything yet
= -- | A space
RequestedSpace
| -- | A newline
RequestedNewline
| -- | Nothing
RequestedNothing
| -- | We just output a newline
AfterNewline
| -- | We haven't printed anything yet
VeryBeginning
deriving (Eq, Show)
-- | 'Layout' options.
data Layout
= SingleLine -- ^ Put everything on single line
| MultiLine -- ^ Use multiple lines
= -- | Put everything on single line
SingleLine
| -- | Use multiple lines
MultiLine
deriving (Eq, Show)
-- | Modes for rendering of pending comments.
data CommentPosition
= OnTheSameLine -- ^ Put the comment on the same line
| OnNextLine -- ^ Put the comment on next line
= -- | Put the comment on the same line
OnTheSameLine
| -- | Put the comment on next line
OnNextLine
deriving (Eq, Show)
-- | Run an 'R' monad.
runR
:: R () -- ^ Monad to run
-> SpanStream -- ^ Span stream
-> CommentStream -- ^ Comment stream
-> Anns -- ^ Annotations
-> Text -- ^ Resulting rendition
runR ::
-- | Monad to run
R () ->
-- | Span stream
SpanStream ->
-- | Comment stream
CommentStream ->
-- | Annotations
Anns ->
-- | Resulting rendition
Text
runR (R m) sstream cstream anns =
TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
where
rc = RC
{ rcIndent = 0
, rcLayout = MultiLine
, rcEnclosingSpans = []
, rcAnns = anns
, rcCanUseBraces = False
{ rcIndent = 0,
rcLayout = MultiLine,
rcEnclosingSpans = [],
rcAnns = anns,
rcCanUseBraces = False
}
sc = SC
{ scColumn = 0
, scBuilder = mempty
, scSpanStream = sstream
, scCommentStream = cstream
, scPendingComments = []
, scDirtyLine = False
, scRequestedDelimiter = VeryBeginning
, scLastCommentSpan = Nothing
{ scColumn = 0,
scBuilder = mempty,
scSpanStream = sstream,
scCommentStream = cstream,
scPendingComments = [],
scDirtyLine = False,
scRequestedDelimiter = VeryBeginning,
scLastCommentSpan = Nothing
}
----------------------------------------------------------------------------
@ -173,35 +185,38 @@ runR (R m) sstream cstream anns =
-- To separate various bits of syntax with white space use 'space' instead
-- of @'txt' " "@. To output 'Outputable' Haskell entities like numbers use
-- 'atom'.
txt
:: Text -- ^ 'Text' to output
-> R ()
txt ::
-- | 'Text' to output
Text ->
R ()
txt = spit False False
-- | Output 'Outputable' fragment of AST. This can be used to output numeric
-- literals and similar. Everything that doesn't have inner structure but
-- does have an 'Outputable' instance.
atom
:: Outputable a
=> a
-> R ()
atom ::
Outputable a =>
a ->
R ()
atom = spit True False . T.pack . showOutputable
-- | Low-level non-public helper to define 'txt' and 'atom'.
spit
:: Bool -- ^ Should we mark the line as dirty?
-> Bool -- ^ Used during outputting of pending comments?
-> Text -- ^ 'Text' to output
-> R ()
spit ::
-- | Should we mark the line as dirty?
Bool ->
-- | Used during outputting of pending comments?
Bool ->
-- | 'Text' to output
Text ->
R ()
spit dirty printingComments txt' = do
requestedDel <- R (gets scRequestedDelimiter)
case requestedDel of
RequestedNewline -> do
R . modify $ \sc -> sc
{ scRequestedDelimiter = RequestedNothing }
R . modify $ \sc ->
sc
{ scRequestedDelimiter = RequestedNothing
}
if printingComments
then newlineRaw
else newline
@ -214,12 +229,13 @@ spit dirty printingComments txt' = do
then T.replicate (i - c) " "
else bool mempty " " (requestedDel == RequestedSpace)
indentedTxt = spaces <> txt'
modify $ \sc -> sc
{ scBuilder = scBuilder sc <> fromText indentedTxt
, scColumn = scColumn sc + T.length indentedTxt
, scDirtyLine = scDirtyLine sc || dirty
, scRequestedDelimiter = RequestedNothing
, scLastCommentSpan =
modify $ \sc ->
sc
{ scBuilder = scBuilder sc <> fromText indentedTxt,
scColumn = scColumn sc + T.length indentedTxt,
scDirtyLine = scDirtyLine sc || dirty,
scRequestedDelimiter = RequestedNothing,
scLastCommentSpan =
-- NOTE If there are pending comments, do not reset last comment
-- location.
if printingComments || (not . null . scPendingComments) sc
@ -235,11 +251,10 @@ spit dirty printingComments txt' = do
-- In practice this design prevents trailing white space and makes it hard
-- to output more than one delimiting space in a row, which is what we
-- usually want.
space :: R ()
space = R . modify $ \sc -> sc
{ scRequestedDelimiter =
case scRequestedDelimiter sc of
space = R . modify $ \sc ->
sc
{ scRequestedDelimiter = case scRequestedDelimiter sc of
RequestedNothing -> RequestedSpace
other -> other
}
@ -253,7 +268,6 @@ space = R . modify $ \sc -> sc
--
-- Similarly to 'space', this design prevents trailing newlines and makes it
-- hard to output more than one blank newline in a row.
newline :: R ()
newline = do
cs <- reverse <$> R (gets scPendingComments)
@ -264,7 +278,8 @@ newline = do
OnTheSameLine -> space
OnNextLine -> newlineRaw
R . forM_ cs $ \(_, indent, txt') ->
let modRC rc = rc
let modRC rc =
rc
{ rcIndent = indent
}
R m = do
@ -272,28 +287,26 @@ newline = do
spit False True txt'
newlineRaw
in local modRC m
R . modify $ \sc -> sc
R . modify $ \sc ->
sc
{ scPendingComments = []
}
-- | Low-level newline primitive. This one always just inserts a newline, no
-- hooks can be attached.
newlineRaw :: R ()
newlineRaw = R . modify $ \sc ->
let requestedDel = scRequestedDelimiter sc
builderSoFar = scBuilder sc
in sc
{ scBuilder =
case requestedDel of
{ scBuilder = case requestedDel of
AfterNewline -> builderSoFar
RequestedNewline -> builderSoFar
VeryBeginning -> builderSoFar
_ -> builderSoFar <> "\n"
, scColumn = 0
, scDirtyLine = False
, scRequestedDelimiter =
case scRequestedDelimiter sc of
_ -> builderSoFar <> "\n",
scColumn = 0,
scDirtyLine = False,
scRequestedDelimiter = case scRequestedDelimiter sc of
AfterNewline -> RequestedNewline
RequestedNewline -> RequestedNewline
VeryBeginning -> VeryBeginning
@ -302,7 +315,6 @@ newlineRaw = R . modify $ \sc ->
-- | Check if the current line is “dirty”, that is, there is something on it
-- that can have comments attached to it.
isLineDirty :: R Bool
isLineDirty = R (gets scDirtyLine)
@ -311,11 +323,11 @@ isLineDirty = R (gets scDirtyLine)
-- indented relative to the parts outside of 'inci' in order for the output
-- to be valid Haskell. When layout is single-line there is no obvious
-- effect, but with multi-line layout correct indentation levels matter.
inci :: R () -> R ()
inci (R m) = R (local modRC m)
where
modRC rc = rc
modRC rc =
rc
{ rcIndent = rcIndent rc + indentStep
}
@ -323,39 +335,40 @@ inci (R m) = R (local modRC m)
-- column. This makes sure that the entire inner block is uniformly
-- \"shifted\" to the right. Only works (and makes sense) when enclosing
-- layout is multi-line.
sitcc :: R () -> R ()
sitcc (R m) = do
requestedDel <- R (gets scRequestedDelimiter)
i <- R (asks rcIndent)
c <- R (gets scColumn)
let modRC rc = rc
let modRC rc =
rc
{ rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
}
vlayout (R m) . R $ do
modify $ \sc -> sc
{ scRequestedDelimiter =
case requestedDel of
modify $ \sc ->
sc
{ scRequestedDelimiter = case requestedDel of
RequestedSpace -> RequestedNothing
other -> other
}
local modRC m
-- | Set 'Layout' for internal computation.
enterLayout :: Layout -> R () -> R ()
enterLayout l (R m) = R (local modRC m)
where
modRC rc = rc
modRC rc =
rc
{ rcLayout = l
}
-- | Do one or another thing depending on current 'Layout'.
vlayout
:: R a -- ^ Single line
-> R a -- ^ Multi line
-> R a
vlayout ::
-- | Single line
R a ->
-- | Multi line
R a ->
R a
vlayout sline mline = do
l <- getLayout
case l of
@ -363,7 +376,6 @@ vlayout sline mline = do
MultiLine -> mline
-- | Get current 'Layout'.
getLayout :: R Layout
getLayout = R (asks rcLayout)
@ -374,91 +386,99 @@ getLayout = R (asks rcLayout)
-- before next newline. When the comment goes after something else on the
-- same line, a space will be inserted between preceding text and the
-- comment when necessary.
registerPendingCommentLine
:: CommentPosition -- ^ Comment position
-> Text -- ^ 'Text' to output
-> R ()
registerPendingCommentLine ::
-- | Comment position
CommentPosition ->
-- | 'Text' to output
Text ->
R ()
registerPendingCommentLine position txt' = R $ do
i <- asks rcIndent
modify $ \sc -> sc
modify $ \sc ->
sc
{ scPendingComments = (position, i, txt') : scPendingComments sc
}
-- | Drop elements that begin before or at the same place as given
-- 'SrcSpan'.
trimSpanStream
:: RealSrcSpan -- ^ Reference span
-> R ()
trimSpanStream ::
-- | Reference span
RealSrcSpan ->
R ()
trimSpanStream ref = do
let leRef :: RealSrcSpan -> Bool
leRef x = realSrcSpanStart x <= realSrcSpanStart ref
R . modify $ \sc -> sc
R . modify $ \sc ->
sc
{ scSpanStream = coerce (dropWhile leRef) (scSpanStream sc)
}
-- | Get location of next element in AST.
nextEltSpan :: R (Maybe RealSrcSpan)
nextEltSpan = listToMaybe . coerce <$> R (gets scSpanStream)
-- | Pop a 'Comment' from the 'CommentStream' if given predicate is
-- satisfied and there are comments in the stream.
popComment
:: (RealLocated Comment -> Bool)
-> R (Maybe (RealLocated Comment))
popComment ::
(RealLocated Comment -> Bool) ->
R (Maybe (RealLocated Comment))
popComment f = R $ do
CommentStream cstream <- gets scCommentStream
case cstream of
[] -> return Nothing
(x : xs) ->
if f x
then Just x <$ modify (\sc -> sc
then
Just x
<$ modify
( \sc ->
sc
{ scCommentStream = CommentStream xs
})
}
)
else return Nothing
-- | Get the first enclosing 'RealSrcSpan' that satisfies given predicate.
getEnclosingSpan
:: (RealSrcSpan -> Bool) -- ^ Predicate to use
-> R (Maybe RealSrcSpan)
getEnclosingSpan ::
-- | Predicate to use
(RealSrcSpan -> Bool) ->
R (Maybe RealSrcSpan)
getEnclosingSpan f =
listToMaybe . filter f <$> R (asks rcEnclosingSpans)
-- | Set 'RealSrcSpan' of enclosing span for the given computation.
withEnclosingSpan :: RealSrcSpan -> R () -> R ()
withEnclosingSpan spn (R m) = R (local modRC m)
where
modRC rc = rc
modRC rc =
rc
{ rcEnclosingSpans = spn : rcEnclosingSpans rc
}
-- | Haddock string style.
data HaddockStyle
= Pipe -- ^ @-- |@
| Caret -- ^ @-- ^@
| Asterisk Int -- ^ @-- *@
| Named String -- ^ @-- $@
= -- | @-- |@
Pipe
| -- | @-- ^@
Caret
| -- | @-- *@
Asterisk Int
| -- | @-- $@
Named String
-- | Set span of last output comment.
setLastCommentSpan
:: Maybe HaddockStyle
-- ^ 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
-> RealSrcSpan
-- ^ Location of last printed comment
-> R ()
setLastCommentSpan mhStyle spn = R . modify $ \sc -> sc
setLastCommentSpan ::
-- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
Maybe HaddockStyle ->
-- | Location of last printed comment
RealSrcSpan ->
R ()
setLastCommentSpan mhStyle spn = R . modify $ \sc ->
sc
{ scLastCommentSpan = Just (mhStyle, spn)
}
-- | Get span of last output comment.
getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
getLastCommentSpan = R (gets scLastCommentSpan)
@ -466,27 +486,23 @@ getLastCommentSpan = R (gets scLastCommentSpan)
-- Annotations
-- | For a given span return 'AnnKeywordId's associated with it.
getAnns
:: SrcSpan
-> R [AnnKeywordId]
getAnns ::
SrcSpan ->
R [AnnKeywordId]
getAnns spn = lookupAnns spn <$> R (asks rcAnns)
----------------------------------------------------------------------------
-- Helpers for braces
-- | Make the inner computation use braces around single-line layouts.
useBraces :: R () -> R ()
useBraces (R r) = R (local (\i -> i {rcCanUseBraces = True}) r)
-- | Make the inner computation omit braces around single-line layouts.
dontUseBraces :: R () -> R ()
dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
-- | Return 'True' if we can use braces in this context.
canUseBraces :: R Bool
canUseBraces = R $ asks rcCanUseBraces
@ -494,6 +510,5 @@ canUseBraces = R $ asks rcCanUseBraces
-- Constants
-- | Indentation step.
indentStep :: Int
indentStep = 2

View File

@ -2,36 +2,36 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Rendering of commonly useful bits.
module Ormolu.Printer.Meat.Common
( FamilyStyle (..)
, p_hsmodName
, p_ieWrappedName
, p_rdrName
, doesNotNeedExtraParens
, p_qualName
, p_infixDefHelper
, p_hsDocString
, p_hsDocName
( FamilyStyle (..),
p_hsmodName,
p_ieWrappedName,
p_rdrName,
doesNotNeedExtraParens,
p_qualName,
p_infixDefHelper,
p_hsDocString,
p_hsDocName,
)
where
import Control.Monad
import Data.List (isPrefixOf)
import Data.Maybe (isJust)
import qualified Data.Text as T
import GHC hiding (GhcPs, IE)
import Name (nameStableString)
import OccName (OccName (..))
import Ormolu.Printer.Combinators
import Ormolu.Utils
import RdrName (RdrName (..))
import qualified Data.Text as T
-- | Data and type family style.
data FamilyStyle
= Associated -- ^ Declarations in type classes
| Free -- ^ Top-level declarations
= -- | Declarations in type classes
Associated
| -- | Top-level declarations
Free
p_hsmodName :: ModuleName -> R ()
p_hsmodName mname = do
@ -52,7 +52,6 @@ p_ieWrappedName = \case
p_rdrName x
-- | Render a @'Located' 'RdrName'@.
p_rdrName :: Located RdrName -> R ()
p_rdrName l@(L spn _) = located l $ \x -> do
ids <- getAnns spn
@ -96,16 +95,15 @@ p_rdrName l@(L spn _) = located l $ \x -> do
-- to detect e.g. tuples for which annotations will indicate parentheses,
-- but the parentheses are already part of the symbol, so no extra layer of
-- parentheses should be added. It also detects the [] literal.
doesNotNeedExtraParens :: RdrName -> Bool
doesNotNeedExtraParens = \case
Exact name ->
let s = nameStableString name
-- NOTE I'm not sure this "stable string" is stable enough, but it looks
in -- NOTE I'm not sure this "stable string" is stable enough, but it looks
-- like this is the most robust way to tell if we're looking at exactly
-- this piece of built-in syntax.
in ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s) ||
("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)
|| ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
_ -> False
p_qualName :: ModuleName -> OccName -> R ()
@ -115,13 +113,16 @@ p_qualName mname occName = do
atom occName
-- | A helper for formatting infix constructions in lhs of definitions.
p_infixDefHelper
:: Bool -- ^ Whether to format in infix style
-> (R () -> R ()) -- ^ Indentation-bumping wrapper
-> R () -- ^ How to print the operator\/name
-> [R ()] -- ^ How to print the arguments
-> R ()
p_infixDefHelper ::
-- | Whether to format in infix style
Bool ->
-- | Indentation-bumping wrapper
(R () -> R ()) ->
-- | How to print the operator\/name
R () ->
-- | How to print the arguments
[R ()] ->
R ()
p_infixDefHelper isInfix inci' name args =
case (isInfix, args) of
(True, p0 : p1 : ps) -> do
@ -146,12 +147,14 @@ p_infixDefHelper isInfix inci' name args =
inci' $ sitcc (sep breakpoint sitcc args)
-- | Print a Haddock.
p_hsDocString
:: HaddockStyle -- ^ Haddock style
-> Bool -- ^ Finish the doc string with a newline
-> LHsDocString -- ^ The doc string to render
-> R ()
p_hsDocString ::
-- | Haddock style
HaddockStyle ->
-- | Finish the doc string with a newline
Bool ->
-- | The doc string to render
LHsDocString ->
R ()
p_hsDocString hstyle needsNewline (L l str) = do
goesAfterComment <- isJust <$> getLastCommentSpan
-- Make sure the Haddock is separated by a newline from other comments.
@ -175,6 +178,5 @@ p_hsDocString hstyle needsNewline (L l str) = do
RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
-- | Print anchor of named doc section.
p_hsDocName :: String -> R ()
p_hsDocName name = txt ("-- $" <> T.pack name)

View File

@ -5,15 +5,15 @@
{-# LANGUAGE ViewPatterns #-}
-- | Rendering of declarations.
module Ormolu.Printer.Meat.Declaration
( p_hsDecls
, hasSeparatedDecls
( p_hsDecls,
hasSeparatedDecls,
)
where
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.List.NonEmpty ((<|), NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import GHC
import OccName (occNameFS)
import Ormolu.Printer.Combinators
@ -35,7 +35,6 @@ import Ormolu.Printer.Meat.Declaration.Warning
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
import RdrName (rdrNameOcc)
import qualified Data.List.NonEmpty as NE
p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls style decls = sepSemi id $
@ -54,7 +53,6 @@ p_hsDecls style decls = sepSemi id $
--
-- Add a declaration to a group iff it is relevant to either the first or
-- the last declaration of the group.
groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
groupDecls [] = []
groupDecls (l@(L _ DocNext) : xs) =
@ -136,16 +134,16 @@ p_derivDecl = \case
XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
-- | Determine if these declarations should be grouped together.
groupedDecls
:: HsDecl GhcPs
-> HsDecl GhcPs
-> Bool
groupedDecls ::
HsDecl GhcPs ->
HsDecl GhcPs ->
Bool
groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'
groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'
groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'
groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns
groupedDecls (DataDeclaration n) x | Just ns <- isPragma x =
groupedDecls (DataDeclaration n) x
| Just ns <- isPragma x =
let f = occNameFS . rdrNameOcc in f n `elem` map f ns
groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'
groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'
@ -168,15 +166,14 @@ intersects a b = go (sort a) (sort b)
-- | Checks if given list of declarations contain a pair which should
-- be separated by a blank line.
hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
hasSeparatedDecls xs = case groupDecls xs of
_ : _ : _ -> True
_ -> False
isPragma
:: HsDecl GhcPs
-> Maybe [RdrName]
isPragma ::
HsDecl GhcPs ->
Maybe [RdrName]
isPragma = \case
InlinePragma n -> Just [n]
SpecializePragma n -> Just [n]
@ -188,13 +185,15 @@ isPragma = \case
-- Declarations referring to a single name
pattern InlinePragma
, SpecializePragma
, SCCPragma
, AnnTypePragma
, AnnValuePragma
, Pattern
, DataDeclaration :: RdrName -> HsDecl GhcPs
pattern
InlinePragma,
SpecializePragma,
SCCPragma,
AnnTypePragma,
AnnValuePragma,
Pattern,
DataDeclaration ::
RdrName -> HsDecl GhcPs
pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
@ -205,10 +204,12 @@ pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
-- Declarations which can refer to multiple names
pattern TypeSignature
, FunctionBody
, PatternSignature
, WarningPragma :: [RdrName] -> HsDecl GhcPs
pattern
TypeSignature,
FunctionBody,
PatternSignature,
WarningPragma ::
[RdrName] -> HsDecl GhcPs
pattern TypeSignature n <- (sigRdrNames -> Just n)
pattern FunctionBody n <- (funRdrNames -> Just n)
pattern PatternSignature n <- (patSigRdrNames -> Just n)

View File

@ -1,6 +1,6 @@
module Ormolu.Printer.Meat.Declaration
( p_hsDecls
, hasSeparatedDecls
( p_hsDecls,
hasSeparatedDecls,
)
where
@ -9,4 +9,5 @@ import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool

View File

@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Meat.Declaration.Annotation
( p_annDecl
( p_annDecl,
)
where

View File

@ -3,9 +3,8 @@
{-# LANGUAGE RecordWildCards #-}
-- | Rendering of type class declarations.
module Ormolu.Printer.Meat.Declaration.Class
( p_classDecl
( p_classDecl,
)
where
@ -18,23 +17,23 @@ import Data.Ord (comparing)
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
import RdrName (RdrName (..))
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
p_classDecl
:: LHsContext GhcPs
-> Located RdrName
-> LHsQTyVars GhcPs
-> LexicalFixity
-> [Located (FunDep (Located RdrName))]
-> [LSig GhcPs]
-> LHsBinds GhcPs
-> [LFamilyDecl GhcPs]
-> [LTyFamDefltEqn GhcPs]
-> [LDocDecl]
-> R ()
p_classDecl ::
LHsContext GhcPs ->
Located RdrName ->
LHsQTyVars GhcPs ->
LexicalFixity ->
[Located (FunDep (Located RdrName))] ->
[LSig GhcPs] ->
LHsBinds GhcPs ->
[LFamilyDecl GhcPs] ->
[LTyFamDefltEqn GhcPs] ->
[LDocDecl] ->
R ()
p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do
let HsQTvs {..} = tvars
variableSpans = getLoc <$> hsq_explicit
@ -63,7 +62,8 @@ p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do
docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
tyFamDefs =
( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
) <$> catdefs
)
<$> catdefs
allDecls =
snd <$> sortBy (comparing fst) (sigs <> vals <> tyFams <> tyFamDefs <> docs)
unless (null allDecls) $ do

View File

@ -3,9 +3,8 @@
{-# LANGUAGE RecordWildCards #-}
-- | Renedring of data type declarations.
module Ormolu.Printer.Meat.Declaration.Data
( p_dataDecl
( p_dataDecl,
)
where
@ -20,13 +19,18 @@ import Ormolu.Utils
import RdrName (RdrName (..))
import SrcLoc (Located)
p_dataDecl
:: FamilyStyle -- ^ Whether to format as data family
-> Located RdrName -- ^ Type constructor
-> [LHsType GhcPs] -- ^ Type patterns
-> LexicalFixity -- ^ Lexical fixity
-> HsDataDefn GhcPs -- ^ Data definition
-> R ()
p_dataDecl ::
-- | Whether to format as data family
FamilyStyle ->
-- | Type constructor
Located RdrName ->
-- | Type patterns
[LHsType GhcPs] ->
-- | Lexical fixity
LexicalFixity ->
-- | Data definition
HsDataDefn GhcPs ->
R ()
p_dataDecl style name tpats fixity HsDataDefn {..} = do
txt $ case dd_ND of
NewType -> "newtype"
@ -36,7 +40,8 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
Free -> " instance"
switchLayout (getLoc name : fmap getLoc tpats) $ do
breakpoint
inci $ p_infixDefHelper
inci $
p_infixDefHelper
(isInfix fixity)
inci
(p_rdrName name)
@ -56,12 +61,14 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
txt "where"
breakpoint
inci $ sepSemi (located' p_conDecl) dd_cons
else switchLayout (getLoc name : (getLoc <$> dd_cons)) $
inci $ do
else switchLayout (getLoc name : (getLoc <$> dd_cons))
$ inci
$ do
breakpoint
txt "="
space
let s = vlayout
let s =
vlayout
(space >> txt "|" >> space)
(newline >> txt "|" >> space)
sep s (sitcc . located' p_conDecl) dd_cons
@ -74,7 +81,8 @@ p_conDecl :: ConDecl GhcPs -> R ()
p_conDecl = \case
ConDeclGADT {..} -> do
mapM_ (p_hsDocString Pipe True) con_doc
let conDeclSpn = fmap getLoc con_names
let conDeclSpn =
fmap getLoc con_names
<> [getLoc con_forall]
<> conTyVarsSpans con_qvars
<> maybeToList (fmap getLoc con_mb_cxt)
@ -116,7 +124,8 @@ p_conDecl = \case
p_hsType (unLoc con_res_ty)
ConDeclH98 {..} -> do
mapM_ (p_hsDocString Pipe True) con_doc
let conDeclSpn = [getLoc con_name]
let conDeclSpn =
[getLoc con_name]
<> fmap getLoc con_ex_tvs
<> maybeToList (fmap getLoc con_mb_cxt)
<> conArgsSpans con_args
@ -156,9 +165,9 @@ conTyVarsSpans = \case
HsQTvs {..} -> getLoc <$> hsq_explicit
XLHsQTyVars NoExt -> []
p_forallBndrs
:: [LHsTyVarBndr GhcPs]
-> R ()
p_forallBndrs ::
[LHsTyVarBndr GhcPs] ->
R ()
p_forallBndrs = \case
[] -> return ()
bndrs -> do
@ -167,9 +176,9 @@ p_forallBndrs = \case
sep space (located' p_hsTyVarBndr) bndrs
txt "."
p_lhsContext
:: LHsContext GhcPs
-> R ()
p_lhsContext ::
LHsContext GhcPs ->
R ()
p_lhsContext = \case
L _ [] -> pure ()
ctx -> do
@ -184,14 +193,16 @@ isGadt = \case
ConDeclH98 {} -> False
XConDecl {} -> False
p_hsDerivingClause
:: HsDerivingClause GhcPs
-> R ()
p_hsDerivingClause ::
HsDerivingClause GhcPs ->
R ()
p_hsDerivingClause HsDerivingClause {..} = do
txt "deriving"
let derivingWhat = located deriv_clause_tys $ \case
[] -> txt "()"
xs -> parens N . sitcc $ sep
xs ->
parens N . sitcc $
sep
(comma >> breakpoint)
(sitcc . located' p_hsType . hsib_body)
xs

View File

@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Meat.Declaration.Default
( p_defaultDecl
( p_defaultDecl,
)
where

View File

@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Meat.Declaration.Foreign
( p_foreignDecl
( p_foreignDecl,
)
where
@ -29,7 +29,6 @@ p_foreignDecl = \case
-- | Printer for the last part of an import\/export, which is function name
-- and type signature.
p_foreignTypeSig :: ForeignDecl GhcPs -> R ()
p_foreignTypeSig fd = do
breakpoint
@ -51,7 +50,6 @@ p_foreignTypeSig fd = do
-- We also layout the identifier using the 'SourceText', because printing
-- with the other two fields of 'CImport' is very complicated. See the
-- 'Outputable' instance of 'ForeignImport' for details.
p_foreignImport :: ForeignImport -> R ()
p_foreignImport (CImport cCallConv safety _ _ sourceText) = do
txt "foreign import"

View File

@ -3,12 +3,11 @@
{-# LANGUAGE RecordWildCards #-}
-- | Type class, type family, and data family instance declarations.
module Ormolu.Printer.Meat.Declaration.Instance
( p_clsInstDecl
, p_tyFamInstDecl
, p_dataFamInstDecl
, p_standaloneDerivDecl
( p_clsInstDecl,
p_tyFamInstDecl,
p_dataFamInstDecl,
p_standaloneDerivDecl,
)
where
@ -21,11 +20,11 @@ import Data.Ord (comparing)
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
import Ormolu.Printer.Meat.Declaration.Data
import Ormolu.Printer.Meat.Declaration.TypeFamily
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()
p_standaloneDerivDecl DerivDecl {..} = do
@ -76,13 +75,15 @@ p_clsInstDecl = \case
vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
tyFamInsts =
( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
) <$> cid_tyfam_insts
)
<$> cid_tyfam_insts
dataFamInsts =
( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
) <$> cid_datafam_insts
)
<$> cid_datafam_insts
allDecls =
snd <$>
sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)
snd
<$> sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)
located hsib_body $ \x -> do
breakpoint
inci $ do

View File

@ -4,9 +4,8 @@
{-# LANGUAGE TypeFamilies #-}
-- | Rendering of Role annotation declarations.
module Ormolu.Printer.Meat.Declaration.RoleAnnotation
( p_roleAnnot
( p_roleAnnot,
)
where
@ -30,8 +29,7 @@ p_roleAnnot' l_name anns = do
inci $ do
p_rdrName l_name
breakpoint
let
p_role' = maybe (txt "_") p_role
let p_role' = maybe (txt "_") p_role
inci . sitcc $ sep breakpoint (sitcc . located' p_role') anns
p_role :: Role -> R ()

View File

@ -3,7 +3,7 @@
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Declaration.Rule
( p_ruleDecls
( p_ruleDecls,
)
where
@ -17,7 +17,8 @@ import Ormolu.Utils
p_ruleDecls :: RuleDecls GhcPs -> R ()
p_ruleDecls = \case
HsRules NoExt _ xs -> pragma "RULES" . sitcc $
HsRules NoExt _ xs ->
pragma "RULES" . sitcc $
sep breakpoint (sitcc . located' p_ruleDecl) xs
XRuleDecls NoExt -> notImplemented "XRuleDecls"

View File

@ -3,11 +3,10 @@
{-# LANGUAGE RecordWildCards #-}
-- | Type signature declarations.
module Ormolu.Printer.Meat.Declaration.Signature
( p_sigDecl
, p_typeAscription
, p_activation
( p_sigDecl,
p_typeAscription,
p_activation,
)
where
@ -35,11 +34,14 @@ p_sigDecl = \case
SCCFunSig NoExt _ name literal -> p_sccSig name literal
_ -> notImplemented "certain types of signature declarations"
p_typeSig
:: Bool -- ^ Should the tail of the names be indented
-> [Located RdrName] -- ^ Names (before @::@)
-> LHsSigWcType GhcPs -- ^ Type
-> R ()
p_typeSig ::
-- | Should the tail of the names be indented
Bool ->
-- | Names (before @::@)
[Located RdrName] ->
-- | Type
LHsSigWcType GhcPs ->
R ()
p_typeSig _ [] _ = return () -- should not happen though
p_typeSig indentTail (n : ns) hswc = do
p_rdrName n
@ -51,9 +53,9 @@ p_typeSig indentTail (n:ns) hswc = do
sep (comma >> breakpoint) p_rdrName ns
p_typeAscription hswc
p_typeAscription
:: LHsSigWcType GhcPs
-> R ()
p_typeAscription ::
LHsSigWcType GhcPs ->
R ()
p_typeAscription HsWC {..} = do
space
inci $ do
@ -65,10 +67,10 @@ p_typeAscription HsWC {..} = do
located t p_hsType
p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"
p_patSynSig
:: [Located RdrName]
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
-> R ()
p_patSynSig ::
[Located RdrName] ->
HsImplicitBndrs GhcPs (LHsType GhcPs) ->
R ()
p_patSynSig names hsib = do
txt "pattern"
let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}
@ -76,18 +78,21 @@ p_patSynSig names hsib = do
then breakpoint >> inci body
else space >> body
p_classOpSig
:: Bool -- ^ Whether this is a \"default\" signature
-> [Located RdrName] -- ^ Names (before @::@)
-> HsImplicitBndrs GhcPs (LHsType GhcPs) -- ^ Type
-> R ()
p_classOpSig ::
-- | Whether this is a \"default\" signature
Bool ->
-- | Names (before @::@)
[Located RdrName] ->
-- | Type
HsImplicitBndrs GhcPs (LHsType GhcPs) ->
R ()
p_classOpSig def names hsib = do
when def (txt "default" >> space)
p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}
p_fixSig
:: FixitySig GhcPs
-> R ()
p_fixSig ::
FixitySig GhcPs ->
R ()
p_fixSig = \case
FixitySig NoExt names (Fixity _ n dir) -> do
txt $ case dir of
@ -100,10 +105,12 @@ p_fixSig = \case
sitcc $ sep (comma >> breakpoint) p_rdrName names
XFixitySig NoExt -> notImplemented "XFixitySig"
p_inlineSig
:: Located RdrName -- ^ Name
-> InlinePragma -- ^ Inline pragma specification
-> R ()
p_inlineSig ::
-- | Name
Located RdrName ->
-- | Inline pragma specification
InlinePragma ->
R ()
p_inlineSig name InlinePragma {..} = pragmaBraces $ do
p_inlineSpec inl_inline
space
@ -115,11 +122,14 @@ p_inlineSig name InlinePragma {..} = pragmaBraces $ do
space
p_rdrName name
p_specSig
:: Located RdrName -- ^ Name
-> [LHsSigType GhcPs] -- ^ The types to specialize to
-> InlinePragma -- ^ For specialize inline
-> R ()
p_specSig ::
-- | Name
Located RdrName ->
-- | The types to specialize to
[LHsSigType GhcPs] ->
-- | For specialize inline
InlinePragma ->
R ()
p_specSig name ts InlinePragma {..} = pragmaBraces $ do
txt "SPECIALIZE"
space
@ -154,35 +164,44 @@ p_activation = \case
txt "]"
p_specInstSig :: LHsSigType GhcPs -> R ()
p_specInstSig hsib = pragma "SPECIALIZE instance" . inci $
p_specInstSig hsib =
pragma "SPECIALIZE instance" . inci $
located (hsib_body hsib) p_hsType
p_minimalSig
:: LBooleanFormula (Located RdrName) -- ^ Boolean formula
-> R ()
p_minimalSig ::
-- | Boolean formula
LBooleanFormula (Located RdrName) ->
R ()
p_minimalSig =
located' $ \booleanFormula ->
pragma "MINIMAL" (inci $ p_booleanFormula booleanFormula)
p_booleanFormula
:: BooleanFormula (Located RdrName) -- ^ Boolean formula
-> R ()
p_booleanFormula ::
-- | Boolean formula
BooleanFormula (Located RdrName) ->
R ()
p_booleanFormula = \case
Var name -> p_rdrName name
And xs -> sitcc $ sep
And xs ->
sitcc $
sep
(comma >> breakpoint)
(located' p_booleanFormula)
xs
Or xs -> sitcc $ sep
Or xs ->
sitcc $
sep
(breakpoint >> txt "| ")
(located' p_booleanFormula)
xs
Parens l -> located l (parens N . p_booleanFormula)
p_completeSig
:: Located [Located RdrName] -- ^ Constructors\/patterns
-> Maybe (Located RdrName) -- ^ Type
-> R ()
p_completeSig ::
-- | Constructors\/patterns
Located [Located RdrName] ->
-- | Type
Maybe (Located RdrName) ->
R ()
p_completeSig cs' mty =
located cs' $ \cs ->
pragma "COMPLETE" . inci $ do

View File

@ -1,7 +1,7 @@
{-# LANGUAGE LambdaCase #-}
module Ormolu.Printer.Meat.Declaration.Splice
( p_spliceDecl
( p_spliceDecl,
)
where

View File

@ -2,9 +2,8 @@
{-# LANGUAGE RecordWildCards #-}
-- | Rendering of type synonym declarations.
module Ormolu.Printer.Meat.Declaration.Type
( p_synDecl
( p_synDecl,
)
where
@ -15,19 +14,23 @@ import Ormolu.Printer.Meat.Type
import RdrName (RdrName (..))
import SrcLoc (Located)
p_synDecl
:: Located RdrName -- ^ Type constructor
-> LexicalFixity -- ^ Fixity
-> LHsQTyVars GhcPs -- ^ Type variables
-> LHsType GhcPs -- ^ RHS of type declaration
-> R ()
p_synDecl ::
-- | Type constructor
Located RdrName ->
-- | Fixity
LexicalFixity ->
-- | Type variables
LHsQTyVars GhcPs ->
-- | RHS of type declaration
LHsType GhcPs ->
R ()
p_synDecl name fixity tvars t = do
txt "type"
space
let HsQTvs {..} = tvars
switchLayout (getLoc name : map getLoc hsq_explicit) $ do
p_infixDefHelper
(case fixity of Infix -> True; _ -> False)
(case fixity of { Infix -> True; _ -> False })
inci
(p_rdrName name)
(map (located' p_hsTyVarBndr) hsq_explicit)

View File

@ -3,22 +3,21 @@
{-# LANGUAGE RecordWildCards #-}
-- | Rendering of data\/type families.
module Ormolu.Printer.Meat.Declaration.TypeFamily
( p_famDecl
, p_tyFamInstEqn
( p_famDecl,
p_tyFamInstEqn,
)
where
import BasicTypes (LexicalFixity (..))
import Control.Monad
import Data.Maybe (isNothing, isJust)
import Data.Maybe (isJust, isNothing)
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
import SrcLoc (Located, GenLocated (..))
import SrcLoc (GenLocated (..), Located)
p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
p_famDecl style FamilyDecl {..} = do
@ -59,10 +58,10 @@ p_famDecl style FamilyDecl {..} = do
sep newline (located' (inci . p_tyFamInstEqn)) eqs
p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
p_familyResultSigL
:: Bool
-> Located (FamilyResultSig GhcPs)
-> Maybe (R ())
p_familyResultSigL ::
Bool ->
Located (FamilyResultSig GhcPs) ->
Maybe (R ())
p_familyResultSigL injAnn l =
case l of
L _ a -> case a of
@ -91,7 +90,8 @@ p_injectivityAnn (InjectivityAnn a bs) = do
p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
p_tyFamInstEqn HsIB {..} = do
let FamEqn {..} = hsib_body
switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $ p_infixDefHelper
switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $
p_infixDefHelper
(isInfix feqn_fixity)
inci
(p_rdrName feqn_tycon)

View File

@ -3,11 +3,11 @@
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Declaration.Value
( p_valDecl
, p_pat
, p_hsExpr
, p_hsSplice
, p_stringLit
( p_valDecl,
p_pat,
p_hsExpr,
p_hsSplice,
p_stringLit,
)
where
@ -20,11 +20,14 @@ import Data.Char (isPunctuation, isSymbol)
import Data.Data hiding (Infix, Prefix)
import Data.List (intersperse, sortOn)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as Text
import GHC
import OccName (mkVarOcc)
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
import Ormolu.Printer.Meat.Declaration.Signature
import Ormolu.Printer.Meat.Type
import Ormolu.Printer.Operators
@ -32,12 +35,8 @@ import Ormolu.Utils
import RdrName (RdrName (..))
import RdrName (rdrNameOcc)
import SrcLoc (combineSrcSpans, isOneLineSpan)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
-- | Style of a group of equations.
data MatchGroupStyle
= Function (Located RdrName)
| PatternBind
@ -46,21 +45,21 @@ data MatchGroupStyle
| LambdaCase
-- | Style of equations in a group.
data GroupStyle
= EqualSign
| RightArrow
-- | Expression placement. This marks the places where expressions that
-- implement handing forms may use them.
data Placement
= Normal -- ^ Multi-line layout should cause
= -- | Multi-line layout should cause
-- insertion of a newline and indentation
-- bump
| Hanging -- ^ Expressions that have hanging form
Normal
| -- | Expressions that have hanging form
-- should use it and avoid bumping one level
-- of indentation
Hanging
deriving (Eq)
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
@ -72,25 +71,29 @@ p_valDecl = \case
PatSynBind NoExt psb -> p_patSynBind psb
XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
p_funBind
:: Located RdrName
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> R ()
p_funBind ::
Located RdrName ->
MatchGroup GhcPs (LHsExpr GhcPs) ->
R ()
p_funBind name = p_matchGroup (Function name)
p_matchGroup
:: MatchGroupStyle
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> R ()
p_matchGroup ::
MatchGroupStyle ->
MatchGroup GhcPs (LHsExpr GhcPs) ->
R ()
p_matchGroup = p_matchGroup' exprPlacement p_hsExpr
p_matchGroup'
:: Data body
=> (body -> Placement) -- ^ How to get body placement
-> (body -> R ()) -- ^ How to print body
-> MatchGroupStyle -- ^ Style of this group of equations
-> MatchGroup GhcPs (Located body) -- ^ Match group
-> R ()
p_matchGroup' ::
Data body =>
-- | How to get body placement
(body -> Placement) ->
-- | How to print body
(body -> R ()) ->
-- | Style of this group of equations
MatchGroupStyle ->
-- | Match group
MatchGroup GhcPs (Located body) ->
R ()
p_matchGroup' placer render style MG {..} = do
let ob = case style of
Case -> id
@ -119,11 +122,10 @@ p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
-- and paretheses) associated with them. It is necessary to use per-equation
-- names obtained from 'm_ctxt' of 'Match'. This function replaces function
-- name inside of 'Function' accordingly.
adjustMatchGroupStyle
:: Match GhcPs body
-> MatchGroupStyle
-> MatchGroupStyle
adjustMatchGroupStyle ::
Match GhcPs body ->
MatchGroupStyle ->
MatchGroupStyle
adjustMatchGroupStyle m = \case
Function _ -> (Function . mc_fun . m_ctxt) m
style -> style
@ -134,25 +136,37 @@ matchStrictness match =
FunRhs {mc_strictness = s} -> s
_ -> NoSrcStrict
p_match
:: MatchGroupStyle -- ^ Style of the group
-> Bool -- ^ Is this an infix match?
-> SrcStrictness -- ^ Strictness prefix (FunBind)
-> [LPat GhcPs] -- ^ Argument patterns
-> GRHSs GhcPs (LHsExpr GhcPs) -- ^ Equations
-> R ()
p_match ::
-- | Style of the group
MatchGroupStyle ->
-- | Is this an infix match?
Bool ->
-- | Strictness prefix (FunBind)
SrcStrictness ->
-- | Argument patterns
[LPat GhcPs] ->
-- | Equations
GRHSs GhcPs (LHsExpr GhcPs) ->
R ()
p_match = p_match' exprPlacement p_hsExpr
p_match'
:: Data body
=> (body -> Placement) -- ^ How to get body placement
-> (body -> R ()) -- ^ How to print body
-> MatchGroupStyle -- ^ Style of this group of equations
-> Bool -- ^ Is this an infix match?
-> SrcStrictness -- ^ Strictness prefix (FunBind)
-> [LPat GhcPs] -- ^ Argument patterns
-> GRHSs GhcPs (Located body) -- ^ Equations
-> R ()
p_match' ::
Data body =>
-- | How to get body placement
(body -> Placement) ->
-- | How to print body
(body -> R ()) ->
-- | Style of this group of equations
MatchGroupStyle ->
-- | Is this an infix match?
Bool ->
-- | Strictness prefix (FunBind)
SrcStrictness ->
-- | Argument patterns
[LPat GhcPs] ->
-- | Equations
GRHSs GhcPs (Located body) ->
R ()
p_match' placer render style isInfix strictness m_pats m_grhss = do
-- NOTE Normally, since patterns may be placed in a multi-line layout, it
-- is necessary to bump indentation for the pattern group so it's more
@ -170,9 +184,11 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
Function name -> p_rdrName name
_ -> return ()
Just ne_pats -> do
let combinedSpans = combineSrcSpans' $
let combinedSpans =
combineSrcSpans' $
getLoc <$> ne_pats
inci' = if isOneLineSpan combinedSpans
inci' =
if isOneLineSpan combinedSpans
then id
else inci
switchLayout [combinedSpans] $ do
@ -197,8 +213,7 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
sitcc stdCase
LambdaCase -> stdCase
return inci'
let
-- Calculate position of end of patterns. This is useful when we decide
let -- Calculate position of end of patterns. This is useful when we decide
-- about putting certain constructions in hanging positions.
endOfPats = case NE.nonEmpty m_pats of
Nothing -> case style of
@ -218,10 +233,13 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
PatternBind -> space >> txt "="
s | isCase s && hasGuards -> return ()
_ -> space >> txt "->"
let grhssSpan = combineSrcSpans' $
let grhssSpan =
combineSrcSpans' $
getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
patGrhssSpan = maybe grhssSpan
(combineSrcSpans grhssSpan . srcLocSpan) endOfPats
patGrhssSpan =
maybe grhssSpan
(combineSrcSpans grhssSpan . srcLocSpan)
endOfPats
placement =
case endOfPats of
Nothing -> blockPlacement placer grhssGRHSs
@ -251,13 +269,15 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
p_grhs = p_grhs' exprPlacement p_hsExpr
p_grhs'
:: Data body
=> (body -> Placement) -- ^ How to get body placement
-> (body -> R ()) -- ^ How to print body
-> GroupStyle
-> GRHS GhcPs (Located body)
-> R ()
p_grhs' ::
Data body =>
-- | How to get body placement
(body -> Placement) ->
-- | How to print body
(body -> R ()) ->
GroupStyle ->
GRHS GhcPs (Located body) ->
R ()
p_grhs' placer render style (GRHS NoExt guards body) =
case guards of
[] -> p_body
@ -335,12 +355,15 @@ p_hsCmdTop = \case
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt = p_stmt' exprPlacement p_hsExpr
p_stmt'
:: Data body
=> (body -> Placement) -- ^ Placer
-> (body -> R ()) -- ^ Render
-> Stmt GhcPs (Located body) -- ^ Statement to render
-> R ()
p_stmt' ::
Data body =>
-- | Placer
(body -> Placement) ->
-- | Render
(body -> R ()) ->
-- | Statement to render
Stmt GhcPs (Located body) ->
R ()
p_stmt' placer render = \case
LastStmt NoExt body _ _ -> located body render
BindStmt NoExt l f _ _ -> do
@ -417,7 +440,8 @@ gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds = \case
HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
let ssStart = either
let ssStart =
either
(srcSpanStart . getLoc)
(srcSpanStart . getLoc)
items =
@ -433,7 +457,8 @@ p_hsLocalBinds = \case
-- elements will also contain semicolons and they will confuse the
-- parser. so we request braces around every element except the last.
br <- layoutToBraces <$> getLayout
sitcc $ sepSemi
sitcc $
sepSemi
(\(m, i) -> (if m then br else id) $ p_item i)
(markInit $ sortOn ssStart items)
HsValBinds NoExt _ -> notImplemented "HsValBinds"
@ -451,9 +476,9 @@ p_hsLocalBinds = \case
EmptyLocalBinds NoExt -> return ()
XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
p_hsRecField
:: HsRecField' RdrName (LHsExpr GhcPs)
-> R ()
p_hsRecField ::
HsRecField' RdrName (LHsExpr GhcPs) ->
R ()
p_hsRecField = \HsRecField {..} -> do
p_rdrName hsRecFieldLbl
unless hsRecPun $ do
@ -520,7 +545,8 @@ p_hsExpr' s = \case
-- This is to allow:
-- f = foo bar do
-- baz
sit' = if placement == Normal
sit' =
if placement == Normal
then sitcc
else id
sit' $ do
@ -559,9 +585,11 @@ p_hsExpr' s = \case
Boxed -> parens
Unboxed -> parensHash
if isSection
then switchLayout [] . parens' s $
then
switchLayout [] . parens' s $
sep comma (located' p_hsTupArg) args
else switchLayout (getLoc <$> args) . parens' s . sitcc $
else
switchLayout (getLoc <$> args) . parens' s . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
ExplicitSum NoExt tag arity e ->
p_unboxedSum N tag arity (located e p_hsExpr)
@ -580,14 +608,18 @@ p_hsExpr' s = \case
txt header
breakpoint
ub <- layoutToBraces <$> getLayout
inci $ sepSemi
inci $
sepSemi
(located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
(unLoc es)
compBody = brackets N $ located es $ \xs -> do
let p_parBody = sep
let p_parBody =
sep
(breakpoint >> txt "| ")
p_seqBody
p_seqBody = sitcc . sep
p_seqBody =
sitcc
. sep
(comma >> breakpoint)
(located' (sitcc . p_stmt))
stmts = init xs
@ -615,8 +647,9 @@ p_hsExpr' s = \case
located rcon_con_name atom
breakpoint
let HsRecFields {..} = rcon_flds
updName f = f {
hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
updName f =
f
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
FieldOcc _ n -> n
XFieldOcc _ -> notImplemented "XFieldOcc"
}
@ -630,8 +663,9 @@ p_hsExpr' s = \case
RecordUpd {..} -> do
located rupd_expr p_hsExpr
breakpoint
let updName f = f {
hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
let updName f =
f
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
Ambiguous _ n -> n
Unambiguous _ n -> n
XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
@ -779,13 +813,17 @@ p_patSynBind PSB {..} = do
inci rhs
p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
p_case
:: Data body
=> (body -> Placement) -- ^ Placer
-> (body -> R ()) -- ^ Render
-> LHsExpr GhcPs -- ^ Expression
-> (MatchGroup GhcPs (Located body)) -- ^ Match group
-> R ()
p_case ::
Data body =>
-- | Placer
(body -> Placement) ->
-- | Render
(body -> R ()) ->
-- | Expression
LHsExpr GhcPs ->
-- | Match group
(MatchGroup GhcPs (Located body)) ->
R ()
p_case placer render e mgroup = do
txt "case"
space
@ -795,14 +833,19 @@ p_case placer render e mgroup = do
breakpoint
inci (p_matchGroup' placer render Case mgroup)
p_if
:: Data body
=> (body -> Placement) -- ^ Placer
-> (body -> R ()) -- ^ Render
-> LHsExpr GhcPs -- ^ If
-> Located body -- ^ Then
-> Located body -- ^ Else
-> R ()
p_if ::
Data body =>
-- | Placer
(body -> Placement) ->
-- | Render
(body -> R ()) ->
-- | If
LHsExpr GhcPs ->
-- | Then
Located body ->
-- | Else
Located body ->
R ()
p_if placer render if' then' else' = do
txt "if"
space
@ -817,12 +860,13 @@ p_if placer render if' then' else' = do
located else' $ \x ->
placeHanging (placer x) (render x)
p_let
:: Data body
=> (body -> R ()) -- ^ Render
-> Located (HsLocalBindsLR GhcPs GhcPs)
-> Located body
-> R ()
p_let ::
Data body =>
-- | Render
(body -> R ()) ->
Located (HsLocalBindsLR GhcPs GhcPs) ->
Located body ->
R ()
p_let render localBinds e = sitcc $ do
txt "let"
space
@ -946,11 +990,14 @@ p_hsSplice = \case
HsSpliced {} -> notImplemented "HsSpliced"
XSplice {} -> notImplemented "XSplice"
p_hsSpliceTH
:: Bool -- ^ Typed splice?
-> LHsExpr GhcPs -- ^ Splice expression
-> SpliceDecoration -- ^ Splice decoration
-> R ()
p_hsSpliceTH ::
-- | Typed splice?
Bool ->
-- | Splice expression
LHsExpr GhcPs ->
-- | Splice decoration
SpliceDecoration ->
R ()
p_hsSpliceTH isTyped expr = \case
HasParens -> do
txt decoSymbol
@ -983,7 +1030,8 @@ p_hsBracket = \case
-- turn makes it impossible to detect if there are parentheses around
-- it, etc. So we have to add parentheses manually assuming they are
-- necessary for all operators.
let isOperator = all
let isOperator =
all
(\i -> isPunctuation i || isSymbol i)
(showOutputable (rdrNameOcc name))
&& not (doesNotNeedExtraParens name)
@ -1035,26 +1083,23 @@ p_stringLit src =
let -- drop the initial '\', any amount of 'ghcSpace', and another '\'
r' = drop 1 . dropWhile ghcSpace . drop 1 $ map orig r
in map orig l : splitGaps r'
-- GHC's definition of whitespaces in strings
-- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653
ghcSpace :: Char -> Bool
ghcSpace c = c <= '\x7f' && is_space c
-- Add backslashes to the inner side of the strings
--
-- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"]
backslashes :: [String] -> [String]
backslashes (x : y : xs) = (x ++ "\\") : backslashes (('\\' : y) : xs)
backslashes xs = xs
-- Attaches previous and next items to each list element
zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
zipPrevNext xs =
let z = zip (zip (Nothing : map Just xs) xs)
let z =
zip (zip (Nothing : map Just xs) xs)
(map Just (tail xs) ++ repeat Nothing)
in map (\((p, x), n) -> (p, x, n)) z
orig (_, x, _) = x
----------------------------------------------------------------------------
@ -1062,7 +1107,6 @@ p_stringLit src =
-- | Return the wrapping function controlling the use of braces according to
-- the current layout.
layoutToBraces :: Layout -> R () -> R ()
layoutToBraces = \case
SingleLine -> useBraces
@ -1070,7 +1114,6 @@ layoutToBraces = \case
-- | Append each element in both lists with semigroups. If one list is shorter
-- than the other, return the rest of the longer list unchanged.
liftAppend :: Semigroup a => [a] -> [a] -> [a]
liftAppend [] [] = []
liftAppend [] (y : ys) = y : ys
@ -1085,7 +1128,6 @@ getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
-- | Place a thing that may have a hanging form. This function handles how
-- to separate it from preceding expressions and whether to bump indentation
-- depending on what sort of expression we have.
placeHanging :: Placement -> R () -> R ()
placeHanging placement m =
case placement of
@ -1098,16 +1140,14 @@ placeHanging placement m =
-- | Check if given block contains single expression which has a hanging
-- form.
blockPlacement
:: (body -> Placement)
-> [LGRHS GhcPs (Located body)]
-> Placement
blockPlacement ::
(body -> Placement) ->
[LGRHS GhcPs (Located body)] ->
Placement
blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
blockPlacement _ _ = Normal
-- | Check if given command has a hanging form.
cmdPlacement :: HsCmd GhcPs -> Placement
cmdPlacement = \case
HsCmdLam NoExt _ -> Hanging
@ -1121,14 +1161,13 @@ cmdTopPlacement = \case
XCmdTop {} -> notImplemented "XCmdTop"
-- | Check if given expression has a hanging form.
exprPlacement :: HsExpr GhcPs -> Placement
exprPlacement = \case
-- Only hang lambdas with single line parameter lists
HsLam NoExt mg -> case mg of
MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs))
-> Hanging
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
Hanging
_ -> Normal
HsLamCase NoExt _ -> Hanging
HsCase NoExt _ _ -> Hanging
@ -1165,11 +1204,13 @@ getOpName = \case
HsVar NoExt (L _ a) -> Just a
_ -> Nothing
p_exprOpTree
:: Bool -- ^ Can use special handling of dollar?
-> BracketStyle -- ^ Bracket style to use
-> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
-> R ()
p_exprOpTree ::
-- | Can use special handling of dollar?
Bool ->
-- | Bracket style to use
BracketStyle ->
OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
R ()
p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
-- NOTE If the beginning of the first argument and the second argument
@ -1194,8 +1235,9 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
gotDollar = case getOpName (unLoc op) of
Just rname -> mkVarOcc "$" == (rdrNameOcc rname)
_ -> False
switchLayout [opTreeLoc x] $
ub $ p_exprOpTree (not gotDollar) s x
switchLayout [opTreeLoc x]
$ ub
$ p_exprOpTree (not gotDollar) s x
let p_op = located op (opWrapper . p_hsExpr)
p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
@ -1204,14 +1246,12 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
p_op
breakpoint
inci p_y
else
placeHanging placement $ do
else placeHanging placement $ do
p_op
space
p_y
-- | Get annotations for the enclosing element.
getEnclosingAnns :: R [AnnKeywordId]
getEnclosingAnns = do
e <- getEnclosingSpan (const True)

View File

@ -1,9 +1,9 @@
module Ormolu.Printer.Meat.Declaration.Value
( p_valDecl
, p_pat
, p_hsExpr
, p_hsSplice
, p_stringLit
( p_valDecl,
p_pat,
p_hsExpr,
p_hsSplice,
p_stringLit,
)
where

View File

@ -2,8 +2,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Meat.Declaration.Warning
( p_warnDecls
, p_moduleWarning
( p_warnDecls,
p_moduleWarning,
)
where

View File

@ -3,10 +3,9 @@
{-# LANGUAGE RecordWildCards #-}
-- | Rendering of import and export lists.
module Ormolu.Printer.Meat.ImportExport
( p_hsmodExports
, p_hsmodImport
( p_hsmodExports,
p_hsmodImport,
)
where
@ -84,9 +83,9 @@ p_lie encLayout (i, totalItems) = \case
inci $ do
let names :: [R ()]
names = located' p_ieWrappedName <$> xs
parens N . sitcc $
sep (comma >> breakpoint) sitcc $
case w of
parens N . sitcc
$ sep (comma >> breakpoint) sitcc
$ case w of
NoIEWildcard -> names
IEWildcard n ->
let (before, after) = splitAt n names
@ -109,10 +108,9 @@ p_lie encLayout (i, totalItems) = \case
MultiLine -> comma
-- | Attach positions to 'Located' things in a list.
attachPositions
:: [Located a]
-> [Located ((Int, Int), a)]
attachPositions ::
[Located a] ->
[Located ((Int, Int), a)]
attachPositions xs =
let f i (L l x) = L l ((i, n), x)
n = length xs

View File

@ -3,9 +3,8 @@
{-# LANGUAGE RecordWildCards #-}
-- | Rendering of modules.
module Ormolu.Printer.Meat.Module
( p_hsModule
( p_hsModule,
)
where

View File

@ -1,18 +1,17 @@
-- | Pretty-printing of language pragmas.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- | Pretty-printing of language pragmas.
module Ormolu.Printer.Meat.Pragma
( p_pragmas
( p_pragmas,
)
where
import Ormolu.Printer.Combinators
import Ormolu.Parser.Pragma (Pragma (..))
import qualified Data.Set as S
import qualified Data.Text as T
import Ormolu.Parser.Pragma (Pragma (..))
import Ormolu.Printer.Combinators
data PragmaTy = Language | OptionsGHC | OptionsHaddock
deriving (Eq, Ord)

View File

@ -3,14 +3,13 @@
{-# LANGUAGE RecordWildCards #-}
-- | Rendering of types.
module Ormolu.Printer.Meat.Type
( p_hsType
, hasDocStrings
, p_hsContext
, p_hsTyVarBndr
, p_conDeclFields
, tyVarsToTypes
( p_hsType,
hasDocStrings,
p_hsContext,
p_hsTyVarBndr,
p_conDeclFields,
tyVarsToTypes,
)
where
@ -18,9 +17,9 @@ import BasicTypes
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
import Ormolu.Printer.Operators
import Ormolu.Utils
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
p_hsType :: HsType GhcPs -> R ()
p_hsType t = p_hsType' (hasDocStrings t) t
@ -157,7 +156,6 @@ p_hsType' multilineArgs = \case
-- | Return 'True' if at least one argument in 'HsType' has a doc string
-- attached to it.
hasDocStrings :: HsType GhcPs -> Bool
hasDocStrings = \case
HsDocTy _ _ _ -> True
@ -168,7 +166,8 @@ p_hsContext :: HsContext GhcPs -> R ()
p_hsContext = \case
[] -> txt "()"
[x] -> located x p_hsType
xs -> parens N . sitcc $
xs ->
parens N . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
@ -184,13 +183,15 @@ p_hsTyVarBndr = \case
XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
p_conDeclFields :: [LConDeclField GhcPs] -> R ()
p_conDeclFields xs = braces N . sitcc $
p_conDeclFields xs =
braces N . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
p_conDeclField :: ConDeclField GhcPs -> R ()
p_conDeclField ConDeclField {..} = do
mapM_ (p_hsDocString Pipe True) cd_fld_doc
sitcc $ sep (comma >> breakpoint)
sitcc $
sep (comma >> breakpoint)
(located' (p_rdrName . rdrNameFieldOcc))
cd_fld_names
space

View File

@ -3,14 +3,14 @@
-- | This module helps handle operator chains composed of different
-- operators that may have different precedence and fixities.
module Ormolu.Printer.Operators
( OpTree (..)
, opTreeLoc
, reassociateOpTree
) where
( OpTree (..),
opTreeLoc,
reassociateOpTree,
)
where
import BasicTypes (Fixity (..), SourceText (NoSourceText), defaultFixity, compareFixity)
import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity)
import Data.Function (on)
import Data.List
import Data.Maybe (fromMaybe)
@ -22,7 +22,6 @@ import SrcLoc (combineSrcSpans)
-- | Intermediate representation of operator trees. It has two type
-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type
-- of operators.
data OpTree ty op
= OpNode ty
| OpBranch
@ -31,7 +30,6 @@ data OpTree ty op
(OpTree ty op)
-- | Return combined 'SrcSpan's of all elements in this 'OpTree'.
opTreeLoc :: OpTree (Located a) b -> SrcSpan
opTreeLoc (OpNode (L l _)) = l
opTreeLoc (OpBranch l _ r) = combineSrcSpans (opTreeLoc l) (opTreeLoc r)
@ -40,11 +38,13 @@ opTreeLoc (OpBranch l _ r) = combineSrcSpans (opTreeLoc l) (opTreeLoc r)
-- relative precedence of operators. Users are expected to first construct
-- an initial 'OpTree', then re-associate it using this function before
-- printing.
reassociateOpTree
:: (op -> Maybe RdrName) -- ^ How to get name of an operator
-> OpTree (Located ty) (Located op) -- ^ Original 'OpTree'
-> OpTree (Located ty) (Located op) -- ^ Re-associated 'OpTree'
reassociateOpTree ::
-- | How to get name of an operator
(op -> Maybe RdrName) ->
-- | Original 'OpTree'
OpTree (Located ty) (Located op) ->
-- | Re-associated 'OpTree'
OpTree (Located ty) (Located op)
reassociateOpTree getOpName opTree =
reassociateOpTreeWith
(buildFixityMap getOpName normOpTree)
@ -54,20 +54,22 @@ reassociateOpTree getOpName opTree =
normOpTree = normalizeOpTree opTree
-- | Re-associate an 'OpTree' given the map with operator fixities.
reassociateOpTreeWith
:: forall ty op.
[(RdrName, Fixity)] -- ^ Fixity map for operators
-> (op -> Maybe RdrName) -- ^ How to get the name of an operator
-> OpTree ty op -- ^ Original 'OpTree'
-> OpTree ty op -- ^ Re-associated 'OpTree'
reassociateOpTreeWith ::
forall ty op.
-- | Fixity map for operators
[(RdrName, Fixity)] ->
-- | How to get the name of an operator
(op -> Maybe RdrName) ->
-- | Original 'OpTree'
OpTree ty op ->
-- | Re-associated 'OpTree'
OpTree ty op
reassociateOpTreeWith fixityMap getOpName = go
where
fixityOf :: op -> Fixity
fixityOf op = fromMaybe defaultFixity $ do
opName <- getOpName op
lookup opName fixityMap
-- Here, left branch is already associated and the root alongside with
-- the right branch is right-associated. This function picks up one item
-- from the right and inserts it correctly to the left.
@ -93,12 +95,14 @@ reassociateOpTreeWith fixityMap getOpName = go
else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
-- | Build a map of inferred 'Fixity's from an 'OpTree'.
buildFixityMap
:: forall ty op.
(op -> Maybe RdrName) -- ^ How to get the name of an operator
-> OpTree (Located ty) (Located op) -- ^ Operator tree
-> [(RdrName, Fixity)] -- ^ Fixity map
buildFixityMap ::
forall ty op.
-- | How to get the name of an operator
(op -> Maybe RdrName) ->
-- | Operator tree
OpTree (Located ty) (Located op) ->
-- | Fixity map
[(RdrName, Fixity)]
buildFixityMap getOpName opTree =
concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
. zip [0 ..]
@ -113,7 +117,6 @@ buildFixityMap getOpName opTree =
overrides =
[ (mkRdrUnqual $ mkVarOcc "$", -1)
]
-- Assign scores to operators based on their location in the source.
score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]
score (OpNode _) = []
@ -126,40 +129,36 @@ buildFixityMap getOpName opTree =
rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
opName <- getOpName (unLoc o)
let s =
if le < ob
-- if the operator is in the beginning of a line, assign
then-- if the operator is in the beginning of a line, assign
-- a score relative to its column within range [0, 1).
then fromIntegral oc / fromIntegral (maxCol + 1)
-- if the operator is in the end of the line, assign the
fromIntegral oc / fromIntegral (maxCol + 1)
else-- if the operator is in the end of the line, assign the
-- score 1.
else
if oe < rb
then 1
else 2 -- otherwise, assign a high score.
return $ (opName, s) : score r
avgScores :: [(RdrName, Double)] -> [(RdrName, Double)]
avgScores
= sortOn snd
avgScores =
sortOn snd
. map (\xs@((n, _) : _) -> (n, avg $ map snd xs))
. groupBy ((==) `on` fst)
. sort
avg :: [Double] -> Double
avg i = sum i / fromIntegral (length i)
-- The start column of the rightmost operator.
maxCol = go opTree
where
go (OpNode (L _ _)) = 0
go (OpBranch l (L o _) r) = maximum
[ go l
, maybe 0 srcSpanStartCol (unSrcSpan o)
, go r
go (OpBranch l (L o _) r) =
maximum
[ go l,
maybe 0 srcSpanStartCol (unSrcSpan o),
go r
]
unSrcSpan (RealSrcSpan r) = Just r
unSrcSpan (UnhelpfulSpan _) = Nothing
@ -168,14 +167,13 @@ buildFixityMap getOpName opTree =
-- | Convert an 'OpTree' to with all operators having the same fixity and
-- associativity (left infix).
normalizeOpTree :: OpTree ty op -> OpTree ty op
normalizeOpTree (OpNode n)
= OpNode n
normalizeOpTree (OpBranch (OpNode l) lop r)
= OpBranch (OpNode l) lop (normalizeOpTree r)
normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r)
= normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
normalizeOpTree (OpNode n) =
OpNode n
normalizeOpTree (OpBranch (OpNode l) lop r) =
OpBranch (OpNode l) lop (normalizeOpTree r)
normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
fixity :: Int -> FixityDirection -> Fixity
fixity = Fixity NoSourceText

View File

@ -2,45 +2,43 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Build span stream from AST.
module Ormolu.Printer.SpanStream
( SpanStream (..)
, mkSpanStream
( SpanStream (..),
mkSpanStream,
)
where
import Data.DList (DList)
import qualified Data.DList as D
import Data.Data (Data)
import Data.Generics (everything, ext2Q)
import Data.List (sortOn)
import Data.Typeable (cast)
import SrcLoc
import qualified Data.DList as D
-- | A stream of 'RealSrcSpan's in ascending order. This allows us to tell
-- e.g. whether there is another \"located\" element of AST between current
-- element and comment we're considering for printing.
newtype SpanStream = SpanStream [RealSrcSpan]
deriving (Eq, Show, Data, Semigroup, Monoid)
-- | Create 'SpanStream' from a data structure containing \"located\"
-- elements.
mkSpanStream
:: Data a
=> a -- ^ Data structure to inspect (AST)
-> SpanStream
mkSpanStream a
= SpanStream
mkSpanStream ::
Data a =>
-- | Data structure to inspect (AST)
a ->
SpanStream
mkSpanStream a =
SpanStream
. sortOn realSrcSpanStart
. D.toList
$ everything mappend (const mempty `ext2Q` queryLocated) a
where
queryLocated
:: (Data e0, Data e1)
=> GenLocated e0 e1
-> DList RealSrcSpan
queryLocated ::
(Data e0, Data e1) =>
GenLocated e0 e1 ->
DList RealSrcSpan
queryLocated (L mspn _) =
case cast mspn :: Maybe SrcSpan of
Nothing -> mempty

View File

@ -1,14 +1,13 @@
-- | Random utilities used by the code.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Random utilities used by the code.
module Ormolu.Utils
( combineSrcSpans'
, isModule
, notImplemented
, showOutputable
, splitDocString
( combineSrcSpans',
isModule,
notImplemented,
showOutputable,
splitDocString,
)
where
@ -16,41 +15,37 @@ import Data.Data (Data, showConstr, toConstr)
import Data.List (dropWhileEnd)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import HsDoc (HsDocString, unpackHDS)
import SrcLoc
import qualified Data.Text as T
import HsDoc (HsDocString, unpackHDS)
import qualified Outputable as GHC
import SrcLoc
-- | Combine all source spans from the given list.
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
-- | Return 'True' if given element of AST is module.
isModule :: Data a => a -> Bool
isModule x = showConstr (toConstr x) == "HsModule"
-- | Placeholder for things that are not yet implemented.
notImplemented :: String -> a
notImplemented msg = error $ "not implemented yet: " ++ msg
-- | Pretty-print an 'GHC.Outputable' thing.
showOutputable :: GHC.Outputable o => o -> String
showOutputable = GHC.showSDocUnsafe . GHC.ppr
-- | Split and normalize a doc string. The result is a list of lines that
-- make up the comment.
splitDocString :: HsDocString -> [Text]
splitDocString docStr =
case r of
[] -> [""]
_ -> r
where
r = fmap escapeLeadingDollar
r =
fmap escapeLeadingDollar
. dropPaddingSpace
. dropWhileEnd T.null
. fmap (T.stripEnd . T.pack)

View File

@ -21,5 +21,6 @@ spec = do
stdTest "{-#OPTIONS_HADDOCK foo, bar, baz #-}" (Just $ PragmaOptionsHaddock "foo, bar, baz")
stdTest :: String -> Maybe Pragma -> Spec
stdTest input result = it input $
stdTest input result =
it input $
parsePragma input `shouldBe` result

View File

@ -1,19 +1,22 @@
{-# LANGUAGE TemplateHaskell #-}
module Ormolu.PrinterSpec (spec) where
module Ormolu.PrinterSpec
( spec,
)
where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.List (isSuffixOf)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Ormolu
import Path
import Path.IO
import System.FilePath (addExtension, dropExtensions, splitExtensions)
import Test.Hspec
import qualified Data.Text as T
import qualified Data.Text.IO as T
spec :: Spec
spec = do
@ -21,7 +24,6 @@ spec = do
forM_ es checkExample
-- | Check a single given example.
checkExample :: Path Rel File -> Spec
checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do
let srcPath = examplesDir </> srcPath'
@ -42,14 +44,12 @@ checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptio
shouldMatch True formatted1 formatted0
-- | Build list of examples for testing.
locateExamples :: IO [Path Rel File]
locateExamples =
filter isInput . snd <$> listDirRecurRel examplesDir
-- | Does given path look like input path (as opposed to expected output
-- path)?
isInput :: Path Rel File -> Bool
isInput path =
let s = fromRelFile path
@ -57,21 +57,21 @@ isInput path =
in exts == ".hs" && not ("-out" `isSuffixOf` s')
-- | For given path of input file return expected name of output.
deriveOutput :: Path Rel File -> IO (Path Rel File)
deriveOutput path = parseRelFile $
deriveOutput path =
parseRelFile $
addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.
-- It also prints multi-line snippets in a more readable form.
shouldMatch :: Bool -> Text -> Text -> Expectation
shouldMatch idempotencyTest actual expected =
when (actual /= expected) . expectationFailure $ unlines
[ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):"
, T.unpack expected
, ">>>>>>>>>>>>>>>>>>>>>> but got:"
, T.unpack actual
when (actual /= expected) . expectationFailure $
unlines
[ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
T.unpack expected,
">>>>>>>>>>>>>>>>>>>>>> but got:",
T.unpack actual
]
where
pass =
@ -84,10 +84,10 @@ examplesDir = $(mkRelDir "data/examples")
-- | Inside this wrapper 'OrmoluException' will be caught and displayed
-- nicely using 'displayException'.
withNiceExceptions
:: Expectation -- ^ Action that may throw the exception
-> Expectation
withNiceExceptions ::
-- | Action that may throw the exception
Expectation ->
Expectation
withNiceExceptions m = m `catch` h
where
h :: OrmoluException -> IO ()