Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 11a5217

Browse files
author
Patrick Thomson
committed
Enable tests.
1 parent 132c30a commit 11a5217

File tree

4 files changed

+198
-1
lines changed

4 files changed

+198
-1
lines changed

‎semantic-core/semantic-core.cabal‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -64,3 +64,17 @@ test-suite doctest
6464
, semantic-core
6565
hs-source-dirs: test
6666
default-language: Haskell2010
67+
68+
test-suite spec
69+
type: exitcode-stdio-1.0
70+
main-is: Spec.hs
71+
other-modules: Generators
72+
build-depends: base
73+
, semantic-core
74+
, hedgehog >= 0.6 && <1
75+
, tasty >= 1.2 && <2
76+
, tasty-hedgehog >= 0.2 && <1
77+
, tasty-hunit >= 0.10 && <1
78+
, trifecta
79+
hs-source-dirs: test
80+
default-language: Haskell2010

‎semantic-core/src/Analysis/Eval.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@ prog6 =
119119
]
120120
]
121121
, File (Loc "main" (locSpan (fromJust here))) $ block
122-
[ Load (String "dep")
122+
[ Load (Var (Path "dep"))
123123
, Let (User "thing") := Var (Path "dep") :. Var (User "var")
124124
]
125125
]

‎semantic-core/test/Generators.hs‎

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
2+
3+
module Generators
4+
( literal
5+
, name
6+
, variable
7+
, boolean
8+
, lambda
9+
, apply
10+
, ifthenelse
11+
) where
12+
13+
import Prelude hiding (span)
14+
15+
import Hedgehog hiding (Var)
16+
import qualified Hedgehog.Gen as Gen
17+
import qualified Hedgehog.Range as Range
18+
19+
import Data.Core
20+
import Data.Name
21+
22+
-- The 'prune' call here ensures that we don't spend all our time just generating
23+
-- fresh names for variables, since the length of variable names is not an
24+
-- interesting property as they parse regardless.
25+
name :: MonadGen m => m Name
26+
name = Gen.prune (User <$> names) where
27+
names = Gen.string (Range.linear 1 10) Gen.lower
28+
29+
boolean :: MonadGen m => m Core
30+
boolean = Bool <$> Gen.bool
31+
32+
variable :: MonadGen m => m Core
33+
variable = Var <$> name
34+
35+
ifthenelse :: MonadGen m => m Core -> m Core
36+
ifthenelse bod = Gen.subterm3 boolean bod bod If
37+
38+
apply :: MonadGen m => m Core -> m Core
39+
apply gen = go where
40+
go = Gen.recursive
41+
Gen.choice
42+
[ Gen.subterm2 gen gen (:$)]
43+
[ Gen.subterm2 go go (:$) -- balanced
44+
, Gen.subtermM go (\x -> Lam <$> name <*> pure x)
45+
]
46+
47+
lambda :: MonadGen m => m Core -> m Core
48+
lambda bod = do
49+
arg <- name
50+
Gen.subterm bod (Lam arg)
51+
52+
atoms :: MonadGen m => [m Core]
53+
atoms = [boolean, variable, pure Unit, pure Frame]
54+
55+
literal :: MonadGen m => m Core
56+
literal = Gen.recursive Gen.choice atoms [lambda literal]

‎semantic-core/test/Spec.hs‎

