Merge remote-tracking branch 'origin/master' into typescript-graphs

semantic.cabal

@@ -70,6 +70,7 @@ library
                      , Data.AST
                      , Data.Blob
                      , Data.Diff
+                     , Data.Empty
                      , Data.Error
                      , Data.Functor.Both
                      , Data.Functor.Classes.Generic

src/Analysis/Abstract/Evaluating.hs

@@ -2,6 +2,7 @@
 module Analysis.Abstract.Evaluating
 ( Evaluating
 , EvaluatingState(..)
+, State
 ) where
 
 import           Control.Abstract.Analysis
@@ -15,6 +16,7 @@ import           Data.Abstract.Heap
 import           Data.Abstract.Module
 import           Data.Abstract.ModuleTable
 import           Data.Abstract.Origin
+import           Data.Empty
 import qualified Data.IntMap as IntMap
 import           Lens.Micro
 import           Prelude hiding (fail)
@@ -60,9 +62,8 @@ deriving instance (Show (Cell location value), Show location, Show term, Show va
 instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
   EvaluatingState e1 h1 m1 l1 x1 j1 o1 <> EvaluatingState e2 h2 m2 l2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2)
 
-instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where
-  mempty = EvaluatingState mempty mempty mempty mempty mempty mempty mempty
-  mappend = (<>)
+instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatingState location term value) where
+  empty = EvaluatingState mempty mempty mempty mempty mempty mempty mempty
 
 _environment :: Lens' (EvaluatingState location term value) (Environment location value)
 _environment = lens environment (\ s e -> s {environment = e})

src/Control/Effect.hs

@@ -15,6 +15,7 @@ import Control.Monad.Effect.Reader
 import Control.Monad.Effect.Resumable
 import Control.Monad.Effect.State
 import Control.Monad.Effect.Writer
+import Data.Empty as E
 import Data.Semigroup.Reducer
 import Prologue
 
@@ -47,9 +48,9 @@ class RunEffect f a where
   runEffect :: Eff (f ': fs) a -> Eff fs (Result f a)
 
 -- | 'State' effects with 'Monoid'al states are interpreted starting from the 'mempty' state value into a pair of result value and final state.
-instance Monoid b => RunEffect (State b) a where
+instance E.Empty b => RunEffect (State b) a where
   type Result (State b) a = (a, b)
-  runEffect = flip runState mempty
+  runEffect = flip runState E.empty
 
 -- | 'Reader' effects with 'Monoid'al environments are interpreted starting from the 'mempty' environment value.
 instance Monoid b => RunEffect (Reader b) a where

src/Data/Empty.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Empty ( Empty (..) ) where
+
+-- | A typeclass for values that have a sensible notion of an empty value.
+-- This is used in Control.Effect to provide a useful default for running
+-- a State computation without providing it an explicit starting value.
+-- This is very useful if a type has no coherent Monoid instance but
+-- needs a value analogous to 'mempty'. It is not recommended to use this
+-- for other purposes, as there are no laws by which 'empty' is required
+-- to abide.
+class Empty a where
+  empty :: a
+
+-- | Every Monoid has an Empty instance.
+instance {-# OVERLAPS #-} Monoid a => Empty a where
+  empty = mempty