Skip to content

Commit 9a55a8d

Browse files
authored
Fix a bug in tactics preventing split of split (#520)
The `auto` tactic attempts to prune unhelpful branches in order to avoid an exponential blowup of search space. On one these optimizations is to not build a data constructor if it doesn't result in new types to solve. For example, we're trying to avoid the following pathological example: ```haskell data Tree a = Leaf a | Branch (Tree a) (Tree a) -- given the following hole: pureTree :: a -> Tree a pureTree a = _ -- we DO NOT want to fill it with pureTree a = Branch _ _ ``` The reasoning here is that both goals in `Branch _ _` have type `Tree a`, which is already the type we're trying to solve, so introducing `Branch` doesn't make any progress. This check is performed in the `splitAuto` tactic, but I got it backwards and it wasn't explicitly tested for. The only code which hit it was `pure @[]` --- but because `[]` doesn't have any subgoals, this hit a vacuous case and flipped the result of the bad logic. Two wrongs made a hard to find bug. This PR: 1. Fixes the reversed logic in `splitAuto` 2. Has a special case for nullary data constructors, fixing the bug cause by vacuousness. 3. Adds property tests ensuring we can `auto` our way through any permutation of a tuple (which is where we originally noticed the bug) 4. Prevents `unsafeRender` from crashing when `unsafeGlobalDynFlags` is unset, such as during testing. 5. Moves tactic solution tracing into the plugin, so it won't run during tests.
1 parent de4e387 commit 9a55a8d

File tree

13 files changed

+151
-16
lines changed

13 files changed

+151
-16
lines changed

.circleci/config.yml

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,15 @@ defaults: &defaults
7272
command: stack --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs --test-arguments="-j1"
7373
no_output_timeout: 120m
7474

75+
- run:
76+
name: Test hls-tactics-plugin
77+
# Tasty by default will run all the tests in parallel. Which should
78+
# work ok, but given that these CircleCI runners aren't the beefiest
79+
# machine can cause some flakiness. So pass -j1 to Tasty (NOT Stack) to
80+
# tell it to go slow and steady.
81+
command: stack --stack-yaml=${STACK_FILE} test hls-tactics-plugin:test:tests --dump-logs --test-arguments="-j1"
82+
no_output_timeout: 30m
83+
7584
- store_test_results:
7685
path: test-results
7786

hie.yaml.stack

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,9 +21,13 @@ cradle:
2121

2222
- path: "./plugins/default/src"
2323
component: "haskell-language-server:exe:haskell-language-server"
24+
2425
- path: "./plugins/tactics/src"
2526
component: "hls-tactics-plugin:lib:hls-tactics-plugin"
2627

28+
- path: "./plugins/tactics/test"
29+
component: "hls-tactics-plugin:test:tests"
30+
2731
- path: "./exe/Arguments.hs"
2832
component: "haskell-language-server:exe:haskell-language-server"
2933

plugins/tactics/hls-tactics-plugin.cabal

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,28 @@ library
7575
, syb
7676
, text
7777
, transformers
78+
, deepseq
7879

7980
default-language: Haskell2010
8081

82+
test-suite tests
83+
type: exitcode-stdio-1.0
84+
main-is: Main.hs
85+
other-modules:
86+
AutoTupleSpec
87+
hs-source-dirs:
88+
test
89+
ghc-options: -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
90+
build-depends:
91+
QuickCheck
92+
, base
93+
, checkers
94+
, hspec
95+
, mtl
96+
, hls-tactics-plugin
97+
, hls-plugin-api
98+
, hie-bios
99+
, ghc
100+
, containers
101+
default-language: Haskell2010
102+

plugins/tactics/src/Ide/Plugin/Tactic.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -296,8 +296,9 @@ tacticCmd tac lf state (TacticParams uri range var_name)
296296
pure $ (, Nothing)
297297
$ Left
298298
$ ResponseError InvalidRequest (T.pack $ show err) Nothing
299-
Right (_, ext) -> do
300-
let g = graft (RealSrcSpan span) ext
299+
Right rtr -> do
300+
traceMX "solns" $ rtr_other_solns rtr
301+
let g = graft (RealSrcSpan span) $ rtr_extract rtr
301302
response = transform dflags (clientCapabilities lf) uri g pm
302303
pure $ case response of
303304
Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res))

plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs

Lines changed: 24 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,7 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE TypeApplications #-}
4+
15
module Ide.Plugin.Tactic.Debug
26
( unsafeRender
37
, unsafeRender'
@@ -9,17 +13,36 @@ module Ide.Plugin.Tactic.Debug
913
, traceMX
1014
) where
1115

16+
import Control.DeepSeq
17+
import Control.Exception
1218
import Debug.Trace
1319
import DynFlags (unsafeGlobalDynFlags)
1420
import Outputable hiding ((<>))
21+
import System.IO.Unsafe (unsafePerformIO)
22+
23+
#if __GLASGOW_HASKELL__ >= 808
24+
import PlainPanic (PlainGhcException)
25+
type GHC_EXCEPTION = PlainGhcException
26+
#else
27+
import Panic (GhcException)
28+
type GHC_EXCEPTION = GhcException
29+
#endif
30+
1531

1632
------------------------------------------------------------------------------
1733
-- | Print something
1834
unsafeRender :: Outputable a => a -> String
1935
unsafeRender = unsafeRender' . ppr
2036

37+
2138
unsafeRender' :: SDoc -> String
22-
unsafeRender' = showSDoc unsafeGlobalDynFlags
39+
unsafeRender' sdoc = unsafePerformIO $ do
40+
let z = showSDoc unsafeGlobalDynFlags sdoc
41+
-- We might not have unsafeGlobalDynFlags (like during testing), in which
42+
-- case GHC panics. Instead of crashing, let's just fail to print.
43+
!res <- try @GHC_EXCEPTION $ evaluate $ deepseq z z
44+
pure $ either (const "<unsafeRender'>") id res
45+
{-# NOINLINE unsafeRender' #-}
2346

2447
traceMX :: (Monad m, Show a) => String -> a -> m ()
2548
traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a

plugins/tactics/src/Ide/Plugin/Tactic/Machinery.hs

Lines changed: 9 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,7 @@ runTactic
6363
:: Context
6464
-> Judgement
6565
-> TacticsM () -- ^ Tactic to use
66-
-> Either [TacticError] (Trace, LHsExpr GhcPs)
66+
-> Either [TacticError] RunTacticResults
6767
runTactic ctx jdg t =
6868
let skolems = tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg
6969
tacticState = defaultTacticState { ts_skolems = skolems }
@@ -73,16 +73,15 @@ runTactic ctx jdg t =
7373
$ runTacticT t jdg tacticState of
7474
(errs, []) -> Left $ take 50 $ errs
7575
(_, fmap assoc23 -> solns) -> do
76-
let sorted = sortBy (comparing $ Down . uncurry scoreSolution . snd) $ solns
77-
-- TODO(sandy): remove this trace sometime
78-
traceM
79-
$ mappend "!!!solns: "
80-
$ intercalate "\n"
81-
$ reverse
82-
$ take 5
83-
$ fmap (show . fst) sorted
76+
let sorted =
77+
sortBy (comparing $ Down . uncurry scoreSolution . snd) solns
8478
case sorted of
85-
(res : _) -> Right $ fst res
79+
(((tr, ext), _) : _) ->
80+
Right
81+
. RunTacticResults tr ext
82+
. reverse
83+
. fmap fst
84+
$ take 5 sorted
8685
-- guaranteed to not be empty
8786
_ -> Left []
8887

plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -217,9 +217,9 @@ splitAuto = tracing "split(auto)" $ do
217217
True -> choice $ fmap splitDataCon dcs
218218
False -> do
219219
choice $ flip fmap dcs $ \dc -> pruning (splitDataCon dc) $ \jdgs ->
220-
case any (/= jGoal jdg) $ fmap jGoal jdgs of
221-
False -> Nothing
222-
True -> Just $ UnhelpfulSplit $ nameOccName $ dataConName dc
220+
case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of
221+
True -> Nothing
222+
False -> Just $ UnhelpfulSplit $ nameOccName $ dataConName dc
223223

224224

225225
------------------------------------------------------------------------------

plugins/tactics/src/Ide/Plugin/Tactic/Types.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -219,3 +219,12 @@ rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a
219219
rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs
220220
rose a rs = Rose $ Node a $ coerce rs
221221

222+
223+
------------------------------------------------------------------------------
224+
-- | The results of 'Ide.Plugin.Tactic.Machinery.runTactic'
225+
data RunTacticResults = RunTacticResults
226+
{ rtr_trace :: Trace
227+
, rtr_extract :: LHsExpr GhcPs
228+
, rtr_other_solns :: [(Trace, LHsExpr GhcPs)]
229+
} deriving Show
230+

plugins/tactics/test/AutoTupleSpec.hs

Lines changed: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,58 @@
1+
{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
3+
module AutoTupleSpec where
4+
5+
import Data.Either (isRight)
6+
import qualified Data.Map as M
7+
import Ide.Plugin.Tactic.Debug
8+
import Ide.Plugin.Tactic.Judgements (mkFirstJudgement)
9+
import Ide.Plugin.Tactic.Machinery
10+
import Ide.Plugin.Tactic.Tactics (auto')
11+
import Ide.Plugin.Tactic.Types
12+
import OccName (mkVarOcc)
13+
import Test.Hspec
14+
import Test.QuickCheck
15+
import Type (mkTyVarTy)
16+
import TysPrim (alphaTyVars)
17+
import TysWiredIn (mkBoxedTupleTy)
18+
19+
20+
instance Show Type where
21+
show = unsafeRender
22+
23+
24+
spec :: Spec
25+
spec = describe "auto for tuple" $ do
26+
it "should always be able to discover an auto solution" $ do
27+
property $ do
28+
-- Pick some number of variables
29+
n <- choose (1, 7)
30+
let vars = fmap mkTyVarTy $ take n alphaTyVars
31+
-- Pick a random ordering
32+
in_vars <- shuffle vars
33+
-- Randomly associate them into tuple types
34+
in_type <- mkBoxedTupleTy
35+
. fmap mkBoxedTupleTy
36+
<$> randomGroups in_vars
37+
out_type <- mkBoxedTupleTy
38+
. fmap mkBoxedTupleTy
39+
<$> randomGroups vars
40+
pure $
41+
-- We should always be able to find a solution
42+
runTactic
43+
(Context [] [])
44+
(mkFirstJudgement
45+
(M.singleton (mkVarOcc "x") $ CType in_type)
46+
True
47+
mempty
48+
out_type)
49+
(auto' $ n * 2) `shouldSatisfy` isRight
50+
51+
52+
randomGroups :: [a] -> Gen [[a]]
53+
randomGroups [] = pure []
54+
randomGroups as = do
55+
n <- choose (1, length as)
56+
(:) <$> pure (take n as)
57+
<*> randomGroups (drop n as)
58+

plugins/tactics/test/Main.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main #-}

test/functional/Tactic.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,7 @@ tests = testGroup
101101
, goldenTest "GoldenGADTDestruct.hs" 7 17 Destruct "gadt"
102102
, goldenTest "GoldenGADTAuto.hs" 7 13 Auto ""
103103
, goldenTest "GoldenSwapMany.hs" 2 12 Auto ""
104+
, goldenTest "GoldenBigTuple.hs" 4 12 Auto ""
104105
]
105106

106107

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
-- There used to be a bug where we were unable to perform a nested split. The
2+
-- more serious regression test of this is 'AutoTupleSpec'.
3+
bigTuple :: (a, b, c, d) -> (a, b, (c, d))
4+
bigTuple = _
Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
-- There used to be a bug where we were unable to perform a nested split. The
2+
-- more serious regression test of this is 'AutoTupleSpec'.
3+
bigTuple :: (a, b, c, d) -> (a, b, (c, d))
4+
bigTuple = (\ pabcd -> case pabcd of { (a, b, c, d) -> (a, b, (c, d)) })

0 commit comments

Comments
 (0)