From b9cf8f73c64487b66cac652d1ab8d27fae20b846 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 31 Oct 2018 15:47:30 -0400 Subject: [PATCH] Environment and App. --- semantic.cabal | 11 ++--------- src/Data/Abstract/Environment.hs | 11 ----------- src/Data/Semigroup/App.hs | 13 ------------- test/Data/Abstract/Environment/Spec.hs | 21 +++++++++++++++++++++ test/Data/Functor/Listable.hs | 7 +++++++ test/Data/Semigroup/App/Spec.hs | 20 ++++++++++++++++++++ test/Spec.hs | 4 ++++ 7 files changed, 54 insertions(+), 33 deletions(-) create mode 100644 test/Data/Abstract/Environment/Spec.hs create mode 100644 test/Data/Semigroup/App/Spec.hs diff --git a/semantic.cabal b/semantic.cabal index a9027cb00..65e9e7bb7 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -332,6 +332,7 @@ test-suite test , Assigning.Assignment.Spec , Control.Abstract.Evaluator.Spec , Control.Rewriting.Spec + , Data.Abstract.Environment.Spec , Data.Abstract.Path.Spec , Data.Abstract.Name.Spec , Data.Diff.Spec @@ -341,6 +342,7 @@ test-suite test , Data.Mergeable , Data.Range.Spec , Data.Scientific.Spec + , Data.Semigroup.App.Spec , Data.Source.Spec , Data.Term.Spec , Diffing.Algorithm.RWS.Spec @@ -432,15 +434,6 @@ test-suite parse-examples default-extensions: RecordWildCards , FlexibleContexts -test-suite doctests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Doctests.hs - default-language: Haskell2010 - ghc-options: -dynamic -threaded -j - build-depends: base - , doctest - benchmark evaluation hs-source-dirs: bench/evaluation type: exitcode-stdio-1.0 diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index d0a9741d7..1e0ecfaf1 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -33,11 +33,6 @@ import qualified Data.Map as Map import Prelude hiding (head, lookup) import Prologue --- $setup --- >>> import Data.Abstract.Address.Precise --- >>> let bright = push (insertEnv (name "foo") (Precise 0) lowerBound) --- >>> let shadowed = insertEnv (name "foo") (Precise 1) bright - -- | A map of names to values. Represents a single scope level of an environment chain. newtype Bindings address = Bindings { unBindings :: Map.Map Name address } deriving stock (Eq, Ord, Generic) @@ -119,9 +114,6 @@ lookup :: Name -> Bindings address -> Maybe address lookup name = Map.lookup name . unBindings -- | Lookup a 'Name' in the environment. --- --- >>> lookupEnv' (name "foo") shadowed --- Just (Precise 1) lookupEnv' :: Name -> Environment address -> Maybe address lookupEnv' name = foldMapA (lookup name) . unEnvironment @@ -134,9 +126,6 @@ insertEnv :: Name -> address -> Environment address -> Environment address insertEnv name addr (Environment (Bindings a :| as)) = Environment (Bindings (Map.insert name addr a) :| as) -- | Remove a 'Name' from the environment. --- --- >>> delete (name "foo") shadowed --- Environment [] delete :: Name -> Environment address -> Environment address delete name = trim . Environment . fmap (Bindings . Map.delete name . unBindings) . unEnvironment diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index c11ff1a08..54455a986 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -6,33 +6,20 @@ module Data.Semigroup.App import Control.Applicative --- $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 = (<>) diff --git a/test/Data/Abstract/Environment/Spec.hs b/test/Data/Abstract/Environment/Spec.hs new file mode 100644 index 000000000..cb1345ef9 --- /dev/null +++ b/test/Data/Abstract/Environment/Spec.hs @@ -0,0 +1,21 @@ +module Data.Abstract.Environment.Spec where + +import Prelude hiding (head) +import SpecHelpers + +import Data.Abstract.Environment +import Data.Abstract.Address.Precise + +spec :: Spec +spec = describe "Environment" $ do + let bright = push (insertEnv (name "foo") (Precise 0) lowerBound) + let shadowed = insertEnv (name "foo") (Precise 1) bright + + it "can extract bindings" $ + pairs (head shadowed) `shouldBe` [("foo", Precise 1)] + + it "should extract the outermost binding given shadowing" $ + lookupEnv' (name "foo") shadowed `shouldBe` Just (Precise 1) + + it "can delete bindings" $ + delete (name "foo") shadowed `shouldBe` Environment (pure lowerBound) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 724a72f17..1076eb393 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -31,6 +31,7 @@ import Data.Patch import Data.Range import Data.Location import Data.Semigroup (Semigroup(..)) +import Data.Semigroup.App import Data.Source import Data.Blob import Data.Span @@ -527,6 +528,12 @@ instance Listable Language.Language where \/ cons0 Language.Ruby \/ cons0 Language.TypeScript +instance Listable (f a) => Listable (App f a) where + tiers = cons1 App + +instance Listable (f a) => Listable (AppMerge f a) where + tiers = cons1 AppMerge + instance Listable Location where tiers = cons2 Location diff --git a/test/Data/Semigroup/App/Spec.hs b/test/Data/Semigroup/App/Spec.hs new file mode 100644 index 000000000..e3acf4bc1 --- /dev/null +++ b/test/Data/Semigroup/App/Spec.hs @@ -0,0 +1,20 @@ +module Data.Semigroup.App.Spec where + +import SpecHelpers +import Data.Semigroup.App + +spec :: Spec +spec = do + describe "App" $ + prop "should be associative" $ + \a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer) + + describe "AppMerge" $ do + prop "should be associative" $ + \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String) + + prop "identity/left" $ + \ a -> mempty <> a == (a :: AppMerge Maybe String) + + prop "identity/right" $ + \ a -> a <> mempty == (a :: AppMerge Maybe String) diff --git a/test/Spec.hs b/test/Spec.hs index 3b5556b4c..844621665 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,12 +9,14 @@ import qualified Assigning.Assignment.Spec import qualified Control.Abstract.Evaluator.Spec import qualified Control.Rewriting.Spec import qualified Data.Diff.Spec +import qualified Data.Abstract.Environment.Spec import qualified Data.Abstract.Name.Spec import qualified Data.Abstract.Path.Spec import qualified Data.Functor.Classes.Generic.Spec import qualified Data.Graph.Spec import qualified Data.Range.Spec import qualified Data.Scientific.Spec +import qualified Data.Semigroup.App.Spec import qualified Data.Source.Spec import qualified Data.Term.Spec import qualified Diffing.Algorithm.RWS.Spec @@ -52,11 +54,13 @@ main = do describe "Control.Rewriting.Spec" Control.Rewriting.Spec.spec describe "Data.Diff" Data.Diff.Spec.spec describe "Data.Graph" Data.Graph.Spec.spec + describe "Data.Abstract.Environment.Spec" Data.Abstract.Environment.Spec.spec describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec describe "Data.Range" Data.Range.Spec.spec describe "Data.Scientific" Data.Scientific.Spec.spec + describe "Data.Semigroup.App" Data.Semigroup.App.Spec.spec describe "Data.Source" Data.Source.Spec.spec describe "Data.Term" Data.Term.Spec.spec describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec