From c5a4490e6bce5e3f72105431512ac092e8701d1f Mon Sep 17 00:00:00 2001 From: Dmitrii Kovanikov Date: Mon, 1 Jun 2020 18:15:19 +0100 Subject: [PATCH] [#106] Patterns boolean algebra (#192) * [#106] Patterns boolean algebra Resolves #106 * Add more tests * Better test names, consistency --- src/Stan/Analysis/Analyser.hs | 4 ++- src/Stan/Hie/MatchAst.hs | 16 +++++++++--- src/Stan/Hie/MatchType.hs | 5 ++++ src/Stan/Inspection/AntiPattern.hs | 2 +- src/Stan/Inspection/Infinite.hs | 3 ++- src/Stan/Inspection/Partial.hs | 21 +++++++++++----- src/Stan/Pattern/Ast.hs | 26 +++++++++++++++++--- src/Stan/Pattern/Edsl.hs | 39 ++++++++++++++++++++++++++++++ src/Stan/Pattern/Type.hs | 25 ++++++++++++------- stan.cabal | 1 + target/Target/Partial.hs | 13 +++++++++- test/Test/Stan/Analysis/Common.hs | 2 +- test/Test/Stan/Analysis/Partial.hs | 32 +++++++++++++++++++----- test/Test/Stan/Number.hs | 4 +-- 14 files changed, 159 insertions(+), 34 deletions(-) create mode 100644 src/Stan/Pattern/Edsl.hs diff --git a/src/Stan/Analysis/Analyser.hs b/src/Stan/Analysis/Analyser.hs index c9781493..566ebac7 100644 --- a/src/Stan/Analysis/Analyser.hs +++ b/src/Stan/Analysis/Analyser.hs @@ -73,7 +73,9 @@ analyseNameMeta insId nameMeta patType hie@HieFile{..} = -- matches with the given nameMeta $ hieMatchNameMeta nameMeta hieId -- compatible with the given pattern - && any (hieMatchPatternType hie_types patType) typeIxs + && case typeIxs of + [] -> False + t : _ -> hieMatchPatternType hie_types patType t pure srcSpan diff --git a/src/Stan/Hie/MatchAst.hs b/src/Stan/Hie/MatchAst.hs index 0e891831..6b31d312 100644 --- a/src/Stan/Hie/MatchAst.hs +++ b/src/Stan/Hie/MatchAst.hs @@ -40,10 +40,18 @@ hieMatchPatternAst -> HieAST TypeIndex -- ^ Current AST node to match -> PatternAst -- ^ Pattern to match against -> Bool -- ^ 'True' if pattern matches AST node -hieMatchPatternAst hie@HieFile{..} Node{..} = \case +hieMatchPatternAst hie@HieFile{..} node@Node{..} = \case PatternAstAnything -> True + PatternAstNeg p -> + not (hieMatchPatternAst hie node p) + PatternAstOr p1 p2 -> + hieMatchPatternAst hie node p1 + || hieMatchPatternAst hie node p2 + PatternAstAnd p1 p2 -> + hieMatchPatternAst hie node p1 + && hieMatchPatternAst hie node p2 PatternAstConstant n -> - Set.member ("HsOverLit", "HsExpr") (nodeAnnotations nodeInfo) + Set.member ("HsOverLit", "HsExpr") (nodeAnnotations nodeInfo) && readMaybe (decodeUtf8 $ slice nodeSpan) == Just n PatternAstName nameMeta patType -> any (matchNameAndType nameMeta patType) @@ -69,4 +77,6 @@ hieMatchPatternAst hie@HieFile{..} Node{..} = \case -> Bool matchNameAndType nameMeta patType ids = hieMatchNameMeta nameMeta ids - && any (hieMatchPatternType hie_types patType) (nodeType nodeInfo) + && case nodeType nodeInfo of + [] -> False + t : _ -> hieMatchPatternType hie_types patType t diff --git a/src/Stan/Hie/MatchType.hs b/src/Stan/Hie/MatchType.hs index 82e7e62b..6be8851b 100644 --- a/src/Stan/Hie/MatchType.hs +++ b/src/Stan/Hie/MatchType.hs @@ -59,9 +59,14 @@ hieMatchPatternType arr pat i = curFlat `satisfyPattern` pat satisfyPattern :: HieTypeFlat -> PatternType -> Bool satisfyPattern _ PatternTypeAnything = True + satisfyPattern t (PatternTypeNeg p) = + not (satisfyPattern t p) satisfyPattern t (PatternTypeOr p1 p2) = satisfyPattern t p1 || satisfyPattern t p2 + satisfyPattern t (PatternTypeAnd p1 p2) = + satisfyPattern t p1 + && satisfyPattern t p2 satisfyPattern (HTyVarTy name) (PatternTypeName nameMeta []) = compareNames nameMeta name satisfyPattern diff --git a/src/Stan/Inspection/AntiPattern.hs b/src/Stan/Inspection/AntiPattern.hs index 9fe2d067..fbf6c09a 100644 --- a/src/Stan/Inspection/AntiPattern.hs +++ b/src/Stan/Inspection/AntiPattern.hs @@ -28,7 +28,7 @@ import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap solutionL) import Stan.NameMeta (mkBaseFoldableMeta) import Stan.Pattern.Ast (PatternAst (..), app, range) -import Stan.Pattern.Type ((?)) +import Stan.Pattern.Edsl (PatternBool (..)) import Stan.Severity (Severity (PotentialBug)) import qualified Stan.Category as Category diff --git a/src/Stan/Inspection/Infinite.hs b/src/Stan/Inspection/Infinite.hs index 097f7a90..bc4a4c7f 100644 --- a/src/Stan/Inspection/Infinite.hs +++ b/src/Stan/Inspection/Infinite.hs @@ -34,7 +34,8 @@ import Relude.Extra.Tuple (mapToFst) import Stan.Core.Id (Id (..)) import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap) import Stan.NameMeta (NameMeta (..), mkBaseFoldableMeta, mkBaseListMeta, mkBaseOldListMeta) -import Stan.Pattern.Type (PatternType (..), listFunPattern, (?)) +import Stan.Pattern.Edsl (PatternBool (..)) +import Stan.Pattern.Type (PatternType (..), listFunPattern) import Stan.Severity (Severity (..)) import qualified Stan.Category as Category diff --git a/src/Stan/Inspection/Partial.hs b/src/Stan/Inspection/Partial.hs index ee55e60a..9be3afd6 100644 --- a/src/Stan/Inspection/Partial.hs +++ b/src/Stan/Inspection/Partial.hs @@ -59,6 +59,7 @@ module Stan.Inspection.Partial , partialInspectionsMap ) where +import Prelude hiding ((&&&)) import Relude.Extra.Lens ((%~), (.~)) import Relude.Extra.Tuple (mapToFst) @@ -67,8 +68,9 @@ import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap descriptionL, solutionL) import Stan.NameMeta (NameMeta (..), baseNameFrom, mkBaseFoldableMeta, mkBaseListMeta, mkBaseOldListMeta) +import Stan.Pattern.Edsl (PatternBool (..)) import Stan.Pattern.Type (PatternType (..), integerPattern, listFunPattern, listPattern, - naturalPattern, nonEmptyPattern, (?), (|->)) + naturalPattern, nonEmptyPattern, (|->)) import Stan.Severity (Severity (..)) import qualified Stan.Category as Category @@ -144,8 +146,9 @@ mkPartialInspectionList insId nameMeta = mkPartialInspection insId nameMeta "lis {- | Smart constructor to create partial 'Inspection' for functions that work with enumerable types. -} -mkPartialInspectionEnum :: Id Inspection -> Text -> [Text] -> Inspection -mkPartialInspectionEnum insId funName solution = mkPartialInspection insId enumMeta "" +mkPartialInspectionEnum :: Id Inspection -> Text -> PatternType -> [Text] -> Inspection +mkPartialInspectionEnum insId funName pat solution = + mkPartialInspectionPattern insId enumMeta pat "" & descriptionL .~ usage funName "enumerable types" & solutionL .~ solution where @@ -206,19 +209,25 @@ stan0009 = mkPartialInspection (Id "STAN-0009") readNameMeta "" -- | 'Inspection' — partial 'GHC.Enum.succ' @STAN-0010@. stan0010 :: Inspection -stan0010 = mkPartialInspectionEnum (Id "STAN-0010") "succ" +stan0010 = mkPartialInspectionEnum + (Id "STAN-0010") + "succ" + (neg (integerPattern |-> (?)) &&& neg (naturalPattern |-> (?))) [ "Use '(+ 1)' for integral types (but be aware of arithmetic overflow)" ] -- | 'Inspection' — partial 'GHC.Enum.pred' @STAN-0011@. stan0011 :: Inspection -stan0011 = mkPartialInspectionEnum (Id "STAN-0011") "pred" +stan0011 = mkPartialInspectionEnum + (Id "STAN-0011") + "pred" + (neg (integerPattern |-> (?))) [ "Use '(- 1)' for integral types (but be aware of arithmetic overflow)" ] -- | 'Inspection' — partial 'GHC.Enum.toEnum' @STAN-0012@. stan0012 :: Inspection -stan0012 = mkPartialInspectionEnum (Id "STAN-0012") "toEnum" [] +stan0012 = mkPartialInspectionEnum (Id "STAN-0012") "toEnum" (?) [] -- | 'Inspection' — partial 'Data.Foldable.maximum' @STAN-0013@. stan0013 :: Inspection diff --git a/src/Stan/Pattern/Ast.hs b/src/Stan/Pattern/Ast.hs index a2639b78..2b9f7ed4 100644 --- a/src/Stan/Pattern/Ast.hs +++ b/src/Stan/Pattern/Ast.hs @@ -18,6 +18,7 @@ module Stan.Pattern.Ast import FastString (FastString) import Stan.NameMeta (NameMeta (..)) +import Stan.Pattern.Edsl (PatternBool (..)) import Stan.Pattern.Type (PatternType) @@ -26,18 +27,37 @@ tries to mirror HIE AST to each future matching, so it's quite low-level, but helper functions are provided. -} data PatternAst - -- | AST wildcard, matches anything. - = PatternAstAnything -- | Integer constant in code. - | PatternAstConstant Int -- TODO: support constants of different types + = PatternAstConstant Int -- TODO: support constants of different types -- | Name of a specific function, variable or data type. | PatternAstName NameMeta PatternType -- | AST node with tags for current node and children patterns | PatternAstNode (Set (FastString, FastString)) -- ^ Set of context info (pairs of tags) [PatternAst] -- ^ Node children + -- | AST wildcard, matches anything. + | PatternAstAnything + -- | Choice between patterns. Should match either of them. + | PatternAstOr PatternAst PatternAst + -- | Union of patterns. Should match both of them. + | PatternAstAnd PatternAst PatternAst + -- | Negation of pattern. Should match everything except this pattern. + | PatternAstNeg PatternAst deriving stock (Show, Eq) +instance PatternBool PatternAst where + (?) :: PatternAst + (?) = PatternAstAnything + + neg :: PatternAst -> PatternAst + neg = PatternAstNeg + + (|||) :: PatternAst -> PatternAst -> PatternAst + (|||) = PatternAstOr + + (&&&) :: PatternAst -> PatternAst -> PatternAst + (&&&) = PatternAstAnd + -- | @app f x@ is a pattern for function application @f x@. app :: PatternAst -> PatternAst -> PatternAst app f x = PatternAstNode (one ("HsApp", "HsExpr")) [f, x] diff --git a/src/Stan/Pattern/Edsl.hs b/src/Stan/Pattern/Edsl.hs new file mode 100644 index 00000000..192371c2 --- /dev/null +++ b/src/Stan/Pattern/Edsl.hs @@ -0,0 +1,39 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Embedded DSL for patterns (AST and Type). Implemented using the +/Final Taggless/ approach. +-} + +module Stan.Pattern.Edsl + ( PatternBool (..) + ) where + +{- | Common interface for 'Bool'-like parts of patterns. Allows to +write composable and reusable complex pattern definitions from smaller +pieces. + +Laws (in terms of matching functions that return 'Bool'): + +* @'(?)' ≡ 'True'@ +* @'neg' '(?)' ≡ 'False'@ +* @'(?)' '|||' x ≡ x '|||' '(?)' ≡ 'True'@ +* @'(?)' '&&&' x ≡ x '&&&' '(?)' ≡ x@ +-} +class PatternBool a where + -- | Anything. Matching should always return 'True'. + (?) :: a + + -- | Negation. Inverses the argument. + neg :: a -> a + + -- | Or-pattern. Choice. + (|||) :: a -> a -> a + + -- | And-pattern. Both. + (&&&) :: a -> a -> a + +infixr 2 ||| +infixr 3 &&& diff --git a/src/Stan/Pattern/Type.hs b/src/Stan/Pattern/Type.hs index 02171b47..fdc40b5a 100644 --- a/src/Stan/Pattern/Type.hs +++ b/src/Stan/Pattern/Type.hs @@ -11,8 +11,6 @@ module Stan.Pattern.Type PatternType (..) -- * eDSL - , (?) - , (|||) , (|->) , (|::) @@ -25,6 +23,7 @@ module Stan.Pattern.Type ) where import Stan.NameMeta (NameMeta (..), baseNameFrom) +import Stan.Pattern.Edsl (PatternBool (..)) {- | Query pattern used to search types in HIE AST. @@ -47,16 +46,24 @@ data PatternType | PatternTypeAnything -- | Choice between patterns. Should match either of them. | PatternTypeOr PatternType PatternType + -- | Union of patterns. Should match both of them. + | PatternTypeAnd PatternType PatternType + -- | Negation of pattern. Should match everything except this pattern. + | PatternTypeNeg PatternType deriving stock (Show, Eq) --- | Short operator alias for 'PatternTypeAnything'. -(?) :: PatternType -(?) = PatternTypeAnything +instance PatternBool PatternType where + (?) :: PatternType + (?) = PatternTypeAnything --- | Short operator alias for 'PatternTypeOr'. -infixr 3 ||| -(|||) :: PatternType -> PatternType -> PatternType -(|||) = PatternTypeOr + neg :: PatternType -> PatternType + neg = PatternTypeNeg + + (|||) :: PatternType -> PatternType -> PatternType + (|||) = PatternTypeOr + + (&&&) :: PatternType -> PatternType -> PatternType + (&&&) = PatternTypeAnd -- | Short operator alias for 'PatternFun'. infixr 4 |-> diff --git a/stan.cabal b/stan.cabal index 289d7ddb..f2b859c2 100644 --- a/stan.cabal +++ b/stan.cabal @@ -99,6 +99,7 @@ library Stan.NameMeta Stan.Observation Stan.Pattern.Ast + Stan.Pattern.Edsl Stan.Pattern.Type Stan.Report Stan.Severity diff --git a/target/Target/Partial.hs b/target/Target/Partial.hs index ecf554a4..8271a407 100644 --- a/target/Target/Partial.hs +++ b/target/Target/Partial.hs @@ -40,7 +40,7 @@ stanRead = read stanSucc :: Int -> Int stanSucc = succ -stanPred :: Int -> Int +stanPred :: Natural -> Natural stanPred = pred stanToEnum :: Int -> Bool @@ -72,3 +72,14 @@ stanFromList = fromList stanFromInteger :: Integer -> Natural stanFromInteger = fromInteger + +-- Other tests + +stanSuccNatural :: Natural -> Natural +stanSuccNatural = succ -- no warning here + +stanPredInteger :: Integer -> Integer +stanPredInteger = pred -- no warning here + +stanPredPoly :: Enum a => a -> a +stanPredPoly = pred diff --git a/test/Test/Stan/Analysis/Common.hs b/test/Test/Stan/Analysis/Common.hs index 8758968f..bfac9774 100644 --- a/test/Test/Stan/Analysis/Common.hs +++ b/test/Test/Stan/Analysis/Common.hs @@ -83,7 +83,7 @@ noObservationAssert modulePath moduleName analysis Inspection{..} line = foundPartialObservation = find (\Observation{..} -> observationInspectionId == inspectionId - && observationFile == modulePath + && observationFile == "target" modulePath && observationModuleName == moduleName && srcSpanStartLine observationLoc == line ) diff --git a/test/Test/Stan/Analysis/Partial.hs b/test/Test/Stan/Analysis/Partial.hs index 89ac0c33..c9c33516 100644 --- a/test/Test/Stan/Analysis/Partial.hs +++ b/test/Test/Stan/Analysis/Partial.hs @@ -8,21 +8,33 @@ import Stan.Analysis (Analysis) import Stan.Inspection (Inspection (..), sortById) import Stan.Inspection.Partial (partialInspectionsMap) import Stan.NameMeta (NameMeta (..)) -import Test.Stan.Analysis.Common (itShouldStr, observationAssert, unsafeNameMeta) +import Test.Stan.Analysis.Common (itShouldStr, noObservationAssert, observationAssert, + unsafeNameMeta) import qualified Data.Text as T +import qualified Stan.Inspection.Partial as Partial + analysisPartialSpec :: Analysis -> Spec -analysisPartialSpec analysis = describe "Partial functions" $ +analysisPartialSpec analysis = describe "Partial functions" $ do forM_ (zip (sortById partialInspectionsMap) [14, 17 ..]) checkObservation + + let noObservation = noObservationAssert + "Target/Partial.hs" + "Target.Partial" + analysis + + it "STAN-0010: doesn't trigger on 'succ :: Natural -> Natural'" $ + noObservation Partial.stan0010 79 + it "STAN-0011: doesn't trigger on 'pred :: Integer -> Integer'" $ + noObservation Partial.stan0011 82 + it "STAN-0011: triggers on polymorphic 'pred :: Enum a => a -> a'" $ + checkObservationFor Partial.stan0011 85 16 20 where checkObservation :: (Inspection, Int) -> SpecWith (Arg Expectation) checkObservation (ins@Inspection{..}, line) = it (itShouldStr ins) $ - observationAssert "Target/Partial.hs" "Target.Partial" - analysis - ins - line start end + checkObservationFor ins line start end where nameMeta :: NameMeta nameMeta = unsafeNameMeta inspectionAnalysis @@ -31,3 +43,11 @@ analysisPartialSpec analysis = describe "Partial functions" $ funLen = T.length $ nameMetaName nameMeta start = if nameMetaName nameMeta == "!!" then funLen + 14 else funLen + 8 end = start + funLen + + checkObservationFor :: Inspection -> Int -> Int -> Int -> Expectation + checkObservationFor ins line start end = observationAssert + "Target/Partial.hs" + "Target.Partial" + analysis + ins + line start end diff --git a/test/Test/Stan/Number.hs b/test/Test/Stan/Number.hs index e9bc5a61..92885036 100644 --- a/test/Test/Stan/Number.hs +++ b/test/Test/Stan/Number.hs @@ -12,9 +12,9 @@ import Stan.Hie (countLinesOfCode) linesOfCodeSpec :: HieFile -> Spec linesOfCodeSpec hieFile = describe "LoC tests" $ it "should count lines of code in the example file" $ - countLinesOfCode hieFile `shouldBe` 74 + countLinesOfCode hieFile `shouldBe` 85 modulesNumSpec :: Int -> Spec modulesNumSpec num = describe "Modules number tests" $ it "should count correct number of modules" $ - num `shouldBe` 46 + num `shouldBe` 47