[Minor] Trace correlations now parsed from trace module. Fixes #92

Author: Tritlo

src/Endemic/Check.hs

@@ -69,6 +69,11 @@ baseFun nm val =
     elb :: LHsLocalBinds GhcPs
     elb = noLoc $ EmptyLocalBinds NoExtField
 
+-- | Unpacks a function defined by baseFun
+unFun :: HsBind GhcPs -> Maybe (LHsExpr GhcPs)
+unFun (FunBind _ _ (MG _ ((L _ [L _ (Match _ _ _ (GRHSs _ [L _ (GRHS _ _ ex)] _))])) _) _ _) = Just ex
+unFun _ = Nothing
+
 -- Shorthands for common constructs
 
 -- | Short for "the function"

src/Endemic/Configuration/Types.hs

@@ -415,14 +415,11 @@ data AdditionalConf = AddConf
   { -- | If assumeNoLoops is true, we check the fixes assuming that there
     -- are no loops in the generated code. Beware! Will die with a message
     -- saying Alarm Clock in case there were loops.
-    assumeNoLoops :: Bool,
-    -- | Allow unfound hoes means that we can ignore holes that are not in
-    -- the trace_correlation
-    allowUnfoundHoles :: Bool
+    assumeNoLoops :: Bool
   }
 
 instance Default AdditionalConf where
-  def = AddConf {assumeNoLoops = True, allowUnfoundHoles = True}
+  def = AddConf {assumeNoLoops = True}
 
 -- | The Problem Description is generated at runtime, descriping a particular
 -- program to fix.

src/Endemic/Eval.hs

@@ -42,6 +42,7 @@ import Data.Dynamic (Dynamic, fromDynamic)
 import Data.Function (on)
 import Data.IORef (IORef, newIORef, readIORef)
 import Data.List (groupBy, intercalate, nub, partition, stripPrefix)
+import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe)
 import Data.Set (Set)
@@ -55,7 +56,7 @@ import DynFlags
 import Endemic.Check
 import Endemic.Configuration
 import Endemic.Plugin
-import Endemic.Traversals (flattenExpr)
+import Endemic.Traversals (flattenExpr, sanctifyExpr)
 import Endemic.Types
 import Endemic.Util
 import ErrUtils (ErrMsg (errMsgSeverity), errMsgSpan, pprErrMsgBagWithLoc)
@@ -67,6 +68,7 @@ import GHC.Prim (unsafeCoerce#)
 import GhcPlugins hiding (exprType)
 import Numeric (showHex)
 import PrelNames (toDynName)
+import qualified Pretty as Pretty
 import RnExpr (rnLExpr)
 import StringBuffer (stringToStringBuffer)
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, makeAbsolute, removeDirectory, removeDirectoryRecursive, removeFile)
@@ -649,44 +651,6 @@ moduleToProb baseCC@CompConf {tempDirBase = baseTempDir, ..} mod_path mb_target
     --           _ -> int_prob
     return (cc', tc_modul, int_prob)
 
--- Create a fake base loc for a trace.
-fakeBaseLoc :: CompileConfig -> EProblem -> EProgFix -> Ghc SrcSpan
-fakeBaseLoc cc prob (fix : _) = getLoc . head <$> buildTraceCorrelExpr cc prob fix
-fakeBaseLoc cc prob [] = error "Cannot construct base loc for empty prog!"
-
--- When we do the trace, we use a "fake_target" function. This build the
--- corresponding expression,
-buildTraceCorrelExpr :: CompileConfig -> EProblem -> EExpr -> Ghc [LHsExpr GhcPs]
-buildTraceCorrelExpr cc EProb {..} expr = do
-  let correl =
-        map (\(nm, _, _) -> baseFun (mkVarUnqual $ fsLit $ "fake_target_" ++ rdrNamePrint nm) expr) e_prog
-      correl_ctxts :: [LHsLocalBinds GhcPs]
-      correl_ctxts = map (\c -> noLoc $ HsValBinds NoExtField (ValBinds NoExtField (unitBag c) [])) correl
-      correl_exprs :: [LHsExpr GhcPs]
-      correl_exprs = map (\ctxt -> noLoc $ HsLet NoExtField ctxt (noLoc hole)) correl_ctxts
-
-  pcorrels <- mapM (parseExprNoInit . showUnsafe) correl_exprs
-  let getBod (L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ bg _))) _))
-        | [L _ FunBind {fun_matches = MG {mg_alts = (L _ alts)}}] <- bagToList bg,
-          [L _ Match {m_grhss = GRHSs {grhssGRHSs = [L _ (GRHS _ _ bod)]}}] <- alts =
-          Just bod
-      getBod _ = Nothing
-  return $ mapMaybe getBod pcorrels
-buildTraceCorrelExpr _ _ _ = error "External fixes not supported!"
-
--- We build a Map from the traced expression and to the  original so we can
--- correlate the trace information with the expression we're checking.
--- This helps e.g. to find placements of changed elements (in our fixes) to the original position.
-buildTraceCorrel :: CompileConfig -> EProblem -> EExpr -> Ghc [Map.Map SrcSpan SrcSpan]
-buildTraceCorrel cc prob expr = do
-  map toCorrel <$> buildTraceCorrelExpr cc prob expr
-  where
-    expr_exprs = flattenExpr expr
-    toCorrel trace_expr = Map.fromList $ filter (\(e, b) -> isGoodSrcSpan e && isGoodSrcSpan b) locPairs
-      where
-        trace_exprs = flattenExpr trace_expr
-        locPairs = zipWith (\t e -> (getLoc t, getLoc e)) trace_exprs expr_exprs
-
 -- | Runs a GHC action and cleans up any hpc-directories that might have been
 -- created as a side-effect.
 -- TODO: Does this slow things down massively? We lose out on the pre-generated
