mirror of
https://github.com/ilyakooo0/ormolu.git
synced 2024-10-26 19:17:55 +03:00
Format Ormolu with Ormolu
This commit is contained in:
parent
c386de89bd
commit
480d6edfb3
@ -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
|
||||
|
10
default.nix
10
default.nix
@ -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;
|
||||
|
@ -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")
|
||||
|
103
src/Ormolu.hs
103
src/Ormolu.hs
@ -1,24 +1,25 @@
|
||||
-- | A formatter for Haskell source code.
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# 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,8 +83,9 @@ ormolu cfg path str = do
|
||||
let txt2 = printModule result1
|
||||
in case diffText txt txt2 pathRendered of
|
||||
Nothing -> return ()
|
||||
Just (loc, l, r) -> liftIO $
|
||||
throwIO (OrmoluNonIdempotentOutput loc l r)
|
||||
Just (loc, l, r) ->
|
||||
liftIO $
|
||||
throwIO (OrmoluNonIdempotentOutput loc l r)
|
||||
return txt
|
||||
|
||||
-- | Load a file and format it. The file stays intact and the rendered
|
||||
@ -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
|
||||
]
|
||||
|
@ -1,54 +1,53 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# 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
|
||||
-- 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)
|
||||
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)
|
||||
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
|
||||
{ unDynOption :: String
|
||||
} deriving (Eq, Ord, Show)
|
||||
newtype DynOption
|
||||
= DynOption
|
||||
{ unDynOption :: String
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
|
||||
|
||||
dynOptionToLocatedStr :: DynOption -> GHC.Located String
|
||||
dynOptionToLocatedStr (DynOption o) = GHC.L GHC.noSrcSpan o
|
||||
|
@ -1,13 +1,12 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# 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 = cstream1
|
||||
, prParsedSource = ps1
|
||||
} =
|
||||
matchIgnoringSrcSpans cstream0 cstream1 <>
|
||||
matchIgnoringSrcSpans ps0 ps1
|
||||
ParseResult
|
||||
{ prCommentStream = cstream0,
|
||||
prParsedSource = ps0
|
||||
}
|
||||
ParseResult
|
||||
{ prCommentStream = cstream1,
|
||||
prParsedSource = 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,36 +60,37 @@ 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
|
||||
(genericQuery
|
||||
`extQ` srcSpanEq
|
||||
`extQ` hsModuleEq
|
||||
`extQ` sourceTextEq
|
||||
`extQ` hsDocStringEq
|
||||
`ext2Q` forLocated)
|
||||
x y
|
||||
| typeOf x == typeOf y,
|
||||
toConstr x == toConstr y =
|
||||
mconcat $
|
||||
gzipWithQ
|
||||
( genericQuery
|
||||
`extQ` srcSpanEq
|
||||
`extQ` hsModuleEq
|
||||
`extQ` sourceTextEq
|
||||
`extQ` hsDocStringEq
|
||||
`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
|
||||
Nothing -> Different []
|
||||
Just hs1 ->
|
||||
matchIgnoringSrcSpans
|
||||
hs0 { hsmodImports = sortImports (hsmodImports hs0) }
|
||||
hs1 { hsmodImports = sortImports (hsmodImports hs1) }
|
||||
|
||||
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,16 +99,14 @@ 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)
|
||||
appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
|
||||
where
|
||||
fresh = not $ any (flip isSubspanOf s) ss
|
||||
helpful = isGoodSrcSpan s
|
||||
@ -115,32 +114,37 @@ 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,
|
||||
getSpan loc left,
|
||||
getSpan loc right
|
||||
)
|
||||
Just (row, col, loc) ->
|
||||
Just
|
||||
( GHC.mkRealSrcLoc (GHC.mkFastString fp) row col,
|
||||
getSpan loc left,
|
||||
getSpan loc right
|
||||
)
|
||||
where
|
||||
go (row, col, loc) t1 t2 =
|
||||
go (row, col, loc) t1 t2 =
|
||||
case (T.uncons t1, T.uncons t2) of
|
||||
-- both text empty, all good
|
||||
(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'
|
||||
then (row + 1, 0, loc + 1)
|
||||
else (row, col + 1, loc + 1)
|
||||
in go (row', col', loc') r1 r2
|
||||
(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
|
||||
-- something is different, return the position
|
||||
_ ->
|
||||
Just (row, col, loc)
|
||||
|
@ -1,65 +1,66 @@
|
||||
{-# 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 $
|
||||
[ "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." ]
|
||||
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."]
|
||||
OrmoluNonIdempotentOutput loc left right ->
|
||||
showParsingErr "Formatting is not idempotent:" loc
|
||||
[ "before: " ++ show left , "after: " ++ show right ]
|
||||
["before: " ++ show left, "after: " ++ show right]
|
||||
++ "Please, consider reporting the bug.\n"
|
||||
|
||||
-- | 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
|
||||
|
@ -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
|
||||
|
@ -1,97 +1,99 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# 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
|
||||
dynFlags0
|
||||
(dynOptionToLocatedStr <$> cfgDynOptions)
|
||||
(dynFlags1, _, ws) <-
|
||||
GHC.parseDynamicFilePragma
|
||||
dynFlags0
|
||||
(dynOptionToLocatedStr <$> cfgDynOptions)
|
||||
return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)
|
||||
-- NOTE It's better to throw this outside of 'ghcWrapper' because
|
||||
-- otherwise the exception will be wrapped as a GHC panic, which we don't
|
||||
-- want.
|
||||
when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
|
||||
throwIO (OrmoluCppEnabled path)
|
||||
throwIO (OrmoluCppEnabled path)
|
||||
let r = case runParser GHC.parseModule dynFlags path input of
|
||||
GHC.PFailed _ ss m ->
|
||||
Left (ss, GHC.showSDoc dynFlags m)
|
||||
GHC.POk pstate pmod ->
|
||||
let (comments, exts) = mkCommentStream extraComments pstate
|
||||
in Right ParseResult
|
||||
{ prParsedSource = pmod
|
||||
, prAnns = mkAnns pstate
|
||||
, prCommentStream = comments
|
||||
, prExtensions = exts
|
||||
}
|
||||
in Right ParseResult
|
||||
{ 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
|
||||
-- apparently interferes with QuasiQuotes in
|
||||
-- weird ways
|
||||
[ 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,28 +126,32 @@ 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
|
||||
dflags2
|
||||
[GHC.noLoc "-hide-all-packages"]
|
||||
(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
|
||||
in GHC.runGhc (Just libdir) act
|
||||
in GHC.runGhc (Just libdir) 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,44 +160,42 @@ 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
|
||||
unlines' (a, b) = (unlines a, catMaybes b)
|
||||
|
||||
findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]
|
||||
findLines path = zipWith (checkLine path) [1..]
|
||||
findLines path = zipWith (checkLine path) [1 ..]
|
||||
|
||||
checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))
|
||||
checkLine path line s
|
||||
| "{-# LINE" `isPrefixOf` s =
|
||||
let (pragma, res) = getPragma s
|
||||
size = length pragma
|
||||
ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
|
||||
in (res, Just $ L ss pragma)
|
||||
let (pragma, res) = getPragma s
|
||||
size = length pragma
|
||||
ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
|
||||
in (res, Just $ L ss pragma)
|
||||
| "#!" `isPrefixOf` s =
|
||||
let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
|
||||
in ("",Just $ L ss s)
|
||||
let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
|
||||
in ("", Just $ L ss s)
|
||||
| otherwise = (s, Nothing)
|
||||
where
|
||||
mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
|
||||
|
||||
getPragma :: String -> (String, String)
|
||||
getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
|
||||
getPragma s@(x:xs)
|
||||
getPragma s@(x : xs)
|
||||
| "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
|
||||
| otherwise =
|
||||
let (prag, remline) = getPragma xs
|
||||
in (x:prag, ' ':remline)
|
||||
let (prag, remline) = getPragma xs
|
||||
in (x : prag, ' ' : remline)
|
||||
|
||||
-- | 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
|
||||
autoExts = allExts \\ manualExts
|
||||
allExts = [minBound..maxBound]
|
||||
allExts = [minBound .. maxBound]
|
||||
|
||||
deriving instance Bounded Extension
|
||||
|
@ -1,37 +1,34 @@
|
||||
-- | 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 $
|
||||
M.fromListWith (++) (mapMaybe f (GHC.annotations pstate))
|
||||
mkAnns ::
|
||||
GHC.PState ->
|
||||
Anns
|
||||
mkAnns pstate =
|
||||
Anns $
|
||||
M.fromListWith (++) (mapMaybe f (GHC.annotations pstate))
|
||||
where
|
||||
f ((spn, kid), _) =
|
||||
case spn of
|
||||
@ -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 _) _ = []
|
||||
|
@ -1,87 +1,84 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# 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)
|
||||
(GHC.annotations_comments pstate)
|
||||
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 $
|
||||
showComment <$> xs
|
||||
showCommentStream (CommentStream xs) =
|
||||
unlines $
|
||||
showComment <$> xs
|
||||
where
|
||||
showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
|
||||
|
||||
@ -91,26 +88,25 @@ 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 $
|
||||
if "{-" `isPrefixOf` s
|
||||
then case NE.nonEmpty (lines s) of
|
||||
Nothing -> s :| []
|
||||
Just (x:|xs) ->
|
||||
let getIndent y =
|
||||
if all isSpace y
|
||||
then startIndent
|
||||
else length (takeWhile isSpace y)
|
||||
n = minimum (startIndent : fmap getIndent xs)
|
||||
in x :| (drop n <$> xs)
|
||||
else s :| []
|
||||
mkComment (L l s) =
|
||||
L l . Comment . fmap dropTrailing $
|
||||
if "{-" `isPrefixOf` s
|
||||
then case NE.nonEmpty (lines s) of
|
||||
Nothing -> s :| []
|
||||
Just (x :| xs) ->
|
||||
let getIndent y =
|
||||
if all isSpace y
|
||||
then startIndent
|
||||
else length (takeWhile isSpace y)
|
||||
n = minimum (startIndent : fmap getIndent xs)
|
||||
in x :| (drop n <$> xs)
|
||||
else s :| []
|
||||
where
|
||||
dropTrailing = dropWhileEnd isSpace
|
||||
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
|
||||
|
@ -1,38 +1,39 @@
|
||||
-- | A module for parsing of pragmas from comments.
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# 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,8 +50,7 @@ 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 :: String -> Maybe [String]
|
||||
parseExtensions str = tokenize str >>= go
|
||||
where
|
||||
go = \case
|
||||
@ -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
|
||||
@ -85,4 +83,4 @@ pLexer = go
|
||||
r <- L.lexer False return
|
||||
case unLoc r of
|
||||
L.ITeof -> return []
|
||||
x -> (x:) <$> go
|
||||
x -> (x :) <$> go
|
||||
|
@ -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
|
||||
-- XXX extend as needed
|
||||
]
|
||||
prettyPrintParseResult ParseResult {..} =
|
||||
unlines
|
||||
[ "parse result:",
|
||||
" comment stream:",
|
||||
showCommentStream prCommentStream
|
||||
-- XXX extend as needed
|
||||
]
|
||||
|
@ -1,11 +1,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Pretty-printer for Haskell AST.
|
||||
|
||||
module Ormolu.Printer
|
||||
( printModule
|
||||
( printModule,
|
||||
)
|
||||
where
|
||||
|
||||
@ -16,12 +15,13 @@ 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)
|
||||
prCommentStream
|
||||
prAnns
|
||||
(mkSpanStream prParsedSource)
|
||||
prCommentStream
|
||||
prAnns
|
||||
|
@ -1,55 +1,60 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | 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,19 +114,19 @@ 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
|
||||
(x:xs) ->
|
||||
(x : xs) ->
|
||||
if isOneLineSpan (foldr combineSrcSpans x xs)
|
||||
then SingleLine
|
||||
else MultiLine
|
||||
@ -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
|
||||
@ -174,12 +182,11 @@ sepSemi f xs = vlayout singleLine multiLine
|
||||
[] -> when ub $ txt "{}"
|
||||
xs' ->
|
||||
if ub
|
||||
then do
|
||||
txt "{ "
|
||||
sep (txt "; ") (dontUseBraces . f) xs'
|
||||
txt " }"
|
||||
else
|
||||
sep (txt "; ") f xs'
|
||||
then do
|
||||
txt "{ "
|
||||
sep (txt "; ") (dontUseBraces . f) xs'
|
||||
txt " }"
|
||||
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 ","
|
||||
|
@ -1,35 +1,34 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | 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,19 +106,21 @@ 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 space >> spitCommentNow l comment
|
||||
else spitCommentPending OnTheSameLine l comment
|
||||
then
|
||||
if isMultilineComment comment
|
||||
then space >> spitCommentNow l comment
|
||||
else spitCommentPending OnTheSameLine l comment
|
||||
else do
|
||||
when (needsNewlineBefore l mlastSpn) $
|
||||
registerPendingCommentLine OnNextLine ""
|
||||
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
|
||||
-- returning 'True' if we're done
|
||||
-> R Bool -- ^ Whether we printed any comments
|
||||
handleCommentSeries ::
|
||||
-- | Given location of previous comment, output the next comment
|
||||
-- returning 'True' if we're done
|
||||
(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,11 +218,11 @@ 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
|
||||
|| 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
|
||||
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
|
||||
|
||||
-- 3) There is no other AST element between this element and the comment:
|
||||
noEltBetween =
|
||||
@ -231,15 +244,15 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
|
||||
Nothing -> True
|
||||
Just espn ->
|
||||
let startColumn = srcLocCol . realSrcSpanStart
|
||||
in if startColumn espn > startColumn ref
|
||||
then True
|
||||
else abs (startColumn espn - startColumn l)
|
||||
>= abs (startColumn ref - startColumn l)
|
||||
in if startColumn espn > startColumn ref
|
||||
then True
|
||||
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
|
||||
|
@ -1,46 +1,49 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
-- | In most cases import "Ormolu.Printer.Combinators" instead, these
|
||||
-- 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
|
||||
-- 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
|
||||
}
|
||||
data RC
|
||||
= RC
|
||||
{ -- | Indentation level, as the column index we need to start from after
|
||||
-- a newline if we break lines
|
||||
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
|
||||
-- newline, 'Int' is the indentation level
|
||||
, scDirtyLine :: !Bool
|
||||
-- ^ 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
|
||||
}
|
||||
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
|
||||
scPendingComments :: ![(CommentPosition, Int, Text)],
|
||||
-- | Whether the current line is “dirty”, that is, already contains
|
||||
-- atoms that can have comments attached to them
|
||||
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,18 +229,19 @@ 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 =
|
||||
-- NOTE If there are pending comments, do not reset last comment
|
||||
-- location.
|
||||
if printingComments || (not . null . scPendingComments) sc
|
||||
then scLastCommentSpan sc
|
||||
else Nothing
|
||||
}
|
||||
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
|
||||
then scLastCommentSpan sc
|
||||
else Nothing
|
||||
}
|
||||
|
||||
-- | This primitive /does not/ necessarily output a space. It just ensures
|
||||
-- that the next thing that will be printed on the same line will be
|
||||
@ -235,14 +251,13 @@ 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
|
||||
}
|
||||
}
|
||||
|
||||
-- | Output a newline. First time 'newline' is used after some non-'newline'
|
||||
-- output it gets inserted immediately. Second use of 'newline' does not
|
||||
@ -253,56 +268,53 @@ 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)
|
||||
case cs of
|
||||
[] -> newlineRaw
|
||||
((position, _, _):_) -> do
|
||||
((position, _, _) : _) -> do
|
||||
case position of
|
||||
OnTheSameLine -> space
|
||||
OnNextLine -> newlineRaw
|
||||
R . forM_ cs $ \(_, indent, txt') ->
|
||||
let modRC rc = rc
|
||||
{ rcIndent = indent
|
||||
}
|
||||
let modRC rc =
|
||||
rc
|
||||
{ rcIndent = indent
|
||||
}
|
||||
R m = do
|
||||
unless (T.null txt') $
|
||||
spit False True txt'
|
||||
newlineRaw
|
||||
in local modRC m
|
||||
R . modify $ \sc -> sc
|
||||
{ scPendingComments = []
|
||||
}
|
||||
in local modRC m
|
||||
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
|
||||
AfterNewline -> builderSoFar
|
||||
RequestedNewline -> builderSoFar
|
||||
VeryBeginning -> builderSoFar
|
||||
_ -> builderSoFar <> "\n"
|
||||
, scColumn = 0
|
||||
, scDirtyLine = False
|
||||
, scRequestedDelimiter =
|
||||
case scRequestedDelimiter sc of
|
||||
AfterNewline -> RequestedNewline
|
||||
RequestedNewline -> RequestedNewline
|
||||
VeryBeginning -> VeryBeginning
|
||||
_ -> AfterNewline
|
||||
}
|
||||
in sc
|
||||
{ scBuilder = case requestedDel of
|
||||
AfterNewline -> builderSoFar
|
||||
RequestedNewline -> builderSoFar
|
||||
VeryBeginning -> builderSoFar
|
||||
_ -> builderSoFar <> "\n",
|
||||
scColumn = 0,
|
||||
scDirtyLine = False,
|
||||
scRequestedDelimiter = case scRequestedDelimiter sc of
|
||||
AfterNewline -> RequestedNewline
|
||||
RequestedNewline -> RequestedNewline
|
||||
VeryBeginning -> VeryBeginning
|
||||
_ -> AfterNewline
|
||||
}
|
||||
|
||||
-- | 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,51 +323,52 @@ 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
|
||||
{ rcIndent = rcIndent rc + indentStep
|
||||
}
|
||||
modRC rc =
|
||||
rc
|
||||
{ rcIndent = rcIndent rc + indentStep
|
||||
}
|
||||
|
||||
-- | Set indentation level for the inner computation equal to current
|
||||
-- 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
|
||||
{ rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
|
||||
}
|
||||
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
|
||||
{ rcLayout = l
|
||||
}
|
||||
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
|
||||
{ scPendingComments = (position, i, txt') : scPendingComments 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
|
||||
{ scSpanStream = coerce (dropWhile leRef) (scSpanStream 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) ->
|
||||
(x : xs) ->
|
||||
if f x
|
||||
then Just x <$ modify (\sc -> sc
|
||||
{ scCommentStream = CommentStream xs
|
||||
})
|
||||
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
|
||||
{ rcEnclosingSpans = spn : rcEnclosingSpans 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
|
||||
{ scLastCommentSpan = Just (mhStyle, spn)
|
||||
}
|
||||
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)
|
||||
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)
|
||||
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
|
||||
|
@ -1,37 +1,37 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# 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
|
||||
@ -67,9 +66,9 @@ p_rdrName l@(L spn _) = located l $ \x -> do
|
||||
singleQuoteWrapper =
|
||||
if AnnSimpleQuote `elem` ids
|
||||
then \y -> do
|
||||
txt "'"
|
||||
y
|
||||
else id
|
||||
txt "'"
|
||||
y
|
||||
else id
|
||||
m =
|
||||
case x of
|
||||
Unqual occName ->
|
||||
@ -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
|
||||
-- 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)
|
||||
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.
|
||||
("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)
|
||||
|| ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
|
||||
_ -> False
|
||||
|
||||
p_qualName :: ModuleName -> OccName -> R ()
|
||||
@ -115,16 +113,19 @@ 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
|
||||
(True, p0 : p1 : ps) -> do
|
||||
let parens' =
|
||||
if null ps
|
||||
then id
|
||||
@ -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)
|
||||
|
@ -1,19 +1,19 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# 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 $
|
||||
@ -43,7 +42,7 @@ p_hsDecls style decls = sepSemi id $
|
||||
-- groups.
|
||||
case groupDecls decls of
|
||||
[] -> []
|
||||
(x:xs) ->
|
||||
(x : xs) ->
|
||||
NE.toList (renderGroup x)
|
||||
++ concatMap (NE.toList . separateGroup . renderGroup) xs
|
||||
where
|
||||
@ -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) =
|
||||
@ -62,19 +60,19 @@ groupDecls (l@(L _ DocNext) : xs) =
|
||||
-- in the next block:
|
||||
case groupDecls xs of
|
||||
[] -> [l :| []]
|
||||
(x:xs') -> (l <| x) : xs'
|
||||
groupDecls (lhdr:xs) =
|
||||
let -- Pick the first decl as the group header
|
||||
hdr = unLoc lhdr
|
||||
-- Zip rest of the decls with their previous decl
|
||||
zipped = zip (lhdr:xs) xs
|
||||
-- Pick decls from the tail if they are relevant to the group header
|
||||
-- or the previous decl.
|
||||
(grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
|
||||
let relevantToHdr = groupedDecls hdr cur
|
||||
relevantToPrev = groupedDecls prev cur
|
||||
in relevantToHdr || relevantToPrev
|
||||
in (lhdr :| map snd grp) : groupDecls (map snd rest)
|
||||
(x : xs') -> (l <| x) : xs'
|
||||
groupDecls (lhdr : xs) =
|
||||
let -- Pick the first decl as the group header
|
||||
hdr = unLoc lhdr
|
||||
-- Zip rest of the decls with their previous decl
|
||||
zipped = zip (lhdr : xs) xs
|
||||
-- Pick decls from the tail if they are relevant to the group header
|
||||
-- or the previous decl.
|
||||
(grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
|
||||
let relevantToHdr = groupedDecls hdr cur
|
||||
relevantToPrev = groupedDecls prev cur
|
||||
in relevantToHdr || relevantToPrev
|
||||
in (lhdr :| map snd grp) : groupDecls (map snd rest)
|
||||
|
||||
p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
|
||||
p_hsDecl style = \case
|
||||
@ -94,7 +92,7 @@ p_hsDecl style = \case
|
||||
DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
|
||||
DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
|
||||
DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
|
||||
DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
|
||||
DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
|
||||
RoleAnnotD NoExt x -> p_roleAnnot x
|
||||
XHsDecl _ -> notImplemented "XHsDecl"
|
||||
|
||||
@ -136,17 +134,17 @@ 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 =
|
||||
let f = occNameFS . rdrNameOcc in f n `elem` map f ns
|
||||
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'
|
||||
groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'
|
||||
@ -161,22 +159,21 @@ intersects a b = go (sort a) (sort b)
|
||||
go :: Ord a => [a] -> [a] -> Bool
|
||||
go _ [] = False
|
||||
go [] _ = False
|
||||
go (x:xs) (y:ys)
|
||||
| x < y = go xs (y:ys)
|
||||
| x > y = go (x:xs) ys
|
||||
go (x : xs) (y : ys)
|
||||
| x < y = go xs (y : ys)
|
||||
| x > y = go (x : xs) ys
|
||||
| otherwise = True
|
||||
|
||||
-- | 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
|
||||
_ : _ : _ -> 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)
|
||||
|
@ -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
|
||||
|
@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Ormolu.Printer.Meat.Declaration.Annotation
|
||||
( p_annDecl
|
||||
( p_annDecl,
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1,11 +1,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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
|
||||
|
@ -1,11 +1,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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,11 +40,12 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
|
||||
Free -> " instance"
|
||||
switchLayout (getLoc name : fmap getLoc tpats) $ do
|
||||
breakpoint
|
||||
inci $ p_infixDefHelper
|
||||
(isInfix fixity)
|
||||
inci
|
||||
(p_rdrName name)
|
||||
(located' p_hsType <$> tpats)
|
||||
inci $
|
||||
p_infixDefHelper
|
||||
(isInfix fixity)
|
||||
inci
|
||||
(p_rdrName name)
|
||||
(located' p_hsType <$> tpats)
|
||||
case dd_kindSig of
|
||||
Nothing -> return ()
|
||||
Just k -> do
|
||||
@ -56,14 +61,16 @@ 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
|
||||
(space >> txt "|" >> space)
|
||||
(newline >> txt "|" >> space)
|
||||
let s =
|
||||
vlayout
|
||||
(space >> txt "|" >> space)
|
||||
(newline >> txt "|" >> space)
|
||||
sep s (sitcc . located' p_conDecl) dd_cons
|
||||
unless (null $ unLoc dd_derivs) breakpoint
|
||||
inci . located dd_derivs $ \xs -> do
|
||||
@ -74,15 +81,16 @@ p_conDecl :: ConDecl GhcPs -> R ()
|
||||
p_conDecl = \case
|
||||
ConDeclGADT {..} -> do
|
||||
mapM_ (p_hsDocString Pipe True) con_doc
|
||||
let conDeclSpn = fmap getLoc con_names
|
||||
<> [getLoc con_forall]
|
||||
<> conTyVarsSpans con_qvars
|
||||
<> maybeToList (fmap getLoc con_mb_cxt)
|
||||
<> conArgsSpans con_args
|
||||
let conDeclSpn =
|
||||
fmap getLoc con_names
|
||||
<> [getLoc con_forall]
|
||||
<> conTyVarsSpans con_qvars
|
||||
<> maybeToList (fmap getLoc con_mb_cxt)
|
||||
<> conArgsSpans con_args
|
||||
switchLayout conDeclSpn $ do
|
||||
case con_names of
|
||||
[] -> return ()
|
||||
(c:cs) -> do
|
||||
(c : cs) -> do
|
||||
p_rdrName c
|
||||
unless (null cs) . inci $ do
|
||||
comma
|
||||
@ -116,10 +124,11 @@ p_conDecl = \case
|
||||
p_hsType (unLoc con_res_ty)
|
||||
ConDeclH98 {..} -> do
|
||||
mapM_ (p_hsDocString Pipe True) con_doc
|
||||
let conDeclSpn = [getLoc con_name]
|
||||
<> fmap getLoc con_ex_tvs
|
||||
<> maybeToList (fmap getLoc con_mb_cxt)
|
||||
<> conArgsSpans con_args
|
||||
let conDeclSpn =
|
||||
[getLoc con_name]
|
||||
<> fmap getLoc con_ex_tvs
|
||||
<> maybeToList (fmap getLoc con_mb_cxt)
|
||||
<> conArgsSpans con_args
|
||||
switchLayout conDeclSpn $ do
|
||||
p_forallBndrs con_ex_tvs
|
||||
unless (null con_ex_tvs) breakpoint
|
||||
@ -156,20 +165,20 @@ conTyVarsSpans = \case
|
||||
HsQTvs {..} -> getLoc <$> hsq_explicit
|
||||
XLHsQTyVars NoExt -> []
|
||||
|
||||
p_forallBndrs
|
||||
:: [LHsTyVarBndr GhcPs]
|
||||
-> R ()
|
||||
p_forallBndrs ::
|
||||
[LHsTyVarBndr GhcPs] ->
|
||||
R ()
|
||||
p_forallBndrs = \case
|
||||
[] -> return ()
|
||||
bndrs -> do
|
||||
txt "forall"
|
||||
space
|
||||
sep space (located' p_hsTyVarBndr) bndrs
|
||||
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,17 +193,19 @@ 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
|
||||
(comma >> breakpoint)
|
||||
(sitcc . located' p_hsType . hsib_body)
|
||||
xs
|
||||
xs ->
|
||||
parens N . sitcc $
|
||||
sep
|
||||
(comma >> breakpoint)
|
||||
(sitcc . located' p_hsType . hsib_body)
|
||||
xs
|
||||
space
|
||||
case deriv_clause_strategy of
|
||||
Nothing -> do
|
||||
|
@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Ormolu.Printer.Meat.Declaration.Default
|
||||
( p_defaultDecl
|
||||
( p_defaultDecl,
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1,9 +1,9 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# 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"
|
||||
|
@ -1,14 +1,13 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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
|
||||
|
@ -1,12 +1,11 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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 ()
|
||||
|
@ -1,9 +1,9 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Ormolu.Printer.Meat.Declaration.Rule
|
||||
( p_ruleDecls
|
||||
( p_ruleDecls,
|
||||
)
|
||||
where
|
||||
|
||||
@ -17,8 +17,9 @@ import Ormolu.Utils
|
||||
|
||||
p_ruleDecls :: RuleDecls GhcPs -> R ()
|
||||
p_ruleDecls = \case
|
||||
HsRules NoExt _ xs -> pragma "RULES" . sitcc $
|
||||
sep breakpoint (sitcc . located' p_ruleDecl) xs
|
||||
HsRules NoExt _ xs ->
|
||||
pragma "RULES" . sitcc $
|
||||
sep breakpoint (sitcc . located' p_ruleDecl) xs
|
||||
XRuleDecls NoExt -> notImplemented "XRuleDecls"
|
||||
|
||||
p_ruleDecl :: RuleDecl GhcPs -> R ()
|
||||
|
@ -1,13 +1,12 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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,13 +34,16 @@ 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_typeSig indentTail (n : ns) hswc = do
|
||||
p_rdrName n
|
||||
if null ns
|
||||
then p_typeAscription hswc
|
||||
@ -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 def names hsib = do
|
||||
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 $
|
||||
located (hsib_body hsib) p_hsType
|
||||
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
|
||||
(comma >> breakpoint)
|
||||
(located' p_booleanFormula)
|
||||
xs
|
||||
Or xs -> sitcc $ sep
|
||||
(breakpoint >> txt "| ")
|
||||
(located' p_booleanFormula)
|
||||
xs
|
||||
And xs ->
|
||||
sitcc $
|
||||
sep
|
||||
(comma >> breakpoint)
|
||||
(located' p_booleanFormula)
|
||||
xs
|
||||
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
|
||||
|
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Ormolu.Printer.Meat.Declaration.Splice
|
||||
( p_spliceDecl
|
||||
( p_spliceDecl,
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1,10 +1,9 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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)
|
||||
|
@ -1,24 +1,23 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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,11 +90,12 @@ 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
|
||||
(isInfix feqn_fixity)
|
||||
inci
|
||||
(p_rdrName feqn_tycon)
|
||||
(located' p_hsType <$> feqn_pats)
|
||||
switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $
|
||||
p_infixDefHelper
|
||||
(isInfix feqn_fixity)
|
||||
inci
|
||||
(p_rdrName feqn_tycon)
|
||||
(located' p_hsType <$> feqn_pats)
|
||||
space
|
||||
txt "="
|
||||
breakpoint
|
||||
|
@ -1,13 +1,13 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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
|
||||
-- insertion of a newline and indentation
|
||||
-- bump
|
||||
| Hanging -- ^ Expressions that have hanging form
|
||||
-- should use it and avoid bumping one level
|
||||
-- of indentation
|
||||
= -- | Multi-line layout should cause
|
||||
-- insertion of a newline and indentation
|
||||
-- bump
|
||||
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
|
||||
@ -131,28 +133,40 @@ adjustMatchGroupStyle m = \case
|
||||
matchStrictness :: Match id body -> SrcStrictness
|
||||
matchStrictness match =
|
||||
case m_ctxt match of
|
||||
FunRhs{mc_strictness=s} -> s
|
||||
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,11 +184,13 @@ 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' $
|
||||
getLoc <$> ne_pats
|
||||
inci' = if isOneLineSpan combinedSpans
|
||||
then id
|
||||
else inci
|
||||
let combinedSpans =
|
||||
combineSrcSpans' $
|
||||
getLoc <$> ne_pats
|
||||
inci' =
|
||||
if isOneLineSpan combinedSpans
|
||||
then id
|
||||
else inci
|
||||
switchLayout [combinedSpans] $ do
|
||||
let stdCase = sep breakpoint (located' p_pat) m_pats
|
||||
case style of
|
||||
@ -197,18 +213,17 @@ 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
|
||||
-- about putting certain constructions in hanging positions.
|
||||
endOfPats = case NE.nonEmpty m_pats of
|
||||
Nothing -> case style of
|
||||
Function name -> (Just . srcSpanEnd . getLoc) name
|
||||
_ -> Nothing
|
||||
Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
|
||||
isCase = \case
|
||||
Case -> True
|
||||
LambdaCase -> True
|
||||
_ -> False
|
||||
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
|
||||
Function name -> (Just . srcSpanEnd . getLoc) name
|
||||
_ -> Nothing
|
||||
Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
|
||||
isCase = \case
|
||||
Case -> True
|
||||
LambdaCase -> True
|
||||
_ -> False
|
||||
let GRHSs {..} = m_grhss
|
||||
hasGuards = withGuards grhssGRHSs
|
||||
unless (length grhssGRHSs > 1) $ do
|
||||
@ -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' $
|
||||
getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
|
||||
patGrhssSpan = maybe grhssSpan
|
||||
(combineSrcSpans grhssSpan . srcLocSpan) endOfPats
|
||||
let grhssSpan =
|
||||
combineSrcSpans' $
|
||||
getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
|
||||
patGrhssSpan =
|
||||
maybe grhssSpan
|
||||
(combineSrcSpans grhssSpan . srcLocSpan)
|
||||
endOfPats
|
||||
placement =
|
||||
case endOfPats of
|
||||
Nothing -> blockPlacement placer grhssGRHSs
|
||||
@ -233,8 +251,8 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
|
||||
p_body = do
|
||||
let groupStyle =
|
||||
if isCase style && hasGuards
|
||||
then RightArrow
|
||||
else EqualSign
|
||||
then RightArrow
|
||||
else EqualSign
|
||||
sep newline (located' (p_grhs' placer render groupStyle)) grhssGRHSs
|
||||
p_where = do
|
||||
let whereIsEmpty = GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds)
|
||||
@ -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
|
||||
@ -276,8 +296,8 @@ p_grhs' placer render style (GRHS NoExt guards body) =
|
||||
Nothing -> placer (unLoc body)
|
||||
Just spn ->
|
||||
if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
|
||||
then placer (unLoc body)
|
||||
else Normal
|
||||
then placer (unLoc body)
|
||||
else Normal
|
||||
endOfGuards =
|
||||
case NE.nonEmpty guards of
|
||||
Nothing -> Nothing
|
||||
@ -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,9 +440,10 @@ gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
|
||||
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
|
||||
p_hsLocalBinds = \case
|
||||
HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
|
||||
let ssStart = either
|
||||
(srcSpanStart . getLoc)
|
||||
(srcSpanStart . getLoc)
|
||||
let ssStart =
|
||||
either
|
||||
(srcSpanStart . getLoc)
|
||||
(srcSpanStart . getLoc)
|
||||
items =
|
||||
(Left <$> bagToList bag) ++ (Right <$> lsigs)
|
||||
p_item (Left x) = located x p_valDecl
|
||||
@ -427,15 +451,16 @@ p_hsLocalBinds = \case
|
||||
-- Assigns 'False' to the last element, 'True' to the rest.
|
||||
markInit :: [a] -> [(Bool, a)]
|
||||
markInit [] = []
|
||||
markInit (x:[]) = [(False, x)]
|
||||
markInit (x:xs) = (True, x) : markInit xs
|
||||
markInit (x : []) = [(False, x)]
|
||||
markInit (x : xs) = (True, x) : markInit xs
|
||||
-- NOTE When in a single-line layout, there is a chance that the inner
|
||||
-- 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
|
||||
(\(m, i) -> (if m then br else id) $ p_item i)
|
||||
(markInit $ sortOn ssStart items)
|
||||
sitcc $
|
||||
sepSemi
|
||||
(\(m, i) -> (if m then br else id) $ p_item i)
|
||||
(markInit $ sortOn ssStart items)
|
||||
HsValBinds NoExt _ -> notImplemented "HsValBinds"
|
||||
HsIPBinds NoExt (IPBinds NoExt xs) ->
|
||||
-- Second argument of IPBind is always Left before type-checking.
|
||||
@ -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
|
||||
@ -505,8 +530,8 @@ p_hsExpr' s = \case
|
||||
-- and then use 'p_withoutHanging' for the descendants.
|
||||
let p_withoutHanging (HsApp NoExt f' x') = do
|
||||
case f' of
|
||||
L _ (HsApp _ _ _) -> located f' p_withoutHanging
|
||||
_ -> located f' (p_hsExpr' s)
|
||||
L _ (HsApp _ _ _) -> located f' p_withoutHanging
|
||||
_ -> located f' (p_hsExpr' s)
|
||||
breakpoint
|
||||
inci $ located x' p_hsExpr
|
||||
p_withoutHanging e = p_hsExpr e
|
||||
@ -514,15 +539,16 @@ p_hsExpr' s = \case
|
||||
-- a single line.
|
||||
placement =
|
||||
if isOneLineSpan (getLoc f)
|
||||
then exprPlacement (unLoc x)
|
||||
else Normal
|
||||
then exprPlacement (unLoc x)
|
||||
else Normal
|
||||
-- We only sit when the last expression is not hanging.
|
||||
-- This is to allow:
|
||||
-- f = foo bar do
|
||||
-- baz
|
||||
sit' = if placement == Normal
|
||||
then sitcc
|
||||
else id
|
||||
sit' =
|
||||
if placement == Normal
|
||||
then sitcc
|
||||
else id
|
||||
sit' $ do
|
||||
useBraces $ located f p_withoutHanging
|
||||
placeHanging placement $
|
||||
@ -559,10 +585,12 @@ p_hsExpr' s = \case
|
||||
Boxed -> parens
|
||||
Unboxed -> parensHash
|
||||
if isSection
|
||||
then switchLayout [] . parens' s $
|
||||
sep comma (located' p_hsTupArg) args
|
||||
else switchLayout (getLoc <$> args) . parens' s . sitcc $
|
||||
sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
|
||||
then
|
||||
switchLayout [] . parens' s $
|
||||
sep comma (located' p_hsTupArg) args
|
||||
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)
|
||||
HsCase NoExt e mgroup ->
|
||||
@ -580,16 +608,20 @@ p_hsExpr' s = \case
|
||||
txt header
|
||||
breakpoint
|
||||
ub <- layoutToBraces <$> getLayout
|
||||
inci $ sepSemi
|
||||
(located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
|
||||
(unLoc es)
|
||||
inci $
|
||||
sepSemi
|
||||
(located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
|
||||
(unLoc es)
|
||||
compBody = brackets N $ located es $ \xs -> do
|
||||
let p_parBody = sep
|
||||
(breakpoint >> txt "| ")
|
||||
p_seqBody
|
||||
p_seqBody = sitcc . sep
|
||||
(comma >> breakpoint)
|
||||
(located' (sitcc . p_stmt))
|
||||
let p_parBody =
|
||||
sep
|
||||
(breakpoint >> txt "| ")
|
||||
p_seqBody
|
||||
p_seqBody =
|
||||
sitcc
|
||||
. sep
|
||||
(comma >> breakpoint)
|
||||
(located' (sitcc . p_stmt))
|
||||
stmts = init xs
|
||||
yield = last xs
|
||||
lists = foldr (liftAppend . gatherStmt) [] stmts
|
||||
@ -603,7 +635,7 @@ p_hsExpr' s = \case
|
||||
MDoExpr -> doBody "mdo"
|
||||
ListComp -> compBody
|
||||
MonadComp -> notImplemented "MonadComp"
|
||||
ArrowExpr -> notImplemented "ArrowExpr"
|
||||
ArrowExpr -> notImplemented "ArrowExpr"
|
||||
GhciStmtCtxt -> notImplemented "GhciStmtCtxt"
|
||||
PatGuard _ -> notImplemented "PatGuard"
|
||||
ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
|
||||
@ -615,11 +647,12 @@ p_hsExpr' s = \case
|
||||
located rcon_con_name atom
|
||||
breakpoint
|
||||
let HsRecFields {..} = rcon_flds
|
||||
updName f = f {
|
||||
hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
||||
FieldOcc _ n -> n
|
||||
XFieldOcc _ -> notImplemented "XFieldOcc"
|
||||
}
|
||||
updName f =
|
||||
f
|
||||
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
||||
FieldOcc _ n -> n
|
||||
XFieldOcc _ -> notImplemented "XFieldOcc"
|
||||
}
|
||||
fields = located' (p_hsRecField . updName) <$> rec_flds
|
||||
dotdot =
|
||||
case rec_dotdot of
|
||||
@ -630,12 +663,13 @@ p_hsExpr' s = \case
|
||||
RecordUpd {..} -> do
|
||||
located rupd_expr p_hsExpr
|
||||
breakpoint
|
||||
let updName f = f {
|
||||
hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
||||
Ambiguous _ n -> n
|
||||
Unambiguous _ n -> n
|
||||
XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
|
||||
}
|
||||
let updName f =
|
||||
f
|
||||
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
||||
Ambiguous _ n -> n
|
||||
Unambiguous _ n -> n
|
||||
XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
|
||||
}
|
||||
inci . braces N . sitcc $
|
||||
sep
|
||||
(comma >> breakpoint)
|
||||
@ -697,7 +731,7 @@ p_hsExpr' s = \case
|
||||
txt "->"
|
||||
placeHanging (cmdTopPlacement (unLoc e)) $
|
||||
located e p_hsCmdTop
|
||||
HsStatic _ e -> do
|
||||
HsStatic _ e -> do
|
||||
txt "static"
|
||||
breakpoint
|
||||
inci (located e p_hsExpr)
|
||||
@ -736,7 +770,7 @@ p_patSynBind PSB {..} = do
|
||||
txt "<-"
|
||||
breakpoint
|
||||
located psb_def p_pat
|
||||
ImplicitBidirectional -> do
|
||||
ImplicitBidirectional -> do
|
||||
txt "="
|
||||
breakpoint
|
||||
located psb_def p_pat
|
||||
@ -753,7 +787,7 @@ p_patSynBind PSB {..} = do
|
||||
PrefixCon xs -> do
|
||||
space
|
||||
p_rdrName psb_id
|
||||
inci $ do
|
||||
inci $ do
|
||||
switchLayout (getLoc <$> xs) $ do
|
||||
unless (null xs) breakpoint
|
||||
sitcc (sep breakpoint p_rdrName xs)
|
||||
@ -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
|
||||
@ -919,7 +963,7 @@ p_unboxedSum s tag arity m = do
|
||||
let before = tag - 1
|
||||
after = arity - before - 1
|
||||
args = replicate before Nothing <> [Just m] <> replicate after Nothing
|
||||
f (x,i) = do
|
||||
f (x, i) = do
|
||||
let isFirst = i == 0
|
||||
isLast = i == arity - 1
|
||||
case x :: Maybe (R ()) of
|
||||
@ -929,7 +973,7 @@ p_unboxedSum s tag arity m = do
|
||||
unless isFirst space
|
||||
m'
|
||||
unless isLast space
|
||||
parensHash s $ sep (txt "|") f (zip args [0..])
|
||||
parensHash s $ sep (txt "|") f (zip args [0 ..])
|
||||
|
||||
p_hsSplice :: HsSplice GhcPs -> R ()
|
||||
p_hsSplice = \case
|
||||
@ -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
|
||||
@ -968,7 +1015,7 @@ p_hsBracket = \case
|
||||
ExpBr NoExt expr -> do
|
||||
anns <- getEnclosingAnns
|
||||
let name = case anns of
|
||||
AnnOpenEQ:_ -> ""
|
||||
AnnOpenEQ : _ -> ""
|
||||
_ -> "e"
|
||||
quote name (located expr p_hsExpr)
|
||||
PatBr NoExt pat -> quote "p" (located pat p_pat)
|
||||
@ -983,10 +1030,11 @@ 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
|
||||
(\i -> isPunctuation i || isSymbol i)
|
||||
(showOutputable (rdrNameOcc name))
|
||||
&& not (doesNotNeedExtraParens name)
|
||||
let isOperator =
|
||||
all
|
||||
(\i -> isPunctuation i || isSymbol i)
|
||||
(showOutputable (rdrNameOcc name))
|
||||
&& not (doesNotNeedExtraParens name)
|
||||
wrapper = if isOperator then parens N else id
|
||||
wrapper $ p_rdrName (noLoc name)
|
||||
TExpBr NoExt expr -> do
|
||||
@ -1019,50 +1067,46 @@ p_stringLit src =
|
||||
multiLine =
|
||||
sitcc $ sep breakpoint (txt . Text.pack) (backslashes s)
|
||||
in vlayout singleLine multiLine
|
||||
where
|
||||
-- Split a string on gaps (backslash delimited whitespaces)
|
||||
--
|
||||
-- > splitGaps "bar\\ \\fo\\&o" == ["bar", "fo\\&o"]
|
||||
splitGaps :: String -> [String]
|
||||
splitGaps "" = []
|
||||
splitGaps s =
|
||||
let -- A backslash and a whitespace starts a "gap"
|
||||
p (Just '\\', _, _) = True
|
||||
p (_, '\\', Just c) | ghcSpace c = False
|
||||
p _ = True
|
||||
in case span p (zipPrevNext s) of
|
||||
(l, r) ->
|
||||
let -- drop the initial '\', any amount of 'ghcSpace', and another '\'
|
||||
where
|
||||
-- Split a string on gaps (backslash delimited whitespaces)
|
||||
--
|
||||
-- > splitGaps "bar\\ \\fo\\&o" == ["bar", "fo\\&o"]
|
||||
splitGaps :: String -> [String]
|
||||
splitGaps "" = []
|
||||
splitGaps s =
|
||||
let -- A backslash and a whitespace starts a "gap"
|
||||
p (Just '\\', _, _) = True
|
||||
p (_, '\\', Just c) | ghcSpace c = False
|
||||
p _ = True
|
||||
in case span p (zipPrevNext s) of
|
||||
(l, r) ->
|
||||
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)
|
||||
(map Just (tail xs) ++ repeat Nothing)
|
||||
in map (\((p, x), n) -> (p, x, n)) z
|
||||
|
||||
orig (_, x, _) = x
|
||||
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)
|
||||
(map Just (tail xs) ++ repeat Nothing)
|
||||
in map (\((p, x), n) -> (p, x, n)) z
|
||||
orig (_, x, _) = x
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Helpers
|
||||
|
||||
-- | 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
|
||||
MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
|
||||
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
|
||||
Hanging
|
||||
_ -> Normal
|
||||
HsLamCase NoExt _ -> Hanging
|
||||
HsCase NoExt _ _ -> Hanging
|
||||
@ -1145,8 +1184,8 @@ exprPlacement = \case
|
||||
-- Indentation breaks if pattern is longer than one line and left
|
||||
-- hanging. Consequently, only apply hanging when it is safe.
|
||||
if isOneLineSpan s
|
||||
then Hanging
|
||||
else Normal
|
||||
then Hanging
|
||||
else Normal
|
||||
_ -> Normal
|
||||
|
||||
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
|
||||
@ -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
|
||||
@ -1179,8 +1220,8 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
|
||||
if isOneLineSpan
|
||||
(mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
|
||||
then case y of
|
||||
OpNode (L _ n) -> exprPlacement n
|
||||
_ -> Normal
|
||||
OpNode (L _ n) -> exprPlacement n
|
||||
_ -> Normal
|
||||
else Normal
|
||||
opWrapper = case unLoc op of
|
||||
EWildPat NoExt -> backticks
|
||||
@ -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,17 +1246,15 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
|
||||
p_op
|
||||
breakpoint
|
||||
inci p_y
|
||||
else
|
||||
placeHanging placement $ do
|
||||
p_op
|
||||
space
|
||||
p_y
|
||||
else placeHanging placement $ do
|
||||
p_op
|
||||
space
|
||||
p_y
|
||||
|
||||
-- | Get annotations for the enclosing element.
|
||||
|
||||
getEnclosingAnns :: R [AnnKeywordId]
|
||||
getEnclosingAnns = do
|
||||
e <- getEnclosingSpan (const True)
|
||||
case e of
|
||||
Nothing -> return []
|
||||
Just e' -> getAnns (RealSrcSpan e')
|
||||
Just e' -> getAnns (RealSrcSpan e')
|
||||
|
@ -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
|
||||
|
||||
|
@ -1,9 +1,9 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Ormolu.Printer.Meat.Declaration.Warning
|
||||
( p_warnDecls
|
||||
, p_moduleWarning
|
||||
( p_warnDecls,
|
||||
p_moduleWarning,
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1,12 +1,11 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Rendering of import and export lists.
|
||||
|
||||
module Ormolu.Printer.Meat.ImportExport
|
||||
( p_hsmodExports
|
||||
, p_hsmodImport
|
||||
( p_hsmodExports,
|
||||
p_hsmodImport,
|
||||
)
|
||||
where
|
||||
|
||||
@ -84,13 +83,13 @@ 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
|
||||
NoIEWildcard -> names
|
||||
IEWildcard n ->
|
||||
let (before, after) = splitAt n names
|
||||
in before ++ [txt ".."] ++ after
|
||||
parens N . sitcc
|
||||
$ sep (comma >> breakpoint) sitcc
|
||||
$ case w of
|
||||
NoIEWildcard -> names
|
||||
IEWildcard n ->
|
||||
let (before, after) = splitAt n names
|
||||
in before ++ [txt ".."] ++ after
|
||||
p_comma
|
||||
IEModuleContents NoExt l1 -> do
|
||||
located l1 p_hsmodName
|
||||
@ -109,11 +108,10 @@ 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
|
||||
in zipWith f [0..] xs
|
||||
in zipWith f [0 ..] xs
|
||||
|
@ -1,11 +1,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Rendering of modules.
|
||||
|
||||
module Ormolu.Printer.Meat.Module
|
||||
( p_hsModule
|
||||
( p_hsModule,
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1,18 +1,17 @@
|
||||
-- | Pretty-printing of language pragmas.
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# 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)
|
||||
@ -23,7 +22,7 @@ p_pragmas ps =
|
||||
PragmaLanguage xs -> (Language,) <$> xs
|
||||
PragmaOptionsGHC x -> [(OptionsGHC, x)]
|
||||
PragmaOptionsHaddock x -> [(OptionsHaddock, x)]
|
||||
in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
|
||||
in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
|
||||
|
||||
p_pragma :: PragmaTy -> String -> R ()
|
||||
p_pragma ty c = do
|
||||
|
@ -1,16 +1,15 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# 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
|
||||
@ -61,7 +60,7 @@ p_hsType' multilineArgs = \case
|
||||
txt "->"
|
||||
interArgBreak
|
||||
case y' of
|
||||
HsFunTy{} -> p_hsTypeR y'
|
||||
HsFunTy {} -> p_hsTypeR y'
|
||||
_ -> located y p_hsTypeR
|
||||
HsListTy NoExt t ->
|
||||
located t (brackets N . p_hsType)
|
||||
@ -72,8 +71,8 @@ p_hsType' multilineArgs = \case
|
||||
HsBoxedTuple -> parens N
|
||||
HsConstraintTuple -> parens N
|
||||
HsBoxedOrConstraintTuple -> parens N
|
||||
in parens' . sitcc $
|
||||
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
in parens' . sitcc $
|
||||
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
HsSumTy NoExt xs ->
|
||||
parensHash N . sitcc $
|
||||
sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
@ -127,14 +126,14 @@ p_hsType' multilineArgs = \case
|
||||
-- If both this list itself and the first element is promoted,
|
||||
-- we need to put a space in between or it fails to parse.
|
||||
case (p, xs) of
|
||||
(Promoted, ((L _ t):_)) | isPromoted t -> space
|
||||
(Promoted, ((L _ t) : _)) | isPromoted t -> space
|
||||
_ -> return ()
|
||||
sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
HsExplicitTupleTy NoExt xs -> do
|
||||
txt "'"
|
||||
parens N $ do
|
||||
case xs of
|
||||
((L _ t):_) | isPromoted t -> space
|
||||
((L _ t) : _) | isPromoted t -> space
|
||||
_ -> return ()
|
||||
sep (comma >> breakpoint) (located' p_hsType) xs
|
||||
HsTyLit NoExt 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,8 +166,9 @@ p_hsContext :: HsContext GhcPs -> R ()
|
||||
p_hsContext = \case
|
||||
[] -> txt "()"
|
||||
[x] -> located x p_hsType
|
||||
xs -> parens N . sitcc $
|
||||
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
xs ->
|
||||
parens N . sitcc $
|
||||
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
|
||||
p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
|
||||
p_hsTyVarBndr = \case
|
||||
@ -184,15 +183,17 @@ p_hsTyVarBndr = \case
|
||||
XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
|
||||
|
||||
p_conDeclFields :: [LConDeclField GhcPs] -> R ()
|
||||
p_conDeclFields xs = braces N . sitcc $
|
||||
sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
|
||||
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)
|
||||
(located' (p_rdrName . rdrNameFieldOcc))
|
||||
cd_fld_names
|
||||
sitcc $
|
||||
sep (comma >> breakpoint)
|
||||
(located' (p_rdrName . rdrNameFieldOcc))
|
||||
cd_fld_names
|
||||
space
|
||||
txt "::"
|
||||
breakpoint
|
||||
@ -228,5 +229,5 @@ tyVarToType = \case
|
||||
UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
|
||||
KindedTyVar NoExt tvar kind ->
|
||||
HsParTy NoExt $ noLoc $
|
||||
HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
|
||||
HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
|
||||
XTyVarBndr {} -> notImplemented "XTyVarBndr"
|
||||
|
@ -1,16 +1,16 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | 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.
|
||||
@ -84,24 +86,26 @@ reassociateOpTreeWith fixityMap getOpName = go
|
||||
-- at the last operator, place the operator and don't recurse
|
||||
go (OpBranch (OpBranch l op r) op' r'@(OpNode _)) =
|
||||
if snd $ compareFixity (fixityOf op) (fixityOf op')
|
||||
then OpBranch l op (go $ OpBranch r op' r')
|
||||
else OpBranch (OpBranch l op r) op' r'
|
||||
then OpBranch l op (go $ OpBranch r op' r')
|
||||
else OpBranch (OpBranch l op r) op' r'
|
||||
-- else, shift one operator to left and recurse.
|
||||
go (OpBranch (OpBranch l op r) op' (OpBranch l' op'' r')) =
|
||||
if snd $ compareFixity (fixityOf op) (fixityOf op')
|
||||
then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
|
||||
else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
|
||||
then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
|
||||
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..]
|
||||
. zip [0 ..]
|
||||
. groupBy (doubleWithinEps 0.00001 `on` snd)
|
||||
. (overrides ++)
|
||||
. avgScores
|
||||
@ -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
|
||||
-- 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
|
||||
-- score 1.
|
||||
else
|
||||
if oe < rb
|
||||
then 1
|
||||
else 2 -- otherwise, assign a high score.
|
||||
return $ (opName, s) : score r
|
||||
if le < ob
|
||||
then-- if the operator is in the beginning of a line, assign
|
||||
-- a score relative to its column within range [0, 1).
|
||||
fromIntegral oc / fromIntegral (maxCol + 1)
|
||||
else-- if the operator is in the end of the line, assign the
|
||||
-- score 1.
|
||||
|
||||
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
|
||||
. map (\xs@((n, _):_) -> (n, avg $ map snd xs))
|
||||
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
|
||||
|
@ -1,46 +1,44 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# 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
|
||||
. sortOn realSrcSpanStart
|
||||
. D.toList
|
||||
$ everything mappend (const mempty `ext2Q` queryLocated) a
|
||||
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
|
||||
|
@ -1,14 +1,13 @@
|
||||
-- | Random utilities used by the code.
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# 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,46 +15,42 @@ 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
|
||||
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
|
||||
_ -> r
|
||||
where
|
||||
r = fmap escapeLeadingDollar
|
||||
. dropPaddingSpace
|
||||
. dropWhileEnd T.null
|
||||
. fmap (T.stripEnd . T.pack)
|
||||
. lines
|
||||
$ unpackHDS docStr
|
||||
r =
|
||||
fmap escapeLeadingDollar
|
||||
. dropPaddingSpace
|
||||
. dropWhileEnd T.null
|
||||
. fmap (T.stripEnd . T.pack)
|
||||
. lines
|
||||
$ unpackHDS docStr
|
||||
-- We cannot have the first character to be a dollar because in that
|
||||
-- case it'll be a parse error (apparently collides with named docs
|
||||
-- syntax @-- $name@ somehow).
|
||||
@ -66,7 +61,7 @@ splitDocString docStr =
|
||||
dropPaddingSpace xs =
|
||||
case dropWhile T.null xs of
|
||||
[] -> []
|
||||
(x:_) ->
|
||||
(x : _) ->
|
||||
let leadingSpace txt = case T.uncons txt of
|
||||
Just (' ', _) -> True
|
||||
_ -> False
|
||||
@ -74,6 +69,6 @@ splitDocString docStr =
|
||||
if leadingSpace txt
|
||||
then T.drop 1 txt
|
||||
else txt
|
||||
in if leadingSpace x
|
||||
then dropSpace <$> xs
|
||||
else xs
|
||||
in if leadingSpace x
|
||||
then dropSpace <$> xs
|
||||
else xs
|
||||
|
@ -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 $
|
||||
parsePragma input `shouldBe` result
|
||||
stdTest input result =
|
||||
it input $
|
||||
parsePragma input `shouldBe` result
|
||||
|
@ -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,37 +44,35 @@ 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
|
||||
(s', exts) = splitExtensions s
|
||||
in exts == ".hs" && not ("-out" `isSuffixOf` s')
|
||||
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 $
|
||||
addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
|
||||
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
|
||||
]
|
||||
shouldMatch idempotencyTest actual expected =
|
||||
when (actual /= expected) . expectationFailure $
|
||||
unlines
|
||||
[ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
|
||||
T.unpack expected,
|
||||
">>>>>>>>>>>>>>>>>>>>>> but got:",
|
||||
T.unpack actual
|
||||
]
|
||||
where
|
||||
pass =
|
||||
if idempotencyTest
|
||||
@ -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 ()
|
||||
|
Loading…
Reference in New Issue
Block a user