-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Retrie.GHC
  ( module Retrie.GHC
#if __GLASGOW_HASKELL__ < 900
  , module ApiAnnotation
  , module Bag
  , module BasicTypes
  , module FastString
  , module FastStringEnv
#if __GLASGOW_HASKELL__ < 810
  , module HsExpr
  , module HsSyn
#else
  , module ErrUtils
  , module GHC.Hs.Expr
  , module GHC.Hs
#endif
  , module Module
  , module Name
  , module OccName
  , module RdrName
  , module SrcLoc
  , module Unique
  , module UniqFM
  , module UniqSet
#else
  -- GHC >= 9.0
  , module GHC.Data.Bag
  , module GHC.Data.FastString
  , module GHC.Data.FastString.Env
  , module GHC.Utils.Error
  , module GHC.Hs
  , module GHC.Parser.Annotation
  , module GHC.Types.Basic
  , module GHC.Types.Name
  , module GHC.Types.Name.Reader
  , module GHC.Types.SrcLoc
  , module GHC.Types.Unique
  , module GHC.Types.Unique.FM
  , module GHC.Types.Unique.Set
  , module GHC.Unit
#endif
  ) where

#if __GLASGOW_HASKELL__ < 900
import ApiAnnotation
import Bag
import BasicTypes
import FastString
import FastStringEnv
#if __GLASGOW_HASKELL__ < 810
import HsExpr
import HsSyn hiding (HsModule)
import qualified HsSyn as HS
#else
import ErrUtils
import GHC.Hs.Expr
import GHC.Hs hiding (HsModule)
import qualified GHC.Hs as HS
#endif
import Module
import Name
import OccName
import RdrName
import SrcLoc
import Unique
import UniqFM
import UniqSet
#else
-- GHC >= 9.0
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Utils.Error
import GHC.Hs
import GHC.Parser.Annotation
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Unit
#endif

import Data.Bifunctor (second)
import Data.Maybe

#if __GLASGOW_HASKELL__ < 900
type HsModule = HS.HsModule GhcPs
#endif

cLPat :: Located (Pat (GhcPass p)) -> LPat (GhcPass p)
#if __GLASGOW_HASKELL__ == 808
cLPat = composeSrcSpan
#else
cLPat :: Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat = Located (Pat (GhcPass p)) -> LPat (GhcPass p)
forall a. a -> a
id
#endif

-- | Only returns located pat if there is a genuine location available.
dLPat :: LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
#if __GLASGOW_HASKELL__ == 808
dLPat (XPat (L s p)) = Just $ L s $ stripSrcSpanPat p
dLPat _ = Nothing
#else
dLPat :: LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
dLPat = LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
forall a. a -> Maybe a
Just
#endif

-- | Will always give a location, but it may be noSrcSpan.
dLPatUnsafe :: LPat (GhcPass p) -> Located (Pat (GhcPass p))
#if __GLASGOW_HASKELL__ == 808
dLPatUnsafe = dL
#else
dLPatUnsafe :: LPat (GhcPass p) -> Located (Pat (GhcPass p))
dLPatUnsafe = LPat (GhcPass p) -> Located (Pat (GhcPass p))
forall a. a -> a
id
#endif

#if __GLASGOW_HASKELL__ == 808
stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p)
stripSrcSpanPat (XPat (L _  p)) = stripSrcSpanPat p
stripSrcSpanPat p = p
#endif

rdrFS :: RdrName -> FastString
rdrFS :: RdrName -> FastString
rdrFS (Qual ModuleName
m OccName
n) = [FastString] -> FastString
forall a. Monoid a => [a] -> a
mconcat [ModuleName -> FastString
moduleNameFS ModuleName
m, FastString
fsDot, OccName -> FastString
occNameFS OccName
n]
rdrFS RdrName
rdr = OccName -> FastString
occNameFS (RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
rdr)

fsDot :: FastString
fsDot :: FastString
fsDot = String -> FastString
mkFastString String
"."

varRdrName :: HsExpr p -> Maybe (Located (IdP p))
varRdrName :: HsExpr p -> Maybe (Located (IdP p))
varRdrName (HsVar XVar p
_ Located (IdP p)
n) = Located (IdP p) -> Maybe (Located (IdP p))
forall a. a -> Maybe a
Just Located (IdP p)
n
varRdrName HsExpr p
_ = Maybe (Located (IdP p))
forall a. Maybe a
Nothing

