From 38cb72a997529366e510bd4aeacae01db75174cd Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 16 Oct 2024 21:00:31 +0200 Subject: [PATCH] ghc-lib-parser 9.12 --- cabal.project | 7 +++ .../declaration/data/wildcard-binders-out.hs | 1 + .../declaration/data/wildcard-binders.hs | 1 + .../declaration/default/default-out.hs | 8 +++ data/examples/declaration/default/default.hs | 7 +++ .../declaration/type/wildcard-binders-out.hs | 1 + .../declaration/type/wildcard-binders.hs | 1 + .../value/function/pattern/or-patterns-out.hs | 36 +++++++++++++ .../value/function/pattern/or-patterns.hs | 33 ++++++++++++ .../function/required-type-arguments-2-out.hs | 22 ++++++++ .../function/required-type-arguments-2.hs | 14 +++++ expected-failures/esqueleto.txt | 4 +- ormolu-live/cabal.project | 7 +++ ormolu.cabal | 6 +-- src/Ormolu/Imports.hs | 18 +++---- src/Ormolu/Parser.hs | 11 +++- src/Ormolu/Printer/Meat/Common.hs | 16 ++++++ src/Ormolu/Printer/Meat/Declaration.hs | 1 + .../Printer/Meat/Declaration/Default.hs | 7 ++- src/Ormolu/Printer/Meat/Declaration/OpTree.hs | 2 +- .../Printer/Meat/Declaration/Signature.hs | 2 +- src/Ormolu/Printer/Meat/Declaration/Value.hs | 49 +++++++++++++----- src/Ormolu/Printer/Meat/Type.hs | 51 ++++++++++--------- 23 files changed, 249 insertions(+), 56 deletions(-) create mode 100644 data/examples/declaration/data/wildcard-binders-out.hs create mode 100644 data/examples/declaration/data/wildcard-binders.hs create mode 100644 data/examples/declaration/type/wildcard-binders-out.hs create mode 100644 data/examples/declaration/type/wildcard-binders.hs create mode 100644 data/examples/declaration/value/function/pattern/or-patterns-out.hs create mode 100644 data/examples/declaration/value/function/pattern/or-patterns.hs create mode 100644 data/examples/declaration/value/function/required-type-arguments-2-out.hs create mode 100644 data/examples/declaration/value/function/required-type-arguments-2.hs diff --git a/cabal.project b/cabal.project index 126477571..6b7cafbc9 100644 --- a/cabal.project +++ b/cabal.project @@ -3,3 +3,10 @@ packages: . extract-hackage-info tests: True constraints: ormolu +dev + +source-repository-package + type: git + location: https://github.com/amesgen/stuff + tag: 7d822c8b35a7b8e5eb16a9d301f3f80eb613a525 + subdir: ghc-lib-parser-9.12.1.20241016 + --sha256: sha256-sFITJ2rJzH8beWJNT5ICiBFnjpR0uGlpKwu2wF7ElH4= diff --git a/data/examples/declaration/data/wildcard-binders-out.hs b/data/examples/declaration/data/wildcard-binders-out.hs new file mode 100644 index 000000000..20d13113f --- /dev/null +++ b/data/examples/declaration/data/wildcard-binders-out.hs @@ -0,0 +1 @@ +data Proxy _ = Proxy diff --git a/data/examples/declaration/data/wildcard-binders.hs b/data/examples/declaration/data/wildcard-binders.hs new file mode 100644 index 000000000..20d13113f --- /dev/null +++ b/data/examples/declaration/data/wildcard-binders.hs @@ -0,0 +1 @@ +data Proxy _ = Proxy diff --git a/data/examples/declaration/default/default-out.hs b/data/examples/declaration/default/default-out.hs index 681fe59d2..383e99367 100644 --- a/data/examples/declaration/default/default-out.hs +++ b/data/examples/declaration/default/default-out.hs @@ -1,3 +1,5 @@ +module MyModule (default Monoid) where + default (Int, Foo, Bar) default @@ -5,3 +7,9 @@ default Foo, Bar ) + +default Num (Int, Float) + +default IsList ([], Vector) + +default IsString (Text.Text, Foundation.String, String) diff --git a/data/examples/declaration/default/default.hs b/data/examples/declaration/default/default.hs index e0bda6b8d..86d2064d0 100644 --- a/data/examples/declaration/default/default.hs +++ b/data/examples/declaration/default/default.hs @@ -1,6 +1,13 @@ +module MyModule (default Monoid) where + default ( Int , Foo , Bar ) default ( Int , Foo, Bar ) + +default Num (Int, Float) +default IsList ([], Vector) + +default IsString (Text.Text, Foundation.String, String) diff --git a/data/examples/declaration/type/wildcard-binders-out.hs b/data/examples/declaration/type/wildcard-binders-out.hs new file mode 100644 index 000000000..07d23972c --- /dev/null +++ b/data/examples/declaration/type/wildcard-binders-out.hs @@ -0,0 +1 @@ +type Const a _ = a diff --git a/data/examples/declaration/type/wildcard-binders.hs b/data/examples/declaration/type/wildcard-binders.hs new file mode 100644 index 000000000..07d23972c --- /dev/null +++ b/data/examples/declaration/type/wildcard-binders.hs @@ -0,0 +1 @@ +type Const a _ = a diff --git a/data/examples/declaration/value/function/pattern/or-patterns-out.hs b/data/examples/declaration/value/function/pattern/or-patterns-out.hs new file mode 100644 index 000000000..8da9465e9 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/or-patterns-out.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PatternSynonyms #-} + +tasty (Cupcake; Cookie) = True +tasty (Liquorice; Raisins) = False + +f :: (Eq a, Show a) => a -> a -> Bool +f a ((== a) -> True; show -> "yes") = True +f _ _ = False + +small (abs -> (0; 1; 2); 3) = True -- -3 is not small +small _ = False + +type Coll a = Either [a] (Set a) + +pattern None <- (Left []; Right (toList -> [])) + +case e of + 1; 2; 3 -> x + 4; (5; 6) -> y + +sane e = case e of + 1 + 2 + 3 -> a + 4 + 5 + 6 -> b + 7; 8 -> c + +insane e = case e of + A _ _ + B _ + C -> 3 + (D; E (Just _) Nothing) -> + 4 + F -> 5 diff --git a/data/examples/declaration/value/function/pattern/or-patterns.hs b/data/examples/declaration/value/function/pattern/or-patterns.hs new file mode 100644 index 000000000..565b6ccb7 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/or-patterns.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE PatternSynonyms #-} + +tasty (Cupcake; Cookie) = True +tasty (Liquorice; Raisins) = False + +f :: (Eq a, Show a) => a -> a -> Bool +f a ((== a) -> True; show -> "yes") = True +f _ _ = False + +small (abs -> (0; 1; 2); 3) = True -- -3 is not small +small _ = False + +type Coll a = Either [a] (Set a) +pattern None <- (Left []; Right (toList -> [])) + +case e of + 1; 2; 3 -> x + 4; (5; 6) -> y + +sane e = case e of + 1 + 2 + 3 -> a + 4 + 5;6 -> b + 7;8 -> c + +insane e = case e of + A _ _; B _ + C -> 3 + (D; E (Just _) Nothing) + -> 4 + F -> 5 diff --git a/data/examples/declaration/value/function/required-type-arguments-2-out.hs b/data/examples/declaration/value/function/required-type-arguments-2-out.hs new file mode 100644 index 000000000..972dd5341 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments-2-out.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} + +ex1 = f (forall a. Proxy a) + +ex2 = f ((ctx) => Int) + +ex2' = f ((ctx, ctx') => Int) + +ex3 = f (String -> Bool) + +long = + f + ( forall m a. + (A a, M m) => + String -> + Bool %1 -> + Maybe Int -> + Maybe + (String, Int) %1 -> + Word %m -> Text + ) diff --git a/data/examples/declaration/value/function/required-type-arguments-2.hs b/data/examples/declaration/value/function/required-type-arguments-2.hs new file mode 100644 index 000000000..ed9fd626a --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments-2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LinearTypes #-} + +ex1 = f (forall a. Proxy a) +ex2 = f (ctx => Int) +ex2' = f ((ctx,ctx') => Int) +ex3 = f (String -> Bool) + +long = f (forall m a. (A a, M m) => String + -> Bool %1 -> + Maybe Int + -> Maybe + (String,Int) + ⊸ Word %m -> Text ) diff --git a/expected-failures/esqueleto.txt b/expected-failures/esqueleto.txt index a549c52a7..02d3d8ce5 100644 --- a/expected-failures/esqueleto.txt +++ b/expected-failures/esqueleto.txt @@ -1,3 +1,3 @@ -src/Database/Esqueleto/Internal/Internal.hs:434:1 +src/Database/Esqueleto/Internal/Internal.hs:(433,5)-(434,0) The GHC parser (in Haddock mode) failed: - [GHC-21231] lexical error in string/character literal at character 's' + [GHC-21231] lexical error at character 's' diff --git a/ormolu-live/cabal.project b/ormolu-live/cabal.project index 839b86234..d3d84c368 100644 --- a/ormolu-live/cabal.project +++ b/ormolu-live/cabal.project @@ -9,3 +9,10 @@ package ormolu package ghc-lib-parser -- The WASM backend does not support the threaded RTS. flags: -threaded-rts + +source-repository-package + type: git + location: https://github.com/amesgen/stuff + tag: 7d822c8b35a7b8e5eb16a9d301f3f80eb613a525 + subdir: ghc-lib-parser-9.12.1.20241016 + --sha256: sha256-sFITJ2rJzH8beWJNT5ICiBFnjpR0uGlpKwu2wF7ElH4= diff --git a/ormolu.cabal b/ormolu.cabal index 0423bb536..374e42091 100644 --- a/ormolu.cabal +++ b/ormolu.cabal @@ -115,7 +115,7 @@ library directory ^>=1.3, file-embed >=0.0.15 && <0.1, filepath >=1.2 && <1.6, - ghc-lib-parser >=9.10 && <9.11, + ghc-lib-parser >=9.12 && <9.13, megaparsec >=9, mtl >=2 && <3, syb >=0.7 && <0.8, @@ -148,7 +148,7 @@ executable ormolu containers >=0.5 && <0.8, directory ^>=1.3, filepath >=1.2 && <1.6, - ghc-lib-parser >=9.10 && <9.11, + ghc-lib-parser >=9.12 && <9.13, optparse-applicative >=0.14 && <0.19, ormolu, text >=2.1 && <3, @@ -201,7 +201,7 @@ test-suite tests containers >=0.5 && <0.8, directory ^>=1.3, filepath >=1.2 && <1.6, - ghc-lib-parser >=9.10 && <9.11, + ghc-lib-parser >=9.12 && <9.13, hspec >=2 && <3, hspec-megaparsec >=2.2, megaparsec >=9, diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs index 71140eb06..96401b997 100644 --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -17,6 +17,7 @@ import Data.Function (on) import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as M +import Data.Ord (comparing) import GHC.Data.FastString import GHC.Hs import GHC.Hs.ImpExp as GHC @@ -207,15 +208,14 @@ compareLIewn = compareIewn `on` unLoc -- | Compare two @'IEWrapppedName' 'GhcPs'@ things. compareIewn :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering -compareIewn (IEName _ x) (IEName _ y) = unLoc x `compareRdrName` unLoc y -compareIewn (IEName _ _) (IEPattern _ _) = LT -compareIewn (IEName _ _) (IEType _ _) = LT -compareIewn (IEPattern _ _) (IEName _ _) = GT -compareIewn (IEPattern _ x) (IEPattern _ y) = unLoc x `compareRdrName` unLoc y -compareIewn (IEPattern _ _) (IEType _ _) = LT -compareIewn (IEType _ _) (IEName _ _) = GT -compareIewn (IEType _ _) (IEPattern _ _) = GT -compareIewn (IEType _ x) (IEType _ y) = unLoc x `compareRdrName` unLoc y +compareIewn = (comparing fst <> (compareRdrName `on` unLoc . snd)) `on` classify + where + classify :: IEWrappedName GhcPs -> (Int, LocatedN RdrName) + classify = \case + IEName _ x -> (0, x) + IEDefault _ x -> (1, x) + IEPattern _ x -> (2, x) + IEType _ x -> (3, x) compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y = diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs index 10a43456f..d9c20b046 100644 --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -175,7 +175,11 @@ parseModuleSnippet Config {..} modFixityMap dynFlags path rawInput = liftIO $ do normalizeModule :: HsModule GhcPs -> HsModule GhcPs normalizeModule hsmod = everywhere - (mkT dropBlankTypeHaddocks `extT` dropBlankDataDeclHaddocks `extT` patchContext) + ( mkT dropBlankTypeHaddocks + `extT` dropBlankDataDeclHaddocks + `extT` patchContext + `extT` patchExprContext + ) hsmod { hsmodImports = normalizeImports (hsmodImports hsmod), @@ -214,6 +218,11 @@ normalizeModule hsmod = [x@(L _ (HsParTy _ _))] -> [x] [x@(L lx _)] -> [L lx (HsParTy noAnn x)] xs -> xs + -- TODO document why we do it like this + patchExprContext :: LHsExpr GhcPs -> LHsExpr GhcPs + patchExprContext = fmap $ \case + HsQual l0 (L l1 [L _ (HsPar _ x)]) e -> HsQual l0 (L l1 [x]) e + x -> x -- | Enable all language extensions that we think should be enabled by -- default for ease of use. diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs index 6b8d00c89..527d3753c 100644 --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -15,6 +15,7 @@ module Ormolu.Printer.Meat.Common p_hsDocName, p_sourceText, p_namespaceSpec, + p_arrow, ) where @@ -33,6 +34,7 @@ import GHC.Types.Name.Occurrence (OccName (..), occNameString) import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc +import Language.Haskell.Syntax (HsArrowOf (..)) import Language.Haskell.Syntax.Module.Name import Ormolu.Config (SourceType (..)) import Ormolu.Printer.Combinators @@ -58,6 +60,10 @@ p_hsmodName mname = do p_ieWrappedName :: IEWrappedName GhcPs -> R () p_ieWrappedName = \case IEName _ x -> p_rdrName x + IEDefault _ x -> do + txt "default" + space + p_rdrName x IEPattern _ x -> do txt "pattern" space @@ -201,3 +207,13 @@ p_namespaceSpec = \case NoNamespaceSpecifier -> pure () TypeNamespaceSpecifier _ -> txt "type" *> space DataNamespaceSpecifier _ -> txt "data" *> space + +p_arrow :: (mult -> R ()) -> HsArrowOf mult GhcPs -> R () +p_arrow p_mult = \case + HsUnrestrictedArrow _ -> txt "->" + HsLinearArrow _ -> txt "%1 ->" + HsExplicitMult _ mult -> do + txt "%" + p_mult mult + space + txt "->" diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs index d3d17ae56..28fbf2424 100644 --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -313,6 +313,7 @@ warnSigRdrNames _ = Nothing patBindNames :: Pat GhcPs -> [RdrName] patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps +patBindNames (OrPat _ ps) = foldMap (patBindNames . unLoc) ps patBindNames (VarPat _ (L _ n)) = [n] patBindNames (WildPat _) = [] patBindNames (LazyPat _ (L _ p)) = patBindNames p diff --git a/src/Ormolu/Printer/Meat/Declaration/Default.hs b/src/Ormolu/Printer/Meat/Declaration/Default.hs index d4c3a4ef3..b52ddca01 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Default.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Default.hs @@ -5,13 +5,18 @@ module Ormolu.Printer.Meat.Declaration.Default ) where +import GHC.Data.Maybe (whenIsJust) import GHC.Hs import Ormolu.Printer.Combinators +import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type p_defaultDecl :: DefaultDecl GhcPs -> R () -p_defaultDecl (DefaultDecl _ ts) = do +p_defaultDecl (DefaultDecl _ mclass ts) = do txt "default" + whenIsJust mclass $ \c -> do + breakpoint + p_rdrName c breakpoint inci . parens N $ sep commaDel (sitcc . located' p_hsType) ts diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs index e953fcc8e..04a9e15f5 100644 --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -169,7 +169,7 @@ p_exprOpTree s t@(OpBranches exprs@(firstExpr :| otherExprs) ops) = do -- intermediate representation. cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) cmdOpTree = \case - (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix _ [x, y])))) -> + (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix [x, y])))) -> BinaryOpBranches (cmdOpTree x) op (cmdOpTree y) n -> OpNode n diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs index 6f876e29d..bdf95716d 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -93,7 +93,7 @@ p_fixSig :: FixitySig GhcPs -> R () p_fixSig = \case - FixitySig namespace names (Fixity _ n dir) -> do + FixitySig namespace names (Fixity n dir) -> do txt $ case dir of InfixL -> "infixl" InfixR -> "infixr" diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs index 60832a72f..365e64e13 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -32,7 +32,6 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text import Data.Void -import GHC.Data.Bag (bagToList) import GHC.Data.FastString import GHC.Data.Strict qualified as Strict import GHC.Hs @@ -119,7 +118,7 @@ p_matchGroup' placer render style mg@MG {..} = do (isInfixMatch m) (HsNoMultAnn NoExtField) (matchStrictness m) - m_pats + (unLoc m_pats) -- TODO m_grhss -- | Function id obtained through pattern matching on 'FunBind' should not @@ -355,19 +354,19 @@ p_hsCmd' isApp s = \case (HsHigherOrderApp, False) -> txt ">>-" placeHanging (exprPlacement (unLoc input)) $ located r p_hsExpr - HsCmdArrForm _ form Prefix _ cmds -> banana s $ do + HsCmdArrForm _ form Prefix cmds -> banana s $ do located form p_hsExpr unless (null cmds) $ do breakpoint inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds))) - HsCmdArrForm _ form Infix _ [left, right] -> do + HsCmdArrForm _ form Infix [left, right] -> do modFixityMap <- askModuleFixityMap debug <- askDebug let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right) p_cmdOpTree s (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree) - HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm" + HsCmdArrForm _ _ Infix _ -> notImplemented "HsCmdArrForm" HsCmdApp _ cmd expr -> do located cmd (p_hsCmd' Applicand s) breakpoint @@ -444,7 +443,6 @@ p_stmt' s placer render = \case | otherwise = Normal switchLayout [loc, l] $ placeHanging placement (located f (render N)) - ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer BodyStmt _ body _ _ -> located body (render s) LetStmt _ binds -> do txt "let" @@ -520,7 +518,7 @@ p_stmts s isApp placer render es = do p_hsLocalBinds :: HsLocalBinds GhcPs -> R () p_hsLocalBinds = \case - HsValBinds epAnn (ValBinds _ bag lsigs) -> pseudoLocated epAnn $ do + HsValBinds epAnn (ValBinds _ binds lsigs) -> pseudoLocated epAnn $ do -- When in a single-line layout, there is a chance that the inner -- elements will also contain semicolons and they will confuse the -- parser. so we request braces around every element except the last. @@ -528,7 +526,7 @@ p_hsLocalBinds = \case let items = let injectLeft (L l x) = L l (Left x) injectRight (L l x) = L l (Right x) - in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs) + in (injectLeft <$> binds) ++ (injectRight <$> lsigs) positionToBracing = \case SinglePos -> id FirstPos -> br @@ -537,8 +535,8 @@ p_hsLocalBinds = \case p_item' (p, item) = positionToBracing p $ withSpacing (either p_valDecl p_sigDecl) item - binds = sortBy (leftmost_smallest `on` getLocA) items - sitcc $ sepSemi p_item' (attachRelativePos binds) + items' = sortBy (leftmost_smallest `on` getLocA) items + sitcc $ sepSemi p_item' (attachRelativePos items') HsValBinds _ _ -> notImplemented "HsValBinds" HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do let p_ipBind (IPBind _ (L _ name) expr) = do @@ -608,7 +606,7 @@ p_hsExpr' isApp s = \case HsVar _ name -> p_rdrName name HsUnboundVar _ occ -> atom occ HsRecSel _ fldOcc -> p_fieldOcc fldOcc - HsOverLabel _ sourceText _ -> do + HsOverLabel sourceText _ -> do txt "#" p_sourceText sourceText HsIPVar _ (HsIPName name) -> do @@ -848,6 +846,27 @@ p_hsExpr' isApp s = \case txt "type" space located hswc_body p_hsType + -- similar to HsForAllTy + HsForAll _ tele e -> do + p_hsForAllTelescope tele + breakpoint + located e p_hsExpr + -- similar to HsQualTy + HsQual _ qs e -> do + located qs $ parens N . sep commaDel (sitcc . located' p_hsExpr) + space + txt "=>" + breakpoint + located e p_hsExpr + -- similar to HsFunTy + HsFunArr _ arrow x y -> do + located x p_hsExpr + space + p_arrow (located' p_hsExpr) arrow + breakpoint + located y p_hsExpr + +-- analogous to HsQualTy -- | Print a list comprehension. -- @@ -947,7 +966,7 @@ gatherStmts = \case -- will be ParStmt. [L _ (ParStmt _ blocks _ _)] -> [ concatMap collectNonParStmts stmts - | ParStmtBlock _ stmts _ _ <- blocks + | ParStmtBlock _ stmts _ _ <- blocks ] -- Otherwise, list will not contain any ParStmt stmts -> @@ -1157,6 +1176,8 @@ p_pat = \case Boxed -> parens S Unboxed -> parensHash S parens' $ sep commaDel (sitcc . located' p_pat) pats + OrPat _ pats -> + sepSemi (located' p_pat) (NE.toList pats) SumPat _ pat tag arity -> p_unboxedSum S tag arity (located pat p_pat) ConPat _ pat details -> @@ -1167,7 +1188,7 @@ p_pat = \case inci . sitcc $ sep breakpoint (sitcc . either p_hsConPatTyArg (located' p_pat)) $ (Left <$> tys) <> (Right <$> xs) - RecCon (HsRecFields fields dotdot) -> do + RecCon (HsRecFields _ fields dotdot) -> do p_rdrName pat breakpoint let f = \case @@ -1394,7 +1415,7 @@ exprPlacement = \case -- Only hang lambdas with single line parameter lists HsLam _ variant mg -> case variant of LamSingle -> case mg of - MG _ (L _ [L _ (Match _ _ (x : xs) _)]) + MG _ (L _ [L _ (Match _ _ (L _ (x : xs)) _)]) | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> Hanging _ -> Normal diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs index cc61be66a..64820ba7a 100644 --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -16,6 +16,7 @@ module Ormolu.Printer.Meat.Type p_conDeclFields, p_lhsTypeArg, p_hsSigType, + p_hsForAllTelescope, hsOuterTyVarBndrsToHsType, lhsTypeToSigType, ) @@ -40,9 +41,7 @@ p_hsType t = p_hsType' (hasDocStrings t) t p_hsType' :: Bool -> HsType GhcPs -> R () p_hsType' multilineArgs = \case HsForAllTy _ tele t -> do - case tele of - HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs - HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs + p_hsForAllTelescope tele interArgBreak located t p_hsType HsQualTy _ qs t -> do @@ -89,14 +88,7 @@ p_hsType' multilineArgs = \case HsFunTy _ arrow x y@(L _ y') -> do located x p_hsType space - case arrow of - HsUnrestrictedArrow _ -> txt "->" - HsLinearArrow _ -> txt "%1 ->" - HsExplicitMult _ mult -> do - txt "%" - p_hsTypeR (unLoc mult) - space - txt "->" + p_arrow (located' p_hsTypeR) arrow interArgBreak case y' of HsFunTy {} -> p_hsTypeR y' @@ -140,7 +132,7 @@ p_hsType' multilineArgs = \case HsDocTy _ t str -> do p_hsDoc Pipe (With #endNewline) str located t p_hsType - HsBangTy _ (HsSrcBang _ u s) t -> do + HsBangTy _ (HsBang u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-}" >> space SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space @@ -226,18 +218,24 @@ instance IsTyVarBndrFlag (HsBndrVis GhcPs) where HsBndrInvisible _ -> txt "@" p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R () -p_hsTyVarBndr = \case - UserTyVar _ flag x -> do - p_tyVarBndrFlag flag - (if isInferred flag then braces N else id) $ p_rdrName x - KindedTyVar _ flag l k -> do - p_tyVarBndrFlag flag - (if isInferred flag then braces else parens) N $ do - located l atom - space - txt "::" - breakpoint - inci (located k p_hsType) +p_hsTyVarBndr HsTvb {..} = do + p_tyVarBndrFlag tvb_flag + let wrap + | isInferred tvb_flag = braces N + | otherwise = case tvb_kind of + HsBndrKind {} -> parens N + HsBndrNoKind {} -> id + wrap $ do + case tvb_var of + HsBndrVar _ x -> p_rdrName x + HsBndrWildCard _ -> txt "_" + case tvb_kind of + HsBndrKind _ k -> do + space + txt "::" + breakpoint + inci (located k p_hsType) + HsBndrNoKind _ -> pure () data ForAllVisibility = ForAllInvis | ForAllVis @@ -290,6 +288,11 @@ p_hsSigType :: HsSigType GhcPs -> R () p_hsSigType HsSig {..} = p_hsType $ hsOuterTyVarBndrsToHsType sig_bndrs sig_body +p_hsForAllTelescope :: HsForAllTelescope GhcPs -> R () +p_hsForAllTelescope = \case + HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs + HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs + ---------------------------------------------------------------------------- -- Conversion functions