{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Ormolu.Printer.Meat.Declaration.Rule
  ( p_ruleDecls,
  )
where

import Control.Monad (unless)
import GHC.Hs.Decls
import GHC.Hs.Extension
import GHC.Hs.Lit
import GHC.Hs.Type
import GHC.Types.Basic
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration.Signature
import Ormolu.Printer.Meat.Declaration.Value
import Ormolu.Printer.Meat.Type

p_ruleDecls :: RuleDecls GhcPs -> R ()
p_ruleDecls :: RuleDecls GhcPs -> R ()
p_ruleDecls (HsRules XCRuleDecls GhcPs
NoExtField SourceText
_ [LRuleDecl GhcPs]
xs) =
  Text -> R () -> R ()
pragma Text
"RULES" (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LRuleDecl GhcPs -> R ()) -> [LRuleDecl GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint (R () -> R ()
sitcc (R () -> R ())
-> (LRuleDecl GhcPs -> R ()) -> LRuleDecl GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RuleDecl GhcPs -> R ()) -> LRuleDecl GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' RuleDecl GhcPs -> R ()
p_ruleDecl) [LRuleDecl GhcPs]
xs

p_ruleDecl :: RuleDecl GhcPs -> R ()
p_ruleDecl :: RuleDecl GhcPs -> R ()
p_ruleDecl (HsRule XHsRule GhcPs
NoExtField Located (SourceText, RuleName)
ruleName Activation
activation Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyvars [LRuleBndr GhcPs]
ruleBndrs Located (HsExpr GhcPs)
lhs Located (HsExpr GhcPs)
rhs) = do
  Located (SourceText, RuleName)
-> ((SourceText, RuleName) -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (SourceText, RuleName)
ruleName (SourceText, RuleName) -> R ()
p_ruleName
  R ()
space
  Activation -> R ()
p_activation Activation
activation
  R ()
space
  case Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyvars of
    Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [LHsTyVarBndr () (NoGhcTc GhcPs)]
xs -> do
      ForAllVisibility
-> (HsTyVarBndr () GhcPs -> R ())
-> [Located (HsTyVarBndr () GhcPs)]
-> R ()
forall a.
Data a =>
ForAllVisibility -> (a -> R ()) -> [Located a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis HsTyVarBndr () GhcPs -> R ()
forall flag.
IsInferredTyVarBndr flag =>
HsTyVarBndr flag GhcPs -> R ()
p_hsTyVarBndr [Located (HsTyVarBndr () GhcPs)]
[LHsTyVarBndr () (NoGhcTc GhcPs)]
xs
      R ()
space
  -- It appears that there is no way to tell if there was an empty forall
  -- in the input or no forall at all. We do not want to add redundant
  -- foralls, so let's just skip the empty ones.
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LRuleBndr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LRuleBndr GhcPs]
ruleBndrs) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
    ForAllVisibility
-> (RuleBndr GhcPs -> R ()) -> [LRuleBndr GhcPs] -> R ()
forall a.
Data a =>
ForAllVisibility -> (a -> R ()) -> [Located a] -> R ()
p_forallBndrs ForAllVisibility
ForAllInvis RuleBndr GhcPs -> R ()
p_ruleBndr [LRuleBndr GhcPs]
ruleBndrs
  R ()
breakpoint
  R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Located (HsExpr GhcPs) -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (HsExpr GhcPs)
lhs HsExpr GhcPs -> R ()
p_hsExpr
    R ()
space
    R ()
equals
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      R ()
breakpoint
      Located (HsExpr GhcPs) -> (HsExpr GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (HsExpr GhcPs)
rhs HsExpr GhcPs -> R ()
p_hsExpr

p_ruleName :: (SourceText, RuleName) -> R ()
p_ruleName :: (SourceText, RuleName) -> R ()
p_ruleName (SourceText
_, RuleName
name) = HsLit GhcPs -> R ()
forall a. Outputable a => a -> R ()
atom (HsLit GhcPs -> R ()) -> HsLit GhcPs -> R ()
forall a b. (a -> b) -> a -> b
$ (XHsString GhcPs -> RuleName -> HsLit GhcPs
forall x. XHsString x -> RuleName -> HsLit x
HsString XHsString GhcPs
SourceText
NoSourceText RuleName
name :: HsLit GhcPs)

p_ruleBndr :: RuleBndr GhcPs -> R ()
p_ruleBndr :: RuleBndr GhcPs -> R ()
p_ruleBndr = \case
  RuleBndr XCRuleBndr GhcPs
NoExtField Located (IdP GhcPs)
x -> Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
x
  RuleBndrSig XRuleBndrSig GhcPs
NoExtField Located (IdP GhcPs)
x HsPS {XHsPS GhcPs
LHsType GhcPs
hsps_ext :: forall pass. HsPatSigType pass -> XHsPS pass
hsps_body :: forall pass. HsPatSigType pass -> LHsType pass
hsps_body :: LHsType GhcPs
hsps_ext :: XHsPS GhcPs
..} -> BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
x
    LHsSigWcType GhcPs -> R ()
p_typeAscription (XHsWC GhcPs (HsImplicitBndrs GhcPs (LHsType GhcPs))
-> HsImplicitBndrs GhcPs (LHsType GhcPs) -> LHsSigWcType GhcPs
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExtField
XHsWC GhcPs (HsImplicitBndrs GhcPs (LHsType GhcPs))
NoExtField (XHsIB GhcPs (LHsType GhcPs)
-> LHsType GhcPs -> HsImplicitBndrs GhcPs (LHsType GhcPs)
forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB NoExtField
XHsIB GhcPs (LHsType GhcPs)
NoExtField LHsType GhcPs
hsps_body))