Skip to content

Commit 9438e79

Browse files
TritloTritlo
committed
[Refactor] Represent fixes by locations and swaps
1 parent 9682bdd commit 9438e79

File tree

6 files changed

+130
-12
lines changed

6 files changed

+130
-12
lines changed

‎ghc-synth.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ library synth
2020
Synth.Repair,
2121
Synth.Check,
2222
Synth.Fill,
23+
Synth.Replace,
2324
Synth.Flatten,
2425
Synth.Sanctify,
2526
Synth.Types,

‎src/Main.hs

+3-1
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import Synth.Diff
2020
import Synth.Eval
2121
import Synth.Flatten
2222
import Synth.Repair
23+
import Synth.Replace (replaceExpr)
2324
import Synth.Types
2425
import Synth.Util
2526
import System.CPUTime
@@ -247,7 +248,8 @@ main = do
247248
(t, fixes) <- time $ repair cc tp
248249
putStrLn $ "DONE! (" ++ showTime t ++ ")"
249250
putStrLn "REPAIRS:"
250-
let fbs = map getFixBinds fixes
251+
let newProgs = map (`replaceExpr` progAtTy e_prog e_ty) fixes
252+
fbs = map getFixBinds newProgs
251253
mapM_ (putStrLn . concatMap (colorizeDiff . ppDiff) . snd . applyFixes mod) fbs
252254
putStrLn "SYNTHESIZING..."
253255
memo <- newIORef Map.empty

‎src/Synth/Repair.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -267,7 +267,7 @@ failingProps cc ep@EProb {..} = do
267267
(ps1, ps2) = splitAt (length e_props `div` 2) e_props
268268
concat <$> mapM fp [ps1, ps2]
269269

270-
repair :: CompileConfig -> EProblem -> IO [EExpr]
270+
repair :: CompileConfig -> EProblem -> IO [EFix]
271271
repair cc tp@EProb {..} =
272272
do
273273
let prog_at_ty = progAtTy e_prog e_ty
@@ -348,6 +348,6 @@ repair cc tp@EProb {..} =
348348
let cc' = (cc {hole_lvl = 0, importStmts = checkImports ++ importStmts cc})
349349
compiled_checks <- zip repls <$> compileParsedChecks cc' checks
350350
ran <- mapM (\(rep, c) -> (rep,) <$> runCheck c) compiled_checks
351-
let succesful = filter (\(_, r) -> r == Right True) ran
351+
let successful = filter (\(_, r) -> r == Right True) ran
352352

353-
return $ map (snd . fst) succesful
353+
return $ map (Map.fromList . fst . fst) successful

‎src/Synth/Replace.hs

