-- 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
#if __GLASGOW_HASKELL__ >= 906
import Language.Haskell.Syntax.Basic as GHC.Unit.Module.Name
#else
import GHC.Unit.Module.Name
#endif
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 = XRec (GhcPass p) (Pat (GhcPass p))
-> XRec (GhcPass p) (Pat (GhcPass p))
GenLocated SrcSpanAnnA (Pat (GhcPass p))
-> GenLocated SrcSpanAnnA (Pat (GhcPass p))
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 = XRec (GhcPass p) (Pat (GhcPass p))
-> Maybe (XRec (GhcPass p) (Pat (GhcPass p)))
GenLocated SrcSpanAnnA (Pat (GhcPass p))
-> Maybe (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
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 = XRec (GhcPass p) (Pat (GhcPass p))
-> XRec (GhcPass p) (Pat (GhcPass p))
GenLocated SrcSpanAnnA (Pat (GhcPass p))
-> GenLocated SrcSpanAnnA (Pat (GhcPass p))
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) = [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 (LIdP p)
varRdrName :: forall p. HsExpr p -> Maybe (LIdP p)
varRdrName (HsVar XVar p
_ LIdP p
n) = LIdP p -> Maybe (LIdP p)
forall a. a -> Maybe a
Just LIdP p
n
varRdrName HsExpr p
_ = Maybe (LIdP 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) = LIdP p -> Maybe (LIdP p)
forall a. a -> Maybe a
Just LIdP p
n
tyvarRdrName HsType p
_ = Maybe (LIdP p)
forall a. Maybe a
Nothing

-- fixityDecls :: HsModule -> [(LIdP p, Fixity)]
#if __GLASGOW_HASKELL__ >= 906
fixityDecls :: HsModule GhcPs -> [(LocatedN RdrName, Fixity)]
#else
fixityDecls :: HsModule -> [(LocatedN RdrName, Fixity)]
#endif
fixityDecls :: HsModule GhcPs -> [(LocatedN RdrName, Fixity)]
fixityDecls HsModule GhcPs
m =
  [ (LocatedN RdrName
nm, Fixity
fixity)
  | L SrcSpanAnnA
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ (FixitySig XFixitySig GhcPs
_ [LIdP GhcPs]
nms Fixity
fixity))) <- HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
m
  , LocatedN RdrName
nm <- [LIdP GhcPs]
[LocatedN RdrName]
nms
  ]

ruleInfo :: RuleDecl GhcPs -> [RuleInfo]
#if __GLASGOW_HASKELL__ >= 906
ruleInfo :: RuleDecl GhcPs -> [RuleInfo]
ruleInfo (HsRule XHsRule GhcPs
_ (L SrcAnn NoEpAnns
_ FastString
riName) Activation
_ Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyBs [LRuleBndr GhcPs]
valBs XRec GhcPs (HsExpr GhcPs)
riLHS XRec GhcPs (HsExpr GhcPs)
riRHS) =
#else
ruleInfo (HsRule _ (L _ (_, riName)) _ tyBs valBs riLHS riRHS) =
#endif
  let
    riQuantifiers :: [RdrName]
riQuantifiers =
      (LocatedN RdrName -> RdrName) -> [LocatedN RdrName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc ([LHsTyVarBndr () GhcPs] -> [LocatedN RdrName]
forall s. [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]
tyBindersToLocatedRdrNames ([GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
-> Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tyBs)) [RdrName] -> [RdrName] -> [RdrName]
forall a. [a] -> [a] -> [a]
++
      [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs [LRuleBndr GhcPs]
valBs
  in [ RuleInfo{[RdrName]
FastString
XRec GhcPs (HsExpr GhcPs)
riName :: FastString
riLHS :: XRec GhcPs (HsExpr GhcPs)
riRHS :: XRec GhcPs (HsExpr GhcPs)
riQuantifiers :: [RdrName]
riName :: FastString
riQuantifiers :: [RdrName]
riLHS :: XRec GhcPs (HsExpr GhcPs)
riRHS :: XRec GhcPs (HsExpr GhcPs)
..} ]

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 SrcSpanAnnN
_ RdrName
v) -> RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just RdrName
v
      RuleBndrSig XRuleBndrSig GhcPs
_ (L SrcSpanAnnN
_ RdrName
v) HsPatSigType GhcPs
_ -> RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just RdrName
v
  | L SrcAnn NoEpAnns
_ RuleBndr GhcPs
b <- [LRuleBndr GhcPs]
[GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
bs
  ]

tyBindersToLocatedRdrNames :: [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]
tyBindersToLocatedRdrNames :: forall s. [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]
tyBindersToLocatedRdrNames [LHsTyVarBndr s GhcPs]
vars = [Maybe (LocatedN RdrName)] -> [LocatedN RdrName]
forall a. [Maybe a] -> [a]
catMaybes
  [ case HsTyVarBndr s GhcPs
var of
      UserTyVar XUserTyVar GhcPs
_ s
_ LIdP GhcPs
v -> LocatedN RdrName -> Maybe (LocatedN RdrName)
forall a. a -> Maybe a
Just LIdP GhcPs
LocatedN RdrName
v
      KindedTyVar XKindedTyVar GhcPs
_ s
_ LIdP GhcPs
v LHsKind GhcPs
_ -> LocatedN RdrName -> Maybe (LocatedN RdrName)
forall a. a -> Maybe a
Just LIdP GhcPs
LocatedN RdrName
v
  | L SrcSpanAnnA
_ HsTyVarBndr s GhcPs
var <- [LHsTyVarBndr s GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr 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 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 a. Num a => [a] -> a
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
  | RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ <- [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)

uniqBag :: Uniquable a => [(a,b)] -> UniqFM a [b]
uniqBag :: forall a b. Uniquable a => [(a, b)] -> UniqFM a [b]
uniqBag = ([b] -> [b] -> [b]) -> [(a, [b])] -> UniqFM a [b]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> [(key, elt)] -> UniqFM key elt
listToUFM_C [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++) ([(a, [b])] -> UniqFM a [b])
-> ([(a, b)] -> [(a, [b])]) -> [(a, b)] -> UniqFM a [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 b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second b -> [b]
forall a. a -> [a]
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
_) = RealSrcLoc -> Maybe RealSrcLoc
forall a. a -> Maybe a
Just RealSrcLoc
l
#endif
getRealLoc SrcLoc
_ = Maybe RealSrcLoc
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
_) = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
s
#endif
getRealSpan SrcSpan
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing