Merge pull request #1661 from github/app-semigroup

App/AppMerge semigroups

semantic.cabal

@@ -72,6 +72,7 @@ library
                      , Data.Patch
                      , Data.Range
                      , Data.Record
+                     , Data.Semigroup.App
                      , Data.Source
                      , Data.Span
                      , Data.SplitDiff

src/Data/Abstract/Evaluatable.hs

@@ -16,6 +16,7 @@ import Data.Abstract.Value
 import Data.Functor.Classes
 import Data.Proxy
 import Data.Semigroup.Foldable
+import Data.Semigroup.App
 import Data.Term
 import Prelude hiding (fail)
 import Prologue
@@ -51,14 +52,4 @@ instance Evaluatable s => Evaluatable (TermF s a) where
 --   3. Only the last statement’s return value is returned.
 instance Evaluatable [] where
   -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
-  eval = maybe unit (runImperative . foldMap1 (Imperative . subtermValue)) . nonEmpty
-
--- | A 'Semigroup' providing an imperative context which extends the local environment with new bindings.
-newtype Imperative m a = Imperative { runImperative :: m a }
-
-instance MonadEnvironment value m => Semigroup (Imperative m a) where
-  Imperative a <> Imperative b = Imperative (a *> b)
-
-instance (MonadEnvironment value m, MonadValue value m) => Monoid (Imperative m value) where
-  mempty = Imperative unit
-  mappend = (<>)
+  eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty

src/Data/Semigroup/App.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Semigroup.App
+( App(..)
+, AppMerge(..)
+) where
+
+import Control.Applicative
+import Data.Semigroup
+
+-- $setup
+-- >>> import Test.QuickCheck
+-- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary ; shrink = map App . shrink . runApp
+-- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary ; shrink = map AppMerge . shrink . runAppMerge
+
+-- | 'Semigroup' under '*>'.
+newtype App f a = App { runApp :: f a }
+  deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
+
+-- $ Associativity:
+--   prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer)
+instance Applicative f => Semigroup (App f a) where
+  App a <> App b = App (a *> b)
+
+
+-- | 'Semigroup' and 'Monoid' under '<*>' and '<>'.
+newtype AppMerge f a = AppMerge { runAppMerge :: f a }
+  deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
+
+-- $ Associativity:
+--   prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String)
+instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where
+  AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b)
+
+-- $ Identity:
+--   prop> \ a -> mempty <> a == (a :: AppMerge Maybe String)
+--   prop> \ a -> a <> mempty == (a :: AppMerge Maybe String)
+instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where
+  mempty = AppMerge (pure mempty)
+  mappend = (<>)