github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Strip annotations in the tests.

Browse Source
This commit is contained in:
Rob Rix 2019-07-17 15:23:56 -04:00
parent 8aacefb5d1
commit 36827bb85c
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 8 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
semantic-core/src/Data/Core.hs
View File

@ -28,6 +28,7 @@ module Data.Core
, ann
, annWith
, instantiate
, stripAnnotations
) where
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)
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
foldSyntax go k h = \case
Let a -> Let a

2
semantic-core/test/Spec.hs
View File

@ -100,7 +100,7 @@ parserSpecs = testGroup "Parsing: simple specs"
]
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 = testGroup "Parsing: Eval.hs examples"