ilyakooo0/ormolu
1
0
Fork 0
mirror of https://github.com/ilyakooo0/ormolu.git synced 2024-10-26 19:17:55 +03:00
Code Issues Projects Releases Wiki Activity

Update ghc-lib-parser to 8.10.1

Browse Source 
GHC 8.10.1 comes with some changes to the AST, which works great for
Ormolu, but causes this commit to be a bit large:

* Trees That Grow extension points for new constructors are now statically
  proven to be uninhabited, via noExtCon :: NoExtCon -> a. Thanks to this
  change I got rid of many notImplemented calls.
* LPat constructor is now a lot more usable, so we don't need to use
  the locatedPat combinator and can remove some boilerplate code.

Also it comes with ImportQualifiedPost and StandaloneKindSignatures
we should support. I did not implement them in this commit, they'll
be merged in later on.

It causes one behaviour change, where the ordering of qualified and
non-qualified imports of the same module is changed. This is due to
our usage of gcompare resulting a different ordering because of the
AST change caused by the ImportQualifiedPost extension. I think this is
acceptable and we shouldn't try to keep backwards compatibility there.

Another behaviour change is that previously HsExpr had a few extra
constructors for arrows and patterns used in expression context. Those
programs were syntactically incorrect, but refused on a later stage. But
we nonetheless formatted those constructs so Ormolu didn't fail there
while keeping the source code intact. However, now those constructors
are removed, so Ormolu fails with a parse error in this case (same as
GHC). I also removed some tests exhibiting this behaviour.
This commit is contained in:
Utku Demir 2020-03-29 10:32:04 +13:00 committed by Mark Karpov
parent 57d0d11b37
commit 2c5472944b
36 changed files with 480 additions and 537 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
data/examples/declaration/type/visible-forall-out.hs Normal file
View File

@ -0,0 +1,2 @@
-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst
data T :: forall k -> k -> Type

2
data/examples/declaration/type/visible-forall.hs Normal file
View File

@ -0,0 +1,2 @@
-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst
data T :: forall k -> k -> Type

9
data/examples/declaration/value/function/arrow/expression-applications-out.hs
View File

