github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Rename the Term constructor to Alg.

Browse Source
This commit is contained in:
Rob Rix 2019-10-10 15:12:44 -04:00
parent 87282872e6
commit cde9635319
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
5 changed files with 32 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -39,7 +39,7 @@ eval :: ( Carrier sig m
-> (Term (Ann Span :+: Core) Name -> m value)
eval Analysis{..} eval = \case
Var n -> lookupEnv' n >>= deref' n
Term (R c) -> case c of
Alg (R c) -> case c of
Rec (Named (Ignored n) b) -> do
addr <- alloc n
v <- bind n addr (eval (instantiate1 (pure n) b))
@ -73,7 +73,7 @@ eval Analysis{..} eval = \case
b' <- eval b
addr <- ref a
b' <$ assign addr b'
Term (L (Ann span c)) -> local (const span) (eval c)
Alg (L (Ann span c)) -> local (const span) (eval c)
where freeVariable s = fail ("free variable: " <> s)
uninitialized s = fail ("uninitialized variable: " <> s)
invalidRef s = fail ("invalid ref: " <> s)
@ -83,7 +83,7 @@ eval Analysis{..} eval = \case
ref = \case
Var n -> lookupEnv' n
Term (R c) -> case c of
Alg (R c) -> case c of
If c t e -> do
c' <- eval c >>= asBool
if c' then ref t else ref e
@ -91,7 +91,7 @@ eval Analysis{..} eval = \case
a' <- ref a
a' ... b >>= maybe (freeVariable (show b)) pure
c -> invalidRef (show c)
Term (L (Ann span c)) -> local (const span) (ref c)
Alg (L (Ann span c)) -> local (const span) (ref c)
prog1 :: (Carrier sig t, Member Core sig) => File (t Name)

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

@ -166,24 +166,24 @@ typecheckingAnalysis = Analysis{..}
arg <- meta
assign addr arg
ty <- eval body
pure (Term (Arr arg ty))
pure (Alg (Arr arg ty))
apply _ f a = do
_A <- meta
_B <- meta
unify (Term (Arr _A _B)) f
unify (Alg (Arr _A _B)) f
unify _A a
pure _B
unit = pure (Term Unit)
bool _ = pure (Term Bool)
asBool b = unify (Term Bool) b >> pure True <|> pure False
string _ = pure (Term String)
asString s = unify (Term String) s $> mempty
unit = pure (Alg Unit)
bool _ = pure (Alg Bool)
asBool b = unify (Alg Bool) b >> pure True <|> pure False
string _ = pure (Alg String)
asString s = unify (Alg String) s $> mempty
record fields = do
fields' <- for fields $ \ (k, v) -> do
addr <- alloc k
(k, v) <$ assign addr v
-- FIXME: should records reference types by address instead?
pure (Term (Record (Map.fromList fields')))
pure (Alg (Record (Map.fromList fields')))
_ ... m = pure (Just m)
@ -212,8 +212,8 @@ solve :: (Carrier sig m, Member (State Substitution) sig, MonadFail m) => Set.Se
solve cs = for_ cs solve
where solve = \case
-- FIXME: how do we enforce proper subtyping? row polymorphism or something?
Term (Record f1) :===: Term (Record f2) -> traverse solve (Map.intersectionWith (:===:) f1 f2) $> ()
Term (Arr a1 b1) :===: Term (Arr a2 b2) -> solve (a1 :===: a2) *> solve (b1 :===: b2)
Alg (Record f1) :===: Alg (Record f2) -> traverse solve (Map.intersectionWith (:===:) f1 f2) $> ()
Alg (Arr a1 b1) :===: Alg (Arr a2 b2) -> solve (a1 :===: a2) *> solve (b1 :===: b2)
Var m1 :===: Var m2 | m1 == m2 -> pure ()
Var m1 :===: t2 -> do
sol <- solution m1

22
semantic-core/src/Core/Core.hs
View File

@ -118,8 +118,8 @@ a >>> b = send (a :>> b)
infixr 1 >>>
unseq :: (Alternative m, Member Core sig) => Term sig a -> m (Term sig a, Term sig a)
unseq (Term sig) | Just (a :>> b) <- prj sig = pure (a, b)
unseq _ = empty
unseq (Alg sig) | Just (a :>> b) <- prj sig = pure (a, b)
unseq _ = empty
unseqs :: Member Core sig => Term sig a -> NonEmpty (Term sig a)
unseqs = go
@ -135,8 +135,8 @@ Named u n :<- a >>>= b = send (Named u a :>>= abstract1 n b)
infixr 1 >>>=
unbind :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Named a :<- Term sig a, Term sig a)
unbind n (Term sig) | Just (Named u a :>>= b) <- prj sig = pure (Named u n :<- a, instantiate1 (pure n) b)
unbind _ _ = empty
unbind n (Alg sig) | Just (Named u a :>>= b) <- prj sig = pure (Named u n :<- a, instantiate1 (pure n) b)
unbind _ _ = empty
unstatement :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Maybe (Named a) :<- Term sig a, Term sig a)
unstatement n t = first (first Just) <$> unbind n t <|> first (Nothing :<-) <$> unseq t
@ -164,8 +164,8 @@ lams :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t (Named a) -> m a
lams names body = foldr lam body names
unlam :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Named a, Term sig a)
unlam n (Term sig) | Just (Lam b) <- prj sig = pure (n <$ b, instantiate1 (pure n) (namedValue b))
unlam _ _ = empty
unlam n (Alg sig) | Just (Lam b) <- prj sig = pure (n <$ b, instantiate1 (pure n) (namedValue b))
unlam _ _ = empty
($$) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a
f $$ a = send (f :$ a)
@ -179,8 +179,8 @@ infixl 8 $$
infixl 8 $$*
unapply :: (Alternative m, Member Core sig) => Term sig a -> m (Term sig a, Term sig a)
unapply (Term sig) | Just (f :$ a) <- prj sig = pure (f, a)
unapply _ = empty
unapply (Alg sig) | Just (f :$ a) <- prj sig = pure (f, a)
unapply _ = empty
unapplies :: Member Core sig => Term sig a -> (Term sig a, Stack (Term sig a))
unapplies core = case unapply core of
@ -237,6 +237,6 @@ annWith callStack = maybe id (annAt . snd) (stackLoc callStack)
stripAnnotations :: forall ann a sig . (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann ann :+: sig) a -> Term sig a
stripAnnotations (Var v) = Var v
stripAnnotations (Term (L (Ann _ b))) = stripAnnotations b
stripAnnotations (Term (R b)) = Term (hmap stripAnnotations b)
stripAnnotations (Var v) = Var v
stripAnnotations (Alg (L (Ann _ b))) = stripAnnotations b
stripAnnotations (Alg (R b)) = Alg (hmap stripAnnotations b)

4
semantic-core/src/Core/Core/Pretty.hs
View File

@ -48,7 +48,7 @@ prettyCore :: Style -> Term Core Name -> AnsiDoc
prettyCore style = precBody . go . fmap name
where go = \case
Var v -> atom v
Term t -> case t of
Alg t -> case t of
Rec (Named (Ignored x) b) -> prec 3 . group . nest 2 $ vsep
[ keyword "rec" <+> name x
, symbol "=" <+> align (withPrec 0 (go (instantiate1 (pure (name x)) b)))
@ -80,7 +80,7 @@ prettyCore style = precBody . go . fmap name
]
statement ->
let (bindings, return) = unstatements (Term statement)
let (bindings, return) = unstatements (Alg statement)
statements = toList (bindings :> (Nothing :<- return))
names = zipWith (\ i (n :<- _) -> maybe (pretty @Int i) (name . namedName) n) [0..] statements
statements' = map (prettyStatement names) statements

10
semantic-core/src/Core/Term.hs
View File

@ -10,7 +10,7 @@ import Control.Monad.Module
data Term sig a
= Var a
| Term (sig (Term sig) a)
| Alg (sig (Term sig) a)
deriving instance ( Eq a
, RightModule sig
@ -37,14 +37,14 @@ instance RightModule sig => Applicative (Term sig) where
(<*>) = ap
instance RightModule sig => Monad (Term sig) where
Var a >>= f = f a
Term t >>= f = Term (t >>=* f)
Var a >>= f = f a
Alg t >>= f = Alg (t >>=* f)
instance RightModule sig => Carrier sig (Term sig) where
eff = Term
eff = Alg
hoistTerm :: (HFunctor sig, forall g . Functor g => Functor (sig g)) => (forall m x . sig m x -> sig' m x) -> Term sig a -> Term sig' a
hoistTerm f = go
where go (Var v) = Var v
go (Term t) = Term (f (hmap (hoistTerm f) t))
go (Alg t) = Alg (f (hmap (hoistTerm f) t))