Implement (Infix|Prefix)Operator (#910)

hindent.cabal

@@ -102,6 +102,8 @@ library
       HIndent.Ast.Module.Name
       HIndent.Ast.Module.Warning
       HIndent.Ast.NodeComments
+      HIndent.Ast.Operator.Infix
+      HIndent.Ast.Operator.Prefix
       HIndent.Ast.Role
       HIndent.Ast.Type
       HIndent.Ast.Type.Variable

src/HIndent/Ast/Declaration/Bind.hs

@@ -7,6 +7,7 @@ module HIndent.Ast.Declaration.Bind
   ) where
 
 import HIndent.Ast.NodeComments
+import HIndent.Ast.Operator.Infix
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
@@ -45,7 +46,7 @@ instance Pretty Bind where
     string "pattern "
     case parameters of
       GHC.InfixCon l r ->
-        spaced [pretty l, pretty $ fmap InfixOp name, pretty r]
+        spaced [pretty l, pretty $ fmap mkInfixOperator name, pretty r]
       GHC.PrefixCon _ [] -> pretty name
       _ -> spaced [pretty name, pretty parameters]
     spacePrefixed [pretty direction, pretty $ fmap PatInsidePatDecl definition]

src/HIndent/Ast/Declaration/Class/NameAndTypeVariables.hs

@@ -7,13 +7,13 @@ module HIndent.Ast.Declaration.Class.NameAndTypeVariables
 
 import qualified GHC.Types.Fixity as GHC
 import HIndent.Ast.NodeComments
+import HIndent.Ast.Operator.Infix
 import HIndent.Ast.Type.Variable
 import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
 import HIndent.Pretty.NodeComments
-import HIndent.Pretty.Types
 
 data NameAndTypeVariables
   = Prefix
@@ -34,7 +34,8 @@ instance CommentExtraction NameAndTypeVariables where
 instance Pretty NameAndTypeVariables where
   pretty' Prefix {..} = spaced $ pretty name : fmap pretty typeVariables
   pretty' Infix {..} = do
-    parens $ spaced [pretty left, pretty $ fmap InfixOp name, pretty right]
+    parens
+      $ spaced [pretty left, pretty $ fmap mkInfixOperator name, pretty right]
     spacePrefixed $ fmap pretty remains
 
 mkNameAndTypeVariables :: GHC.TyClDecl GHC.GhcPs -> Maybe NameAndTypeVariables

src/HIndent/Ast/Declaration/Data/Haskell98/Constructor/Body.hs

@@ -8,12 +8,12 @@ module HIndent.Ast.Declaration.Data.Haskell98.Constructor.Body
 
 import HIndent.Ast.Declaration.Data.Record.Field
 import HIndent.Ast.NodeComments
+import HIndent.Ast.Operator.Infix
 import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
 import HIndent.Pretty.NodeComments
-import HIndent.Pretty.Types
 
 data Haskell98ConstructorBody
   = Infix
@@ -37,7 +37,7 @@ instance CommentExtraction Haskell98ConstructorBody where
 
 instance Pretty Haskell98ConstructorBody where
   pretty' Infix {..} =
-    spaced [pretty left, pretty $ fmap InfixOp name, pretty right]
+    spaced [pretty left, pretty $ fmap mkInfixOperator name, pretty right]
   pretty' Prefix {..} = pretty name >> hor <-|> ver
     where
       hor = spacePrefixed $ fmap pretty types

src/HIndent/Ast/Declaration/Signature.hs

@@ -14,6 +14,7 @@ import HIndent.Ast.Declaration.Signature.Fixity
 import HIndent.Ast.Declaration.Signature.Inline.Phase
 import HIndent.Ast.Declaration.Signature.Inline.Spec
 import HIndent.Ast.NodeComments
+import HIndent.Ast.Operator.Infix
 import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
@@ -121,7 +122,8 @@ instance Pretty Signature where
           $ indentedWithSpace 3
           $ printCommentsAnd signature (pretty . HsSigTypeInsideDeclSig)
   pretty' Fixity {..} =
