Skip to content

Commit 96f2da8

Browse files
georgefstgeorgefst
committed
test: Extend available actions property test to cover typedefs
1 parent 592b6b3 commit 96f2da8

File tree

1 file changed

+91
-16
lines changed

1 file changed

+91
-16
lines changed

‎primer/test/Tests/Action/Available.hs

Lines changed: 91 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE OverloadedLabels #-}
23
{-# LANGUAGE OverloadedRecordDot #-}
34

@@ -13,6 +14,8 @@ import Data.Text qualified as T
1314
import Data.Text.Lazy qualified as TL
1415
import GHC.Err (error)
1516
import Hedgehog (
17+
GenT,
18+
LabelName,
1619
PropertyT,
1720
annotate,
1821
annotateShow,
@@ -46,17 +49,22 @@ import Primer.App (
4649
NodeType (..),
4750
ProgError (ActionError, DefAlreadyExists),
4851
Selection' (..),
52+
TypeDefConsSelection (TypeDefConsSelection),
53+
TypeDefNodeSelection (TypeDefConsNodeSelection, TypeDefParamNodeSelection),
54+
TypeDefSelection (TypeDefSelection),
4955
appProg,
5056
checkAppWellFormed,
5157
handleEditRequest,
5258
progAllDefs,
5359
progAllTypeDefs,
60+
progAllTypeDefsMeta,
5461
progCxt,
5562
progImports,
5663
progModules,
5764
progSmartHoles,
5865
runEditAppM,
5966
)
67+
import Primer.App.Base (TypeDefConsFieldSelection (..))
6068
import Primer.Builtins (builtinModuleName, cCons, tList, tNat)
6169
import Primer.Core (
6270
Expr,
@@ -112,6 +120,7 @@ import Primer.Module (
112120
import Primer.Name (Name (unName))
113121
import Primer.Test.TestM (evalTestM)
114122
import Primer.Test.Util (clearMeta, testNoSevereLogs)
123+
import Primer.TypeDef (ASTTypeDef (astTypeDefConstructors), TypeDef (TypeDefAST, TypeDefPrim), ValCon (..), astTypeDefParameters, typeDefAST)
115124
import Primer.Typecheck (
116125
CheckEverythingRequest (CheckEverything, toCheck, trusted),
117126
SmartHoles (NoSmartHoles, SmartHoles),
@@ -242,27 +251,95 @@ tasty_available_actions_accepted = withTests 500 $
242251
-- We only test SmartHoles mode (which is the only supported user-facing
243252
-- mode - NoSmartHoles is only used for internal sanity testing etc)
244253
a <- forAllT $ genApp SmartHoles cxt
254+
let allTypes = progAllTypeDefsMeta $ appProg a
245255
let allDefs = progAllDefs $ appProg a
246256
let isMutable = \case
247257
Editable -> True
248258
NonEditable -> False
249-
(defName, (defMut, def)) <-
250-
maybe discard (\(t, x) -> label t >> pure x)
251-
=<< forAllT
252-
( case partition (isMutable . fst . snd) $ Map.toList allDefs of
259+
let genDef :: Map name (Editable, def) -> GenT WT (Maybe (LabelName, (Editable, (name, def))))
260+
genDef m =
261+
second (\(n, (e, t)) -> (e, (n, t)))
262+
<<$>> case partition (isMutable . fst . snd) $ Map.toList m of
253263
([], []) -> pure Nothing
254264
(mut, []) -> Just . ("all mut",) <$> Gen.element mut
255265
([], immut) -> Just . ("all immut",) <$> Gen.element immut
256266
(mut, immut) -> Just . ("mixed mut/immut",) <$> Gen.frequency [(9, Gen.element mut), (1, Gen.element immut)]
267+
(defMut, typeOrTermDef) <-
268+
maybe discard (\(t, x) -> label t >> pure x)
269+
=<< forAllT
270+
( Gen.choice
271+
[ second (second Left) <<$>> genDef allTypes
272+
, second (second Right) <<$>> genDef allDefs
273+
]
257274
)
258275
collect defMut
259-
case def of
260-
DefAST{} -> label "AST"
261-
DefPrim{} -> label "Prim"
262-
(loc, acts) <-
263-
fmap (first (SelectionDef . DefSelection defName) . snd) . forAllWithT fst $
264-
Gen.frequency $
265-
catMaybes
276+
case typeOrTermDef of
277+
Left (_, t) ->
278+
label "type" >> case t of
279+
TypeDefPrim{} -> label "Prim"
280+
TypeDefAST{} -> label "AST"
281+
Right (_, t) ->
282+
label "term" >> case t of
283+
DefPrim{} -> label "Prim"
284+
DefAST{} -> label "AST"
285+
(def, (loc, acts)) <- case typeOrTermDef of
286+
Left (defName, def) ->
287+
(,)
288+
<$> maybe (annotate "primitive type def" >> failure) (pure . Left) (typeDefAST def)
289+
<*> (fmap snd . forAllWithT fst) case typeDefAST def of
290+
Nothing -> Gen.discard
291+
Just def' ->
292+
let typeDefSel = SelectionTypeDef . TypeDefSelection defName
293+
forTypeDef = ("forTypeDef", (typeDefSel Nothing, Available.forTypeDef l defMut))
294+
in Gen.frequency
295+
[ (1, pure forTypeDef)
296+
,
297+
( 2
298+
, case astTypeDefParameters def' of
299+
[] -> pure forTypeDef
300+
ps -> do
301+
(p, _) <- Gen.element ps
302+
pure
303+
( "forTypeDefParamNode"
304+
,
305+
( typeDefSel $ Just $ TypeDefParamNodeSelection p
306+
, Available.forTypeDefParamNode l defMut
307+
)
308+
)
309+
)
310+
,
311+
( 5
312+
, case astTypeDefConstructors def' of
313+
[] -> pure forTypeDef
314+
cs -> do
315+
ValCon{valConName, valConArgs} <- Gen.element cs
316+
let typeDefConsNodeSel = typeDefSel . Just . TypeDefConsNodeSelection . TypeDefConsSelection valConName
317+
forTypeDefConsNode = ("forTypeDefConsNode", (typeDefConsNodeSel Nothing, Available.forTypeDefConsNode l defMut))
318+
case valConArgs of
319+
[] -> pure forTypeDefConsNode
320+
as ->
321+
Gen.frequency
322+
[ (1, pure forTypeDefConsNode)
323+
,
324+
( 5
325+
, do
326+
(n, t) <- Gen.element $ zip [0 ..] as
327+
i <- Gen.element $ t ^.. typeIDs
328+
pure
329+
( "forTypeDefConsFieldNode"
330+
,
331+
( typeDefConsNodeSel . Just $ TypeDefConsFieldSelection n i
332+
, Available.forTypeDefConsFieldNode l defMut def' valConName n i
333+
)
334+
)
335+
)
336+
]
337+
)
338+
]
339+
Right (defName, def) ->
340+
(,)
341+
<$> maybe (annotate "primitive def" >> failure) (pure . Right) (defAST def)
342+
<*> (fmap (first (SelectionDef . DefSelection defName) . snd) . forAllWithT fst . Gen.frequency . catMaybes)
266343
[ Just (1, pure ("forDef", (Nothing, Available.forDef (snd <$> allDefs) l defMut defName)))
267344
, defAST def <&> \d' -> (2,) $ do
268345
let ty = astDefType d'
@@ -284,21 +361,19 @@ tasty_available_actions_accepted = withTests 500 $
284361
collect action
285362
case action of
286363
Available.NoInput act' -> do
287-
def' <- maybe (annotate "primitive def" >> failure) pure $ defAST def
288364
progActs <-
289365
either (\e -> annotateShow e >> failure) pure $
290-
toProgActionNoInput (map snd $ progAllDefs $ appProg a) (Right def') loc act'
366+
toProgActionNoInput (map snd $ progAllDefs $ appProg a) def loc act'
291367
actionSucceeds (handleEditRequest progActs) a
292368
Available.Input act' -> do
293-
def' <- maybe (annotate "primitive def" >> failure) pure $ defAST def
294369
Available.Options{Available.opts, Available.free} <-
295370
maybe (annotate "id not found" >> failure) pure $
296371
Available.options
297372
(map snd $ progAllTypeDefs $ appProg a)
298373
(map snd $ progAllDefs $ appProg a)
299374
(progCxt $ appProg a)
300375
l
301-
(Right def')
376+
def
302377
loc
303378
act'
304379
let opts' = [Gen.element $ (Offered,) <$> opts | not (null opts)]
@@ -312,7 +387,7 @@ tasty_available_actions_accepted = withTests 500 $
312387
[] -> annotate "no options" >> success
313388
options -> do
314389
opt <- forAllT $ Gen.choice options
315-
progActs <- either (\e -> annotateShow e >> failure) pure $ toProgActionInput (Right def') loc (snd opt) act'
390+
progActs <- either (\e -> annotateShow e >> failure) pure $ toProgActionInput def loc (snd opt) act'
316391
actionSucceedsOrCapture (fst opt) (handleEditRequest progActs) a
317392
where
318393
runEditAppMLogs ::

0 commit comments

Comments
 (0)