github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 09:15:01 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #219 from github/re-name

Browse Source 
Rename User to Name
This commit is contained in:
Rob Rix 2019-08-06 15:18:50 -04:00 committed by GitHub
commit becf320762
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
11 changed files with 113 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
semantic-core/src/Analysis/Concrete.hs
View File

@ -34,13 +34,13 @@ import Data.Traversable (for)
import Prelude hiding (fail)
type Precise = Int
type Env = Map.Map User Precise
type Env = Map.Map Name Precise
newtype FrameId = FrameId { unFrameId :: Precise }
deriving (Eq, Ord, Show)
data Concrete term
= Closure Loc User term Env
= Closure Loc Name term Env
| Unit
| Bool Bool
| String Text
@ -69,15 +69,15 @@ data Edge = Lexical | Import
-- >>> map fileBody (snd (concrete eval [File (Loc "bool" emptySpan) (Core.bool True)]))
-- [Right (Bool True)]
concrete
:: (Foldable term, Show (term User))
:: (Foldable term, Show (term Name))
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis (term User) Precise (Concrete (term User)) m
-> (term User -> m (Concrete (term User)))
-> (term User -> m (Concrete (term User)))
=> Analysis (term Name) Precise (Concrete (term Name)) m
-> (term Name -> m (Concrete (term Name)))
-> (term Name -> m (Concrete (term Name)))
)
-> [File (term User)]
-> (Heap (term User), [File (Either (Loc, String) (Concrete (term User)))])
-> [File (term Name)]
-> (Heap (term Name), [File (Either (Loc, String) (Concrete (term Name)))])
concrete eval
= run
. runFresh
@ -89,17 +89,17 @@ runFile
, Effect sig
, Foldable term
, Member Fresh sig
, Member (State (Heap (term User))) sig
, Show (term User)
, Member (State (Heap (term Name))) sig
, Show (term Name)
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis (term User) Precise (Concrete (term User)) m
-> (term User -> m (Concrete (term User)))
-> (term User -> m (Concrete (term User)))
=> Analysis (term Name) Precise (Concrete (term Name)) m
-> (term Name -> m (Concrete (term Name)))
-> (term Name -> m (Concrete (term Name)))
)
-> File (term User)
-> m (File (Either (Loc, String) (Concrete (term User))))
-> File (term Name)
-> m (File (Either (Loc, String) (Concrete (term Name))))
runFile eval file = traverse run file
where run = runReader (fileLoc file)
. runFailWithLoc
@ -111,11 +111,11 @@ concreteAnalysis :: ( Carrier sig m
, Member Fresh sig
, Member (Reader Env) sig
, Member (Reader Loc) sig
, Member (State (Heap (term User))) sig
, Member (State (Heap (term Name))) sig
, MonadFail m
, Show (term User)
, Show (term Name)
)
=> Analysis (term User) Precise (Concrete (term User)) m
=> Analysis (term Name) Precise (Concrete (term Name)) m
concreteAnalysis = Analysis{..}
where alloc _ = fresh
bind name addr m = local (Map.insert name addr) m
@ -151,7 +151,7 @@ concreteAnalysis = Analysis{..}
pure (val >>= lookupConcrete heap n)
lookupConcrete :: Heap term -> User -> Concrete term -> Maybe Precise
lookupConcrete :: Heap term -> Name -> Concrete term -> Maybe Precise
lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete
where -- look up the name in a concrete value
inConcrete = inFrame <=< maybeA . recordFrame
@ -177,7 +177,7 @@ runHeap = runState mempty
-- > λ let (heap, res) = concrete [ruby]
-- > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap))
-- > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg
heapGraph :: (Precise -> Concrete term -> a) -> (Either Edge User -> Precise -> G.Graph a) -> Heap term -> G.Graph a
heapGraph :: (Precise -> Concrete term -> a) -> (Either Edge Name -> Precise -> G.Graph a) -> Heap term -> G.Graph a
heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest
outgoing = \case
@ -211,7 +211,7 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
data EdgeType term
= Edge Edge
| Slot User
| Slot Name
| Value (Concrete term)
deriving (Eq, Ord, Show)

