[mrkkrp#106] Patterns boolean algebra (mrkkrp#192)

* [mrkkrp#106] Patterns boolean algebra

Resolves mrkkrp#106

* Add more tests

* Better test names, consistency

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
 

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

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

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

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

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

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]

src/Stan/Pattern/Edsl.hs

@@ -0,0 +1,39 @@
+{- |
+Copyright: (c) 2020 Kowainik
+SPDX-License-Identifier: MPL-2.0
+Maintainer: Kowainik <xrom.xkov@gmail.com>
+
+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 &&&

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 |->

stan.cabal

@@ -99,6 +99,7 @@ library
                          Stan.NameMeta
                          Stan.Observation
                            Stan.Pattern.Ast
+                           Stan.Pattern.Edsl
                            Stan.Pattern.Type
                          Stan.Report
                          Stan.Severity

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

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
         )

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

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