-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved.
-- SPDX-License-Identifier: BSD-3-Clause.
--
-- Adapted from (1) https://github.com/mpickering/apply-refact.git and
-- (2) https://gitlab.haskell.org/ghc/ghc ('compiler/renamer/RnTypes.hs').

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
#include "ghclib_api.h"
module Language.Haskell.GhclibParserEx.Fixity(
    applyFixities
  , fixitiesFromModule
  , preludeFixities, baseFixities
  , infixr_, infixl_, infix_, fixity
  ) where

#if defined (GHC_8_8)
import HsSyn
import BasicTypes
import RdrName
import OccName
import SrcLoc
#elif defined (GHC_8_10)
import GHC.Hs
import BasicTypes
import RdrName
import OccName
import SrcLoc
#elif defined  (GHC_9_0)
import GHC.Hs
import GHC.Types.Basic
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.SrcLoc
#elif defined (GHC_9_2) || defined (GHC_9_4) || defined (GHC_9_6)
import GHC.Hs
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.SrcLoc
#else
import GHC.Hs
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Data.FastString
#endif

import Data.Maybe
import Data.Data hiding (Fixity)
import Data.Generics.Uniplate.Data

#if defined (GHC_9_0) || defined (GHC_8_10)
noExt :: NoExtField
noExt = noExtField
#endif

-- | Rearrange a parse tree to account for fixities.
applyFixities :: Data a => [(String, Fixity)] -> a -> a
applyFixities :: forall a. Data a => [(String, Fixity)] -> a -> a
applyFixities [(String, Fixity)]
fixities a
m =
  let m' :: a
m'  = (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
expFix [(String, Fixity)]
fixities) a
m
      m'' :: a
m'' = (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([(String, Fixity)] -> LPat GhcPs -> LPat GhcPs
patFix [(String, Fixity)]
fixities) a
m'
  in a
m''

expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
expFix [(String, Fixity)]
fixities (L SrcSpanAnnA
loc (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
l LHsExpr GhcPs
op LHsExpr GhcPs
r)) =
  [(String, Fixity)]
-> SrcSpanAnnA
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) SrcSpanAnnA
loc LHsExpr GhcPs
l LHsExpr GhcPs
op ([(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) LHsExpr GhcPs
op) LHsExpr GhcPs
r
expFix [(String, Fixity)]
_ LHsExpr GhcPs
e = LHsExpr GhcPs
e

-- LPat and Pat have gone through a lot of churn. See
-- https://gitlab.haskell.org/ghc/ghc/merge_requests/1925 for details.
patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs
#if ! ( defined (GHC_8_10) || defined (GHC_8_8) )
patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs
patFix [(String, Fixity)]
fixities (L SrcSpanAnnA
loc (ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
op (InfixCon LPat GhcPs
pat1 LPat GhcPs
pat2))) =
  SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc ([(String, Fixity)]
-> LocatedN RdrName
-> Fixity
-> LPat GhcPs
-> LPat GhcPs
-> Pat GhcPs
mkConOpPat ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op ([(String, Fixity)] -> LocatedN RdrName -> Fixity
findFixity' ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op) LPat GhcPs
pat1 LPat GhcPs
pat2)
#elif defined (GHC_8_10)
patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) =
  L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2)
#else
patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) =
  mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2
#endif
patFix [(String, Fixity)]
_ LPat GhcPs
p = LPat GhcPs
p

mkConOpPat ::
  [(String, Fixity)]
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  -> LocatedN RdrName
#else
  -> Located RdrName
#endif
  -> Fixity
  -> LPat GhcPs -> LPat GhcPs
  -> Pat GhcPs
#if ! ( defined (GHC_8_10) || defined (GHC_8_8) )
mkConOpPat :: [(String, Fixity)]
-> LocatedN RdrName
-> Fixity
-> LPat GhcPs
-> LPat GhcPs
-> Pat GhcPs
mkConOpPat [(String, Fixity)]
fs LocatedN RdrName
op2 Fixity
fix2 p1 :: LPat GhcPs
p1@(L SrcSpanAnnA
loc (ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
op1 (InfixCon LPat GhcPs
p11 LPat GhcPs
p12))) LPat GhcPs
p2
#elif defined (GHC_8_10)
mkConOpPat fs op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
#else
mkConOpPat fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2
#endif
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool
nofix_error = XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op2 (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1 LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2)
#elif defined (GHC_9_0)
  | nofix_error = ConPat noExtField op2 (InfixCon p1 p2)