-    spaced [pretty fixity, hCommaSep $ fmap (pretty . fmap InfixOp) names]
+    spaced
+      [pretty fixity, hCommaSep $ fmap (pretty . fmap mkInfixOperator) names]
   pretty' Inline {..} = do
     string "{-# "
     pretty spec

src/HIndent/Ast/Declaration/TypeSynonym/Lhs.hs

@@ -7,13 +7,13 @@ module HIndent.Ast.Declaration.TypeSynonym.Lhs
 
 import qualified GHC.Types.Fixity as GHC
 import HIndent.Ast.NodeComments
+import HIndent.Ast.Operator.Infix
 import HIndent.Ast.Type.Variable
 import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
 import HIndent.Pretty.NodeComments
-import HIndent.Pretty.Types
 
 data TypeSynonymLhs
   = Prefix
@@ -33,7 +33,7 @@ instance CommentExtraction TypeSynonymLhs where
 instance Pretty TypeSynonymLhs where
   pretty' Prefix {..} = spaced $ pretty name : fmap pretty typeVariables
   pretty' Infix {..} =
-    spaced [pretty left, pretty $ fmap InfixOp name, pretty right]
+    spaced [pretty left, pretty $ fmap mkInfixOperator name, pretty right]
 
 mkTypeSynonymLhs :: GHC.TyClDecl GHC.GhcPs -> TypeSynonymLhs
 mkTypeSynonymLhs GHC.SynDecl {tcdFixity = GHC.Prefix, ..} =

src/HIndent/Ast/Operator/Infix.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Operator.Infix
+  ( InfixOperator
+  , mkInfixOperator
+  ) where
+
+import Data.Maybe
+import qualified GHC.Types.Name as GHC
+import qualified GHC.Types.Name.Reader as GHC
+import qualified GHC.Unit.Module as GHC
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data InfixOperator = InfixOperator
+  { name :: GHC.OccName
+  , moduleName :: Maybe GHC.ModuleName
+  , backtick :: Bool
+  }
+
+instance CommentExtraction InfixOperator where
+  nodeComments InfixOperator {} = NodeComments [] [] []
+
+instance Pretty InfixOperator where
+  pretty' InfixOperator {..} =
+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ pretty name]
+    where
+      wrap =
+        if backtick
+          then backticks
+          else id
+
+mkInfixOperator :: GHC.RdrName -> InfixOperator
+mkInfixOperator (GHC.Unqual name) =
+  InfixOperator name Nothing (backticksNeeded name)
+mkInfixOperator (GHC.Qual modName name) =
+  InfixOperator name (Just modName) (backticksNeeded name)
+mkInfixOperator (GHC.Orig {}) =
+  error "This AST node should not appear in the parser output."
+mkInfixOperator (GHC.Exact name) =
+  InfixOperator (GHC.occName name) Nothing (backticksNeeded $ GHC.occName name)
+
+backticksNeeded :: GHC.OccName -> Bool
+backticksNeeded = not . GHC.isSymOcc

src/HIndent/Ast/Operator/Prefix.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Operator.Prefix
+  ( PrefixOperator
+  , mkPrefixOperator
+  ) where
+
+import Data.Maybe
+import qualified GHC.Types.Name as GHC
+import qualified GHC.Types.Name.Reader as GHC
+import qualified GHC.Unit.Module as GHC
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data PrefixOperator = PrefixOperator
+  { name :: String
+  , moduleName :: Maybe GHC.ModuleName
+  , parentheses :: Bool
+  }
+
+instance CommentExtraction PrefixOperator where
+  nodeComments PrefixOperator {} = NodeComments [] [] []
+
+instance Pretty PrefixOperator where
+  pretty' PrefixOperator {..} =
+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ string name]
+    where
+      wrap =
+        if parentheses
+          then parens
+          else id
+
+mkPrefixOperator :: GHC.RdrName -> PrefixOperator
+mkPrefixOperator (GHC.Unqual name) =
+  PrefixOperator (showOutputable name) Nothing (parensNeeded name)
+mkPrefixOperator (GHC.Qual modName name) =
+  PrefixOperator (showOutputable name) (Just modName) (parensNeeded name)
+mkPrefixOperator (GHC.Orig {}) =
+  error "This AST node should not appear in the parser output."
+mkPrefixOperator (GHC.Exact name) =
+  PrefixOperator (showOutputable name) Nothing (parensNeeded $ GHC.occName name)
+
+parensNeeded :: GHC.OccName -> Bool
+parensNeeded = GHC.isSymOcc

