ghc-lib-parser 9.12

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=

data/examples/declaration/data/wildcard-binders-out.hs

@@ -0,0 +1 @@
+data Proxy _ = Proxy

data/examples/declaration/data/wildcard-binders.hs

@@ -0,0 +1 @@
+data Proxy _ = Proxy

data/examples/declaration/default/default-out.hs

@@ -1,7 +1,15 @@
+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)

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)

data/examples/declaration/type/wildcard-binders-out.hs

@@ -0,0 +1 @@
+type Const a _ = a

data/examples/declaration/type/wildcard-binders.hs

@@ -0,0 +1 @@
+type Const a _ = a

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

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

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
+    )

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 )

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'

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=

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,

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 =

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.

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 "->"

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

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

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
 

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"