#else
  | nofix_error = ConPatIn op2 (InfixCon p1 p2)
#endif
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool
associate_right = XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn XRec GhcPs (ConLikeP GhcPs)
op1 (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p11 (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc ([(String, Fixity)]
-> LocatedN RdrName
-> Fixity
-> LPat GhcPs
-> LPat GhcPs
-> Pat GhcPs
mkConOpPat [(String, Fixity)]
fs LocatedN RdrName
op2 Fixity
fix2 LPat GhcPs
p12 LPat GhcPs
p2)))
#elif defined (GHC_9_0)
  | associate_right = ConPat noExtField op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2)))
#elif defined (GHC_8_10)
  | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2)))
#else
  | associate_right = ConPatIn op1 (InfixCon p11 (cL loc (mkConOpPat fs op2 fix2 p12 p2)))
#endif
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool
otherwise = XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op2 (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1 LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2)
#elif defined (GHC_9_0)
  | otherwise = ConPat noExtField op2 (InfixCon p1 p2)
#else
  | otherwise = ConPatIn op2 (InfixCon p1 p2)
#endif
  where
    fix1 :: Fixity
fix1 = [(String, Fixity)] -> LocatedN RdrName -> Fixity
findFixity' [(String, Fixity)]
fs XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op1
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
mkConOpPat [(String, Fixity)]
_ LocatedN RdrName
op Fixity
_ LPat GhcPs
p1 LPat GhcPs
p2 = XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1 LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2)
#elif defined (GHC_9_0)
mkConOpPat _ op _ p1 p2 = ConPat noExtField op (InfixCon p1 p2)
#else
mkConOpPat _ op _ p1 p2 = ConPatIn op (InfixCon p1 p2)
#endif

mkOpApp ::
   [(String, Fixity)]
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
   -> SrcSpanAnnA
#else
   -> SrcSpan
#endif
   -> LHsExpr GhcPs -- Left operand; already rearrange.
   -> LHsExpr GhcPs -> Fixity -- Operator and fixity.
   -> LHsExpr GhcPs -- Right operand (not an OpApp, but might be a NegApp).
   -> LHsExpr GhcPs
--      (e11 `op1` e12) `op2` e2
mkOpApp :: [(String, Fixity)]
-> SrcSpanAnnA
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp [(String, Fixity)]
fs SrcSpanAnnA
loc e1 :: LHsExpr GhcPs
e1@(L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
x1 LHsExpr GhcPs
e11 LHsExpr GhcPs
op1 LHsExpr GhcPs
e12)) LHsExpr GhcPs
op2 Fixity
fix2 LHsExpr GhcPs
e2
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool
nofix_error = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
e1 LHsExpr GhcPs
op2 LHsExpr GhcPs
e2)
#else
  | nofix_error = L loc (OpApp noExt e1 op2 e2)
#endif
  | Bool
associate_right = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
x1 LHsExpr GhcPs
e11 LHsExpr GhcPs
op1 ([(String, Fixity)]
-> SrcSpanAnnA
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp [(String, Fixity)]
fs SrcSpanAnnA
loc' LHsExpr GhcPs
e12 LHsExpr GhcPs
op2 Fixity
fix2 LHsExpr GhcPs
e2 ))
  where
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
    loc' :: SrcSpanAnnA
loc'= GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
combineLocsA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e12 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2
#else
    loc'= combineLocs e12 e2
#endif
    fix1 :: Fixity
fix1 = [(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity [(String, Fixity)]
fs LHsExpr GhcPs
op1
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
--      (- neg_arg) `op` e2
mkOpApp [(String, Fixity)]
fs SrcSpanAnnA
loc e1 :: LHsExpr GhcPs
e1@(L SrcSpanAnnA
_ (NegApp XNegApp GhcPs
_ LHsExpr GhcPs
neg_arg SyntaxExpr GhcPs
neg_name)) LHsExpr GhcPs
op2 Fixity
fix2 LHsExpr GhcPs
e2
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool
nofix_error = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
e1 LHsExpr GhcPs
op2 LHsExpr GhcPs
e2)
#else
  | nofix_error = L loc (OpApp noExt e1 op2 e2)
#endif
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool
associate_right = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XNegApp GhcPs -> LHsExpr GhcPs -> SyntaxExpr GhcPs -> HsExpr GhcPs
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn ([(String, Fixity)]
-> SrcSpanAnnA
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp [(String, Fixity)]
fs SrcSpanAnnA
loc' LHsExpr GhcPs
neg_arg LHsExpr GhcPs
op2 Fixity
fix2 LHsExpr GhcPs
e2) SyntaxExpr GhcPs
neg_name)
#else
  | associate_right = L loc (NegApp noExt (mkOpApp fs loc' neg_arg op2 fix2 e2) neg_name)
#endif
  where
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
    loc' :: SrcSpanAnnA
loc' = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
combineLocsA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
neg_arg LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2
#else
    loc' = combineLocs neg_arg e2
#endif
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2
--      e1 `op` - neg_arg
mkOpApp [(String, Fixity)]
_ SrcSpanAnnA
loc LHsExpr GhcPs
e1 LHsExpr GhcPs
op1 Fixity
fix1 e2 :: LHsExpr GhcPs
e2@(L SrcSpanAnnA
_ NegApp {}) -- NegApp can occur on the right.
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
  | Bool -> Bool
not Bool
associate_right  = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
e1 LHsExpr GhcPs
op1 LHsExpr GhcPs
e2)-- We *want* right association.
#else
  | not associate_right  = L loc (OpApp noExt e1 op1 e2)-- We *want* right association.
#endif
  where
    (Bool
_, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
negateFixity
 --     Default case, no rearrangment.
#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
mkOpApp [(String, Fixity)]
_ SrcSpanAnnA
loc LHsExpr GhcPs
e1 LHsExpr GhcPs
op Fixity
_fix LHsExpr GhcPs
e2 = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
e1 LHsExpr GhcPs
op LHsExpr GhcPs
e2)
#else
mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noExt e1 op e2)
#endif

getIdent :: LHsExpr GhcPs -> String
getIdent :: LHsExpr GhcPs -> String
getIdent (LHsExpr GhcPs -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc -> HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
n)) = OccName -> String
occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> String) -> RdrName -> String
forall a b. (a -> b) -> a -> b
$ RdrName
n
getIdent LHsExpr GhcPs
_ = String -> String
forall a. HasCallStack => String -> a
error String
"Must be HsVar"

