From fde3424c1320d49d5b12bbbbfdadaeb194cb471e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Jul 2019 12:32:47 -0400 Subject: [PATCH 1/8] Dedent all the Analysis fields. --- semantic-core/src/Analysis/Eval.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs index 2e68a8530f..547b507194 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -210,18 +210,18 @@ ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' stateme data Analysis address value m = Analysis - { alloc :: User -> m address - , bind :: forall a . User -> address -> m a -> m a - , lookupEnv :: User -> m (Maybe address) - , deref :: address -> m (Maybe value) - , assign :: address -> value -> m () - , abstract :: (Term Core User -> m value) -> User -> Term Core User -> m value - , apply :: (Term Core User -> m value) -> value -> value -> m value - , unit :: m value - , bool :: Bool -> m value - , asBool :: value -> m Bool - , string :: Text -> m value - , asString :: value -> m Text - , record :: [(User, value)] -> m value - , (...) :: address -> User -> m (Maybe address) + { alloc :: User -> m address + , bind :: forall a . User -> address -> m a -> m a + , lookupEnv :: User -> m (Maybe address) + , deref :: address -> m (Maybe value) + , assign :: address -> value -> m () + , abstract :: (Term Core User -> m value) -> User -> Term Core User -> m value + , apply :: (Term Core User -> m value) -> value -> value -> m value + , unit :: m value + , bool :: Bool -> m value + , asBool :: value -> m Bool + , string :: Text -> m value + , asString :: value -> m Text + , record :: [(User, value)] -> m value + , (...) :: address -> User -> m (Maybe address) } From 7d9100f81649d6ebdbe56892a532e8d88b59f934 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Jul 2019 12:33:00 -0400 Subject: [PATCH 2/8] Derive a Semigroup instance for Concrete. --- semantic-core/src/Analysis/Concrete.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/semantic-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index fab556ad2d..c3cdc3fff9 100644 --- a/semantic-core/src/Analysis/Concrete.hs +++ b/semantic-core/src/Analysis/Concrete.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-} module Analysis.Concrete ( Concrete(..) , concrete @@ -28,6 +28,7 @@ import qualified Data.IntSet as IntSet import Data.Loc import qualified Data.Map as Map import Data.Name +import Data.Semigroup (Last (..)) import qualified Data.Set as Set import Data.Term import Data.Text (Text, pack) @@ -47,6 +48,7 @@ data Concrete | String Text | Record Env deriving (Eq, Ord, Show) + deriving Semigroup via Last Concrete recordFrame :: Concrete -> Maybe Env recordFrame (Record frame) = Just frame From cd950fd6ec3e452975672cb03a51c4177ff3e63c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Jul 2019 12:33:13 -0400 Subject: [PATCH 3/8] Derive a Semigroup instance for Term Monotype a. --- semantic-core/src/Analysis/Typecheck.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index f2bf865964..b007bf1807 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, OverloadedStrings, QuantifiedConstraints, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators #-} +{-# LANGUAGE DeriveGeneric, DeriveTraversable, DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, OverloadedStrings, QuantifiedConstraints, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators #-} module Analysis.Typecheck ( Monotype (..) , Meta @@ -30,6 +30,7 @@ import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe) import Data.Name as Name import Data.Scope +import Data.Semigroup (Last (..)) import qualified Data.Set as Set import Data.Term import Data.Void @@ -44,6 +45,9 @@ data Monotype f a | Record (Map.Map User (f a)) deriving (Foldable, Functor, Generic1, Traversable) +-- FIXME: Union the effects/annotations on the operands. +deriving via (Last (Term Monotype a)) instance Semigroup (Term Monotype a) + deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Monotype f a) deriving instance (Ord a, forall a . Eq a => Eq (f a) , forall a . Ord a => Ord (f a), Monad f) => Ord (Monotype f a) From 0f34dcec4573566fe48b1f05649f55e4c916bc40 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Jul 2019 12:33:33 -0400 Subject: [PATCH 4/8] Sequence values in the abstract domain. --- semantic-core/src/Analysis/Eval.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs index 547b507194..e02ddfce2f 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -30,6 +30,7 @@ import Prelude hiding (fail) eval :: ( Carrier sig m , Member (Reader Loc) sig , MonadFail m + , Semigroup value ) => Analysis address value m -> (Term Core User -> m value) @@ -41,12 +42,12 @@ eval Analysis{..} eval = \case addr <- alloc n v <- bind n addr (eval (instantiate1 (pure n) b)) v <$ assign addr v - a :>> b -> eval a >> eval b + a :>> b -> (<>) <$> eval a <*> eval b Named (Ignored n) a :>>= b -> do a' <- eval a addr <- alloc n assign addr a' - bind n addr (eval (instantiate1 (pure n) b)) + bind n addr ((a' <>) <$> eval (instantiate1 (pure n) b)) Lam (Named (Ignored n) b) -> abstract eval n (instantiate1 (pure n) b) f :$ a -> do f' <- eval f From 559a7aa59caef234c236703f2375442fc4f7b871 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Aug 2019 13:41:45 -0400 Subject: [PATCH 5/8] :memo: the Semigroup use. --- semantic-core/src/Analysis/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs index e02ddfce2f..15abe28087 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/semantic-core/src/Analysis/Eval.hs @@ -42,6 +42,9 @@ eval Analysis{..} eval = \case addr <- alloc n v <- bind n addr (eval (instantiate1 (pure n) b)) v <$ assign addr v + -- NB: Combining the results of the evaluations allows us to model effects in abstract domains. This in turn means that we can define an abstract domain modelling the types-and-effects of computations by means of a 'Semigroup' instance which takes the type of its second operand and the union of both operands’ effects. + -- + -- It’s also worth noting that we use a semigroup instead of a semilattice because the lattice structure of our abstract domains is instead modelled by nondeterminism effects used by some of them. a :>> b -> (<>) <$> eval a <*> eval b Named (Ignored n) a :>>= b -> do a' <- eval a From 82cb7e49b079ba9bbef799d0bdd9d8da204d7d05 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Aug 2019 13:43:37 -0400 Subject: [PATCH 6/8] :memo: the Semigroup instance for Term Monotype a. --- semantic-core/src/Analysis/Typecheck.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index b007bf1807..916b21559f 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -46,6 +46,8 @@ data Monotype f a deriving (Foldable, Functor, Generic1, Traversable) -- FIXME: Union the effects/annotations on the operands. + +-- | We derive the 'Semigroup' instance for types to take the second argument. This is equivalent to stating that the type of an imperative sequence of statements is the type of its final statement. deriving via (Last (Term Monotype a)) instance Semigroup (Term Monotype a) deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Monotype f a) From d6002466634d9ff39b05a7d718de9c9ec1529cbf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Aug 2019 13:44:21 -0400 Subject: [PATCH 7/8] :memo: the Semigroup instance for Concrete. --- semantic-core/src/Analysis/Concrete.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index 3b8718ab2d..78f79dc480 100644 --- a/semantic-core/src/Analysis/Concrete.hs +++ b/semantic-core/src/Analysis/Concrete.hs @@ -48,6 +48,7 @@ data Concrete | String Text | Record Env deriving (Eq, Ord, Show) + -- | We derive the 'Semigroup' instance for 'Concrete' to take the second argument. This is equivalent to stating that the return value of an imperative sequence of statements is the value of its final statement. deriving Semigroup via Last Concrete recordFrame :: Concrete -> Maybe Env From c2e620ac6ffbbccf6033987c6d4bec421c0a86ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Aug 2019 13:52:24 -0400 Subject: [PATCH 8/8] =?UTF-8?q?Haddock=20doesn=E2=80=99t=20like=20this.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- semantic-core/src/Analysis/Concrete.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantic-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index 78f79dc480..7ae7801714 100644 --- a/semantic-core/src/Analysis/Concrete.hs +++ b/semantic-core/src/Analysis/Concrete.hs @@ -48,7 +48,7 @@ data Concrete | String Text | Record Env deriving (Eq, Ord, Show) - -- | We derive the 'Semigroup' instance for 'Concrete' to take the second argument. This is equivalent to stating that the return value of an imperative sequence of statements is the value of its final statement. + -- NB: We derive the 'Semigroup' instance for 'Concrete' to take the second argument. This is equivalent to stating that the return value of an imperative sequence of statements is the value of its final statement. deriving Semigroup via Last Concrete recordFrame :: Concrete -> Maybe Env