{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

module HIndent.Ast.Declaration.Bind
  ( Bind
  , mkBind
  ) where

import HIndent.Ast.Name.Infix
import HIndent.Ast.Name.Prefix
import HIndent.Ast.NodeComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments
import HIndent.Pretty.Types

-- The difference between `Function` and `Pattern` is the same as the difference
-- between `FunBind` and `PatBind` in GHC AST. See
-- https://hackage.haskell.org/package/ghc-lib-parser-9.8.2.20240223/docs/src/Language.Haskell.Syntax.Binds.html.
--
-- TODO: Merge them.
data Bind
  = Function
      { Bind -> MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
      }
  | Pattern
      { Bind -> LPat GhcPs
lhs :: GHC.LPat GHC.GhcPs
      , Bind -> GRHSs GhcPs (LHsExpr GhcPs)
rhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
      }
  | PatternSynonym
      { Bind -> LIdP GhcPs
name :: GHC.LIdP GHC.GhcPs
      , Bind -> HsPatSynDetails GhcPs
parameters :: GHC.HsPatSynDetails GHC.GhcPs
      , Bind -> HsPatSynDir GhcPs
direction :: GHC.HsPatSynDir GHC.GhcPs
      , Bind -> LPat GhcPs
definition :: GHC.LPat GHC.GhcPs
      }

instance CommentExtraction Bind where
  nodeComments :: Bind -> NodeComments
nodeComments Function {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []
  nodeComments Pattern {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []
  nodeComments PatternSynonym {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []

instance Pretty Bind where
  pretty' :: Bind -> Printer ()
pretty' Function {MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: Bind -> MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
..} = MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Printer ()
forall a. Pretty a => a -> Printer ()
pretty MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches
  pretty' Pattern {LPat GhcPs
GRHSs GhcPs (LHsExpr GhcPs)
lhs :: Bind -> LPat GhcPs
rhs :: Bind -> GRHSs GhcPs (LHsExpr GhcPs)
lhs :: LPat GhcPs
rhs :: GRHSs GhcPs (LHsExpr GhcPs)
..} = GenLocated SrcSpanAnnA (Pat GhcPs) -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
lhs Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs
  pretty' PatternSynonym {LIdP GhcPs
LPat GhcPs
HsPatSynDetails GhcPs
HsPatSynDir GhcPs
name :: Bind -> LIdP GhcPs
parameters :: Bind -> HsPatSynDetails GhcPs
direction :: Bind -> HsPatSynDir GhcPs
definition :: Bind -> LPat GhcPs
name :: LIdP GhcPs
parameters :: HsPatSynDetails GhcPs
direction :: HsPatSynDir GhcPs
definition :: LPat GhcPs
..} = do
    HasCallStack => String -> Printer ()
String -> Printer ()
string String
"pattern "
    case HsPatSynDetails GhcPs
parameters of
      GHC.InfixCon LIdP GhcPs
l LIdP GhcPs
r ->
        [Printer ()] -> Printer ()
spaced
          [ GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (GenLocated SrcSpanAnnN PrefixName -> Printer ())
-> GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a b. (a -> b) -> a -> b
$ (RdrName -> PrefixName)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN PrefixName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> PrefixName
mkPrefixName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
l
          , GenLocated SrcSpanAnnN InfixName -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (GenLocated SrcSpanAnnN InfixName -> Printer ())
-> GenLocated SrcSpanAnnN InfixName -> Printer ()
forall a b. (a -> b) -> a -> b
$ (RdrName -> InfixName)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN InfixName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> InfixName
mkInfixName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
          , GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (GenLocated SrcSpanAnnN PrefixName -> Printer ())
-> GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a b. (a -> b) -> a -> b
$ (RdrName -> PrefixName)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN PrefixName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> PrefixName
mkPrefixName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
r
          ]
      GHC.PrefixCon [Void]
_ [] -> GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (GenLocated SrcSpanAnnN PrefixName -> Printer ())
-> GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a b. (a -> b) -> a -> b
$ (RdrName -> PrefixName)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN PrefixName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> PrefixName
mkPrefixName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
      HsPatSynDetails GhcPs
_ -> [Printer ()] -> Printer ()
spaced [GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (GenLocated SrcSpanAnnN PrefixName -> Printer ())
-> GenLocated SrcSpanAnnN PrefixName -> Printer ()
forall a b. (a -> b) -> a -> b
$ (RdrName -> PrefixName)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN PrefixName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> PrefixName
mkPrefixName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name, HsConDetails
  Void (GenLocated SrcSpanAnnN RdrName) [RecordPatSynField GhcPs]
-> Printer ()
forall a. Pretty a => a -> Printer ()
pretty HsPatSynDetails GhcPs
HsConDetails
  Void (GenLocated SrcSpanAnnN RdrName) [RecordPatSynField GhcPs]
parameters]
    [Printer ()] -> Printer ()
spacePrefixed [HsPatSynDir GhcPs -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty HsPatSynDir GhcPs
direction, GenLocated SrcSpanAnnA PatInsidePatDecl -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (GenLocated SrcSpanAnnA PatInsidePatDecl -> Printer ())
-> GenLocated SrcSpanAnnA PatInsidePatDecl -> Printer ()
forall a b. (a -> b) -> a -> b
$ (Pat GhcPs -> PatInsidePatDecl)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA PatInsidePatDecl
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat GhcPs -> PatInsidePatDecl
PatInsidePatDecl LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
definition]
    case HsPatSynDir GhcPs
direction of
      GHC.ExplicitBidirectional MatchGroup GhcPs (LHsExpr GhcPs)
matches -> do
        Printer ()
newline
        Printer () -> Printer ()
forall a. Printer a -> Printer a
indentedBlock (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Printer ()
String -> Printer ()
string String
"where " Printer () -> Printer () -> Printer ()
forall a. Printer () -> Printer a -> Printer a
|=> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Printer ()
forall a. Pretty a => a -> Printer ()
pretty MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matches
      HsPatSynDir GhcPs
_ -> () -> Printer ()
forall a. a -> Printer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mkBind :: GHC.HsBind GHC.GhcPs -> Bind
mkBind :: HsBind GhcPs -> Bind
mkBind GHC.FunBind {XFunBind GhcPs GhcPs
LIdP GhcPs
MatchGroup GhcPs (LHsExpr GhcPs)
fun_ext :: XFunBind GhcPs GhcPs
fun_id :: LIdP GhcPs
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
..} = Function {MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
..}
mkBind GHC.PatBind {XPatBind GhcPs GhcPs
LPat GhcPs
GRHSs GhcPs (LHsExpr GhcPs)
HsMultAnn GhcPs
pat_ext :: XPatBind GhcPs GhcPs
pat_lhs :: LPat GhcPs
pat_mult :: HsMultAnn GhcPs
pat_rhs :: GRHSs GhcPs (LHsExpr GhcPs)
pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
..} = Pattern {LPat GhcPs
GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GenLocated SrcSpanAnnA (Pat GhcPs)
lhs :: LPat GhcPs
rhs :: GRHSs GhcPs (LHsExpr GhcPs)
lhs :: GenLocated SrcSpanAnnA (Pat GhcPs)
rhs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
..}
  where
    lhs :: LPat GhcPs
lhs = LPat GhcPs
pat_lhs
    rhs :: GRHSs GhcPs (LHsExpr GhcPs)
rhs = GRHSs GhcPs (LHsExpr GhcPs)
pat_rhs
mkBind (GHC.PatSynBind XPatSynBind GhcPs GhcPs
_ GHC.PSB {XPSB GhcPs GhcPs
LIdP GhcPs
LPat GhcPs
HsPatSynDetails GhcPs
HsPatSynDir GhcPs
psb_ext :: XPSB GhcPs GhcPs
psb_id :: LIdP GhcPs
psb_args :: HsPatSynDetails GhcPs
psb_def :: LPat GhcPs
psb_dir :: HsPatSynDir GhcPs
psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_ext :: forall idL idR. PatSynBind idL idR -> XPSB idL idR
..}) = PatternSynonym {LIdP GhcPs
LPat GhcPs
GenLocated SrcSpanAnnN RdrName
GenLocated SrcSpanAnnA (Pat GhcPs)
HsPatSynDetails GhcPs
HsConDetails
  Void (GenLocated SrcSpanAnnN RdrName) [RecordPatSynField GhcPs]
HsPatSynDir GhcPs
name :: LIdP GhcPs
parameters :: HsPatSynDetails GhcPs
direction :: HsPatSynDir GhcPs
definition :: LPat GhcPs
name :: GenLocated SrcSpanAnnN RdrName
parameters :: HsConDetails
  Void (GenLocated SrcSpanAnnN RdrName) [RecordPatSynField GhcPs]
direction :: HsPatSynDir GhcPs
definition :: GenLocated SrcSpanAnnA (Pat GhcPs)
..}
  where
    name :: LIdP GhcPs
name = LIdP GhcPs
psb_id
    parameters :: HsPatSynDetails GhcPs
parameters = HsPatSynDetails GhcPs
psb_args
    direction :: HsPatSynDir GhcPs
direction = HsPatSynDir GhcPs
psb_dir
    definition :: LPat GhcPs
definition = LPat GhcPs
psb_def
mkBind HsBind GhcPs
_ = String -> Bind
forall a. HasCallStack => String -> a
error String
"This AST node should not appear."