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

module HIndent.Ast.Declaration.Rule
  ( RuleDeclaration
  , mkRuleDeclaration
  ) where

import qualified GHC.Core as GHC
import qualified GHC.Data.FastString as GHC
import HIndent.Ast.Declaration.Rule.Binder
import HIndent.Ast.NodeComments
import HIndent.Ast.WithComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments

data RuleDeclaration = RuleDeclaration
  { RuleDeclaration -> WithComments RuleName
name :: WithComments GHC.RuleName
  , RuleDeclaration -> [WithComments RuleBinder]
binders :: [WithComments RuleBinder]
  , RuleDeclaration -> WithComments (HsExpr GhcPs)
lhs :: WithComments (GHC.HsExpr GHC.GhcPs)
  , RuleDeclaration -> WithComments (HsExpr GhcPs)
rhs :: WithComments (GHC.HsExpr GHC.GhcPs)
  }

instance CommentExtraction RuleDeclaration where
  nodeComments :: RuleDeclaration -> NodeComments
nodeComments RuleDeclaration {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []

instance Pretty RuleDeclaration where
  pretty' :: RuleDeclaration -> Printer ()
pretty' (RuleDeclaration {[WithComments RuleBinder]
WithComments RuleName
WithComments (HsExpr GhcPs)
name :: RuleDeclaration -> WithComments RuleName
binders :: RuleDeclaration -> [WithComments RuleBinder]
lhs :: RuleDeclaration -> WithComments (HsExpr GhcPs)
rhs :: RuleDeclaration -> WithComments (HsExpr GhcPs)
name :: WithComments RuleName
binders :: [WithComments RuleBinder]
lhs :: WithComments (HsExpr GhcPs)
rhs :: WithComments (HsExpr GhcPs)
..}) =
    [Printer ()] -> Printer ()
spaced
      [ WithComments RuleName -> (RuleName -> Printer ()) -> Printer ()
forall a. WithComments a -> (a -> Printer ()) -> Printer ()
prettyWith WithComments RuleName
name (Printer () -> Printer ()
forall a. Printer a -> Printer a
doubleQuotes (Printer () -> Printer ())
-> (RuleName -> Printer ()) -> RuleName -> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Printer ()
String -> Printer ()
string (String -> Printer ())
-> (RuleName -> String) -> RuleName -> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleName -> String
GHC.unpackFS)
      , Printer ()
prettyLhs
      , HasCallStack => String -> Printer ()
String -> Printer ()
string String
"="
      , WithComments (HsExpr GhcPs) -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments (HsExpr GhcPs)
rhs
      ]
    where
      prettyLhs :: Printer ()
prettyLhs =
        if [WithComments RuleBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WithComments RuleBinder]
binders
          then WithComments (HsExpr GhcPs) -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments (HsExpr GhcPs)
lhs
          else do
            HasCallStack => String -> Printer ()
String -> Printer ()
string String
"forall "
            [Printer ()] -> Printer ()
spaced ([Printer ()] -> Printer ()) -> [Printer ()] -> Printer ()
forall a b. (a -> b) -> a -> b
$ (WithComments RuleBinder -> Printer ())
-> [WithComments RuleBinder] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments RuleBinder -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty [WithComments RuleBinder]
binders
            Printer ()
dot
            Printer ()
space
            WithComments (HsExpr GhcPs) -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments (HsExpr GhcPs)
lhs

mkRuleDeclaration :: GHC.RuleDecl GHC.GhcPs -> RuleDeclaration
mkRuleDeclaration :: RuleDecl GhcPs -> RuleDeclaration
mkRuleDeclaration rule :: RuleDecl GhcPs
rule@GHC.HsRule {[LRuleBndr GhcPs]
Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
XHsRule GhcPs
XRec GhcPs RuleName
XRec GhcPs (HsExpr GhcPs)
Activation
rd_ext :: XHsRule GhcPs
rd_name :: XRec GhcPs RuleName
rd_act :: Activation
rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
rd_tmvs :: [LRuleBndr GhcPs]
rd_lhs :: XRec GhcPs (HsExpr GhcPs)
rd_rhs :: XRec GhcPs (HsExpr GhcPs)
rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_lhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
rd_tyvs :: forall pass.
RuleDecl pass -> Maybe [LHsTyVarBndr () (NoGhcTc pass)]
rd_act :: forall pass. RuleDecl pass -> Activation
rd_name :: forall pass. RuleDecl pass -> XRec pass RuleName
rd_ext :: forall pass. RuleDecl pass -> XHsRule pass
..} = RuleDeclaration {[WithComments RuleBinder]
WithComments RuleName
WithComments (HsExpr GhcPs)
name :: WithComments RuleName
binders :: [WithComments RuleBinder]
lhs :: WithComments (HsExpr GhcPs)
rhs :: WithComments (HsExpr GhcPs)
name :: WithComments RuleName
binders :: [WithComments RuleBinder]
lhs :: WithComments (HsExpr GhcPs)
rhs :: WithComments (HsExpr GhcPs)
..}
  where
    name :: WithComments RuleName
name = RuleDecl GhcPs -> WithComments RuleName
getName RuleDecl GhcPs
rule
    binders :: [WithComments RuleBinder]
binders = (GenLocated EpAnnCO (RuleBndr GhcPs) -> WithComments RuleBinder)
-> [GenLocated EpAnnCO (RuleBndr GhcPs)]
-> [WithComments RuleBinder]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleBndr GhcPs -> RuleBinder)
-> WithComments (RuleBndr GhcPs) -> WithComments RuleBinder
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleBndr GhcPs -> RuleBinder
mkRuleBinder (WithComments (RuleBndr GhcPs) -> WithComments RuleBinder)
-> (GenLocated EpAnnCO (RuleBndr GhcPs)
    -> WithComments (RuleBndr GhcPs))
-> GenLocated EpAnnCO (RuleBndr GhcPs)
-> WithComments RuleBinder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated EpAnnCO (RuleBndr GhcPs)
-> WithComments (RuleBndr GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated) [LRuleBndr GhcPs]
[GenLocated EpAnnCO (RuleBndr GhcPs)]
rd_tmvs
    lhs :: WithComments (HsExpr GhcPs)
lhs = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> WithComments (HsExpr GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rd_lhs
    rhs :: WithComments (HsExpr GhcPs)
rhs = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> WithComments (HsExpr GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rd_rhs

getName :: GHC.RuleDecl GHC.GhcPs -> WithComments GHC.RuleName
#if MIN_VERSION_ghc_lib_parser(9, 6, 1)
getName :: RuleDecl GhcPs -> WithComments RuleName
getName = GenLocated EpAnnCO RuleName -> WithComments RuleName
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated (GenLocated EpAnnCO RuleName -> WithComments RuleName)
-> (RuleDecl GhcPs -> GenLocated EpAnnCO RuleName)
-> RuleDecl GhcPs
-> WithComments RuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleDecl GhcPs -> XRec GhcPs RuleName
RuleDecl GhcPs -> GenLocated EpAnnCO RuleName
forall pass. RuleDecl pass -> XRec pass RuleName
GHC.rd_name
#else
getName = fromGenLocated . fmap snd . GHC.rd_name
#endif