32
semantic-core/src/Analysis/Eval.hs
View File

@ -33,9 +33,9 @@ eval :: ( Carrier sig m
, MonadFail m
, Semigroup value
)
=> Analysis (Term (Ann :+: Core) User) address value m
-> (Term (Ann :+: Core) User -> m value)
-> (Term (Ann :+: Core) User -> m value)
=> Analysis (Term (Ann :+: Core) Name) address value m
-> (Term (Ann :+: Core) Name -> m value)
-> (Term (Ann :+: Core) Name -> m value)
eval Analysis{..} eval = \case
Var n -> lookupEnv' n >>= deref' n
Term (R c) -> case c of
@ -93,30 +93,30 @@ eval Analysis{..} eval = \case
Term (L (Ann loc c)) -> local (const loc) (ref c)
prog1 :: (Carrier sig t, Member Core sig) => File (t User)
prog1 :: (Carrier sig t, Member Core sig) => File (t Name)
prog1 = fromBody $ lam (named' "foo")
( named' "bar" :<- pure "foo"
>>>= Core.if' (pure "bar")
(Core.bool False)
(Core.bool True))
prog2 :: (Carrier sig t, Member Core sig) => File (t User)
prog2 :: (Carrier sig t, Member Core sig) => File (t Name)
prog2 = fromBody $ fileBody prog1 $$ Core.bool True
prog3 :: (Carrier sig t, Member Core sig) => File (t User)
prog3 :: (Carrier sig t, Member Core sig) => File (t Name)
prog3 = fromBody $ lams [named' "foo", named' "bar", named' "quux"]
(Core.if' (pure "quux")
(pure "bar")
(pure "foo"))
prog4 :: (Carrier sig t, Member Core sig) => File (t User)
prog4 :: (Carrier sig t, Member Core sig) => File (t Name)
prog4 = fromBody
( named' "foo" :<- Core.bool True
>>>= Core.if' (pure "foo")
(Core.bool True)
(Core.bool False))
prog5 :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t User)
prog5 :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t Name)
prog5 = fromBody $ ann (do'
[ Just (named' "mkPoint") :<- lams [named' "_x", named' "_y"] (ann (Core.record
[ ("x", ann (pure "_x"))
@ -127,7 +127,7 @@ prog5 = fromBody $ ann (do'
, Nothing :<- ann (ann (pure "point") Core.... "y") .= ann (ann (pure "point") Core.... "x")
])
prog6 :: (Carrier sig t, Member Core sig) => [File (t User)]
prog6 :: (Carrier sig t, Member Core sig) => [File (t Name)]
prog6 =
[ File (Loc "dep" (locSpan (fromJust here))) $ Core.record
[ ("dep", Core.record [ ("var", Core.bool True) ]) ]
@ -137,7 +137,7 @@ prog6 =
])
]
ruby :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t User)
ruby :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t Name)
ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' statements))
where statements =
[ Just "Class" :<- record
@ -215,18 +215,18 @@ ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' stateme
data Analysis term address value m = Analysis
{ alloc :: User -> m address
, bind :: forall a . User -> address -> m a -> m a
, lookupEnv :: User -> m (Maybe address)
{ alloc :: Name -> m address
, bind :: forall a . Name -> address -> m a -> m a
, lookupEnv :: Name -> m (Maybe address)
, deref :: address -> m (Maybe value)
, assign :: address -> value -> m ()
, abstract :: (term -> m value) -> User -> term -> m value
, abstract :: (term -> m value) -> Name -> term -> m value
, apply :: (term -> m value) -> value -> value -> m value
, unit :: m value
, bool :: Bool -> m value
, asBool :: value -> m Bool
, string :: Text -> m value
, asString :: value -> m Text
, record :: [(User, value)] -> m value
, (...) :: address -> User -> m (Maybe address)
, record :: [(Name, value)] -> m value
, (...) :: address -> Name -> m (Maybe address)
}

16
semantic-core/src/Analysis/ImportGraph.hs
View File

@ -41,7 +41,7 @@ instance Monoid (Value term) where
mempty = Value Abstract mempty
data Semi term
= Closure Loc User term
= Closure Loc Name term
-- FIXME: Bound String values.
| String Text
| Abstract
@ -52,12 +52,12 @@ importGraph
:: (Ord term, Show term)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis term User (Value term) m
=> Analysis term Name (Value term) m
-> (term -> m (Value term))
-> (term -> m (Value term))
)
-> [File term]
-> ( Heap User (Value term)
-> ( Heap Name (Value term)
, [File (Either (Loc, String) (Value term))]
)
importGraph eval
@ -70,13 +70,13 @@ runFile
:: ( Carrier sig m
, Effect sig
, Member Fresh sig
, Member (State (Heap User (Value term))) sig
, Member (State (Heap Name (Value term))) sig
, Ord term
, Show term
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis term User (Value term) m
=> Analysis term Name (Value term) m
-> (term -> m (Value term))
-> (term -> m (Value term))
)
@ -86,18 +86,18 @@ runFile eval file = traverse run file
where run = runReader (fileLoc file)
. runFailWithLoc
. fmap fold
. convergeTerm (Proxy @User) (fix (cacheTerm . eval importGraphAnalysis))
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval importGraphAnalysis))
-- FIXME: decompose into a product domain and two atomic domains
importGraphAnalysis :: ( Alternative m
, Carrier sig m
, Member (Reader Loc) sig
, Member (State (Heap User (Value term))) sig
, Member (State (Heap Name (Value term))) sig
, MonadFail m
, Ord term
, Show term
)
=> Analysis term User (Value term) m
=> Analysis term Name (Value term) m
importGraphAnalysis = Analysis{..}
where alloc = pure
bind _ _ m = m

