content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE ViewPatterns #-}
  
  module HIndent.Ast.Expression
    ( Expression
    , GuardExpression
    , mkExpression
    , mkGuardExpression
    ) where
  
  import Control.Monad
  import Control.Monad.RWS (gets)
  import Data.List.NonEmpty (NonEmpty(..), (<|))
  import qualified Data.List.NonEmpty as NonEmpty
  import qualified GHC.Hs as GHC
  import qualified GHC.Types.Basic as GHC
  import qualified GHC.Types.Fixity as GHC
  import qualified GHC.Types.SrcLoc as GHC
  import HIndent.Ast.Expression.Bracket (Bracket, mkBracket)
  import qualified HIndent.Ast.Expression.ListComprehension as LC
  import HIndent.Ast.Expression.OverloadedLabel
    ( OverloadedLabel
    , mkOverloadedLabel
    )
  import HIndent.Ast.Expression.RangeExpression
    ( RangeExpression
    , mkRangeExpression
    )
  import HIndent.Ast.Expression.RecordUpdateField (mkRecordUpdateFields)
  import HIndent.Ast.Guard (Guard, mkMultiWayIfExprGuard)
  import HIndent.Ast.Module.Name (mkModuleName)
  import HIndent.Ast.Name.Prefix
  import HIndent.Ast.NodeComments (NodeComments(..))
  import HIndent.Ast.Pattern
  import HIndent.Ast.Type
  import HIndent.Ast.Type.ImplicitParameterName
    ( ImplicitParameterName
    , mkImplicitParameterName
    )
  import HIndent.Ast.WithComments
  import HIndent.CabalFile ()
  import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty, printCommentsAnd)
  import HIndent.Pretty.Combinators
  import HIndent.Pretty.NodeComments
  import HIndent.Pretty.Types (DoOrMdo(..), QualifiedDo(..))
  import HIndent.Printer
  import qualified Language.Haskell.Syntax.Basic as HS
  #if MIN_VERSION_ghc_lib_parser(9, 6, 1)
  import Data.Maybe
  import HIndent.Ast.Expression.Splice (Splice, mkSplice, mkTypedSplice)
  import HIndent.Fixity (fixities)
  import qualified Language.Haskell.GhclibParserEx.GHC.Hs.Expr as GHC
  #else
  import qualified GHC.Types.Name.Reader as NameReader
  import HIndent.Ast.Expression.Splice (Splice, mkSplice)
  #endif
  data Expression
    = Variable (WithComments PrefixName)
    | UnboundVariable PrefixName
    | OverloadedLabel OverloadedLabel
    | ImplicitParameter ImplicitParameterName
    | OverloadedLiteral (GHC.HsOverLit GHC.GhcPs)
    | Literal (GHC.HsLit GHC.GhcPs)
    | Lambda (GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs))
    | LambdaCase
        { usesCases :: Bool
        , matches :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
        }
    | Application (NonEmpty (WithComments Expression))
    | TypeApplication
        { expression :: WithComments Expression
        , typeArg :: GHC.LHsWcType (GHC.NoGhcTc GHC.GhcPs)
        }
    | OperatorApplication
        { firstOperand :: WithComments Expression
        , operatorOperandPairs :: NonEmpty
            (WithComments InfixExpr, WithComments Expression)
        }
    | Negation (WithComments Expression)
    | Parenthesized (WithComments Expression)
    | LeftSection
        { left :: WithComments Expression
        , operator :: WithComments InfixExpr
        }
    | RightSection
        { operator :: WithComments InfixExpr
        , right :: WithComments Expression
        }
    | Tuple
        { arguments :: [WithComments (Maybe (WithComments Expression))]
        , isBoxed :: Bool
        }
    | Sum
        { position :: GHC.ConTag
        , arity :: HS.SumWidth
        , expression :: WithComments Expression
        }
    | CaseExpression
        { scrutinee :: WithComments Expression
        , matches :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
        }
    | IfExpression
        { predicate :: WithComments Expression
        , thenBranch :: WithComments Expression
        , elseBranch :: WithComments Expression
        }
    | MultiIf [WithComments Guard]
    | LetBinding
        { bindings :: GHC.HsLocalBinds GHC.GhcPs
        , expression :: WithComments Expression
        }
    | DoBlock
        { qualifiedDo :: QualifiedDo
        , statements :: GHC.XRec GHC.GhcPs [GHC.ExprLStmt GHC.GhcPs]
        }
    | ListComprehension (WithComments LC.ListComprehension)
    | ListLiteral [WithComments Expression]
    | RecordConstruction
        { name :: WithComments PrefixName
        , binds :: GHC.HsRecordBinds GHC.GhcPs
        }
    | RecordUpdate
        { expression :: WithComments Expression
        , updates :: GHC.LHsRecUpdFields GHC.GhcPs
        }
    | FieldProjection
        { expression :: WithComments Expression
        , selector :: GHC.XRec GHC.GhcPs (GHC.DotFieldOcc GHC.GhcPs)
        }
    | Projection (NonEmpty (GHC.XRec GHC.GhcPs (GHC.DotFieldOcc GHC.GhcPs)))
    | TypeSignature
        { expression :: WithComments Expression
        , signature :: WithComments Type
        }
    | ArithmeticSequence RangeExpression
    | TypedQuotation (WithComments Expression)
    | UntypedQuotation Bracket
    | Splice Splice
    | ProcExpression
        { pat :: WithComments Pattern
        , cmd :: GHC.LHsCmdTop GHC.GhcPs
        }
    | StaticExpression (WithComments Expression)
    | PragmaticExpression
        { pragma :: GHC.HsPragE GHC.GhcPs
        , expression :: WithComments Expression
        }
  
  instance CommentExtraction Expression where
    nodeComments _ = NodeComments [] [] []
  
  instance Pretty Expression where
    pretty' (Variable name) = pretty name
    pretty' (UnboundVariable name) = pretty name
    pretty' (OverloadedLabel label) = pretty label
    pretty' (ImplicitParameter name) = pretty name
    pretty' (OverloadedLiteral lit) = pretty lit
    pretty' (Literal lit) = pretty lit
    pretty' (Lambda matches) = pretty matches
    pretty' LambdaCase {..} = do
      string
        $ if usesCases
            then "\\cases"
            else "\\case"
      if null $ GHC.unLoc $ GHC.mg_alts matches
        then string " {}"
        else do
          newline
          indentedBlock $ pretty matches
    pretty' (Application (headExpr :| argList)) = horizontal <-|> vertical
      where
        horizontal = spaced $ pretty <$> headExpr : argList
        vertical = do
          col <- gets psColumn
          indentSpaces <- getIndentSpaces
          pretty headExpr
          col' <- gets psColumn
          let headLength =
                col'
                  - col
                  - if col == 0
                      then indentSpaces
                      else 0
              hangFirstArg = headLength + 1 <= indentSpaces
          if hangFirstArg
            then space
            else newline
          spaces' <- getIndentSpaces
          indentedWithSpace spaces' $ lined $ fmap pretty argList
    pretty' TypeApplication {..} = do
      pretty expression
      string " @"
      pretty typeArg
    pretty' OperatorApplication {..} = horizontal <-|> vertical
      where
        horizontal = do
          pretty firstOperand
          space
          spaced
            $ concatMap (\(op, r) -> [pretty op, pretty r]) operatorOperandPairs
        vertical = do
          pretty firstOperand
          prettyOpAndRhs $ NonEmpty.toList operatorOperandPairs
          where
            prettyOpAndRhs [] = pure ()
            prettyOpAndRhs [(o, r)]
              | shouldBeInline (getNode r) = space >> spaced [pretty o, pretty r]
            prettyOpAndRhs ((o, r):xs) = do
              newline
              indentedBlock $ (pretty o >> space) |=> pretty r
              prettyOpAndRhs xs
            shouldBeInline DoBlock {} = True
            shouldBeInline Lambda {} = True
            shouldBeInline LambdaCase {} = True
            shouldBeInline _ = False
    pretty' (Negation expr) = string "-" >> pretty expr
    pretty' (Parenthesized expr) = parens $ pretty expr
    pretty' LeftSection {..} = spaced [pretty left, pretty operator]
    pretty' RightSection {..} = (pretty operator >> space) |=> pretty right
    pretty' Tuple {..} = horizontal <-|> vertical
      where
        horizontal = parH $ prettyArg pretty <$> arguments
        vertical =
          parV
            $ prefixedLined ","
            $ prettyArg (\expr -> space |=> pretty expr) <$> arguments
        prettyArg f arg = prettyWith arg (maybe (pure ()) f)
        (parH, parV) =
          if isBoxed
            then (hTuple, parens)
            else (hUnboxedTuple, unboxedParens)
    pretty' Sum {..} = do
      string "(#"
      forM_ [1 .. arity] $ \idx -> do
        if idx == position
          then space >> pretty expression >> space
          else space
        when (idx < arity) $ string "|"
      string "#)"
    pretty' CaseExpression {..} = do
      string "case " |=> do
        pretty scrutinee
        string " of"
      if null $ GHC.unLoc $ GHC.mg_alts matches
        then string " {}"
        else do
          newline
          indentedBlock $ pretty matches
    pretty' IfExpression {..} = do
      string "if " |=> pretty predicate
      indentedBlock
        $ newlinePrefixed [branch "then " thenBranch, branch "else " elseBranch]
      where
        branch str exprWithComments =
          prettyWith exprWithComments $ \expr ->
            case expr of
              DoBlock {} -> do
                string str
                pretty expr
              _ -> string str |=> pretty expr
    pretty' (MultiIf multiIfClauses) =
      string "if " |=> lined (fmap pretty multiIfClauses)
    pretty' LetBinding {..} =
      lined
        [string "let " |=> pretty bindings, string " in " |=> pretty expression]
    pretty' DoBlock {..} = do
      pretty qualifiedDo
      newline
      indentedBlock $ printCommentsAnd statements (lined . fmap pretty)
    pretty' (ListComprehension listComprehension) = pretty listComprehension
    pretty' (ListLiteral listItems) = horizontal <-|> vertical
      where
        horizontal = brackets $ hCommaSep $ fmap pretty listItems
        vertical = vList $ fmap pretty listItems
    pretty' RecordConstruction {..} = horizontal <-|> vertical
      where
        horizontal = spaced [pretty name, pretty binds]
        vertical = do
          pretty name
          (space >> pretty binds) <-|> (newline >> indentedBlock (pretty binds))
    pretty' RecordUpdate {..} = pretty $ mkRecordUpdateFields expression updates
    pretty' FieldProjection {..} = do
      pretty expression
      dot
      pretty selector
    pretty' (Projection projectionFields) =
      parens $ forM_ projectionFields prettyProjectionField
      where
        prettyProjectionField projectionField = do
          string "."
          pretty projectionField
    pretty' TypeSignature {..} =
      spaced [pretty expression, string "::", pretty signature]
    pretty' (ArithmeticSequence rangeExpression) = pretty rangeExpression
    pretty' (TypedQuotation expr) = typedBrackets $ pretty expr
    pretty' (UntypedQuotation bracket) = pretty bracket
    pretty' ProcExpression {..} =
      case cmd of
        x@(GHC.L _ (GHC.HsCmdTop _ (GHC.L _ (GHC.HsCmdDo _ stmts)))) -> do
          spaced [string "proc", pretty pat, string "-> do"]
          newline
          indentedBlock
            $ printCommentsAnd
                x
                (const (printCommentsAnd stmts (lined . fmap pretty)))
        _ -> hor <-|> ver
      where
        hor = spaced [string "proc", pretty pat, string "->", pretty cmd]
        ver = do
          spaced [string "proc", pretty pat, string "->"]
          newline
          indentedBlock $ pretty cmd
    pretty' (StaticExpression expr) = spaced [string "static", pretty expr]
    pretty' PragmaticExpression {..} = spaced [pretty pragma, pretty expression]
    pretty' (Splice splice') = pretty splice'
  
  mkExpression :: GHC.HsExpr GHC.GhcPs -> Expression
  mkExpression (GHC.HsVar _ name) =
    Variable $ mkPrefixName <$> fromGenLocated name
  #if MIN_VERSION_ghc_lib_parser(9, 6, 0)
  mkExpression (GHC.HsUnboundVar _ name) = UnboundVariable $ mkPrefixName name
  #else
  mkExpression (GHC.HsUnboundVar _ name) =
    UnboundVariable $ mkPrefixName $ NameReader.mkRdrUnqual name
  #endif
  #if MIN_VERSION_ghc_lib_parser(9, 12, 1)
  mkExpression (GHC.HsOverLabel _ label) =
    OverloadedLabel $ mkOverloadedLabel label
  #elif MIN_VERSION_ghc_lib_parser(9, 6, 1)
  mkExpression (GHC.HsOverLabel _ _ label) =
    OverloadedLabel $ mkOverloadedLabel label
  #else
  mkExpression (GHC.HsOverLabel _ label) =
    OverloadedLabel $ mkOverloadedLabel label
  #endif
  mkExpression (GHC.HsIPVar _ name) =
    ImplicitParameter $ mkImplicitParameterName name
  mkExpression (GHC.HsOverLit _ lit) = OverloadedLiteral lit
  mkExpression (GHC.HsLit _ lit) = Literal lit
  #if MIN_VERSION_ghc_lib_parser(9, 10, 1)
  mkExpression (GHC.HsEmbTy _ _) =
    error "`ghc-lib-parser` never generates this AST node."
  #endif
  #if MIN_VERSION_ghc_lib_parser(9, 10, 1)
  mkExpression (GHC.HsLam _ GHC.LamSingle matches) = Lambda matches
  mkExpression (GHC.HsLam _ GHC.LamCases matches) =
    LambdaCase {usesCases = True, ..}
  mkExpression (GHC.HsLam _ GHC.LamCase matches) =
    LambdaCase {usesCases = False, ..}
  #else
  mkExpression (GHC.HsLam _ matches) = Lambda matches
  #if MIN_VERSION_ghc_lib_parser(9, 4, 1)
  mkExpression (GHC.HsLamCase _ GHC.LamCases matches) =
    LambdaCase {usesCases = True, ..}
  mkExpression (GHC.HsLamCase _ GHC.LamCase matches) =
    LambdaCase {usesCases = False, ..}
  #else
  mkExpression (GHC.HsLamCase _ _ matches) = LambdaCase {usesCases = False, ..}
  #endif
  #endif
  mkExpression (GHC.HsApp _ function argument) =
    case getNode f of
      Application (h :| as) -> Application $ h :| push as
      _ -> Application $ f :| [a]
    where
      f = mkExpression <$> fromGenLocated function
      a = mkExpression <$> fromGenLocated argument
      push [] = [a]
      push (x:xs) = go x xs
        where
          go final [] = [addComments (getComments f) final, a]
          go current (y:ys) = current : go y ys
  #if MIN_VERSION_ghc_lib_parser(9, 10, 1)
  mkExpression (GHC.HsAppType _ fun typeArg) =
    TypeApplication {expression = mkExpression <$> fromGenLocated fun, ..}
  #else
  mkExpression (GHC.HsAppType _ fun _ typeArg) =
    TypeApplication {expression = mkExpression <$> fromGenLocated fun, ..}
  #endif
  mkExpression (GHC.OpApp _ lhs op rhs) = OperatorApplication {..}
    where
      (firstOperand, operatorOperandPairs) =
        case fixityDir operatorFixity of
          GHC.InfixL -> build leftChain
          GHC.InfixR -> build rightChain
          GHC.InfixN
            | GHC.L _ (GHC.OpApp _ _ o _) <- lhs
            , isSameAssoc o -> build leftChain
            | otherwise -> build rightChain
      operatorFixity = findFixity op
      build (x:xs) = (mkExpression <$> fromGenLocated x, f xs)
        where
          f [l, o] =
            NonEmpty.singleton
              ( InfixExpr . mkExpression <$> fromGenLocated l
              , mkExpression <$> fromGenLocated o)
          f (l:o:rs) =
            ( InfixExpr . mkExpression <$> fromGenLocated l
            , mkExpression <$> fromGenLocated o)
              <| f rs
          f _ = error "Malformed operator chain"
      build _ = error "Empty operator chain"
      findFixity o =
        fromMaybe GHC.defaultFixity $ lookup (GHC.varToStr o) fixities
      leftChain = reverse $ rhs : op : collect lhs
        where
          collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]
          collect (GHC.L _ (GHC.OpApp _ l o r))
            | isSameAssoc o = r : o : collect l
          collect x = [x]
      rightChain = lhs : op : collect rhs
        where
          collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]
          collect (GHC.L _ (GHC.OpApp _ l o r))
            | isSameAssoc o = l : o : collect r
          collect x = [x]
      isSameAssoc (findFixity -> fixity) =
        fixityLevel fixity == level && fixityDir fixity == dir
      level = fixityLevel operatorFixity
      dir = fixityDir operatorFixity
  #if MIN_VERSION_ghc_lib_parser(9, 12, 1)
      fixityLevel (GHC.Fixity lvl _) = lvl
      
      fixityDir (GHC.Fixity _ direction) = direction
  #else
      fixityLevel (GHC.Fixity _ lvl _) = lvl
      
      fixityDir (GHC.Fixity _ _ direction) = direction
  #endif
  mkExpression (GHC.NegApp _ expr _) =
    Negation $ mkExpression <$> fromGenLocated expr
  #if MIN_VERSION_ghc_lib_parser(9, 10, 1)
  mkExpression (GHC.HsPar _ expr) =
    Parenthesized $ mkExpression <$> fromGenLocated expr
  #elif MIN_VERSION_ghc_lib_parser(9, 8, 1)
  mkExpression (GHC.HsPar _ _ expr _) =
    Parenthesized $ mkExpression <$> fromGenLocated expr
  #else
  mkExpression (GHC.HsPar _ expr) =
    Parenthesized $ mkExpression <$> fromGenLocated expr
  #endif
  mkExpression (GHC.SectionL _ l r) =
    LeftSection
      { left = mkExpression <$> fromGenLocated l
      , operator = InfixExpr . mkExpression <$> fromGenLocated r
      }
  mkExpression (GHC.SectionR _ l r) =
    RightSection
      { operator = InfixExpr . mkExpression <$> fromGenLocated l
      , right = mkExpression <$> fromGenLocated r
      }
  #if MIN_VERSION_ghc_lib_parser(9, 10, 1)
  mkExpression (GHC.ExplicitTuple _ tupleArgs boxity) =
    Tuple
      { arguments = mkTupleArgument <$> tupleArgs
      , isBoxed =
          case boxity of
            GHC.Boxed -> True
            GHC.Unboxed -> False
      }
    where
      mkTupleArgument (GHC.Present _ expr) =
        mkWithComments $ Just $ mkExpression <$> fromGenLocated expr
      mkTupleArgument (GHC.Missing ann) = fromEpAnn ann Nothing
  #else
  mkExpression (GHC.ExplicitTuple _ tupleArgs boxity) =
    Tuple
      { arguments = mkTupleArgument <$> tupleArgs
      , isBoxed =
          case boxity of
            GHC.Boxed -> True
            GHC.Unboxed -> False
      }
    where
      mkTupleArgument (GHC.Present ann expr) =
        fromEpAnn ann $ Just $ mkExpression <$> fromGenLocated expr
      mkTupleArgument (GHC.Missing ann) = fromEpAnn ann Nothing
  #endif
  mkExpression (GHC.ExplicitSum _ position arity expr) =
    Sum {expression = mkExpression <$> fromGenLocated expr, ..}
  mkExpression (GHC.HsCase _ scrut matches) =
    CaseExpression
      {scrutinee = mkExpression <$> fromGenLocated scrut, matches = matches}
  mkExpression (GHC.HsIf _ predicateExpr thenExpr elseExpr) =
    IfExpression
      { predicate = mkExpression <$> fromGenLocated predicateExpr
      , thenBranch = mkExpression <$> fromGenLocated thenExpr
      , elseBranch = mkExpression <$> fromGenLocated elseExpr
      }
  mkExpression (GHC.HsMultiIf _ clauses) =
    MultiIf (fmap (fmap mkMultiWayIfExprGuard . fromGenLocated) clauses)
  #if MIN_VERSION_ghc_lib_parser(9, 10, 1)
  mkExpression (GHC.HsLet _ bindings body) =
    LetBinding {expression = mkExpression <$> fromGenLocated body, ..}
  #elif MIN_VERSION_ghc_lib_parser(9, 8, 1)
  mkExpression (GHC.HsLet _ _ bindings _ body) =
    LetBinding {expression = mkExpression <$> fromGenLocated body, ..}
  #else
  mkExpression (GHC.HsLet _ bindings body) =
    LetBinding {expression = mkExpression <$> fromGenLocated body, ..}
  #endif
  mkExpression (GHC.HsDo _ GHC.ListComp statements) =
    ListComprehension $ LC.mkListComprehension <$> fromGenLocated statements
  mkExpression (GHC.HsDo _ GHC.MonadComp statements) =
    ListComprehension $ LC.mkListComprehension <$> fromGenLocated statements
  mkExpression (GHC.HsDo _ (GHC.DoExpr moduleName) statements) =
    DoBlock {qualifiedDo = QualifiedDo (fmap mkModuleName moduleName) Do, ..}
  mkExpression (GHC.HsDo _ (GHC.MDoExpr moduleName) statements) =
    DoBlock {qualifiedDo = QualifiedDo (fmap mkModuleName moduleName) Mdo, ..}
  mkExpression (GHC.HsDo _ GHC.GhciStmtCtxt {} _) =
    error "`ghc-lib-parser` never generates this AST node."
  mkExpression (GHC.ExplicitList _ items) =
    ListLiteral (fmap (fmap mkExpression . fromGenLocated) items)
  mkExpression (GHC.RecordCon {GHC.rcon_con = conName, GHC.rcon_flds = binds}) =
    RecordConstruction {name = mkPrefixName <$> fromGenLocated conName, binds}
  mkExpression (GHC.RecordUpd { GHC.rupd_expr = recordExpr
                              , GHC.rupd_flds = updates
                              }) =
    RecordUpdate
      {expression = mkExpression <$> fromGenLocated recordExpr, updates}
  mkExpression (GHC.HsGetField {GHC.gf_expr = fieldExpr, GHC.gf_field = selector}) =
    FieldProjection
      {expression = mkExpression <$> fromGenLocated fieldExpr, selector}
  #if MIN_VERSION_ghc_lib_parser(9, 12, 1)
  mkExpression (GHC.HsProjection {GHC.proj_flds = fields}) =
    Projection $ GHC.noLocA <$> fields
  #else
  mkExpression (GHC.HsProjection {GHC.proj_flds = fields}) = Projection fields
  #endif
  mkExpression (GHC.ExprWithTySig _ signatureExpr ty) =
    TypeSignature
      { expression = mkExpression <$> fromGenLocated signatureExpr
      , signature =
          flattenComments
            $ mkTypeFromHsSigType <$> fromGenLocated (GHC.hswc_body ty)
      }
  mkExpression (GHC.ArithSeq _ _ info) =
    ArithmeticSequence $ mkRangeExpression info
  mkExpression (GHC.HsTypedBracket _ typedExpr) =
    TypedQuotation $ mkExpression <$> fromGenLocated typedExpr
  mkExpression (GHC.HsUntypedBracket _ content) =
    UntypedQuotation $ mkBracket content
  #if MIN_VERSION_ghc_lib_parser(9, 12, 2)
  mkExpression GHC.HsForAll {} =
    error "`ghc-lib-parser` never generates this AST node."
  mkExpression GHC.HsQual {} =
    error "`ghc-lib-parser` never generates this AST node."
  mkExpression GHC.HsFunArr {} =
    error "`ghc-lib-parser` never generates this AST node."
  #endif
  #if MIN_VERSION_ghc_lib_parser(9, 6, 1)
  mkExpression (GHC.HsTypedSplice _ expr) = Splice $ mkTypedSplice expr
  mkExpression (GHC.HsUntypedSplice _ splice) = Splice $ mkSplice splice
  #else
  mkExpression (GHC.HsSpliceE _ splice) = Splice $ mkSplice splice
  mkExpression (GHC.HsTypedSplice _ expr) = Splice $ mkSplice expr
  mkExpression (GHC.HsUntypedSplice _ splice) = Splice $ mkSplice splice
  #endif
  mkExpression (GHC.HsProc _ pat cmd) =
    ProcExpression {pat = mkPattern <$> fromGenLocated pat, ..}
  mkExpression (GHC.HsStatic _ staticExpr) =
    StaticExpression $ mkExpression <$> fromGenLocated staticExpr
  mkExpression (GHC.HsPragE _ pragma pragmaticExpr) =
    PragmaticExpression
      {expression = mkExpression <$> fromGenLocated pragmaticExpr, ..}
  #if !MIN_VERSION_ghc_lib_parser(9, 12, 1)
  mkExpression (GHC.HsRecSel _ _) =
    error "`ghc-lib-parser` never generates this AST node."
  #endif
  newtype InfixExpr =
    InfixExpr Expression
  
  instance CommentExtraction InfixExpr where
    nodeComments _ = NodeComments [] [] []
  
  instance Pretty InfixExpr where
    pretty' (InfixExpr (Variable name)) = pretty $ mkPrefixAsInfix <$> name
    pretty' (InfixExpr (UnboundVariable name)) = pretty $ mkPrefixAsInfix name
    pretty' (InfixExpr (Parenthesized inner)) = pretty $ fmap InfixExpr inner
    pretty' (InfixExpr x) = pretty x
  
  data GuardExpression
    = GuardWithDo Expression
    | GuardWithAppAndDo Expression
    | GuardExpression Expression
  
  instance CommentExtraction GuardExpression where
    nodeComments (GuardWithDo expr) = nodeComments expr
    nodeComments (GuardWithAppAndDo expr) = nodeComments expr
    nodeComments (GuardExpression expr) = nodeComments expr
  
  instance Pretty GuardExpression where
    pretty' (GuardWithDo expr) = space >> pretty expr
    pretty' (GuardWithAppAndDo expr) = space >> pretty expr
    pretty' (GuardExpression expr) = horizontal <-|> vertical
      where
        horizontal = space >> pretty expr
        vertical = newline >> indentedBlock (pretty expr)
  
  mkGuardExpression :: Expression -> GuardExpression
  mkGuardExpression expr@DoBlock {} = GuardWithDo expr
  mkGuardExpression expr
    | OperatorApplication {..} <- expr
    , DoBlock {} <- getNode firstOperand = GuardWithAppAndDo expr
    | otherwise = GuardExpression expr
  