mirror of
https://github.com/ilyakooo0/ormolu.git
synced 2024-10-27 03:28:33 +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) ->
|
proc (y, z) ->
|
||||||
(| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |)
|
(| 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 =
|
bar2 f g h x =
|
||||||
proc (y, z) ->
|
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 =
|
bar3 f g h x =
|
||||||
proc (y, z) ->
|
proc (y, z) ->
|
||||||
(h f . h g) -<
|
( (h f . h g) -<
|
||||||
(y x) . y z
|
(y x) . y z
|
||||||
||| (h g . h f) -<
|
) |||
|
||||||
y z . (y x)
|
( (h g . h f) -<
|
||||||
|
y z . (y x)
|
||||||
|
)
|
||||||
|
@ -4,16 +4,16 @@ bar0 f g h x =
|
|||||||
proc (y, z) ->
|
proc (y, z) ->
|
||||||
(| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)
|
(| 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 =
|
bar2 f g h x =
|
||||||
proc (y, z) ->
|
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 =
|
bar3 f g h x =
|
||||||
proc (y, z) ->
|
proc (y, z) ->
|
||||||
(h f.h g)
|
((h f.h g)
|
||||||
-< (y x).y z
|
-< (y x).y z)
|
||||||
|||
|
|||
|
||||||
(h g . h f)
|
((h g . h f)
|
||||||
-<y z . (y x)
|
-<y z . (y x))
|
||||||
|
@ -13,6 +13,3 @@ multiline
|
|||||||
bar
|
bar
|
||||||
baz
|
baz
|
||||||
) = True
|
) = True
|
||||||
|
|
||||||
-- https://github.com/tweag/ormolu/issues/343
|
|
||||||
foo = (f -> 4)
|
|
||||||
|
@ -10,6 +10,3 @@ g ((f, _), f -> 4) = True
|
|||||||
multiline (t -> Foo
|
multiline (t -> Foo
|
||||||
bar
|
bar
|
||||||
baz) = True
|
baz) = True
|
||||||
|
|
||||||
-- https://github.com/tweag/ormolu/issues/343
|
|
||||||
foo = (f -> 4)
|
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
module P where
|
module P where
|
||||||
|
|
||||||
import Prelude hiding ((.), id)
|
|
||||||
import qualified Prelude
|
import qualified Prelude
|
||||||
|
import Prelude hiding ((.), id)
|
||||||
|
@ -17,10 +17,14 @@ let
|
|||||||
"ormolu" = pkgs.haskell.lib.enableCabalFlag
|
"ormolu" = pkgs.haskell.lib.enableCabalFlag
|
||||||
(super.callCabal2nix "ormolu" source { }) "dev";
|
(super.callCabal2nix "ormolu" source { }) "dev";
|
||||||
# Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want
|
# 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.
|
# too slow.
|
||||||
"ghc-lib-parser" = pkgs.haskell.lib.dontHaddock
|
"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 {
|
ormolize = import ./nix/ormolize {
|
||||||
inherit pkgs;
|
inherit pkgs;
|
||||||
|
@ -68,7 +68,7 @@ library
|
|||||||
, containers >= 0.5 && < 0.7
|
, containers >= 0.5 && < 0.7
|
||||||
, dlist >= 0.8 && < 0.9
|
, dlist >= 0.8 && < 0.9
|
||||||
, exceptions >= 0.6 && < 0.11
|
, 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
|
, mtl >= 2.0 && < 3.0
|
||||||
, syb >= 0.7 && < 0.8
|
, syb >= 0.7 && < 0.8
|
||||||
, text >= 0.2 && < 1.3
|
, text >= 0.2 && < 1.3
|
||||||
@ -149,7 +149,7 @@ executable ormolu
|
|||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
build-depends: base >= 4.12 && < 5.0
|
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
|
, gitrev >= 1.3 && < 1.4
|
||||||
, optparse-applicative >= 0.14 && < 0.16
|
, optparse-applicative >= 0.14 && < 0.16
|
||||||
, ormolu
|
, ormolu
|
||||||
|
12
src/GHC.hs
12
src/GHC.hs
@ -6,16 +6,8 @@ where
|
|||||||
|
|
||||||
import ApiAnnotation as X
|
import ApiAnnotation as X
|
||||||
import BasicTypes as X
|
import BasicTypes as X
|
||||||
import HsBinds as X
|
import GHC.Hs as X
|
||||||
import HsDecls as X
|
import GHC.Hs.Instances 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 Module as X
|
import Module as X
|
||||||
import RdrName as X
|
import RdrName as X
|
||||||
import SrcLoc as X
|
import SrcLoc as X
|
||||||
|
@ -1,5 +1,7 @@
|
|||||||
{-# OPTIONS_GHC -Wno-missing-fields #-}
|
{-# OPTIONS_GHC -Wno-missing-fields #-}
|
||||||
|
|
||||||
|
-- Modified from ghc-lib-api-ext.
|
||||||
|
|
||||||
module GHC.DynFlags
|
module GHC.DynFlags
|
||||||
( baseDynFlags,
|
( baseDynFlags,
|
||||||
)
|
)
|
||||||
@ -8,31 +10,40 @@ where
|
|||||||
import Config
|
import Config
|
||||||
import DynFlags
|
import DynFlags
|
||||||
import Fingerprint
|
import Fingerprint
|
||||||
import Platform
|
import GHC.Platform
|
||||||
|
import ToolSettings
|
||||||
|
|
||||||
-- | Taken from HLint.
|
|
||||||
fakeSettings :: Settings
|
fakeSettings :: Settings
|
||||||
fakeSettings =
|
fakeSettings =
|
||||||
Settings
|
Settings
|
||||||
{ sTargetPlatform = platform,
|
{ sGhcNameVersion =
|
||||||
sPlatformConstants = platformConstants,
|
GhcNameVersion
|
||||||
sProjectVersion = cProjectVersion,
|
{ ghcNameVersion_programName = "ghc",
|
||||||
sProgramName = "ghc",
|
ghcNameVersion_projectVersion = cProjectVersion
|
||||||
sOpt_P_fingerprint = fingerprint0,
|
},
|
||||||
sPgm_F = ""
|
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 :: LlvmConfig
|
||||||
fakeLlvmConfig = ([], [])
|
fakeLlvmConfig = LlvmConfig [] []
|
||||||
|
|
||||||
baseDynFlags :: DynFlags
|
baseDynFlags :: DynFlags
|
||||||
baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
|
baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
|
||||||
|
@ -13,8 +13,8 @@ import Data.Function (on)
|
|||||||
import Data.Generics (gcompare)
|
import Data.Generics (gcompare)
|
||||||
import Data.List (sortBy)
|
import Data.List (sortBy)
|
||||||
import GHC hiding (GhcPs, IE)
|
import GHC hiding (GhcPs, IE)
|
||||||
import HsExtension
|
import GHC.Hs.Extension
|
||||||
import HsImpExp (IE (..))
|
import GHC.Hs.ImpExp (IE (..))
|
||||||
import Ormolu.Utils (notImplemented)
|
import Ormolu.Utils (notImplemented)
|
||||||
|
|
||||||
-- | Sort imports by module name. This also sorts explicit import lists for
|
-- | 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,
|
{ ideclHiding = second (fmap sortLies) <$> ideclHiding,
|
||||||
..
|
..
|
||||||
}
|
}
|
||||||
XImportDecl {} -> notImplemented "XImportDecl"
|
XImportDecl x -> noExtCon x
|
||||||
|
|
||||||
-- | Compare two @'LImportDecl' 'GhcPs'@ things.
|
-- | Compare two @'LImportDecl' 'GhcPs'@ things.
|
||||||
compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
|
compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
|
||||||
@ -51,8 +51,8 @@ sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)
|
|||||||
-- | Sort imports\/exports inside of 'IEThingWith'.
|
-- | Sort imports\/exports inside of 'IEThingWith'.
|
||||||
sortThings :: IE GhcPs -> IE GhcPs
|
sortThings :: IE GhcPs -> IE GhcPs
|
||||||
sortThings = \case
|
sortThings = \case
|
||||||
IEThingWith NoExt x w xs fl ->
|
IEThingWith NoExtField x w xs fl ->
|
||||||
IEThingWith NoExt x w (sortBy (compareIewn `on` unLoc) xs) fl
|
IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl
|
||||||
other -> other
|
other -> other
|
||||||
|
|
||||||
-- | Compare two located imports or exports.
|
-- | Compare two located imports or exports.
|
||||||
@ -62,15 +62,15 @@ compareIE = compareIewn `on` getIewn
|
|||||||
-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
|
-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
|
||||||
getIewn :: IE GhcPs -> IEWrappedName RdrName
|
getIewn :: IE GhcPs -> IEWrappedName RdrName
|
||||||
getIewn = \case
|
getIewn = \case
|
||||||
IEVar NoExt x -> unLoc x
|
IEVar NoExtField x -> unLoc x
|
||||||
IEThingAbs NoExt x -> unLoc x
|
IEThingAbs NoExtField x -> unLoc x
|
||||||
IEThingAll NoExt x -> unLoc x
|
IEThingAll NoExtField x -> unLoc x
|
||||||
IEThingWith NoExt x _ _ _ -> unLoc x
|
IEThingWith NoExtField x _ _ _ -> unLoc x
|
||||||
IEModuleContents NoExt _ -> notImplemented "IEModuleContents"
|
IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
|
||||||
IEGroup NoExt _ _ -> notImplemented "IEGroup"
|
IEGroup NoExtField _ _ -> notImplemented "IEGroup"
|
||||||
IEDoc NoExt _ -> notImplemented "IEDoc"
|
IEDoc NoExtField _ -> notImplemented "IEDoc"
|
||||||
IEDocNamed NoExt _ -> notImplemented "IEDocNamed"
|
IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
|
||||||
XIE NoExt -> notImplemented "XIE"
|
XIE x -> noExtCon x
|
||||||
|
|
||||||
-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
|
-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
|
||||||
compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
|
compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
|
||||||
|
@ -9,14 +9,17 @@ module Ormolu.Parser
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Bag (bagToList)
|
||||||
import qualified CmdLineParser as GHC
|
import qualified CmdLineParser as GHC
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Data.List ((\\), foldl', isPrefixOf)
|
import Data.List ((\\), foldl', isPrefixOf, sortOn)
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
|
import Data.Ord (Down (Down))
|
||||||
import DynFlags as GHC
|
import DynFlags as GHC
|
||||||
|
import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
|
||||||
import qualified FastString as GHC
|
import qualified FastString as GHC
|
||||||
import GHC hiding (IE, UnicodeSyntax)
|
import GHC hiding (IE, UnicodeSyntax)
|
||||||
import GHC.DynFlags (baseDynFlags)
|
import GHC.DynFlags (baseDynFlags)
|
||||||
@ -29,7 +32,6 @@ import Ormolu.Exception
|
|||||||
import Ormolu.Parser.Anns
|
import Ormolu.Parser.Anns
|
||||||
import Ormolu.Parser.CommentStream
|
import Ormolu.Parser.CommentStream
|
||||||
import Ormolu.Parser.Result
|
import Ormolu.Parser.Result
|
||||||
import qualified Outputable as GHC
|
|
||||||
import qualified Panic as GHC
|
import qualified Panic as GHC
|
||||||
import qualified Parser as GHC
|
import qualified Parser as GHC
|
||||||
import qualified StringBuffer as GHC
|
import qualified StringBuffer as GHC
|
||||||
@ -73,20 +75,34 @@ parseModule Config {..} path input' = liftIO $ do
|
|||||||
|| any
|
|| any
|
||||||
(("RecordDotPreprocessor" ==) . moduleNameString)
|
(("RecordDotPreprocessor" ==) . moduleNameString)
|
||||||
(pluginModNames dynFlags)
|
(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
|
r = case runParser GHC.parseModule dynFlags path input of
|
||||||
GHC.PFailed _ ss m ->
|
GHC.PFailed pstate ->
|
||||||
Left (ss, GHC.showSDoc dynFlags m)
|
case pStateErrors pstate of
|
||||||
|
Just err -> Left err
|
||||||
|
Nothing -> error "invariant violation: PFailed does not have an error"
|
||||||
GHC.POk pstate pmod ->
|
GHC.POk pstate pmod ->
|
||||||
let (comments, exts, shebangs) = mkCommentStream extraComments pstate
|
case pStateErrors pstate of
|
||||||
in Right
|
-- Some parse errors (pattern/arrow syntax in expr context)
|
||||||
ParseResult
|
-- do not cause a parse error, but they are replaced with "_"
|
||||||
{ prParsedSource = pmod,
|
-- by the parser and the modified AST is propagated to the
|
||||||
prAnns = mkAnns pstate,
|
-- later stages; but we fail in those cases.
|
||||||
prCommentStream = comments,
|
Just err -> Left err
|
||||||
prExtensions = exts,
|
Nothing ->
|
||||||
prShebangs = shebangs,
|
let (comments, exts, shebangs) = mkCommentStream extraComments pstate
|
||||||
prUseRecordDot = useRecordDot
|
in Right
|
||||||
}
|
ParseResult
|
||||||
|
{ prParsedSource = pmod,
|
||||||
|
prAnns = mkAnns pstate,
|
||||||
|
prCommentStream = comments,
|
||||||
|
prExtensions = exts,
|
||||||
|
prShebangs = shebangs,
|
||||||
|
prUseRecordDot = useRecordDot
|
||||||
|
}
|
||||||
return (warnings, r)
|
return (warnings, r)
|
||||||
|
|
||||||
-- | Extensions that are not enabled automatically and should be activated
|
-- | Extensions that are not enabled automatically and should be activated
|
||||||
@ -223,3 +239,25 @@ parsePragmasIntoDynFlags flags extraOpts filepath str =
|
|||||||
reportErr
|
reportErr
|
||||||
(GHC.handleSourceError reportErr act)
|
(GHC.handleSourceError reportErr act)
|
||||||
reportErr e = return $ Left (show e)
|
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,
|
inci,
|
||||||
located,
|
located,
|
||||||
located',
|
located',
|
||||||
locatedPat,
|
|
||||||
switchLayout,
|
switchLayout,
|
||||||
Layout (..),
|
Layout (..),
|
||||||
vlayout,
|
vlayout,
|
||||||
@ -64,7 +63,6 @@ import Control.Monad
|
|||||||
import Data.Data (Data)
|
import Data.Data (Data)
|
||||||
import Data.List (intersperse)
|
import Data.List (intersperse)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import GHC (Pat (XPat), XXPat)
|
|
||||||
import Ormolu.Printer.Comments
|
import Ormolu.Printer.Comments
|
||||||
import Ormolu.Printer.Internal
|
import Ormolu.Printer.Internal
|
||||||
import Ormolu.Utils (isModule)
|
import Ormolu.Utils (isModule)
|
||||||
@ -111,28 +109,6 @@ located' ::
|
|||||||
R ()
|
R ()
|
||||||
located' = flip located
|
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.
|
-- | 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
|
-- 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
|
-- several elements when there is no corresponding 'Located' wrapper
|
||||||
|
@ -110,29 +110,30 @@ groupDecls (lhdr : xs) =
|
|||||||
|
|
||||||
p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
|
p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
|
||||||
p_hsDecl style = \case
|
p_hsDecl style = \case
|
||||||
TyClD NoExt x -> p_tyClDecl style x
|
TyClD NoExtField x -> p_tyClDecl style x
|
||||||
ValD NoExt x -> p_valDecl x
|
ValD NoExtField x -> p_valDecl x
|
||||||
SigD NoExt x -> p_sigDecl x
|
SigD NoExtField x -> p_sigDecl x
|
||||||
InstD NoExt x -> p_instDecl style x
|
InstD NoExtField x -> p_instDecl style x
|
||||||
DerivD NoExt x -> p_derivDecl x
|
DerivD NoExtField x -> p_derivDecl x
|
||||||
DefD NoExt x -> p_defaultDecl x
|
DefD NoExtField x -> p_defaultDecl x
|
||||||
ForD NoExt x -> p_foreignDecl x
|
ForD NoExtField x -> p_foreignDecl x
|
||||||
WarningD NoExt x -> p_warnDecls x
|
WarningD NoExtField x -> p_warnDecls x
|
||||||
AnnD NoExt x -> p_annDecl x
|
AnnD NoExtField x -> p_annDecl x
|
||||||
RuleD NoExt x -> p_ruleDecls x
|
RuleD NoExtField x -> p_ruleDecls x
|
||||||
SpliceD NoExt x -> p_spliceDecl x
|
SpliceD NoExtField x -> p_spliceDecl x
|
||||||
DocD NoExt docDecl ->
|
DocD NoExtField docDecl ->
|
||||||
case docDecl of
|
case docDecl of
|
||||||
DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
|
DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
|
||||||
DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
|
DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
|
||||||
DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
|
DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
|
||||||
DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
|
DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
|
||||||
RoleAnnotD NoExt x -> p_roleAnnot x
|
RoleAnnotD NoExtField x -> p_roleAnnot x
|
||||||
XHsDecl _ -> notImplemented "XHsDecl"
|
KindSigD NoExtField _ -> notImplemented "StandaloneKindSignatures"
|
||||||
|
XHsDecl x -> noExtCon x
|
||||||
|
|
||||||
p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
|
p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
|
||||||
p_tyClDecl style = \case
|
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
|
SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
|
||||||
DataDecl {..} ->
|
DataDecl {..} ->
|
||||||
p_dataDecl
|
p_dataDecl
|
||||||
@ -153,19 +154,19 @@ p_tyClDecl style = \case
|
|||||||
tcdATs
|
tcdATs
|
||||||
tcdATDefs
|
tcdATDefs
|
||||||
tcdDocs
|
tcdDocs
|
||||||
XTyClDecl {} -> notImplemented "XTyClDecl"
|
XTyClDecl x -> noExtCon x
|
||||||
|
|
||||||
p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
|
p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
|
||||||
p_instDecl style = \case
|
p_instDecl style = \case
|
||||||
ClsInstD NoExt x -> p_clsInstDecl x
|
ClsInstD NoExtField x -> p_clsInstDecl x
|
||||||
TyFamInstD NoExt x -> p_tyFamInstDecl style x
|
TyFamInstD NoExtField x -> p_tyFamInstDecl style x
|
||||||
DataFamInstD NoExt x -> p_dataFamInstDecl style x
|
DataFamInstD NoExtField x -> p_dataFamInstDecl style x
|
||||||
XInstDecl _ -> notImplemented "XInstDecl"
|
XInstDecl x -> noExtCon x
|
||||||
|
|
||||||
p_derivDecl :: DerivDecl GhcPs -> R ()
|
p_derivDecl :: DerivDecl GhcPs -> R ()
|
||||||
p_derivDecl = \case
|
p_derivDecl = \case
|
||||||
d@DerivDecl {..} -> p_standaloneDerivDecl d
|
d@DerivDecl {..} -> p_standaloneDerivDecl d
|
||||||
XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
|
XDerivDecl x -> noExtCon x
|
||||||
|
|
||||||
-- | Determine if these declarations should be grouped together.
|
-- | Determine if these declarations should be grouped together.
|
||||||
groupedDecls ::
|
groupedDecls ::
|
||||||
@ -225,13 +226,13 @@ pattern
|
|||||||
Pattern,
|
Pattern,
|
||||||
DataDeclaration ::
|
DataDeclaration ::
|
||||||
RdrName -> HsDecl GhcPs
|
RdrName -> HsDecl GhcPs
|
||||||
pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
|
pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _)
|
||||||
pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
|
pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _)
|
||||||
pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
|
pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _)
|
||||||
pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)
|
pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _)
|
||||||
pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)
|
pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _)
|
||||||
pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))
|
pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _))
|
||||||
pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
|
pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (L _ n) _ _ _)
|
||||||
|
|
||||||
-- Declarations which can refer to multiple names
|
-- Declarations which can refer to multiple names
|
||||||
|
|
||||||
@ -249,51 +250,51 @@ pattern PatternSignature n <- (patSigRdrNames -> Just n)
|
|||||||
pattern WarningPragma n <- (warnSigRdrNames -> Just n)
|
pattern WarningPragma n <- (warnSigRdrNames -> Just n)
|
||||||
|
|
||||||
pattern DocNext, DocPrev :: HsDecl GhcPs
|
pattern DocNext, DocPrev :: HsDecl GhcPs
|
||||||
pattern DocNext <- (DocD NoExt (DocCommentNext _))
|
pattern DocNext <- (DocD NoExtField (DocCommentNext _))
|
||||||
pattern DocPrev <- (DocD NoExt (DocCommentPrev _))
|
pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))
|
||||||
|
|
||||||
sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
||||||
sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns
|
sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns
|
||||||
sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns
|
sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns
|
||||||
sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
|
sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
|
||||||
sigRdrNames _ = Nothing
|
sigRdrNames _ = Nothing
|
||||||
|
|
||||||
defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
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
|
defSigRdrNames _ = Nothing
|
||||||
|
|
||||||
funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
||||||
funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]
|
funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]
|
||||||
funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n
|
funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n
|
||||||
funRdrNames _ = Nothing
|
funRdrNames _ = Nothing
|
||||||
|
|
||||||
patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
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
|
patSigRdrNames _ = Nothing
|
||||||
|
|
||||||
warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
||||||
warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case
|
warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case
|
||||||
L _ (Warning NoExt ns _) -> map unLoc ns
|
L _ (Warning NoExtField ns _) -> map unLoc ns
|
||||||
L _ (XWarnDecl NoExt) -> []
|
L _ (XWarnDecl x) -> noExtCon x
|
||||||
warnSigRdrNames _ = Nothing
|
warnSigRdrNames _ = Nothing
|
||||||
|
|
||||||
patBindNames :: Pat GhcPs -> [RdrName]
|
patBindNames :: Pat GhcPs -> [RdrName]
|
||||||
patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps
|
patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps
|
||||||
patBindNames (VarPat NoExt (L _ n)) = [n]
|
patBindNames (VarPat NoExtField (L _ n)) = [n]
|
||||||
patBindNames (WildPat NoExt) = []
|
patBindNames (WildPat NoExtField) = []
|
||||||
patBindNames (LazyPat NoExt p) = patBindNames p
|
patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p
|
||||||
patBindNames (BangPat NoExt p) = patBindNames p
|
patBindNames (BangPat NoExtField (L _ p)) = patBindNames p
|
||||||
patBindNames (ParPat NoExt p) = patBindNames p
|
patBindNames (ParPat NoExtField (L _ p)) = patBindNames p
|
||||||
patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps
|
patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps
|
||||||
patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p
|
patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p
|
||||||
patBindNames (SumPat NoExt p _ _) = patBindNames p
|
patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p
|
||||||
patBindNames (ViewPat NoExt _ p) = patBindNames p
|
patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p
|
||||||
patBindNames (SplicePat NoExt _) = []
|
patBindNames (SplicePat NoExtField _) = []
|
||||||
patBindNames (LitPat NoExt _) = []
|
patBindNames (LitPat NoExtField _) = []
|
||||||
patBindNames (SigPat _ p _) = patBindNames p
|
patBindNames (SigPat _ (L _ p) _) = patBindNames p
|
||||||
patBindNames (NPat NoExt _ _ _) = []
|
patBindNames (NPat NoExtField _ _ _) = []
|
||||||
patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]
|
patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n]
|
||||||
patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
|
patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
|
||||||
patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer
|
patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer
|
||||||
patBindNames (CoPat NoExt _ p _) = patBindNames p
|
patBindNames (CoPat NoExtField _ p _) = patBindNames p
|
||||||
patBindNames (XPat p) = patBindNames (unLoc p)
|
patBindNames (XPat x) = noExtCon x
|
||||||
|
@ -10,15 +10,14 @@ import GHC
|
|||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import Ormolu.Printer.Meat.Declaration.Value
|
import Ormolu.Printer.Meat.Declaration.Value
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_annDecl :: AnnDecl GhcPs -> R ()
|
p_annDecl :: AnnDecl GhcPs -> R ()
|
||||||
p_annDecl = \case
|
p_annDecl = \case
|
||||||
HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do
|
HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do
|
||||||
p_annProv annProv
|
p_annProv annProv
|
||||||
breakpoint
|
breakpoint
|
||||||
located expr p_hsExpr
|
located expr p_hsExpr
|
||||||
XAnnDecl {} -> notImplemented "XAnnDecl"
|
XAnnDecl x -> noExtCon x
|
||||||
|
|
||||||
p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
|
p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
|
||||||
p_annProv = \case
|
p_annProv = \case
|
||||||
|
@ -18,7 +18,6 @@ import Ormolu.Printer.Combinators
|
|||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
|
import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
|
||||||
import Ormolu.Printer.Meat.Type
|
import Ormolu.Printer.Meat.Type
|
||||||
import Ormolu.Utils
|
|
||||||
import RdrName (RdrName (..))
|
import RdrName (RdrName (..))
|
||||||
|
|
||||||
p_classDecl ::
|
p_classDecl ::
|
||||||
@ -30,7 +29,7 @@ p_classDecl ::
|
|||||||
[LSig GhcPs] ->
|
[LSig GhcPs] ->
|
||||||
LHsBinds GhcPs ->
|
LHsBinds GhcPs ->
|
||||||
[LFamilyDecl GhcPs] ->
|
[LFamilyDecl GhcPs] ->
|
||||||
[LTyFamDefltEqn GhcPs] ->
|
[LTyFamDefltDecl GhcPs] ->
|
||||||
[LDocDecl] ->
|
[LDocDecl] ->
|
||||||
R ()
|
R ()
|
||||||
p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do
|
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
|
-- location order. This happens because different declarations are stored
|
||||||
-- in different lists. Consequently, to get all the declarations in proper
|
-- in different lists. Consequently, to get all the declarations in proper
|
||||||
-- order, they need to be manually sorted.
|
-- order, they need to be manually sorted.
|
||||||
sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs
|
sigs = (getLoc &&& fmap (SigD NoExtField)) <$> csigs
|
||||||
vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs
|
vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cdefs
|
||||||
tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats
|
tyFams = (getLoc &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats
|
||||||
docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
|
docs = (getLoc &&& fmap (DocD NoExtField)) <$> cdocs
|
||||||
tyFamDefs =
|
tyFamDefs =
|
||||||
( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
|
( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
|
||||||
)
|
)
|
||||||
<$> catdefs
|
<$> catdefs
|
||||||
allDecls =
|
allDecls =
|
||||||
@ -70,7 +69,7 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d
|
|||||||
unless (null allDecls) $ do
|
unless (null allDecls) $ do
|
||||||
breakpoint -- Ensure whitespace is added after where clause.
|
breakpoint -- Ensure whitespace is added after where clause.
|
||||||
inci (p_hsDeclsRespectGrouping Associated allDecls)
|
inci (p_hsDeclsRespectGrouping Associated allDecls)
|
||||||
p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars"
|
p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c
|
||||||
|
|
||||||
p_classContext :: LHsContext GhcPs -> R ()
|
p_classContext :: LHsContext GhcPs -> R ()
|
||||||
p_classContext ctx = unless (null (unLoc ctx)) $ do
|
p_classContext ctx = unless (null (unLoc ctx)) $ do
|
||||||
@ -97,13 +96,6 @@ p_funDep (before, after) = do
|
|||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- Helpers
|
-- 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 :: LexicalFixity -> Bool
|
||||||
isInfix = \case
|
isInfix = \case
|
||||||
Infix -> True
|
Infix -> True
|
||||||
|
@ -76,7 +76,7 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
|
|||||||
unless (null $ unLoc dd_derivs) breakpoint
|
unless (null $ unLoc dd_derivs) breakpoint
|
||||||
inci . located dd_derivs $ \xs ->
|
inci . located dd_derivs $ \xs ->
|
||||||
sep newline (located' p_hsDerivingClause) 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 :: ConDecl GhcPs -> R ()
|
||||||
p_conDecl = \case
|
p_conDecl = \case
|
||||||
@ -106,7 +106,7 @@ p_conDecl = \case
|
|||||||
else breakpoint
|
else breakpoint
|
||||||
interArgBreak
|
interArgBreak
|
||||||
when (unLoc con_forall) $ do
|
when (unLoc con_forall) $ do
|
||||||
p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)
|
p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars)
|
||||||
interArgBreak
|
interArgBreak
|
||||||
forM_ con_mb_cxt p_lhsContext
|
forM_ con_mb_cxt p_lhsContext
|
||||||
case con_args of
|
case con_args of
|
||||||
@ -134,7 +134,7 @@ p_conDecl = \case
|
|||||||
<> conArgsSpans con_args
|
<> conArgsSpans con_args
|
||||||
switchLayout conDeclSpn $ do
|
switchLayout conDeclSpn $ do
|
||||||
when (unLoc con_forall) $ do
|
when (unLoc con_forall) $ do
|
||||||
p_forallBndrs p_hsTyVarBndr con_ex_tvs
|
p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs
|
||||||
breakpoint
|
breakpoint
|
||||||
forM_ con_mb_cxt p_lhsContext
|
forM_ con_mb_cxt p_lhsContext
|
||||||
case con_args of
|
case con_args of
|
||||||
@ -153,7 +153,7 @@ p_conDecl = \case
|
|||||||
p_rdrName con_name
|
p_rdrName con_name
|
||||||
space
|
space
|
||||||
located y p_hsType
|
located y p_hsType
|
||||||
XConDecl NoExt -> notImplemented "XConDecl"
|
XConDecl x -> noExtCon x
|
||||||
|
|
||||||
conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
|
conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
|
||||||
conArgsSpans = \case
|
conArgsSpans = \case
|
||||||
@ -167,7 +167,7 @@ conArgsSpans = \case
|
|||||||
conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
|
conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
|
||||||
conTyVarsSpans = \case
|
conTyVarsSpans = \case
|
||||||
HsQTvs {..} -> getLoc <$> hsq_explicit
|
HsQTvs {..} -> getLoc <$> hsq_explicit
|
||||||
XLHsQTyVars NoExt -> []
|
XLHsQTyVars x -> noExtCon x
|
||||||
|
|
||||||
p_lhsContext ::
|
p_lhsContext ::
|
||||||
LHsContext GhcPs ->
|
LHsContext GhcPs ->
|
||||||
@ -225,9 +225,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
|
|||||||
txt "via"
|
txt "via"
|
||||||
space
|
space
|
||||||
located hsib_body p_hsType
|
located hsib_body p_hsType
|
||||||
ViaStrategy (XHsImplicitBndrs NoExt) ->
|
ViaStrategy (XHsImplicitBndrs x) ->
|
||||||
notImplemented "XHsImplicitBndrs"
|
noExtCon x
|
||||||
p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"
|
p_hsDerivingClause (XHsDerivingClause x) = noExtCon x
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- Helpers
|
-- Helpers
|
||||||
|
@ -9,13 +9,12 @@ where
|
|||||||
import GHC
|
import GHC
|
||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Type
|
import Ormolu.Printer.Meat.Type
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_defaultDecl :: DefaultDecl GhcPs -> R ()
|
p_defaultDecl :: DefaultDecl GhcPs -> R ()
|
||||||
p_defaultDecl = \case
|
p_defaultDecl = \case
|
||||||
DefaultDecl NoExt ts -> do
|
DefaultDecl NoExtField ts -> do
|
||||||
txt "default"
|
txt "default"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci . parens N . sitcc $
|
inci . parens N . sitcc $
|
||||||
sep (comma >> breakpoint) (sitcc . located' p_hsType) ts
|
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.Combinators
|
||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import Ormolu.Printer.Meat.Declaration.Signature
|
import Ormolu.Printer.Meat.Declaration.Signature
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_foreignDecl :: ForeignDecl GhcPs -> R ()
|
p_foreignDecl :: ForeignDecl GhcPs -> R ()
|
||||||
p_foreignDecl = \case
|
p_foreignDecl = \case
|
||||||
@ -25,7 +24,7 @@ p_foreignDecl = \case
|
|||||||
fd@ForeignExport {fd_fe} -> do
|
fd@ForeignExport {fd_fe} -> do
|
||||||
p_foreignExport fd_fe
|
p_foreignExport fd_fe
|
||||||
p_foreignTypeSig fd
|
p_foreignTypeSig fd
|
||||||
XForeignDecl {} -> notImplemented "XForeignDecl"
|
XForeignDecl x -> noExtCon x
|
||||||
|
|
||||||
-- | Printer for the last part of an import\/export, which is function name
|
-- | Printer for the last part of an import\/export, which is function name
|
||||||
-- and type signature.
|
-- and type signature.
|
||||||
@ -39,7 +38,7 @@ p_foreignTypeSig fd = do
|
|||||||
]
|
]
|
||||||
$ do
|
$ do
|
||||||
p_rdrName (fd_name fd)
|
p_rdrName (fd_name fd)
|
||||||
p_typeAscription (HsWC NoExt (fd_sig_ty fd))
|
p_typeAscription (HsWC NoExtField (fd_sig_ty fd))
|
||||||
|
|
||||||
-- | Printer for 'ForeignImport'.
|
-- | Printer for 'ForeignImport'.
|
||||||
--
|
--
|
||||||
|
@ -56,8 +56,8 @@ p_standaloneDerivDecl DerivDecl {..} = do
|
|||||||
inci (located hsib_body p_hsType)
|
inci (located hsib_body p_hsType)
|
||||||
breakpoint
|
breakpoint
|
||||||
instTypes True
|
instTypes True
|
||||||
ViaStrategy (XHsImplicitBndrs NoExt) ->
|
ViaStrategy (XHsImplicitBndrs x) ->
|
||||||
notImplemented "XHsImplicitBndrs"
|
noExtCon x
|
||||||
p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
|
p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
|
||||||
|
|
||||||
p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
|
p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
|
||||||
@ -70,14 +70,14 @@ p_clsInstDecl = \case
|
|||||||
-- location order. This happens because different declarations are stored in
|
-- location order. This happens because different declarations are stored in
|
||||||
-- different lists. Consequently, to get all the declarations in proper
|
-- different lists. Consequently, to get all the declarations in proper
|
||||||
-- order, they need to be manually sorted.
|
-- order, they need to be manually sorted.
|
||||||
let sigs = (getLoc &&& fmap (SigD NoExt)) <$> cid_sigs
|
let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs
|
||||||
vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
|
vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds
|
||||||
tyFamInsts =
|
tyFamInsts =
|
||||||
( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
|
( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
|
||||||
)
|
)
|
||||||
<$> cid_tyfam_insts
|
<$> cid_tyfam_insts
|
||||||
dataFamInsts =
|
dataFamInsts =
|
||||||
( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
|
( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)
|
||||||
)
|
)
|
||||||
<$> cid_datafam_insts
|
<$> cid_datafam_insts
|
||||||
allDecls =
|
allDecls =
|
||||||
@ -96,8 +96,8 @@ p_clsInstDecl = \case
|
|||||||
-- Ensure whitespace is added after where clause.
|
-- Ensure whitespace is added after where clause.
|
||||||
breakpoint
|
breakpoint
|
||||||
dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
|
dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
|
||||||
XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"
|
XHsImplicitBndrs x -> noExtCon x
|
||||||
XClsInstDecl NoExt -> notImplemented "XClsInstDecl"
|
XClsInstDecl x -> noExtCon x
|
||||||
|
|
||||||
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
|
p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
|
||||||
p_tyFamInstDecl style = \case
|
p_tyFamInstDecl style = \case
|
||||||
|
@ -12,14 +12,13 @@ import CoAxiom
|
|||||||
import GHC
|
import GHC
|
||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import Ormolu.Utils
|
|
||||||
import RdrName (RdrName (..))
|
import RdrName (RdrName (..))
|
||||||
import SrcLoc (Located)
|
import SrcLoc (Located)
|
||||||
|
|
||||||
p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
|
p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
|
||||||
p_roleAnnot = \case
|
p_roleAnnot = \case
|
||||||
RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns
|
RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns
|
||||||
XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"
|
XRoleAnnotDecl x -> noExtCon x
|
||||||
|
|
||||||
p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
|
p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
|
||||||
p_roleAnnot' l_name anns = do
|
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.Signature
|
||||||
import Ormolu.Printer.Meat.Declaration.Value
|
import Ormolu.Printer.Meat.Declaration.Value
|
||||||
import Ormolu.Printer.Meat.Type
|
import Ormolu.Printer.Meat.Type
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_ruleDecls :: RuleDecls GhcPs -> R ()
|
p_ruleDecls :: RuleDecls GhcPs -> R ()
|
||||||
p_ruleDecls = \case
|
p_ruleDecls = \case
|
||||||
HsRules NoExt _ xs ->
|
HsRules NoExtField _ xs ->
|
||||||
pragma "RULES" . sitcc $
|
pragma "RULES" . sitcc $
|
||||||
sep breakpoint (sitcc . located' p_ruleDecl) xs
|
sep breakpoint (sitcc . located' p_ruleDecl) xs
|
||||||
XRuleDecls NoExt -> notImplemented "XRuleDecls"
|
XRuleDecls x -> noExtCon x
|
||||||
|
|
||||||
p_ruleDecl :: RuleDecl GhcPs -> R ()
|
p_ruleDecl :: RuleDecl GhcPs -> R ()
|
||||||
p_ruleDecl = \case
|
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
|
located ruleName p_ruleName
|
||||||
space
|
space
|
||||||
p_activation activation
|
p_activation activation
|
||||||
@ -33,13 +32,13 @@ p_ruleDecl = \case
|
|||||||
case tyvars of
|
case tyvars of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just xs -> do
|
Just xs -> do
|
||||||
p_forallBndrs p_hsTyVarBndr xs
|
p_forallBndrs ForallInvis p_hsTyVarBndr xs
|
||||||
space
|
space
|
||||||
-- It appears that there is no way to tell if there was an empty forall
|
-- 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
|
-- in the input or no forall at all. We do not want to add redundant
|
||||||
-- foralls, so let's just skip the empty ones.
|
-- foralls, so let's just skip the empty ones.
|
||||||
unless (null ruleBndrs) $
|
unless (null ruleBndrs) $
|
||||||
p_forallBndrs p_ruleBndr ruleBndrs
|
p_forallBndrs ForallInvis p_ruleBndr ruleBndrs
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ do
|
inci $ do
|
||||||
located lhs p_hsExpr
|
located lhs p_hsExpr
|
||||||
@ -48,15 +47,15 @@ p_ruleDecl = \case
|
|||||||
inci $ do
|
inci $ do
|
||||||
breakpoint
|
breakpoint
|
||||||
located rhs p_hsExpr
|
located rhs p_hsExpr
|
||||||
XRuleDecl NoExt -> notImplemented "XRuleDecl"
|
XRuleDecl x -> noExtCon x
|
||||||
|
|
||||||
p_ruleName :: (SourceText, RuleName) -> R ()
|
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 :: RuleBndr GhcPs -> R ()
|
||||||
p_ruleBndr = \case
|
p_ruleBndr = \case
|
||||||
RuleBndr NoExt x -> p_rdrName x
|
RuleBndr NoExtField x -> p_rdrName x
|
||||||
RuleBndrSig NoExt x hswc -> parens N $ do
|
RuleBndrSig NoExtField x hswc -> parens N $ do
|
||||||
p_rdrName x
|
p_rdrName x
|
||||||
p_typeAscription hswc
|
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 :: Sig GhcPs -> R ()
|
||||||
p_sigDecl = \case
|
p_sigDecl = \case
|
||||||
TypeSig NoExt names hswc -> p_typeSig True names hswc
|
TypeSig NoExtField names hswc -> p_typeSig True names hswc
|
||||||
PatSynSig NoExt names hsib -> p_patSynSig names hsib
|
PatSynSig NoExtField names hsib -> p_patSynSig names hsib
|
||||||
ClassOpSig NoExt def names hsib -> p_classOpSig def names hsib
|
ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib
|
||||||
FixSig NoExt sig -> p_fixSig sig
|
FixSig NoExtField sig -> p_fixSig sig
|
||||||
InlineSig NoExt name inlinePragma -> p_inlineSig name inlinePragma
|
InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma
|
||||||
SpecSig NoExt name ts inlinePragma -> p_specSig name ts inlinePragma
|
SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma
|
||||||
SpecInstSig NoExt _ hsib -> p_specInstSig hsib
|
SpecInstSig NoExtField _ hsib -> p_specInstSig hsib
|
||||||
MinimalSig NoExt _ booleanFormula -> p_minimalSig booleanFormula
|
MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula
|
||||||
CompleteMatchSig NoExt _sourceText cs ty -> p_completeSig cs ty
|
CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty
|
||||||
SCCFunSig NoExt _ name literal -> p_sccSig name literal
|
SCCFunSig NoExtField _ name literal -> p_sccSig name literal
|
||||||
_ -> notImplemented "certain types of signature declarations"
|
_ -> notImplemented "certain types of signature declarations"
|
||||||
|
|
||||||
p_typeSig ::
|
p_typeSig ::
|
||||||
@ -65,7 +65,7 @@ p_typeAscription HsWC {..} = do
|
|||||||
then newline
|
then newline
|
||||||
else breakpoint
|
else breakpoint
|
||||||
located t p_hsType
|
located t p_hsType
|
||||||
p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"
|
p_typeAscription (XHsWildCardBndrs x) = noExtCon x
|
||||||
|
|
||||||
p_patSynSig ::
|
p_patSynSig ::
|
||||||
[Located RdrName] ->
|
[Located RdrName] ->
|
||||||
@ -73,7 +73,7 @@ p_patSynSig ::
|
|||||||
R ()
|
R ()
|
||||||
p_patSynSig names hsib = do
|
p_patSynSig names hsib = do
|
||||||
txt "pattern"
|
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
|
if length names > 1
|
||||||
then breakpoint >> inci body
|
then breakpoint >> inci body
|
||||||
else space >> body
|
else space >> body
|
||||||
@ -88,13 +88,13 @@ p_classOpSig ::
|
|||||||
R ()
|
R ()
|
||||||
p_classOpSig def names hsib = do
|
p_classOpSig def names hsib = do
|
||||||
when def (txt "default" >> space)
|
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 ::
|
p_fixSig ::
|
||||||
FixitySig GhcPs ->
|
FixitySig GhcPs ->
|
||||||
R ()
|
R ()
|
||||||
p_fixSig = \case
|
p_fixSig = \case
|
||||||
FixitySig NoExt names (Fixity _ n dir) -> do
|
FixitySig NoExtField names (Fixity _ n dir) -> do
|
||||||
txt $ case dir of
|
txt $ case dir of
|
||||||
InfixL -> "infixl"
|
InfixL -> "infixl"
|
||||||
InfixR -> "infixr"
|
InfixR -> "infixr"
|
||||||
@ -103,7 +103,7 @@ p_fixSig = \case
|
|||||||
atom n
|
atom n
|
||||||
space
|
space
|
||||||
sitcc $ sep (comma >> breakpoint) p_rdrName names
|
sitcc $ sep (comma >> breakpoint) p_rdrName names
|
||||||
XFixitySig NoExt -> notImplemented "XFixitySig"
|
XFixitySig x -> noExtCon x
|
||||||
|
|
||||||
p_inlineSig ::
|
p_inlineSig ::
|
||||||
-- | Name
|
-- | Name
|
||||||
|
@ -8,9 +8,8 @@ where
|
|||||||
import GHC
|
import GHC
|
||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
|
import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_spliceDecl :: SpliceDecl GhcPs -> R ()
|
p_spliceDecl :: SpliceDecl GhcPs -> R ()
|
||||||
p_spliceDecl = \case
|
p_spliceDecl = \case
|
||||||
SpliceDecl NoExt splice _explicit -> located splice p_hsSplice
|
SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice
|
||||||
XSpliceDecl {} -> notImplemented "XSpliceDecl"
|
XSpliceDecl x -> noExtCon x
|
||||||
|
@ -11,7 +11,6 @@ import GHC
|
|||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import Ormolu.Printer.Meat.Type
|
import Ormolu.Printer.Meat.Type
|
||||||
import Ormolu.Utils (notImplemented)
|
|
||||||
import RdrName (RdrName (..))
|
import RdrName (RdrName (..))
|
||||||
import SrcLoc (Located)
|
import SrcLoc (Located)
|
||||||
|
|
||||||
@ -38,4 +37,4 @@ p_synDecl name fixity HsQTvs {..} t = do
|
|||||||
txt "="
|
txt "="
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located t p_hsType)
|
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
|
sep newline (located' (inci . p_tyFamInstEqn)) eqs
|
||||||
p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =
|
p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =
|
||||||
notImplemented "XLHsQTyVars"
|
notImplemented "XLHsQTyVars"
|
||||||
p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
|
p_famDecl _ (XFamilyDecl x) = noExtCon x
|
||||||
|
|
||||||
p_familyResultSigL ::
|
p_familyResultSigL ::
|
||||||
Located (FamilyResultSig GhcPs) ->
|
Located (FamilyResultSig GhcPs) ->
|
||||||
@ -65,17 +65,17 @@ p_familyResultSigL ::
|
|||||||
p_familyResultSigL l =
|
p_familyResultSigL l =
|
||||||
case l of
|
case l of
|
||||||
L _ a -> case a of
|
L _ a -> case a of
|
||||||
NoSig NoExt -> Nothing
|
NoSig NoExtField -> Nothing
|
||||||
KindSig NoExt k -> Just $ do
|
KindSig NoExtField k -> Just $ do
|
||||||
txt "::"
|
txt "::"
|
||||||
breakpoint
|
breakpoint
|
||||||
located k p_hsType
|
located k p_hsType
|
||||||
TyVarSig NoExt bndr -> Just $ do
|
TyVarSig NoExtField bndr -> Just $ do
|
||||||
txt "="
|
txt "="
|
||||||
breakpoint
|
breakpoint
|
||||||
located bndr p_hsTyVarBndr
|
located bndr p_hsTyVarBndr
|
||||||
XFamilyResultSig NoExt ->
|
XFamilyResultSig x ->
|
||||||
notImplemented "XFamilyResultSig"
|
noExtCon x
|
||||||
|
|
||||||
p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
|
p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
|
||||||
p_injectivityAnn (InjectivityAnn a bs) = do
|
p_injectivityAnn (InjectivityAnn a bs) = do
|
||||||
@ -92,7 +92,7 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
|
|||||||
case feqn_bndrs of
|
case feqn_bndrs of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just bndrs -> do
|
Just bndrs -> do
|
||||||
p_forallBndrs p_hsTyVarBndr bndrs
|
p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
|
||||||
breakpoint
|
breakpoint
|
||||||
(if null feqn_bndrs then id else inci) $ do
|
(if null feqn_bndrs then id else inci) $ do
|
||||||
let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
|
let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
|
||||||
@ -106,8 +106,8 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
|
|||||||
txt "="
|
txt "="
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located feqn_rhs p_hsType)
|
inci (located feqn_rhs p_hsType)
|
||||||
p_tyFamInstEqn HsIB {hsib_body = XFamEqn {}} = notImplemented "HsIB XFamEqn"
|
p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
|
||||||
p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
|
p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- Helpers
|
-- Helpers
|
||||||
|
@ -1,6 +1,7 @@
|
|||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Ormolu.Printer.Meat.Declaration.Value
|
module Ormolu.Printer.Meat.Declaration.Value
|
||||||
( p_valDecl,
|
( p_valDecl,
|
||||||
@ -65,12 +66,12 @@ data Placement
|
|||||||
|
|
||||||
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
|
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
|
||||||
p_valDecl = \case
|
p_valDecl = \case
|
||||||
FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
|
FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches
|
||||||
PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
|
PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
|
||||||
VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
|
VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
|
||||||
AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
|
AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
|
||||||
PatSynBind NoExt psb -> p_patSynBind psb
|
PatSynBind NoExtField psb -> p_patSynBind psb
|
||||||
XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
|
XHsBindsLR x -> noExtCon x
|
||||||
|
|
||||||
p_funBind ::
|
p_funBind ::
|
||||||
Located RdrName ->
|
Located RdrName ->
|
||||||
@ -114,8 +115,8 @@ p_matchGroup' placer render style MG {..} = do
|
|||||||
(matchStrictness m)
|
(matchStrictness m)
|
||||||
m_pats
|
m_pats
|
||||||
m_grhss
|
m_grhss
|
||||||
p_Match _ = notImplemented "XMatch"
|
p_Match (XMatch x) = noExtCon x
|
||||||
p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
|
p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x
|
||||||
|
|
||||||
-- | Function id obtained through pattern matching on 'FunBind' should not
|
-- | Function id obtained through pattern matching on 'FunBind' should not
|
||||||
-- be used to print the actual equations because the different ‘RdrNames’
|
-- 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
|
then id
|
||||||
else inci
|
else inci
|
||||||
switchLayout [combinedSpans] $ do
|
switchLayout [combinedSpans] $ do
|
||||||
let stdCase = sep breakpoint p_pat m_pats
|
let stdCase = sep breakpoint (located' p_pat) m_pats
|
||||||
case style of
|
case style of
|
||||||
Function name ->
|
Function name ->
|
||||||
p_infixDefHelper
|
p_infixDefHelper
|
||||||
isInfix
|
isInfix
|
||||||
inci'
|
inci'
|
||||||
(p_rdrName name)
|
(p_rdrName name)
|
||||||
(p_pat <$> m_pats)
|
(located' p_pat <$> m_pats)
|
||||||
PatternBind -> stdCase
|
PatternBind -> stdCase
|
||||||
Case -> stdCase
|
Case -> stdCase
|
||||||
Lambda -> do
|
Lambda -> do
|
||||||
@ -266,7 +267,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
|
|||||||
switchLayout [patGrhssSpan] $
|
switchLayout [patGrhssSpan] $
|
||||||
placeHanging placement p_body
|
placeHanging placement p_body
|
||||||
inci p_where
|
inci p_where
|
||||||
p_match' _ _ _ _ _ _ XGRHSs {} = notImplemented "XGRHSs"
|
p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
|
||||||
|
|
||||||
p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
|
p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
|
||||||
p_grhs = p_grhs' exprPlacement p_hsExpr
|
p_grhs = p_grhs' exprPlacement p_hsExpr
|
||||||
@ -280,7 +281,7 @@ p_grhs' ::
|
|||||||
GroupStyle ->
|
GroupStyle ->
|
||||||
GRHS GhcPs (Located body) ->
|
GRHS GhcPs (Located body) ->
|
||||||
R ()
|
R ()
|
||||||
p_grhs' placer render style (GRHS NoExt guards body) =
|
p_grhs' placer render style (GRHS NoExtField guards body) =
|
||||||
case guards of
|
case guards of
|
||||||
[] -> p_body
|
[] -> p_body
|
||||||
xs -> do
|
xs -> do
|
||||||
@ -305,11 +306,11 @@ p_grhs' placer render style (GRHS NoExt guards body) =
|
|||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
|
Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
|
||||||
p_body = located body render
|
p_body = located body render
|
||||||
p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
|
p_grhs' _ _ _ (XGRHS x) = noExtCon x
|
||||||
|
|
||||||
p_hsCmd :: HsCmd GhcPs -> R ()
|
p_hsCmd :: HsCmd GhcPs -> R ()
|
||||||
p_hsCmd = \case
|
p_hsCmd = \case
|
||||||
HsCmdArrApp NoExt body input arrType _ -> do
|
HsCmdArrApp NoExtField body input arrType _ -> do
|
||||||
located body p_hsExpr
|
located body p_hsExpr
|
||||||
space
|
space
|
||||||
case arrType of
|
case arrType of
|
||||||
@ -317,42 +318,42 @@ p_hsCmd = \case
|
|||||||
HsHigherOrderApp -> txt "-<<"
|
HsHigherOrderApp -> txt "-<<"
|
||||||
placeHanging (exprPlacement (unLoc input)) $
|
placeHanging (exprPlacement (unLoc input)) $
|
||||||
located input p_hsExpr
|
located input p_hsExpr
|
||||||
HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do
|
HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do
|
||||||
located form p_hsExpr
|
located form p_hsExpr
|
||||||
unless (null cmds) $ do
|
unless (null cmds) $ do
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
|
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
|
located left p_hsCmdTop
|
||||||
space
|
space
|
||||||
located form p_hsExpr
|
located form p_hsExpr
|
||||||
placeHanging (cmdTopPlacement (unLoc right)) $
|
placeHanging (cmdTopPlacement (unLoc right)) $
|
||||||
located right p_hsCmdTop
|
located right p_hsCmdTop
|
||||||
HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
|
HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
|
||||||
HsCmdApp {} ->
|
HsCmdApp {} ->
|
||||||
-- XXX Does this ever occur in the syntax tree? It does not seem like it
|
-- 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.
|
-- does. Open an issue and ping @yumiova if this ever occurs in output.
|
||||||
notImplemented "HsCmdApp"
|
notImplemented "HsCmdApp"
|
||||||
HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
|
HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
|
||||||
HsCmdPar NoExt c -> parens N (located c p_hsCmd)
|
HsCmdPar NoExtField c -> parens N (located c p_hsCmd)
|
||||||
HsCmdCase NoExt e mgroup ->
|
HsCmdCase NoExtField e mgroup ->
|
||||||
p_case cmdPlacement p_hsCmd 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'
|
p_if cmdPlacement p_hsCmd if' then' else'
|
||||||
HsCmdLet NoExt localBinds c ->
|
HsCmdLet NoExtField localBinds c ->
|
||||||
p_let p_hsCmd localBinds c
|
p_let p_hsCmd localBinds c
|
||||||
HsCmdDo NoExt es -> do
|
HsCmdDo NoExtField es -> do
|
||||||
txt "do"
|
txt "do"
|
||||||
newline
|
newline
|
||||||
inci . located es $
|
inci . located es $
|
||||||
sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
|
sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
|
||||||
HsCmdWrap {} -> notImplemented "HsCmdWrap"
|
HsCmdWrap {} -> notImplemented "HsCmdWrap"
|
||||||
XCmd {} -> notImplemented "XCmd"
|
XCmd x -> noExtCon x
|
||||||
|
|
||||||
p_hsCmdTop :: HsCmdTop GhcPs -> R ()
|
p_hsCmdTop :: HsCmdTop GhcPs -> R ()
|
||||||
p_hsCmdTop = \case
|
p_hsCmdTop = \case
|
||||||
HsCmdTop NoExt cmd -> located cmd p_hsCmd
|
HsCmdTop NoExtField cmd -> located cmd p_hsCmd
|
||||||
XCmdTop {} -> notImplemented "XHsCmdTop"
|
XCmdTop x -> noExtCon x
|
||||||
|
|
||||||
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
|
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
|
||||||
p_stmt = p_stmt' exprPlacement p_hsExpr
|
p_stmt = p_stmt' exprPlacement p_hsExpr
|
||||||
@ -367,16 +368,13 @@ p_stmt' ::
|
|||||||
Stmt GhcPs (Located body) ->
|
Stmt GhcPs (Located body) ->
|
||||||
R ()
|
R ()
|
||||||
p_stmt' placer render = \case
|
p_stmt' placer render = \case
|
||||||
LastStmt NoExt body _ _ -> located body render
|
LastStmt NoExtField body _ _ -> located body render
|
||||||
BindStmt NoExt p f _ _ -> do
|
BindStmt NoExtField p f _ _ -> do
|
||||||
p_pat p
|
located p p_pat
|
||||||
space
|
space
|
||||||
txt "<-"
|
txt "<-"
|
||||||
-- https://gitlab.haskell.org/ghc/ghc/issues/17330
|
let loc = getLoc p
|
||||||
let loc = case p of
|
placement =
|
||||||
XPat pat -> getLoc pat
|
|
||||||
_ -> error "p_stmt': BindStmt: Pat does not contain a location"
|
|
||||||
let placement =
|
|
||||||
case f of
|
case f of
|
||||||
L l' x ->
|
L l' x ->
|
||||||
if isOneLineSpan
|
if isOneLineSpan
|
||||||
@ -386,8 +384,8 @@ p_stmt' placer render = \case
|
|||||||
switchLayout [loc, getLoc f] $
|
switchLayout [loc, getLoc f] $
|
||||||
placeHanging placement (located f render)
|
placeHanging placement (located f render)
|
||||||
ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
|
ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
|
||||||
BodyStmt NoExt body _ _ -> located body render
|
BodyStmt NoExtField body _ _ -> located body render
|
||||||
LetStmt NoExt binds -> do
|
LetStmt NoExtField binds -> do
|
||||||
txt "let"
|
txt "let"
|
||||||
space
|
space
|
||||||
sitcc $ located binds p_hsLocalBinds
|
sitcc $ located binds p_hsLocalBinds
|
||||||
@ -429,10 +427,10 @@ p_stmt' placer render = \case
|
|||||||
txt "rec"
|
txt "rec"
|
||||||
space
|
space
|
||||||
sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
|
sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
|
||||||
XStmtLR {} -> notImplemented "XStmtLR"
|
XStmtLR c -> noExtCon c
|
||||||
|
|
||||||
gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
|
gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
|
||||||
gatherStmt (L _ (ParStmt NoExt block _ _)) =
|
gatherStmt (L _ (ParStmt NoExtField block _ _)) =
|
||||||
foldr ((<>) . gatherStmtBlock) [] block
|
foldr ((<>) . gatherStmtBlock) [] block
|
||||||
gatherStmt (L s stmt@TransStmt {..}) =
|
gatherStmt (L s stmt@TransStmt {..}) =
|
||||||
foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
|
foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
|
||||||
@ -441,11 +439,11 @@ gatherStmt stmt = [[stmt]]
|
|||||||
gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
|
gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
|
||||||
gatherStmtBlock (ParStmtBlock _ stmts _ _) =
|
gatherStmtBlock (ParStmtBlock _ stmts _ _) =
|
||||||
foldr (liftAppend . gatherStmt) [] stmts
|
foldr (liftAppend . gatherStmt) [] stmts
|
||||||
gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
|
gatherStmtBlock (XParStmtBlock x) = noExtCon x
|
||||||
|
|
||||||
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
|
p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
|
||||||
p_hsLocalBinds = \case
|
p_hsLocalBinds = \case
|
||||||
HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
|
HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
|
||||||
let ssStart =
|
let ssStart =
|
||||||
either
|
either
|
||||||
(srcSpanStart . getLoc)
|
(srcSpanStart . getLoc)
|
||||||
@ -467,20 +465,23 @@ p_hsLocalBinds = \case
|
|||||||
sepSemi
|
sepSemi
|
||||||
(\(m, i) -> (if m then br else id) $ p_item i)
|
(\(m, i) -> (if m then br else id) $ p_item i)
|
||||||
(markInit $ sortOn ssStart items)
|
(markInit $ sortOn ssStart items)
|
||||||
HsValBinds NoExt _ -> notImplemented "HsValBinds"
|
HsValBinds NoExtField _ -> notImplemented "HsValBinds"
|
||||||
HsIPBinds NoExt (IPBinds NoExt xs) ->
|
HsIPBinds NoExtField (IPBinds NoExtField xs) ->
|
||||||
-- Second argument of IPBind is always Left before type-checking.
|
-- 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
|
atom name
|
||||||
space
|
space
|
||||||
txt "="
|
txt "="
|
||||||
breakpoint
|
breakpoint
|
||||||
useBraces $ inci $ located expr p_hsExpr
|
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
|
in sepSemi (located' p_ipBind) xs
|
||||||
HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
|
HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
|
||||||
EmptyLocalBinds NoExt -> return ()
|
EmptyLocalBinds NoExtField -> return ()
|
||||||
XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
|
XHsLocalBindsLR x -> noExtCon x
|
||||||
|
|
||||||
p_hsRecField ::
|
p_hsRecField ::
|
||||||
HsRecField' RdrName (LHsExpr GhcPs) ->
|
HsRecField' RdrName (LHsExpr GhcPs) ->
|
||||||
@ -495,42 +496,42 @@ p_hsRecField HsRecField {..} = do
|
|||||||
|
|
||||||
p_hsTupArg :: HsTupArg GhcPs -> R ()
|
p_hsTupArg :: HsTupArg GhcPs -> R ()
|
||||||
p_hsTupArg = \case
|
p_hsTupArg = \case
|
||||||
Present NoExt x -> located x p_hsExpr
|
Present NoExtField x -> located x p_hsExpr
|
||||||
Missing NoExt -> pure ()
|
Missing NoExtField -> pure ()
|
||||||
XTupArg {} -> notImplemented "XTupArg"
|
XTupArg x -> noExtCon x
|
||||||
|
|
||||||
p_hsExpr :: HsExpr GhcPs -> R ()
|
p_hsExpr :: HsExpr GhcPs -> R ()
|
||||||
p_hsExpr = p_hsExpr' N
|
p_hsExpr = p_hsExpr' N
|
||||||
|
|
||||||
p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
|
p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
|
||||||
p_hsExpr' s = \case
|
p_hsExpr' s = \case
|
||||||
HsVar NoExt name -> p_rdrName name
|
HsVar NoExtField name -> p_rdrName name
|
||||||
HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
|
HsUnboundVar NoExtField v -> atom (unboundVarOcc v)
|
||||||
HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
|
HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"
|
||||||
HsRecFld NoExt x ->
|
HsRecFld NoExtField x ->
|
||||||
case x of
|
case x of
|
||||||
Unambiguous NoExt name -> p_rdrName name
|
Unambiguous NoExtField name -> p_rdrName name
|
||||||
Ambiguous NoExt name -> p_rdrName name
|
Ambiguous NoExtField name -> p_rdrName name
|
||||||
XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
|
XAmbiguousFieldOcc xx -> noExtCon xx
|
||||||
HsOverLabel NoExt _ v -> do
|
HsOverLabel NoExtField _ v -> do
|
||||||
txt "#"
|
txt "#"
|
||||||
atom v
|
atom v
|
||||||
HsIPVar NoExt (HsIPName name) -> do
|
HsIPVar NoExtField (HsIPName name) -> do
|
||||||
txt "?"
|
txt "?"
|
||||||
atom name
|
atom name
|
||||||
HsOverLit NoExt v -> atom (ol_val v)
|
HsOverLit NoExtField v -> atom (ol_val v)
|
||||||
HsLit NoExt lit ->
|
HsLit NoExtField lit ->
|
||||||
case lit of
|
case lit of
|
||||||
HsString (SourceText stxt) _ -> p_stringLit stxt
|
HsString (SourceText stxt) _ -> p_stringLit stxt
|
||||||
HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
|
HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
|
||||||
r -> atom r
|
r -> atom r
|
||||||
HsLam NoExt mgroup ->
|
HsLam NoExtField mgroup ->
|
||||||
p_matchGroup Lambda mgroup
|
p_matchGroup Lambda mgroup
|
||||||
HsLamCase NoExt mgroup -> do
|
HsLamCase NoExtField mgroup -> do
|
||||||
txt "\\case"
|
txt "\\case"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (p_matchGroup LambdaCase mgroup)
|
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
|
let -- In order to format function applications with multiple parameters
|
||||||
-- nicer, traverse the AST to gather the function and all the
|
-- nicer, traverse the AST to gather the function and all the
|
||||||
-- parameters together.
|
-- parameters together.
|
||||||
@ -564,9 +565,9 @@ p_hsExpr' s = \case
|
|||||||
-- expression is parenthesised.
|
-- expression is parenthesised.
|
||||||
indent =
|
indent =
|
||||||
case func of
|
case func of
|
||||||
L _ (HsPar NoExt _) -> inci
|
L _ (HsPar NoExtField _) -> inci
|
||||||
L _ (HsAppType NoExt _ _) -> inci
|
L _ (HsAppType NoExtField _ _) -> inci
|
||||||
L _ (HsMultiIf NoExt _) -> inci
|
L _ (HsMultiIf NoExtField _) -> inci
|
||||||
L spn _ ->
|
L spn _ ->
|
||||||
if isOneLineSpan spn
|
if isOneLineSpan spn
|
||||||
then inci
|
then inci
|
||||||
@ -588,35 +589,35 @@ p_hsExpr' s = \case
|
|||||||
sep breakpoint (located' p_hsExpr) initp
|
sep breakpoint (located' p_hsExpr) initp
|
||||||
placeHanging placement $
|
placeHanging placement $
|
||||||
located lastp p_hsExpr
|
located lastp p_hsExpr
|
||||||
HsAppType NoExt e a -> do
|
HsAppType NoExtField e a -> do
|
||||||
located e p_hsExpr
|
located e p_hsExpr
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ do
|
inci $ do
|
||||||
txt "@"
|
txt "@"
|
||||||
located (hswc_body a) p_hsType
|
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)
|
let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
|
||||||
p_exprOpTree True s (reassociateOpTree getOpName opTree)
|
p_exprOpTree True s (reassociateOpTree getOpName opTree)
|
||||||
NegApp NoExt e _ -> do
|
NegApp NoExtField e _ -> do
|
||||||
txt "-"
|
txt "-"
|
||||||
space
|
space
|
||||||
located e p_hsExpr
|
located e p_hsExpr
|
||||||
HsPar NoExt e ->
|
HsPar NoExtField e ->
|
||||||
parens s (located e (dontUseBraces . p_hsExpr))
|
parens s (located e (dontUseBraces . p_hsExpr))
|
||||||
SectionL NoExt x op -> do
|
SectionL NoExtField x op -> do
|
||||||
located x p_hsExpr
|
located x p_hsExpr
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located op p_hsExpr)
|
inci (located op p_hsExpr)
|
||||||
SectionR NoExt op x -> do
|
SectionR NoExtField op x -> do
|
||||||
located op p_hsExpr
|
located op p_hsExpr
|
||||||
useRecordDot' <- useRecordDot
|
useRecordDot' <- useRecordDot
|
||||||
let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
|
let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
|
||||||
unless (useRecordDot' && isRecordDot') breakpoint
|
unless (useRecordDot' && isRecordDot') breakpoint
|
||||||
inci (located x p_hsExpr)
|
inci (located x p_hsExpr)
|
||||||
ExplicitTuple NoExt args boxity -> do
|
ExplicitTuple NoExtField args boxity -> do
|
||||||
let isSection = any (isMissing . unLoc) args
|
let isSection = any (isMissing . unLoc) args
|
||||||
isMissing = \case
|
isMissing = \case
|
||||||
Missing NoExt -> True
|
Missing NoExtField -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
let parens' =
|
let parens' =
|
||||||
case boxity of
|
case boxity of
|
||||||
@ -629,18 +630,18 @@ p_hsExpr' s = \case
|
|||||||
else
|
else
|
||||||
switchLayout (getLoc <$> args) . parens' s . sitcc $
|
switchLayout (getLoc <$> args) . parens' s . sitcc $
|
||||||
sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
|
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)
|
p_unboxedSum N tag arity (located e p_hsExpr)
|
||||||
HsCase NoExt e mgroup ->
|
HsCase NoExtField e mgroup ->
|
||||||
p_case exprPlacement p_hsExpr 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'
|
p_if exprPlacement p_hsExpr if' then' else'
|
||||||
HsMultiIf NoExt guards -> do
|
HsMultiIf NoExtField guards -> do
|
||||||
txt "if "
|
txt "if "
|
||||||
inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
|
inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
|
||||||
HsLet NoExt localBinds e ->
|
HsLet NoExtField localBinds e ->
|
||||||
p_let p_hsExpr localBinds e
|
p_let p_hsExpr localBinds e
|
||||||
HsDo NoExt ctx es -> do
|
HsDo NoExtField ctx es -> do
|
||||||
let doBody header = do
|
let doBody header = do
|
||||||
txt header
|
txt header
|
||||||
breakpoint
|
breakpoint
|
||||||
@ -685,10 +686,10 @@ p_hsExpr' s = \case
|
|||||||
breakpoint
|
breakpoint
|
||||||
let HsRecFields {..} = rcon_flds
|
let HsRecFields {..} = rcon_flds
|
||||||
updName f =
|
updName f =
|
||||||
f
|
(f :: HsRecField GhcPs (LHsExpr GhcPs))
|
||||||
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
||||||
FieldOcc _ n -> n
|
FieldOcc _ n -> n
|
||||||
XFieldOcc _ -> notImplemented "XFieldOcc"
|
XFieldOcc x -> noExtCon x
|
||||||
}
|
}
|
||||||
fields = located' (p_hsRecField . updName) <$> rec_flds
|
fields = located' (p_hsRecField . updName) <$> rec_flds
|
||||||
dotdot =
|
dotdot =
|
||||||
@ -708,27 +709,26 @@ p_hsExpr' s = \case
|
|||||||
== (srcSpanStartCol <$> mrs (head rupd_flds))
|
== (srcSpanStartCol <$> mrs (head rupd_flds))
|
||||||
unless (useRecordDot' && isPluginForm) breakpoint
|
unless (useRecordDot' && isPluginForm) breakpoint
|
||||||
let updName f =
|
let updName f =
|
||||||
f
|
(f :: HsRecUpdField GhcPs)
|
||||||
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
{ hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
|
||||||
Ambiguous _ n -> n
|
Ambiguous _ n -> n
|
||||||
Unambiguous _ n -> n
|
Unambiguous _ n -> n
|
||||||
XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
|
XAmbiguousFieldOcc x -> noExtCon x
|
||||||
}
|
}
|
||||||
inci . braces N . sitcc $
|
inci . braces N . sitcc $
|
||||||
sep
|
sep
|
||||||
(comma >> breakpoint)
|
(comma >> breakpoint)
|
||||||
(sitcc . located' (p_hsRecField . updName))
|
(sitcc . located' (p_hsRecField . updName))
|
||||||
rupd_flds
|
rupd_flds
|
||||||
ExprWithTySig NoExt x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
|
ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
|
||||||
located x p_hsExpr
|
located x p_hsExpr
|
||||||
space
|
space
|
||||||
txt "::"
|
txt "::"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ located hsib_body p_hsType
|
inci $ located hsib_body p_hsType
|
||||||
ExprWithTySig NoExt _ HsWC {hswc_body = XHsImplicitBndrs {}} ->
|
ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x
|
||||||
notImplemented "XHsImplicitBndrs"
|
ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
|
||||||
ExprWithTySig NoExt _ XHsWildCardBndrs {} -> notImplemented "XHsWildCardBndrs"
|
ArithSeq NoExtField _ x ->
|
||||||
ArithSeq NoExt _ x ->
|
|
||||||
case x of
|
case x of
|
||||||
From from -> brackets s . sitcc $ do
|
From from -> brackets s . sitcc $ do
|
||||||
located from p_hsExpr
|
located from p_hsExpr
|
||||||
@ -750,25 +750,25 @@ p_hsExpr' s = \case
|
|||||||
txt ".."
|
txt ".."
|
||||||
space
|
space
|
||||||
located to p_hsExpr
|
located to p_hsExpr
|
||||||
HsSCC NoExt _ name x -> do
|
HsSCC NoExtField _ name x -> do
|
||||||
txt "{-# SCC "
|
txt "{-# SCC "
|
||||||
atom name
|
atom name
|
||||||
txt " #-}"
|
txt " #-}"
|
||||||
breakpoint
|
breakpoint
|
||||||
located x p_hsExpr
|
located x p_hsExpr
|
||||||
HsCoreAnn NoExt _ value x -> do
|
HsCoreAnn NoExtField _ value x -> do
|
||||||
txt "{-# CORE "
|
txt "{-# CORE "
|
||||||
atom value
|
atom value
|
||||||
txt " #-}"
|
txt " #-}"
|
||||||
breakpoint
|
breakpoint
|
||||||
located x p_hsExpr
|
located x p_hsExpr
|
||||||
HsBracket NoExt x -> p_hsBracket x
|
HsBracket NoExtField x -> p_hsBracket x
|
||||||
HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
|
HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
|
||||||
HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
|
HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
|
||||||
HsSpliceE NoExt splice -> p_hsSplice splice
|
HsSpliceE NoExtField splice -> p_hsSplice splice
|
||||||
HsProc NoExt p e -> do
|
HsProc NoExtField p e -> do
|
||||||
txt "proc"
|
txt "proc"
|
||||||
locatedPat p $ \x -> do
|
located p $ \x -> do
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (p_pat x)
|
inci (p_pat x)
|
||||||
breakpoint
|
breakpoint
|
||||||
@ -779,31 +779,11 @@ p_hsExpr' s = \case
|
|||||||
txt "static"
|
txt "static"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located e p_hsExpr)
|
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"
|
HsTick {} -> notImplemented "HsTick"
|
||||||
HsBinTick {} -> notImplemented "HsBinTick"
|
HsBinTick {} -> notImplemented "HsBinTick"
|
||||||
HsTickPragma {} -> notImplemented "HsTickPragma"
|
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"
|
HsWrap {} -> notImplemented "HsWrap"
|
||||||
XExpr {} -> notImplemented "XExpr"
|
XExpr x -> noExtCon x
|
||||||
|
|
||||||
p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
|
p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
|
||||||
p_patSynBind PSB {..} = do
|
p_patSynBind PSB {..} = do
|
||||||
@ -813,15 +793,15 @@ p_patSynBind PSB {..} = do
|
|||||||
Unidirectional -> do
|
Unidirectional -> do
|
||||||
txt "<-"
|
txt "<-"
|
||||||
breakpoint
|
breakpoint
|
||||||
p_pat psb_def
|
located psb_def p_pat
|
||||||
ImplicitBidirectional -> do
|
ImplicitBidirectional -> do
|
||||||
txt "="
|
txt "="
|
||||||
breakpoint
|
breakpoint
|
||||||
p_pat psb_def
|
located psb_def p_pat
|
||||||
ExplicitBidirectional mgroup -> do
|
ExplicitBidirectional mgroup -> do
|
||||||
txt "<-"
|
txt "<-"
|
||||||
breakpoint
|
breakpoint
|
||||||
p_pat psb_def
|
located psb_def p_pat
|
||||||
newline
|
newline
|
||||||
txt "where"
|
txt "where"
|
||||||
newline
|
newline
|
||||||
@ -855,7 +835,7 @@ p_patSynBind PSB {..} = do
|
|||||||
space
|
space
|
||||||
p_rdrName r
|
p_rdrName r
|
||||||
inci rhs
|
inci rhs
|
||||||
p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
|
p_patSynBind (XPatSynBind x) = noExtCon x
|
||||||
|
|
||||||
p_case ::
|
p_case ::
|
||||||
Data body =>
|
Data body =>
|
||||||
@ -922,40 +902,37 @@ p_let render localBinds e = sitcc $ do
|
|||||||
|
|
||||||
p_pat :: Pat GhcPs -> R ()
|
p_pat :: Pat GhcPs -> R ()
|
||||||
p_pat = \case
|
p_pat = \case
|
||||||
-- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always
|
WildPat NoExtField -> txt "_"
|
||||||
-- constructed with the 'XPat' constructor, containing a @Located Pat@.
|
VarPat NoExtField name -> p_rdrName name
|
||||||
XPat pat -> located pat p_pat
|
LazyPat NoExtField pat -> do
|
||||||
WildPat NoExt -> txt "_"
|
|
||||||
VarPat NoExt name -> p_rdrName name
|
|
||||||
LazyPat NoExt pat -> do
|
|
||||||
txt "~"
|
txt "~"
|
||||||
p_pat pat
|
located pat p_pat
|
||||||
AsPat NoExt name pat -> do
|
AsPat NoExtField name pat -> do
|
||||||
p_rdrName name
|
p_rdrName name
|
||||||
txt "@"
|
txt "@"
|
||||||
p_pat pat
|
located pat p_pat
|
||||||
ParPat NoExt pat ->
|
ParPat NoExtField pat ->
|
||||||
locatedPat pat (parens S . p_pat)
|
located pat (parens S . p_pat)
|
||||||
BangPat NoExt pat -> do
|
BangPat NoExtField pat -> do
|
||||||
txt "!"
|
txt "!"
|
||||||
p_pat pat
|
located pat p_pat
|
||||||
ListPat NoExt pats ->
|
ListPat NoExtField pats ->
|
||||||
brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats
|
brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
|
||||||
TuplePat NoExt pats boxing -> do
|
TuplePat NoExtField pats boxing -> do
|
||||||
let f =
|
let f =
|
||||||
case boxing of
|
case boxing of
|
||||||
Boxed -> parens S
|
Boxed -> parens S
|
||||||
Unboxed -> parensHash S
|
Unboxed -> parensHash S
|
||||||
f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats
|
f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
|
||||||
SumPat NoExt pat tag arity ->
|
SumPat NoExtField pat tag arity ->
|
||||||
p_unboxedSum S tag arity (p_pat pat)
|
p_unboxedSum S tag arity (located pat p_pat)
|
||||||
ConPatIn pat details ->
|
ConPatIn pat details ->
|
||||||
case details of
|
case details of
|
||||||
PrefixCon xs -> sitcc $ do
|
PrefixCon xs -> sitcc $ do
|
||||||
p_rdrName pat
|
p_rdrName pat
|
||||||
unless (null xs) $ do
|
unless (null xs) $ do
|
||||||
breakpoint
|
breakpoint
|
||||||
inci . sitcc $ sep breakpoint (sitcc . p_pat) xs
|
inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs
|
||||||
RecCon (HsRecFields fields dotdot) -> do
|
RecCon (HsRecFields fields dotdot) -> do
|
||||||
p_rdrName pat
|
p_rdrName pat
|
||||||
breakpoint
|
breakpoint
|
||||||
@ -965,36 +942,37 @@ p_pat = \case
|
|||||||
inci . braces N . sitcc . sep (comma >> breakpoint) f $
|
inci . braces N . sitcc . sep (comma >> breakpoint) f $
|
||||||
case dotdot of
|
case dotdot of
|
||||||
Nothing -> Just <$> fields
|
Nothing -> Just <$> fields
|
||||||
Just n -> (Just <$> take n fields) ++ [Nothing]
|
Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
|
||||||
InfixCon l r -> do
|
InfixCon l r -> do
|
||||||
switchLayout [getLoc l, getLoc r] $ do
|
switchLayout [getLoc l, getLoc r] $ do
|
||||||
p_pat l
|
located l p_pat
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ do
|
inci $ do
|
||||||
p_rdrName pat
|
p_rdrName pat
|
||||||
space
|
space
|
||||||
p_pat r
|
located r p_pat
|
||||||
ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
|
ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
|
||||||
ViewPat NoExt expr pat -> sitcc $ do
|
ViewPat NoExtField expr pat -> sitcc $ do
|
||||||
located expr p_hsExpr
|
located expr p_hsExpr
|
||||||
space
|
space
|
||||||
txt "->"
|
txt "->"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (p_pat pat)
|
inci (located pat p_pat)
|
||||||
SplicePat NoExt splice -> p_hsSplice splice
|
SplicePat NoExtField splice -> p_hsSplice splice
|
||||||
LitPat NoExt p -> atom p
|
LitPat NoExtField p -> atom p
|
||||||
NPat NoExt v _ _ -> located v (atom . ol_val)
|
NPat NoExtField v _ _ -> located v (atom . ol_val)
|
||||||
NPlusKPat NoExt n k _ _ _ -> sitcc $ do
|
NPlusKPat NoExtField n k _ _ _ -> sitcc $ do
|
||||||
p_rdrName n
|
p_rdrName n
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ do
|
inci $ do
|
||||||
txt "+"
|
txt "+"
|
||||||
space
|
space
|
||||||
located k (atom . ol_val)
|
located k (atom . ol_val)
|
||||||
SigPat NoExt pat hswc -> do
|
SigPat NoExtField pat hswc -> do
|
||||||
p_pat pat
|
located pat p_pat
|
||||||
p_typeAscription hswc
|
p_typeAscription hswc
|
||||||
CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
|
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' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
|
||||||
p_pat_hsRecField HsRecField {..} = do
|
p_pat_hsRecField HsRecField {..} = do
|
||||||
@ -1004,7 +982,7 @@ p_pat_hsRecField HsRecField {..} = do
|
|||||||
space
|
space
|
||||||
txt "="
|
txt "="
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (p_pat hsRecFieldArg)
|
inci (located hsRecFieldArg p_pat)
|
||||||
|
|
||||||
p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
|
p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
|
||||||
p_unboxedSum s tag arity m = do
|
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 :: HsSplice GhcPs -> R ()
|
||||||
p_hsSplice = \case
|
p_hsSplice = \case
|
||||||
HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
|
HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco
|
||||||
HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
|
HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco
|
||||||
HsQuasiQuote NoExt _ quoterName srcSpan str -> do
|
HsQuasiQuote NoExtField _ quoterName srcSpan str -> do
|
||||||
txt "["
|
txt "["
|
||||||
p_rdrName (L srcSpan quoterName)
|
p_rdrName (L srcSpan quoterName)
|
||||||
txt "|"
|
txt "|"
|
||||||
@ -1037,7 +1015,7 @@ p_hsSplice = \case
|
|||||||
txt "|]"
|
txt "|]"
|
||||||
HsSpliced {} -> notImplemented "HsSpliced"
|
HsSpliced {} -> notImplemented "HsSpliced"
|
||||||
HsSplicedT {} -> notImplemented "HsSplicedT"
|
HsSplicedT {} -> notImplemented "HsSplicedT"
|
||||||
XSplice {} -> notImplemented "XSplice"
|
XSplice x -> noExtCon x
|
||||||
|
|
||||||
p_hsSpliceTH ::
|
p_hsSpliceTH ::
|
||||||
-- | Typed splice?
|
-- | Typed splice?
|
||||||
@ -1061,17 +1039,17 @@ p_hsSpliceTH isTyped expr = \case
|
|||||||
|
|
||||||
p_hsBracket :: HsBracket GhcPs -> R ()
|
p_hsBracket :: HsBracket GhcPs -> R ()
|
||||||
p_hsBracket = \case
|
p_hsBracket = \case
|
||||||
ExpBr NoExt expr -> do
|
ExpBr NoExtField expr -> do
|
||||||
anns <- getEnclosingAnns
|
anns <- getEnclosingAnns
|
||||||
let name = case anns of
|
let name = case anns of
|
||||||
AnnOpenEQ : _ -> ""
|
AnnOpenEQ : _ -> ""
|
||||||
_ -> "e"
|
_ -> "e"
|
||||||
quote name (located expr p_hsExpr)
|
quote name (located expr p_hsExpr)
|
||||||
PatBr NoExt pat -> quote "p" (p_pat pat)
|
PatBr NoExtField pat -> located pat (quote "p" . p_pat)
|
||||||
DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
|
DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)
|
||||||
DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
|
DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer
|
||||||
TypBr NoExt ty -> quote "t" (located ty p_hsType)
|
TypBr NoExtField ty -> quote "t" (located ty p_hsType)
|
||||||
VarBr NoExt isSingleQuote name -> do
|
VarBr NoExtField isSingleQuote name -> do
|
||||||
txt (bool "''" "'" isSingleQuote)
|
txt (bool "''" "'" isSingleQuote)
|
||||||
-- HACK As you can see we use 'noLoc' here to be able to pass name into
|
-- 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
|
-- 'p_rdrName' since the latter expects a "located" thing. The problem
|
||||||
@ -1086,13 +1064,13 @@ p_hsBracket = \case
|
|||||||
&& not (doesNotNeedExtraParens name)
|
&& not (doesNotNeedExtraParens name)
|
||||||
wrapper = if isOperator then parens N else id
|
wrapper = if isOperator then parens N else id
|
||||||
wrapper $ p_rdrName (noLoc name)
|
wrapper $ p_rdrName (noLoc name)
|
||||||
TExpBr NoExt expr -> do
|
TExpBr NoExtField expr -> do
|
||||||
txt "[||"
|
txt "[||"
|
||||||
breakpoint'
|
breakpoint'
|
||||||
located expr p_hsExpr
|
located expr p_hsExpr
|
||||||
breakpoint'
|
breakpoint'
|
||||||
txt "||]"
|
txt "||]"
|
||||||
XBracket {} -> notImplemented "XBracket"
|
XBracket x -> noExtCon x
|
||||||
where
|
where
|
||||||
quote :: Text -> R () -> R ()
|
quote :: Text -> R () -> R ()
|
||||||
quote name body = do
|
quote name body = do
|
||||||
@ -1171,9 +1149,9 @@ liftAppend (x : xs) [] = x : xs
|
|||||||
liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
|
liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
|
||||||
|
|
||||||
getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
|
getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
|
||||||
getGRHSSpan (GRHS NoExt guards body) =
|
getGRHSSpan (GRHS NoExtField guards body) =
|
||||||
combineSrcSpans' $ getLoc body :| map getLoc guards
|
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
|
-- | Place a thing that may have a hanging form. This function handles how
|
||||||
-- to separate it from preceding expressions and whether to bump indentation
|
-- to separate it from preceding expressions and whether to bump indentation
|
||||||
@ -1194,67 +1172,63 @@ blockPlacement ::
|
|||||||
(body -> Placement) ->
|
(body -> Placement) ->
|
||||||
[LGRHS GhcPs (Located body)] ->
|
[LGRHS GhcPs (Located body)] ->
|
||||||
Placement
|
Placement
|
||||||
blockPlacement placer [L _ (GRHS NoExt _ (L _ x))] = placer x
|
blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
|
||||||
blockPlacement _ _ = Normal
|
blockPlacement _ _ = Normal
|
||||||
|
|
||||||
-- | Check if given command has a hanging form.
|
-- | Check if given command has a hanging form.
|
||||||
cmdPlacement :: HsCmd GhcPs -> Placement
|
cmdPlacement :: HsCmd GhcPs -> Placement
|
||||||
cmdPlacement = \case
|
cmdPlacement = \case
|
||||||
HsCmdLam NoExt _ -> Hanging
|
HsCmdLam NoExtField _ -> Hanging
|
||||||
HsCmdCase NoExt _ _ -> Hanging
|
HsCmdCase NoExtField _ _ -> Hanging
|
||||||
HsCmdDo NoExt _ -> Hanging
|
HsCmdDo NoExtField _ -> Hanging
|
||||||
_ -> Normal
|
_ -> Normal
|
||||||
|
|
||||||
cmdTopPlacement :: HsCmdTop GhcPs -> Placement
|
cmdTopPlacement :: HsCmdTop GhcPs -> Placement
|
||||||
cmdTopPlacement = \case
|
cmdTopPlacement = \case
|
||||||
HsCmdTop NoExt (L _ x) -> cmdPlacement x
|
HsCmdTop NoExtField (L _ x) -> cmdPlacement x
|
||||||
XCmdTop {} -> notImplemented "XCmdTop"
|
XCmdTop x -> noExtCon x
|
||||||
|
|
||||||
-- | Check if given expression has a hanging form.
|
-- | Check if given expression has a hanging form.
|
||||||
exprPlacement :: HsExpr GhcPs -> Placement
|
exprPlacement :: HsExpr GhcPs -> Placement
|
||||||
exprPlacement = \case
|
exprPlacement = \case
|
||||||
-- Only hang lambdas with single line parameter lists
|
-- Only hang lambdas with single line parameter lists
|
||||||
HsLam NoExt mg -> case mg of
|
HsLam NoExtField mg -> case mg of
|
||||||
MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
|
MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
|
||||||
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
|
| isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
|
||||||
Hanging
|
Hanging
|
||||||
_ -> Normal
|
_ -> Normal
|
||||||
HsLamCase NoExt _ -> Hanging
|
HsLamCase NoExtField _ -> Hanging
|
||||||
HsCase NoExt _ _ -> Hanging
|
HsCase NoExtField _ _ -> Hanging
|
||||||
HsDo NoExt DoExpr _ -> Hanging
|
HsDo NoExtField DoExpr _ -> Hanging
|
||||||
HsDo NoExt MDoExpr _ -> Hanging
|
HsDo NoExtField MDoExpr _ -> Hanging
|
||||||
-- If the rightmost expression in an operator chain is hanging, make the
|
-- 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@
|
-- whole block hanging; so that we can use the common @f = foo $ do@
|
||||||
-- style.
|
-- style.
|
||||||
OpApp NoExt _ _ y -> exprPlacement (unLoc y)
|
OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
|
||||||
-- Same thing for function applications (usually with -XBlockArguments)
|
-- Same thing for function applications (usually with -XBlockArguments)
|
||||||
HsApp NoExt _ y -> exprPlacement (unLoc y)
|
HsApp NoExtField _ y -> exprPlacement (unLoc y)
|
||||||
HsProc NoExt p _ ->
|
HsProc NoExtField p _ ->
|
||||||
-- https://gitlab.haskell.org/ghc/ghc/issues/17330
|
-- Indentation breaks if pattern is longer than one line and left
|
||||||
let loc = case p of
|
-- hanging. Consequently, only apply hanging when it is safe.
|
||||||
XPat pat -> getLoc pat
|
if isOneLineSpan (getLoc p)
|
||||||
_ -> error "exprPlacement: HsProc: Pat does not contain a location"
|
then Hanging
|
||||||
in -- Indentation breaks if pattern is longer than one line and left
|
else Normal
|
||||||
-- hanging. Consequently, only apply hanging when it is safe.
|
|
||||||
if isOneLineSpan loc
|
|
||||||
then Hanging
|
|
||||||
else Normal
|
|
||||||
_ -> Normal
|
_ -> Normal
|
||||||
|
|
||||||
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
|
withGuards :: [LGRHS GhcPs (Located body)] -> Bool
|
||||||
withGuards = any (checkOne . unLoc)
|
withGuards = any (checkOne . unLoc)
|
||||||
where
|
where
|
||||||
checkOne :: GRHS GhcPs (Located body) -> Bool
|
checkOne :: GRHS GhcPs (Located body) -> Bool
|
||||||
checkOne (GRHS NoExt [] _) = False
|
checkOne (GRHS NoExtField [] _) = False
|
||||||
checkOne _ = True
|
checkOne _ = True
|
||||||
|
|
||||||
exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
|
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
|
exprOpTree n = OpNode n
|
||||||
|
|
||||||
getOpName :: HsExpr GhcPs -> Maybe RdrName
|
getOpName :: HsExpr GhcPs -> Maybe RdrName
|
||||||
getOpName = \case
|
getOpName = \case
|
||||||
HsVar NoExt (L _ a) -> Just a
|
HsVar NoExtField (L _ a) -> Just a
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
p_exprOpTree ::
|
p_exprOpTree ::
|
||||||
@ -1276,8 +1250,10 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
|
|||||||
OpNode (L _ n) -> exprPlacement n
|
OpNode (L _ n) -> exprPlacement n
|
||||||
_ -> Normal
|
_ -> Normal
|
||||||
else Normal
|
else Normal
|
||||||
|
-- Distinguish holes used in infix notation.
|
||||||
|
-- eg. '1 _foo 2' and '1 `_foo` 2'
|
||||||
opWrapper = case unLoc op of
|
opWrapper = case unLoc op of
|
||||||
EWildPat NoExt -> backticks
|
HsUnboundVar NoExtField _ -> backticks
|
||||||
_ -> id
|
_ -> id
|
||||||
layout <- getLayout
|
layout <- getLayout
|
||||||
let ub = case layout of
|
let ub = case layout of
|
||||||
@ -1332,7 +1308,7 @@ isRecordDot ::
|
|||||||
SrcSpan ->
|
SrcSpan ->
|
||||||
Bool
|
Bool
|
||||||
isRecordDot op (RealSrcSpan ySpan) = case op of
|
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)
|
isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
|
||||||
_ -> False
|
_ -> False
|
||||||
isRecordDot _ _ = False
|
isRecordDot _ _ = False
|
||||||
|
@ -13,17 +13,16 @@ import Data.Text (Text)
|
|||||||
import GHC
|
import GHC
|
||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_warnDecls :: WarnDecls GhcPs -> R ()
|
p_warnDecls :: WarnDecls GhcPs -> R ()
|
||||||
p_warnDecls (Warnings NoExt _ warnings) =
|
p_warnDecls (Warnings NoExtField _ warnings) =
|
||||||
traverse_ (located' p_warnDecl) warnings
|
traverse_ (located' p_warnDecl) warnings
|
||||||
p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"
|
p_warnDecls (XWarnDecls x) = noExtCon x
|
||||||
|
|
||||||
p_warnDecl :: WarnDecl GhcPs -> R ()
|
p_warnDecl :: WarnDecl GhcPs -> R ()
|
||||||
p_warnDecl (Warning NoExt functions warningTxt) =
|
p_warnDecl (Warning NoExtField functions warningTxt) =
|
||||||
p_topLevelWarning functions warningTxt
|
p_topLevelWarning functions warningTxt
|
||||||
p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"
|
p_warnDecl (XWarnDecl x) = noExtCon x
|
||||||
|
|
||||||
p_moduleWarning :: WarningTxt -> R ()
|
p_moduleWarning :: WarningTxt -> R ()
|
||||||
p_moduleWarning wtxt = do
|
p_moduleWarning wtxt = do
|
||||||
|
@ -11,10 +11,9 @@ where
|
|||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import GHC
|
import GHC
|
||||||
import HsImpExp (IE (..))
|
import GHC.Hs.ImpExp (IE (..))
|
||||||
import Ormolu.Printer.Combinators
|
import Ormolu.Printer.Combinators
|
||||||
import Ormolu.Printer.Meat.Common
|
import Ormolu.Printer.Meat.Common
|
||||||
import Ormolu.Utils
|
|
||||||
|
|
||||||
p_hsmodExports :: [LIE GhcPs] -> R ()
|
p_hsmodExports :: [LIE GhcPs] -> R ()
|
||||||
p_hsmodExports [] = do
|
p_hsmodExports [] = do
|
||||||
@ -34,7 +33,9 @@ p_hsmodImport ImportDecl {..} = do
|
|||||||
space
|
space
|
||||||
when ideclSafe (txt "safe")
|
when ideclSafe (txt "safe")
|
||||||
space
|
space
|
||||||
when ideclQualified (txt "qualified")
|
when
|
||||||
|
(isImportDeclQualified ideclQualified)
|
||||||
|
(txt "qualified")
|
||||||
space
|
space
|
||||||
case ideclPkgQual of
|
case ideclPkgQual of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
@ -62,22 +63,22 @@ p_hsmodImport ImportDecl {..} = do
|
|||||||
layout <- getLayout
|
layout <- getLayout
|
||||||
sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
|
sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
|
||||||
newline
|
newline
|
||||||
p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"
|
p_hsmodImport (XImportDecl x) = noExtCon x
|
||||||
|
|
||||||
p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
|
p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
|
||||||
p_lie encLayout (i, totalItems) = \case
|
p_lie encLayout (i, totalItems) = \case
|
||||||
IEVar NoExt l1 -> do
|
IEVar NoExtField l1 -> do
|
||||||
located l1 p_ieWrappedName
|
located l1 p_ieWrappedName
|
||||||
p_comma
|
p_comma
|
||||||
IEThingAbs NoExt l1 -> do
|
IEThingAbs NoExtField l1 -> do
|
||||||
located l1 p_ieWrappedName
|
located l1 p_ieWrappedName
|
||||||
p_comma
|
p_comma
|
||||||
IEThingAll NoExt l1 -> do
|
IEThingAll NoExtField l1 -> do
|
||||||
located l1 p_ieWrappedName
|
located l1 p_ieWrappedName
|
||||||
space
|
space
|
||||||
txt "(..)"
|
txt "(..)"
|
||||||
p_comma
|
p_comma
|
||||||
IEThingWith NoExt l1 w xs _ -> sitcc $ do
|
IEThingWith NoExtField l1 w xs _ -> sitcc $ do
|
||||||
located l1 p_ieWrappedName
|
located l1 p_ieWrappedName
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ do
|
inci $ do
|
||||||
@ -91,16 +92,16 @@ p_lie encLayout (i, totalItems) = \case
|
|||||||
let (before, after) = splitAt n names
|
let (before, after) = splitAt n names
|
||||||
in before ++ [txt ".."] ++ after
|
in before ++ [txt ".."] ++ after
|
||||||
p_comma
|
p_comma
|
||||||
IEModuleContents NoExt l1 -> do
|
IEModuleContents NoExtField l1 -> do
|
||||||
located l1 p_hsmodName
|
located l1 p_hsmodName
|
||||||
p_comma
|
p_comma
|
||||||
IEGroup NoExt n str -> do
|
IEGroup NoExtField n str -> do
|
||||||
unless (i == 0) newline
|
unless (i == 0) newline
|
||||||
p_hsDocString (Asterisk n) False (noLoc str)
|
p_hsDocString (Asterisk n) False (noLoc str)
|
||||||
IEDoc NoExt str ->
|
IEDoc NoExtField str ->
|
||||||
p_hsDocString Pipe False (noLoc str)
|
p_hsDocString Pipe False (noLoc str)
|
||||||
IEDocNamed NoExt str -> p_hsDocName str
|
IEDocNamed NoExtField str -> p_hsDocName str
|
||||||
XIE NoExt -> notImplemented "XIE"
|
XIE x -> noExtCon x
|
||||||
where
|
where
|
||||||
p_comma =
|
p_comma =
|
||||||
case encLayout of
|
case encLayout of
|
||||||
|
@ -27,11 +27,11 @@ p_hsType t = p_hsType' (hasDocStrings t) t
|
|||||||
|
|
||||||
p_hsType' :: Bool -> HsType GhcPs -> R ()
|
p_hsType' :: Bool -> HsType GhcPs -> R ()
|
||||||
p_hsType' multilineArgs = \case
|
p_hsType' multilineArgs = \case
|
||||||
HsForAllTy NoExt bndrs t -> do
|
HsForAllTy NoExtField visibility bndrs t -> do
|
||||||
p_forallBndrs p_hsTyVarBndr bndrs
|
p_forallBndrs visibility p_hsTyVarBndr bndrs
|
||||||
interArgBreak
|
interArgBreak
|
||||||
p_hsType' multilineArgs (unLoc t)
|
p_hsType' multilineArgs (unLoc t)
|
||||||
HsQualTy NoExt qs t -> do
|
HsQualTy NoExtField qs t -> do
|
||||||
located qs p_hsContext
|
located qs p_hsContext
|
||||||
space
|
space
|
||||||
txt "=>"
|
txt "=>"
|
||||||
@ -40,7 +40,7 @@ p_hsType' multilineArgs = \case
|
|||||||
HsQualTy {} -> p_hsTypeR (unLoc t)
|
HsQualTy {} -> p_hsTypeR (unLoc t)
|
||||||
HsFunTy {} -> p_hsTypeR (unLoc t)
|
HsFunTy {} -> p_hsTypeR (unLoc t)
|
||||||
_ -> located t p_hsTypeR
|
_ -> located t p_hsTypeR
|
||||||
HsTyVar NoExt p n -> do
|
HsTyVar NoExtField p n -> do
|
||||||
case p of
|
case p of
|
||||||
IsPromoted -> do
|
IsPromoted -> do
|
||||||
txt "'"
|
txt "'"
|
||||||
@ -49,7 +49,7 @@ p_hsType' multilineArgs = \case
|
|||||||
_ -> return ()
|
_ -> return ()
|
||||||
NotPromoted -> return ()
|
NotPromoted -> return ()
|
||||||
p_rdrName n
|
p_rdrName n
|
||||||
HsAppTy NoExt f x -> sitcc $ do
|
HsAppTy NoExtField f x -> sitcc $ do
|
||||||
located f p_hsType
|
located f p_hsType
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located x p_hsType)
|
inci (located x p_hsType)
|
||||||
@ -62,7 +62,7 @@ p_hsType' multilineArgs = \case
|
|||||||
inci $ do
|
inci $ do
|
||||||
txt "@"
|
txt "@"
|
||||||
located kd p_hsType
|
located kd p_hsType
|
||||||
HsFunTy NoExt x y@(L _ y') -> do
|
HsFunTy NoExtField x y@(L _ y') -> do
|
||||||
located x p_hsType
|
located x p_hsType
|
||||||
space
|
space
|
||||||
txt "->"
|
txt "->"
|
||||||
@ -70,9 +70,9 @@ p_hsType' multilineArgs = \case
|
|||||||
case y' of
|
case y' of
|
||||||
HsFunTy {} -> p_hsTypeR y'
|
HsFunTy {} -> p_hsTypeR y'
|
||||||
_ -> located y p_hsTypeR
|
_ -> located y p_hsTypeR
|
||||||
HsListTy NoExt t ->
|
HsListTy NoExtField t ->
|
||||||
located t (brackets N . p_hsType)
|
located t (brackets N . p_hsType)
|
||||||
HsTupleTy NoExt tsort xs ->
|
HsTupleTy NoExtField tsort xs ->
|
||||||
let parens' =
|
let parens' =
|
||||||
case tsort of
|
case tsort of
|
||||||
HsUnboxedTuple -> parensHash N
|
HsUnboxedTuple -> parensHash N
|
||||||
@ -81,33 +81,33 @@ p_hsType' multilineArgs = \case
|
|||||||
HsBoxedOrConstraintTuple -> parens N
|
HsBoxedOrConstraintTuple -> parens N
|
||||||
in parens' . sitcc $
|
in parens' . sitcc $
|
||||||
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||||
HsSumTy NoExt xs ->
|
HsSumTy NoExtField xs ->
|
||||||
parensHash N . sitcc $
|
parensHash N . sitcc $
|
||||||
sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
|
sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
|
||||||
HsOpTy NoExt x op y ->
|
HsOpTy NoExtField x op y ->
|
||||||
sitcc $
|
sitcc $
|
||||||
let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
|
let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
|
||||||
in p_tyOpTree (reassociateOpTree Just opTree)
|
in p_tyOpTree (reassociateOpTree Just opTree)
|
||||||
HsParTy NoExt t ->
|
HsParTy NoExtField t ->
|
||||||
parens N (located t p_hsType)
|
parens N (located t p_hsType)
|
||||||
HsIParamTy NoExt n t -> sitcc $ do
|
HsIParamTy NoExtField n t -> sitcc $ do
|
||||||
located n atom
|
located n atom
|
||||||
space
|
space
|
||||||
txt "::"
|
txt "::"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located t p_hsType)
|
inci (located t p_hsType)
|
||||||
HsStarTy NoExt _ -> txt "*"
|
HsStarTy NoExtField _ -> txt "*"
|
||||||
HsKindSig NoExt t k -> sitcc $ do
|
HsKindSig NoExtField t k -> sitcc $ do
|
||||||
located t p_hsType
|
located t p_hsType
|
||||||
space -- FIXME
|
space -- FIXME
|
||||||
txt "::"
|
txt "::"
|
||||||
space
|
space
|
||||||
inci (located k p_hsType)
|
inci (located k p_hsType)
|
||||||
HsSpliceTy NoExt splice -> p_hsSplice splice
|
HsSpliceTy NoExtField splice -> p_hsSplice splice
|
||||||
HsDocTy NoExt t str -> do
|
HsDocTy NoExtField t str -> do
|
||||||
p_hsDocString Pipe True str
|
p_hsDocString Pipe True str
|
||||||
located t p_hsType
|
located t p_hsType
|
||||||
HsBangTy NoExt (HsSrcBang _ u s) t -> do
|
HsBangTy NoExtField (HsSrcBang _ u s) t -> do
|
||||||
case u of
|
case u of
|
||||||
SrcUnpack -> txt "{-# UNPACK #-}" >> space
|
SrcUnpack -> txt "{-# UNPACK #-}" >> space
|
||||||
SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
|
SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
|
||||||
@ -117,9 +117,9 @@ p_hsType' multilineArgs = \case
|
|||||||
SrcStrict -> txt "!"
|
SrcStrict -> txt "!"
|
||||||
NoSrcStrict -> return ()
|
NoSrcStrict -> return ()
|
||||||
located t p_hsType
|
located t p_hsType
|
||||||
HsRecTy NoExt fields ->
|
HsRecTy NoExtField fields ->
|
||||||
p_conDeclFields fields
|
p_conDeclFields fields
|
||||||
HsExplicitListTy NoExt p xs -> do
|
HsExplicitListTy NoExtField p xs -> do
|
||||||
case p of
|
case p of
|
||||||
IsPromoted -> txt "'"
|
IsPromoted -> txt "'"
|
||||||
NotPromoted -> return ()
|
NotPromoted -> return ()
|
||||||
@ -130,18 +130,18 @@ p_hsType' multilineArgs = \case
|
|||||||
(IsPromoted, L _ t : _) | isPromoted t -> space
|
(IsPromoted, L _ t : _) | isPromoted t -> space
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
|
||||||
HsExplicitTupleTy NoExt xs -> do
|
HsExplicitTupleTy NoExtField xs -> do
|
||||||
txt "'"
|
txt "'"
|
||||||
parens N $ do
|
parens N $ do
|
||||||
case xs of
|
case xs of
|
||||||
L _ t : _ | isPromoted t -> space
|
L _ t : _ | isPromoted t -> space
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
sep (comma >> breakpoint) (located' p_hsType) xs
|
sep (comma >> breakpoint) (located' p_hsType) xs
|
||||||
HsTyLit NoExt t ->
|
HsTyLit NoExtField t ->
|
||||||
case t of
|
case t of
|
||||||
HsStrTy (SourceText s) _ -> p_stringLit s
|
HsStrTy (SourceText s) _ -> p_stringLit s
|
||||||
a -> atom a
|
a -> atom a
|
||||||
HsWildCardTy NoExt -> txt "_"
|
HsWildCardTy NoExtField -> txt "_"
|
||||||
XHsType (NHsCoreTy t) -> atom t
|
XHsType (NHsCoreTy t) -> atom t
|
||||||
where
|
where
|
||||||
isPromoted = \case
|
isPromoted = \case
|
||||||
@ -173,26 +173,29 @@ p_hsContext = \case
|
|||||||
|
|
||||||
p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
|
p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
|
||||||
p_hsTyVarBndr = \case
|
p_hsTyVarBndr = \case
|
||||||
UserTyVar NoExt x ->
|
UserTyVar NoExtField x ->
|
||||||
p_rdrName x
|
p_rdrName x
|
||||||
KindedTyVar NoExt l k -> parens N $ do
|
KindedTyVar NoExtField l k -> parens N $ do
|
||||||
located l atom
|
located l atom
|
||||||
space
|
space
|
||||||
txt "::"
|
txt "::"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci (located k p_hsType)
|
inci (located k p_hsType)
|
||||||
XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
|
XTyVarBndr x -> noExtCon x
|
||||||
|
|
||||||
-- | Render several @forall@-ed variables.
|
-- | Render several @forall@-ed variables.
|
||||||
p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()
|
p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()
|
||||||
p_forallBndrs _ [] = txt "forall."
|
p_forallBndrs ForallInvis _ [] = txt "forall."
|
||||||
p_forallBndrs p tyvars =
|
p_forallBndrs ForallVis _ [] = txt "forall ->"
|
||||||
|
p_forallBndrs vis p tyvars =
|
||||||
switchLayout (getLoc <$> tyvars) $ do
|
switchLayout (getLoc <$> tyvars) $ do
|
||||||
txt "forall"
|
txt "forall"
|
||||||
breakpoint
|
breakpoint
|
||||||
inci $ do
|
inci $ do
|
||||||
sitcc $ sep breakpoint (sitcc . located' p) tyvars
|
sitcc $ sep breakpoint (sitcc . located' p) tyvars
|
||||||
txt "."
|
case vis of
|
||||||
|
ForallInvis -> txt "."
|
||||||
|
ForallVis -> space >> txt "->"
|
||||||
|
|
||||||
p_conDeclFields :: [LConDeclField GhcPs] -> R ()
|
p_conDeclFields :: [LConDeclField GhcPs] -> R ()
|
||||||
p_conDeclFields xs =
|
p_conDeclFields xs =
|
||||||
@ -211,10 +214,10 @@ p_conDeclField ConDeclField {..} = do
|
|||||||
txt "::"
|
txt "::"
|
||||||
breakpoint
|
breakpoint
|
||||||
sitcc . inci $ p_hsType (unLoc cd_fld_type)
|
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 :: 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)
|
OpBranch (tyOpTree l) op (tyOpTree r)
|
||||||
tyOpTree n = OpNode n
|
tyOpTree n = OpNode n
|
||||||
|
|
||||||
@ -235,17 +238,17 @@ p_tyOpTree (OpBranch l op r) = do
|
|||||||
tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
|
tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
|
||||||
tyVarsToTypes = \case
|
tyVarsToTypes = \case
|
||||||
HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
|
HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
|
||||||
XLHsQTyVars {} -> notImplemented "XLHsQTyVars"
|
XLHsQTyVars x -> noExtCon x
|
||||||
|
|
||||||
tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
|
tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
|
||||||
tyVarToType = \case
|
tyVarToType = \case
|
||||||
UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
|
UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar
|
||||||
KindedTyVar NoExt tvar kind ->
|
KindedTyVar NoExtField tvar kind ->
|
||||||
-- Note: we always add parentheses because for whatever reason GHC does
|
-- Note: we always add parentheses because for whatever reason GHC does
|
||||||
-- not use HsParTy for left-hand sides of declarations. Please see
|
-- not use HsParTy for left-hand sides of declarations. Please see
|
||||||
-- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
|
-- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
|
||||||
-- long as 'tyVarToType' does not get applied to right-hand sides of
|
-- long as 'tyVarToType' does not get applied to right-hand sides of
|
||||||
-- declarations.
|
-- declarations.
|
||||||
HsParTy NoExt $ noLoc $
|
HsParTy NoExtField $ noLoc $
|
||||||
HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
|
HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
|
||||||
XTyVarBndr {} -> notImplemented "XTyVarBndr"
|
XTyVarBndr x -> noExtCon x
|
||||||
|
@ -22,7 +22,7 @@ import Data.Maybe (fromMaybe)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import GHC
|
import GHC
|
||||||
import HsDoc (HsDocString, unpackHDS)
|
import GHC.Hs.Doc (HsDocString, unpackHDS)
|
||||||
import qualified Outputable as GHC
|
import qualified Outputable as GHC
|
||||||
|
|
||||||
-- | Combine all source spans from the given list.
|
-- | Combine all source spans from the given list.
|
||||||
|
Loading…
Reference in New Issue
Block a user