{-# language ApplicativeDo #-}
{-# language BlockArguments #-}
{-# language DeriveGeneric #-}
{-# language FlexibleContexts #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language NoImplicitPrelude #-}
{-# language OverloadedLabels #-}
{-# language OverloadedStrings #-}

module Weeder
  ( -- * Analysis
    Analysis(..)
  , analyseHieFile
  , emptyAnalysis
  , allDeclarations

    -- ** Reachability
  , Root(..)
  , reachable

    -- * Declarations
  , Declaration(..)
  )
   where

-- algebraic-graphs
import Algebra.Graph ( Graph, edge, empty, overlay, vertex, vertexList )
import Algebra.Graph.ToGraph ( dfs )

-- base
import Control.Applicative ( Alternative )
import Control.Monad ( guard, msum, when )
import Data.Foldable ( for_, traverse_ )
import Data.List ( intercalate )
import Data.Monoid ( First( First ) )
import GHC.Generics ( Generic )
import Prelude hiding ( span )

-- containers
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import Data.Sequence ( Seq )
import Data.Set ( Set )
import qualified Data.Set as Set

-- generic-lens
import Data.Generics.Labels ()

-- ghc
import GHC.Data.FastString ( unpackFS )
import GHC.Types.Avail
  ( AvailInfo( Avail, AvailTC )
  , GreName( NormalGreName, FieldGreName )
  )
import GHC.Types.FieldLabel ( FieldLabel( FieldLabel, flSelector ) )
import GHC.Iface.Ext.Types
  ( BindType( RegularBind )
  , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl )
  , DeclType( DataDec, ClassDec, ConDec )
  , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo )
  , HieASTs( HieASTs )
  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file )
  , IdentifierDetails( IdentifierDetails, identInfo )
  , NodeAnnotation( NodeAnnotation, nodeAnnotType )
  , NodeInfo( nodeIdentifiers, nodeAnnotations )
  , Scope( ModuleScope )
  , getSourcedNodeInfo
  )
import GHC.Unit.Module ( Module, moduleStableString )
import GHC.Types.Name
  ( Name, nameModule_maybe, nameOccName
  , OccName
  , isDataOcc
  , isDataSymOcc
  , isTcOcc
  , isTvOcc
  , isVarOcc
  , occNameString
  )
import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart )

-- lens
import Control.Lens ( (%=) )

-- mtl
import Control.Monad.State.Class ( MonadState )

-- transformers
import Control.Monad.Trans.Maybe ( runMaybeT )


data Declaration =
  Declaration
    { Declaration -> Module
declModule :: Module
      -- ^ The module this declaration occurs in.
    , Declaration -> OccName
declOccName :: OccName
      -- ^ The symbol name of a declaration.
    }
  deriving
    ( Declaration -> Declaration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Declaration -> Declaration -> Bool
$c/= :: Declaration -> Declaration -> Bool
== :: Declaration -> Declaration -> Bool
$c== :: Declaration -> Declaration -> Bool
Eq, Eq Declaration
Declaration -> Declaration -> Bool
Declaration -> Declaration -> Ordering
Declaration -> Declaration -> Declaration
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Declaration -> Declaration -> Declaration
$cmin :: Declaration -> Declaration -> Declaration
max :: Declaration -> Declaration -> Declaration
$cmax :: Declaration -> Declaration -> Declaration
>= :: Declaration -> Declaration -> Bool
$c>= :: Declaration -> Declaration -> Bool
> :: Declaration -> Declaration -> Bool
$c> :: Declaration -> Declaration -> Bool
<= :: Declaration -> Declaration -> Bool
$c<= :: Declaration -> Declaration -> Bool
< :: Declaration -> Declaration -> Bool
$c< :: Declaration -> Declaration -> Bool
compare :: Declaration -> Declaration -> Ordering
$ccompare :: Declaration -> Declaration -> Ordering
Ord )


instance Show Declaration where
  show :: Declaration -> FilePath
show =
    Declaration -> FilePath
declarationStableName


declarationStableName :: Declaration -> String
declarationStableName :: Declaration -> FilePath
declarationStableName Declaration { Module
declModule :: Module
declModule :: Declaration -> Module
declModule, OccName
declOccName :: OccName
declOccName :: Declaration -> OccName
declOccName } =
  let
    namespace :: FilePath
namespace
      | OccName -> Bool
isVarOcc OccName
declOccName     = FilePath
"var"
      | OccName -> Bool
isTvOcc OccName
declOccName      = FilePath
"tv"
      | OccName -> Bool
isTcOcc OccName
declOccName      = FilePath
"tc"
      | OccName -> Bool
isDataOcc OccName
declOccName    = FilePath
"data"
      | OccName -> Bool
isDataSymOcc OccName
declOccName = FilePath
"dataSym"
      | Bool
otherwise                = FilePath
"unknown"

    in
    forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"$" [ FilePath
namespace, Module -> FilePath
moduleStableString Module
declModule, FilePath
"$", OccName -> FilePath
occNameString OccName
declOccName ]


-- | All information maintained by 'analyseHieFile'.
data Analysis =
  Analysis
    { Analysis -> Graph Declaration
dependencyGraph :: Graph Declaration
      -- ^ A graph between declarations, capturing dependencies.
    , Analysis -> Map Declaration (Set RealSrcSpan)
declarationSites :: Map Declaration ( Set RealSrcSpan )
      -- ^ A partial mapping between declarations and their definition site.
      -- This Map is partial as we don't always know where a Declaration was
      -- defined (e.g., it may come from a package without source code).
      -- We capture a set of spans, because a declaration may be defined in
      -- multiple locations, e.g., a type signature for a function separate
      -- from its definition.
    , Analysis -> Set Declaration
implicitRoots :: Set Declaration
      -- ^ The Set of all Declarations that are always reachable. This is used
      -- to capture knowledge not yet modelled in weeder, such as instance
      -- declarations depending on top-level functions.
    , Analysis -> Map Module (Set Declaration)
exports :: Map Module ( Set Declaration )
      -- ^ All exports for a given module.
    , Analysis -> Map Module FilePath
modulePaths :: Map Module FilePath
      -- ^ A map from modules to the file path to the .hs file defining them.
    }
  deriving
    ( forall x. Rep Analysis x -> Analysis
forall x. Analysis -> Rep Analysis x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Analysis x -> Analysis
$cfrom :: forall x. Analysis -> Rep Analysis x
Generic )


-- | The empty analysis - the result of analysing zero @.hie@ files.
emptyAnalysis :: Analysis
emptyAnalysis :: Analysis
emptyAnalysis = Graph Declaration
-> Map Declaration (Set RealSrcSpan)
-> Set Declaration
-> Map Module (Set Declaration)
-> Map Module FilePath
-> Analysis
Analysis forall a. Graph a
empty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty


-- | A root for reachability analysis.
data Root
  = -- | A given declaration is a root.
    DeclarationRoot Declaration
  | -- | All exported declarations in a module are roots.
    ModuleRoot Module
  deriving
    ( Root -> Root -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Root -> Root -> Bool
$c/= :: Root -> Root -> Bool
== :: Root -> Root -> Bool
$c== :: Root -> Root -> Bool
Eq, Eq Root
Root -> Root -> Bool
Root -> Root -> Ordering
Root -> Root -> Root
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Root -> Root -> Root
$cmin :: Root -> Root -> Root
max :: Root -> Root -> Root
$cmax :: Root -> Root -> Root
>= :: Root -> Root -> Bool
$c>= :: Root -> Root -> Bool
> :: Root -> Root -> Bool
$c> :: Root -> Root -> Bool
<= :: Root -> Root -> Bool
$c<= :: Root -> Root -> Bool
< :: Root -> Root -> Bool
$c< :: Root -> Root -> Bool
compare :: Root -> Root -> Ordering
$ccompare :: Root -> Root -> Ordering
Ord )


-- | Determine the set of all declaration reachable from a set of roots.
reachable :: Analysis -> Set Root -> Set Declaration
reachable :: Analysis -> Set Root -> Set Declaration
reachable Analysis{ Graph Declaration
dependencyGraph :: Graph Declaration
dependencyGraph :: Analysis -> Graph Declaration
dependencyGraph, Map Module (Set Declaration)
exports :: Map Module (Set Declaration)
exports :: Analysis -> Map Module (Set Declaration)
exports } Set Root
roots =
  forall a. Ord a => [a] -> Set a
Set.fromList ( forall t.
(ToGraph t, Ord (ToVertex t)) =>
[ToVertex t] -> t -> [ToVertex t]
dfs ( forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Root -> [Declaration]
rootDeclarations Set Root
roots ) Graph Declaration
dependencyGraph )

  where

    rootDeclarations :: Root -> [Declaration]
rootDeclarations = \case
      DeclarationRoot Declaration
d -> [ Declaration
d ]
      ModuleRoot Module
m -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Set a -> [a]
Set.toList ( forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
m Map Module (Set Declaration)
exports )


-- | The set of all known declarations, including usages.
allDeclarations :: Analysis -> Set Declaration
allDeclarations :: Analysis -> Set Declaration
allDeclarations Analysis{ Graph Declaration
dependencyGraph :: Graph Declaration
dependencyGraph :: Analysis -> Graph Declaration
dependencyGraph } =
  forall a. Ord a => [a] -> Set a
Set.fromList ( forall a. Ord a => Graph a -> [a]
vertexList Graph Declaration
dependencyGraph )


-- | Incrementally update 'Analysis' with information in a 'HieFile'.
analyseHieFile :: MonadState Analysis m => HieFile -> m ()
analyseHieFile :: forall (m :: * -> *). MonadState Analysis m => HieFile -> m ()
analyseHieFile HieFile{ hie_asts :: HieFile -> HieASTs Int
hie_asts = HieASTs Map HiePath (HieAST Int)
hieASTs, [AvailInfo]
hie_exports :: [AvailInfo]
hie_exports :: HieFile -> [AvailInfo]
hie_exports, Module
hie_module :: Module
hie_module :: HieFile -> Module
hie_module, FilePath
hie_hs_file :: FilePath
hie_hs_file :: HieFile -> FilePath
hie_hs_file } = do
  #modulePaths %= Map.insert hie_module hie_hs_file

  for_ hieASTs \ast -> do
    addAllDeclarations ast
    topLevelAnalysis ast

  for_ hie_exports ( analyseExport hie_module )


analyseExport :: MonadState Analysis m => Module -> AvailInfo -> m ()
analyseExport :: forall (m :: * -> *).
MonadState Analysis m =>
Module -> AvailInfo -> m ()
analyseExport Module
m = \case
  Avail (NormalGreName Name
name) ->
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport forall a b. (a -> b) -> a -> b
$ Name -> Maybe Declaration
nameToDeclaration Name
name

  Avail (FieldGreName (FieldLabel{ Name
flSelector :: Name
flSelector :: FieldLabel -> Name
flSelector })) ->
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport forall a b. (a -> b) -> a -> b
$ Name -> Maybe Declaration
nameToDeclaration Name
flSelector

  AvailTC Name
name [GreName]
pieces -> do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( Name -> Maybe Declaration
nameToDeclaration Name
name ) forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport

    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [GreName]
pieces \case
      NormalGreName Name
name ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport forall a b. (a -> b) -> a -> b
$ Name -> Maybe Declaration
nameToDeclaration Name
name

      FieldGreName (FieldLabel{ Name
flSelector :: Name
flSelector :: FieldLabel -> Name
flSelector }) ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport forall a b. (a -> b) -> a -> b
$ Name -> Maybe Declaration
nameToDeclaration Name
flSelector

  where

    addExport :: MonadState Analysis m => Declaration -> m ()
    addExport :: forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport Declaration
d = forall a. IsLabel "exports" a => a
#exports forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) Module
m ( forall a. a -> Set a
Set.singleton Declaration
d )


-- | @addDependency x y@ adds the information that @x@ depends on @y@.
addDependency :: MonadState Analysis m => Declaration -> Declaration -> m ()
addDependency :: forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> Declaration -> m ()
addDependency Declaration
x Declaration
y =
  #dependencyGraph %= overlay ( edge x y )


addImplicitRoot :: MonadState Analysis m => Declaration -> m ()
addImplicitRoot :: forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addImplicitRoot Declaration
x =
  #implicitRoots %= Set.insert x


define :: MonadState Analysis m => Declaration -> RealSrcSpan -> m ()
define :: forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> RealSrcSpan -> m ()
define Declaration
decl RealSrcSpan
span =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
span forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
span ) do
    #declarationSites %= Map.insertWith Set.union decl ( Set.singleton span )
    #dependencyGraph %= overlay ( vertex decl )


addDeclaration :: MonadState Analysis m => Declaration -> m ()
addDeclaration :: forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addDeclaration Declaration
decl =
  #dependencyGraph %= overlay ( vertex decl )


-- | Try and add vertices for all declarations in an AST - both
-- those declared here, and those referred to from here.
addAllDeclarations :: ( MonadState Analysis m ) => HieAST a -> m ()
addAllDeclarations :: forall (m :: * -> *) a. MonadState Analysis m => HieAST a -> m ()
addAllDeclarations n :: HieAST a
n@Node{ [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren } = do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers ( forall a b. a -> b -> a
const Bool
True ) HieAST a
n ) forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addDeclaration

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [HieAST a]
nodeChildren forall (m :: * -> *) a. MonadState Analysis m => HieAST a -> m ()
addAllDeclarations


topLevelAnalysis :: MonadState Analysis m => HieAST a -> m ()
topLevelAnalysis :: forall (m :: * -> *) a. MonadState Analysis m => HieAST a -> m ()
topLevelAnalysis n :: HieAST a
n@Node{ [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren } = do
  Maybe ()
analysed <-
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
      ( forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
          [
          --   analyseStandaloneDeriving n
          -- ,
            forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseInstanceDeclaration HieAST a
n
          , forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseBinding HieAST a
n
          , forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseRewriteRule HieAST a
n
          , forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseClassDeclaration HieAST a
n
          , forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseDataDeclaration HieAST a
n
          , forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analysePatternSynonyms HieAST a
n
          ]
      )

  case Maybe ()
analysed of
    Maybe ()
Nothing ->
      -- We didn't find a top level declaration here, check all this nodes
      -- children.
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *) a. MonadState Analysis m => HieAST a -> m ()
topLevelAnalysis [HieAST a]
nodeChildren

    Just () ->
      -- Top level analysis succeeded, there's nothing more to do for this node.
      forall (m :: * -> *) a. Monad m => a -> m a
return ()


analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseBinding :: forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseBinding n :: HieAST a
n@Node{ RealSrcSpan
nodeSpan :: RealSrcSpan
nodeSpan :: forall a. HieAST a -> RealSrcSpan
nodeSpan, SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } = do
  let bindAnns :: Set (FilePath, FilePath)
bindAnns = forall a. Ord a => [a] -> Set a
Set.fromList [(FilePath
"FunBind", FilePath
"HsBindLR"), (FilePath
"PatBind", FilePath
"HsBindLR")]
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set (FilePath, FilePath)
bindAnns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Seq Declaration
findDeclarations HieAST a
n ) \Declaration
d -> do
    forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> RealSrcSpan -> m ()
