mirror of
https://github.com/ilyakooo0/ormolu.git
synced 2024-10-26 19:17:55 +03:00
Update ghc-lib-parser to 8.10.1
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:
parent
57d0d11b37
commit
2c5472944b
2
data/examples/declaration/type/visible-forall-out.hs
Normal file
2
data/examples/declaration/type/visible-forall-out.hs
Normal 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
2
data/examples/declaration/type/visible-forall.hs
Normal 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
|
@ -1,9 +0,0 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
|
||||
foo x y = x -< y
|
||||
|
||||
bar f x =
|
||||
f x -< -- Hello
|
||||
x -- World
|
||||
|
||||
baz x y = x -<< y
|
@ -1,9 +0,0 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
|
||||
foo x y = x -< y
|
||||
|
||||
bar f x
|
||||
= f x -- Hello
|
||||
-< x -- World
|
||||
|
||||
baz x y = x -<< y
|
@ -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
|
||||
)
|
||||
|)
|
@ -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)
|
||||
|)
|
@ -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)
|
||||
)
|
||||
|
@ -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))
|
||||
|
@ -13,6 +13,3 @@ multiline
|
||||
bar
|
||||
baz
|
||||
) = True
|
||||
|
||||
-- https://github.com/tweag/ormolu/issues/343
|
||||
foo = (f -> 4)
|
||||
|
@ -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)
|
||||
|
@ -1,4 +1,4 @@
|
||||
module P where
|
||||
|
||||
import Prelude hiding ((.), id)
|
||||
import qualified Prelude
|
||||
import Prelude hiding ((.), id)
|
||||
|
@ -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;
|
||||
|
@ -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
12
src/GHC.hs
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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'.
|
||||
--
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
Loading…
Reference in New Issue
Block a user