Lines changed: 127 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,127 @@
1+
{-# LANGUAGE OverloadedStrings, TypeApplications #-}
2+
{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+
module Main (main) where
5+
6+
import Data.String
7+
import qualified Text.Trifecta as Trifecta
8+
9+
import Hedgehog hiding (Var)
10+
import Test.Tasty
11+
import Test.Tasty.Hedgehog
12+
import Test.Tasty.HUnit
13+
14+
import Data.File
15+
import qualified Generators as Gen
16+
import qualified Analysis.Eval as Eval
17+
import Data.Core
18+
import Data.Core.Pretty
19+
import Data.Core.Parser as Parse
20+
import Data.Name
21+
22+
-- * Helpers
23+
24+
true, false :: Core
25+
true = Bool True
26+
false = Bool False
27+
28+
instance IsString Name where fromString = User
29+
30+
parseEither :: Trifecta.Parser a -> String -> Either String a
31+
parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Trifecta.parseString (p <* Trifecta.eof) mempty
32+
33+
-- * Parser roundtripping properties. Note that parsing and prettyprinting is generally
34+
-- not a roundtrip, because the parser inserts 'Ann' nodes itself.
35+
36+
prop_roundtrips :: Gen Core -> Property
37+
prop_roundtrips gen = property $ do
38+
input <- forAll gen
39+
tripping input showCore (parseEither (Parse.core <* Trifecta.eof))
40+
41+
parserProps :: TestTree
42+
parserProps = testGroup "Parsing: roundtripping"
43+
[ testProperty "literals" $ prop_roundtrips Gen.literal
44+
, testProperty "if/then/else" . prop_roundtrips . Gen.ifthenelse $ Gen.variable
45+
, testProperty "lambda" . prop_roundtrips $ Gen.lambda Gen.literal
46+
, testProperty "function application" . prop_roundtrips $ Gen.apply Gen.variable
47+
]
48+
49+
-- * Parser specs
50+
51+
parsesInto :: String -> Core -> Assertion
52+
parsesInto str res = case parseEither Parse.core str of
53+
Right x -> x @?= res
54+
Left m -> assertFailure m
55+
56+
assert_booleans_parse :: Assertion
57+
assert_booleans_parse = do
58+
parseEither Parse.core "#true" @?= Right true
59+
parseEither Parse.core "#false" @?= Right false
60+
61+
a, f, g, h :: Core
62+
(a, f, g, h) = (Var "a", Var "f", Var "g", Var "h")
63+
64+
assert_ifthen_parse :: Assertion
65+
assert_ifthen_parse = "if #true then #true else #false" `parsesInto` (If true true false)
66+
67+
assert_application_parse :: Assertion
68+
assert_application_parse ="f g" `parsesInto` (f :$ g)
69+
70+
assert_application_left_associative :: Assertion
71+
assert_application_left_associative = "f g h" `parsesInto` (f :$ g :$ h)
72+
73+
assert_push_left_associative :: Assertion
74+
assert_push_left_associative = "f.g.h" `parsesInto` (f :. g :. h)
75+
76+
assert_ascii_lambda_parse :: Assertion
77+
assert_ascii_lambda_parse = "\\a -> a" `parsesInto` Lam "a" a
78+
79+
assert_unicode_lambda_parse :: Assertion
80+
assert_unicode_lambda_parse = "λa → a" `parsesInto` Lam "a" a
81+
82+
assert_quoted_name_parse :: Assertion
83+
assert_quoted_name_parse = "#{(NilClass)}" `parsesInto` Var (User "(NilClass)")
84+
85+
assert_let_dot_precedence :: Assertion
86+
assert_let_dot_precedence = "let a = f.g.h" `parsesInto` (Let "a" := (f :. g :. h))
87+
88+
assert_let_in_push_precedence :: Assertion
89+
assert_let_in_push_precedence = "f.let g = h" `parsesInto` (f :. (Let "g" := h))
90+
91+
parserSpecs :: TestTree
92+
parserSpecs = testGroup "Parsing: simple specs"
93+
[ testCase "true/false" assert_booleans_parse
94+
, testCase "if/then/else" assert_ifthen_parse
95+
, testCase "function application" assert_application_parse
96+
, testCase "application is left-associative" assert_application_left_associative
97+
, testCase "dotted push is left-associative" assert_push_left_associative
98+
, testCase "lambda with ASCII syntax" assert_ascii_lambda_parse
99+
, testCase "lambda with unicode syntax" assert_unicode_lambda_parse
100+
, testCase "quoted names" assert_quoted_name_parse
101+
, testCase "let + dot precedence" assert_let_dot_precedence
102+
, testCase "let in push" assert_let_in_push_precedence
103+
]
104+
105+
assert_roundtrips :: File Core -> Assertion
106+
assert_roundtrips (File _ core) = parseEither Parse.core (showCore core) @?= Right (stripAnnotations core)
107+
108+
parserExamples :: TestTree
109+
parserExamples = testGroup "Parsing: Eval.hs examples"
110+
[ testCase "prog1" (assert_roundtrips Eval.prog1)
111+
, testCase "prog2" (assert_roundtrips Eval.prog2)
112+
, testCase "prog3" (assert_roundtrips Eval.prog3)
113+
, testCase "prog4" (assert_roundtrips Eval.prog4)
114+
, testCase "prog6.1" (assert_roundtrips (head Eval.prog6))
115+
, testCase "prog6.2" (assert_roundtrips (last Eval.prog6))
116+
, testCase "ruby" (assert_roundtrips Eval.ruby)
117+
]
118+
119+
tests :: TestTree
120+
tests = testGroup "semantic-core"
121+
[ parserSpecs
122+
, parserExamples
123+
, parserProps
124+
]
125+
126+
main :: IO ()
127+
main = defaultMain tests

0 commit comments

Comments
 (0)