From 2e1905c08209d1f8172930173812acbd93538ff5 Mon Sep 17 00:00:00 2001 From: Yashasvi Rana Date: Fri, 20 Sep 2024 19:43:14 +0530 Subject: [PATCH 1/3] dc fix --- dc/.juspay/dc/test/Main.hs.err.json | 1 + dc/.juspay/dc/test/Main.hs.json | 8 ++++++++ dc/.juspay/dc/test/Sample.hs.err.json | 14 ++++++++++++++ dc/.juspay/dc/test/Sample.hs.json | 10 ++++++++++ dc/.juspay/domainConfig.yaml | 7 +++++++ dc/dc.cabal | 5 ++++- dc/src/DC/DefaultCheck.hs | 6 +++++- dc/test/Main.hs | 11 ++++++++++- dc/test/Sample.hs | 20 ++++++++++++++++++++ flake.lock | 6 +++--- flake.nix | 2 ++ 11 files changed, 84 insertions(+), 6 deletions(-) create mode 100644 dc/.juspay/dc/test/Main.hs.err.json create mode 100644 dc/.juspay/dc/test/Main.hs.json create mode 100644 dc/.juspay/dc/test/Sample.hs.err.json create mode 100644 dc/.juspay/dc/test/Sample.hs.json create mode 100644 dc/.juspay/domainConfig.yaml create mode 100644 dc/test/Sample.hs diff --git a/dc/.juspay/dc/test/Main.hs.err.json b/dc/.juspay/dc/test/Main.hs.err.json new file mode 100644 index 0000000..9e26dfe --- /dev/null +++ b/dc/.juspay/dc/test/Main.hs.err.json @@ -0,0 +1 @@ +{} \ No newline at end of file diff --git a/dc/.juspay/dc/test/Main.hs.json b/dc/.juspay/dc/test/Main.hs.json new file mode 100644 index 0000000..cdc7c96 --- /dev/null +++ b/dc/.juspay/dc/test/Main.hs.json @@ -0,0 +1,8 @@ +{ + "allFailuresRecords": [], + "commonErrorFuns": [], + "createdFailures": [], + "createdRecords": [], + "updatedFailures": [], + "updatedRecords": [] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/Sample.hs.err.json b/dc/.juspay/dc/test/Sample.hs.err.json new file mode 100644 index 0000000..83a7c1f --- /dev/null +++ b/dc/.juspay/dc/test/Sample.hs.err.json @@ -0,0 +1,14 @@ +{ + "proxyFunction": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 13, + "src_span_endl": 8, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 8 + } + ] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/Sample.hs.json b/dc/.juspay/dc/test/Sample.hs.json new file mode 100644 index 0000000..035b50f --- /dev/null +++ b/dc/.juspay/dc/test/Sample.hs.json @@ -0,0 +1,10 @@ +{ + "allFailuresRecords": [], + "commonErrorFuns": [ + "temp" + ], + "createdFailures": [], + "createdRecords": [], + "updatedFailures": [], + "updatedRecords": [] +} \ No newline at end of file diff --git a/dc/.juspay/domainConfig.yaml b/dc/.juspay/domainConfig.yaml new file mode 100644 index 0000000..b6471f2 --- /dev/null +++ b/dc/.juspay/domainConfig.yaml @@ -0,0 +1,7 @@ +tag: FunctionCheck +contents: + listOfRestrictedFuns: + - "throwExceptionV2" + - "throwErr" + moduleNameToCheck: "Main" + funNameToCheck: "testParentFunction" \ No newline at end of file diff --git a/dc/dc.cabal b/dc/dc.cabal index 77462d1..3b9d21d 100644 --- a/dc/dc.cabal +++ b/dc/dc.cabal @@ -74,6 +74,10 @@ library -- Directories containing source files. hs-source-dirs: src + other-modules: + DC.Constants + DC.Types + -- Base language which the package is written in. default-language: Haskell2010 @@ -102,5 +106,4 @@ test-suite dc-test -- Test dependencies. build-depends: - base ^>=4.16.4.0, dc diff --git a/dc/src/DC/DefaultCheck.hs b/dc/src/DC/DefaultCheck.hs index 0d4a1be..211b0ee 100644 --- a/dc/src/DC/DefaultCheck.hs +++ b/dc/src/DC/DefaultCheck.hs @@ -84,6 +84,7 @@ checkIntegrity opts modSummary tcEnv = do FunctionCheck (FunctionCheckConfig{..}) -> do if moduleName' == moduleNameToCheck then do let exprsC = foldl (\acc (val) -> acc ++ getErrorrs val ) [] exprs + -- liftIO $ print ("Module Name found" ++ moduleNameToCheck ++ " " ++ show exprs ) addErrs $ map (mkGhcCompileError) (exprsC) else do let exprsC = foldl (\acc (val) -> HM.union acc (getFuncs val) ) HM.empty exprs @@ -391,9 +392,12 @@ checkInOtherModsWithoutErrorFuns allPaths checkerCase moduleName' fun@(FunctionI FunctionCheck _ -> if module_name fun == moduleName' || "_in" == module_name fun then pure [] else do + -- print ("Dnct", fun) let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.err.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (prefixPath ++ pos ++ newFileName)) allPaths - let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + -- print ("Dnct", filterNames) + let orgName = if null filterNames then (prefixPath ++ "test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + -- print ("Org", orgName) fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) pure $ either (\_ -> []) (\contents -> maybe [] diff --git a/dc/test/Main.hs b/dc/test/Main.hs index 3e2059e..8e0143a 100644 --- a/dc/test/Main.hs +++ b/dc/test/Main.hs @@ -1,4 +1,13 @@ module Main (main) where +import Sample + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = do + let s = testParentFunction + putStrLn "Test suite not ye implemented." + +testParentFunction :: String +testParentFunction = proxyFunction + + diff --git a/dc/test/Sample.hs b/dc/test/Sample.hs new file mode 100644 index 0000000..304d08a --- /dev/null +++ b/dc/test/Sample.hs @@ -0,0 +1,20 @@ +module Sample where + +testParentFunctionF :: String +testParentFunctionF = "this should not get caught" + +proxyFunction :: String +proxyFunction = case maybeTest of + Left str -> temp + Right str -> "asdfghj" + +maybeTest :: Either String String +maybeTest = Right "test string" + +temp :: String +temp = case maybeTest of + Left str -> "throwErr" + Right str -> throwErr + +throwErr :: String +throwErr = "This should be an error" \ No newline at end of file diff --git a/flake.lock b/flake.lock index a7b5b0b..0c0d92a 100644 --- a/flake.lock +++ b/flake.lock @@ -323,11 +323,11 @@ }, "haskell-flake_3": { "locked": { - "lastModified": 1726441645, - "narHash": "sha256-mXVvqtBqgcDnT2MTJP8eJeQtajKbNrYevPHpoDqKnVQ=", + "lastModified": 1726772832, + "narHash": "sha256-/kSaQVrsZsw5jmvCtRRouXvYDQSdTJ4wzsthIpuXoLQ=", "owner": "srid", "repo": "haskell-flake", - "rev": "96aad3a08f30333fead66da396dbf7a21ac4adb6", + "rev": "31d7f050935f5a543212b7624d245f918ab14275", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 7495fa1..7daf05a 100644 --- a/flake.nix +++ b/flake.nix @@ -61,6 +61,7 @@ settings = { beam-core.jailbreak = true; sheriff.check = false; + dc.check = false; }; devShell = { mkShellArgs = { @@ -110,6 +111,7 @@ # jailbreak = true; # }; sheriff.check = false; + dc.check = false; }; devShell = { From 053c026293665524d6d9c46ad3c17482709a2030 Mon Sep 17 00:00:00 2001 From: Yashasvi Rana Date: Mon, 30 Sep 2024 15:49:05 +0530 Subject: [PATCH 2/3] read prefix path from plugin options, add options for condition check, paths to consider, paths to ignore, modules to ignore in the yaml config file --- dc/.juspay/dc/test/Sample.hs.err.json | 38 +++++- dc/.juspay/dc/test/Sample.hs.json | 3 +- dc/.juspay/dc/test/test/Main.hs.json | 8 ++ dc/.juspay/dc/test/test/Sample.hs.err.json | 46 ++++++++ dc/.juspay/dc/test/test/Sample.hs.json | 11 ++ dc/.juspay/domainConfig.yaml | 11 +- dc/dc.cabal | 6 +- dc/src/DC/Constants.hs | 5 +- dc/src/DC/DefaultCheck.hs | 127 ++++++++++++--------- dc/src/DC/Types.hs | 9 +- dc/test/Sample.hs | 11 +- 11 files changed, 204 insertions(+), 71 deletions(-) create mode 100644 dc/.juspay/dc/test/test/Main.hs.json create mode 100644 dc/.juspay/dc/test/test/Sample.hs.err.json create mode 100644 dc/.juspay/dc/test/test/Sample.hs.json diff --git a/dc/.juspay/dc/test/Sample.hs.err.json b/dc/.juspay/dc/test/Sample.hs.err.json index 83a7c1f..4b61393 100644 --- a/dc/.juspay/dc/test/Sample.hs.err.json +++ b/dc/.juspay/dc/test/Sample.hs.err.json @@ -4,11 +4,43 @@ "error_message": "Should not use exception functions for sync in default cases", "module_name": "", "package_name": "", - "src_span_endC": 13, - "src_span_endl": 8, + "src_span_endC": 14, + "src_span_endl": 9, "src_span_name": "test/Sample.hs", "src_span_startC": 5, - "src_span_startl": 8 + "src_span_startl": 9 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 15, + "src_span_endl": 10, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 10 + } + ], + "temp": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 14, + "src_span_endl": 17, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 17 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 15, + "src_span_endl": 18, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 18 } ] } \ No newline at end of file diff --git a/dc/.juspay/dc/test/Sample.hs.json b/dc/.juspay/dc/test/Sample.hs.json index 035b50f..6684178 100644 --- a/dc/.juspay/dc/test/Sample.hs.json +++ b/dc/.juspay/dc/test/Sample.hs.json @@ -1,7 +1,8 @@ { "allFailuresRecords": [], "commonErrorFuns": [ - "temp" + "temp", + "proxyFunction" ], "createdFailures": [], "createdRecords": [], diff --git a/dc/.juspay/dc/test/test/Main.hs.json b/dc/.juspay/dc/test/test/Main.hs.json new file mode 100644 index 0000000..cdc7c96 --- /dev/null +++ b/dc/.juspay/dc/test/test/Main.hs.json @@ -0,0 +1,8 @@ +{ + "allFailuresRecords": [], + "commonErrorFuns": [], + "createdFailures": [], + "createdRecords": [], + "updatedFailures": [], + "updatedRecords": [] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/test/Sample.hs.err.json b/dc/.juspay/dc/test/test/Sample.hs.err.json new file mode 100644 index 0000000..4b61393 --- /dev/null +++ b/dc/.juspay/dc/test/test/Sample.hs.err.json @@ -0,0 +1,46 @@ +{ + "proxyFunction": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 14, + "src_span_endl": 9, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 9 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 15, + "src_span_endl": 10, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 10 + } + ], + "temp": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 14, + "src_span_endl": 17, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 17 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 15, + "src_span_endl": 18, + "src_span_name": "test/Sample.hs", + "src_span_startC": 5, + "src_span_startl": 18 + } + ] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/test/Sample.hs.json b/dc/.juspay/dc/test/test/Sample.hs.json new file mode 100644 index 0000000..6684178 --- /dev/null +++ b/dc/.juspay/dc/test/test/Sample.hs.json @@ -0,0 +1,11 @@ +{ + "allFailuresRecords": [], + "commonErrorFuns": [ + "temp", + "proxyFunction" + ], + "createdFailures": [], + "createdRecords": [], + "updatedFailures": [], + "updatedRecords": [] +} \ No newline at end of file diff --git a/dc/.juspay/domainConfig.yaml b/dc/.juspay/domainConfig.yaml index b6471f2..2a7de11 100644 --- a/dc/.juspay/domainConfig.yaml +++ b/dc/.juspay/domainConfig.yaml @@ -1,7 +1,14 @@ tag: FunctionCheck contents: listOfRestrictedFuns: - - "throwExceptionV2" + - "defaultInvalidThrowECException" + - "defaultThrowECException" - "throwErr" + - "throwExceptionV2" + - "throwUpstreamGatewayError" moduleNameToCheck: "Main" - funNameToCheck: "testParentFunction" \ No newline at end of file + funNameToCheck: "testParentFunction" + conditionToCheck: [] + pathsToConsider: [] + pathsToIgnore: [] + modulesToIgnore: [] \ No newline at end of file diff --git a/dc/dc.cabal b/dc/dc.cabal index 3b9d21d..e11a1bd 100644 --- a/dc/dc.cabal +++ b/dc/dc.cabal @@ -88,7 +88,7 @@ test-suite dc-test -- Base language which the package is written in. default-language: Haskell2010 - ghc-options: -fplugin=DC.DefaultCheck + ghc-options: -fplugin=DC.DefaultCheck -fplugin-opt=DC.DefaultCheck:{"prefixPath":"./.juspay/dc/test/"} -- Modules included in this executable, other than Main. -- other-modules: @@ -101,9 +101,13 @@ test-suite dc-test -- Directories containing source files. hs-source-dirs: test + other-modules: + Sample + -- The entrypoint to the test suite. main-is: Main.hs -- Test dependencies. build-depends: + base, dc diff --git a/dc/src/DC/Constants.hs b/dc/src/DC/Constants.hs index f453ed8..abd7806 100644 --- a/dc/src/DC/Constants.hs +++ b/dc/src/DC/Constants.hs @@ -14,5 +14,6 @@ defaultCase = "Should not use status as success or failure in default case" syncError :: String syncError = "Should not use exception functions for sync in default cases" -prefixPath :: String -prefixPath = "./.juspay/dc/" \ No newline at end of file +-- taking this from plugin options now +-- prefixPath :: +-- prefixPath = "./.juspay/dc/test/" \ No newline at end of file diff --git a/dc/src/DC/DefaultCheck.hs b/dc/src/DC/DefaultCheck.hs index 211b0ee..35ad4ff 100644 --- a/dc/src/DC/DefaultCheck.hs +++ b/dc/src/DC/DefaultCheck.hs @@ -69,20 +69,29 @@ checkIntegrity opts modSummary tcEnv = do Right conf -> do let path = (intercalate "/" . reverse . tail . reverse . splitOn "/") modulePath liftIO $ createDirectoryIfMissing True path - getAllUpdatesLi <- mapM (loopOverLHsBindLR pathsTobeChecked conf moduleName') (bagToList $ tcg_binds tcEnv) + getAllUpdatesLi <- mapM (loopOverLHsBindLR prefixPath pathsTobeChecked conf moduleName') (bagToList $ tcg_binds tcEnv) let getAllUpdatesList = fst <$> getAllUpdatesLi getAllFuns = HM.unions $ snd <$> getAllUpdatesLi let res = foldl (\(UpdateInfo acc1 acc2 acc3 acc4 acc5 acc6) (UpdateInfo x y z z1 z2 otherFuns) -> UpdateInfo ((acc1) ++ (changeModName moduleName' <$> x)) ((acc2) ++ (changeModName moduleName' <$> y)) ((acc3) ++ (changeModName moduleName' <$> z)) ((acc4) ++ (changeModName moduleName' <$> z1)) ((acc5) ++ (changeModName moduleName' <$> z2)) ((acc6) ++ (changeModName moduleName' <$> otherFuns))) (UpdateInfo [] [] [] [] [] []) $ catMaybes getAllUpdatesList let combination = lookUpAndConcat getAllFuns allRes = getAllRes conf moduleName' combination res liftIO $ B.writeFile (modulePath <> ".json") (encodePretty $ (\(UpdateInfo createRec upRecords upFails cFails allFails otherFuns) -> UpdateInfoAsText (nub $ name <$> createRec) (nub $ name <$> upRecords) (nub $ name <$> upFails) (nub $ name <$> cFails) (nub $ name <$> allFails) (nub $ name <$> otherFuns)) allRes) - !exprs <- mapM (loopOverLHsBindLRTot pathsTobeChecked conf path allRes moduleName') (bagToList $ tcg_binds tcEnv) + !exprs <- mapM (loopOverLHsBindLRTot prefixPath pathsTobeChecked conf path allRes moduleName') (bagToList $ tcg_binds tcEnv) case conf of FieldsCheck _ -> do let exprsC = foldl (\acc (val) -> acc ++ getErrorrs val ) [] exprs addErrs $ map (mkGhcCompileError) (exprsC) FunctionCheck (FunctionCheckConfig{..}) -> do - if moduleName' == moduleNameToCheck then do + if moduleName' `elem` modulesToIgnore then do + liftIO $ B.writeFile (modulePath <> ".err.json") "{}" + liftIO $ B.writeFile (modulePath <> ".json") (encodePretty $ UpdateInfoAsText [] [] [] [] [] []) + else if (not $ null pathsToConsider) && (null $ filter (\pathToConsider -> (prefixPath ++ pathToConsider) `isPrefixOf` path) pathsToConsider) then do + liftIO $ B.writeFile (modulePath <> ".err.json") "{}" + liftIO $ B.writeFile (modulePath <> ".json") (encodePretty $ UpdateInfoAsText [] [] [] [] [] []) + else if (not $ null pathsToIgnore) && (not $ null $ filter (\pathToIgnore -> (prefixPath ++ pathToIgnore) `isPrefixOf` path) pathsToIgnore) then do + liftIO $ B.writeFile (modulePath <> ".err.json") "{}" + liftIO $ B.writeFile (modulePath <> ".json") (encodePretty $ UpdateInfoAsText [] [] [] [] [] []) + else if moduleName' == moduleNameToCheck then do let exprsC = foldl (\acc (val) -> acc ++ getErrorrs val ) [] exprs -- liftIO $ print ("Module Name found" ++ moduleNameToCheck ++ " " ++ show exprs ) addErrs $ map (mkGhcCompileError) (exprsC) @@ -151,8 +160,8 @@ processAllLetPats (L _ _) = do Nothing -loopOverLHsBindLRTot :: [String] -> CheckerConfig -> String -> UpdateInfo -> String -> LHsBindLR GhcTc GhcTc -> TcM ErrorCase -loopOverLHsBindLRTot allPaths conf path allFuns moduleName' vals@(L _ AbsBinds {abs_binds = binds}) = do +loopOverLHsBindLRTot :: String -> [String] -> CheckerConfig -> String -> UpdateInfo -> String -> LHsBindLR GhcTc GhcTc -> TcM ErrorCase +loopOverLHsBindLRTot prefixPath allPaths conf path allFuns moduleName' vals@(L _ AbsBinds {abs_binds = binds}) = do case conf of FunctionCheck (FunctionCheckConfig{..}) -> if moduleName' == moduleNameToCheck @@ -164,34 +173,34 @@ loopOverLHsBindLRTot allPaths conf path allFuns moduleName' vals@(L _ AbsBinds { let allNrFuns = nub $ ((concatMap processExpr binds1)) -- liftIO $ print("ALLFUN", allNrFuns) first <- catMaybes <$> (liftIO $ (mapM ((\x@(FunctionInfo _ _ _ _ _) -> do - nc <- checkInOtherModsWithoutErrorFuns allPaths conf moduleName' x + nc <- checkInOtherModsWithoutErrorFuns prefixPath allPaths conf moduleName' x -- print(nc, x) if null nc then pure Nothing else (pure $ Just $ nc))) (allNrFuns))) pure $ Errors $ concat first else pure $ Errors [] else do let allVals = ((bagToList binds ^? biplateRef :: [LHsExpr GhcTc])) - allFunsWithFailure <- mapM (getFunctionNameIfFailure allPaths conf "" [] "" "" moduleName') (bagToList binds ^? biplateRef) + allFunsWithFailure <- mapM (getFunctionNameIfFailure prefixPath allPaths conf "" [] "" "" moduleName') (bagToList binds ^? biplateRef) let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (bagToList binds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) let funName = map (\y -> transformFromNameStableString y (showSDocUnsafe $ ppr $ getLoc $ vals) False ) (getFunctionName vals) let val = map (\(upType,listY) -> (createUpdateInfo upType $ map (\y -> transformFromNameStableString y (showSDocUnsafe $ ppr $ getLoc $ vals) False) listY)) allFunsWithFailure - allC <- nub <$> (mapM (loopOverModBinds allPaths conf path allLetPats allFuns moduleName' val) allVals) + allC <- nub <$> (mapM (loopOverModBinds prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) let allV = foldl (\acc (val1) -> acc ++ getErrorrs val1 ) [] allC -- liftIO $ print (allC, allV, funName) pure $ if null allV then Functions HM.empty else Functions (foldl (\acc val1 -> HM.insert val1 allV acc) HM.empty (name <$> funName)) FieldsCheck (EnumCheck{..}) -> do let allVals = ((bagToList binds ^? biplateRef :: [LHsExpr GhcTc])) - allFunsWithFailure <- mapM (getFunctionNameIfFailure allPaths conf recordType enumList enumType fieldType moduleName') (bagToList binds ^? biplateRef) + allFunsWithFailure <- mapM (getFunctionNameIfFailure prefixPath allPaths conf recordType enumList enumType fieldType moduleName') (bagToList binds ^? biplateRef) let val = map (\(upType,listY) -> (createUpdateInfo upType $ map (\y -> transformFromNameStableString y (showSDocUnsafe $ ppr $ getLoc $ vals) False) listY)) allFunsWithFailure let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (bagToList binds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) - allC <- nub <$> (mapM (loopOverModBinds allPaths conf path allLetPats allFuns moduleName' val) allVals) + allC <- nub <$> (mapM (loopOverModBinds prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) case conf of FieldsCheck _ -> pure $ Errors $ foldl (\acc (vals1) -> acc ++ getErrorrs vals1 ) [] allC -- FunctionCheck _ -> do -- let allV = foldl (\acc (vals1) -> acc ++ getErrorrs vals1 ) [] allC -- -- liftIO $ print (allC, allV, funName) -- pure $ if null allV then Functions HM.empty else Functions (foldl (\acc vals1 -> HM.insert vals1 allV acc) HM.empty (name <$> funName)) -loopOverLHsBindLRTot _ _ _ _ _ _ = pure $ Errors [] +loopOverLHsBindLRTot _ _ _ _ _ _ _ = pure $ Errors [] createUpdateInfo :: TypeOfUpdate -> [FunctionInfo] -> UpdateInfo createUpdateInfo Update list = UpdateInfo [] list [] [] [] [] @@ -201,12 +210,12 @@ createUpdateInfo UpdateWithFailure list = UpdateInfo [] [] list [] [] [] createUpdateInfo Default list = UpdateInfo [] [] list [] [] [] createUpdateInfo _ _ = UpdateInfo [] [] [] [] [] [] -loopOverModBinds :: [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> LHsExpr GhcTc -> TcM ErrorCase -loopOverModBinds allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList (L _ (HsCase _ _ exprLStmt)) = do +loopOverModBinds :: String -> [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> LHsExpr GhcTc -> TcM ErrorCase +loopOverModBinds prefixPath allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList (L _ (HsCase _ _ exprLStmt)) = do -- liftIO $ print ("val",allFuns) - allFunsPats <- mapM (loopOverPats allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList) $ map unLoc $ unLoc $ mg_alts exprLStmt + allFunsPats <- mapM (loopOverPats prefixPath allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList) $ map unLoc $ unLoc $ mg_alts exprLStmt pure $ Errors $ foldl (\acc (val) -> acc ++ getErrorrs val ) [] allFunsPats -loopOverModBinds _ _ _ _ _ _ _ _ = do +loopOverModBinds _ _ _ _ _ _ _ _ _ = do pure $ Errors [] getAllEnums :: LHsExpr GhcTc -> Maybe String @@ -214,25 +223,25 @@ getAllEnums (L _ (HsConLikeOut _ liter)) = Just $ showSDocUnsafe $ ppr liter getAllEnums (L _ _) = Nothing -loopOverPats :: [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> Match GhcTc (LHsExpr GhcTc) -> TcM ErrorCase -loopOverPats allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleName' allPatsList match = do +loopOverPats :: String -> [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> Match GhcTc (LHsExpr GhcTc) -> TcM ErrorCase +loopOverPats prefixPath allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleName' allPatsList match = do case checkerCase of FieldsCheck (EnumCheck{..}) -> do let normalBinds = (\(GRHS _ _ stmt )-> stmt ) <$> unLoc <$> (grhssGRHSs $ m_grhss match) argBinds = m_pats match checker = any (\x -> isVarPatExprBool x) (normalBinds ^? biplateRef :: [LHsExpr GhcTc] ) if checker then pure $ Errors [] else - let a = any isVarPat argBinds + let a = any (isVarPat ["Nothing", "Left"]) argBinds in if a then do -- liftIO $ (print (showSDocUnsafe $ ppr normalBind, showSDocUnsafe $ ppr normalBinds )) let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (normalBinds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) let allFUnsInside = HM.union allLetPats allFUnsInsid allFuns = concat $ map processExpr (normalBinds ^? biplateRef) check <- mapM (\x -> case HM.lookup (mkStringFromFunctionInfo x) allFUnsInside of - Nothing -> throwErrorRules x allPaths path moduleName' allFunsWithFailure allPatsList + Nothing -> throwErrorRules x prefixPath allPaths path moduleName' allFunsWithFailure allPatsList Just val -> do -- liftIO $ print ("showing " ++ show val) - res <- mapM (\y -> throwErrorRules y allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) + res <- mapM (\y -> throwErrorRules y prefixPath allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) let concatVals = concat $ catMaybes ( res) if null concatVals then pure Nothing else pure $ Just concatVals) (nub allFuns) --anyM (\x -> if module_name x == moduleName' -- then pure $ name x `elem` (name <$> allFunsWithFailure) && module_name x `elem` (module_name <$> allFunsWithFailure) @@ -241,7 +250,7 @@ loopOverPats allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleNam then pure $ Errors $ (\x -> CompileError "" "" x (getLocGhc $ head argBinds)) <$> (catMaybes check) else do processedPats <- mapM (\x -> do - allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError allPaths checkerCase moduleName') x + allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName') x pure $ any (==True) allCHecks) allLetPats let allFailureNames = name <$> (updatedFailurs allFunsWithFailure) let allNeeded = mapMaybe getExprTypeWithName $ normalBinds ^? biplateRef @@ -265,7 +274,7 @@ loopOverPats allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleNam FunctionCheck (FunctionCheckConfig{..}) -> do let normalBinds = (\(GRHS _ _ stmt )-> stmt ) <$> unLoc <$> (grhssGRHSs $ m_grhss match) argBinds = m_pats match - let a = any isVarPat argBinds + let a = any (isVarPat conditionToCheck) argBinds if a then do let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (normalBinds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) let allFUnsInside = HM.union allLetPats allFUnsInsid @@ -273,10 +282,10 @@ loopOverPats allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleNam check <- mapM (\x -> if name x `elem` listOfRestrictedFuns then pure $ Just syncError else do case HM.lookup (mkStringFromFunctionInfo x) allFUnsInside of - Nothing -> throwFunctionErrorRules x allPaths path moduleName' allFunsWithFailure allPatsList + Nothing -> throwFunctionErrorRules x prefixPath allPaths path moduleName' allFunsWithFailure allPatsList Just val -> do -- liftIO $ print ("showing " ++ show val) - res <- mapM (\y -> throwFunctionErrorRules y allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) + res <- mapM (\y -> throwFunctionErrorRules y prefixPath allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) let concatVals = concat $ catMaybes ( res) if null concatVals then pure Nothing else pure $ Just concatVals) (nub allFuns) if ((not $ null (catMaybes check))) @@ -286,19 +295,20 @@ loopOverPats allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleNam throwFunctionErrorRules :: FunctionInfo + -> String -> [String] -> String -> String -> UpdateInfo -> [UpdateInfo] -> TcM (Maybe [Char]) -throwFunctionErrorRules x allPaths path moduleName' (UpdateInfo _ _ _ _ _ otherFuns) _ = do +throwFunctionErrorRules x prefixPath allPaths path moduleName' (UpdateInfo _ _ _ _ _ otherFuns) _ = do -- liftIO $ print ("Checking " ++ name x ++ show x) if module_name x == moduleName' || "_in" == module_name x then pure $ if( name x `elem` (name <$> otherFuns) && module_name x `elem` (module_name <$> otherFuns)) then Just (syncError) else Nothing - else checkInOtherModsFunction allPaths path x + else checkInOtherModsFunction prefixPath allPaths path x getLocGhc :: _ -> SrcSpan getLocGhc val = @@ -310,13 +320,14 @@ getLocGhc val = throwErrorRules :: FunctionInfo + -> String -> [String] -> String -> String -> UpdateInfo -> [UpdateInfo] -> TcM (Maybe [Char]) -throwErrorRules x allPaths path moduleName' (UpdateInfo _ _ upFails cFails _ _) _ = do +throwErrorRules x prefixPath allPaths path moduleName' (UpdateInfo _ _ upFails cFails _ _) _ = do -- liftIO $ print ("Checking " ++ name x ++ show x) if module_name x == moduleName' || "_in" == module_name x then pure $ if( name x `elem` (name <$> cFails) && module_name x `elem` (module_name <$> cFails)) then @@ -329,10 +340,10 @@ throwErrorRules x allPaths path moduleName' (UpdateInfo _ _ upFails cFails _ _) -- || (name x `elem` (concat $ map (\x -> name <$> x) $ updatedFailurs <$> allPatsList)) then -- Just defaultCase else Nothing - else checkInOtherMods allPaths path x + else checkInOtherMods prefixPath allPaths path x -checkInOtherModsFunction :: [String] -> String -> FunctionInfo -> TcM (Maybe String) -checkInOtherModsFunction allPaths path (FunctionInfo _ y z _ _) = do +checkInOtherModsFunction :: String -> [String] -> String -> FunctionInfo -> TcM (Maybe String) +checkInOtherModsFunction prefixPath allPaths path (FunctionInfo _ y z _ _) = do let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (path ++ pos ++ newFileName)) allPaths let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName @@ -344,8 +355,8 @@ checkInOtherModsFunction allPaths path (FunctionInfo _ y z _ _) = do then Just (syncError ++ show (z,otherFuns)) else Nothing) (Aeson.decode contents :: Maybe UpdateInfoAsText)) fileContents -checkInOtherMods :: [String] -> String -> FunctionInfo -> TcM (Maybe String) -checkInOtherMods allPaths path (FunctionInfo _ y z _ _) = do +checkInOtherMods :: String -> [String] -> String -> FunctionInfo -> TcM (Maybe String) +checkInOtherMods prefixPath allPaths path (FunctionInfo _ y z _ _) = do let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (path ++ pos ++ newFileName)) allPaths let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName @@ -359,8 +370,8 @@ checkInOtherMods allPaths path (FunctionInfo _ y z _ _) = do then Just (updateError ++ show (z,upFails)) else Nothing) (Aeson.decode contents :: Maybe UpdateInfoAsText)) fileContents -checkInOtherModsWithoutError :: [String] -> CheckerConfig -> String -> FunctionInfo -> IO Bool -checkInOtherModsWithoutError allPaths checkerCase moduleName' fun@(FunctionInfo _ y z _ _) = do +checkInOtherModsWithoutError :: String -> [String] -> CheckerConfig -> String -> FunctionInfo -> IO Bool +checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName' fun@(FunctionInfo _ y z _ _) = do case checkerCase of FieldsCheck _ -> do if module_name fun == moduleName' || "_in" == module_name fun then pure False @@ -386,8 +397,8 @@ checkInOtherModsWithoutError allPaths checkerCase moduleName' fun@(FunctionInfo z `elem` checkerF) (Aeson.decode contents :: Maybe UpdateInfoAsText)) fileContents -checkInOtherModsWithoutErrorFuns :: [String] -> CheckerConfig -> String -> FunctionInfo -> IO [CompileError] -checkInOtherModsWithoutErrorFuns allPaths checkerCase moduleName' fun@(FunctionInfo _ y z _ _) = do +checkInOtherModsWithoutErrorFuns :: String -> [String] -> CheckerConfig -> String -> FunctionInfo -> IO [CompileError] +checkInOtherModsWithoutErrorFuns prefixPath allPaths checkerCase moduleName' fun@(FunctionInfo _ y z _ _) = do case checkerCase of FunctionCheck _ -> if module_name fun == moduleName' || "_in" == module_name fun then pure [] @@ -396,7 +407,7 @@ checkInOtherModsWithoutErrorFuns allPaths checkerCase moduleName' fun@(FunctionI let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.err.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (prefixPath ++ pos ++ newFileName)) allPaths -- print ("Dnct", filterNames) - let orgName = if null filterNames then (prefixPath ++ "test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + let orgName = if null filterNames then (prefixPath ++ newFileName) else prefixPath ++ head filterNames ++ newFileName -- print ("Org", orgName) fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) pure $ either (\_ -> []) (\contents -> @@ -552,7 +563,7 @@ processExpr (L _ _) = [] isVarPatMatch :: (LMatch GhcTc body) -> Bool isVarPatMatch (L _ match) = let argBinds = m_pats match - in any isVarPat argBinds + in any (isVarPat ["Nothing", "Left"]) argBinds isVarPatExprBool :: LHsExpr GhcTc -> Bool isVarPatExprBool (L _ (HsCase _ _ (MG _ (L _ mg_alts) _))) = @@ -565,11 +576,15 @@ isVarPatExprBool _ = False -- argBinds = m_pats match -- in any isVarPat argBinds -isVarPat :: LPat GhcTc -> Bool -isVarPat (L _ pat) = case pat of +isVarPat :: [String] -> LPat GhcTc -> Bool +isVarPat matchWith (L _ pat) = case pat of VarPat _ (L _ _) -> True WildPat _ -> True - x -> if any (\y -> y `isInfixOf` (showSDocUnsafe $ ppr x)) ["Nothing", "Left"] then True else False + x -> if null matchWith + then True + else if any (\y -> y `isInfixOf` (showSDocUnsafe $ ppr x)) matchWith + then True + else False getExprType :: LHsExpr GhcTc -> Maybe String getExprType (L _ (HsVar _ idT)) = Just $ showSDocUnsafe $ ppr $ idType $ unLoc idT @@ -808,11 +823,11 @@ getFunctionName (L _ (PatBind{})) = [""] getFunctionName (L _ (AbsBinds{abs_binds = binds})) = concatMap getFunctionName $ bagToList binds getFunctionName _ = [] -getFunctionNameIfFailure :: [String] -> CheckerConfig -> String -> [String] -> String -> String -> String -> LHsBindLR GhcTc GhcTc -> TcM (TypeOfUpdate, [String]) +getFunctionNameIfFailure :: String -> [String] -> CheckerConfig -> String -> [String] -> String -> String -> String -> LHsBindLR GhcTc GhcTc -> TcM (TypeOfUpdate, [String]) #if __GLASGOW_HASKELL__ < 900 -getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(FunBind _ idT _ _ _)) = do +getFunctionNameIfFailure prefixPath allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(FunBind _ idT _ _ _)) = do #else -getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(FunBind _ idT _ _)) = do +getFunctionNameIfFailure prefixPath allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(FunBind _ idT _ _)) = do #endif let allValsTypes = mapMaybe getExprType (x ^? biplateRef) let allVals = (map unLoc (x ^? biplateRef :: [LHsExpr GhcTc])) @@ -820,7 +835,7 @@ getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType field processedPats <- mapM (\funInfo -> do if any (\val -> val `elem` enumList) (name <$> funInfo) then pure True else do - allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError allPaths checkerCase moduleName') funInfo + allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName') funInfo pure $ any (==True) allCHecks) allLetPats let allBinds = concat $ mapMaybe loopOverFunBind (x ^? biplateRef :: [LHsBindLR GhcTc GhcTc]) funName = [nameStableString $ getName idT] @@ -839,14 +854,14 @@ getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType field else if any (\val -> isInfixOf val (showSDocUnsafe $ ppr x) ) enumList && (Just enumType) == (lastMaybe (splitOn " " $ replace "->" "" $ showSDocUnsafe $ ppr (lastMaybe allValsTypes))) then (Default, funName) else (NoChange,[]) -getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(VarBind{var_id = var})) = do +getFunctionNameIfFailure prefixPath allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(VarBind{var_id = var})) = do let allValsTypes = mapMaybe getExprType (x ^? biplateRef) let allVals = (map unLoc (x ^? biplateRef :: [LHsExpr GhcTc])) let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (x ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) processedPats <- mapM (\funInfo -> do if any (\val -> val `elem` enumList) (name <$> funInfo) then pure True else do - allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError allPaths checkerCase moduleName') funInfo + allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName') funInfo pure $ any (==True) allCHecks) allLetPats let allBinds = concat $ mapMaybe loopOverFunBind (x ^? biplateRef :: [LHsBindLR GhcTc GhcTc]) funName = [nameStableString $ varName var] @@ -865,14 +880,14 @@ getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType field else if any (\val -> isInfixOf val (showSDocUnsafe $ ppr x) ) enumList && (Just enumType) == (lastMaybe (splitOn " " $ replace "->" "" $ showSDocUnsafe $ ppr (lastMaybe allValsTypes))) then (Default, funName) else (NoChange,[]) -getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(AbsBinds{abs_binds = binds})) = do +getFunctionNameIfFailure prefixPath allPaths checkerCase recordType enumList enumType fieldType moduleName' (L _ x@(AbsBinds{abs_binds = binds})) = do let allValsTypes = mapMaybe getExprType (x ^? biplateRef) let allVals = (map unLoc (bagToList binds ^? biplateRef :: [LHsExpr GhcTc])) let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (bagToList binds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) processedPats <- mapM (\funInfo -> do if any (\val -> val `elem` enumList) (name <$> funInfo) then pure True else do - allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError allPaths checkerCase moduleName') funInfo + allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName') funInfo pure $ any (==True) allCHecks) allLetPats let allBinds = concat $ mapMaybe loopOverFunBind (bagToList binds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]) funName = concatMap getFunctionName $ bagToList binds @@ -894,10 +909,10 @@ getFunctionNameIfFailure allPaths checkerCase recordType enumList enumType field -- pure $ if any (\(x,y) -> y==True) allRecordUpdsAndCreate then (Update, funName) -- else if any (\(x,y) -> x==True) allRecordUpdsAndCreate then (Create, funName) -- else if any (\val -> isInfixOf val (showSDocUnsafe $ ppr x)) enumList && any (\val -> isInfixOf enumType val ) allValsTypes then (Default, funName) else (NoChange,[]) -getFunctionNameIfFailure _ _ _ _ _ _hasFld _ _ = pure $ (NoChange,[]) +getFunctionNameIfFailure _ _ _ _ _ _ _hasFld _ _ = pure $ (NoChange,[]) -loopOverLHsBindLR :: [String] -> CheckerConfig -> String -> LHsBindLR GhcTc GhcTc -> TcM ((Maybe UpdateInfo), (HM.HashMap String [FunctionInfo])) -loopOverLHsBindLR allPaths checkerCase moduleName' x@(L _ AbsBinds {abs_binds = binds1}) = do +loopOverLHsBindLR :: String -> [String] -> CheckerConfig -> String -> LHsBindLR GhcTc GhcTc -> TcM ((Maybe UpdateInfo), (HM.HashMap String [FunctionInfo])) +loopOverLHsBindLR prefixPath allPaths checkerCase moduleName' x@(L _ AbsBinds {abs_binds = binds1}) = do case checkerCase of FieldsCheck (EnumCheck{..}) -> do let binds = ( bagToList binds1 ^? biplateRef) @@ -910,7 +925,7 @@ loopOverLHsBindLR allPaths checkerCase moduleName' x@(L _ AbsBinds {abs_binds = processedPats <- mapM (\(funInfo :: [FunctionInfo]) -> if any (\val -> val `elem` enumList) (name <$> funInfo) then pure True else do - allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError allPaths checkerCase moduleName') funInfo + allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName') funInfo pure $ any (==True) allCHecks) allLetPats allBinds <- liftIO $ concat <$> catMaybes <$> mapM loopOverFunBindM (bagToList binds1 ^? biplateRef :: [LHsBindLR GhcTc GhcTc]) let filteredAllVals = filter processHsCase allVals @@ -960,7 +975,7 @@ loopOverLHsBindLR allPaths checkerCase moduleName' x@(L _ AbsBinds {abs_binds = let fname = name <$> funName first <- liftIO $ (ifM (anyM (\val@(FunctionInfo _ _ y _ _) -> do let fc = ((y `elem` listOfRestrictedFuns)) - nc <- checkInOtherModsWithoutError allPaths checkerCase moduleName' val + nc <- checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName' val pure $ fc || nc) (allNrFuns)) (pure $ Just $ UpdateInfo [] [] [] [] [] funName) (pure Nothing) @@ -969,7 +984,7 @@ loopOverLHsBindLR allPaths checkerCase moduleName' x@(L _ AbsBinds {abs_binds = -- liftIO $ print (allLetPats, showSDocUnsafe $ ppr binds1) -loopOverLHsBindLR _ _ _ _ = pure (Nothing, HM.empty) +loopOverLHsBindLR _ _ _ _ _ = pure (Nothing, HM.empty) processHsCase :: LHsExpr GhcTc -> Bool processHsCase (L _ (HsCase _ _ _)) = True @@ -988,7 +1003,7 @@ getAllNeededFun :: String -> [String] -> String -> String -> Bool -> LHsBindLR getAllNeededFun recordType enumList enumType fieldType _ _ allBinds processedPats match = do let normalBinds = (\(GRHS _ _ stmt )-> stmt ) <$> unLoc <$> (grhssGRHSs $ m_grhss match) argBinds = m_pats match - a = any isVarPat argBinds + a = any (isVarPat ["Nothing", "Left"]) argBinds checker = any (\val -> isVarPatExprBool val) (normalBinds ^? biplateRef :: [LHsExpr GhcTc] ) if checker then pure ([], []) else if a then do diff --git a/dc/src/DC/Types.hs b/dc/src/DC/Types.hs index 923817e..07045fe 100644 --- a/dc/src/DC/Types.hs +++ b/dc/src/DC/Types.hs @@ -14,6 +14,7 @@ import GhcPlugins hiding ((<>)) data PluginOpts = PluginOpts { failOnFileNotFound :: Bool, + prefixPath :: String, domainConfigFile :: String, pathsTobeChecked :: [String] } deriving (Show, Eq) @@ -22,6 +23,7 @@ defaultPluginOpts :: PluginOpts defaultPluginOpts = PluginOpts { failOnFileNotFound = True, + prefixPath = "./.juspay/dc/", domainConfigFile = ".juspay/domainConfig.yaml", pathsTobeChecked = ["euler-x/src","euler-x/src-generated","euler-x/src-extras","euler-api-decider/src", "ecPrelude/src", "ecPrelude/src-generated","ecPrelude/src-extras", "oltp/src", "oltp/src-generated","oltp/src-extras", "dbTypes/src-generated", "src/"] } @@ -30,8 +32,9 @@ instance FromJSON PluginOpts where parseJSON = withObject "PluginOpts" $ \o -> do failOnFileNotFound <- o .:? "failOnFileNotFound" .!= (failOnFileNotFound defaultPluginOpts) domainConfigFile <- o .:? "domainConfigFile" .!= (domainConfigFile defaultPluginOpts) + prefixPath <- o .:? "prefixPath" .!= (prefixPath defaultPluginOpts) pathsTobeChecked <- o .:? "pathsTobeChecked" .!= (pathsTobeChecked defaultPluginOpts) - return PluginOpts {domainConfigFile = domainConfigFile, failOnFileNotFound = failOnFileNotFound, pathsTobeChecked = pathsTobeChecked } + return PluginOpts {domainConfigFile = domainConfigFile, failOnFileNotFound = failOnFileNotFound, prefixPath = prefixPath, pathsTobeChecked = pathsTobeChecked } data EnumCheck = EnumCheck @@ -48,6 +51,10 @@ data FunctionCheckConfig = { listOfRestrictedFuns :: [String] , moduleNameToCheck :: String , funNameToCheck :: String + , conditionToCheck :: [String] -- input empty list to check all conditions + , pathsToConsider :: [String] -- use empty list to consider all paths + , pathsToIgnore :: [String] -- use empty list to ignore no path, pathsToIgnore gets prority over pathsToConsider + , modulesToIgnore :: [String] } deriving (Generic, Show, Eq, Ord) deriving (ToJSON, FromJSON) diff --git a/dc/test/Sample.hs b/dc/test/Sample.hs index 304d08a..cb2a35c 100644 --- a/dc/test/Sample.hs +++ b/dc/test/Sample.hs @@ -1,20 +1,21 @@ module Sample where testParentFunctionF :: String -testParentFunctionF = "this should not get caught" +testParentFunctionF = "this should no get caught" + proxyFunction :: String proxyFunction = case maybeTest of - Left str -> temp - Right str -> "asdfghj" + Left _str -> temp + Right _str -> throwErr maybeTest :: Either String String maybeTest = Right "test string" temp :: String temp = case maybeTest of - Left str -> "throwErr" - Right str -> throwErr + Left _str -> throwErr + Right _str -> throwErr throwErr :: String throwErr = "This should be an error" \ No newline at end of file From f4b3c2a18fc1452ea51e6de3f52d3881c881ffe5 Mon Sep 17 00:00:00 2001 From: Yashasvi Rana Date: Fri, 11 Oct 2024 11:03:46 +0530 Subject: [PATCH 3/3] fix path issues, add non case match patterns, fix ghc928 issue, add more tests --- .../test/IgnorePath/IgnoreModule.hs.err.json | 14 ++ .../IgnoreModule.hs.json} | 3 +- dc/.juspay/dc/test/Main.hs.json | 4 +- .../PathsToConsider/Considered.hs.err.json | 26 +++ .../test/PathsToConsider/Considered.hs.json | 11 ++ .../ConsideredTests.hs.err.json | 14 ++ .../ConsideredTests.hs.json} | 3 +- .../dc/test/RestrictedFuncs.hs.err.json | 1 + .../Main.hs.json => RestrictedFuncs.hs.json} | 0 dc/.juspay/dc/test/Sample.hs.err.json | 46 ----- dc/.juspay/dc/test/TestCases.hs.err.json | 174 ++++++++++++++++++ dc/.juspay/dc/test/TestCases.hs.json | 17 ++ dc/.juspay/dc/test/test/Sample.hs.err.json | 46 ----- dc/.juspay/domainConfig.yaml | 5 +- dc/dc.cabal | 8 +- dc/src/DC/DefaultCheck.hs | 117 ++++++++---- dc/src/DC/Types.hs | 2 +- dc/test/IgnorePath/IgnoreModule.hs | 6 + dc/test/Main.hs | 20 +- dc/test/PathsToConsider/Considered.hs | 10 + dc/test/PathsToConsider/ConsideredTests.hs | 6 + dc/test/RestrictedFuncs.hs | 7 + dc/test/Sample.hs | 21 --- dc/test/TestCases.hs | 61 ++++++ 24 files changed, 457 insertions(+), 165 deletions(-) create mode 100644 dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.err.json rename dc/.juspay/dc/test/{Sample.hs.json => IgnorePath/IgnoreModule.hs.json} (80%) create mode 100644 dc/.juspay/dc/test/PathsToConsider/Considered.hs.err.json create mode 100644 dc/.juspay/dc/test/PathsToConsider/Considered.hs.json create mode 100644 dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.err.json rename dc/.juspay/dc/test/{test/Sample.hs.json => PathsToConsider/ConsideredTests.hs.json} (80%) create mode 100644 dc/.juspay/dc/test/RestrictedFuncs.hs.err.json rename dc/.juspay/dc/test/{test/Main.hs.json => RestrictedFuncs.hs.json} (100%) delete mode 100644 dc/.juspay/dc/test/Sample.hs.err.json create mode 100644 dc/.juspay/dc/test/TestCases.hs.err.json create mode 100644 dc/.juspay/dc/test/TestCases.hs.json delete mode 100644 dc/.juspay/dc/test/test/Sample.hs.err.json create mode 100644 dc/test/IgnorePath/IgnoreModule.hs create mode 100644 dc/test/PathsToConsider/Considered.hs create mode 100644 dc/test/PathsToConsider/ConsideredTests.hs create mode 100644 dc/test/RestrictedFuncs.hs delete mode 100644 dc/test/Sample.hs create mode 100644 dc/test/TestCases.hs diff --git a/dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.err.json b/dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.err.json new file mode 100644 index 0000000..26332ca --- /dev/null +++ b/dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.err.json @@ -0,0 +1,14 @@ +{ + "ignoredFun": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 22, + "src_span_endl": 6, + "src_span_name": "test/IgnorePath/IgnoreModule.hs", + "src_span_startC": 14, + "src_span_startl": 6 + } + ] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/Sample.hs.json b/dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.json similarity index 80% rename from dc/.juspay/dc/test/Sample.hs.json rename to dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.json index 6684178..d801c86 100644 --- a/dc/.juspay/dc/test/Sample.hs.json +++ b/dc/.juspay/dc/test/IgnorePath/IgnoreModule.hs.json @@ -1,8 +1,7 @@ { "allFailuresRecords": [], "commonErrorFuns": [ - "temp", - "proxyFunction" + "ignoredFun" ], "createdFailures": [], "createdRecords": [], diff --git a/dc/.juspay/dc/test/Main.hs.json b/dc/.juspay/dc/test/Main.hs.json index cdc7c96..9adf3d7 100644 --- a/dc/.juspay/dc/test/Main.hs.json +++ b/dc/.juspay/dc/test/Main.hs.json @@ -1,6 +1,8 @@ { "allFailuresRecords": [], - "commonErrorFuns": [], + "commonErrorFuns": [ + "testParentFunction" + ], "createdFailures": [], "createdRecords": [], "updatedFailures": [], diff --git a/dc/.juspay/dc/test/PathsToConsider/Considered.hs.err.json b/dc/.juspay/dc/test/PathsToConsider/Considered.hs.err.json new file mode 100644 index 0000000..b70eb19 --- /dev/null +++ b/dc/.juspay/dc/test/PathsToConsider/Considered.hs.err.json @@ -0,0 +1,26 @@ +{ + "consideredFun": [ + { + "error_message": "Should not use exception functions for sync in default cases(\"consideredFun'\",[\"consideredFun'\"])", + "module_name": "", + "package_name": "", + "src_span_endC": 31, + "src_span_endl": 7, + "src_span_name": "test/PathsToConsider/Considered.hs", + "src_span_startC": 17, + "src_span_startl": 7 + } + ], + "consideredFunOutsideErr": [ + { + "error_message": "Should not use exception functions for sync in default cases(\"simpleReturn\",[\"tempThrowErr\",\"whereClauseCaseLeftErr\",\"whereClauseErr\",\"rightCaseError\",\"leftCaseError\",\"whereClauseCaseRightErr\",\"simpleReturn\",\"ignoredErr\"])", + "module_name": "", + "package_name": "", + "src_span_endC": 39, + "src_span_endl": 10, + "src_span_name": "test/PathsToConsider/Considered.hs", + "src_span_startC": 27, + "src_span_startl": 10 + } + ] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/PathsToConsider/Considered.hs.json b/dc/.juspay/dc/test/PathsToConsider/Considered.hs.json new file mode 100644 index 0000000..b3ca47d --- /dev/null +++ b/dc/.juspay/dc/test/PathsToConsider/Considered.hs.json @@ -0,0 +1,11 @@ +{ + "allFailuresRecords": [], + "commonErrorFuns": [ + "consideredFunOutsideErr", + "consideredFun" + ], + "createdFailures": [], + "createdRecords": [], + "updatedFailures": [], + "updatedRecords": [] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.err.json b/dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.err.json new file mode 100644 index 0000000..583b9c7 --- /dev/null +++ b/dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.err.json @@ -0,0 +1,14 @@ +{ + "consideredFun'": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 26, + "src_span_endl": 6, + "src_span_name": "test/PathsToConsider/ConsideredTests.hs", + "src_span_startC": 18, + "src_span_startl": 6 + } + ] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/test/Sample.hs.json b/dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.json similarity index 80% rename from dc/.juspay/dc/test/test/Sample.hs.json rename to dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.json index 6684178..874b210 100644 --- a/dc/.juspay/dc/test/test/Sample.hs.json +++ b/dc/.juspay/dc/test/PathsToConsider/ConsideredTests.hs.json @@ -1,8 +1,7 @@ { "allFailuresRecords": [], "commonErrorFuns": [ - "temp", - "proxyFunction" + "consideredFun'" ], "createdFailures": [], "createdRecords": [], diff --git a/dc/.juspay/dc/test/RestrictedFuncs.hs.err.json b/dc/.juspay/dc/test/RestrictedFuncs.hs.err.json new file mode 100644 index 0000000..9e26dfe --- /dev/null +++ b/dc/.juspay/dc/test/RestrictedFuncs.hs.err.json @@ -0,0 +1 @@ +{} \ No newline at end of file diff --git a/dc/.juspay/dc/test/test/Main.hs.json b/dc/.juspay/dc/test/RestrictedFuncs.hs.json similarity index 100% rename from dc/.juspay/dc/test/test/Main.hs.json rename to dc/.juspay/dc/test/RestrictedFuncs.hs.json diff --git a/dc/.juspay/dc/test/Sample.hs.err.json b/dc/.juspay/dc/test/Sample.hs.err.json deleted file mode 100644 index 4b61393..0000000 --- a/dc/.juspay/dc/test/Sample.hs.err.json +++ /dev/null @@ -1,46 +0,0 @@ -{ - "proxyFunction": [ - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 14, - "src_span_endl": 9, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 9 - }, - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 15, - "src_span_endl": 10, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 10 - } - ], - "temp": [ - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 14, - "src_span_endl": 17, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 17 - }, - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 15, - "src_span_endl": 18, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 18 - } - ] -} \ No newline at end of file diff --git a/dc/.juspay/dc/test/TestCases.hs.err.json b/dc/.juspay/dc/test/TestCases.hs.err.json new file mode 100644 index 0000000..2d9675a --- /dev/null +++ b/dc/.juspay/dc/test/TestCases.hs.err.json @@ -0,0 +1,174 @@ +{ + "ignoredErr": [ + { + "error_message": "Should not use exception functions for sync in default cases(\"ignoredFun\",[\"ignoredFun\"])", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 9, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 14, + "src_span_startl": 9 + } + ], + "indirectLeftCaseError": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 25, + "src_span_endl": 37, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 25, + "src_span_startl": 35 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 27, + "src_span_endl": 36, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 15, + "src_span_startl": 36 + } + ], + "indirectRightCaseError": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 28, + "src_span_endl": 42, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 26, + "src_span_startl": 40 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 28, + "src_span_endl": 42, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 42 + } + ], + "indirectSimpleReturn": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 36, + "src_span_endl": 32, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 24, + "src_span_startl": 32 + } + ], + "leftCaseError": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 25, + "src_span_endl": 24, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 17, + "src_span_startl": 22 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 23, + "src_span_endl": 23, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 15, + "src_span_startl": 23 + } + ], + "rightCaseError": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 29, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 18, + "src_span_startl": 27 + }, + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 29, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 29 + } + ], + "simpleReturn": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 12, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 12 + } + ], + "tempThrowErr": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 58, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 58 + } + ], + "whereClauseCaseLeftErr": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 55, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 55 + } + ], + "whereClauseCaseRightErr": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 19, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 19 + } + ], + "whereClauseErr": [ + { + "error_message": "Should not use exception functions for sync in default cases", + "module_name": "", + "package_name": "", + "src_span_endC": 24, + "src_span_endl": 48, + "src_span_name": "test/TestCases.hs", + "src_span_startC": 16, + "src_span_startl": 48 + } + ] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/TestCases.hs.json b/dc/.juspay/dc/test/TestCases.hs.json new file mode 100644 index 0000000..489b1a3 --- /dev/null +++ b/dc/.juspay/dc/test/TestCases.hs.json @@ -0,0 +1,17 @@ +{ + "allFailuresRecords": [], + "commonErrorFuns": [ + "tempThrowErr", + "whereClauseCaseLeftErr", + "whereClauseErr", + "rightCaseError", + "leftCaseError", + "whereClauseCaseRightErr", + "simpleReturn", + "ignoredErr" + ], + "createdFailures": [], + "createdRecords": [], + "updatedFailures": [], + "updatedRecords": [] +} \ No newline at end of file diff --git a/dc/.juspay/dc/test/test/Sample.hs.err.json b/dc/.juspay/dc/test/test/Sample.hs.err.json deleted file mode 100644 index 4b61393..0000000 --- a/dc/.juspay/dc/test/test/Sample.hs.err.json +++ /dev/null @@ -1,46 +0,0 @@ -{ - "proxyFunction": [ - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 14, - "src_span_endl": 9, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 9 - }, - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 15, - "src_span_endl": 10, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 10 - } - ], - "temp": [ - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 14, - "src_span_endl": 17, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 17 - }, - { - "error_message": "Should not use exception functions for sync in default cases", - "module_name": "", - "package_name": "", - "src_span_endC": 15, - "src_span_endl": 18, - "src_span_name": "test/Sample.hs", - "src_span_startC": 5, - "src_span_startl": 18 - } - ] -} \ No newline at end of file diff --git a/dc/.juspay/domainConfig.yaml b/dc/.juspay/domainConfig.yaml index 2a7de11..cabf0ce 100644 --- a/dc/.juspay/domainConfig.yaml +++ b/dc/.juspay/domainConfig.yaml @@ -1,11 +1,8 @@ tag: FunctionCheck contents: listOfRestrictedFuns: - - "defaultInvalidThrowECException" - - "defaultThrowECException" - "throwErr" - - "throwExceptionV2" - - "throwUpstreamGatewayError" + - "throwException" moduleNameToCheck: "Main" funNameToCheck: "testParentFunction" conditionToCheck: [] diff --git a/dc/dc.cabal b/dc/dc.cabal index e11a1bd..e084b1f 100644 --- a/dc/dc.cabal +++ b/dc/dc.cabal @@ -88,7 +88,7 @@ test-suite dc-test -- Base language which the package is written in. default-language: Haskell2010 - ghc-options: -fplugin=DC.DefaultCheck -fplugin-opt=DC.DefaultCheck:{"prefixPath":"./.juspay/dc/test/"} + ghc-options: -fplugin=DC.DefaultCheck -fplugin-opt=DC.DefaultCheck:{"prefixPath":"./.juspay/dc/","pathsTobeChecked":["test/"]} -- Modules included in this executable, other than Main. -- other-modules: @@ -102,7 +102,11 @@ test-suite dc-test hs-source-dirs: test other-modules: - Sample + TestCases + RestrictedFuncs + IgnorePath.IgnoreModule + PathsToConsider.Considered + PathsToConsider.ConsideredTests -- The entrypoint to the test suite. main-is: Main.hs diff --git a/dc/src/DC/DefaultCheck.hs b/dc/src/DC/DefaultCheck.hs index 35ad4ff..bf2891b 100644 --- a/dc/src/DC/DefaultCheck.hs +++ b/dc/src/DC/DefaultCheck.hs @@ -4,6 +4,8 @@ {-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TypeFamilies, RecordWildCards, PartialTypeSignatures #-} -- {-# OPTIONS_GHC -ddump-parsed-ast #-} +-- to do : fix if else + module DC.DefaultCheck where import Control.Reference (biplateRef, (^?)) @@ -92,8 +94,9 @@ checkIntegrity opts modSummary tcEnv = do liftIO $ B.writeFile (modulePath <> ".err.json") "{}" liftIO $ B.writeFile (modulePath <> ".json") (encodePretty $ UpdateInfoAsText [] [] [] [] [] []) else if moduleName' == moduleNameToCheck then do + let exprsCt = foldl (\acc (val) -> HM.union acc (getFuncs val) ) HM.empty exprs + liftIO $ B.writeFile (modulePath <> ".err.json") (encodePretty exprsCt) let exprsC = foldl (\acc (val) -> acc ++ getErrorrs val ) [] exprs - -- liftIO $ print ("Module Name found" ++ moduleNameToCheck ++ " " ++ show exprs ) addErrs $ map (mkGhcCompileError) (exprsC) else do let exprsC = foldl (\acc (val) -> HM.union acc (getFuncs val) ) HM.empty exprs @@ -171,7 +174,6 @@ loopOverLHsBindLRTot prefixPath allPaths conf path allFuns moduleName' vals@(L _ if ("$_in$" ++ funNameToCheck) `elem` funName then do -- getTxnStatusFromGateway let binds1 = ( (bagToList binds) ^? biplateRef :: [LHsExpr GhcTc]) let allNrFuns = nub $ ((concatMap processExpr binds1)) - -- liftIO $ print("ALLFUN", allNrFuns) first <- catMaybes <$> (liftIO $ (mapM ((\x@(FunctionInfo _ _ _ _ _) -> do nc <- checkInOtherModsWithoutErrorFuns prefixPath allPaths conf moduleName' x -- print(nc, x) @@ -184,7 +186,9 @@ loopOverLHsBindLRTot prefixPath allPaths conf path allFuns moduleName' vals@(L _ let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (bagToList binds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) let funName = map (\y -> transformFromNameStableString y (showSDocUnsafe $ ppr $ getLoc $ vals) False ) (getFunctionName vals) let val = map (\(upType,listY) -> (createUpdateInfo upType $ map (\y -> transformFromNameStableString y (showSDocUnsafe $ ppr $ getLoc $ vals) False) listY)) allFunsWithFailure - allC <- nub <$> (mapM (loopOverModBinds prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) + allC <- if null conditionToCheck + then nub <$> (mapM (loopOverModBindsAll prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) + else nub <$> (mapM (loopOverModBindsCase prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) let allV = foldl (\acc (val1) -> acc ++ getErrorrs val1 ) [] allC -- liftIO $ print (allC, allV, funName) pure $ if null allV then Functions HM.empty else Functions (foldl (\acc val1 -> HM.insert val1 allV acc) HM.empty (name <$> funName)) @@ -193,7 +197,7 @@ loopOverLHsBindLRTot prefixPath allPaths conf path allFuns moduleName' vals@(L _ allFunsWithFailure <- mapM (getFunctionNameIfFailure prefixPath allPaths conf recordType enumList enumType fieldType moduleName') (bagToList binds ^? biplateRef) let val = map (\(upType,listY) -> (createUpdateInfo upType $ map (\y -> transformFromNameStableString y (showSDocUnsafe $ ppr $ getLoc $ vals) False) listY)) allFunsWithFailure let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (bagToList binds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) - allC <- nub <$> (mapM (loopOverModBinds prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) + allC <- nub <$> (mapM (loopOverModBindsCase prefixPath allPaths conf path allLetPats allFuns moduleName' val) allVals) case conf of FieldsCheck _ -> pure $ Errors $ foldl (\acc (vals1) -> acc ++ getErrorrs vals1 ) [] allC -- FunctionCheck _ -> do @@ -210,14 +214,41 @@ createUpdateInfo UpdateWithFailure list = UpdateInfo [] [] list [] [] [] createUpdateInfo Default list = UpdateInfo [] [] list [] [] [] createUpdateInfo _ _ = UpdateInfo [] [] [] [] [] [] -loopOverModBinds :: String -> [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> LHsExpr GhcTc -> TcM ErrorCase -loopOverModBinds prefixPath allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList (L _ (HsCase _ _ exprLStmt)) = do - -- liftIO $ print ("val",allFuns) +loopOverModBindsCase :: String -> [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> LHsExpr GhcTc -> TcM ErrorCase +loopOverModBindsCase prefixPath allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList (L _ (HsCase _ _ exprLStmt)) = do allFunsPats <- mapM (loopOverPats prefixPath allPaths checkerCase path allFUnsInside allFuns moduleName' allPatsList) $ map unLoc $ unLoc $ mg_alts exprLStmt pure $ Errors $ foldl (\acc (val) -> acc ++ getErrorrs val ) [] allFunsPats -loopOverModBinds _ _ _ _ _ _ _ _ _ = do +loopOverModBindsCase _ _ _ _ _ _ _ _ _ = do pure $ Errors [] +loopOverModBindsAll :: String -> [String] -> CheckerConfig -> String -> HM.HashMap String [FunctionInfo] -> UpdateInfo -> String -> [UpdateInfo] -> LHsExpr GhcTc -> TcM ErrorCase +loopOverModBindsAll prefixPath allPaths checkerCase path allFUnsInsid allFunsWithFailure moduleName' allPatsList x = do + case checkerCase of + FunctionCheck (FunctionCheckConfig{..}) -> do + let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (x ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) + let allFUnsInside = HM.union allLetPats allFUnsInsid + allFuns = concat $ map processExpr (x ^? biplateRef) + check <- mapM + (\x -> do + if name x `elem` listOfRestrictedFuns + then do + pure $ Just syncError + else do + case HM.lookup (mkStringFromFunctionInfo x) allFUnsInside of + Nothing -> do + throwFunctionErrorRules x prefixPath allPaths path moduleName' allFunsWithFailure allPatsList + Just val -> do + res <- mapM (\y -> throwFunctionErrorRules y prefixPath allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) + let concatVals = concat $ catMaybes ( res) + if null concatVals + then pure Nothing + else pure $ Just concatVals) + (nub allFuns) + if ((not $ null (catMaybes check))) + then pure $ Errors $ (\y -> CompileError "" "" y (getLocGhc x)) <$> (catMaybes check) + else pure $ Errors [] + _ -> pure $ Errors [] + getAllEnums :: LHsExpr GhcTc -> Maybe String getAllEnums (L _ (HsConLikeOut _ liter)) = Just $ showSDocUnsafe $ ppr liter getAllEnums (L _ _) = Nothing @@ -275,23 +306,31 @@ loopOverPats prefixPath allPaths checkerCase path allFUnsInsid allFunsWithFailur let normalBinds = (\(GRHS _ _ stmt )-> stmt ) <$> unLoc <$> (grhssGRHSs $ m_grhss match) argBinds = m_pats match let a = any (isVarPat conditionToCheck) argBinds - if a then do + if a + then do let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (normalBinds ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) let allFUnsInside = HM.union allLetPats allFUnsInsid allFuns = concat $ map processExpr (normalBinds ^? biplateRef) - check <- mapM (\x -> if name x `elem` listOfRestrictedFuns then - pure $ Just syncError else do - case HM.lookup (mkStringFromFunctionInfo x) allFUnsInside of - Nothing -> throwFunctionErrorRules x prefixPath allPaths path moduleName' allFunsWithFailure allPatsList - Just val -> do - -- liftIO $ print ("showing " ++ show val) - res <- mapM (\y -> throwFunctionErrorRules y prefixPath allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) - let concatVals = concat $ catMaybes ( res) - if null concatVals then pure Nothing else pure $ Just concatVals) (nub allFuns) + check <- mapM + (\x -> if name x `elem` listOfRestrictedFuns + then do + pure $ Just syncError + else do + case HM.lookup (mkStringFromFunctionInfo x) allFUnsInside of + Nothing -> do + throwFunctionErrorRules x prefixPath allPaths path moduleName' allFunsWithFailure allPatsList + Just val -> do + res <- mapM (\y -> throwFunctionErrorRules y prefixPath allPaths path moduleName' allFunsWithFailure allPatsList) (nub val) + let concatVals = concat $ catMaybes ( res) + if null concatVals + then pure Nothing + else pure $ Just concatVals) + (nub allFuns) if ((not $ null (catMaybes check))) - then pure $ Errors $ (\x -> CompileError "" "" x (getLocGhc $ head argBinds)) <$> (catMaybes check) - else pure $ Errors [] - else pure $ Errors [] + then pure $ Errors $ (\x -> CompileError "" "" x (getLocGhc $ head argBinds)) <$> (catMaybes check) + else pure $ Errors [] + else do + pure $ Errors [] throwFunctionErrorRules :: FunctionInfo @@ -308,7 +347,8 @@ throwFunctionErrorRules x prefixPath allPaths path moduleName' (UpdateInfo _ _ _ pure $ if( name x `elem` (name <$> otherFuns) && module_name x `elem` (module_name <$> otherFuns)) then Just (syncError) else Nothing - else checkInOtherModsFunction prefixPath allPaths path x + else + checkInOtherModsFunction prefixPath allPaths path x getLocGhc :: _ -> SrcSpan getLocGhc val = @@ -344,9 +384,9 @@ throwErrorRules x prefixPath allPaths path moduleName' (UpdateInfo _ _ upFails c checkInOtherModsFunction :: String -> [String] -> String -> FunctionInfo -> TcM (Maybe String) checkInOtherModsFunction prefixPath allPaths path (FunctionInfo _ y z _ _) = do - let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.json" - filterNames <- liftIO $ filterM (\pos -> doesFileExist (path ++ pos ++ newFileName)) allPaths - let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + let newFileName = (intercalate "/" . splitOn "." $ y) ++ ".hs.json" + filterNames <- liftIO $ filterM (\pos -> doesFileExist (prefixPath ++ pos ++ newFileName)) allPaths + let orgName = if null filterNames then (prefixPath ++ newFileName) else prefixPath ++ head filterNames ++ newFileName fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) pure $ either (\_ -> Nothing) (\contents -> maybe Nothing @@ -357,9 +397,9 @@ checkInOtherModsFunction prefixPath allPaths path (FunctionInfo _ y z _ _) = do checkInOtherMods :: String -> [String] -> String -> FunctionInfo -> TcM (Maybe String) checkInOtherMods prefixPath allPaths path (FunctionInfo _ y z _ _) = do - let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.json" + let newFileName = (intercalate "/" . splitOn "." $ y) ++ ".hs.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (path ++ pos ++ newFileName)) allPaths - let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + let orgName = if null filterNames then (prefixPath ++ newFileName) else prefixPath ++ head filterNames ++ newFileName fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) pure $ either (\_ -> Nothing) (\contents -> maybe Nothing @@ -378,18 +418,20 @@ checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName' fun@(Fu else do let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (prefixPath ++ pos ++ newFileName)) allPaths - let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + let orgName = if null filterNames then (prefixPath ++ newFileName) else prefixPath ++ head filterNames ++ newFileName fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) pure $ either (\_ -> False) (\contents -> maybe False (\(UpdateInfoAsText creRecords upRecords upFails cFails defaultF _) -> z `elem` creRecords ++ upRecords ++ upFails ++ cFails ++ defaultF) (Aeson.decode contents :: Maybe UpdateInfoAsText)) fileContents FunctionCheck _ -> - if module_name fun == moduleName' || "_in" == module_name fun then pure False + if module_name fun == moduleName' + then + pure False else do - let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.json" + let newFileName = (intercalate "/" . splitOn "." $ y) ++ ".hs.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (prefixPath ++ pos ++ newFileName)) allPaths - let orgName = if null filterNames then ("test" ++ newFileName) else prefixPath ++ head filterNames ++ newFileName + let orgName = if null filterNames then (prefixPath ++ newFileName) else prefixPath ++ head filterNames ++ newFileName fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) pure $ either (\_ -> False) (\contents -> maybe False @@ -404,9 +446,8 @@ checkInOtherModsWithoutErrorFuns prefixPath allPaths checkerCase moduleName' fun if module_name fun == moduleName' || "_in" == module_name fun then pure [] else do -- print ("Dnct", fun) - let newFileName = "/" ++ (intercalate "/" . splitOn "." $ y) ++ ".hs.err.json" + let newFileName = (intercalate "/" . splitOn "." $ y) ++ ".hs.err.json" filterNames <- liftIO $ filterM (\pos -> doesFileExist (prefixPath ++ pos ++ newFileName)) allPaths - -- print ("Dnct", filterNames) let orgName = if null filterNames then (prefixPath ++ newFileName) else prefixPath ++ head filterNames ++ newFileName -- print ("Org", orgName) fileContents <- liftIO $ (try $ B.readFile orgName :: IO (Either SomeException B.ByteString)) @@ -558,7 +599,10 @@ processExpr x@(L _ (HsConLikeOut _ (RealDataCon liter))) = [FunctionInfo "" "" (showSDocUnsafe $ ppr liter) (showSDocUnsafe $ ppr $ getLoc x) False] processExpr x@(L _ (HsConLikeOut _ (liter))) = [FunctionInfo "" "" (showSDocUnsafe $ ppr liter) (showSDocUnsafe $ ppr $ getLoc x) False] -processExpr (L _ _) = [] +#if __GLASGOW_HASKELL__ >= 900 +processExpr (L _ x@(XExpr ((WrapExpr (HsWrap hsWrapper hsExpr))))) = processExpr (wrapXRec @(GhcTc) hsExpr) +#endif +processExpr _ = [] isVarPatMatch :: (LMatch GhcTc body) -> Bool isVarPatMatch (L _ match) = @@ -833,8 +877,9 @@ getFunctionNameIfFailure prefixPath allPaths checkerCase recordType enumList enu let allVals = (map unLoc (x ^? biplateRef :: [LHsExpr GhcTc])) let allLetPats = HM.fromList $ ((mapMaybe processAllLetPats (x ^? biplateRef :: [LHsBindLR GhcTc GhcTc]))) processedPats <- mapM (\funInfo -> do - if any (\val -> val `elem` enumList) (name <$> funInfo) then pure True - else do + if any (\val -> val `elem` enumList) (name <$> funInfo) + then do pure True + else do allCHecks <- liftIO $ mapM (checkInOtherModsWithoutError prefixPath allPaths checkerCase moduleName') funInfo pure $ any (==True) allCHecks) allLetPats let allBinds = concat $ mapMaybe loopOverFunBind (x ^? biplateRef :: [LHsBindLR GhcTc GhcTc]) diff --git a/dc/src/DC/Types.hs b/dc/src/DC/Types.hs index 07045fe..8c93cc6 100644 --- a/dc/src/DC/Types.hs +++ b/dc/src/DC/Types.hs @@ -25,7 +25,7 @@ defaultPluginOpts = failOnFileNotFound = True, prefixPath = "./.juspay/dc/", domainConfigFile = ".juspay/domainConfig.yaml", - pathsTobeChecked = ["euler-x/src","euler-x/src-generated","euler-x/src-extras","euler-api-decider/src", "ecPrelude/src", "ecPrelude/src-generated","ecPrelude/src-extras", "oltp/src", "oltp/src-generated","oltp/src-extras", "dbTypes/src-generated", "src/"] + pathsTobeChecked = ["src/", "src-generated/"] } instance FromJSON PluginOpts where diff --git a/dc/test/IgnorePath/IgnoreModule.hs b/dc/test/IgnorePath/IgnoreModule.hs new file mode 100644 index 0000000..84f4212 --- /dev/null +++ b/dc/test/IgnorePath/IgnoreModule.hs @@ -0,0 +1,6 @@ +module IgnorePath.IgnoreModule where + +import RestrictedFuncs + +ignoredFun :: String +ignoredFun = throwErr \ No newline at end of file diff --git a/dc/test/Main.hs b/dc/test/Main.hs index 8e0143a..231ccb3 100644 --- a/dc/test/Main.hs +++ b/dc/test/Main.hs @@ -1,6 +1,8 @@ module Main (main) where -import Sample +import TestCases +import RestrictedFuncs +import PathsToConsider.Considered main :: IO () main = do @@ -8,6 +10,16 @@ main = do putStrLn "Test suite not ye implemented." testParentFunction :: String -testParentFunction = proxyFunction - - +testParentFunction = + let + testCase1 = simpleReturn + testCase2 = leftCaseError + testCase3 = rightCaseError + testCase4 = indirectSimpleReturn + testCase5 = indirectLeftCaseError + testCase6 = indirectRightCaseError + testCase7 = whereClauseErr + testCase8 = whereClauseCaseRightErr + testCase9 = ignoredErr + testCase10 = consideredFun + in "Nothing" diff --git a/dc/test/PathsToConsider/Considered.hs b/dc/test/PathsToConsider/Considered.hs new file mode 100644 index 0000000..731ce3a --- /dev/null +++ b/dc/test/PathsToConsider/Considered.hs @@ -0,0 +1,10 @@ +module PathsToConsider.Considered where + +import PathsToConsider.ConsideredTests +import TestCases + +consideredFun :: String +consideredFun = consideredFun' + +consideredFunOutsideErr :: String +consideredFunOutsideErr = simpleReturn diff --git a/dc/test/PathsToConsider/ConsideredTests.hs b/dc/test/PathsToConsider/ConsideredTests.hs new file mode 100644 index 0000000..93c1ef8 --- /dev/null +++ b/dc/test/PathsToConsider/ConsideredTests.hs @@ -0,0 +1,6 @@ +module PathsToConsider.ConsideredTests where + +import RestrictedFuncs + +consideredFun' :: String +consideredFun' = throwErr \ No newline at end of file diff --git a/dc/test/RestrictedFuncs.hs b/dc/test/RestrictedFuncs.hs new file mode 100644 index 0000000..46fff2c --- /dev/null +++ b/dc/test/RestrictedFuncs.hs @@ -0,0 +1,7 @@ +module RestrictedFuncs where + +throwErr :: String +throwErr = "Throw Error" + +throwException :: String +throwException = "Throw Exception" diff --git a/dc/test/Sample.hs b/dc/test/Sample.hs deleted file mode 100644 index cb2a35c..0000000 --- a/dc/test/Sample.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Sample where - -testParentFunctionF :: String -testParentFunctionF = "this should no get caught" - - -proxyFunction :: String -proxyFunction = case maybeTest of - Left _str -> temp - Right _str -> throwErr - -maybeTest :: Either String String -maybeTest = Right "test string" - -temp :: String -temp = case maybeTest of - Left _str -> throwErr - Right _str -> throwErr - -throwErr :: String -throwErr = "This should be an error" \ No newline at end of file diff --git a/dc/test/TestCases.hs b/dc/test/TestCases.hs new file mode 100644 index 0000000..a0edd3e --- /dev/null +++ b/dc/test/TestCases.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -fplugin=DC.DefaultCheck #-} + +module TestCases where + +import RestrictedFuncs +import IgnorePath.IgnoreModule + +ignoredErr :: String +ignoredErr = ignoredFun + +simpleReturn :: String +simpleReturn = throwErr + +whereClauseCaseRightErr :: String +whereClauseCaseRightErr = case eitherValue of + Left _ -> "Nothing" + Right _ -> temp + where + temp = throwErr + +leftCaseError :: String +leftCaseError = case eitherValue of + Left _ -> throwErr + Right _ -> "Nothing" + +rightCaseError :: String +rightCaseError = case eitherValue of + Left _ -> "Nothing" + Right _ -> throwErr + +indirectSimpleReturn :: String +indirectSimpleReturn = tempThrowErr + +indirectLeftCaseError :: String +indirectLeftCaseError = case eitherValue of + Left _ -> tempThrowErr + Right _ -> "Nothing" + +indirectRightCaseError :: String +indirectRightCaseError = case eitherValue of + Left _ -> "Nothing" + Right _ -> tempThrowErr + + +whereClauseErr :: String +whereClauseErr = temp + where + temp = throwErr + +whereClauseCaseLeftErr :: String +whereClauseCaseLeftErr = case eitherValue of + Left _ -> temp + Right _ -> "Nothing" + where + temp = throwErr + +tempThrowErr :: String +tempThrowErr = throwErr + +eitherValue :: (Either String String) +eitherValue = Left "String"