{-# LANGUAGE BangPatterns #-}
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
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
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
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
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)
extractComparisonGuard
:: HieAST TypeIndex
-> Maybe (HieAST TypeIndex, HieAST TypeIndex)
extractComparisonGuard :: HieAST TypeIndex -> Maybe (HieAST TypeIndex, HieAST TypeIndex)
extractComparisonGuard node :: HieAST TypeIndex
node = do
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
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
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
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
(?)
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)
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")
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)
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
(HieFile -> HieAST TypeIndex -> PatternAst -> Bool
hieMatchPatternAst HieFile
hie HieAST TypeIndex
node PatternAst
dataDecl)
(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
[] -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
[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
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
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
[] -> []
[n :: HieAST TypeIndex
n] ->
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
where
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
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
matchField :: HieAST TypeIndex -> Slist RealSrcSpan
matchField :: HieAST TypeIndex -> Slist RealSrcSpan
matchField = PatternAst -> HieFile -> HieAST TypeIndex -> Slist RealSrcSpan
createMatch PatternAst
lazyField HieFile
hie
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
(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')
(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
[] -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
[pm :: HieAST TypeIndex
pm] -> HieAST TypeIndex -> Slist RealSrcSpan
analyseBranches HieAST TypeIndex
pm
_:pm :: HieAST TypeIndex
pm:_ -> HieAST TypeIndex -> Slist RealSrcSpan
analyseBranches HieAST TypeIndex
pm
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
[] -> Slist RealSrcSpan
forall a. Monoid a => a
mempty
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
$
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)
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
( Literal -> PatternAst
PatternAstConstant Literal
AnyLiteral
PatternAst -> PatternAst -> PatternAst
forall a. PatternBool a => a -> a -> a
||| PatternAst
literalPat
)
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
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)
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)
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)
(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)
data OperatorDecl
= Fixity !Text
| Operator !Text !RealSrcSpan
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)
analyseAstWith
:: forall a
. (HieAST TypeIndex -> Slist a)
-> 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
matchAstWith
:: forall a
. (HieAST TypeIndex -> Slist a)
-> 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
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
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)