tyvarRdrName :: HsType p -> Maybe (Located (IdP p))
tyvarRdrName :: HsType p -> Maybe (Located (IdP p))
tyvarRdrName (HsTyVar XTyVar p
_ PromotionFlag
_ Located (IdP p)
n) = Located (IdP p) -> Maybe (Located (IdP p))
forall a. a -> Maybe a
Just Located (IdP p)
n
tyvarRdrName HsType p
_ = Maybe (Located (IdP p))
forall a. Maybe a
Nothing

fixityDecls :: HsModule -> [(Located RdrName, Fixity)]
fixityDecls :: HsModule -> [(Located RdrName, Fixity)]
fixityDecls HsModule
m =
  [ (Located RdrName
nm, Fixity
fixity)
  | L SrcSpan
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ (FixitySig XFixitySig GhcPs
_ [Located (IdP GhcPs)]
nms Fixity
fixity))) <- HsModule -> [GenLocated SrcSpan (HsDecl GhcPs)]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule
m
  , Located RdrName
nm <- [Located (IdP GhcPs)]
[Located RdrName]
nms
  ]

ruleInfo :: RuleDecl GhcPs -> [RuleInfo]
ruleInfo :: RuleDecl GhcPs -> [RuleInfo]
ruleInfo (HsRule XHsRule GhcPs
_ (L SrcSpan
_ (SourceText
_, FastString
riName)) Activation
_ Maybe [LHsTyVarBndr (NoGhcTc GhcPs)]
tyBs [LRuleBndr GhcPs]
valBs Located (HsExpr GhcPs)
riLHS Located (HsExpr GhcPs)
riRHS) =
  let
    riQuantifiers :: [RdrName]
