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

Redefine records as a flat list of bindings.

Browse Source
This commit is contained in:
Rob Rix 2019-07-19 14:21:39 -04:00
parent f373ca410f
commit 1398c995a0
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 5 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)

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

@ -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"