@ -1,9 +0,0 @@
{-# LANGUAGE Arrows #-}
foo x y = x -< y
bar f x =
f x -< -- Hello
x -- World
baz x y = x -<< y

9
data/examples/declaration/value/function/arrow/expression-applications.hs
View File

@ -1,9 +0,0 @@
{-# LANGUAGE Arrows #-}
foo x y = x -< y
bar f x
= f x -- Hello
-< x -- World
baz x y = x -<< y

14
data/examples/declaration/value/function/arrow/expression-forms-out.hs
View File

@ -1,14 +0,0 @@
{-# LANGUAGE Arrows #-}
foo f g x y = (| test (f -< x) (g -< y) |)
bar f g x y =
(|
test
( f -<
x
)
( g -<
y
)
|)

11
data/examples/declaration/value/function/arrow/expression-forms.hs
View File

@ -1,11 +0,0 @@
{-# LANGUAGE Arrows #-}
foo f g x y = (| test (f -< x) (g -< y) |)
bar f g x y = (|
test
(f
-< x)
(g
-< y)
|)

14
data/examples/declaration/value/function/arrow/proc-forms2-out.hs
View File

@ -4,15 +4,17 @@ bar0 f g h x =
proc (y, z) ->
(| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |)
bar1 f g x y = proc _ -> f -< x &&& g -< y
bar1 f g x y = proc _ -> (f -< x) &&& (g -< y)
bar2 f g h x =
proc (y, z) ->
h f . (h g) -< (y x) . y z ||| (h g) . h f -< y z . (y x)
(h f . (h g) -< (y x) . y z) ||| ((h g) . h f -< y z . (y x))
bar3 f g h x =
proc (y, z) ->
(h f . h g) -<
(y x) . y z
||| (h g . h f) -<
y z . (y x)
( (h f . h g) -<
(y x) . y z
) |||
( (h g . h f) -<
y z . (y x)
)

12
data/examples/declaration/value/function/arrow/proc-forms2.hs
View File

@ -4,16 +4,16 @@ bar0 f g h x =
proc (y, z) ->
(| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)
bar1 f g x y = proc _ -> f -< x&&&g -< y
bar1 f g x y = proc _ -> (f -< x)&&&(g -< y)
bar2 f g h x =
proc (y, z) ->
h f.(h g) -< (y x).y z ||| (h g) . h f-<y z . (y x)
(h f.(h g) -< (y x).y z) ||| ((h g) . h f-<y z . (y x))
bar3 f g h x =
proc (y, z) ->
(h f.h g)
-< (y x).y z
((h f.h g)
-< (y x).y z)
|||
(h g . h f)
-<y z . (y x)
((h g . h f)
-<y z . (y x))

3
data/examples/declaration/value/function/pattern/view-pattern-out.hs
View File

@ -13,6 +13,3 @@ multiline
bar
baz
) = True
-- https://github.com/tweag/ormolu/issues/343
foo = (f -> 4)

3
data/examples/declaration/value/function/pattern/view-pattern.hs
View File

@ -10,6 +10,3 @@ g ((f, _), f -> 4) = True
multiline (t -> Foo
bar
baz) = True
-- https://github.com/tweag/ormolu/issues/343
foo = (f -> 4)

2
data/examples/import/qualified-prelude-out.hs
View File

@ -1,4 +1,4 @@
module P where
import Prelude hiding ((.), id)
import qualified Prelude
import Prelude hiding ((.), id)

8
default.nix
View File

@ -17,10 +17,14 @@ let
"ormolu" = pkgs.haskell.lib.enableCabalFlag
(super.callCabal2nix "ormolu" source { }) "dev";
# Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want
# ghc-lib-parser-8.8.1. We disable Haddock generation because it's way
# ghc-lib-parser-8.10.1. We disable Haddock generation because it's way
# too slow.
"ghc-lib-parser" = pkgs.haskell.lib.dontHaddock
(super.callHackage "ghc-lib-parser" "8.8.1" { });
(super.callHackageDirect {
pkg = "ghc-lib-parser";
ver = "8.10.1.20200324";
sha256 = "0f2c68fzdj2lw6da2zpx7a0cx631im3kylwd85dzx1npsm1vzlbg";
} {});
};
ormolize = import ./nix/ormolize {
inherit pkgs;

4
ormolu.cabal
View File

@ -68,7 +68,7 @@ library
, containers >= 0.5 && < 0.7
, dlist >= 0.8 && < 0.9
, exceptions >= 0.6 && < 0.11
, ghc-lib-parser >= 8.8.1 && < 8.8.3
, ghc-lib-parser >= 8.10 && < 8.11
, mtl >= 2.0 && < 3.0
, syb >= 0.7 && < 0.8
, text >= 0.2 && < 1.3
@ -149,7 +149,7 @@ executable ormolu
main-is: Main.hs
hs-source-dirs: app
build-depends: base >= 4.12 && < 5.0
, ghc-lib-parser >= 8.8.1 && < 8.8.3
, ghc-lib-parser >= 8.10 && < 8.11
, gitrev >= 1.3 && < 1.4
, optparse-applicative >= 0.14 && < 0.16
, ormolu

12
src/GHC.hs
View File

@ -6,16 +6,8 @@ where
import ApiAnnotation as X
import BasicTypes as X
import HsBinds as X
import HsDecls as X
import HsDoc as X
import HsExpr as X
import HsExtension as X
import HsImpExp as X
import HsInstances as X ()
import HsLit as X
import HsPat as X
import HsSyn as X
import GHC.Hs as X
import GHC.Hs.Instances as X ()
import Module as X
import RdrName as X
import SrcLoc as X

49
src/GHC/DynFlags.hs
View File

@ -1,5 +1,7 @@
{-# OPTIONS_GHC -Wno-missing-fields #-}
-- Modified from ghc-lib-api-ext.
module GHC.DynFlags
( baseDynFlags,
)
@ -8,31 +10,40 @@ where
import Config
import DynFlags
import Fingerprint
import Platform
import GHC.Platform
import ToolSettings
-- | Taken from HLint.
fakeSettings :: Settings
fakeSettings =
Settings
{ sTargetPlatform = platform,
sPlatformConstants = platformConstants,
sProjectVersion = cProjectVersion,
sProgramName = "ghc",
sOpt_P_fingerprint = fingerprint0,
sPgm_F = ""
{ sGhcNameVersion =
GhcNameVersion
{ ghcNameVersion_programName = "ghc",
ghcNameVersion_projectVersion = cProjectVersion
},
sFileSettings = FileSettings {},
sTargetPlatform =
Platform
{ platformWordSize = PW8,
platformMini =
PlatformMini
{ platformMini_arch = ArchUnknown,
platformMini_os = OSUnknown
},
platformUnregisterised = True
},
sPlatformMisc = PlatformMisc {},
sPlatformConstants =
PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},
sToolSettings =
ToolSettings
{ toolSettings_opt_P_fingerprint = fingerprint0,
toolSettings_pgm_F = ""
}
}
where
platform =
Platform
{ platformWordSize = 8,
platformOS = OSUnknown,
platformUnregisterised = True
}
platformConstants =
PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}
fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
fakeLlvmConfig = ([], [])
fakeLlvmConfig :: LlvmConfig
fakeLlvmConfig = LlvmConfig [] []
baseDynFlags :: DynFlags
baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

28
src/Ormolu/Imports.hs
View File

@ -13,8 +13,8 @@ import Data.Function (on)
import Data.Generics (gcompare)
import Data.List (sortBy)
import GHC hiding (GhcPs, IE)
import HsExtension
import HsImpExp (IE (..))
import GHC.Hs.Extension
import GHC.Hs.ImpExp (IE (..))
import Ormolu.Utils (notImplemented)
-- | Sort imports by module name. This also sorts explicit import lists for
@ -29,7 +29,7 @@ sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
{ ideclHiding = second (fmap sortLies) <$> ideclHiding,
..
}
XImportDecl {} -> notImplemented "XImportDecl"
XImportDecl x -> noExtCon x
-- | Compare two @'LImportDecl' 'GhcPs'@ things.
compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
@ -51,8 +51,8 @@ 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 ->
IEThingWith NoExt x w (sortBy (compareIewn `on` unLoc) xs) fl
IEThingWith NoExtField x w xs fl ->
IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl
other -> other
-- | Compare two located imports or exports.
@ -62,15 +62,15 @@ compareIE = compareIewn `on` getIewn
-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
getIewn :: IE GhcPs -> IEWrappedName RdrName
getIewn = \case
IEVar NoExt x -> unLoc x
IEThingAbs NoExt x -> unLoc x
IEThingAll NoExt x -> unLoc x
IEThingWith NoExt x _ _ _ -> unLoc x
IEModuleContents NoExt _ -> notImplemented "IEModuleContents"
IEGroup NoExt _ _ -> notImplemented "IEGroup"
IEDoc NoExt _ -> notImplemented "IEDoc"
IEDocNamed NoExt _ -> notImplemented "IEDocNamed"
XIE NoExt -> notImplemented "XIE"
IEVar NoExtField x -> unLoc x
IEThingAbs NoExtField x -> unLoc x
IEThingAll NoExtField x -> unLoc x
IEThingWith NoExtField x _ _ _ -> unLoc x
IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
IEGroup NoExtField _ _ -> notImplemented "IEGroup"
IEDoc NoExtField _ -> notImplemented "IEDoc"
IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
XIE x -> noExtCon x
-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering

66
src/Ormolu/Parser.hs
View File

@ -9,14 +9,17 @@ module Ormolu.Parser
)
where
import Bag (bagToList)
import qualified CmdLineParser as GHC
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.List ((\\), foldl', isPrefixOf)
import Data.List ((\\), foldl', isPrefixOf, sortOn)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes)
import Data.Ord (Down (Down))
import DynFlags as GHC
import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
import qualified FastString as GHC
import GHC hiding (IE, UnicodeSyntax)
import GHC.DynFlags (baseDynFlags)
@ -29,7 +32,6 @@ import Ormolu.Exception
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import qualified Outputable as GHC
import qualified Panic as GHC
import qualified Parser as GHC
import qualified StringBuffer as GHC
@ -73,20 +75,34 @@ parseModule Config {..} path input' = liftIO $ do
|| any
(("RecordDotPreprocessor" ==) . moduleNameString)
(pluginModNames dynFlags)
pStateErrors = \pstate ->
let errs = bagToList $ GHC.getErrorMessages pstate dynFlags
in case sortOn (Down . SeverityOrd . errMsgSeverity) errs of
[] -> Nothing
err : _ -> Just (errMsgSpan err, show err) -- Show instance returns a short error message
r = case runParser GHC.parseModule dynFlags path input of
GHC.PFailed _ ss m ->
Left (ss, GHC.showSDoc dynFlags m)
GHC.PFailed pstate ->
case pStateErrors pstate of
Just err -> Left err
Nothing -> error "invariant violation: PFailed does not have an error"
GHC.POk pstate pmod ->
let (comments, exts, shebangs) = mkCommentStream extraComments pstate
in Right
ParseResult
{ prParsedSource = pmod,
prAnns = mkAnns pstate,
prCommentStream = comments,
prExtensions = exts,
prShebangs = shebangs,
prUseRecordDot = useRecordDot
}
case pStateErrors pstate of
-- Some parse errors (pattern/arrow syntax in expr context)
-- do not cause a parse error, but they are replaced with "_"
-- by the parser and the modified AST is propagated to the
-- later stages; but we fail in those cases.
Just err -> Left err
Nothing ->
let (comments, exts, shebangs) = mkCommentStream extraComments pstate
in Right
ParseResult
{ prParsedSource = pmod,
prAnns = mkAnns pstate,
prCommentStream = comments,
prExtensions = exts,
prShebangs = shebangs,
prUseRecordDot = useRecordDot
}
return (warnings, r)
-- | Extensions that are not enabled automatically and should be activated
@ -223,3 +239,25 @@ parsePragmasIntoDynFlags flags extraOpts filepath str =
reportErr
(GHC.handleSourceError reportErr act)
reportErr e = return $ Left (show e)
----------------------------------------------------------------------------
-- Even more helpers
-- Wrap GHC's ErrUtils.Severity to add Ord instance
newtype SeverityOrd = SeverityOrd Severity
instance Eq SeverityOrd where
s1 == s2 = compare s1 s2 == EQ
instance Ord SeverityOrd where
compare (SeverityOrd s1) (SeverityOrd s2) =
compare (f s1) (f s2)
where
f :: Severity -> Int
f SevOutput = 1
f SevFatal = 2
f SevInteractive = 3
f SevDump = 4
f SevInfo = 5
f SevWarning = 6
f SevError = 7

24
src/Ormolu/Printer/Combinators.hs
View File

@ -23,7 +23,6 @@ module Ormolu.Printer.Combinators
inci,
located,
located',
locatedPat,
switchLayout,
Layout (..),
vlayout,
@ -64,7 +63,6 @@ import Control.Monad
import Data.Data (Data)
import Data.List (intersperse)
import Data.Text (Text)
import GHC (Pat (XPat), XXPat)
import Ormolu.Printer.Comments
import Ormolu.Printer.Internal
import Ormolu.Utils (isModule)
@ -111,28 +109,6 @@ located' ::
R ()
located' = flip located
-- | A version of 'located' that works on 'Pat'.
--
-- Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always
-- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.
--
-- Most of the time, we can just use 'p_pat' directly, because it handles
-- located 'Pat's. However, sometimes we want to use the location to render
-- something other than the given 'Pat'.
--
-- If given 'Pat' does not contain a location, we error out.
--
-- This should become unnecessary if
-- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.
locatedPat ::
(Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>
Pat pass ->
(Pat pass -> R ()) ->
R ()
locatedPat p f = case p of
XPat pat -> located pat f
_ -> error "locatedPat: Pat does not contain a location"
-- | Set layout according to combination of given 'SrcSpan's for a given.
-- Use this only when you need to set layout based on e.g. combined span of
-- several elements when there is no corresponding 'Located' wrapper

115
src/Ormolu/Printer/Meat/Declaration.hs
View File

@ -110,29 +110,30 @@ groupDecls (lhdr : xs) =
p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
p_hsDecl style = \case
TyClD NoExt x -> p_tyClDecl style x
ValD NoExt x -> p_valDecl x
SigD NoExt x -> p_sigDecl x
InstD NoExt x -> p_instDecl style x
DerivD NoExt x -> p_derivDecl x
DefD NoExt x -> p_defaultDecl x
ForD NoExt x -> p_foreignDecl x
WarningD NoExt x -> p_warnDecls x
AnnD NoExt x -> p_annDecl x
RuleD NoExt x -> p_ruleDecls x
SpliceD NoExt x -> p_spliceDecl x
DocD NoExt docDecl ->
TyClD NoExtField x -> p_tyClDecl style x
ValD NoExtField x -> p_valDecl x
SigD NoExtField x -> p_sigDecl x
InstD NoExtField x -> p_instDecl style x
DerivD NoExtField x -> p_derivDecl x
DefD NoExtField x -> p_defaultDecl x
ForD NoExtField x -> p_foreignDecl x
WarningD NoExtField x -> p_warnDecls x
AnnD NoExtField x -> p_annDecl x
RuleD NoExtField x -> p_ruleDecls x
SpliceD NoExtField x -> p_spliceDecl x
DocD NoExtField docDecl ->
case docDecl of
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)
RoleAnnotD NoExt x -> p_roleAnnot x
XHsDecl _ -> notImplemented "XHsDecl"
RoleAnnotD NoExtField x -> p_roleAnnot x
KindSigD NoExtField _ -> notImplemented "StandaloneKindSignatures"
XHsDecl x -> noExtCon x
p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
p_tyClDecl style = \case
FamDecl NoExt x -> p_famDecl style x
FamDecl NoExtField x -> p_famDecl style x
SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
DataDecl {..} ->
p_dataDecl
@ -153,19 +154,19 @@ p_tyClDecl style = \case
tcdATs
tcdATDefs
tcdDocs
XTyClDecl {} -> notImplemented "XTyClDecl"
XTyClDecl x -> noExtCon x
p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
p_instDecl style = \case
ClsInstD NoExt x -> p_clsInstDecl x
TyFamInstD NoExt x -> p_tyFamInstDecl style x
DataFamInstD NoExt x -> p_dataFamInstDecl style x
XInstDecl _ -> notImplemented "XInstDecl"
ClsInstD NoExtField x -> p_clsInstDecl x
TyFamInstD NoExtField x -> p_tyFamInstDecl style x
DataFamInstD NoExtField x -> p_dataFamInstDecl style x
XInstDecl x -> noExtCon x
p_derivDecl :: DerivDecl GhcPs -> R ()
p_derivDecl = \case
d@DerivDecl {..} -> p_standaloneDerivDecl d
XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
XDerivDecl x -> noExtCon x
-- | Determine if these declarations should be grouped together.
groupedDecls ::
@ -225,13 +226,13 @@ pattern
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) _)
pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)
pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)
pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))
pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _)
pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _)
pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _)
pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _)
pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _)
pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _))
pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (L _ n) _ _ _)
-- Declarations which can refer to multiple names
@ -249,51 +250,51 @@ pattern PatternSignature n <- (patSigRdrNames -> Just n)
pattern WarningPragma n <- (warnSigRdrNames -> Just n)
pattern DocNext, DocPrev :: HsDecl GhcPs
pattern DocNext <- (DocD NoExt (DocCommentNext _))
pattern DocPrev <- (DocD NoExt (DocCommentPrev _))
pattern DocNext <- (DocD NoExtField (DocCommentNext _))
pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))
sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns
sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns
sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns
sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns
sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
sigRdrNames _ = Nothing
defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
defSigRdrNames (SigD NoExt (ClassOpSig NoExt True ns _)) = Just $ map unLoc ns
defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns
defSigRdrNames _ = Nothing
funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]
funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n
funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]
funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n
funRdrNames _ = Nothing
patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
patSigRdrNames _ = Nothing
warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case
L _ (Warning NoExt ns _) -> map unLoc ns
L _ (XWarnDecl NoExt) -> []
warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case
L _ (Warning NoExtField ns _) -> map unLoc ns
L _ (XWarnDecl x) -> noExtCon x
warnSigRdrNames _ = Nothing
patBindNames :: Pat GhcPs -> [RdrName]
patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps
patBindNames (VarPat NoExt (L _ n)) = [n]
patBindNames (WildPat NoExt) = []
patBindNames (LazyPat NoExt p) = patBindNames p
patBindNames (BangPat NoExt p) = patBindNames p
patBindNames (ParPat NoExt p) = patBindNames p
patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps
patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p
patBindNames (SumPat NoExt p _ _) = patBindNames p
patBindNames (ViewPat NoExt _ p) = patBindNames p
patBindNames (SplicePat NoExt _) = []
patBindNames (LitPat NoExt _) = []
patBindNames (SigPat _ p _) = patBindNames p
patBindNames (NPat NoExt _ _ _) = []
patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]
patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps
patBindNames (VarPat NoExtField (L _ n)) = [n]
patBindNames (WildPat NoExtField) = []
patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p
patBindNames (BangPat NoExtField (L _ p)) = patBindNames p
patBindNames (ParPat NoExtField (L _ p)) = patBindNames p
patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps
patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p
patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p
patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p
patBindNames (SplicePat NoExtField _) = []
patBindNames (LitPat NoExtField _) = []
patBindNames (SigPat _ (L _ p) _) = patBindNames p
patBindNames (NPat NoExtField _ _ _) = []
patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n]
patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer
patBindNames (CoPat NoExt _ p _) = patBindNames p
patBindNames (XPat p) = patBindNames (unLoc p)
patBindNames (CoPat NoExtField _ p _) = patBindNames p
patBindNames (XPat x) = noExtCon x

