mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Redefine records as a flat list of bindings.
This commit is contained in:
parent
f373ca410f
commit
1398c995a0
@ -37,7 +37,6 @@ import Control.Applicative (Alternative (..))
|
|||||||
import Control.Effect.Carrier
|
import Control.Effect.Carrier
|
||||||
import Control.Monad.Module
|
import Control.Monad.Module
|
||||||
import Data.Foldable (foldl')
|
import Data.Foldable (foldl')
|
||||||
import Data.List (elemIndex)
|
|
||||||
import Data.List.NonEmpty (NonEmpty (..))
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
import Data.Loc
|
import Data.Loc
|
||||||
import Data.Name
|
import Data.Name
|
||||||
@ -69,7 +68,7 @@ data Core f a
|
|||||||
-- | Allocation of a new frame.
|
-- | Allocation of a new frame.
|
||||||
| Frame
|
| Frame
|
||||||
-- | A record holding simultaneously-bound, potentially mutually-recursive definitions.
|
-- | A record holding simultaneously-bound, potentially mutually-recursive definitions.
|
||||||
| Record [Named (Scope Int f a)]
|
| Record [(User, f a)]
|
||||||
| f a :. f a
|
| f a :. f a
|
||||||
-- | Assignment of a value to the reference returned by the lhs.
|
-- | Assignment of a value to the reference returned by the lhs.
|
||||||
| f a := f a
|
| f a := f a
|
||||||
@ -101,7 +100,7 @@ instance RightModule Core where
|
|||||||
Load b >>=* f = Load (b >>= f)
|
Load b >>=* f = Load (b >>= f)
|
||||||
Edge e b >>=* f = Edge e (b >>= f)
|
Edge e b >>=* f = Edge e (b >>= f)
|
||||||
Frame >>=* _ = Frame
|
Frame >>=* _ = Frame
|
||||||
Record fs >>=* f = Record (map (fmap (>>=* f)) fs)
|
Record fs >>=* f = Record (map (fmap (>>= f)) fs)
|
||||||
(a :. b) >>=* f = (a >>= f) :. (b >>= f)
|
(a :. b) >>=* f = (a >>= f) :. (b >>= f)
|
||||||
(a := b) >>=* f = (a >>= f) := (b >>= f)
|
(a := b) >>=* f = (a >>= f) := (b >>= f)
|
||||||
Ann l b >>=* f = Ann l (b >>= f)
|
Ann l b >>=* f = Ann l (b >>= f)
|
||||||
@ -188,9 +187,8 @@ edge e b = send (Edge e b)
|
|||||||
frame :: (Carrier sig m, Member Core sig) => m a
|
frame :: (Carrier sig m, Member Core sig) => m a
|
||||||
frame = send Frame
|
frame = send Frame
|
||||||
|
|
||||||
record :: (Eq a, Carrier sig m, Member Core sig) => [(Named a, m a)] -> m a
|
record :: (Carrier sig m, Member Core sig) => [(User, m a)] -> m a
|
||||||
record fs = send (Record (map bind' fs))
|
record fs = send (Record fs)
|
||||||
where bind' (n, f) = bind (`elemIndex` map (namedValue . fst) fs) f <$ n
|
|
||||||
|
|
||||||
(...) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a
|
(...) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a
|
||||||
a ... b = send (a :. b)
|
a ... b = send (a :. b)
|
||||||
|
@ -86,7 +86,7 @@ prettyCore style = run . runReader @Prec 0 . go
|
|||||||
pure (lambda <> name x <+> arrow <+> body)
|
pure (lambda <> name x <+> arrow <+> body)
|
||||||
|
|
||||||
Record fs -> do
|
Record fs -> do
|
||||||
fs' <- for fs $ \ (Named (Ignored x) v) -> (name x <+> symbol "=" <+>) <$> go (instantiate (pure . namedName . (fs !!)) v)
|
fs' <- for fs $ \ (x, v) -> (name x <+> symbol "=" <+>) <$> go v
|
||||||
pure $ Pretty.encloseSep Pretty.lbrace Pretty.rbrace Pretty.semi fs'
|
pure $ Pretty.encloseSep Pretty.lbrace Pretty.rbrace Pretty.semi fs'
|
||||||
|
|
||||||
Frame -> pure $ primitive "frame"
|
Frame -> pure $ primitive "frame"
|
||||||
|
Loading…
Reference in New Issue
Block a user