-- If there are no fixities, give 'baseFixities'.
getFixities :: [(String, Fixity)] -> [(String, Fixity)]
getFixities :: [(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities = if [(String, Fixity)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Fixity)]
fixities then [(String, Fixity)]
baseFixities else [(String, Fixity)]
fixities

findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity [(String, Fixity)]
fs LHsExpr GhcPs
r = [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
fs (LHsExpr GhcPs -> String
getIdent LHsExpr GhcPs
r) -- Expressions.

#if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
findFixity' :: [(String, Fixity)] -> LocatedN RdrName -> Fixity
#else
findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity
#endif
findFixity' :: [(String, Fixity)] -> LocatedN RdrName -> Fixity
findFixity' [(String, Fixity)]
fs LocatedN RdrName
r = [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
fs (OccName -> String
occNameString (OccName -> String)
-> (LocatedN RdrName -> OccName) -> LocatedN RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (LocatedN RdrName -> RdrName) -> LocatedN RdrName -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (LocatedN RdrName -> String) -> LocatedN RdrName -> String
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
r) -- Patterns.

askFix :: [(String, Fixity)] -> String -> Fixity
askFix :: [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
xs = \String
k -> Fixity -> String -> [(String, Fixity)] -> Fixity
forall {a} {a}. Eq a => a -> a -> [(a, a)] -> a
lookupWithDefault Fixity
defaultFixity String
k [(String, Fixity)]
xs
  where lookupWithDefault :: a -> a -> [(a, a)] -> a
lookupWithDefault a
def_v a
k [(a, a)]
mp1 = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def_v (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ a -> [(a, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
k [(a, a)]
mp1

-- All fixities defined in the Prelude.
preludeFixities :: [(String, Fixity)]
preludeFixities :: [(String, Fixity)]
preludeFixities = [[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> [String] -> [(String, Fixity)]
infixr_ Int
9  [String
"."]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
9  [String
"!!"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
8  [String
"^",String
"^^",String
"**"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
7  [String
"*",String
"/",String
"quot",String
"rem",String
"div",String
"mod",String
":%",String
"%"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
6  [String
"+",String
"-"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
5  [String
":",String
"++"]
    , Int -> [String] -> [(String, Fixity)]
infix_  Int
4  [String
"==",String
"/=",String
"<",String
"<=",String
">=",String
">",String
"elem",String
"notElem"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
3  [String
"&&"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
2  [String
"||"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
1  [String
">>",String
">>="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
1  [String
"=<<"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
0  [String
"$",String
"$!",String
"seq"]
    ]

-- All fixities defined in the base package. Note that the @+++@
-- operator appears in both Control.Arrows and
-- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in
-- this list is that of Control.Arrows.
baseFixities :: [(String, Fixity)]
baseFixities :: [(String, Fixity)]
baseFixities = [(String, Fixity)]
preludeFixities [(String, Fixity)] -> [(String, Fixity)] -> [(String, Fixity)]
forall a. [a] -> [a] -> [a]
++ [[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> [String] -> [(String, Fixity)]
infixr_ Int
9 [String
"Compose"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
9 [String
"!",String
"//",String
"!:"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
8 [String
"shift",String
"rotate",String
"shiftL",String
"shiftR",String
"rotateL",String
"rotateR"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
7 [String
".&."]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
6 [String
"xor"]
    , Int -> [String] -> [(String, Fixity)]
infix_  Int
6 [String
":+"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
6 [String
"<>"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
5 [String
".|."]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
5 [String
"+:+",String
"<++",String
"<+>",String
"<|"] -- Fixity conflict for +++ between ReadP and Arrow.
    , Int -> [String] -> [(String, Fixity)]
infix_  Int
5 [String
"\\\\"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
4 [String
"<$>",String
"<$",String
"$>",String
"<*>",String
"<*",String
"*>",String
"<**>",String
"<$!>"]
    , Int -> [String] -> [(String, Fixity)]
infix_  Int
4 [String
"elemP",String
"notElemP",String
":~:", String
":~~:"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
3 [String
"<|>"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
3 [String
"&&&",String
"***"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
2 [String
"+++",String
"|||"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
1 [String
"&"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
1 [String
"<=<",String
">=>",String
">>>",String
"<<<",String
"^<<",String
"<<^",String
"^>>",String
">>^"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
0 [String
"on"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
0 [String
"par",String
"pseq"]
    ]

infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)]
infixr_ :: Int -> [String] -> [(String, Fixity)]
infixr_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
InfixR
infixl_ :: Int -> [String] -> [(String, Fixity)]
infixl_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
InfixL
infix_ :: Int -> [String] -> [(String, Fixity)]
infix_  = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
InfixN

fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]
#if ! (defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) )
fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
a Int
p = (String -> (String, Fixity)) -> [String] -> [(String, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map (,SourceText -> Int -> FixityDirection -> Fixity
Fixity (FastString -> SourceText
SourceText (String -> FastString
fsLit String
"")) Int
p FixityDirection
a)
#else
fixity a p = map (,Fixity (SourceText "") p a)
#endif
#if defined (GHC_9_4) || defined(GHC_9_2) || defined (GHC_9_0)
fixitiesFromModule :: Located HsModule -> [(String, Fixity)]
#else
fixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)]
#endif
#if ! (defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
fixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)]
fixitiesFromModule (L SrcSpan
_ (HsModule XCModule GhcPs
_ Maybe (XRec GhcPs ModuleName)
_ Maybe (XRec GhcPs [LIE GhcPs])
_ [LImportDecl GhcPs]
_ [LHsDecl GhcPs]
decls)) = (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [(String, Fixity)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [(String, Fixity)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [(String, Fixity)]
GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [(String, Fixity)]
f [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls
#elif defined (GHC_9_4) || defined(GHC_9_2)
fixitiesFromModule (L _ (HsModule _ _ _ _ _ decls _ _)) = concatMap f decls
#elif defined (GHC_9_0)
fixitiesFromModule (L _ (HsModule _ _ _ _ decls _ _)) = concatMap f decls
#else
fixitiesFromModule (L _ (HsModule _ _ _ decls _ _)) = concatMap f decls
#endif
  where
    f :: LHsDecl GhcPs -> [(String, Fixity)]
    f :: LHsDecl GhcPs -> [(String, Fixity)]
f (L SrcSpanAnnA
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ (FixitySig XFixitySig GhcPs
_ [LIdP GhcPs]
ops (Fixity SourceText
_ Int
p FixityDirection
dir))))) =
          FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
dir Int
p ((LocatedN RdrName -> String) -> [LocatedN RdrName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString(OccName -> String)
-> (LocatedN RdrName -> OccName) -> LocatedN RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (LocatedN RdrName -> RdrName) -> LocatedN RdrName -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc) [LIdP GhcPs]
[LocatedN RdrName]
ops)
    f LHsDecl GhcPs
_ = []