Skip to content
Snippets Groups Projects
Commit d761e23f authored by Ben Gamari's avatar Ben Gamari :turtle:
Browse files

Factor shrinkExpr into separate top-level

parent 60763320
No related branches found
No related tags found
1 merge request!10Enable testing of Word64# on 32-bit platforms
......@@ -142,46 +142,7 @@ instance KnownWidth width => Show (Expr width) where
instance KnownWidth width => Arbitrary (Expr width) where
arbitrary = genExpr
shrink e =
case e of
ERel op a b -> shrinkBinOp (ERel op) a b
EAdd a b -> shrinkBinOp EAdd a b ++ [ a | interpret b == 0 ] ++ [ b | interpret a == 0 ]
ESub a b -> shrinkBinOp ESub a b ++ [ a | interpret b == 0 ] ++ [ ENegate b | interpret a == 0 ]
EMul a b -> shrinkBinOp EMul a b ++ [ a | interpret b == 1 ] ++ [ b | interpret a == 1 ]
EQuot s a b -> shrinkDivOp (EQuot s) a b ++ [ a | interpret b == 1 ] ++ [ 0 | interpret a == 0 ]
ERem s a b -> shrinkDivOp (ERem s) a b ++ [ a | interpret b == 1 ] ++ [ 0 | interpret a == 0 ]
EAnd a b -> shrinkBinOp EAnd a b ++ [ a | interpret b == ones ] ++ [ b | interpret a == ones ]
EOr a b -> shrinkBinOp EOr a b ++ [ a | interpret b == 0 ] ++ [ b | interpret a == 0 ]
EXOr a b -> shrinkBinOp EXOr a b ++ [ a | interpret b == 0 ] ++ [ b | interpret a == 0 ]
ENot a -> shrinkUnOp ENot a ++ [a]
EShl a b -> shrinkBinOp EShl a b ++ [ a | interpret b == 0 ]
EShrl a b -> shrinkBinOp EShrl a b ++ [ a | interpret b == 0 ]
EShra a b -> shrinkBinOp EShra a b ++ [ a | interpret b == 0 ]
ENegate a -> shrinkUnOp ENegate a ++ [a]
ENarrow a -> shrinkUnOp ENarrow a
++ [ ENarrow b | ENarrow b <- pure a, Wider <- pure $ b `compareWidths` e ]
++ [ b | EZeroExt b <- pure a, SameWidth <- pure $ e `compareWidths` b ]
ESignExt a -> shrinkUnOp ESignExt a
++ [ ESignExt b | ESignExt b <- pure a, Wider <- pure $ e `compareWidths` b ]
++ [ EZeroExt a ]
EZeroExt a -> shrinkUnOp EZeroExt a
++ [ EZeroExt b | EZeroExt b <- pure a, Wider <- pure $ e `compareWidths` b ]
ELoad a -> shrinkUnOp ELoad a
ELit a -> map ELit (shrink a)
where
shrinkUnOp op a =
[ ELit $ interpret (op a) ] ++
[ op a' | a' <- shrink a ]
shrinkBinOp op a b =
[ ELit $ interpret (op a b) ] ++
[ op a' b' | (a', b') <- shrink (a, b) ]
shrinkDivOp op a b =
[ ELit $ interpret (op a b) ] ++
[ op a' b'
| (a', b') <- shrink (a, b)
, interpret b' /= 0
]
shrink e = shrinkExpr e
genExpr :: forall width. (KnownWidth width)
=> Gen (Expr width)
......@@ -290,6 +251,49 @@ genExpr' _width = sized gen
remOp = ERem <$> arbitrary <*> subexpr2 <*> nonzero subexpr2
nonzero = flip suchThat $ \x -> interpret x /= 0
shrinkExpr :: forall width. (KnownWidth width)
=> Expr width -> [Expr width]
shrinkExpr e =
case e of
ERel op a b -> shrinkBinOp (ERel op) a b
EAdd a b -> shrinkBinOp EAdd a b ++ [ a | interpret b == 0 ] ++ [ b | interpret a == 0 ]
ESub a b -> shrinkBinOp ESub a b ++ [ a | interpret b == 0 ] ++ [ ENegate b | interpret a == 0 ]
EMul a b -> shrinkBinOp EMul a b ++ [ a | interpret b == 1 ] ++ [ b | interpret a == 1 ]
EQuot s a b -> shrinkDivOp (EQuot s) a b ++ [ a | interpret b == 1 ] ++ [ 0 | interpret a == 0 ]
ERem s a b -> shrinkDivOp (ERem s) a b ++ [ a | interpret b == 1 ] ++ [ 0 | interpret a == 0 ]
EAnd a b -> shrinkBinOp EAnd a b ++ [ a | interpret b == ones ] ++ [ b | interpret a == ones ]
EOr a b -> shrinkBinOp EOr a b ++ [ a | interpret b == 0 ] ++ [ b | interpret a == 0 ]
EXOr a b -> shrinkBinOp EXOr a b ++ [ a | interpret b == 0 ] ++ [ b | interpret a == 0 ]
ENot a -> shrinkUnOp ENot a ++ [a]
EShl a b -> shrinkBinOp EShl a b ++ [ a | interpret b == 0 ]
EShrl a b -> shrinkBinOp EShrl a b ++ [ a | interpret b == 0 ]
EShra a b -> shrinkBinOp EShra a b ++ [ a | interpret b == 0 ]
ENegate a -> shrinkUnOp ENegate a ++ [a]
ENarrow a -> shrinkUnOp ENarrow a
++ [ ENarrow b | ENarrow b <- pure a, Wider <- pure $ b `compareWidths` e ]
++ [ b | EZeroExt b <- pure a, SameWidth <- pure $ e `compareWidths` b ]
ESignExt a -> shrinkUnOp ESignExt a
++ [ ESignExt b | ESignExt b <- pure a, Wider <- pure $ e `compareWidths` b ]
++ [ EZeroExt a ]
EZeroExt a -> shrinkUnOp EZeroExt a
++ [ EZeroExt b | EZeroExt b <- pure a, Wider <- pure $ e `compareWidths` b ]
ELoad a -> shrinkUnOp ELoad a
ELit a -> map ELit (shrink a)
where
shrinkUnOp op a =
[ ELit $ interpret (op a) ] ++
[ op a' | a' <- shrink a ]
shrinkBinOp op a b =
[ ELit $ interpret (op a b) ] ++
[ op a' b' | (a', b') <- shrink (a, b) ]
shrinkDivOp op a b =
[ ELit $ interpret (op a b) ] ++
[ op a' b'
| (a', b') <- shrink (a, b)
, interpret b' /= 0
]
-- * SomeExpr
data SomeExpr where
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment