mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Strip annotations in the tests.
This commit is contained in:
parent
8aacefb5d1
commit
36827bb85c
@ -28,6 +28,7 @@ module Data.Core
|
|||||||
, ann
|
, ann
|
||||||
, annWith
|
, annWith
|
||||||
, instantiate
|
, instantiate
|
||||||
|
, stripAnnotations
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative (Alternative (..))
|
import Control.Applicative (Alternative (..))
|
||||||
@ -189,6 +190,12 @@ annWith :: (Carrier sig m, Member Core sig) => CallStack -> m a -> m a
|
|||||||
annWith callStack = maybe id (fmap send . Ann) (stackLoc callStack)
|
annWith callStack = maybe id (fmap send . Ann) (stackLoc callStack)
|
||||||
|
|
||||||
|
|
||||||
|
stripAnnotations :: (Member Core sig, Syntax sig) => Term sig a -> Term sig a
|
||||||
|
stripAnnotations = iter id alg Var Var
|
||||||
|
where alg t | Just c <- prj t, Ann _ b <- c = b
|
||||||
|
| otherwise = Term t
|
||||||
|
|
||||||
|
|
||||||
instance Syntax Core where
|
instance Syntax Core where
|
||||||
foldSyntax go k h = \case
|
foldSyntax go k h = \case
|
||||||
Let a -> Let a
|
Let a -> Let a
|
||||||
|
@ -100,7 +100,7 @@ parserSpecs = testGroup "Parsing: simple specs"
|
|||||||
]
|
]
|
||||||
|
|
||||||
assert_roundtrips :: File (Term Core User) -> Assertion
|
assert_roundtrips :: File (Term Core User) -> Assertion
|
||||||
assert_roundtrips (File _ core) = parseEither Parse.core (showCore core) @?= Right core
|
assert_roundtrips (File _ core) = parseEither Parse.core (showCore core) @?= Right (stripAnnotations core)
|
||||||
|
|
||||||
parserExamples :: TestTree
|
parserExamples :: TestTree
|
||||||
parserExamples = testGroup "Parsing: Eval.hs examples"
|
parserExamples = testGroup "Parsing: Eval.hs examples"
|
||||||
|
Loading…
Reference in New Issue
Block a user