18
semantic-core/src/Analysis/ScopeGraph.hs
View File

@ -50,12 +50,12 @@ scopeGraph
:: Ord term
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis term User ScopeGraph m
=> Analysis term Name ScopeGraph m
-> (term -> m ScopeGraph)
-> (term -> m ScopeGraph)
)
-> [File term]
-> (Heap User ScopeGraph, [File (Either (Loc, String) ScopeGraph)])
-> (Heap Name ScopeGraph, [File (Either (Loc, String) ScopeGraph)])
scopeGraph eval
= run
. runFresh
@ -66,12 +66,12 @@ runFile
:: ( Carrier sig m
, Effect sig
, Member Fresh sig
, Member (State (Heap User ScopeGraph)) sig
, Member (State (Heap Name ScopeGraph)) sig
, Ord term
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis term User ScopeGraph m
=> Analysis term Name ScopeGraph m
-> (term -> m ScopeGraph)
-> (term -> m ScopeGraph)
)
@ -79,19 +79,19 @@ runFile
-> m (File (Either (Loc, String) ScopeGraph))
runFile eval file = traverse run file
where run = runReader (fileLoc file)
. runReader (Map.empty @User @Loc)
. runReader (Map.empty @Name @Loc)
. runFailWithLoc
. fmap fold
. convergeTerm (Proxy @User) (fix (cacheTerm . eval scopeGraphAnalysis))
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval scopeGraphAnalysis))
scopeGraphAnalysis
:: ( Alternative m
, Carrier sig m
, Member (Reader Loc) sig
, Member (Reader (Map.Map User Loc)) sig
, Member (State (Heap User ScopeGraph)) sig
, Member (Reader (Map.Map Name Loc)) sig
, Member (State (Heap Name ScopeGraph)) sig
)
=> Analysis term User ScopeGraph m
=> Analysis term Name ScopeGraph m
scopeGraphAnalysis = Analysis{..}
where alloc = pure
bind name _ m = do

18
semantic-core/src/Analysis/Typecheck.hs
View File