@@ -762,12 +726,22 @@ traceTarget ::
   EProp ->
   [RExpr] ->
   IO (Maybe TraceRes)
-traceTarget cc tp e fp ce = head <$> (traceTargets cc tp e [(fp, ce)])
+traceTarget cc tp e fp ce = head <$> traceTargets cc tp e [(fp, ce)]
 
-toInvokes :: Trace -> Map.Map SrcSpan Integer
-toInvokes res = Map.fromList $ map only_max $ flatten res
+toInvokes :: Trace -> Map.Map (EExpr, SrcSpan) Integer
+toInvokes (ex, res) = Map.fromList $ mapMaybe only_max $ flatten res
   where
-    only_max (src, r) = (mkInteractive src, maximum $ map snd r)
+    only_max :: (SrcSpan, [(BoxLabel, Integer)]) -> Maybe ((EExpr, SrcSpan), Integer)
+    -- TODO: What does it mean if there are multiple labels here?
+    only_max (src, xs)
+      | xboxes <- filter isXBox xs,
+        not (null xboxes),
+        s <- maximum (map snd xboxes) =
+        Just ((ex, src), s)
+      where
+        isXBox (ExpBox _, _) = True
+        isXBox _ = False
+    only_max _ = Nothing
 
 -- Run HPC to get the trace information.
 traceTargets ::
@@ -779,19 +753,13 @@ traceTargets ::
 traceTargets _ _ _ [] = return []
 -- Note: we call runGhc' here directly, since we want every trace to be a
 -- new ghc thread (since we set the dynflags per module)
-traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
+traceTargets cc@CompConf {..} tp@EProb {..} exprs ps_w_ce =
   runGhc' cc $ do
     seed <- liftIO newSeed
