-- 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
  , module GHC.Data.Bag
  , module GHC.Data.FastString
  , module GHC.Data.FastString.Env
  , module GHC.Driver.Errors
  , module GHC.Hs
  , module GHC.Hs.Expr
  , module GHC.Parser.Annotation
  , module GHC.Parser.Errors.Ppr
  , module GHC.Plugins
  , module GHC.Types.Basic
  , module GHC.Types.Error
  , module GHC.Types.Fixity
  , module GHC.Types.Name
  , module GHC.Types.Name.Occurrence
  , module GHC.Types.Name.Reader
  , module GHC.Types.SourceText
  , module GHC.Types.SrcLoc
  , module GHC.Types.Unique
  , module GHC.Types.Unique.FM
  , module GHC.Types.Unique.Set
  , module GHC.Unit.Module.Name
  , module GHC.Utils.Outputable
  ) where

import GHC
import GHC.Builtin.Names
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Driver.Errors
import GHC.Hs
import GHC.Hs.Expr
import GHC.Parser.Annotation
import GHC.Parser.Errors.Ppr
import GHC.Plugins (showSDoc)
import GHC.Types.Basic hiding (EP)
import GHC.Types.Error
import GHC.Types.Fixity
import GHC.Types.Name
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Unit.Module.Name
import GHC.Utils.Outputable (Outputable (ppr))

import Data.Bifunctor (second)
import Data.Maybe

cLPat :: LPat (GhcPass p) -> LPat (GhcPass p)
cLPat :: forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat = forall a. a -> a
id

-- | Only returns located pat if there is a genuine location available.
dLPat :: LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat :: forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat = forall a. a -> Maybe a
Just

-- | Will always give a location, but it may be noSrcSpan.
dLPatUnsafe :: LPat (GhcPass p) -> LPat (GhcPass p)
dLPatUnsafe :: forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
dLPatUnsafe = forall a. a -> a
id

#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) = 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 (forall name. HasOccName name => name -> OccName
occName RdrName
rdr)

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

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

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

-- fixityDecls :: HsModule -> [(LIdP p, Fixity)]
fixityDecls :: HsModule -> [(LocatedN RdrName, Fixity)]
fixityDecls :: HsModule -> [(LocatedN RdrName, Fixity)]
fixityDecls HsModule
m =
  [ (LocatedN RdrName
nm, Fixity
fixity)
  | L SrcSpanAnnA
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ (FixitySig XFixitySig GhcPs
_ [LIdP GhcPs]
nms Fixity
fixity))) <- HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
m
  , LocatedN RdrName
nm <- [LIdP GhcPs]
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 XRec GhcPs (HsExpr GhcPs)
riLHS XRec GhcPs (HsExpr GhcPs)
riRHS) =
  let
    riQuantifiers :: [RdrName]
riQuantifiers =
      forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc (forall s. [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]
tyBindersToLocatedRdrNames (forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyBs)) forall a. [a] -> [a] -> [a]
++
      [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs [LRuleBndr GhcPs]
valBs
  in [ RuleInfo{[RdrName]
XRec GhcPs (HsExpr GhcPs)
FastString
riRHS :: XRec GhcPs (HsExpr GhcPs)
riLHS :: XRec GhcPs (HsExpr GhcPs)
riQuantifiers :: [RdrName]
riName :: FastString
riQuantifiers :: [RdrName]
riRHS :: XRec GhcPs (HsExpr GhcPs)
riLHS :: XRec GhcPs (HsExpr GhcPs)
riName :: FastString
..} ]

ruleBindersToQs :: [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs :: [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs [LRuleBndr GhcPs]
bs = forall a. [Maybe a] -> [a]
catMaybes
  [ case RuleBndr GhcPs
b of
      RuleBndr XCRuleBndr GhcPs
_ (L SrcSpanAnnN
_ RdrName
v) -> forall a. a -> Maybe a
Just RdrName
v
      RuleBndrSig XRuleBndrSig GhcPs
_ (L SrcSpanAnnN
_ RdrName
v) HsPatSigType GhcPs
_ -> forall a. a -> Maybe a
Just RdrName
v
  | L SrcSpan
_ RuleBndr GhcPs
b <- [LRuleBndr GhcPs]
bs
  ]

tyBindersToLocatedRdrNames :: [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]
tyBindersToLocatedRdrNames :: forall s. [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]
tyBindersToLocatedRdrNames [LHsTyVarBndr s GhcPs]
vars = forall a. [Maybe a] -> [a]
catMaybes
  [ case HsTyVarBndr s GhcPs
var of
      UserTyVar XUserTyVar GhcPs
_ s
_ LIdP GhcPs
v -> forall a. a -> Maybe a
Just LIdP GhcPs
v
      KindedTyVar XKindedTyVar GhcPs
_ s
_ LIdP GhcPs
v LHsKind GhcPs
_ -> forall a. a -> Maybe a
Just LIdP GhcPs
v
  | L SrcSpanAnnA
_ HsTyVarBndr s GhcPs
var <- [LHsTyVarBndr s GhcPs]
vars ]

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

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

overlaps :: SrcSpan -> SrcSpan -> Bool
overlaps :: SrcSpan -> SrcSpan -> Bool
overlaps (RealSrcSpan RealSrcSpan
s1 Maybe BufSpan
_) (RealSrcSpan RealSrcSpan
s2 Maybe BufSpan
_) =
     RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s1 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 forall a. Ord a => a -> a -> Bool
<= Int
l Bool -> Bool -> Bool
&&
  RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s forall a. Ord a => a -> a -> Bool
<= Int
p  Bool -> Bool -> Bool
&&
  RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s forall a. Ord a => a -> a -> Bool
>= Int
l   Bool -> Bool -> Bool
&&
  RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s forall a. Ord a => a -> a -> Bool
>= Int
p

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

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

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

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

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