@ -43,7 +43,7 @@ data Monotype f a
| Unit
| String
| Arr (f a) (f a)
| Record (Map.Map User (f a))
| Record (Map.Map Name (f a))
deriving (Foldable, Functor, Generic1, Traversable)
type Type = Term Monotype Meta
@ -95,12 +95,12 @@ typecheckingFlowInsensitive
:: Ord term
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis term User Type m
=> Analysis term Name Type m
-> (term -> m Type)
-> (term -> m Type)
)
-> [File term]
-> ( Heap User Type
-> ( Heap Name Type
, [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))]
)
typecheckingFlowInsensitive eval
@ -114,12 +114,12 @@ runFile
:: ( Carrier sig m
, Effect sig
, Member Fresh sig
, Member (State (Heap User Type)) sig
, Member (State (Heap Name Type)) sig
, Ord term
)
=> (forall sig m
. (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
=> Analysis term User Type m
=> Analysis term Name Type m
-> (term -> m Type)
-> (term -> m Type)
)
@ -129,7 +129,7 @@ runFile eval file = traverse run file
where run
= (\ m -> do
(subst, t) <- m
modify @(Heap User Type) (fmap (Set.map (substAll subst)))
modify @(Heap Name Type) (fmap (Set.map (substAll subst)))
pure (substAll subst <$> t))
. runState (mempty :: Substitution)
. runReader (fileLoc file)
@ -142,16 +142,16 @@ runFile eval file = traverse run file
v <- meta
bs <- m
v <$ for_ bs (unify v))
. convergeTerm (Proxy @User) (fix (cacheTerm . eval typecheckingAnalysis))
. convergeTerm (Proxy @Name) (fix (cacheTerm . eval typecheckingAnalysis))
typecheckingAnalysis
:: ( Alternative m
, Carrier sig m
, Member Fresh sig
, Member (State (Set.Set Constraint)) sig
, Member (State (Heap User Type)) sig
, Member (State (Heap Name Type)) sig
)
=> Analysis term User Type m
=> Analysis term Name Type m
typecheckingAnalysis = Analysis{..}
where alloc = pure
bind _ _ m = m

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

@ -71,9 +71,9 @@ data Core f a
-- | Load the specified file (by path).
| Load (f a)
-- | A record mapping some keys to some values.
| Record [(User, f a)]
| Record [(Name, f a)]
-- | Projection from a record.
| f a :. User
| f a :. Name
-- | Assignment of a value to the reference returned by the lhs.
| f a := f a
deriving (Foldable, Functor, Generic1, Traversable)
@ -198,10 +198,10 @@ string = send . String
load :: (Carrier sig m, Member Core sig) => m a -> m a
load = send . Load
record :: (Carrier sig m, Member Core sig) => [(User, m a)] -> m a
record :: (Carrier sig m, Member Core sig) => [(Name, m a)] -> m a
record fs = send (Record fs)
(...) :: (Carrier sig m, Member Core sig) => m a -> User -> m a
(...) :: (Carrier sig m, Member Core sig) => m a -> Name -> m a
a ... b = send (a :. b)
infixl 9 ...

34
semantic-core/src/Data/Core/Parser.hs
View File