5
src/Ormolu/Printer/Meat/Declaration/Annotation.hs
View File

@ -10,15 +10,14 @@ import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration.Value
import Ormolu.Utils
p_annDecl :: AnnDecl GhcPs -> R ()
p_annDecl = \case
HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do
HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do
p_annProv annProv
breakpoint
located expr p_hsExpr
XAnnDecl {} -> notImplemented "XAnnDecl"
XAnnDecl x -> noExtCon x
p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
p_annProv = \case

22
src/Ormolu/Printer/Meat/Declaration/Class.hs
View File

@ -18,7 +18,6 @@ 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 (..))
p_classDecl ::
@ -30,7 +29,7 @@ p_classDecl ::
[LSig GhcPs] ->
LHsBinds GhcPs ->
[LFamilyDecl GhcPs] ->
[LTyFamDefltEqn GhcPs] ->
[LTyFamDefltDecl GhcPs] ->
[LDocDecl] ->
R ()
p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do
@ -42,12 +41,12 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d
-- location order. This happens because different declarations are stored
-- in different lists. Consequently, to get all the declarations in proper
-- order, they need to be manually sorted.
sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs
vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs
tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats
docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
sigs = (getLoc &&& fmap (SigD NoExtField)) <$> csigs
vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cdefs
tyFams = (getLoc &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats
docs = (getLoc &&& fmap (DocD NoExtField)) <$> cdocs
tyFamDefs =
( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
)
<$> catdefs
allDecls =
@ -70,7 +69,7 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d
unless (null allDecls) $ do
breakpoint -- Ensure whitespace is added after where clause.
inci (p_hsDeclsRespectGrouping Associated allDecls)
p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars"
p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c
p_classContext :: LHsContext GhcPs -> R ()
p_classContext ctx = unless (null (unLoc ctx)) $ do
@ -97,13 +96,6 @@ p_funDep (before, after) = do
----------------------------------------------------------------------------
-- Helpers
defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}
where
eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}
tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}
defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn"
isInfix :: LexicalFixity -> Bool
isInfix = \case
Infix -> True

16
src/Ormolu/Printer/Meat/Declaration/Data.hs
View File

@ -76,7 +76,7 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
unless (null $ unLoc dd_derivs) breakpoint
inci . located dd_derivs $ \xs ->
sep newline (located' p_hsDerivingClause) xs
p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"
p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x
p_conDecl :: ConDecl GhcPs -> R ()
p_conDecl = \case
@ -106,7 +106,7 @@ p_conDecl = \case
else breakpoint
interArgBreak
when (unLoc con_forall) $ do
p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)
p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars)
interArgBreak
forM_ con_mb_cxt p_lhsContext
case con_args of
@ -134,7 +134,7 @@ p_conDecl = \case
<> conArgsSpans con_args
switchLayout conDeclSpn $ do
when (unLoc con_forall) $ do
p_forallBndrs p_hsTyVarBndr con_ex_tvs
p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs
breakpoint
forM_ con_mb_cxt p_lhsContext
case con_args of
@ -153,7 +153,7 @@ p_conDecl = \case
p_rdrName con_name
space
located y p_hsType
XConDecl NoExt -> notImplemented "XConDecl"
XConDecl x -> noExtCon x
conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
conArgsSpans = \case
@ -167,7 +167,7 @@ conArgsSpans = \case
conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
conTyVarsSpans = \case
HsQTvs {..} -> getLoc <$> hsq_explicit
XLHsQTyVars NoExt -> []
XLHsQTyVars x -> noExtCon x
p_lhsContext ::
LHsContext GhcPs ->
@ -225,9 +225,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
txt "via"
space
located hsib_body p_hsType
ViaStrategy (XHsImplicitBndrs NoExt) ->
notImplemented "XHsImplicitBndrs"
p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"
ViaStrategy (XHsImplicitBndrs x) ->
noExtCon x
p_hsDerivingClause (XHsDerivingClause x) = noExtCon x
----------------------------------------------------------------------------
-- Helpers

5
src/Ormolu/Printer/Meat/Declaration/Default.hs
View File

@ -9,13 +9,12 @@ where
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
p_defaultDecl :: DefaultDecl GhcPs -> R ()
p_defaultDecl = \case
DefaultDecl NoExt ts -> do
DefaultDecl NoExtField ts -> do
txt "default"
breakpoint
inci . parens N . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsType) ts
XDefaultDecl {} -> notImplemented "XDefaultDecl"
XDefaultDecl x -> noExtCon x

5
src/Ormolu/Printer/Meat/Declaration/Foreign.hs
View File

@ -15,7 +15,6 @@ import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration.Signature
import Ormolu.Utils
p_foreignDecl :: ForeignDecl GhcPs -> R ()
p_foreignDecl = \case
@ -25,7 +24,7 @@ p_foreignDecl = \case
fd@ForeignExport {fd_fe} -> do
p_foreignExport fd_fe
p_foreignTypeSig fd
XForeignDecl {} -> notImplemented "XForeignDecl"
XForeignDecl x -> noExtCon x
-- | Printer for the last part of an import\/export, which is function name
-- and type signature.
@ -39,7 +38,7 @@ p_foreignTypeSig fd = do
]
$ do
p_rdrName (fd_name fd)
p_typeAscription (HsWC NoExt (fd_sig_ty fd))
p_typeAscription (HsWC NoExtField (fd_sig_ty fd))
-- | Printer for 'ForeignImport'.
--

16
src/Ormolu/Printer/Meat/Declaration/Instance.hs
View File