src/HIndent/Pretty.hs

@@ -42,6 +42,8 @@ import HIndent.Ast.Declaration.Data.Record.Field
 import HIndent.Ast.Declaration.Family.Type
 import HIndent.Ast.Declaration.Signature
 import HIndent.Ast.NodeComments
+import HIndent.Ast.Operator.Infix
+import HIndent.Ast.Operator.Prefix
 import HIndent.Ast.Type.Variable
 import HIndent.Ast.WithComments
 import HIndent.Config
@@ -149,7 +151,7 @@ instance Pretty (GHC.HsExpr GHC.GhcPs) where
   pretty' = prettyHsExpr
 
 prettyHsExpr :: GHC.HsExpr GHC.GhcPs -> Printer ()
-prettyHsExpr (GHC.HsVar _ bind) = pretty $ fmap PrefixOp bind
+prettyHsExpr (GHC.HsVar _ bind) = pretty $ fmap mkPrefixOperator bind
 prettyHsExpr (GHC.HsUnboundVar _ x) = pretty x
 #if MIN_VERSION_ghc_lib_parser(9,6,1)
 prettyHsExpr (GHC.HsOverLabel _ _ l) = string "#" >> string (GHC.unpackFS l)
@@ -548,7 +550,7 @@ prettyMatchExpr GHC.Match {..} =
       case (m_pats, m_ctxt) of
         (l:r:xs, GHC.FunRhs {..}) -> do
           spaced
-            $ [pretty l, pretty $ fmap InfixOp mc_fun, pretty r]
+            $ [pretty l, pretty $ fmap mkInfixOperator mc_fun, pretty r]
                 ++ fmap pretty xs
           pretty m_grhss
         _ -> error "Not enough parameters are passed."
@@ -729,21 +731,21 @@ prettyHsType (GHC.HsOpTy _ _ l op r) = do
     then do
       pretty l
       newline
-      pretty $ fmap InfixOp op
+      pretty $ fmap mkInfixOperator op
       space
       pretty r
-    else spaced [pretty l, pretty $ fmap InfixOp op, pretty r]
+    else spaced [pretty l, pretty $ fmap mkInfixOperator op, pretty r]
 #else
 prettyHsType (GHC.HsOpTy _ l op r) = do
   lineBreak <- gets (configLineBreaks . psConfig)
   if showOutputable op `elem` lineBreak
     then do
       pretty l
       newline
-      pretty $ fmap InfixOp op
+      pretty $ fmap mkInfixOperator op
       space
       pretty r
-    else spaced [pretty l, pretty $ fmap InfixOp op, pretty r]
+    else spaced [pretty l, pretty $ fmap mkInfixOperator op, pretty r]
 #endif
 prettyHsType (GHC.HsParTy _ inside) = parens $ pretty inside
 prettyHsType (GHC.HsIParamTy _ x ty) =
@@ -828,7 +830,7 @@ instance Pretty ParStmtBlockInsideVerticalList where
     vCommaSep $ fmap pretty xs
 
 instance Pretty GHC.RdrName where