@ -46,23 +46,23 @@ identifier = choice [quote, plain] <?> "identifier" where
-- * Parsers (corresponding to EBNF)
core :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
core :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
core = expr
expr :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
expr :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
expr = ifthenelse <|> lambda <|> rec <|> load <|> assign
assign :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
assign :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
assign = application <**> (symbolic '=' *> rhs <|> pure id) <?> "assignment"
where rhs = flip (Core..=) <$> application
application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
application = projection `chainl1` (pure (Core.$$))
projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
projection = foldl' (Core....) <$> atom <*> many (namedValue <$ dot <*> name)
atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
atom = choice
[ comp
, lit
@ -70,29 +70,29 @@ atom = choice
, parens expr
]
comp :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
comp :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) <?> "compound statement"
statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named User) :<- t User)
statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named Name) :<- t Name)
statement
= try ((:<-) . Just <$> name <* symbol "<-" <*> expr)
<|> (Nothing :<-) <$> expr
<?> "statement"
ifthenelse :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
ifthenelse :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
ifthenelse = Core.if'
<$ reserved "if" <*> expr
<* reserved "then" <*> expr
<* reserved "else" <*> expr
<?> "if-then-else statement"
rec :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
rec :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
rec = Core.rec <$ reserved "rec" <*> name <* symbolic '=' <*> expr <?> "recursive binding"
load :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
load :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
load = Core.load <$ reserved "load" <*> expr
lvalue :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
lvalue :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
lvalue = choice
[ projection
, ident
@ -101,10 +101,10 @@ lvalue = choice
-- * Literals
name :: (TokenParsing m, Monad m) => m (Named User)
name :: (TokenParsing m, Monad m) => m (Named Name)
name = named' <$> identifier <?> "name"
lit :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
lit :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
lit = let x `given` n = x <$ reserved n in choice
[ Core.bool True `given` "#true"
, Core.bool False `given` "#false"
@ -113,13 +113,13 @@ lit = let x `given` n = x <$ reserved n in choice
, Core.string <$> stringLiteral
] <?> "literal"
record :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
record :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma)
lambda :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
lambda :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
lambda = Core.lam <$ lambduh <*> name <* arrow <*> expr <?> "lambda" where
lambduh = symbolic 'λ' <|> symbolic '\\'
arrow = symbol "→" <|> symbol "->"
ident :: (Applicative t, Monad m, TokenParsing m) => m (t User)
ident :: (Applicative t, Monad m, TokenParsing m) => m (t Name)
ident = pure . namedValue <$> name <?> "identifier"

12
semantic-core/src/Data/Core/Pretty.hs
View File

@ -19,16 +19,16 @@ import Data.Text.Prettyprint.Doc
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty
showCore :: Term Core User -> String
showCore :: Term Core Name -> String
showCore = Pretty.renderString . layoutSmart defaultLayoutOptions . unAnnotate . prettyCore Ascii
printCore :: Term Core User -> IO ()
printCore :: Term Core Name -> IO ()
printCore p = Pretty.putDoc (prettyCore Unicode p) *> putStrLn ""
showFile :: File (Term Core User) -> String
showFile :: File (Term Core Name) -> String
showFile = showCore . fileBody
printFile :: File (Term Core User) -> IO ()
printFile :: File (Term Core Name) -> IO ()
printFile = printCore . fileBody
type AnsiDoc = Doc Pretty.AnsiStyle
@ -41,10 +41,10 @@ primitive = keyword . mappend "#"
data Style = Unicode | Ascii
name :: User -> AnsiDoc
name :: Name -> AnsiDoc
name n = if needsQuotation n then enclose (symbol "#{") (symbol "}") (pretty n) else pretty n
prettyCore :: Style -> Term Core User -> AnsiDoc
prettyCore :: Style -> Term Core Name -> AnsiDoc
prettyCore style = precBody . go . fmap name
where go = \case
Var v -> atom v