@ -56,8 +56,8 @@ p_standaloneDerivDecl DerivDecl {..} = do
inci (located hsib_body p_hsType)
breakpoint
instTypes True
ViaStrategy (XHsImplicitBndrs NoExt) ->
notImplemented "XHsImplicitBndrs"
ViaStrategy (XHsImplicitBndrs x) ->
noExtCon x
p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
@ -70,14 +70,14 @@ p_clsInstDecl = \case
-- location order. This happens because different declarations are stored in
-- different lists. Consequently, to get all the declarations in proper
-- order, they need to be manually sorted.
let sigs = (getLoc &&& fmap (SigD NoExt)) <$> cid_sigs
vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs
vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds
tyFamInsts =
( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
)
<$> cid_tyfam_insts
dataFamInsts =
( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)
)
<$> cid_datafam_insts
allDecls =
@ -96,8 +96,8 @@ p_clsInstDecl = \case
-- Ensure whitespace is added after where clause.
breakpoint
dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"
XClsInstDecl NoExt -> notImplemented "XClsInstDecl"
XHsImplicitBndrs x -> noExtCon x
XClsInstDecl x -> noExtCon x
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
p_tyFamInstDecl style = \case

5
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs
View File

@ -12,14 +12,13 @@ import CoAxiom
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Utils
import RdrName (RdrName (..))
import SrcLoc (Located)
p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
p_roleAnnot = \case
RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns
XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"
RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns
XRoleAnnotDecl x -> noExtCon x
p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
p_roleAnnot' l_name anns = do

21
src/Ormolu/Printer/Meat/Declaration/Rule.hs
View File

@ -14,18 +14,17 @@ import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration.Signature
import Ormolu.Printer.Meat.Declaration.Value
import Ormolu.Printer.Meat.Type
import Ormolu.Utils
p_ruleDecls :: RuleDecls GhcPs -> R ()
p_ruleDecls = \case
HsRules NoExt _ xs ->
HsRules NoExtField _ xs ->
pragma "RULES" . sitcc $
sep breakpoint (sitcc . located' p_ruleDecl) xs
XRuleDecls NoExt -> notImplemented "XRuleDecls"
XRuleDecls x -> noExtCon x
p_ruleDecl :: RuleDecl GhcPs -> R ()
p_ruleDecl = \case
HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do
HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do
located ruleName p_ruleName
space
p_activation activation
@ -33,13 +32,13 @@ p_ruleDecl = \case
case tyvars of
Nothing -> return ()
Just xs -> do
p_forallBndrs p_hsTyVarBndr xs
p_forallBndrs ForallInvis p_hsTyVarBndr xs
space
-- It appears that there is no way to tell if there was an empty forall
-- in the input or no forall at all. We do not want to add redundant
-- foralls, so let's just skip the empty ones.
unless (null ruleBndrs) $
p_forallBndrs p_ruleBndr ruleBndrs
p_forallBndrs ForallInvis p_ruleBndr ruleBndrs
breakpoint
inci $ do
located lhs p_hsExpr
@ -48,15 +47,15 @@ p_ruleDecl = \case
inci $ do
breakpoint
located rhs p_hsExpr
XRuleDecl NoExt -> notImplemented "XRuleDecl"
XRuleDecl x -> noExtCon x
p_ruleName :: (SourceText, RuleName) -> R ()
p_ruleName (_, name) = atom $ HsString NoSourceText name
p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs)
p_ruleBndr :: RuleBndr GhcPs -> R ()
p_ruleBndr = \case
RuleBndr NoExt x -> p_rdrName x
RuleBndrSig NoExt x hswc -> parens N $ do
RuleBndr NoExtField x -> p_rdrName x
RuleBndrSig NoExtField x hswc -> parens N $ do
p_rdrName x
p_typeAscription hswc
XRuleBndr NoExt -> notImplemented "XRuleBndr"
XRuleBndr x -> noExtCon x

30
src/Ormolu/Printer/Meat/Declaration/Signature.hs
View File

@ -22,16 +22,16 @@ import Ormolu.Utils
p_sigDecl :: Sig GhcPs -> R ()
p_sigDecl = \case
TypeSig NoExt names hswc -> p_typeSig True names hswc
PatSynSig NoExt names hsib -> p_patSynSig names hsib
ClassOpSig NoExt def names hsib -> p_classOpSig def names hsib
FixSig NoExt sig -> p_fixSig sig
InlineSig NoExt name inlinePragma -> p_inlineSig name inlinePragma
SpecSig NoExt name ts inlinePragma -> p_specSig name ts inlinePragma
SpecInstSig NoExt _ hsib -> p_specInstSig hsib
MinimalSig NoExt _ booleanFormula -> p_minimalSig booleanFormula
CompleteMatchSig NoExt _sourceText cs ty -> p_completeSig cs ty
SCCFunSig NoExt _ name literal -> p_sccSig name literal
TypeSig NoExtField names hswc -> p_typeSig True names hswc
PatSynSig NoExtField names hsib -> p_patSynSig names hsib
ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib
FixSig NoExtField sig -> p_fixSig sig
InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma
SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma
SpecInstSig NoExtField _ hsib -> p_specInstSig hsib
MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula
CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty
SCCFunSig NoExtField _ name literal -> p_sccSig name literal
_ -> notImplemented "certain types of signature declarations"
p_typeSig ::
@ -65,7 +65,7 @@ p_typeAscription HsWC {..} = do
then newline
else breakpoint
located t p_hsType
p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"
p_typeAscription (XHsWildCardBndrs x) = noExtCon x
p_patSynSig ::
[Located RdrName] ->
@ -73,7 +73,7 @@ p_patSynSig ::
R ()
p_patSynSig names hsib = do
txt "pattern"
let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}
let body = p_typeSig False names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
if length names > 1
then breakpoint >> inci body
else space >> body
@ -88,13 +88,13 @@ p_classOpSig ::
R ()
p_classOpSig def names hsib = do
when def (txt "default" >> space)
p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}
p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
p_fixSig ::
FixitySig GhcPs ->
R ()
p_fixSig = \case
FixitySig NoExt names (Fixity _ n dir) -> do
FixitySig NoExtField names (Fixity _ n dir) -> do
txt $ case dir of
InfixL -> "infixl"
InfixR -> "infixr"
@ -103,7 +103,7 @@ p_fixSig = \case
atom n
space
sitcc $ sep (comma >> breakpoint) p_rdrName names
XFixitySig NoExt -> notImplemented "XFixitySig"
XFixitySig x -> noExtCon x
p_inlineSig ::
-- | Name

5
src/Ormolu/Printer/Meat/Declaration/Splice.hs
View File

@ -8,9 +8,8 @@ where
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
import Ormolu.Utils
p_spliceDecl :: SpliceDecl GhcPs -> R ()
p_spliceDecl = \case
SpliceDecl NoExt splice _explicit -> located splice p_hsSplice
XSpliceDecl {} -> notImplemented "XSpliceDecl"
SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice
XSpliceDecl x -> noExtCon x

3
src/Ormolu/Printer/Meat/Declaration/Type.hs
View File

@ -11,7 +11,6 @@ import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Type
import Ormolu.Utils (notImplemented)
import RdrName (RdrName (..))
import SrcLoc (Located)
@ -38,4 +37,4 @@ p_synDecl name fixity HsQTvs {..} t = do
txt "="
breakpoint
inci (located t p_hsType)
p_synDecl _ _ XLHsQTyVars {} _ = notImplemented "XLHsQTyVars"
p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x

18
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs
View File