+102
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,102 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
3+
module Synth.Replace where
4+
5+
import Bag
6+
import Data.Map hiding (map)
7+
import GHC
8+
import Synth.Util
9+
10+
-- Fill the first hole in the expression.
11+
replaceExpr :: Map SrcSpan (HsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
12+
replaceExpr repls (L loc _) | loc `member` repls = L loc (repls ! loc)
13+
replaceExpr repls (L loc (HsApp x l r)) =
14+
L loc $ HsApp x (re l) (re r)
15+
where
16+
re = replaceExpr repls
17+
replaceExpr repls (L loc (HsPar x l)) =
18+
L loc . HsPar x $ replaceExpr repls l
19+
replaceExpr repls (L loc (ExprWithTySig x l t)) =
20+
L loc . flip (ExprWithTySig x) t $ replaceExpr repls l
21+
replaceExpr repls (L loc (HsLet x b e)) =
22+
L loc $ HsLet x (replaceExprLocalBinds repls b) (replaceExpr repls e)
23+
replaceExpr repls (L loc (HsIf x mb c t e)) =
24+
L loc $ HsIf x mb (re c) (re t) (re e)
25+
where
26+
re = replaceExpr repls
27+
replaceExpr repls (L loc (OpApp x c t e)) =
28+
L loc $ OpApp x (re c) (re t) (re e)
29+
where
30+
re = replaceExpr repls
31+
replaceExpr _ e = e
32+
33+
replaceExprLocalBinds :: Map SrcSpan (HsExpr GhcPs) -> LHsLocalBinds GhcPs -> LHsLocalBinds GhcPs
34+
replaceExprLocalBinds repls (L loc (HsValBinds x (ValBinds xv bs sigs))) =
35+
L loc $ HsValBinds x $ ValBinds xv (replaceExprBinds repls bs) sigs
36+
replaceExprLocalBinds _ e = e
37+
38+
replaceExprBinds ::
39+
Map SrcSpan (HsExpr GhcPs) ->
40+
LHsBinds GhcPs ->
41+
LHsBinds GhcPs
42+
replaceExprBinds repls bs =
43+
listToBag $ map (replaceExprBind repls) (bagToList bs)
44+
45+
replaceExprBind ::
46+
Map SrcSpan (HsExpr GhcPs) ->
47+
LHsBindLR GhcPs GhcPs ->
48+
LHsBindLR GhcPs GhcPs
49+
replaceExprBind repls (L loc fb@FunBind {fun_matches = mg@MG {mg_alts = (L locms mtcs)}}) =
50+
L loc (fb {fun_matches = mg {mg_alts = L locms (map (replaceMatch repls) mtcs)}})
51+
replaceExprBind repls (L loc (VarBind x b v k)) =
52+
L loc . flip (VarBind x b) k $ replaceExpr repls v
53+
replaceExprBind _ e = e
54+
55+
replaceMatch ::
56+
Map SrcSpan (HsExpr GhcPs) ->
57+
LMatch GhcPs (LHsExpr GhcPs) ->
58+
LMatch GhcPs (LHsExpr GhcPs)
59+
replaceMatch repls (L loc m@Match {m_grhss = m_grhss}) =
60+
L loc (m {m_grhss = replaceGRHSs repls m_grhss})
61+
replaceMatch _ e = e
62+
63+
replaceGRHSs ::
64+
Map SrcSpan (HsExpr GhcPs) ->
65+
GRHSs GhcPs (LHsExpr GhcPs) ->
66+
GRHSs GhcPs (LHsExpr GhcPs)
67+
replaceGRHSs repls grhss@GRHSs {..} =
68+
grhss
69+
{ grhssGRHSs = map (replaceLGRHS repls) grhssGRHSs,
70+
grhssLocalBinds = replaceExprLocalBinds repls grhssLocalBinds
71+
}
72+
replaceGRHSs _ e = e
73+
74+
replaceLGRHS ::
75+
Map SrcSpan (HsExpr GhcPs) ->
76+
LGRHS GhcPs (LHsExpr GhcPs) ->
77+
LGRHS GhcPs (LHsExpr GhcPs)
78+
replaceLGRHS repls (L l (GRHS x guards e)) =
79+
L l $ GRHS x (map (replaceGStmt repls) guards) (replaceExpr repls e)
80+
replaceLGRHS _ e = e
81+
82+
replaceGStmt ::
83+
Map SrcSpan (HsExpr GhcPs) ->
84+
GuardLStmt GhcPs ->
85+
GuardLStmt GhcPs
86+
replaceGStmt = replaceLStmt
87+
88+
-- TODO: more kinds of statements
89+
replaceLStmt ::
90+
Map SrcSpan (HsExpr GhcPs) ->
91+
LStmt GhcPs (LHsExpr GhcPs) ->
92+
LStmt GhcPs (LHsExpr GhcPs)
93+
replaceLStmt repls (L l (LastStmt x e b s)) =
94+
(\ne -> L l (LastStmt x ne b s)) $ replaceExpr repls e
95+
replaceLStmt repls (L l (BodyStmt x e se1 se2)) =
96+
(\ne -> L l (BodyStmt x ne se1 se2)) $ replaceExpr repls e
97+
-- Guard statements are Bind statements
98+
replaceLStmt repls (L l (BindStmt x p e se1 se2)) =
99+
(\ne -> L l (BindStmt x p ne se1 se2)) $ replaceExpr repls e
100+
replaceLStmt repls (L l (LetStmt x lbs)) =
101+
L l . LetStmt x $ replaceExprLocalBinds repls lbs
102+
replaceLStmt _ e = e

‎src/Synth/Types.hs

+4
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
module Synth.Types where
44

55
import Constraint
6+
import Data.Map (Map)
67
import GHC
78
import Outputable
89
import qualified Outputable as O
@@ -35,6 +36,9 @@ type EType = LHsSigWcType GhcPs
3536

3637
type EExpr = LHsExpr GhcPs
3738

39+
-- A fix is a list of replacements and their locations
40+
type EFix = Map SrcSpan (HsExpr GhcPs)
41+
3842
data EProblem = EProb
3943
{ e_props :: [EProp],
4044
e_ctxt :: EContext,

‎tests/Tests.hs

+17-8
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Synth.Repair
3232
repair,
3333
translate,
3434
)
35+
import Synth.Replace (replaceExpr)
3536
import Synth.Sanctify
3637
import Synth.Types
3738
import Synth.Util
@@ -117,8 +118,10 @@ repairTests =
117118
r_prog = wrong_prog,
118119
r_props = props
119120
}
120-
fixes <- map (trim . showUnsafe) <$> (translate cc rp >>= repair cc)
121-
expected `elem` fixes @? "Expected repair not found in fixes",
121+
tp@EProb {..} <- translate cc rp
122+
fixes <- repair cc tp
123+
let fixProgs = map (`replaceExpr` progAtTy e_prog e_ty) fixes
124+
expected `elem` map (trim . showUnsafe) fixProgs @? "Expected repair not found in fixes",
122125
localOption (mkTimeout 20_000_000) $
123126
testCase "GetExprCands finds important candidates" $ do
124127
let cc =
@@ -512,8 +515,10 @@ moduleTests =
512515
]
513516