16
semantic-core/src/Data/Name.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE DeriveTraversable, LambdaCase, OverloadedLists #-}
module Data.Name
( User
( Name
, Named(..)
, named
, named'
@ -18,19 +18,19 @@ import qualified Data.HashSet as HashSet
import Data.Text as Text (Text, any, unpack)
-- | User-specified and -relevant names.
type User = Text
type Name = Text
-- | Annotates an @a@ with a 'User'-provided name, which is ignored for '==' and 'compare'.
data Named a = Named (Ignored User) a
-- | Annotates an @a@ with a 'Name'-provided name, which is ignored for '==' and 'compare'.
data Named a = Named (Ignored Name) a
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
named :: User -> a -> Named a
named :: Name -> a -> Named a
named = Named . Ignored
named' :: User -> Named User
named' :: Name -> Named Name
named' u = Named (Ignored u) u
namedName :: Named a -> User
namedName :: Named a -> Name
namedName (Named (Ignored n) _) = n
namedValue :: Named a -> a
@ -49,7 +49,7 @@ reservedNames = [ "#true", "#false", "if", "then", "else"
-- | Returns true if any character would require quotation or if the
-- name conflicts with a Core primitive.
needsQuotation :: User -> Bool
needsQuotation :: Name -> Bool
needsQuotation u = HashSet.member (unpack u) reservedNames || Text.any (not . isSimpleCharacter) u
-- | A ‘simple’ character is, loosely defined, a character that is compatible

20
semantic-core/test/Generators.hs
View File

@ -26,20 +26,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 User)
name :: MonadGen m => m (Named Name)
name = Gen.prune (named' <$> names) where
names = Gen.text (Range.linear 1 10) Gen.lower
boolean :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User)
boolean :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name)
boolean = Core.bool <$> Gen.bool
variable :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User)
variable :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name)
variable = pure . namedValue <$> name
ifthenelse :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User) -> m (t User)
ifthenelse :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name)
ifthenelse bod = Gen.subterm3 boolean bod bod Core.if'
apply :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User) -> m (t User)
apply :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name)
apply gen = go where
go = Gen.recursive
Gen.choice
@ -48,21 +48,21 @@ apply gen = go where
, Gen.subtermM go (\x -> Core.lam <$> name <*> pure x)
]
lambda :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User) -> m (t User)
lambda :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name)
lambda bod = do
arg <- name
Gen.subterm bod (Core.lam arg)
record :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User) -> m (t User)
record :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name)
record bod = Core.record <$> Gen.list (Range.linear 0 5) ((,) . namedValue <$> name <*> bod)
atoms :: (Carrier sig t, Member Core.Core sig, MonadGen m) => [m (t User)]
atoms :: (Carrier sig t, Member Core.Core sig, MonadGen m) => [m (t Name)]
atoms = [variable, pure Core.unit, boolean, Core.string <$> Gen.text (Range.linear 1 10) Gen.lower]
literal :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User)
literal :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name)
literal = Gen.recursive Gen.choice atoms [lambda literal, record literal]
expr :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t User)
expr :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name)
expr = Gen.recursive Gen.choice atoms
[ Gen.subtermM expr (\x -> flip Core.rec x <$> name)
, Gen.subterm2 expr expr (Core.>>>)

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

@ -21,7 +21,7 @@ import Data.Term
-- * Helpers
true, false :: Term (Ann :+: Core) User
true, false :: Term (Ann :+: Core) Name
true = bool True
false = bool False
@ -31,7 +31,7 @@ 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 (Ann :+: Core) User) -> Property
prop_roundtrips :: Gen (Term (Ann :+: Core) Name) -> Property
prop_roundtrips gen = property $ do
input <- forAll gen
tripping input (showCore . stripAnnotations) (parseEither (Parse.core <* Trifecta.eof))
@ -47,7 +47,7 @@ parserProps = testGroup "Parsing: roundtripping"
-- * Parser specs
parsesInto :: String -> Term (Ann :+: Core) User -> Assertion
parsesInto :: String -> Term (Ann :+: Core) Name -> Assertion
parsesInto str res = case parseEither Parse.core str of
Right x -> x @?= res
Left m -> assertFailure m
@ -57,7 +57,7 @@ assert_booleans_parse = do
parseEither Parse.core "#true" @?= Right true
parseEither Parse.core "#false" @?= Right false
a, f, g, h :: Term (Ann :+: Core) User
a, f, g, h :: Term (Ann :+: Core) Name
(a, f, g, h) = (pure "a", pure "f", pure "g", pure "h")
assert_ifthen_parse :: Assertion
@ -93,7 +93,7 @@ parserSpecs = testGroup "Parsing: simple specs"
, testCase "quoted names" assert_quoted_name_parse
]
assert_roundtrips :: File (Term (Ann :+: Core) User) -> Assertion
assert_roundtrips :: File (Term (Ann :+: Core) Name) -> Assertion
assert_roundtrips (File _ core) = case parseEither Parse.core (showCore (stripAnnotations core)) of
Right v -> stripAnnotations v @?= stripAnnotations core
Left e -> assertFailure e