Generate User names.

Author: robrix

semantic-core/test/Generators.hs

@@ -23,20 +23,20 @@ import Data.Term
 -- The 'prune' call here ensures that we don't spend all our time just generating
 -- fresh names for variables, since the length of variable names is not an
 -- interesting property as they parse regardless.
-name :: MonadGen m => m (Named Name)
-name = Gen.prune ((Named . Ignored <*> User) <$> names) where
+name :: MonadGen m => m (Named User)
+name = Gen.prune ((Named . Ignored <*> id) <$> names) where
   names = Gen.text (Range.linear 1 10) Gen.lower
 
-boolean :: MonadGen m => m (Term Core Name)
+boolean :: MonadGen m => m (Term Core User)
 boolean = bool <$> Gen.bool
 
-variable :: MonadGen m => m (Term Core Name)
+variable :: MonadGen m => m (Term Core User)
 variable = pure . namedValue <$> name
 
-ifthenelse :: MonadGen m => m (Term Core Name) -> m (Term Core Name)
+ifthenelse :: MonadGen m => m (Term Core User) -> m (Term Core User)
 ifthenelse bod = Gen.subterm3 boolean bod bod if'
 
-apply :: MonadGen m => m (Term Core Name) -> m (Term Core Name)
+apply :: MonadGen m => m (Term Core User) -> m (Term Core User)
 apply gen = go where
   go = Gen.recursive
     Gen.choice
@@ -45,13 +45,13 @@ apply gen = go where
     , Gen.subtermM go (\x -> lam <$> name <*> pure x)
     ]
 
-lambda :: MonadGen m => m (Term Core Name) -> m (Term Core Name)
+lambda :: MonadGen m => m (Term Core User) -> m (Term Core User)
 lambda bod = do
   arg <- name
   Gen.subterm bod (lam arg)
 
-atoms :: MonadGen m => [m (Term Core Name)]
+atoms :: MonadGen m => [m (Term Core User)]
 atoms = [boolean, variable, pure unit, pure frame]
 
-literal :: MonadGen m => m (Term Core Name)
+literal :: MonadGen m => m (Term Core User)
 literal = Gen.recursive Gen.choice atoms [lambda literal]

semantic-core/test/Spec.hs

@@ -1,6 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Main (main) where
 
 import           Data.String
@@ -22,19 +20,17 @@ import           Data.Term
 
 -- * Helpers
 
-true, false :: Term Core Name
-true  = Bool True
-false = Bool False
-
-instance IsString Name where fromString = User . fromString
+true, false :: Term Core User
+true  = bool True
+false = bool False
 
 parseEither :: Trifecta.Parser a -> String -> Either String a
 parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Trifecta.parseString (p <* Trifecta.eof) mempty
 
 -- * 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 Name) -> Property
+prop_roundtrips :: Gen (Term Core User) -> Property
 prop_roundtrips gen = property $ do
   input <- forAll gen
   tripping input showCore (parseEither (Parse.core <* Trifecta.eof))
@@ -49,7 +45,7 @@ parserProps = testGroup "Parsing: roundtripping"
 
 -- * Parser specs
 
-parsesInto :: String -> Term Core Name -> Assertion
+parsesInto :: String -> Term Core User -> Assertion
 parsesInto str res = case parseEither Parse.core str of
   Right x -> x @?= res
   Left m  -> assertFailure m
@@ -59,35 +55,35 @@ assert_booleans_parse = do
   parseEither Parse.core "#true"  @?= Right true
   parseEither Parse.core "#false" @?= Right false
 
-a, f, g, h :: Term Core Name
-(a, f, g, h) = (Var "a", Var "f", Var "g", Var "h")
+a, f, g, h :: Term Core User
+(a, f, g, h) = (pure "a", pure "f", pure "g", pure "h")
 
 assert_ifthen_parse :: Assertion
-assert_ifthen_parse = "if #true then #true else #false" `parsesInto` (If true true false)
+assert_ifthen_parse = "if #true then #true else #false" `parsesInto` (if' true true false)
 
 assert_application_parse :: Assertion
-assert_application_parse ="f g" `parsesInto` (f :$ g)
+assert_application_parse = "f g" `parsesInto` (f $$ g)
 
 assert_application_left_associative :: Assertion
-assert_application_left_associative = "f g h" `parsesInto` (f :$ g :$ h)
+assert_application_left_associative = "f g h" `parsesInto` (f $$ g $$ h)
 
 assert_push_left_associative :: Assertion
-assert_push_left_associative = "f.g.h" `parsesInto` (f :. g :. h)
+assert_push_left_associative = "f.g.h" `parsesInto` (f ... g ... h)
 
 assert_ascii_lambda_parse :: Assertion
-assert_ascii_lambda_parse = "\\a -> a" `parsesInto` Lam "a" a
+assert_ascii_lambda_parse = "\\a -> a" `parsesInto` lam (named' "a") a
 
 assert_unicode_lambda_parse :: Assertion
-assert_unicode_lambda_parse = "λa → a" `parsesInto` Lam "a" a
+assert_unicode_lambda_parse = "λa → a" `parsesInto` lam (named' "a") a
 
 assert_quoted_name_parse :: Assertion
-assert_quoted_name_parse = "#{(NilClass)}" `parsesInto` Var (User "(NilClass)")
+assert_quoted_name_parse = "#{(NilClass)}" `parsesInto` pure "(NilClass)"
 
 assert_let_dot_precedence :: Assertion
-assert_let_dot_precedence = "let a = f.g.h" `parsesInto` (Let "a" := (f :. g :. h))
+assert_let_dot_precedence = "let a = f.g.h" `parsesInto` (let' "a" .= (f ... g ... h))
 
 assert_let_in_push_precedence :: Assertion
-assert_let_in_push_precedence = "f.let g = h" `parsesInto` (f :. (Let "g" := h))
+assert_let_in_push_precedence = "f.let g = h" `parsesInto` (f ... (let' "g" .= h))
 
 parserSpecs :: TestTree
 parserSpecs = testGroup "Parsing: simple specs"
@@ -103,8 +99,8 @@ parserSpecs = testGroup "Parsing: simple specs"
   , testCase "let in push" assert_let_in_push_precedence
   ]
 
-assert_roundtrips :: File (Term Core Name) -> Assertion
-assert_roundtrips (File _ core) = parseEither Parse.core (showCore core) @?= Right (stripAnnotations core)
+assert_roundtrips :: File (Term Core User) -> Assertion
+assert_roundtrips (File _ core) = parseEither Parse.core (showCore core) @?= Right core
 
 parserExamples :: TestTree
 parserExamples = testGroup "Parsing: Eval.hs examples"