514517
(cc', mod, [rp]) <- moduleToProb cc toFix repair_target
515-
fixes <- translate cc' rp >>= repair cc'
516-
let fixDiffs = map (concatMap ppDiff . snd . applyFixes mod . getFixBinds) fixes
518+
tp@EProb {..} <- translate cc' rp
519+
fixes <- repair cc' tp
520+
let fixProgs = map (`replaceExpr` progAtTy e_prog e_ty) fixes
521+
fixDiffs = map (concatMap ppDiff . snd . applyFixes mod . getFixBinds) fixProgs
517522
fixDiffs @?= expected,
518523
localOption (mkTimeout 30_000_000) $
519524
testCase "Repair BrokenModule finds correct target" $ do
@@ -549,8 +554,10 @@ moduleTests =
549554
]
550555
]
551556
(cc', mod, [rp]) <- moduleToProb cc toFix repair_target
552-
fixes <- translate cc' rp >>= repair cc'
553-
let fixDiffs = map (concatMap ppDiff . snd . applyFixes mod . getFixBinds) fixes
557+
tp@EProb {..} <- translate cc' rp
558+
fixes <- repair cc' tp
559+
let fixProgs = map (`replaceExpr` progAtTy e_prog e_ty) fixes
560+
fixDiffs = map (concatMap ppDiff . snd . applyFixes mod . getFixBinds) fixProgs
554561
fixDiffs @?= expected,
555562
localOption (mkTimeout 30_000_000) $
556563
testCase "Repair MagicConstant" $ do
@@ -574,8 +581,10 @@ moduleTests =
574581
]
575582

576583
(cc', mod, [rp]) <- moduleToProb cc toFix repair_target
577-
fixes <- translate cc' rp >>= repair cc'
578-
let fixDiffs = map (concatMap ppDiff . snd . applyFixes mod . getFixBinds) fixes
584+
tp@EProb {..} <- translate cc' rp
585+
fixes <- repair cc' tp
586+
let fixProgs = map (`replaceExpr` progAtTy e_prog e_ty) fixes
587+
fixDiffs = map (concatMap ppDiff . snd . applyFixes mod . getFixBinds) fixProgs
579588
fixDiffs @?= expected
580589
]
581590

0 commit comments

Comments
 (0)