-  pretty' = pretty . PrefixOp
+  pretty' = pretty . mkPrefixOperator
 
 instance Pretty
            (GHC.GRHS
@@ -947,7 +949,7 @@ instance Pretty (GHC.Pat GHC.GhcPs) where
 
 instance Pretty PatInsidePatDecl where
   pretty' (PatInsidePatDecl (GHC.ConPat {pat_args = (GHC.InfixCon l r), ..})) =
-    spaced [pretty l, pretty $ fmap InfixOp pat_con, pretty r]
+    spaced [pretty l, pretty $ fmap mkInfixOperator pat_con, pretty r]
   pretty' (PatInsidePatDecl x) = pretty x
 
 prettyPat :: GHC.Pat GHC.GhcPs -> Printer ()
@@ -979,13 +981,13 @@ prettyPat (GHC.SumPat _ x position numElem) = do
 prettyPat GHC.ConPat {..} =
   case pat_args of
     GHC.PrefixCon _ as -> do
-      pretty $ fmap PrefixOp pat_con
+      pretty $ fmap mkPrefixOperator pat_con
       spacePrefixed $ fmap pretty as
     GHC.RecCon rec -> (pretty pat_con >> space) |=> pretty (RecConPat rec)
     GHC.InfixCon a b -> do
       pretty a
       unlessSpecialOp (GHC.unLoc pat_con) space
-      pretty $ fmap InfixOp pat_con
+      pretty $ fmap mkInfixOperator pat_con
       unlessSpecialOp (GHC.unLoc pat_con) space
       pretty b
 prettyPat (GHC.ViewPat _ l r) = spaced [pretty l, string "->", pretty r]
@@ -1122,7 +1124,8 @@ instance Pretty a => Pretty (GHC.HsScaled GHC.GhcPs a) where
   pretty' (GHC.HsScaled _ x) = pretty x
 
 instance Pretty InfixExpr where
-  pretty' (InfixExpr (GHC.L _ (GHC.HsVar _ bind))) = pretty $ fmap InfixOp bind
+  pretty' (InfixExpr (GHC.L _ (GHC.HsVar _ bind))) =
+    pretty $ fmap mkInfixOperator bind
   pretty' (InfixExpr x) = pretty' x
 
 instance Pretty InfixApp where
@@ -1218,30 +1221,6 @@ instance Pretty (GHC.HsForAllTelescope GHC.GhcPs) where
       $ fmap (pretty . fmap mkTypeVariable . fromGenLocated) hsf_invis_bndrs
     dot
 
-instance Pretty InfixOp where
-  pretty' (InfixOp (GHC.Unqual name)) = backticksIfNotSymbol name $ pretty name
-  pretty' (InfixOp (GHC.Qual modName name)) =
-    backticksIfNotSymbol name $ do
-      pretty modName
-      string "."
-      pretty name
-  pretty' (InfixOp GHC.Orig {}) = notUsedInParsedStage
-  pretty' (InfixOp (GHC.Exact name)) = backticksIfNotSymbol occ $ pretty occ
-    where
-      occ = GHC.occName name
-
-instance Pretty PrefixOp where
-  pretty' (PrefixOp (GHC.Unqual name)) = parensIfSymbol name $ pretty name
-  pretty' (PrefixOp (GHC.Qual modName name)) =
-    parensIfSymbol name $ do
-      pretty modName
-      string "."
-      pretty name
-  pretty' (PrefixOp GHC.Orig {}) = notUsedInParsedStage
-  pretty' (PrefixOp (GHC.Exact name)) = parensIfSymbol occ $ output name
-    where
-      occ = GHC.occName name
-
 instance Pretty Context where
   pretty' (Context xs) =
     pretty (HorizontalContext xs) <-|> pretty (VerticalContext xs)

src/HIndent/Pretty.hs-boot

@@ -8,9 +8,11 @@ module HIndent.Pretty
   ) where
 
 import           Data.Void
+import qualified GHC.Types.Name                     as GHC
 import qualified GHC.Types.Name.Reader              as GHC
 import qualified GHC.Types.SourceText               as GHC
 import qualified GHC.Types.SrcLoc                   as GHC
+import qualified GHC.Unit                           as GHC
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHc
 import           HIndent.Pretty.NodeComments
@@ -44,8 +46,6 @@ instance Pretty GHC.RdrName
 
 instance Pretty SigBindFamily
 
-instance Pretty InfixOp
-
 instance Pretty HsSigType'
 
 instance Pretty
@@ -98,3 +98,7 @@ instance Pretty (GHC.HsUntypedSplice GHC.GhcPs)
 instance Pretty (GHC.HsSplice GHC.GhcPs)
 #endif
 instance Pretty (GHC.FieldOcc GHC.GhcPs)
+
+instance Pretty GHC.OccName
+
+instance Pretty GHC.ModuleName