mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
Fix the tests.
This commit is contained in:
parent
e9b21f6ebf
commit
e2db378be6
@ -84,6 +84,7 @@ test-suite spec
|
||||
other-modules: Generators
|
||||
build-depends: base
|
||||
, semantic-core
|
||||
, fused-effects
|
||||
, hedgehog ^>= 1
|
||||
, tasty >= 1.2 && <2
|
||||
, tasty-hedgehog ^>= 1.0.0.1
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ScopedTypeVariables, TypeOperators #-}
|
||||
|
||||
module Generators
|
||||
( literal
|
||||
@ -18,6 +18,7 @@ import Hedgehog hiding (Var)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
|
||||
import Control.Effect.Sum ((:+:))
|
||||
import qualified Data.Core as Core
|
||||
import Data.Name
|
||||
import Data.Term
|
||||
@ -29,16 +30,16 @@ name :: MonadGen m => m (Named User)
|
||||
name = Gen.prune (named' <$> names) where
|
||||
names = Gen.text (Range.linear 1 10) Gen.lower
|
||||
|
||||
boolean :: MonadGen m => m (Term Core.Core User)
|
||||
boolean :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User)
|
||||
boolean = Core.bool <$> Gen.bool
|
||||
|
||||
variable :: MonadGen m => m (Term Core.Core User)
|
||||
variable :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User)
|
||||
variable = pure . namedValue <$> name
|
||||
|
||||
ifthenelse :: MonadGen m => m (Term Core.Core User) -> m (Term Core.Core User)
|
||||
ifthenelse :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User) -> m (Term (Core.Ann :+: Core.Core) User)
|
||||
ifthenelse bod = Gen.subterm3 boolean bod bod Core.if'
|
||||
|
||||
apply :: MonadGen m => m (Term Core.Core User) -> m (Term Core.Core User)
|
||||
apply :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User) -> m (Term (Core.Ann :+: Core.Core) User)
|
||||
apply gen = go where
|
||||
go = Gen.recursive
|
||||
Gen.choice
|
||||
@ -47,21 +48,21 @@ apply gen = go where
|
||||
, Gen.subtermM go (\x -> Core.lam <$> name <*> pure x)
|
||||
]
|
||||
|
||||
lambda :: MonadGen m => m (Term Core.Core User) -> m (Term Core.Core User)
|
||||
lambda :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User) -> m (Term (Core.Ann :+: Core.Core) User)
|
||||
lambda bod = do
|
||||
arg <- name
|
||||
Gen.subterm bod (Core.lam arg)
|
||||
|
||||
record :: MonadGen m => m (Term Core.Core User) -> m (Term Core.Core User)
|
||||
record :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User) -> m (Term (Core.Ann :+: Core.Core) User)
|
||||
record bod = Core.record <$> Gen.list (Range.linear 0 5) ((,) . namedValue <$> name <*> bod)
|
||||
|
||||
atoms :: MonadGen m => [m (Term Core.Core User)]
|
||||
atoms :: MonadGen m => [m (Term (Core.Ann :+: Core.Core) User)]
|
||||
atoms = [variable, pure Core.unit, boolean, Core.string <$> Gen.text (Range.linear 1 10) Gen.lower]
|
||||
|
||||
literal :: MonadGen m => m (Term Core.Core User)
|
||||
literal :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User)
|
||||
literal = Gen.recursive Gen.choice atoms [lambda literal, record literal]
|
||||
|
||||
expr :: MonadGen m => m (Term Core.Core User)
|
||||
expr :: MonadGen m => m (Term (Core.Ann :+: Core.Core) User)
|
||||
expr = Gen.recursive Gen.choice atoms
|
||||
[ Gen.subtermM expr (\x -> flip Core.rec x <$> name)
|
||||
, Gen.subterm2 expr expr (Core.>>>)
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedStrings, TypeOperators #-}
|
||||
module Main (main) where
|
||||
|
||||
import Data.String
|
||||
@ -9,6 +9,7 @@ import Test.Tasty
|
||||
import Test.Tasty.Hedgehog
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import Control.Effect.Sum
|
||||
import Data.File
|
||||
import qualified Generators as Gen
|
||||
import qualified Analysis.Eval as Eval
|
||||
@ -20,7 +21,7 @@ import Data.Term
|
||||
|
||||
-- * Helpers
|
||||
|
||||
true, false :: Term Core User
|
||||
true, false :: Term (Ann :+: Core) User
|
||||
true = bool True
|
||||
false = bool False
|
||||
|
||||
@ -30,10 +31,10 @@ parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Tri
|
||||
-- * Parser roundtripping properties. Note that parsing and prettyprinting is generally
|
||||
-- not a roundtrip, because the parser inserts 'Ann' nodes itself.
|
||||
|
||||
prop_roundtrips :: Gen (Term Core User) -> Property
|
||||
prop_roundtrips :: Gen (Term (Ann :+: Core) User) -> Property
|
||||
prop_roundtrips gen = property $ do
|
||||
input <- forAll gen
|
||||
tripping input showCore (parseEither (Parse.core <* Trifecta.eof))
|
||||
tripping input (showCore . stripAnnotations) (parseEither (Parse.core <* Trifecta.eof))
|
||||
|
||||
parserProps :: TestTree
|
||||
parserProps = testGroup "Parsing: roundtripping"
|
||||
@ -46,7 +47,7 @@ parserProps = testGroup "Parsing: roundtripping"
|
||||
|
||||
-- * Parser specs
|
||||
|
||||
parsesInto :: String -> Term Core User -> Assertion
|
||||
parsesInto :: String -> Term (Ann :+: Core) User -> Assertion
|
||||
parsesInto str res = case parseEither Parse.core str of
|
||||
Right x -> x @?= res
|
||||
Left m -> assertFailure m
|
||||
@ -56,7 +57,7 @@ assert_booleans_parse = do
|
||||
parseEither Parse.core "#true" @?= Right true
|
||||
parseEither Parse.core "#false" @?= Right false
|
||||
|
||||
a, f, g, h :: Term Core User
|
||||
a, f, g, h :: Term (Ann :+: Core) User
|
||||
(a, f, g, h) = (pure "a", pure "f", pure "g", pure "h")
|
||||
|
||||
assert_ifthen_parse :: Assertion
|
||||
@ -92,9 +93,9 @@ parserSpecs = testGroup "Parsing: simple specs"
|
||||
, testCase "quoted names" assert_quoted_name_parse
|
||||
]
|
||||
|
||||
assert_roundtrips :: File (Term Core User) -> Assertion
|
||||
assert_roundtrips (File _ core) = case parseEither Parse.core (showCore core) of
|
||||
Right v -> v @?= stripAnnotations core
|
||||
assert_roundtrips :: File (Term (Ann :+: Core) User) -> Assertion
|
||||
assert_roundtrips (File _ core) = case parseEither Parse.core (showCore (stripAnnotations core)) of
|
||||
Right v -> stripAnnotations v @?= stripAnnotations core
|
||||
Left e -> assertFailure e
|
||||
|
||||
parserExamples :: TestTree
|
||||
|
Loading…
Reference in New Issue
Block a user