define Declaration
d RealSrcSpan
nodeSpan

    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Set Declaration
uses HieAST a
n ) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> Declaration -> m ()
addDependency Declaration
d


analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseRewriteRule :: forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseRewriteRule n :: HieAST a
n@Node{ SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath
"HsRule", FilePath
"RuleDecl") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Set Declaration
uses HieAST a
n ) forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addImplicitRoot


analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseInstanceDeclaration :: forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseInstanceDeclaration n :: HieAST a
n@Node{ SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath
"ClsInstD", FilePath
"InstDecl") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addImplicitRoot ( forall a. HieAST a -> Set Declaration
uses HieAST a
n )


analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseClassDeclaration :: forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseClassDeclaration n :: HieAST a
n@Node{ SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath
"ClassDecl", FilePath
"TyClDecl") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers Set ContextInfo -> Bool
isClassDeclaration HieAST a
n ) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers ( forall a b. a -> b -> a
const Bool
True ) HieAST a
n ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> Declaration -> m ()
addDependency

  where

    isClassDeclaration :: Set ContextInfo -> Bool
isClassDeclaration =
      Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Set a -> Set a
Set.filter \case
        Decl DeclType
ClassDec Maybe RealSrcSpan
_ ->
          Bool
True

        ContextInfo
