1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Futhark.IR.Syntax.CoreTests (tests) where
import Control.Applicative
import Data.Loc (Loc (..), Pos (..))
import Futhark.IR.Pretty (prettyString)
import Futhark.IR.Syntax.Core
import Language.Futhark.CoreTests ()
import Language.Futhark.PrimitiveTests ()
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.HUnit
import Prelude
instance Arbitrary NoUniqueness where
arbitrary = pure NoUniqueness
instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where
arbitrary =
oneof
[ Prim <$> arbitrary,
Array <$> arbitrary <*> arbitrary <*> arbitrary
]
instance Arbitrary Ident where
arbitrary = Ident <$> arbitrary <*> arbitrary
instance Arbitrary Rank where
arbitrary = Rank <$> elements [1 .. 9]
instance Arbitrary Shape where
arbitrary = Shape . map intconst <$> listOf1 (elements [1 .. 9])
where
intconst = Constant . IntValue . Int32Value
subShapeTests :: [TestTree]
subShapeTests =
[ shape [free 1, free 2] `isSubShapeOf` shape [free 1, free 2],
shape [free 1, free 3] `isNotSubShapeOf` shape [free 1, free 2],
shape [free 1] `isNotSubShapeOf` shape [free 1, free 2],
shape [free 1, free 2] `isSubShapeOf` shape [free 1, Ext 3],
shape [Ext 1, Ext 2] `isNotSubShapeOf` shape [Ext 1, Ext 1],
shape [Ext 1, Ext 1] `isSubShapeOf` shape [Ext 1, Ext 2]
]
where
shape :: [ExtSize] -> ExtShape
shape = Shape
free :: Int -> ExtSize
free = Free . Constant . IntValue . Int32Value . fromIntegral
isSubShapeOf shape1 shape2 =
subShapeTest shape1 shape2 True
isNotSubShapeOf shape1 shape2 =
subShapeTest shape1 shape2 False
subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree
subShapeTest shape1 shape2 expected =
testCase
( "subshapeOf "
++ prettyString shape1
++ " "
++ prettyString shape2
++ " == "
++ show expected
)
$ shape1 `subShapeOf` shape2 @?= expected
provenanceTests :: [TestTree]
provenanceTests =
[ testGroup
"<>"
[ testCase "simple" $
(Provenance [] line1 <> Provenance [] line0) @?= Provenance [] lines01,
testCase "mempty left" $
(Provenance [] mempty <> Provenance [] line0) @?= Provenance [] line0,
testCase "mempty right" $
(Provenance [] line1 <> Provenance [] mempty) @?= Provenance [] line1
],
testGroup
"stackProvenance"
[ testCase "encloses" $
(Provenance [] line0 `stackProvenance` Provenance [] line0_sub)
@?= Provenance [] line0_sub
]
]
where
line0 = Loc (Pos "" 0 1 0) (Pos "" 0 10 10)
line0_sub = Loc (Pos "" 0 2 1) (Pos "" 0 9 9)
line1 = Loc (Pos "" 1 1 0) (Pos "" 1 10 20)
lines01 = Loc (Pos "" 0 1 0) (Pos "" 1 10 20)
tests :: TestTree
tests =
testGroup
"Internal CoreTests"
[ testGroup "subShape" subShapeTests,
testGroup "Provenance" provenanceTests
]
|