-    let traceHash = flip showHex "" $ abs $ hashString $ showSDocUnsafe $ ppr (exprs', ps_w_ce, seed)
+    let traceHash = flip showHex "" $ abs $ hashString $ showSDocUnsafe $ ppr (exprs, ps_w_ce, seed)
         tempDir = tempDirBase </> "trace" </> traceHash
         the_f = tempDir </> ("FakeTraceTarget" ++ traceHash) <.> "hs"
     liftIO $ createDirectoryIfMissing True tempDir
-    (exprs, realSpan) <- case exprs' of
-      ((L (RealSrcSpan realSpan) _) : _) -> return (exprs', realSpan)
-      _ -> do
-        ~tl@(RealSrcSpan rsp) <- fakeBaseLoc cc tp exprs'
-        let exprs = map (L tl . unLoc) exprs'
-        return (exprs, rsp)
     let correl =
           zipWith
             ( \(nm, _, _) e ->
@@ -801,33 +769,11 @@ traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
             e_prog
             exprs
         fake_target_names = Set.fromList $ map (\(n, _, _) -> n) correl
-        toDom :: (TixModule, Mix) -> [MixEntryDom [(BoxLabel, Integer)]]
-        toDom (TixModule _ _ _ ts, Mix _ _ _ _ es) =
-          createMixEntryDom $ zipWith (\t (pos, bl) -> (pos, (bl, t))) ts es
-        isTarget Node {rootLabel = (_, [(TopLevelBox [ftn], _)])} =
-          ftn `Set.member` fake_target_names
-        isTarget _ = False
-        -- We convert the HpcPos to the equivalent span we would get if we'd
-        -- parsed and compiled the expression directly.
-        toFakeSpan :: FilePath -> HpcPos -> HpcPos -> SrcSpan
-        toFakeSpan the_f root sp = mkSrcSpan start end
-          where
-            fname = fsLit $ takeFileName the_f
-            (_, _, rel, rec) = fromHpcPos root
-            eloff = rel - srcSpanEndLine realSpan
-            ecoff = rec - srcSpanEndCol realSpan
-            (sl, sc, el, ec) = fromHpcPos sp
-            -- We add two spaces before every line in the source.
-            start = mkSrcLoc fname (sl - eloff) (sc - ecoff -1)
-            -- GHC Srcs end one after the end
-            end = mkSrcLoc fname (el - eloff) (ec - ecoff)
         mname = filter isAlphaNum $ dropExtension $ takeFileName the_f
         modTxt = exprToTraceModule cc tp seed mname correl ps_w_ce
         exeName = dropExtension the_f
         mixFilePath = tempDir
-        timeoutVal = fromIntegral timeout
 
-    liftIO $ logStr DEBUG modTxt
     liftIO $ writeFile the_f modTxt
     _ <- liftIO $ mapM (logStr DEBUG) $ lines modTxt
     -- We set the module as the main module, which makes GHC generate
@@ -858,6 +804,18 @@ traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
 
     _ <- load (LoadUpTo target_name)
 
+    modul@ParsedModule {pm_parsed_source = (L _ HsModule {..})} <-
+      getModSummary target_name >>= parseModule
+    -- Retrieves the Values declared in the given Haskell-Module
+    let our_targets :: Map String (LHsExpr GhcPs)
+        our_targets = Map.fromList $ mapMaybe fromValD hsmodDecls
+          where
+            fromValD (L l (ValD _ b@FunBind {..}))
+              | rdrNameToStr (unLoc fun_id) `elem` fake_target_names,
+                Just ex <- unFun b =
+                Just (rdrNameToStr $ unLoc fun_id, ex)
+            fromValD _ = Nothing
+
     -- We should for here in case it doesn't terminate, and modify
     -- the run function so that it use the trace reflect functionality
     -- to timeout and dump the tix file if possible.
@@ -908,21 +866,40 @@ traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
           -- TODO: When run in parallel, this can fail
           let rm m = (m,) <$> readMix [mixFilePath] (Right m)
               isTargetMod = (mname ==) . tixModuleName
+              toDom :: (TixModule, Mix) -> [MixEntryDom [(BoxLabel, Integer)]]
+              toDom (TixModule _ _ _ ts, Mix _ _ _ _ es) =
+                createMixEntryDom $ zipWith (\t (pos, bl) -> (pos, (bl, t))) ts es
+
+              nd n@Node {rootLabel = (root, _)} =
+                fmap (Data.Bifunctor.first (toSpan the_f)) n
+              wTarget n@Node {rootLabel = (_, [(TopLevelBox [ftn], _)])} =
+                (,nd n) <$> our_targets Map.!? ftn
+              wTarget _ = Nothing
+              -- We convert the HpcPos to the equivalent span we would get if we'd
+              -- parsed and compiled the expression directly.
+              toSpan :: FilePath -> HpcPos -> SrcSpan
+              toSpan the_f sp = mkSrcSpan start end
+                where
+                  fname = fsLit the_f
+                  (sl, sc, el, ec) = fromHpcPos sp
+                  -- We add two spaces before every line in the source.
+                  start = mkSrcLoc fname sl sc
+                  end = mkSrcLoc fname el (ec + 1)
           case tix of
             Just (Tix mods) -> do
               -- We throw away any extra functions in the file, such as
               -- the properties and the main function, and only look at
               -- the ticks for our expression
               let fake_only = filter isTargetMod mods
-                  nd n@Node {rootLabel = (root, _)} =
-                    fmap (Data.Bifunctor.first (toFakeSpan the_f root)) n
-              res <- map nd . filter isTarget . concatMap toDom <$> mapM rm fake_only
+              res <- mapMaybe wTarget . concatMap toDom <$> mapM rm fake_only
               return $ Just res
             _ -> return Nothing
 
     res <- liftIO $ mapM (runTrace . fst) $ zip [0 ..] ps_w_ce
     cleanupAfterLoads tempDir mname dynFlags
     return res
+  where
+    timeoutVal = fromIntegral timeout
 traceTargets _ _ [] _ = error "No fix!"
 traceTargets _ ExProb {} _ _ = error "Exprobs not supported!"
 

src/Endemic/Repair.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -40,6 +41,7 @@ import Data.Char (isAlphaNum)
 import Data.Default
 import Data.Dynamic (fromDyn)
 import Data.Either (lefts, rights)
+import Data.Foldable (find)
 import Data.Function (on)
 import Data.Functor (($>), (<&>))
 import qualified Data.Functor
@@ -428,7 +430,7 @@ findEvaluatedHoles
             resolve = map $ (expr_map IntMap.!) *** map (first (eprop_map Map.!))
 
     -- traces that worked are all non-empty traces that are sufficiently mapped to exprs and props
-    traces_that_worked <-
+    traces_that_worked :: [(EExpr, Map (EExpr, SrcSpan) Integer)] <-
       liftIO $
         map (second (Map.unionsWith (+) . map (toInvokes . snd)))
           -- The traces are per prop per expr, but we need a per expr per prop,
@@ -445,26 +447,21 @@ findEvaluatedHoles
     -- We then remove suggested holes that are unlikely to help (naively for now
     -- in the sense that we remove only holes which did not get evaluated at all,
     -- so they are definitely not going to matter).
-    let fk (expr, invokes) | non_zero <- Map.keysSet (Map.filter (> 0) invokes),
-                             not (null non_zero) = do
-          liftIO $ logStr DEBUG "Building trace correlation..."
-          trace_correls_per_target <- buildTraceCorrel cc tp expr
-
-          let non_zero_src = Set.unions $ Set.map lookupInCorrel non_zero
-              lookupInCorrel el =
-                case mapMaybe (Map.lookup el) trace_correls_per_target of
-                  -- TODO: This should never happen
-                  [] ->
-                    if allowUnfoundHoles
-                      then Set.empty
-                      else error "Shouldn't happen!"
-                  xs -> Set.fromList xs
-          return $ filter ((`Set.member` non_zero_src) . fst) $ sanctifyExpr expr
-        fk _ = return []
-        nubOrd = Set.toList . Set.fromList
-    non_zero_holes <- mapM fk traces_that_worked
+    let fk :: (EExpr, Map (EExpr, SrcSpan) Integer) -> Set.Set (SrcSpan, LHsExpr GhcPs)
+        fk (expr, invokes)
+          | non_zero <- Map.keysSet (Map.filter (> 0) invokes),
+            not (null non_zero) =
+            Set.map toExprHole non_zero
+          where
+            sfe = sanctifyExpr expr
+            toExprHole (iv_expr, iv_loc) =
+              case find ((== iv_loc) . fst . snd) (zip sfe (sanctifyExpr iv_expr)) of
+                Just r -> fst r
+                _ -> error "SHOULND'T HAPPEN"
+        fk _ = Set.empty
+        non_zero_holes = Set.unions $ map fk traces_that_worked
     -- nubOrd deduplicates collections of sortable items. it's faster than other dedups.
-    let nzh = nubOrd $ concat non_zero_holes
+    let nzh = Set.toList non_zero_holes
     liftIO $ logStr DEBUG $ "Found " ++ show (length nzh) ++ " evaluated holes"
     return nzh
 findEvaluatedHoles _ = error "Cannot find evaluated holes of external problems yet!"

src/Endemic/Types.hs

@@ -79,7 +79,7 @@ isFixed :: TestSuiteResult -> Bool
 isFixed (Right x) = x
 isFixed (Left xs) = and xs
 
-type Trace = Tree (SrcSpan, [(BoxLabel, Integer)])
+type Trace = (LHsExpr GhcPs, Tree (SrcSpan, [(BoxLabel, Integer)]))
 
 type TraceRes = [Trace]
 

src/Endemic/Util.hs

@@ -379,8 +379,8 @@ propToName :: EProp -> String
 propToName (L _ FunBind {..}) = rdrNameToStr $ unLoc fun_id
 propToName _ = error "Non-prop passed to propToName!"
 
-traceOutMsg :: Outputable p => String -> p -> p
-traceOutMsg msg a = trace (msg ++ " { " ++ showSDocUnsafe (ppr a) ++ " } ") a
+traceOutId :: Outputable p => String -> p -> p
+traceOutId msg a = trace (msg ++ " { " ++ showSDocUnsafe (ppr a) ++ " } ") a
 
 traceOut :: Outputable p => String -> p -> a -> a
 traceOut msg a = trace (msg ++ " { " ++ showSDocUnsafe (ppr a) ++ " } ")

tests/SlowTests.hs

@@ -22,7 +22,8 @@ import Endemic.Search.Exhaustive
 import Endemic.Search.PseudoGenetic (pseudoGeneticRepair)
 import Endemic.Traversals
 import Endemic.Types
-import Endemic.Util (logStr, withLogLevel)
+import Endemic.Util (logStr, traceOut, traceOutId, withLogLevel)
+import GhcPlugins (text)
 import Test.Tasty
 import Test.Tasty.ExpectedFailure
 import Test.Tasty.HUnit
@@ -166,13 +167,12 @@ specialTests =
         60_000_000
         "Issue 87 w/o function fits"
         "tests/cases/Issue87.hs",
-      expectFail $
-        mkRepairTest
-          tESTCONF
-          (runGenRepair . \desc -> desc {addConf = (addConf desc) {allowUnfoundHoles = False}})
-          60_000_000
-          "Issue 92"
-          "tests/cases/BrokenModule.hs"
+      mkRepairTest
+        tESTCONF
+        runGenRepair
+        60_000_000
+        "Issue 92"
+        "tests/cases/BrokenModule.hs"
     ]
 
 refinementTests :: TestTree

tests/Tests.hs

@@ -344,10 +344,10 @@ traceTests =
           [failed_prop] <- failingProps cc tp
           Just counter_example <- propCounterExample cc tp failed_prop
           let eprog_fix = eProgToEProgFix e_prog
-          Just [Node {subForest = [tree@Node {rootLabel = (tl, tname)}]}] <-
+          Just [(texp, Node {subForest = [tree@Node {rootLabel = (tl, tname)}]})] <-
             traceTarget cc tp eprog_fix failed_prop counter_example
           expr <- runJustParseExpr cc wrong_prog
-          getLoc expr @?= mkInteractive tl
+          showUnsafe expr @?= showUnsafe texp
           all ((== 1) . snd) (concatMap snd $ flatten tree) @? "All subexpressions should be touched only once!",
       localOption (mkTimeout 30_000_000) $
         testCase "Trace finds loop" $ do
@@ -382,12 +382,10 @@ traceTests =
           let [(_, e_ty, e_prog')] = e_prog
               prog_at_ty = progAtTy e_prog' e_ty
               eprog_fix = eProgToEProgFix $ applyFixToEProg e_prog mempty
-          [tcorrel] <- runGhc' cc $ buildTraceCorrel cc tp prog_at_ty
-          Just [res] <- traceTarget cc tp eprog_fix failed_prop counter_example_args
-          let eMap = Map.fromList $ map (getLoc &&& showUnsafe) $ flattenExpr prog_at_ty
-              chain l = tcorrel Map.!? l >>= (eMap Map.!?)
-              trc = map (\(s, r) -> (chain $ mkInteractive s, r, maximum $ map snd r)) $ flatten res
-              isXbox (ExpBox _) = True
+          Just [(texp, res)] <- traceTarget cc tp eprog_fix failed_prop counter_example_args
+          let eMap = Map.fromList $ map (getLoc &&& showUnsafe) $ flattenExpr texp
+              trc = map (\(s, r) -> (eMap Map.!? s, r, maximum $ map snd r)) $ flatten res
+              isXBox (ExpBox _) = True
               isXBox _ = False
               isInEMapOrNotExpBox (Just _, _, _) = True
               isInEMapOrNotExpBox (_, r, _) = not (any (isXBox . fst) r)