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

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 )

-- bytestring
import Data.ByteString ( ByteString )

-- 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 Avail ( AvailInfo( Avail, AvailTC ) )
import FieldLabel ( FieldLbl( FieldLabel, flSelector ) )
import HieTypes
  ( BindType( RegularBind )
  , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl )
  , DeclType( DataDec, ClassDec, ConDec )
  , HieAST( Node, nodeInfo, nodeChildren, nodeSpan )
  , HieASTs( HieASTs )
  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file, hie_hs_src )
  , IdentifierDetails( IdentifierDetails, identInfo )
  , NodeInfo( NodeInfo, nodeIdentifiers, nodeAnnotations )
  , Scope( ModuleScope )
  )
import Module ( Module, moduleStableString )
import Name ( Name, nameModule_maybe, nameOccName )
import OccName
  ( OccName
  , isDataOcc
  , isDataSymOcc
  , isTcOcc
  , isTvOcc
  , isVarOcc
  , occNameString
  )
import 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
(Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool) -> Eq Declaration
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
Eq Declaration
-> (Declaration -> Declaration -> Ordering)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Declaration)
-> (Declaration -> Declaration -> Declaration)
-> Ord 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
$cp1Ord :: Eq Declaration
Ord )


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


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

    in
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"$" [ String
namespace, Module -> String
moduleStableString Module
declModule, String
"$", OccName -> String
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 String
modulePaths :: Map Module FilePath
      -- ^ A map from modules to the file path to the .hs file defining them.
    , Analysis -> Map Module ByteString
moduleSource :: Map Module ByteString
    }
  deriving
    ( (forall x. Analysis -> Rep Analysis x)
-> (forall x. Rep Analysis x -> Analysis) -> Generic Analysis
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 String
-> Map Module ByteString
-> Analysis
Analysis Graph Declaration
forall a. Graph a
empty Map Declaration (Set RealSrcSpan)
forall a. Monoid a => a
mempty Set Declaration
forall a. Monoid a => a
mempty Map Module (Set Declaration)
forall a. Monoid a => a
mempty Map Module String
forall a. Monoid a => a
mempty Map Module ByteString
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
(Root -> Root -> Bool) -> (Root -> Root -> Bool) -> Eq Root
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
Eq Root
-> (Root -> Root -> Ordering)
-> (Root -> Root -> Bool)
-> (Root -> Root -> Bool)
-> (Root -> Root -> Bool)
-> (Root -> Root -> Bool)
-> (Root -> Root -> Root)
-> (Root -> Root -> Root)
-> Ord 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
$cp1Ord :: Eq Root
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 =
  [Declaration] -> Set Declaration
forall a. Ord a => [a] -> Set a
Set.fromList ( [ToVertex (Graph Declaration)]
-> Graph Declaration -> [ToVertex (Graph Declaration)]
forall t.
(ToGraph t, Ord (ToVertex t)) =>
[ToVertex t] -> t -> [ToVertex t]
dfs ( (Root -> [Declaration]) -> Set Root -> [Declaration]
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 -> (Set Declaration -> [Declaration])
-> Maybe (Set Declaration) -> [Declaration]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Set Declaration -> [Declaration]
forall a. Set a -> [a]
Set.toList ( Module -> Map Module (Set Declaration) -> Maybe (Set Declaration)
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 } =
  [Declaration] -> Set Declaration
forall a. Ord a => [a] -> Set a
Set.fromList ( Graph Declaration -> [Declaration]
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 :: HieFile -> m ()
analyseHieFile HieFile{ hie_asts :: HieFile -> HieASTs Int
hie_asts = HieASTs Map FastString (HieAST Int)
hieASTs, [AvailInfo]
hie_exports :: [AvailInfo]
hie_exports :: HieFile -> [AvailInfo]
hie_exports, Module
hie_module :: Module
hie_module :: HieFile -> Module
hie_module, String
hie_hs_file :: String
hie_hs_file :: HieFile -> String
hie_hs_file, ByteString
hie_hs_src :: ByteString
hie_hs_src :: HieFile -> ByteString
hie_hs_src } = do
  #modulePaths %= Map.insert hie_module hie_hs_file
  #moduleSource %= Map.insert hie_module hie_hs_src

  for_ hieASTs \ast -> do
    addAllDeclarations ast
    topLevelAnalysis ast

  for_ hie_exports ( analyseExport hie_module )


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

  AvailTC Name
name [Name]
pieces [FieldLabel]
fields -> do
    Maybe Declaration -> (Declaration -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( Name -> Maybe Declaration
nameToDeclaration Name
name ) Declaration -> m ()
forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport
    [Name] -> (Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Name]
pieces ( (Declaration -> m ()) -> Maybe Declaration -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Declaration -> m ()
forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport (Maybe Declaration -> m ())
-> (Name -> Maybe Declaration) -> Name -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Declaration
nameToDeclaration )
    [FieldLabel] -> (FieldLabel -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FieldLabel]
fields \FieldLabel{ Name
flSelector :: Name
flSelector :: forall a. FieldLbl a -> a
flSelector } -> Maybe Declaration -> (Declaration -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( Name -> Maybe Declaration
nameToDeclaration Name
flSelector ) Declaration -> m ()
forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addExport

  where

    addExport :: MonadState Analysis m => Declaration -> m ()
    addExport :: Declaration -> m ()
addExport Declaration
d = IsLabel
  "exports"
  (ASetter
     Analysis
     Analysis
     (Map Module (Set Declaration))
     (Map Module (Set Declaration)))
ASetter
  Analysis
  Analysis
  (Map Module (Set Declaration))
  (Map Module (Set Declaration))
#exports ASetter
  Analysis
  Analysis
  (Map Module (Set Declaration))
  (Map Module (Set Declaration))
-> (Map Module (Set Declaration) -> Map Module (Set Declaration))
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Set Declaration -> Set Declaration -> Set Declaration)
-> Module
-> Set Declaration
-> Map Module (Set Declaration)
-> Map Module (Set Declaration)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set Declaration -> Set Declaration -> Set Declaration
forall a. Semigroup a => a -> a -> a
(<>) Module
m ( Declaration -> Set Declaration
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 :: Declaration -> Declaration -> m ()
addDependency Declaration
x Declaration
y =
  #dependencyGraph %= overlay ( edge x y )


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


define :: MonadState Analysis m => Declaration -> RealSrcSpan -> m ()
define :: Declaration -> RealSrcSpan -> m ()
define Declaration
decl RealSrcSpan
span =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
span RealSrcLoc -> RealSrcLoc -> Bool
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 :: 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 :: HieAST a -> m ()
addAllDeclarations n :: HieAST a
n@Node{ [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren } = do
  Seq Declaration -> (Declaration -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers ( Bool -> Set ContextInfo -> Bool
forall a b. a -> b -> a
const Bool
True ) HieAST a
n ) Declaration -> m ()
forall (m :: * -> *). MonadState Analysis m => Declaration -> m ()
addDeclaration

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


topLevelAnalysis :: MonadState Analysis m => HieAST a -> m ()
topLevelAnalysis :: 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 <-
    MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
      ( [MaybeT m ()] -> MaybeT m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
          [
          --   analyseStandaloneDeriving n
          -- ,
            HieAST a -> MaybeT m ()
forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseInstanceDeclaration HieAST a
n
          , HieAST a -> MaybeT m ()
forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseBinding HieAST a
n
          , HieAST a -> MaybeT m ()
forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseRewriteRule HieAST a
n
          , HieAST a -> MaybeT m ()
forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseClassDeclaration HieAST a
n
          , HieAST a -> MaybeT m ()
forall (m :: * -> *) a.
(Alternative m, MonadState Analysis m) =>
HieAST a -> m ()
analyseDataDeclaration HieAST a
n
          ]
      )

  case Maybe ()
analysed of
    Maybe ()
Nothing ->
      -- We didn't find a top level declaration here, check all this nodes
      -- children.
      (HieAST a -> m ()) -> [HieAST a] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ HieAST a -> m ()
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.
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseBinding :: HieAST a -> m ()
analyseBinding n :: HieAST a
n@Node{ RealSrcSpan
nodeSpan :: RealSrcSpan
nodeSpan :: forall a. HieAST a -> RealSrcSpan
nodeSpan, nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ Set (FastString, FastString)
nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations } } = do
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ ( FastString
"FunBind", FastString
"HsBindLR" ) (FastString, FastString) -> Set (FastString, FastString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (FastString, FastString)
nodeAnnotations

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

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


analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseRewriteRule :: HieAST a -> m ()
analyseRewriteRule n :: HieAST a
n@Node{ nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ Set (FastString, FastString)
nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations } } = do
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ( ( FastString
"HsRule", FastString
"RuleDecl" ) (FastString, FastString) -> Set (FastString, FastString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (FastString, FastString)
nodeAnnotations )

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


analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseInstanceDeclaration :: HieAST a -> m ()
analyseInstanceDeclaration n :: HieAST a
n@Node{ nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ Set (FastString, FastString)
nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations } } = do
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ( ( FastString
"ClsInstD", FastString
"InstDecl" ) (FastString, FastString) -> Set (FastString, FastString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (FastString, FastString)
nodeAnnotations )

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


analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseClassDeclaration :: HieAST a -> m ()
analyseClassDeclaration n :: HieAST a
n@Node{ nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ Set (FastString, FastString)
nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations } } = do
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ( ( FastString
"ClassDecl", FastString
"TyClDecl" ) (FastString, FastString) -> Set (FastString, FastString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (FastString, FastString)
nodeAnnotations )

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

  where

    isClassDeclaration :: Set ContextInfo -> Bool
isClassDeclaration =
      Bool -> Bool
not (Bool -> Bool)
-> (Set ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ContextInfo -> Bool
forall a. Set a -> Bool
Set.null (Set ContextInfo -> Bool)
-> (Set ContextInfo -> Set ContextInfo) -> Set ContextInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContextInfo -> Bool) -> Set ContextInfo -> Set ContextInfo
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 :: HieAST a -> m ()
analyseDataDeclaration n :: HieAST a
n@Node { nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ Set (FastString, FastString)
nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations } } = do
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ( ( FastString
"DataDecl", FastString
"TyClDecl" ) (FastString, FastString) -> Set (FastString, FastString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (FastString, FastString)
nodeAnnotations )

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

          Set Declaration -> (Declaration -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( HieAST a -> Set Declaration
forall a. HieAST a -> Set Declaration
uses HieAST a
constructor ) ( Declaration -> Declaration -> m ()
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 :: HieAST a -> Seq (HieAST a)
constructors n :: HieAST a
n@Node { [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren, nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ Set (FastString, FastString)
nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations } } =
  if ((FastString, FastString) -> Bool)
-> Set (FastString, FastString) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( \( FastString
_, FastString
t ) -> FastString
t FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"ConDecl" ) Set (FastString, FastString)
nodeAnnotations then
    HieAST a -> Seq (HieAST a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HieAST a
n

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


findDeclarations :: HieAST a -> Seq Declaration
findDeclarations :: HieAST a -> Seq Declaration
findDeclarations =
  (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers
    (   Bool -> Bool
not
      (Bool -> Bool)
-> (Set ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ContextInfo -> Bool
forall a. Set a -> Bool
Set.null
      (Set ContextInfo -> Bool)
-> (Set ContextInfo -> Set ContextInfo) -> Set ContextInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContextInfo -> Bool) -> Set ContextInfo -> Set ContextInfo
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 :: (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers Set ContextInfo -> Bool
f Node{ nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo = NodeInfo{ NodeIdentifiers a
nodeIdentifiers :: NodeIdentifiers a
nodeIdentifiers :: forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers }, [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren } =
     ((Either ModuleName Name, IdentifierDetails a) -> Seq Declaration)
-> [(Either ModuleName Name, IdentifierDetails a)]
-> Seq Declaration
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
       ( \case
           ( Left ModuleName
_, IdentifierDetails a
_ ) ->
             Seq Declaration
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
               (Declaration -> Seq Declaration)
-> Maybe Declaration -> Seq Declaration
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Declaration -> Seq Declaration
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Name -> Maybe Declaration
nameToDeclaration Name
name )

             else
               Seq Declaration
forall a. Monoid a => a
mempty
           )

       ( NodeIdentifiers a
-> [(Either ModuleName Name, IdentifierDetails a)]
forall k a. Map k a -> [(k, a)]
Map.toList NodeIdentifiers a
nodeIdentifiers )
  Seq Declaration -> Seq Declaration -> Seq Declaration
forall a. Semigroup a => a -> a -> a
<> (HieAST a -> Seq Declaration) -> [HieAST a] -> Seq Declaration
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers Set ContextInfo -> Bool
f ) [HieAST a]
nodeChildren


uses :: HieAST a -> Set Declaration
uses :: HieAST a -> Set Declaration
uses =
    (Declaration -> Set Declaration)
-> Seq Declaration -> Set Declaration
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Declaration -> Set Declaration
forall a. a -> Set a
Set.singleton
  (Seq Declaration -> Set Declaration)
-> (HieAST a -> Seq Declaration) -> HieAST a -> Set Declaration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
forall a. (Set ContextInfo -> Bool) -> HieAST a -> Seq Declaration
findIdentifiers \Set ContextInfo
identInfo -> ContextInfo
Use ContextInfo -> Set ContextInfo -> Bool
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 :: Module -> OccName -> Declaration
Declaration { declModule :: Module
declModule = Module
m, declOccName :: OccName
declOccName = Name -> OccName
nameOccName Name
name }