[#171] Inspection: strict data type fields (#233)

* [#171] Inspection: strict data type fields

Resolves #171

* Fix after review

* Make all fields strict

src/Stan/Analysis.hs

@@ -167,7 +167,9 @@ analyseHieFile hieFile@HieFile{..} cabalExts obs insIds = do
     let fileInfoMergedExtensions = mergeParsedExtensions fileInfoCabalExtensions fileInfoExtensions
     -- get list of inspections for the file
     let ins = mapMaybe lookupInspectionById (toList insIds)
-    let allObservations = S.concatMap (`analysisByInspection` hieFile) ins
+    let allObservations = S.concatMap
+            (\iId -> analysisByInspection fileInfoMergedExtensions iId hieFile)
+            ins
     let (ignoredObs, fileInfoObservations) = S.partition ((`elem` obs) . observationId) allObservations
 
     incModulesNum

src/Stan/Analysis/Analyser.hs

@@ -13,6 +13,8 @@ module Stan.Analysis.Analyser
     ( analysisByInspection
     ) where
 
+import Extensions (ExtensionsResult)
+import GHC.LanguageExtensions.Type (Extension (Strict, StrictData))
 import HieTypes (HieAST (..), HieASTs (..), HieFile (..), Identifier, IdentifierDetails (..),
                  NodeInfo (..), TypeIndex)
 import Name (nameOccName)
@@ -21,27 +23,36 @@ import Slist (Slist, slist)
 import SrcLoc (RealSrcSpan)
 
 import Stan.Core.Id (Id)
+import Stan.FileInfo (isExtensionDisabled)
 import Stan.Hie.MatchAst (hieMatchPatternAst)
 import Stan.Hie.MatchType (hieMatchPatternType)
 import Stan.Inspection (Inspection (..), InspectionAnalysis (..))
 import Stan.NameMeta (NameMeta, hieMatchNameMeta)
 import Stan.Observation (Observations, mkObservation)
-import Stan.Pattern.Ast (PatternAst, fixity, typeSig)
+import Stan.Pattern.Ast (PatternAst, constructor, dataDecl, fixity, lazyField, typeSig)
 import Stan.Pattern.Type (PatternType)
 
 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 :: Inspection -> HieFile -> Observations
-analysisByInspection Inspection{..} = case inspectionAnalysis of
+analysisByInspection
+    :: ExtensionsResult
+    -> Inspection
+    -> HieFile
+    -> Observations
+analysisByInspection exts Inspection{..} = case inspectionAnalysis of
     FindName nameMeta patType -> analyseNameMeta inspectionId nameMeta patType
     FindAst patAst            -> analyseAst inspectionId patAst
     Infix                     -> analyseInfix inspectionId
+    LazyField                 -> memptyIfFalse
+        (isExtensionDisabled StrictData exts && isExtensionDisabled Strict exts)
+        (analyseLazyFields inspectionId)
 
 {- | Check for occurrences of the specified function given via 'NameMeta'.
 -}
@@ -93,11 +104,62 @@ analyseAst
   -> HieFile
   -> Observations
 analyseAst insId patAst hie =
-    mkObservation insId hie <$> analyseAstWith matchPattern hie
+    mkObservation insId hie <$> analyseAstWith (createMatch patAst hie) hie
+
+{- | 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 insId hie =
+    mkObservation insId hie <$> analyseAstWith matchLazyField hie
   where
-    matchPattern :: HieAST TypeIndex -> Slist RealSrcSpan
-    matchPattern node@Node{..} =
-        memptyIfFalse (hieMatchPatternAst hie node patAst) (S.one nodeSpan)
+    matchLazyField :: HieAST TypeIndex -> Slist RealSrcSpan
+    matchLazyField node = memptyIfFalse
+        -- return empty list if it's not a data type
+        (hieMatchPatternAst hie node dataDecl)
+        -- get list of all constructors
+        $ let constructors = filter
+                (\n -> hieMatchPatternAst hie n constructor)
+                (nodeChildren node)
+          in case constructors of
+              -- no constructors = not observations
+              []  -> mempty
+              -- single constructor
+              [c] -> S.concatMap matchField $ extractFields False c
+              -- multiple constructors = analyse everything
+              cs  -> S.concatMap (S.concatMap matchField . extractFields True) cs
+
+    -- Extract fields as AST nodes. Return empty list if only one field
+    -- (as a workaround for the @newtype@ problem)
+    --
+    -- record constructors have 2 children:
+    --   1. Constructor name.
+    --   2. 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 hasManyCtors ctor = case drop 1 $ nodeChildren ctor of
+        [] -> []  -- no fields
+        [n] ->  -- single field, maybe dummy record node
+            if isDummyRecordNode n
+            then case nodeChildren n of
+                []      -> []
+                [field] -> [field | hasManyCtors]
+                fields  -> fields
+            else [n | hasManyCtors]
+        fields -> fields  -- plain constructor
+      where
+        -- simple check for the dummy AST node
+        isDummyRecordNode :: HieAST TypeIndex -> Bool
+        isDummyRecordNode = Set.null . nodeAnnotations . nodeInfo
+
+    -- matches record fields non-recursively
+    matchField :: HieAST TypeIndex -> Slist RealSrcSpan
+    matchField = createMatch lazyField hie
 
 {- | Analyse HIE AST to find all operators which lack explicit fixity
 declaration.
@@ -163,9 +225,9 @@ analyseInfix insId hie =
 
 -- | Either top-level operator or fixity declaration
 data OperatorDecl
-    = Fixity Text
+    = Fixity !Text
     -- | Operator name with its position to display later
-    | Operator Text RealSrcSpan
+    | Operator !Text !RealSrcSpan
 
 {- | Partition a foldable of operator declarations into two maps:
 
@@ -188,6 +250,8 @@ partitionDecls = foldl' insertDecl mempty
         Fixity name -> (HM.insert name () fixities, topOperators)
         Operator name srcSpan -> (fixities, HM.insert name srcSpan topOperators)
 
+{- | Analyses the whole AST starting from the very top.
+-}
 analyseAstWith
   :: forall a
   .  (HieAST TypeIndex -> Slist a)
@@ -199,10 +263,32 @@ analyseAstWith match = findNodes . hie_asts
   where
     findNodes :: HieASTs TypeIndex -> Slist a
     findNodes =
-        S.concatMap matchAst
+        S.concatMap (matchAstWith match)
         . Map.elems
         . 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 match = matchAst
+  where
     matchAst :: HieAST TypeIndex -> Slist a
     matchAst node@Node{..} =
         match node <> S.concatMap matchAst nodeChildren
+
+{- | Create a non-recursive matching function for 'PatternAst' that
+returns sized list of source positions for nodes that matches this
+pattern.
+
+* If the pattern matches 'Node', return it
+* Otherwise return empty list
+-}
+createMatch :: PatternAst -> HieFile -> (HieAST TypeIndex -> Slist RealSrcSpan)
+createMatch patAst hie node@Node{..} =
+    memptyIfFalse (hieMatchPatternAst hie node patAst) (S.one nodeSpan)

src/Stan/Cli.hs

@@ -43,10 +43,10 @@ import Stan.Report.Settings (ReportSettings (..))
 
 -- | Commands used in Stan CLI.
 data StanCommand
-    = Stan StanArgs  -- ^ Just @stan@ with its options.
-    | StanInspection InspectionArgs  -- ^ @stan inspection@.
-    | StanTomlToCli TomlToCliArgs  -- ^ @stan toml-to-cli@
-    | StanCliToToml CliToTomlArgs  -- ^ @stan cli-to-toml@
+    = Stan !StanArgs  -- ^ Just @stan@ with its options.
+    | StanInspection !InspectionArgs  -- ^ @stan inspection@.
+    | StanTomlToCli !TomlToCliArgs  -- ^ @stan toml-to-cli@
+    | StanCliToToml !CliToTomlArgs  -- ^ @stan cli-to-toml@
 
 -- | Options used for the main @stan@ command.
 data StanArgs = StanArgs
@@ -191,9 +191,9 @@ toggleSolutionP = flag ShowSolution HideSolution $ mconcat
     ]
 
 data ConfigCommand
-    = CheckCommand Check
-    | RemoveCommand Scope
-    | IgnoreCommand (Id Observation)
+    = CheckCommand !Check
+    | RemoveCommand !Scope
+    | IgnoreCommand !(Id Observation)
 
 partitionCommands :: [ConfigCommand] -> ([Check], [Scope], [Id Observation])
 partitionCommands [] = ([], [], [])

src/Stan/Config.hs

@@ -106,16 +106,16 @@ data Check = Check
 
 -- | Criterion for inspections filtering.
 data CheckFilter
-    = CheckInspection (Id Inspection)
-    | CheckSeverity Severity
-    | CheckCategory Category
+    = CheckInspection !(Id Inspection)
+    | CheckSeverity !Severity
+    | CheckCategory !Category
     | CheckAll
     deriving stock (Show, Eq)
 
 -- | Where to apply the rule for controlling inspection set.
 data Scope
-    = ScopeFile FilePath
-    | ScopeDirectory FilePath
+    = ScopeFile !FilePath
+    | ScopeDirectory !FilePath
     | ScopeAll
     deriving stock (Show, Eq)
 

src/Stan/FileInfo.hs

@@ -11,13 +11,18 @@ module Stan.FileInfo
     , FileInfo (..)
 
     , extensionsToText
+    , isExtensionDisabled
     ) where
 
-import Extensions (ExtensionsError, ExtensionsResult, ParsedExtensions (..), showOnOffExtension)
+import Extensions (Extensions (..), ExtensionsError, ExtensionsResult, OnOffExtension (..),
+                   ParsedExtensions (..), showOnOffExtension)
+import GHC.LanguageExtensions.Type (Extension)
 
 import Stan.Core.ModuleName (ModuleName)
 import Stan.Observation (Observations)
 
+import qualified Data.Set as Set
+
 
 -- | File specific information.
 data FileInfo = FileInfo
@@ -41,3 +46,12 @@ extensionsToText = \case
         case parsedExtensionsSafe of
             Just s  -> show s : exts
             Nothing -> exts
+
+{- | Check whether the given extension is disabled
+-}
+isExtensionDisabled :: Extension -> ExtensionsResult -> Bool
+isExtensionDisabled ext = \case
+    Left _ -> True  -- no info about extensions, consider it disabled
+    Right Extensions{..} ->
+           Set.notMember (On ext) extensionsAll
+        || Set.member (Off ext) extensionsAll

src/Stan/Inspection.hs

@@ -88,11 +88,13 @@ inspections in a uniformed way.
 -}
 data InspectionAnalysis
     -- | Find specific function name by specified 'PatternType'.
-    = FindName NameMeta PatternType
+    = FindName !NameMeta !PatternType
     -- | Find the specific part of the Haskell AST.
-    | FindAst PatternAst
+    | FindAst !PatternAst
     -- | Find all operators without matching @infix[r|l]@
     | Infix
+    -- | Check if the data type has lazy fields
+    | LazyField
     deriving stock (Show, Eq)
 
 -- | Show 'Inspection' in a human-friendly format.

src/Stan/Inspection/AntiPattern.hs

@@ -23,6 +23,8 @@ module Stan.Inspection.AntiPattern
     , stan0204
       -- *** Anti-pattern slow 'size' for 'HashSet'
     , stan0205
+      -- *** Anti-pattern: Lazy fields
+    , stan0206
 
       -- * All inspections
     , antiPatternInspectionsMap
@@ -51,6 +53,7 @@ antiPatternInspectionsMap = fromList $ fmapToFst inspectionId
     , stan0203
     , stan0204
     , stan0205
+    , stan0206
     ]
 
 -- | Smart constructor to create anti-pattern 'Inspection'.
@@ -147,3 +150,19 @@ stan0205 = mkAntiPatternInspection (Id "STAN-0205") "HashSet size"
         , nameMetaModuleName = "Data.HashSet.Base"
         , nameMetaName       = "size"
         }
+
+-- | 'Inspection' — missing fixity declaration @STAN-0206@.
+stan0206 :: Inspection
+stan0206 = Inspection
+    { inspectionId = Id "STAN-0206"
+    , inspectionName = "Data types with non-strict fields"
+    , inspectionDescription =
+        "Defining lazy fields in data types can lead to unexpected space leaks"
+    , inspectionSolution =
+        [ "Add '!' before the type, e.g. !Int or !(Maybe Bool)"
+        , "Enable the 'StrictData' extension: {-# LANGUAGE StrictData #-}"
+        ]
+    , inspectionCategory = Category.spaceLeak :| [Category.syntax]
+    , inspectionSeverity = Performance
+    , inspectionAnalysis = LazyField
+    }