@ -57,7 +57,7 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
sep newline (located' (inci . p_tyFamInstEqn)) eqs
p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =
notImplemented "XLHsQTyVars"
p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
p_famDecl _ (XFamilyDecl x) = noExtCon x
p_familyResultSigL ::
Located (FamilyResultSig GhcPs) ->
@ -65,17 +65,17 @@ p_familyResultSigL ::
p_familyResultSigL l =
case l of
L _ a -> case a of
NoSig NoExt -> Nothing
KindSig NoExt k -> Just $ do
NoSig NoExtField -> Nothing
KindSig NoExtField k -> Just $ do
txt "::"
breakpoint
located k p_hsType
TyVarSig NoExt bndr -> Just $ do
TyVarSig NoExtField bndr -> Just $ do
txt "="
breakpoint
located bndr p_hsTyVarBndr
XFamilyResultSig NoExt ->
notImplemented "XFamilyResultSig"
XFamilyResultSig x ->
noExtCon x
p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
p_injectivityAnn (InjectivityAnn a bs) = do
@ -92,7 +92,7 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
case feqn_bndrs of
Nothing -> return ()
Just bndrs -> do
p_forallBndrs p_hsTyVarBndr bndrs
p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
breakpoint
(if null feqn_bndrs then id else inci) $ do
let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
@ -106,8 +106,8 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
txt "="
breakpoint
inci (located feqn_rhs p_hsType)
p_tyFamInstEqn HsIB {hsib_body = XFamEqn {}} = notImplemented "HsIB XFamEqn"
p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x
----------------------------------------------------------------------------
-- Helpers

364
src/Ormolu/Printer/Meat/Declaration/Value.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Ormolu.Printer.Meat.Declaration.Value
( p_valDecl,
@ -65,12 +66,12 @@ data Placement
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
p_valDecl = \case
FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches
PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
PatSynBind NoExt psb -> p_patSynBind psb
XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
PatSynBind NoExtField psb -> p_patSynBind psb
XHsBindsLR x -> noExtCon x
p_funBind ::
Located RdrName ->
@ -114,8 +115,8 @@ p_matchGroup' placer render style MG {..} = do
(matchStrictness m)
m_pats
m_grhss
p_Match _ = notImplemented "XMatch"
p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
p_Match (XMatch x) = noExtCon x
p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x
-- | Function id obtained through pattern matching on 'FunBind' should not
-- be used to print the actual equations because the different ‘RdrNames’
@ -193,14 +194,14 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
then id
else inci
switchLayout [combinedSpans] $ do
let stdCase = sep breakpoint p_pat m_pats
let stdCase = sep breakpoint (located' p_pat) m_pats
case style of
Function name ->
p_infixDefHelper
isInfix
inci'
(p_rdrName name)
(p_pat <$> m_pats)
(located' p_pat <$> m_pats)
PatternBind -> stdCase
Case -> stdCase
Lambda -> do
@ -266,7 +267,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
switchLayout [patGrhssSpan] $
placeHanging placement p_body
inci p_where
p_match' _ _ _ _ _ _ XGRHSs {} = notImplemented "XGRHSs"
p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
p_grhs = p_grhs' exprPlacement p_hsExpr
@ -280,7 +281,7 @@ p_grhs' ::
GroupStyle ->
GRHS GhcPs (Located body) ->
R ()
p_grhs' placer render style (GRHS NoExt guards body) =
p_grhs' placer render style (GRHS NoExtField guards body) =
case guards of
[] -> p_body
xs -> do
@ -305,11 +306,11 @@ p_grhs' placer render style (GRHS NoExt guards body) =
Nothing -> Nothing
Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
p_body = located body render
p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
p_grhs' _ _ _ (XGRHS x) = noExtCon x
p_hsCmd :: HsCmd GhcPs -> R ()
p_hsCmd = \case
HsCmdArrApp NoExt body input arrType _ -> do
HsCmdArrApp NoExtField body input arrType _ -> do
located body p_hsExpr
space
case arrType of
@ -317,42 +318,42 @@ p_hsCmd = \case
HsHigherOrderApp -> txt "-<<"
placeHanging (exprPlacement (unLoc input)) $
located input p_hsExpr
HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do
HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do
located form p_hsExpr
unless (null cmds) $ do
breakpoint
inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
HsCmdArrForm NoExt form Infix _ [left, right] -> do
HsCmdArrForm NoExtField form Infix _ [left, right] -> do
located left p_hsCmdTop
space
located form p_hsExpr
placeHanging (cmdTopPlacement (unLoc right)) $
located right p_hsCmdTop
HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
HsCmdApp {} ->
-- XXX Does this ever occur in the syntax tree? It does not seem like it
-- does. Open an issue and ping @yumiova if this ever occurs in output.
notImplemented "HsCmdApp"
HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
HsCmdPar NoExt c -> parens N (located c p_hsCmd)
HsCmdCase NoExt e mgroup ->
HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
HsCmdPar NoExtField c -> parens N (located c p_hsCmd)
HsCmdCase NoExtField e mgroup ->
p_case cmdPlacement p_hsCmd e mgroup
HsCmdIf NoExt _ if' then' else' ->
HsCmdIf NoExtField _ if' then' else' ->
p_if cmdPlacement p_hsCmd if' then' else'
HsCmdLet NoExt localBinds c ->
HsCmdLet NoExtField localBinds c ->
p_let p_hsCmd localBinds c
HsCmdDo NoExt es -> do
HsCmdDo NoExtField es -> do
txt "do"
newline
inci . located es $
sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
HsCmdWrap {} -> notImplemented "HsCmdWrap"
XCmd {} -> notImplemented "XCmd"
XCmd x -> noExtCon x
p_hsCmdTop :: HsCmdTop GhcPs -> R ()
p_hsCmdTop = \case
HsCmdTop NoExt cmd -> located cmd p_hsCmd
XCmdTop {} -> notImplemented "XHsCmdTop"
HsCmdTop NoExtField cmd -> located cmd p_hsCmd
XCmdTop x -> noExtCon x
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt = p_stmt' exprPlacement p_hsExpr
@ -367,16 +368,13 @@ p_stmt' ::
Stmt GhcPs (Located body) ->
R ()
p_stmt' placer render = \case
LastStmt NoExt body _ _ -> located body render
BindStmt NoExt p f _ _ -> do
p_pat p
LastStmt NoExtField body _ _ -> located body render
BindStmt NoExtField p f _ _ -> do
located p p_pat
space
txt "<-"
-- https://gitlab.haskell.org/ghc/ghc/issues/17330
let loc = case p of
XPat pat -> getLoc pat
_ -> error "p_stmt': BindStmt: Pat does not contain a location"
let placement =
let loc = getLoc p
placement =
case f of
L l' x ->
if isOneLineSpan
@ -386,8 +384,8 @@ p_stmt' placer render = \case
switchLayout [loc, getLoc f] $
placeHanging placement (located f render)
ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
BodyStmt NoExt body _ _ -> located body render
LetStmt NoExt binds -> do
BodyStmt NoExtField body _ _ -> located body render
LetStmt NoExtField binds -> do
txt "let"
space
sitcc $ located binds p_hsLocalBinds
@ -429,10 +427,10 @@ p_stmt' placer render = \case
txt "rec"
space
sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
XStmtLR {} -> notImplemented "XStmtLR"
XStmtLR c -> noExtCon c
gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
gatherStmt (L _ (ParStmt NoExt block _ _)) =
gatherStmt (L _ (ParStmt NoExtField block _ _)) =
foldr ((<>) . gatherStmtBlock) [] block
gatherStmt (L s stmt@TransStmt {..}) =
foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
@ -441,11 +439,11 @@ gatherStmt stmt = [[stmt]]
gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
gatherStmtBlock (ParStmtBlock _ stmts _ _) =
foldr (liftAppend . gatherStmt) [] stmts
gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
gatherStmtBlock (XParStmtBlock x) = noExtCon x
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
p_hsLocalBinds = \case
HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
let ssStart =
either
(srcSpanStart . getLoc)
@ -467,20 +465,23 @@ p_hsLocalBinds = \case
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) ->
HsValBinds NoExtField _ -> notImplemented "HsValBinds"
HsIPBinds NoExtField (IPBinds NoExtField xs) ->
-- Second argument of IPBind is always Left before type-checking.
let p_ipBind (IPBind NoExt (Left name) expr) = do
let p_ipBind (IPBind NoExtField (Left name) expr) = do
atom name
space
txt "="
breakpoint
useBraces $ inci $ located expr p_hsExpr
p_ipBind _ = notImplemented "XHsIPBinds"
p_ipBind (IPBind NoExtField (Right _) _) =
-- Should only occur after the type checker
notImplemented "IPBind _ (Right _) _"
p_ipBind (XIPBind x) = noExtCon x
in sepSemi (located' p_ipBind) xs
HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
EmptyLocalBinds NoExt -> return ()
XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
EmptyLocalBinds NoExtField -> return ()
XHsLocalBindsLR x -> noExtCon x
p_hsRecField ::
HsRecField' RdrName (LHsExpr GhcPs) ->
@ -495,42 +496,42 @@ p_hsRecField HsRecField {..} = do
p_hsTupArg :: HsTupArg GhcPs -> R ()
p_hsTupArg = \case
Present NoExt x -> located x p_hsExpr
Missing NoExt -> pure ()
XTupArg {} -> notImplemented "XTupArg"
Present NoExtField x -> located x p_hsExpr
Missing NoExtField -> pure ()
XTupArg x -> noExtCon x
p_hsExpr :: HsExpr GhcPs -> R ()
p_hsExpr = p_hsExpr' N
p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
p_hsExpr' s = \case
HsVar NoExt name -> p_rdrName name
HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
HsRecFld NoExt x ->
HsVar NoExtField name -> p_rdrName name
HsUnboundVar NoExtField v -> atom (unboundVarOcc v)
HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"
HsRecFld NoExtField x ->
case x of
Unambiguous NoExt name -> p_rdrName name
Ambiguous NoExt name -> p_rdrName name
XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
HsOverLabel NoExt _ v -> do
Unambiguous NoExtField name -> p_rdrName name
Ambiguous NoExtField name -> p_rdrName name
XAmbiguousFieldOcc xx -> noExtCon xx
HsOverLabel NoExtField _ v -> do
txt "#"
atom v
HsIPVar NoExt (HsIPName name) -> do
HsIPVar NoExtField (HsIPName name) -> do
txt "?"
atom name
HsOverLit NoExt v -> atom (ol_val v)
HsLit NoExt lit ->
HsOverLit NoExtField v -> atom (ol_val v)
HsLit NoExtField lit ->
case lit of
HsString (SourceText stxt) _ -> p_stringLit stxt
HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
r -> atom r
HsLam NoExt mgroup ->
HsLam NoExtField mgroup ->
p_matchGroup Lambda mgroup
HsLamCase NoExt mgroup -> do
HsLamCase NoExtField mgroup -> do
txt "\\case"
breakpoint
inci (p_matchGroup LambdaCase mgroup)
HsApp NoExt f x -> do
HsApp NoExtField f x -> do
let -- In order to format function applications with multiple parameters
-- nicer, traverse the AST to gather the function and all the
-- parameters together.
@ -564,9 +565,9 @@ p_hsExpr' s = \case
-- expression is parenthesised.
indent =
case func of
L _ (HsPar NoExt _) -> inci
L _ (HsAppType NoExt _ _) -> inci
L _ (HsMultiIf NoExt _) -> inci
L _ (HsPar NoExtField _) -> inci
L _ (HsAppType NoExtField _ _) -> inci
L _ (HsMultiIf NoExtField _) -> inci
L spn _ ->
if isOneLineSpan spn
then inci
@ -588,35 +589,35 @@ p_hsExpr' s = \case
sep breakpoint (located' p_hsExpr) initp
placeHanging placement $
located lastp p_hsExpr
HsAppType NoExt e a -> do
HsAppType NoExtField e a -> do
located e p_hsExpr
breakpoint
inci $ do
txt "@"
located (hswc_body a) p_hsType
OpApp NoExt x op y -> do
OpApp NoExtField x op y -> do
let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
p_exprOpTree True s (reassociateOpTree getOpName opTree)
NegApp NoExt e _ -> do
NegApp NoExtField e _ -> do
txt "-"
space
located e p_hsExpr
HsPar NoExt e ->
HsPar NoExtField e ->
parens s (located e (dontUseBraces . p_hsExpr))
SectionL NoExt x op -> do
SectionL NoExtField x op -> do
located x p_hsExpr
breakpoint
inci (located op p_hsExpr)
SectionR NoExt op x -> do
SectionR NoExtField op x -> do
located op p_hsExpr
useRecordDot' <- useRecordDot
let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
unless (useRecordDot' && isRecordDot') breakpoint
inci (located x p_hsExpr)
ExplicitTuple NoExt args boxity -> do
ExplicitTuple NoExtField args boxity -> do
let isSection = any (isMissing . unLoc) args
isMissing = \case
Missing NoExt -> True
Missing NoExtField -> True
_ -> False
let parens' =
case boxity of
@ -629,18 +630,18 @@ p_hsExpr' s = \case
else
switchLayout (getLoc <$> args) . parens' s . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
ExplicitSum NoExt tag arity e ->
ExplicitSum NoExtField tag arity e ->
p_unboxedSum N tag arity (located e p_hsExpr)
HsCase NoExt e mgroup ->
HsCase NoExtField e mgroup ->
p_case exprPlacement p_hsExpr e mgroup
HsIf NoExt _ if' then' else' ->
HsIf NoExtField _ if' then' else' ->
p_if exprPlacement p_hsExpr if' then' else'
HsMultiIf NoExt guards -> do
HsMultiIf NoExtField guards -> do
txt "if "
inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
HsLet NoExt localBinds e ->
HsLet NoExtField localBinds e ->
p_let p_hsExpr localBinds e
HsDo NoExt ctx es -> do
HsDo NoExtField ctx es -> do
let doBody header = do
txt header
breakpoint
@ -685,10 +686,10 @@ p_hsExpr' s = \case
breakpoint
let HsRecFields {..} = rcon_flds
updName f =
f
(f :: HsRecField GhcPs (LHsExpr GhcPs))
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
FieldOcc _ n -> n
XFieldOcc _ -> notImplemented "XFieldOcc"
XFieldOcc x -> noExtCon x
}
fields = located' (p_hsRecField . updName) <$> rec_flds
dotdot =
@ -708,27 +709,26 @@ p_hsExpr' s = \case
== (srcSpanStartCol <$> mrs (head rupd_flds))
unless (useRecordDot' && isPluginForm) breakpoint
let updName f =
f
(f :: HsRecUpdField GhcPs)
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
Ambiguous _ n -> n
Unambiguous _ n -> n
XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
XAmbiguousFieldOcc x -> noExtCon x
}
inci . braces N . sitcc $
sep
(comma >> breakpoint)
(sitcc . located' (p_hsRecField . updName))
rupd_flds
ExprWithTySig NoExt x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
located x p_hsExpr
space
txt "::"
breakpoint
inci $ located hsib_body p_hsType
ExprWithTySig NoExt _ HsWC {hswc_body = XHsImplicitBndrs {}} ->
notImplemented "XHsImplicitBndrs"
ExprWithTySig NoExt _ XHsWildCardBndrs {} -> notImplemented "XHsWildCardBndrs"
ArithSeq NoExt _ x ->
ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x
ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
ArithSeq NoExtField _ x ->
case x of
From from -> brackets s . sitcc $ do
located from p_hsExpr
@ -750,25 +750,25 @@ p_hsExpr' s = \case
txt ".."
space
located to p_hsExpr
HsSCC NoExt _ name x -> do
HsSCC NoExtField _ name x -> do
txt "{-# SCC "
atom name
txt " #-}"
breakpoint
located x p_hsExpr
HsCoreAnn NoExt _ value x -> do
HsCoreAnn NoExtField _ value x -> do
txt "{-# CORE "
atom value
txt " #-}"
breakpoint
located x p_hsExpr
HsBracket NoExt x -> p_hsBracket x
HsBracket NoExtField x -> p_hsBracket x
HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
HsSpliceE NoExt splice -> p_hsSplice splice
HsProc NoExt p e -> do
HsSpliceE NoExtField splice -> p_hsSplice splice
HsProc NoExtField p e -> do
txt "proc"
locatedPat p $ \x -> do
located p $ \x -> do
breakpoint
inci (p_pat x)
breakpoint
@ -779,31 +779,11 @@ p_hsExpr' s = \case
txt "static"
breakpoint
inci (located e p_hsExpr)
HsArrApp NoExt body input arrType cond ->
p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
HsArrForm NoExt form mfixity cmds ->
p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
HsTick {} -> notImplemented "HsTick"
HsBinTick {} -> notImplemented "HsBinTick"
HsTickPragma {} -> notImplemented "HsTickPragma"
-- These four constructs should never appear in correct programs.
-- See: https://github.com/tweag/ormolu/issues/343
EWildPat NoExt -> txt "_"
EAsPat NoExt n p -> do
p_rdrName n
txt "@"
located p p_hsExpr
EViewPat NoExt p e -> do
located p p_hsExpr
space
txt "->"
breakpoint
inci (located e p_hsExpr)
ELazyPat NoExt p -> do
txt "~"
located p p_hsExpr
HsWrap {} -> notImplemented "HsWrap"
XExpr {} -> notImplemented "XExpr"
XExpr x -> noExtCon x
p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
p_patSynBind PSB {..} = do
@ -813,15 +793,15 @@ p_patSynBind PSB {..} = do
Unidirectional -> do
txt "<-"
breakpoint
p_pat psb_def
located psb_def p_pat
ImplicitBidirectional -> do
txt "="
breakpoint
p_pat psb_def
located psb_def p_pat
ExplicitBidirectional mgroup -> do
txt "<-"
breakpoint
p_pat psb_def
located psb_def p_pat
newline
txt "where"
newline
@ -855,7 +835,7 @@ p_patSynBind PSB {..} = do
space
p_rdrName r
inci rhs
p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
p_patSynBind (XPatSynBind x) = noExtCon x
p_case ::
Data body =>
@ -922,40 +902,37 @@ p_let render localBinds e = sitcc $ do
p_pat :: Pat GhcPs -> R ()
p_pat = \case
-- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always
-- constructed with the 'XPat' constructor, containing a @Located Pat@.
XPat pat -> located pat p_pat
WildPat NoExt -> txt "_"
VarPat NoExt name -> p_rdrName name
LazyPat NoExt pat -> do
WildPat NoExtField -> txt "_"
VarPat NoExtField name -> p_rdrName name
LazyPat NoExtField pat -> do
txt "~"
p_pat pat
AsPat NoExt name pat -> do
located pat p_pat
AsPat NoExtField name pat -> do
p_rdrName name
txt "@"
p_pat pat
ParPat NoExt pat ->
locatedPat pat (parens S . p_pat)
BangPat NoExt pat -> do
located pat p_pat
ParPat NoExtField pat ->
located pat (parens S . p_pat)
BangPat NoExtField pat -> do
txt "!"
p_pat pat
ListPat NoExt pats ->
brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats
TuplePat NoExt pats boxing -> do
located pat p_pat
ListPat NoExtField pats ->
brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
TuplePat NoExtField pats boxing -> do
let f =
case boxing of
Boxed -> parens S
Unboxed -> parensHash S
f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats
SumPat NoExt pat tag arity ->
p_unboxedSum S tag arity (p_pat pat)
f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
SumPat NoExtField pat tag arity ->
p_unboxedSum S tag arity (located pat p_pat)
ConPatIn pat details ->
case details of
PrefixCon xs -> sitcc $ do
p_rdrName pat
unless (null xs) $ do
breakpoint
inci . sitcc $ sep breakpoint (sitcc . p_pat) xs
inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs
RecCon (HsRecFields fields dotdot) -> do
p_rdrName pat
breakpoint
@ -965,36 +942,37 @@ p_pat = \case
inci . braces N . sitcc . sep (comma >> breakpoint) f $
case dotdot of
Nothing -> Just <$> fields
Just n -> (Just <$> take n fields) ++ [Nothing]
Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
InfixCon l r -> do
switchLayout [getLoc l, getLoc r] $ do
p_pat l
located l p_pat
breakpoint
inci $ do
p_rdrName pat
space
p_pat r
located r p_pat
ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
ViewPat NoExt expr pat -> sitcc $ do
ViewPat NoExtField expr pat -> sitcc $ do
located expr p_hsExpr
space
txt "->"
breakpoint
inci (p_pat pat)
SplicePat NoExt splice -> p_hsSplice splice
LitPat NoExt p -> atom p
NPat NoExt v _ _ -> located v (atom . ol_val)
NPlusKPat NoExt n k _ _ _ -> sitcc $ do
inci (located pat p_pat)
SplicePat NoExtField splice -> p_hsSplice splice
LitPat NoExtField p -> atom p
NPat NoExtField v _ _ -> located v (atom . ol_val)
NPlusKPat NoExtField n k _ _ _ -> sitcc $ do
p_rdrName n
breakpoint
inci $ do
txt "+"
space
located k (atom . ol_val)
SigPat NoExt pat hswc -> do
p_pat pat
SigPat NoExtField pat hswc -> do
located pat p_pat
p_typeAscription hswc
CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
XPat x -> noExtCon x
p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
p_pat_hsRecField HsRecField {..} = do
@ -1004,7 +982,7 @@ p_pat_hsRecField HsRecField {..} = do
space
txt "="
breakpoint
inci (p_pat hsRecFieldArg)
inci (located hsRecFieldArg p_pat)
p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
p_unboxedSum s tag arity m = do
@ -1025,9 +1003,9 @@ p_unboxedSum s tag arity m = do
p_hsSplice :: HsSplice GhcPs -> R ()
p_hsSplice = \case
HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
HsQuasiQuote NoExt _ quoterName srcSpan str -> do
HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco
HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco
HsQuasiQuote NoExtField _ quoterName srcSpan str -> do
txt "["
p_rdrName (L srcSpan quoterName)
txt "|"
@ -1037,7 +1015,7 @@ p_hsSplice = \case
txt "|]"
HsSpliced {} -> notImplemented "HsSpliced"
HsSplicedT {} -> notImplemented "HsSplicedT"
XSplice {} -> notImplemented "XSplice"
XSplice x -> noExtCon x
p_hsSpliceTH ::
-- | Typed splice?
@ -1061,17 +1039,17 @@ p_hsSpliceTH isTyped expr = \case
p_hsBracket :: HsBracket GhcPs -> R ()
p_hsBracket = \case
ExpBr NoExt expr -> do
ExpBr NoExtField expr -> do
anns <- getEnclosingAnns
let name = case anns of
AnnOpenEQ : _ -> ""
_ -> "e"
quote name (located expr p_hsExpr)
PatBr NoExt pat -> quote "p" (p_pat pat)
DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
TypBr NoExt ty -> quote "t" (located ty p_hsType)
VarBr NoExt isSingleQuote name -> do
PatBr NoExtField pat -> located pat (quote "p" . p_pat)
DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)
DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer
TypBr NoExtField ty -> quote "t" (located ty p_hsType)
VarBr NoExtField isSingleQuote name -> do
txt (bool "''" "'" isSingleQuote)
-- HACK As you can see we use 'noLoc' here to be able to pass name into
-- 'p_rdrName' since the latter expects a "located" thing. The problem
@ -1086,13 +1064,13 @@ p_hsBracket = \case
&& not (doesNotNeedExtraParens name)
wrapper = if isOperator then parens N else id
wrapper $ p_rdrName (noLoc name)
TExpBr NoExt expr -> do
TExpBr NoExtField expr -> do
txt "[||"
breakpoint'
located expr p_hsExpr
breakpoint'
txt "||]"
XBracket {} -> notImplemented "XBracket"
XBracket x -> noExtCon x
where
quote :: Text -> R () -> R ()
quote name body = do
@ -1171,9 +1149,9 @@ liftAppend (x : xs) [] = x : xs
liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
getGRHSSpan (GRHS NoExt guards body) =
getGRHSSpan (GRHS NoExtField guards body) =
combineSrcSpans' $ getLoc body :| map getLoc guards
getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
getGRHSSpan (XGRHS x) = noExtCon x
-- | Place a thing that may have a hanging form. This function handles how
-- to separate it from preceding expressions and whether to bump indentation
@ -1194,67 +1172,63 @@ blockPlacement ::
(body -> Placement) ->
[LGRHS GhcPs (Located body)] ->
Placement
blockPlacement placer [L _ (GRHS NoExt _ (L _ x))] = placer x
blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
blockPlacement _ _ = Normal
-- | Check if given command has a hanging form.
cmdPlacement :: HsCmd GhcPs -> Placement
cmdPlacement = \case
HsCmdLam NoExt _ -> Hanging
HsCmdCase NoExt _ _ -> Hanging
HsCmdDo NoExt _ -> Hanging
HsCmdLam NoExtField _ -> Hanging
HsCmdCase NoExtField _ _ -> Hanging
HsCmdDo NoExtField _ -> Hanging
_ -> Normal
cmdTopPlacement :: HsCmdTop GhcPs -> Placement
cmdTopPlacement = \case
HsCmdTop NoExt (L _ x) -> cmdPlacement x
XCmdTop {} -> notImplemented "XCmdTop"
HsCmdTop NoExtField (L _ x) -> cmdPlacement x
XCmdTop x -> noExtCon x
-- | 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) _)]) _
HsLam NoExtField mg -> case mg of
MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
Hanging
_ -> Normal
HsLamCase NoExt _ -> Hanging
HsCase NoExt _ _ -> Hanging
HsDo NoExt DoExpr _ -> Hanging
HsDo NoExt MDoExpr _ -> Hanging
HsLamCase NoExtField _ -> Hanging
HsCase NoExtField _ _ -> Hanging
HsDo NoExtField DoExpr _ -> Hanging
HsDo NoExtField MDoExpr _ -> Hanging
-- If the rightmost expression in an operator chain is hanging, make the
-- whole block hanging; so that we can use the common @f = foo $ do@
-- style.
OpApp NoExt _ _ y -> exprPlacement (unLoc y)
OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
-- Same thing for function applications (usually with -XBlockArguments)
HsApp NoExt _ y -> exprPlacement (unLoc y)
HsProc NoExt p _ ->
-- https://gitlab.haskell.org/ghc/ghc/issues/17330
let loc = case p of
XPat pat -> getLoc pat
_ -> error "exprPlacement: HsProc: Pat does not contain a location"
in -- Indentation breaks if pattern is longer than one line and left
-- hanging. Consequently, only apply hanging when it is safe.
if isOneLineSpan loc
then Hanging
else Normal
HsApp NoExtField _ y -> exprPlacement (unLoc y)
HsProc NoExtField p _ ->
-- Indentation breaks if pattern is longer than one line and left
-- hanging. Consequently, only apply hanging when it is safe.
if isOneLineSpan (getLoc p)
then Hanging
else Normal
_ -> Normal
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
withGuards = any (checkOne . unLoc)
where
checkOne :: GRHS GhcPs (Located body) -> Bool
checkOne (GRHS NoExt [] _) = False
checkOne (GRHS NoExtField [] _) = False
checkOne _ = True
exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
exprOpTree n = OpNode n
getOpName :: HsExpr GhcPs -> Maybe RdrName
getOpName = \case
HsVar NoExt (L _ a) -> Just a
HsVar NoExtField (L _ a) -> Just a
_ -> Nothing
p_exprOpTree ::
@ -1276,8 +1250,10 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
OpNode (L _ n) -> exprPlacement n
_ -> Normal
else Normal
-- Distinguish holes used in infix notation.
-- eg. '1 _foo 2' and '1 `_foo` 2'
opWrapper = case unLoc op of
EWildPat NoExt -> backticks
HsUnboundVar NoExtField _ -> backticks
_ -> id
layout <- getLayout
let ub = case layout of
@ -1332,7 +1308,7 @@ isRecordDot ::
SrcSpan ->
Bool
isRecordDot op (RealSrcSpan ySpan) = case op of
HsVar NoExt (L (RealSrcSpan opSpan) opName) ->
HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
_ -> False
isRecordDot _ _ = False