_ ->
          Bool
False


analyseDataDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseDataDeclaration :: forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseDataDeclaration n :: HieAST a
n@Node{ SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath
"DataDecl", FilePath
"TyClDecl") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
    ( forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ( forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just )
        ( forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers ( forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isDataDec ) HieAST a
n )
    )
    \Declaration
dataTypeName ->
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Seq (HieAST a)
constructors HieAST a
n ) \HieAST a
constructor ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just ) ( forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers ( forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isConDec ) HieAST a
constructor ) ) \Declaration
conDec -> do
          forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> Declaration -> m ()
addDependency Declaration
conDec Declaration
dataTypeName

          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Set Declaration
uses HieAST a
constructor ) ( forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> Declaration -> m ()
addDependency Declaration
conDec )

  where

    isDataDec :: ContextInfo -> Bool
isDataDec = \case
      Decl DeclType
DataDec Maybe RealSrcSpan
_ -> Bool
True
      ContextInfo
_              -> Bool
False

    isConDec :: ContextInfo -> Bool
isConDec = \case
      Decl DeclType
ConDec Maybe RealSrcSpan
_ -> Bool
True
      ContextInfo
_             -> Bool
False


constructors :: HieAST a -> Seq ( HieAST a )
constructors :: forall a. HieAST a -> Seq (HieAST a)
constructors n :: HieAST a
n@Node{ [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren, SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } =
  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( (FilePath
"ConDecl" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> FilePath
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeAnnotation -> FastString
nodeAnnotType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) (forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo) then
    forall (f :: * -> *) a. Applicative f => a -> f a
pure HieAST a
n

  else
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HieAST a -> Seq (HieAST a)
constructors [HieAST a]
nodeChildren

analysePatternSynonyms :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analysePatternSynonyms :: forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analysePatternSynonyms n :: HieAST a
n@Node{ SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo } = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath
"PatSynBind", FilePath
"HsBindLR") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations) forall a b. (a -> b) -> a -> b
$ forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Seq Declaration
findDeclarations HieAST a
n ) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall a. HieAST a -> Set Declaration
uses HieAST a
n ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadState Analysis m =>
Declaration -> Declaration -> m ()
addDependency

findDeclarations :: HieAST a -> Seq Declaration
findDeclarations :: forall a. HieAST a -> Seq Declaration
findDeclarations =
  forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers
    (   Bool -> Bool
not
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Set a -> Set a
Set.filter \case
          -- Things that count as declarations
          ValBind BindType
RegularBind Scope
ModuleScope Maybe RealSrcSpan
_ -> Bool
True
          PatternBind Scope
ModuleScope Scope
_ Maybe RealSrcSpan
_       -> Bool
True
          Decl DeclType
_ Maybe RealSrcSpan
_                          -> Bool
True
          ContextInfo
TyDecl                            -> Bool
True
          ClassTyDecl{}                     -> Bool
True

          -- Anything else is not a declaration
          ContextInfo
_ -> Bool
False
    )


findIdentifiers
  :: ( Set ContextInfo -> Bool )
  -> HieAST a
  -> Seq Declaration
findIdentifiers :: forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers Set ContextInfo -> Bool
f Node{ SourcedNodeInfo a
sourcedNodeInfo :: SourcedNodeInfo a
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo, [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren } =
     forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
       ( \case
           ( Left ModuleName
_, IdentifierDetails a
_ ) ->
             forall a. Monoid a => a
mempty

           ( Right Name
name, IdentifierDetails{ Set ContextInfo
identInfo :: Set ContextInfo
identInfo :: forall a. IdentifierDetails a -> Set ContextInfo
identInfo } ) ->
             if Set ContextInfo -> Bool
f Set ContextInfo
identInfo then
               forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Name -> Maybe Declaration
nameToDeclaration Name
name )

             else
               forall a. Monoid a => a
mempty
           )
       (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers) (forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo a
sourcedNodeInfo))
  forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers Set ContextInfo -> Bool
f ) [HieAST a]
nodeChildren


uses :: HieAST a -> Set Declaration
uses :: forall a. HieAST a -> Set Declaration
uses =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. a -> Set a
Set.singleton
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers \Set ContextInfo
identInfo -> ContextInfo
Use forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ContextInfo
identInfo


nameToDeclaration :: Name -> Maybe Declaration
nameToDeclaration :: Name -> Maybe Declaration
nameToDeclaration Name
name = do
  Module
m <- Name -> Maybe Module
nameModule_maybe Name
name
  return Declaration { declModule :: Module
declModule = Module
m, declOccName :: OccName
declOccName = Name -> OccName
nameOccName Name
name }


unNodeAnnotation :: NodeAnnotation -> (String, String)
unNodeAnnotation :: NodeAnnotation -> (FilePath, FilePath)
unNodeAnnotation (NodeAnnotation FastString
x FastString
y) = (FastString -> FilePath
unpackFS FastString
x, FastString -> FilePath
unpackFS FastString
y)