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

Derive the RightModule instance for Core.

Browse Source
This commit is contained in:
Rob Rix 2019-10-28 13:26:15 -04:00
parent 8d751c1dbc
commit a8333adae0
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 1 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -92,28 +92,13 @@ infix 3 :=
instance HFunctor Core
instance Effect Traversable Core
instance RightModule Core
deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Core f a)
deriving instance (Ord a, forall a . Eq a => Eq (f a)
, forall a . Ord a => Ord (f a), Monad f) => Ord (Core f a)
deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Core f a)
instance RightModule Core where
Rec b >>=* f = Rec ((>>=* f) <$> b)
(a :>> b) >>=* f = (a >>= f) :>> (b >>= f)
(a :>>= b) >>=* f = ((>>= f) <$> a) :>>= (b >>=* f)
Lam b >>=* f = Lam ((>>=* f) <$> b)
(a :$ b) >>=* f = (a >>= f) :$ (b >>= f)
Unit >>=* _ = Unit
Bool b >>=* _ = Bool b
If c t e >>=* f = If (c >>= f) (t >>= f) (e >>= f)
String s >>=* _ = String s
Load b >>=* f = Load (b >>= f)
Record fs >>=* f = Record (map (fmap (>>= f)) fs)
(a :. b) >>=* f = (a >>= f) :. b
(a :? b) >>=* f = (a >>= f) :. b
(a := b) >>=* f = (a >>= f) := (b >>= f)
rec :: (Eq a, Has Core sig m) => Named a -> m a -> m a
rec (Named u n) b = send (Rec (Named u (abstract1 n b)))