9
src/Ormolu/Printer/Meat/Declaration/Warning.hs
View File

@ -13,17 +13,16 @@ import Data.Text (Text)
import GHC
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Utils
p_warnDecls :: WarnDecls GhcPs -> R ()
p_warnDecls (Warnings NoExt _ warnings) =
p_warnDecls (Warnings NoExtField _ warnings) =
traverse_ (located' p_warnDecl) warnings
p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"
p_warnDecls (XWarnDecls x) = noExtCon x
p_warnDecl :: WarnDecl GhcPs -> R ()
p_warnDecl (Warning NoExt functions warningTxt) =
p_warnDecl (Warning NoExtField functions warningTxt) =
p_topLevelWarning functions warningTxt
p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"
p_warnDecl (XWarnDecl x) = noExtCon x
p_moduleWarning :: WarningTxt -> R ()
p_moduleWarning wtxt = do

27
src/Ormolu/Printer/Meat/ImportExport.hs
View File

@ -11,10 +11,9 @@ where
import Control.Monad
import GHC
import HsImpExp (IE (..))
import GHC.Hs.ImpExp (IE (..))
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Utils
p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports [] = do
@ -34,7 +33,9 @@ p_hsmodImport ImportDecl {..} = do
space
when ideclSafe (txt "safe")
space
when ideclQualified (txt "qualified")
when
(isImportDeclQualified ideclQualified)
(txt "qualified")
space
case ideclPkgQual of
Nothing -> return ()
@ -62,22 +63,22 @@ p_hsmodImport ImportDecl {..} = do
layout <- getLayout
sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
newline
p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"
p_hsmodImport (XImportDecl x) = noExtCon x
p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
p_lie encLayout (i, totalItems) = \case
IEVar NoExt l1 -> do
IEVar NoExtField l1 -> do
located l1 p_ieWrappedName
p_comma
IEThingAbs NoExt l1 -> do
IEThingAbs NoExtField l1 -> do
located l1 p_ieWrappedName
p_comma
IEThingAll NoExt l1 -> do
IEThingAll NoExtField l1 -> do
located l1 p_ieWrappedName
space
txt "(..)"
p_comma
IEThingWith NoExt l1 w xs _ -> sitcc $ do
IEThingWith NoExtField l1 w xs _ -> sitcc $ do
located l1 p_ieWrappedName
breakpoint
inci $ do
@ -91,16 +92,16 @@ p_lie encLayout (i, totalItems) = \case
let (before, after) = splitAt n names
in before ++ [txt ".."] ++ after
p_comma
IEModuleContents NoExt l1 -> do
IEModuleContents NoExtField l1 -> do
located l1 p_hsmodName
p_comma
IEGroup NoExt n str -> do
IEGroup NoExtField n str -> do
unless (i == 0) newline
p_hsDocString (Asterisk n) False (noLoc str)
IEDoc NoExt str ->
IEDoc NoExtField str ->
p_hsDocString Pipe False (noLoc str)
IEDocNamed NoExt str -> p_hsDocName str
XIE NoExt -> notImplemented "XIE"
IEDocNamed NoExtField str -> p_hsDocName str
XIE x -> noExtCon x
where
p_comma =
case encLayout of

77
src/Ormolu/Printer/Meat/Type.hs
View File

@ -27,11 +27,11 @@ p_hsType t = p_hsType' (hasDocStrings t) t
p_hsType' :: Bool -> HsType GhcPs -> R ()
p_hsType' multilineArgs = \case
HsForAllTy NoExt bndrs t -> do
p_forallBndrs p_hsTyVarBndr bndrs
HsForAllTy NoExtField visibility bndrs t -> do
p_forallBndrs visibility p_hsTyVarBndr bndrs
interArgBreak
p_hsType' multilineArgs (unLoc t)
HsQualTy NoExt qs t -> do
HsQualTy NoExtField qs t -> do
located qs p_hsContext
space
txt "=>"
@ -40,7 +40,7 @@ p_hsType' multilineArgs = \case
HsQualTy {} -> p_hsTypeR (unLoc t)
HsFunTy {} -> p_hsTypeR (unLoc t)
_ -> located t p_hsTypeR
HsTyVar NoExt p n -> do
HsTyVar NoExtField p n -> do
case p of
IsPromoted -> do
txt "'"
@ -49,7 +49,7 @@ p_hsType' multilineArgs = \case
_ -> return ()
NotPromoted -> return ()
p_rdrName n
HsAppTy NoExt f x -> sitcc $ do
HsAppTy NoExtField f x -> sitcc $ do
located f p_hsType
breakpoint
inci (located x p_hsType)
@ -62,7 +62,7 @@ p_hsType' multilineArgs = \case
inci $ do
txt "@"
located kd p_hsType
HsFunTy NoExt x y@(L _ y') -> do
HsFunTy NoExtField x y@(L _ y') -> do
located x p_hsType
space
txt "->"
@ -70,9 +70,9 @@ p_hsType' multilineArgs = \case
case y' of
HsFunTy {} -> p_hsTypeR y'
_ -> located y p_hsTypeR
HsListTy NoExt t ->
HsListTy NoExtField t ->
located t (brackets N . p_hsType)
HsTupleTy NoExt tsort xs ->
HsTupleTy NoExtField tsort xs ->
let parens' =
case tsort of
HsUnboxedTuple -> parensHash N
@ -81,33 +81,33 @@ p_hsType' multilineArgs = \case
HsBoxedOrConstraintTuple -> parens N
in parens' . sitcc $
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
HsSumTy NoExt xs ->
HsSumTy NoExtField xs ->
parensHash N . sitcc $
sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
HsOpTy NoExt x op y ->
HsOpTy NoExtField x op y ->
sitcc $
let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
in p_tyOpTree (reassociateOpTree Just opTree)
HsParTy NoExt t ->
HsParTy NoExtField t ->
parens N (located t p_hsType)
HsIParamTy NoExt n t -> sitcc $ do
HsIParamTy NoExtField n t -> sitcc $ do
located n atom
space
txt "::"
breakpoint
inci (located t p_hsType)
HsStarTy NoExt _ -> txt "*"
HsKindSig NoExt t k -> sitcc $ do
HsStarTy NoExtField _ -> txt "*"
HsKindSig NoExtField t k -> sitcc $ do
located t p_hsType
space -- FIXME
txt "::"
space
inci (located k p_hsType)
HsSpliceTy NoExt splice -> p_hsSplice splice
HsDocTy NoExt t str -> do
HsSpliceTy NoExtField splice -> p_hsSplice splice
HsDocTy NoExtField t str -> do
p_hsDocString Pipe True str
located t p_hsType
HsBangTy NoExt (HsSrcBang _ u s) t -> do
HsBangTy NoExtField (HsSrcBang _ u s) t -> do
case u of
SrcUnpack -> txt "{-# UNPACK #-}" >> space
SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
@ -117,9 +117,9 @@ p_hsType' multilineArgs = \case
SrcStrict -> txt "!"
NoSrcStrict -> return ()
located t p_hsType
HsRecTy NoExt fields ->
HsRecTy NoExtField fields ->
p_conDeclFields fields
HsExplicitListTy NoExt p xs -> do
HsExplicitListTy NoExtField p xs -> do
case p of
IsPromoted -> txt "'"
NotPromoted -> return ()
@ -130,18 +130,18 @@ p_hsType' multilineArgs = \case
(IsPromoted, L _ t : _) | isPromoted t -> space
_ -> return ()
sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
HsExplicitTupleTy NoExt xs -> do
HsExplicitTupleTy NoExtField xs -> do
txt "'"
parens N $ do
case xs of
L _ t : _ | isPromoted t -> space
_ -> return ()
sep (comma >> breakpoint) (located' p_hsType) xs
HsTyLit NoExt t ->
HsTyLit NoExtField t ->
case t of
HsStrTy (SourceText s) _ -> p_stringLit s
a -> atom a
HsWildCardTy NoExt -> txt "_"
HsWildCardTy NoExtField -> txt "_"
XHsType (NHsCoreTy t) -> atom t
where
isPromoted = \case
@ -173,26 +173,29 @@ p_hsContext = \case
p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
p_hsTyVarBndr = \case
UserTyVar NoExt x ->
UserTyVar NoExtField x ->
p_rdrName x
KindedTyVar NoExt l k -> parens N $ do
KindedTyVar NoExtField l k -> parens N $ do
located l atom
space
txt "::"
breakpoint
inci (located k p_hsType)
XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
XTyVarBndr x -> noExtCon x
-- | Render several @forall@-ed variables.
p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()
p_forallBndrs _ [] = txt "forall."
p_forallBndrs p tyvars =
p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()
p_forallBndrs ForallInvis _ [] = txt "forall."
p_forallBndrs ForallVis _ [] = txt "forall ->"
p_forallBndrs vis p tyvars =
switchLayout (getLoc <$> tyvars) $ do
txt "forall"
breakpoint
inci $ do
sitcc $ sep breakpoint (sitcc . located' p) tyvars
txt "."
case vis of
ForallInvis -> txt "."
ForallVis -> space >> txt "->"
p_conDeclFields :: [LConDeclField GhcPs] -> R ()
p_conDeclFields xs =
@ -211,10 +214,10 @@ p_conDeclField ConDeclField {..} = do
txt "::"
breakpoint
sitcc . inci $ p_hsType (unLoc cd_fld_type)
p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"
p_conDeclField (XConDeclField x) = noExtCon x
tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)
tyOpTree (L _ (HsOpTy NoExt l op r)) =
tyOpTree (L _ (HsOpTy NoExtField l op r)) =
OpBranch (tyOpTree l) op (tyOpTree r)
tyOpTree n = OpNode n
@ -235,17 +238,17 @@ p_tyOpTree (OpBranch l op r) = do
tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
tyVarsToTypes = \case
HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
XLHsQTyVars {} -> notImplemented "XLHsQTyVars"
XLHsQTyVars x -> noExtCon x
tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
tyVarToType = \case
UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
KindedTyVar NoExt tvar kind ->
UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar
KindedTyVar NoExtField tvar kind ->
-- Note: we always add parentheses because for whatever reason GHC does
-- not use HsParTy for left-hand sides of declarations. Please see
-- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
-- long as 'tyVarToType' does not get applied to right-hand sides of
-- declarations.
HsParTy NoExt $ noLoc $
HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
XTyVarBndr {} -> notImplemented "XTyVarBndr"
HsParTy NoExtField $ noLoc $
HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
XTyVarBndr x -> noExtCon x

2
src/Ormolu/Utils.hs
View File

@ -22,7 +22,7 @@ import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC
import HsDoc (HsDocString, unpackHDS)
import GHC.Hs.Doc (HsDocString, unpackHDS)
import qualified Outputable as GHC
-- | Combine all source spans from the given list.