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

Define block using a newtype helper.

Browse Source 
We can’t rely on having a Semigroup instance for the term type.
This commit is contained in:
Rob Rix 2019-07-17 11:42:16 -04:00
parent 1e3e8dd425
commit 3e53644a36
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 8 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, OverloadedStrings, QuantifiedConstraints, RankNTypes, {-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, OverloadedStrings, QuantifiedConstraints, RankNTypes,
ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-} ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Core module Data.Core
( Core(..) ( Core(..)
, CoreF(..) , CoreF(..)
@ -41,7 +41,6 @@ import Data.Coerce
import Data.Foldable (foldl') import Data.Foldable (foldl')
import Data.List.NonEmpty import Data.List.NonEmpty
import Data.Loc import Data.Loc
import Data.Maybe
import Data.Name import Data.Name
import Data.Scope import Data.Scope
import Data.Stack import Data.Stack
@ -127,8 +126,13 @@ infixl 4 :.
let' :: (Carrier sig m, Member CoreF sig) => User -> m a let' :: (Carrier sig m, Member CoreF sig) => User -> m a
let' = send . Let let' = send . Let
block :: (Foldable t, Carrier sig m, Member CoreF sig, Semigroup (m a)) => t (m a) -> m a block :: (Foldable t, Carrier sig m, Member CoreF sig) => t (m a) -> m a
block = fromMaybe unit . foldMap Just block = maybe unit getBlock . foldMap (Just . Block)
newtype Block m a = Block { getBlock :: m a }
instance (Carrier sig m, Member CoreF sig) => Semigroup (Block m a) where
Block a <> Block b = Block (send (a :>> b))
lam :: (Eq a, Carrier sig m, Member CoreF sig) => Named a -> m a -> m a lam :: (Eq a, Carrier sig m, Member CoreF sig) => Named a -> m a -> m a
lam (Named u n) b = send (Lam u (bind1 n b)) lam (Named u n) b = send (Lam u (bind1 n b))