riQuantifiers =
      (Located RdrName -> RdrName) -> [Located RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([LHsTyVarBndr GhcPs] -> [Located RdrName]
tyBindersToLocatedRdrNames ([LHsTyVarBndr GhcPs]
-> Maybe [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr GhcPs]
Maybe [LHsTyVarBndr (NoGhcTc GhcPs)]
tyBs)) [RdrName] -> [RdrName] -> [RdrName]
forall a. [a] -> [a] -> [a]
++
      [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs [LRuleBndr GhcPs]
valBs
  in [ RuleInfo :: FastString
-> [RdrName]
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> RuleInfo
RuleInfo{[RdrName]
Located (HsExpr GhcPs)
FastString
riRHS :: Located (HsExpr GhcPs)
riLHS :: Located (HsExpr GhcPs)
riQuantifiers :: [RdrName]
riName :: FastString
riQuantifiers :: [RdrName]
riRHS :: Located (HsExpr GhcPs)
riLHS :: Located (HsExpr GhcPs)
riName :: FastString
..} ]
#if __GLASGOW_HASKELL__ < 900
ruleInfo XRuleDecl{} = []
#endif

ruleBindersToQs :: [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs :: [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs [LRuleBndr GhcPs]
bs = [Maybe RdrName] -> [RdrName]
forall a. [Maybe a] -> [a]
catMaybes
  [ case RuleBndr GhcPs
b of
      RuleBndr XCRuleBndr GhcPs
_ (L SrcSpan
_ IdP GhcPs
v) -> RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just IdP GhcPs
RdrName
v
      RuleBndrSig XRuleBndrSig GhcPs
_ (L SrcSpan
_ IdP GhcPs
v) LHsSigWcType GhcPs
_ -> RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just IdP GhcPs
RdrName
v
#if __GLASGOW_HASKELL__ < 900
      XRuleBndr{} -> Maybe RdrName
forall a. Maybe a
Nothing
#endif
  | L SrcSpan
_ RuleBndr GhcPs
b <- [LRuleBndr GhcPs]
bs
  ]

#if __GLASGOW_HASKELL__ < 900
tyBindersToLocatedRdrNames :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
#else
tyBindersToLocatedRdrNames :: [LHsTyVarBndr () GhcPs] -> [Located RdrName]
#endif
tyBindersToLocatedRdrNames :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
tyBindersToLocatedRdrNames [LHsTyVarBndr GhcPs]
vars = [Maybe (Located RdrName)] -> [Located RdrName]
forall a. [Maybe a] -> [a]
catMaybes
  [ case HsTyVarBndr GhcPs
var of
#if __GLASGOW_HASKELL__ < 900
      UserTyVar XUserTyVar GhcPs
_ Located (IdP GhcPs)
v -> Located RdrName -> Maybe (Located RdrName)
forall a. a -> Maybe a
Just Located (IdP GhcPs)
Located RdrName
v
      KindedTyVar XKindedTyVar GhcPs
_ Located (IdP GhcPs)
v LHsKind GhcPs
_ -> Located RdrName -> Maybe (Located RdrName)
forall a. a -> Maybe a
Just Located (IdP GhcPs)
Located RdrName
v
      XTyVarBndr{} -> Maybe (Located RdrName)
forall a. Maybe a
Nothing
#else
      UserTyVar _ _ v -> Just v
      KindedTyVar _ _ v _ -> Just v
#endif
  | L SrcSpan
_ HsTyVarBndr GhcPs
var <- [LHsTyVarBndr GhcPs]
vars ]

data RuleInfo = RuleInfo
  { RuleInfo -> FastString
riName :: RuleName
  , RuleInfo -> [RdrName]
riQuantifiers :: [RdrName]
  , RuleInfo -> Located (HsExpr GhcPs)
riLHS :: LHsExpr GhcPs
  , RuleInfo -> Located (HsExpr GhcPs)
riRHS :: LHsExpr GhcPs
  }

#if __GLASGOW_HASKELL__ < 810
noExtField :: NoExt
noExtField = noExt
#endif

overlaps :: SrcSpan -> SrcSpan -> Bool
overlaps :: SrcSpan -> SrcSpan -> Bool
overlaps SrcSpan
ss1 SrcSpan
ss2
  | Just RealSrcSpan
s1 <- SrcSpan -> Maybe RealSrcSpan
getRealSpan SrcSpan
ss1, Just RealSrcSpan
s2 <- SrcSpan -> Maybe RealSrcSpan
getRealSpan SrcSpan
ss2 =
    RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s1 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s2 Bool -> Bool -> Bool
&&
    ((RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s1, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s1) (Int, Int) -> RealSrcSpan -> Bool
`within` RealSrcSpan
s2 Bool -> Bool -> Bool
||
     (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s1, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s1) (Int, Int) -> RealSrcSpan -> Bool
`within` RealSrcSpan
s2)
overlaps SrcSpan
_ SrcSpan
_ = Bool
False

within :: (Int, Int) -> RealSrcSpan -> Bool
within :: (Int, Int) -> RealSrcSpan -> Bool
within (Int
l,Int
p) RealSrcSpan
s =
  RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l Bool -> Bool -> Bool
&&
  RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
p  Bool -> Bool -> Bool
&&
  RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l   Bool -> Bool -> Bool
&&
  RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
p

lineCount :: [SrcSpan] -> Int
lineCount :: [SrcSpan] -> Int
lineCount [SrcSpan]
ss = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
  [ RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  | Just RealSrcSpan
s <- (SrcSpan -> Maybe RealSrcSpan) -> [SrcSpan] -> [Maybe RealSrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map SrcSpan -> Maybe RealSrcSpan
getRealSpan [SrcSpan]
ss
  ]

showRdrs :: [RdrName] -> String
showRdrs :: [RdrName] -> String
showRdrs = [String] -> String
forall a. Show a => a -> String
show ([String] -> String)
-> ([RdrName] -> [String]) -> [RdrName] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RdrName -> String) -> [RdrName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName)

#if __GLASGOW_HASKELL__ < 900
uniqBag :: Uniquable a => [(a,b)] -> UniqFM [b]
#else
uniqBag :: Uniquable a => [(a,b)] -> UniqFM a [b]
#endif
uniqBag :: [(a, b)] -> UniqFM [b]
uniqBag = ([b] -> [b] -> [b]) -> [(a, [b])] -> UniqFM [b]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> [(key, elt)] -> UniqFM elt
listToUFM_C [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++) ([(a, [b])] -> UniqFM [b])
-> ([(a, b)] -> [(a, [b])]) -> [(a, b)] -> UniqFM [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (a, [b])) -> [(a, b)] -> [(a, [b])]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> [b]) -> (a, b) -> (a, [b])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second b -> [b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

getRealLoc :: SrcLoc -> Maybe RealSrcLoc
#if __GLASGOW_HASKELL__ < 900
getRealLoc :: SrcLoc -> Maybe RealSrcLoc
getRealLoc (RealSrcLoc RealSrcLoc
l) = RealSrcLoc -> Maybe RealSrcLoc
forall a. a -> Maybe a
Just RealSrcLoc
l
#else
getRealLoc (RealSrcLoc l _) = Just l
#endif
getRealLoc SrcLoc
_ = Maybe RealSrcLoc
forall a. Maybe a
Nothing

getRealSpan :: SrcSpan -> Maybe RealSrcSpan
#if __GLASGOW_HASKELL__ < 900
getRealSpan :: SrcSpan -> Maybe RealSrcSpan
getRealSpan (RealSrcSpan RealSrcSpan
s) = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
s
#else
getRealSpan (RealSrcSpan s _) = Just s
#endif
getRealSpan SrcSpan
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing