{-# LANGUAGE BangPatterns #-}

{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Analysing functions by 'InspectionAnalysis' for the corresponding
'Inspection'.
-}

module Stan.Analysis.Analyser
    ( analysisByInspection
    ) where

import Extensions (ExtensionsResult)
import GHC.LanguageExtensions.Type (Extension (Strict, StrictData))
import Slist (Slist, slist)

import Stan.Core.Id (Id)
import Stan.Core.List (nonRepeatingPairs)
import Stan.FileInfo (isExtensionDisabled)
import Stan.Ghc.Compat (RealSrcSpan, isSymOcc, nameOccName, occNameString)
import Stan.Hie (eqAst)
import Stan.Hie.Compat (HieAST (..), HieASTs (..), HieFile (..), Identifier, NodeInfo (..),
                        TypeIndex)
import Stan.Hie.MatchAst (hieMatchPatternAst)
import Stan.Inspection (Inspection (..), InspectionAnalysis (..))
import Stan.NameMeta (NameMeta, ghcPrimNameFrom)
import Stan.Observation (Observations, mkObservation)
import Stan.Pattern.Ast (Literal (..), PatternAst (..), anyNamesToPatternAst, case', constructor,
                         constructorNameIdentifier, dataDecl, fixity, fun, guardBranch, lambdaCase,
                         lazyField, literalPat, opApp, patternMatchArrow, patternMatchBranch,
                         patternMatch_, rhs, tuple, typeSig)
import Stan.Pattern.Edsl (PatternBool (..))

import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Slist as S


{- | Create analysing function for 'Inspection' by pattern-matching
over 'InspectionAnalysis'.
-}
analysisByInspection
    :: ExtensionsResult
    -> Inspection
    -> HieFile
    -> Observations
analysisByInspection :: ExtensionsResult -> Inspection -> HieFile -> Observations
analysisByInspection exts :: ExtensionsResult
exts Inspection{..} = case InspectionAnalysis
inspectionAnalysis of
    FindAst patAst :: PatternAst
patAst -> Id Inspection -> PatternAst -> HieFile -> Observations
analyseAst Id Inspection
inspectionId PatternAst
patAst
    Infix -> Id Inspection -> HieFile -> Observations
analyseInfix Id Inspection
inspectionId
    LazyField -> Bool -> (HieFile -> Observations) -> HieFile -> Observations
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
        (Extension -> ExtensionsResult -> Bool
isExtensionDisabled Extension
StrictData ExtensionsResult
exts Bool -> Bool -> Bool
&& Extension -> ExtensionsResult -> Bool
isExtensionDisabled Extension
Strict ExtensionsResult
exts)
        (Id Inspection -> HieFile -> Observations
analyseLazyFields Id Inspection
inspectionId)
    BigTuples -> Id Inspection -> HieFile -> Observations
analyseBigTuples Id Inspection
inspectionId
    PatternMatchOn_ -> Id Inspection -> HieFile -> Observations
analysePatternMatch_ Id Inspection
inspectionId
    UseCompare -> Id Inspection -> HieFile -> Observations
analyseCompare Id Inspection
inspectionId

{- | Check for occurrences of the specified function given via 'NameMeta'.
-}
analyseAst
    :: Id Inspection
    -> PatternAst
    -> HieFile
    -> Observations
analyseAst :: Id Inspection -> PatternAst -> HieFile -> Observations
analyseAst insId :: Id Inspection
insId patAst :: PatternAst
patAst hie :: HieFile
hie =
    Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation Id Inspection
insId HieFile
hie (RealSrcSpan -> Observation) -> Slist RealSrcSpan -> Observations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HieAST TypeIndex -> Slist RealSrcSpan)
-> HieFile -> Slist RealSrcSpan
forall a. (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith (PatternAst -> HieFile -> HieAST TypeIndex -> Slist RealSrcSpan
createMatch PatternAst
patAst HieFile
hie) HieFile
hie

{- | Check for big tuples (size >= 4) in the following places:

* Type signatures: foo :: (Int, Int, Int, Int)
* Literals: (True, 0, [], Nothing)
-}
analyseBigTuples
    :: Id Inspection
    -> HieFile
    -> Observations
analyseBigTuples :: Id Inspection -> HieFile -> Observations
analyseBigTuples insId :: Id Inspection
insId hie :: HieFile
hie =
    (HieAST TypeIndex -> Observation)
-> Slist (HieAST TypeIndex) -> Observations
forall a b. (a -> b) -> Slist a -> Slist b
S.map (Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation Id Inspection
insId HieFile
hie (RealSrcSpan -> Observation)
-> (HieAST TypeIndex -> RealSrcSpan)
-> HieAST TypeIndex
-> Observation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan)
    (Slist (HieAST TypeIndex) -> Observations)
-> Slist (HieAST TypeIndex) -> Observations
forall a b. (a -> b) -> a -> b
$ (HieAST TypeIndex -> Bool)
-> Slist (HieAST TypeIndex) -> Slist (HieAST TypeIndex)
forall a. (a -> Bool) -> Slist a -> Slist a
S.filter HieAST TypeIndex -> Bool
isBigTuple
    (Slist (HieAST TypeIndex) -> Slist (HieAST TypeIndex))
-> Slist (HieAST TypeIndex) -> Slist (HieAST TypeIndex)
forall a b. (a -> b) -> a -> b
$ (HieAST TypeIndex -> Slist (HieAST TypeIndex))
-> HieFile -> Slist (HieAST TypeIndex)
forall a. (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith (PatternAst
-> HieFile -> HieAST TypeIndex -> Slist (HieAST TypeIndex)
createMatchAst PatternAst
tuple HieFile
hie) HieFile
hie
  where
    isBigTuple :: HieAST TypeIndex -> Bool
    isBigTuple :: HieAST TypeIndex -> Bool
isBigTuple Node{..} = case [HieAST TypeIndex]
nodeChildren of
        _:_:_:_:_  -> Bool
True
        _lessThan4 :: [HieAST TypeIndex]
_lessThan4 -> Bool
False

{- | Find usages of multiple comparison operators and suggest using
'compare'. Currently, handles the following cases:

* Guards

The algorithm is to find all guards, filter them by usage of
comparison operators and find matches.
-}
analyseCompare
    :: Id Inspection
    -> HieFile
    -> Observations
analyseCompare :: Id Inspection -> HieFile -> Observations
analyseCompare insId :: Id Inspection
insId hie :: HieFile
hie =
    Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation Id Inspection
insId HieFile
hie (RealSrcSpan -> Observation) -> Slist RealSrcSpan -> Observations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HieAST TypeIndex -> Slist RealSrcSpan)
-> HieFile -> Slist RealSrcSpan
forall a. (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith HieAST TypeIndex -> Slist RealSrcSpan
matchComparisonGuards HieFile
hie
  where
    matchComparisonGuards :: HieAST TypeIndex -> Slist RealSrcSpan
    matchComparisonGuards :: HieAST TypeIndex -> Slist RealSrcSpan
matchComparisonGuards node :: HieAST TypeIndex
node = Bool -> Slist RealSrcSpan -> Slist RealSrcSpan
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
        (HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
fun)
        (Slist RealSrcSpan -> Slist RealSrcSpan)
-> Slist RealSrcSpan -> Slist RealSrcSpan
forall a b. (a -> b) -> a -> b
$ let guards :: [(HieAST TypeIndex, HieAST TypeIndex)]
guards = (HieAST TypeIndex -> Maybe (HieAST TypeIndex, HieAST TypeIndex))
-> [HieAST TypeIndex] -> [(HieAST TypeIndex, HieAST TypeIndex)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HieAST TypeIndex -> Maybe (HieAST TypeIndex, HieAST TypeIndex)
extractComparisonGuard (HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
node)
          in Bool -> Slist RealSrcSpan -> Slist RealSrcSpan
forall m. Monoid m => Bool -> m -> m
memptyIfFalse ([(HieAST TypeIndex, HieAST TypeIndex)] -> Bool
hasManyCompares [(HieAST TypeIndex, HieAST TypeIndex)]
guards) (RealSrcSpan -> Slist RealSrcSpan
forall a. a -> Slist a
S.one (RealSrcSpan -> Slist RealSrcSpan)
-> RealSrcSpan -> Slist RealSrcSpan
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST TypeIndex
node)

    {- Extract left argument, name of a comparison operator and right
    argument from a guard.
    -}
    extractComparisonGuard
        :: HieAST TypeIndex
        -> Maybe (HieAST TypeIndex, HieAST TypeIndex)
    extractComparisonGuard :: HieAST TypeIndex -> Maybe (HieAST TypeIndex, HieAST TypeIndex)
extractComparisonGuard node :: HieAST TypeIndex
node = do
        -- guard starts with GRHS annotation
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
rhs
        -- guard predicate is a first son
        stmt :: HieAST TypeIndex
stmt:_ <- [HieAST TypeIndex] -> Maybe [HieAST TypeIndex]
forall a. a -> Maybe a
Just ([HieAST TypeIndex] -> Maybe [HieAST TypeIndex])
-> [HieAST TypeIndex] -> Maybe [HieAST TypeIndex]
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
node
        -- check if it's a guard
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
stmt PatternAst
guardBranch
        -- check if it's an operator
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
stmt (PatternAst -> Bool) -> PatternAst -> Bool
forall a b. (a -> b) -> a -> b
$ PatternAst -> PatternAst -> PatternAst -> PatternAst
opApp PatternAst
forall a. PatternBool a => a
(?) PatternAst
opsPat PatternAst
forall a. PatternBool a => a
(?)
        -- extract comparison
        x :: HieAST TypeIndex
x:_opAst :: HieAST TypeIndex
_opAst:y :: HieAST TypeIndex
y:_ <- [HieAST TypeIndex] -> Maybe [HieAST TypeIndex]
forall a. a -> Maybe a
Just ([HieAST TypeIndex] -> Maybe [HieAST TypeIndex])
-> [HieAST TypeIndex] -> Maybe [HieAST TypeIndex]
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
stmt
        (HieAST TypeIndex, HieAST TypeIndex)
-> Maybe (HieAST TypeIndex, HieAST TypeIndex)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HieAST TypeIndex
x, HieAST TypeIndex
y)

    -- pattern for any comparison operator
    opsPat :: PatternAst
    opsPat :: PatternAst
opsPat = NonEmpty NameMeta -> PatternAst
anyNamesToPatternAst (NonEmpty NameMeta -> PatternAst)
-> NonEmpty NameMeta -> PatternAst
forall a b. (a -> b) -> a -> b
$ NameMeta
le NameMeta -> [NameMeta] -> NonEmpty NameMeta
forall a. a -> [a] -> NonEmpty a
:| [NameMeta
leq, NameMeta
eq, NameMeta
ge, NameMeta
geq]

    le, leq, eq, ge, geq :: NameMeta
    le :: NameMeta
le  = Text -> NameMeta
opName "<"
    leq :: NameMeta
leq = Text -> NameMeta
opName "<="
    eq :: NameMeta
eq  = Text -> NameMeta
opName "=="
    ge :: NameMeta
ge  = Text -> NameMeta
opName ">"
    geq :: NameMeta
geq = Text -> NameMeta
opName ">="

    opName :: Text -> NameMeta
    opName :: Text -> NameMeta
opName = (Text -> ModuleName -> NameMeta
`ghcPrimNameFrom` "GHC.Classes")

    -- return True if any two pairs perform comparison of similar things
    hasManyCompares :: [(HieAST TypeIndex, HieAST TypeIndex)] -> Bool
    hasManyCompares :: [(HieAST TypeIndex, HieAST TypeIndex)] -> Bool
hasManyCompares = (((HieAST TypeIndex, HieAST TypeIndex),
  (HieAST TypeIndex, HieAST TypeIndex))
 -> Bool)
-> [((HieAST TypeIndex, HieAST TypeIndex),
     (HieAST TypeIndex, HieAST TypeIndex))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (((HieAST TypeIndex, HieAST TypeIndex)
 -> (HieAST TypeIndex, HieAST TypeIndex) -> Bool)
-> ((HieAST TypeIndex, HieAST TypeIndex),
    (HieAST TypeIndex, HieAST TypeIndex))
-> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HieAST TypeIndex, HieAST TypeIndex)
-> (HieAST TypeIndex, HieAST TypeIndex) -> Bool
matchingComparions) ([((HieAST TypeIndex, HieAST TypeIndex),
   (HieAST TypeIndex, HieAST TypeIndex))]
 -> Bool)
-> ([(HieAST TypeIndex, HieAST TypeIndex)]
    -> [((HieAST TypeIndex, HieAST TypeIndex),
         (HieAST TypeIndex, HieAST TypeIndex))])
-> [(HieAST TypeIndex, HieAST TypeIndex)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(HieAST TypeIndex, HieAST TypeIndex)]
-> [((HieAST TypeIndex, HieAST TypeIndex),
     (HieAST TypeIndex, HieAST TypeIndex))]
forall a. [a] -> [(a, a)]
nonRepeatingPairs

    matchingComparions
        :: (HieAST TypeIndex, HieAST TypeIndex)
        -> (HieAST TypeIndex, HieAST TypeIndex)
        -> Bool
    matchingComparions :: (HieAST TypeIndex, HieAST TypeIndex)
-> (HieAST TypeIndex, HieAST TypeIndex) -> Bool
matchingComparions (a :: HieAST TypeIndex
a, b :: HieAST TypeIndex
b) (x :: HieAST TypeIndex
x, y :: HieAST TypeIndex
y) =
        (HieFile -> HieAST TypeIndex -> HieAST TypeIndex -> Bool
forall a. Eq a => HieFile -> HieAST a -> HieAST a -> Bool
eqAst HieFile
hie HieAST TypeIndex
a HieAST TypeIndex
x Bool -> Bool -> Bool
&& HieFile -> HieAST TypeIndex -> HieAST TypeIndex -> Bool
forall a. Eq a => HieFile -> HieAST a -> HieAST a -> Bool
eqAst HieFile
hie HieAST TypeIndex
b HieAST TypeIndex
y) Bool -> Bool -> Bool
|| (HieFile -> HieAST TypeIndex -> HieAST TypeIndex -> Bool
forall a. Eq a => HieFile -> HieAST a -> HieAST a -> Bool
eqAst HieFile
hie HieAST TypeIndex
a HieAST TypeIndex
y Bool -> Bool -> Bool
&& HieFile -> HieAST TypeIndex -> HieAST TypeIndex -> Bool
forall a. Eq a => HieFile -> HieAST a -> HieAST a -> Bool
eqAst HieFile
hie HieAST TypeIndex
b HieAST TypeIndex
x)


{- | Check for occurrences lazy fields in all constructors. Ignores
@newtype@s. Currently HIE Ast doesn't have information whether the
data type is @newtype@ or not. So the algorithm ignores all data types
with a single constructor and single field inside that constructor.
-}
analyseLazyFields
    :: Id Inspection
    -> HieFile
    -> Observations
analyseLazyFields :: Id Inspection -> HieFile -> Observations
analyseLazyFields insId :: Id Inspection
insId hie :: HieFile
hie =
    Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation Id Inspection
insId HieFile
hie (RealSrcSpan -> Observation) -> Slist RealSrcSpan -> Observations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HieAST TypeIndex -> Slist RealSrcSpan)
-> HieFile -> Slist RealSrcSpan
forall a. (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith HieAST TypeIndex -> Slist RealSrcSpan
matchLazyField HieFile
hie
  where
    matchLazyField :: HieAST TypeIndex -> Slist RealSrcSpan
    matchLazyField :: HieAST TypeIndex -> Slist RealSrcSpan
matchLazyField node :: HieAST TypeIndex
node = Bool -> Slist RealSrcSpan -> Slist RealSrcSpan
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
        -- return empty list if it's not a data type
        (HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
dataDecl)
        -- get list of all constructors
        (Slist RealSrcSpan -> Slist RealSrcSpan)
-> Slist RealSrcSpan -> Slist RealSrcSpan
forall a b. (a -> b) -> a -> b
$ let constructors :: [HieAST TypeIndex]
constructors = (HieAST TypeIndex -> Bool)
-> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a. (a -> Bool) -> [a] -> [a]
filter
                (\n :: HieAST TypeIndex
n -> HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
n PatternAst
constructor)
                (HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
node)
          in case [HieAST TypeIndex]
constructors of
              -- no constructors = not observations
              []  -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
              -- single constructor
              [c :: HieAST TypeIndex
c] -> (HieAST TypeIndex -> Slist RealSrcSpan)
-> [HieAST TypeIndex] -> Slist RealSrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap HieAST TypeIndex -> Slist RealSrcSpan
matchField ([HieAST TypeIndex] -> Slist RealSrcSpan)
-> [HieAST TypeIndex] -> Slist RealSrcSpan
forall a b. (a -> b) -> a -> b
$ Bool -> HieAST TypeIndex -> [HieAST TypeIndex]
extractFields Bool
False HieAST TypeIndex
c
              -- multiple constructors = analyse everything
              cs :: [HieAST TypeIndex]
cs  -> (HieAST TypeIndex -> Slist RealSrcSpan)
-> [HieAST TypeIndex] -> Slist RealSrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap ((HieAST TypeIndex -> Slist RealSrcSpan)
-> [HieAST TypeIndex] -> Slist RealSrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap HieAST TypeIndex -> Slist RealSrcSpan
matchField ([HieAST TypeIndex] -> Slist RealSrcSpan)
-> (HieAST TypeIndex -> [HieAST TypeIndex])
-> HieAST TypeIndex
-> Slist RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> HieAST TypeIndex -> [HieAST TypeIndex]
extractFields Bool
True) [HieAST TypeIndex]
cs

    -- Extract fields as AST nodes. Return empty list if only one field
    -- (as a workaround for the @newtype@ problem)
    --
    -- record constructors have the following children:
    --   1. One or many constraints (e.g. forall a . Num a =>)
    --   2. Constructor name.
    --   3. Dummy child with all fields as childrens
    -- plain constructors have constructor name and children in the same list
    extractFields :: Bool -> HieAST TypeIndex -> [HieAST TypeIndex]
    extractFields :: Bool -> HieAST TypeIndex -> [HieAST TypeIndex]
extractFields hasManyCtors :: Bool
hasManyCtors ctor :: HieAST TypeIndex
ctor = case TypeIndex -> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a. TypeIndex -> [a] -> [a]
drop 1 ([HieAST TypeIndex] -> [HieAST TypeIndex])
-> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a b. (a -> b) -> a -> b
$ (HieAST TypeIndex -> Bool)
-> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile HieAST TypeIndex -> Bool
isConstraint ([HieAST TypeIndex] -> [HieAST TypeIndex])
-> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
ctor of
        [] -> []  -- no fields
        [n :: HieAST TypeIndex
n] ->  -- single field, maybe dummy record node
            if HieAST TypeIndex -> Bool
isDummyRecordNode HieAST TypeIndex
n
            then case HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
n of
                []      -> []
                [field :: HieAST TypeIndex
field] -> [HieAST TypeIndex
field | Bool
hasManyCtors]
                fields :: [HieAST TypeIndex]
fields  -> [HieAST TypeIndex]
fields
            else [HieAST TypeIndex
n | Bool
hasManyCtors]
        fields :: [HieAST TypeIndex]
fields -> [HieAST TypeIndex]
fields  -- plain constructor
      where
        -- simple check for the dummy AST node
        isDummyRecordNode :: HieAST TypeIndex -> Bool
        isDummyRecordNode :: HieAST TypeIndex -> Bool
isDummyRecordNode = Set (FastString, FastString) -> Bool
forall a. Set a -> Bool
Set.null (Set (FastString, FastString) -> Bool)
-> (HieAST TypeIndex -> Set (FastString, FastString))
-> HieAST TypeIndex
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo TypeIndex -> Set (FastString, FastString)
forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations (NodeInfo TypeIndex -> Set (FastString, FastString))
-> (HieAST TypeIndex -> NodeInfo TypeIndex)
-> HieAST TypeIndex
-> Set (FastString, FastString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST TypeIndex -> NodeInfo TypeIndex
forall a. HieAST a -> NodeInfo a
nodeInfo

        -- Not the constructor identifier
        isConstraint :: HieAST TypeIndex -> Bool
        isConstraint :: HieAST TypeIndex -> Bool
isConstraint n :: HieAST TypeIndex
n = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
n PatternAst
constructorNameIdentifier

    -- matches record fields non-recursively
    matchField :: HieAST TypeIndex -> Slist RealSrcSpan
    matchField :: HieAST TypeIndex -> Slist RealSrcSpan
matchField = PatternAst -> HieFile -> HieAST TypeIndex -> Slist RealSrcSpan
createMatch PatternAst
lazyField HieFile
hie

{- | Check for occurrences of pattern matching on @_@ for sum types (except
literals).
-}
analysePatternMatch_ :: Id Inspection -> HieFile -> Observations
analysePatternMatch_ :: Id Inspection -> HieFile -> Observations
analysePatternMatch_ insId :: Id Inspection
insId hie :: HieFile
hie =
    Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation Id Inspection
insId HieFile
hie (RealSrcSpan -> Observation) -> Slist RealSrcSpan -> Observations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HieAST TypeIndex -> Slist RealSrcSpan)
-> HieFile -> Slist RealSrcSpan
forall a. (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith HieAST TypeIndex -> Slist RealSrcSpan
matchPatternMatch HieFile
hie
  where
    matchPatternMatch :: HieAST TypeIndex -> Slist RealSrcSpan
    matchPatternMatch :: HieAST TypeIndex -> Slist RealSrcSpan
matchPatternMatch node :: HieAST TypeIndex
node = Bool -> Slist RealSrcSpan -> Slist RealSrcSpan
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
        -- return empty list if it's not a case or lambda case
        (HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node (PatternAst -> Bool) -> PatternAst -> Bool
forall a b. (a -> b) -> a -> b
$ PatternAst
lambdaCase PatternAst -> PatternAst -> PatternAst
forall a. PatternBool a => a -> a -> a
||| PatternAst
case')
        -- get list of all case branches
        (Slist RealSrcSpan -> Slist RealSrcSpan)
-> Slist RealSrcSpan -> Slist RealSrcSpan
forall a b. (a -> b) -> a -> b
$ case HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
node of
              -- no branches = not observations
              []     -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
              -- lambda case, first kid is pattern matching
              [pm :: HieAST TypeIndex
pm]   -> HieAST TypeIndex -> Slist RealSrcSpan
analyseBranches HieAST TypeIndex
pm
              -- case, first kid is @case exp of@, the second is pattern matching
              _:pm :: HieAST TypeIndex
pm:_ -> HieAST TypeIndex -> Slist RealSrcSpan
analyseBranches HieAST TypeIndex
pm

    {- Check the pattern matching child on some particular expressions.

    -}
    analyseBranches :: HieAST TypeIndex -> Slist RealSrcSpan
    analyseBranches :: HieAST TypeIndex -> Slist RealSrcSpan
analyseBranches pm :: HieAST TypeIndex
pm = case HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
pm of
        -- if there is no children = no observations
        [] -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
        -- we need to check first and all other children separately
        -- see 'isFirstPatternMatchBranchOk' comment to understand the first
        -- child's rules.
        c :: HieAST TypeIndex
c:cs :: [HieAST TypeIndex]
cs -> Bool -> Slist RealSrcSpan -> Slist RealSrcSpan
forall m. Monoid m => Bool -> m -> m
memptyIfFalse (HieAST TypeIndex -> Bool
isFirstPatternMatchBranchOk HieAST TypeIndex
c) (Slist RealSrcSpan -> Slist RealSrcSpan)
-> Slist RealSrcSpan -> Slist RealSrcSpan
forall a b. (a -> b) -> a -> b
$
            {- if the first child satisfies rules of the first pattern matching
            branch, then we need to find the child with pattern matching on @_@.
            If there is no such expression = all is good.
            -}
            case (HieAST TypeIndex -> Bool)
-> [HieAST TypeIndex] -> Maybe (HieAST TypeIndex)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\x :: HieAST TypeIndex
x -> HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
x (PatternAst -> PatternAst
patternMatch_ PatternAst
forall a. PatternBool a => a
(?))) [HieAST TypeIndex]
cs of
                Nothing -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
                Just e :: HieAST TypeIndex
e  -> RealSrcSpan -> Slist RealSrcSpan
forall a. a -> Slist a
S.one (HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST TypeIndex
e)

    {- The first pattern matching branch should not:
    1. Be empty (makes no sense)
    2. Be a literal pattern matching (e.g. on 'Int's or 'String's)
    In all other cases we can continue our matching checks with other children.
    -}
    isFirstPatternMatchBranchOk :: HieAST TypeIndex -> Bool
    isFirstPatternMatchBranchOk :: HieAST TypeIndex -> Bool
isFirstPatternMatchBranchOk c :: HieAST TypeIndex
c = HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
c PatternAst
patternMatchBranch Bool -> Bool -> Bool
&&
        case (HieAST TypeIndex -> Bool)
-> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile HieAST TypeIndex -> Bool
isNotMatchArrow ([HieAST TypeIndex] -> [HieAST TypeIndex])
-> [HieAST TypeIndex] -> [HieAST TypeIndex]
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
c of
            []  -> Bool
False
            [x :: HieAST TypeIndex
x] -> HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
x PatternAst
notLiteral
            _:_ -> Bool
True
      where
        isNotMatchArrow :: HieAST TypeIndex -> Bool
        isNotMatchArrow :: HieAST TypeIndex -> Bool
isNotMatchArrow n :: HieAST TypeIndex
n = HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
n (PatternAst -> Bool) -> PatternAst -> Bool
forall a b. (a -> b) -> a -> b
$ PatternAst -> PatternAst
forall a. PatternBool a => a -> a
neg (PatternAst -> PatternAst) -> PatternAst -> PatternAst
forall a b. (a -> b) -> a -> b
$ PatternAst -> PatternAst
patternMatchArrow PatternAst
forall a. PatternBool a => a
(?)

    notLiteral :: PatternAst
    notLiteral :: PatternAst
notLiteral = PatternAst -> PatternAst
forall a. PatternBool a => a -> a
neg
        -- general literal expression
        ( Literal -> PatternAst
PatternAstConstant Literal
AnyLiteral
        -- since GHC-8.10 expression for literal in pattern matching
        PatternAst -> PatternAst -> PatternAst
forall a. PatternBool a => a -> a -> a
||| PatternAst
literalPat
        )

{- | Analyse HIE AST to find all operators which lack explicit fixity
declaration.

The algorithm is the following:

1. Traverse AST and discover all top-level operators and @infix@
declarations in a single pass.
2. Compare two resulting sets to find out operators without @infix@
declaration.
-}
analyseInfix
    :: Id Inspection
    -> HieFile
    -> Observations
analyseInfix :: Id Inspection -> HieFile -> Observations
analyseInfix insId :: Id Inspection
insId hie :: HieFile
hie =
    let opDecls :: Slist OperatorDecl
opDecls = (HieAST TypeIndex -> Slist OperatorDecl)
-> HieFile -> Slist OperatorDecl
forall a. (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith (HieAST TypeIndex -> Slist OperatorDecl
matchInfix (HieAST TypeIndex -> Slist OperatorDecl)
-> (HieAST TypeIndex -> Slist OperatorDecl)
-> HieAST TypeIndex
-> Slist OperatorDecl
forall a. Semigroup a => a -> a -> a
<> HieAST TypeIndex -> Slist OperatorDecl
matchOperator) HieFile
hie
        (fixities :: HashMap Text ()
fixities, topOperators :: HashMap Text RealSrcSpan
topOperators) = Slist OperatorDecl -> (HashMap Text (), HashMap Text RealSrcSpan)
forall (f :: * -> *).
Foldable f =>
f OperatorDecl -> (HashMap Text (), HashMap Text RealSrcSpan)
partitionDecls Slist OperatorDecl
opDecls
        operatorsWithoutFixity :: HashMap Text RealSrcSpan
operatorsWithoutFixity = HashMap Text RealSrcSpan
-> HashMap Text () -> HashMap Text RealSrcSpan
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HM.difference HashMap Text RealSrcSpan
topOperators HashMap Text ()
fixities
    in Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation Id Inspection
insId HieFile
hie (RealSrcSpan -> Observation) -> Slist RealSrcSpan -> Observations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RealSrcSpan] -> Slist RealSrcSpan
forall a. [a] -> Slist a
slist (HashMap Text RealSrcSpan -> [RealSrcSpan]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashMap Text RealSrcSpan
operatorsWithoutFixity)
  where
    -- returns list of operator names defined in a single fixity declaration:
    -- infix 5 ***, +++, ???
    matchInfix :: HieAST TypeIndex -> Slist OperatorDecl
    matchInfix :: HieAST TypeIndex -> Slist OperatorDecl
matchInfix node :: HieAST TypeIndex
node@Node{..} = Bool -> Slist OperatorDecl -> Slist OperatorDecl
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
        (HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
fixity)
        ((HieAST TypeIndex -> Slist OperatorDecl)
-> [HieAST TypeIndex] -> Slist OperatorDecl
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap HieAST TypeIndex -> Slist OperatorDecl
nodeIds [HieAST TypeIndex]
nodeChildren)

    -- singleton or empty list with the top-level operator definition
    matchOperator :: HieAST TypeIndex -> Slist OperatorDecl
    matchOperator :: HieAST TypeIndex -> Slist OperatorDecl
matchOperator node :: HieAST TypeIndex
node@Node{..} = Bool -> Slist OperatorDecl -> Slist OperatorDecl
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
        (HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
typeSig)
        (Maybe (Slist OperatorDecl) -> Slist OperatorDecl
forall m. Monoid m => Maybe m -> m
maybeToMonoid (Maybe (Slist OperatorDecl) -> Slist OperatorDecl)
-> Maybe (Slist OperatorDecl) -> Slist OperatorDecl
forall a b. (a -> b) -> a -> b
$ (NonEmpty (HieAST TypeIndex) -> Slist OperatorDecl)
-> [HieAST TypeIndex] -> Maybe (Slist OperatorDecl)
forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty (HieAST TypeIndex -> Slist OperatorDecl
extractOperatorName (HieAST TypeIndex -> Slist OperatorDecl)
-> (NonEmpty (HieAST TypeIndex) -> HieAST TypeIndex)
-> NonEmpty (HieAST TypeIndex)
-> Slist OperatorDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (HieAST TypeIndex) -> HieAST TypeIndex
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head) [HieAST TypeIndex]
nodeChildren)
        -- first child of a parent is a name of a function/operator

    -- return AST node identifier names as a sized list of texts
    nodeIds :: HieAST TypeIndex -> Slist OperatorDecl
    nodeIds :: HieAST TypeIndex -> Slist OperatorDecl
nodeIds =
        (Identifier -> Slist OperatorDecl)
-> [Identifier] -> Slist OperatorDecl
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap Identifier -> Slist OperatorDecl
identifierName
        ([Identifier] -> Slist OperatorDecl)
-> (HieAST TypeIndex -> [Identifier])
-> HieAST TypeIndex
-> Slist OperatorDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier (IdentifierDetails TypeIndex) -> [Identifier]
forall k a. Map k a -> [k]
Map.keys
        (Map Identifier (IdentifierDetails TypeIndex) -> [Identifier])
-> (HieAST TypeIndex
    -> Map Identifier (IdentifierDetails TypeIndex))
-> HieAST TypeIndex
-> [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo TypeIndex -> Map Identifier (IdentifierDetails TypeIndex)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers
        (NodeInfo TypeIndex
 -> Map Identifier (IdentifierDetails TypeIndex))
-> (HieAST TypeIndex -> NodeInfo TypeIndex)
-> HieAST TypeIndex
-> Map Identifier (IdentifierDetails TypeIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST TypeIndex -> NodeInfo TypeIndex
forall a. HieAST a -> NodeInfo a
nodeInfo

    identifierName :: Identifier -> Slist OperatorDecl
    identifierName :: Identifier -> Slist OperatorDecl
identifierName = \case
        Left _ -> Slist OperatorDecl
forall a. Monoid a => a
mempty
        Right name :: Name
name -> OperatorDecl -> Slist OperatorDecl
forall a. a -> Slist a
S.one (OperatorDecl -> Slist OperatorDecl)
-> OperatorDecl -> Slist OperatorDecl
forall a b. (a -> b) -> a -> b
$ Text -> OperatorDecl
Fixity (Text -> OperatorDecl) -> Text -> OperatorDecl
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
name

    extractOperatorName :: HieAST TypeIndex -> Slist OperatorDecl
    extractOperatorName :: HieAST TypeIndex -> Slist OperatorDecl
extractOperatorName Node{..} =
        (Identifier -> Slist OperatorDecl)
-> [Identifier] -> Slist OperatorDecl
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap (RealSrcSpan -> Identifier -> Slist OperatorDecl
topLevelOperatorName RealSrcSpan
nodeSpan)
        ([Identifier] -> Slist OperatorDecl)
-> [Identifier] -> Slist OperatorDecl
forall a b. (a -> b) -> a -> b
$ Map Identifier (IdentifierDetails TypeIndex) -> [Identifier]
forall k a. Map k a -> [k]
Map.keys
        (Map Identifier (IdentifierDetails TypeIndex) -> [Identifier])
-> Map Identifier (IdentifierDetails TypeIndex) -> [Identifier]
forall a b. (a -> b) -> a -> b
$ NodeInfo TypeIndex -> Map Identifier (IdentifierDetails TypeIndex)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo TypeIndex
nodeInfo

    topLevelOperatorName :: RealSrcSpan -> Identifier -> Slist OperatorDecl
    topLevelOperatorName :: RealSrcSpan -> Identifier -> Slist OperatorDecl
topLevelOperatorName srcSpan :: RealSrcSpan
srcSpan = \case
        Left _ -> Slist OperatorDecl
forall a. Monoid a => a
mempty
        Right name :: Name
name ->
            let occName :: OccName
occName = Name -> OccName
nameOccName Name
name
            in Bool -> Slist OperatorDecl -> Slist OperatorDecl
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
                (OccName -> Bool
isSymOcc OccName
occName)  -- check if operator
                (OperatorDecl -> Slist OperatorDecl
forall a. a -> Slist a
S.one (OperatorDecl -> Slist OperatorDecl)
-> OperatorDecl -> Slist OperatorDecl
forall a b. (a -> b) -> a -> b
$ Text -> RealSrcSpan -> OperatorDecl
Operator (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
occName) RealSrcSpan
srcSpan)

-- | Either top-level operator or fixity declaration
data OperatorDecl
    = Fixity !Text
    -- | Operator name with its position to display later
    | Operator !Text !RealSrcSpan

{- | Partition a foldable of operator declarations into two maps:

1. Fixity declarations (mapped to @()@).
2. Top-level operator names (mapped to their source positions.

'Map' is used to be able to use the nice @merge@ function.
-}
partitionDecls
    :: Foldable f
    => f OperatorDecl
    -> (HashMap Text (), HashMap Text RealSrcSpan)
partitionDecls :: f OperatorDecl -> (HashMap Text (), HashMap Text RealSrcSpan)
partitionDecls = ((HashMap Text (), HashMap Text RealSrcSpan)
 -> OperatorDecl -> (HashMap Text (), HashMap Text RealSrcSpan))
-> (HashMap Text (), HashMap Text RealSrcSpan)
-> f OperatorDecl
-> (HashMap Text (), HashMap Text RealSrcSpan)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HashMap Text (), HashMap Text RealSrcSpan)
-> OperatorDecl -> (HashMap Text (), HashMap Text RealSrcSpan)
insertDecl (HashMap Text (), HashMap Text RealSrcSpan)
forall a. Monoid a => a
mempty
  where
    insertDecl
        :: (HashMap Text (), HashMap Text RealSrcSpan)
        -> OperatorDecl
        -> (HashMap Text (), HashMap Text RealSrcSpan)
    insertDecl :: (HashMap Text (), HashMap Text RealSrcSpan)
-> OperatorDecl -> (HashMap Text (), HashMap Text RealSrcSpan)
insertDecl (!HashMap Text ()
fixities, !HashMap Text RealSrcSpan
topOperators) = \case
        Fixity name :: Text
name -> (Text -> () -> HashMap Text () -> HashMap Text ()
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
name () HashMap Text ()
fixities, HashMap Text RealSrcSpan
topOperators)
        Operator name :: Text
name srcSpan :: RealSrcSpan
srcSpan -> (HashMap Text ()
fixities, Text
-> RealSrcSpan
-> HashMap Text RealSrcSpan
-> HashMap Text RealSrcSpan
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
name RealSrcSpan
srcSpan HashMap Text RealSrcSpan
topOperators)

{- | Analyses the whole AST starting from the very top.
-}
analyseAstWith
    :: forall a
    .  (HieAST TypeIndex -> Slist a)
    -- ^ Function to match AST node to some arbitrary type and return a
    -- sized list of matched elements
    -> HieFile
    -> Slist a
analyseAstWith :: (HieAST TypeIndex -> Slist a) -> HieFile -> Slist a
analyseAstWith match :: HieAST TypeIndex -> Slist a
match = HieASTs TypeIndex -> Slist a
findNodes (HieASTs TypeIndex -> Slist a)
-> (HieFile -> HieASTs TypeIndex) -> HieFile -> Slist a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> HieASTs TypeIndex
hie_asts
  where
    findNodes :: HieASTs TypeIndex -> Slist a
    findNodes :: HieASTs TypeIndex -> Slist a
findNodes =
        (HieAST TypeIndex -> Slist a) -> [HieAST TypeIndex] -> Slist a
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap ((HieAST TypeIndex -> Slist a) -> HieAST TypeIndex -> Slist a
forall a.
(HieAST TypeIndex -> Slist a) -> HieAST TypeIndex -> Slist a
matchAstWith HieAST TypeIndex -> Slist a
match)
        ([HieAST TypeIndex] -> Slist a)
-> (HieASTs TypeIndex -> [HieAST TypeIndex])
-> HieASTs TypeIndex
-> Slist a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FastString (HieAST TypeIndex) -> [HieAST TypeIndex]
forall k a. Map k a -> [a]
Map.elems
        (Map FastString (HieAST TypeIndex) -> [HieAST TypeIndex])
-> (HieASTs TypeIndex -> Map FastString (HieAST TypeIndex))
-> HieASTs TypeIndex
-> [HieAST TypeIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieASTs TypeIndex -> Map FastString (HieAST TypeIndex)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts

{- | Recursively match AST nodes starting from a given AST.
-}
matchAstWith
    :: forall a
    .  (HieAST TypeIndex -> Slist a)
    -- ^ Function to match AST node to some arbitrary type and return a
    -- sized list of matched elements
    -> HieAST TypeIndex
    -> Slist a
matchAstWith :: (HieAST TypeIndex -> Slist a) -> HieAST TypeIndex -> Slist a
matchAstWith match :: HieAST TypeIndex -> Slist a
match = HieAST TypeIndex -> Slist a
matchAst
  where
    matchAst :: HieAST TypeIndex -> Slist a
    matchAst :: HieAST TypeIndex -> Slist a
matchAst node :: HieAST TypeIndex
node@Node{..} =
        HieAST TypeIndex -> Slist a
match HieAST TypeIndex
node Slist a -> Slist a -> Slist a
forall a. Semigroup a => a -> a -> a
<> (HieAST TypeIndex -> Slist a) -> [HieAST TypeIndex] -> Slist a
forall (t :: * -> *) a b.
Foldable t =>
(a -> Slist b) -> t a -> Slist b
S.concatMap HieAST TypeIndex -> Slist a
matchAst [HieAST TypeIndex]
nodeChildren

-- | Like 'createMatchAst' but returns source spans of AST nodes.
createMatch :: PatternAst -> HieFile -> (HieAST TypeIndex -> Slist RealSrcSpan)
createMatch :: PatternAst -> HieFile -> HieAST TypeIndex -> Slist RealSrcSpan
createMatch patAst :: PatternAst
patAst hie :: HieFile
hie = (HieAST TypeIndex -> RealSrcSpan)
-> Slist (HieAST TypeIndex) -> Slist RealSrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan (Slist (HieAST TypeIndex) -> Slist RealSrcSpan)
-> (HieAST TypeIndex -> Slist (HieAST TypeIndex))
-> HieAST TypeIndex
-> Slist RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternAst
-> HieFile -> HieAST TypeIndex -> Slist (HieAST TypeIndex)
createMatchAst PatternAst
patAst HieFile
hie

{- | Create a non-recursive matching function for 'PatternAst' that
returns sized list of nodes that match this pattern.

* If the pattern matches 'Node', return it
* Otherwise return empty list
-}
createMatchAst
    :: PatternAst
    -> HieFile
    -> (HieAST TypeIndex -> Slist (HieAST TypeIndex))
createMatchAst :: PatternAst
-> HieFile -> HieAST TypeIndex -> Slist (HieAST TypeIndex)
createMatchAst patAst :: PatternAst
patAst hie :: HieFile
hie node :: HieAST TypeIndex
node =
    Bool -> Slist (HieAST TypeIndex) -> Slist (HieAST TypeIndex)
forall m. Monoid m => Bool -> m -> m
memptyIfFalse (HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
patAst) (HieAST TypeIndex -> Slist (HieAST TypeIndex)
forall a. a -> Slist a
S.one HieAST TypeIndex
node)