diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,14 @@
 # Revision history for interval-patterns
 
+## 0.8.0
+
+* `newtype Shrink x = Shrink {getShrink :: Borel x}`, the monoid formed by `Borel.intersection` and `whole`
+* `landAbove :: (Ord x, Ord y) => y -> Layers x y -> Borel x` above "sea level"
+* `land :: (Ord x, Monoid y, Ord y) => Layers x y -> Borel x` above a "sea level" of `mempty`
+* remove unnecessary `Lattice` constraints on the endpoints of `Borel` sets
+* fix `Constr` definitions having an extra `-` character
+* fix bug in `difference` conflating the cases `Finishes` and `FinishedBy`
+
 ## 0.7.2
 
 * fix sign of result in `Data.Timeframe.duration`
diff --git a/interval-patterns.cabal b/interval-patterns.cabal
--- a/interval-patterns.cabal
+++ b/interval-patterns.cabal
@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               interval-patterns
-version:            0.7.2
+version:            0.8.0
 author:             Melanie Brown
 synopsis:           Intervals, and monoids thereof
 category:           Algebra, Charts, Data Structures, Math, Statistics
@@ -10,14 +10,14 @@
 homepage:           https://github.com/mixphix/interval-patterns
 bug-reports:        https://github.com/mixphix/interval-patterns/issues
 extra-source-files: CHANGELOG.md
-copyright:          2023 Melanie Brown
+copyright:          2023-2024 Melanie Brown
 description:
   Please see the README at https://github.com/mixphix/interval-patterns
 
 common interval-patterns
   build-depends:
     , base         >=4.11    && <5
-    , containers   >=0.6.7   && <0.7
+    , containers   >=0.6.7   && <0.8
     , deepseq      >=1.4.8   && <1.6
     , groups       >=0.5.3   && <0.6
     , hashable     >=1.4.2   && <1.5
@@ -63,4 +63,6 @@
   build-depends:
     , hspec
     , interval-patterns
+    , parsec
     , QuickCheck
+    , text
diff --git a/src/Data/Interval.hs b/src/Data/Interval.hs
--- a/src/Data/Interval.hs
+++ b/src/Data/Interval.hs
@@ -514,7 +514,7 @@
 intervalOpenOpenConstr =
   mkConstr
     intervalDataType
-    ":<--->:"
+    ":<-->:"
     []
     Infix
 
@@ -522,7 +522,7 @@
 intervalClosedOpenConstr =
   mkConstr
     intervalDataType
-    ":|--->:"
+    ":|-->:"
     []
     Infix
 
@@ -530,7 +530,7 @@
 intervalOpenClosedConstr =
   mkConstr
     intervalDataType
-    ":<---|:"
+    ":<--|:"
     []
     Infix
 
@@ -538,7 +538,7 @@
 intervalClosedClosedConstr =
   mkConstr
     intervalDataType
-    ":|---|:"
+    ":|--|:"
     []
     Infix
 
@@ -1010,7 +1010,7 @@
     _ -> i : unionsAsc (j : is)
   x -> x
 
--- | Take the complement of the interval, as possibly 'OneOrTwo'.
+-- | Take the complement of the interval, as possibly 'OneOrTwo'. See also 'Data.Interval.Borel.complement'.
 --
 -- @
 -- >>> complement (3 :<>: 4)
@@ -1073,9 +1073,9 @@
   Overlaps i _ _ -> Just $ One i
   Starts{} -> Nothing
   During{} -> Nothing
-  Finishes{} -> Nothing
+  Finishes i _ -> Just $ One i
   Identical{} -> Nothing
-  FinishedBy i _ -> Just $ One i
+  FinishedBy{} -> Nothing
   Contains i _ k -> Just $ Two i k
   StartedBy _ j -> Just $ One j
   OverlappedBy _ _ k -> Just $ One k
diff --git a/src/Data/Interval/Borel.hs b/src/Data/Interval/Borel.hs
--- a/src/Data/Interval/Borel.hs
+++ b/src/Data/Interval/Borel.hs
@@ -1,5 +1,5 @@
 module Data.Interval.Borel (
-  Borel,
+  Borel (Borel),
   borel,
   intervalSet,
   Data.Interval.Borel.empty,
@@ -22,6 +22,7 @@
   intersections,
   hull,
   isSubsetOf,
+  Shrink (..),
 ) where
 
 import Algebra.Heyting (Heyting ((==>)))
@@ -55,7 +56,7 @@
 -- groups of intervals, such as for calculating the overall timespan
 -- of a group of events. However, it is agnostic of
 -- how many times each given point has been covered.
--- To keep track of this data, use 'Data.Interval.Layers'.
+-- To keep track of this data, use 'Data.Interval.Layers.Layers'.
 newtype Borel x = Borel (Set (Interval x))
   deriving (Eq, Ord, Show, Generic, Typeable, Data)
 
@@ -67,40 +68,40 @@
   mempty :: (Ord x) => Borel x
   mempty = Borel mempty
 
-instance (Ord x, Lattice x) => Lattice (Borel x) where
-  (\/) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x
+instance (Ord x) => Lattice (Borel x) where
+  (\/) :: (Ord x) => Borel x -> Borel x -> Borel x
   (\/) = union
 
-  (/\) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x
+  (/\) :: (Ord x) => Borel x -> Borel x -> Borel x
   (/\) = intersection
 
-instance (Ord x, Lattice x) => BoundedMeetSemiLattice (Borel x) where
-  top :: (Ord x, Lattice x) => Borel x
+instance (Ord x) => BoundedMeetSemiLattice (Borel x) where
+  top :: (Ord x) => Borel x
   top = whole
 
-instance (Ord x, Lattice x) => BoundedJoinSemiLattice (Borel x) where
-  bottom :: (Ord x, Lattice x) => Borel x
+instance (Ord x) => BoundedJoinSemiLattice (Borel x) where
+  bottom :: (Ord x) => Borel x
   bottom = mempty
 
-instance (Ord x, Lattice x) => Heyting (Borel x) where
-  (==>) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x
+instance (Ord x) => Heyting (Borel x) where
+  (==>) :: (Ord x) => Borel x -> Borel x -> Borel x
   x ==> y = complement x \/ y
 
-instance (Ord x, Lattice x) => Semiring (Borel x) where
-  plus :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x
+instance (Ord x) => Semiring (Borel x) where
+  plus :: (Ord x) => Borel x -> Borel x -> Borel x
   plus = symmetricDifference
 
-  times :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x
+  times :: (Ord x) => Borel x -> Borel x -> Borel x
   times = intersection
 
-  zero :: (Ord x, Lattice x) => Borel x
+  zero :: (Ord x) => Borel x
   zero = mempty
 
-  one :: (Ord x, Lattice x) => Borel x
+  one :: (Ord x) => Borel x
   one = whole
 
-instance (Ord x, Lattice x) => Ring (Borel x) where
-  negate :: (Ord x, Lattice x) => Borel x -> Borel x
+instance (Ord x) => Ring (Borel x) where
+  negate :: (Ord x) => Borel x -> Borel x
   negate = complement
 
 -- | Consider the 'Borel' set identified by a list of 'Interval's.
@@ -191,9 +192,7 @@
 
 -- | Take the intersection of a list of 'Borel' sets.
 intersections :: (Ord x) => [Borel x] -> Borel x
-intersections [] = mempty
-intersections [i] = i
-intersections (i : j : js) = intersection (intersection i j) (intersections js)
+intersections = getShrink . foldMap Shrink
 
 -- | Take the smallest spanning 'Interval' of a 'Borel' set,
 -- provided that it is not the empty set.
@@ -202,3 +201,15 @@
 
 isSubsetOf :: (Ord x) => Borel x -> Borel x -> Bool
 isSubsetOf is js = null $ difference is js
+
+-- | Newtype wrapper for the monoid under 'intersection'.
+newtype Shrink x = Shrink {getShrink :: Borel x}
+  deriving (Eq, Ord, Show, Generic, Typeable, Data)
+
+instance (Ord x) => Semigroup (Shrink x) where
+  (<>) :: (Ord x) => Shrink x -> Shrink x -> Shrink x
+  Shrink x <> Shrink y = Shrink (intersection x y)
+
+instance (Ord x) => Monoid (Shrink x) where
+  mempty :: (Ord x) => Shrink x
+  mempty = Shrink whole
diff --git a/src/Data/Interval/Layers.hs b/src/Data/Interval/Layers.hs
--- a/src/Data/Interval/Layers.hs
+++ b/src/Data/Interval/Layers.hs
@@ -1,5 +1,5 @@
 module Data.Interval.Layers (
-  Layers,
+  Layers (Layers),
   Data.Interval.Layers.fromList,
   Data.Interval.Layers.toList,
   empty,
@@ -7,6 +7,8 @@
   insert,
   pile,
   squash,
+  land,
+  landAbove,
   thickness,
   thickest,
   dig,
@@ -83,11 +85,28 @@
 toList :: (Ord x) => Layers x y -> [(Interval x, y)]
 toList (Layers s) = Map.toList s
 
--- | Ignore the 'Layers' and focus only on whether points are 'within'
+-- | Ignore the 'Layers' and focus only on whether points are 'Data.Interval.within'
 -- any contained 'Interval' or not.
 squash :: (Ord x) => Layers x y -> Borel x
 squash (Layers s) = foldMap Borel.singleton (Map.keys s)
 
+-- | Treating 'mempty' as sea level, consider the 'Borel' set of a provided
+-- 'Layers' that is "land".
+--
+-- An improvement over 'squash' in that it will not return 'I.Whole'
+-- if 'baseline' or some involved interval calculations have been used.
+land :: (Ord x, Monoid y, Ord y) => Layers x y -> Borel x
+land = landAbove mempty
+
+-- | Given a "sea level", consider the 'Borel' set of a provided 'Layers'
+-- that is "land".
+--
+-- An improvement over 'squash' in that it will not return 'I.Whole'
+-- if 'baseline' or some involved interval calculations have been used.
+landAbove :: (Ord x, Ord y) => y -> Layers x y -> Borel x
+landAbove sea (Layers s) = flip Map.foldMapWithKey s \i y ->
+  if y > sea then Borel.singleton i else Borel.empty
+
 -- | @insert ix y l@ draws over @l@ a rectangle with base @ix@ of thickness @y@.
 insert ::
   (Ord x, Ord y, Semigroup y) =>
@@ -209,38 +228,30 @@
     Meets i j k ->
       (i, iy) : nestingsAsc (Heap.fromList [(j, iy <> jy), (k, jy)] <> js)
     Overlaps i j k ->
-      nestingsAsc
-        $ Heap.fromList [(i, iy), (j, iy <> jy), (k, jy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, iy), (j, iy <> jy), (k, jy)] <> js
     Starts i j ->
-      nestingsAsc
-        $ Heap.fromList [(i, iy <> jy), (j, jy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, iy <> jy), (j, jy)] <> js
     During i j k ->
-      nestingsAsc
-        $ Heap.fromList [(i, jy), (j, iy <> jy), (k, jy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, jy), (j, iy <> jy), (k, jy)] <> js
     Finishes i j ->
-      nestingsAsc
-        $ Heap.fromList [(i, iy), (j, iy <> jy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, iy), (j, iy <> jy)] <> js
     Identical i -> nestingsAsc (Heap.insert (i, iy <> jy) js)
     FinishedBy i j ->
-      nestingsAsc
-        $ Heap.fromList [(i, iy), (j, iy <> jy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, iy), (j, iy <> jy)] <> js
     Contains i j k ->
-      nestingsAsc
-        $ Heap.fromList [(i, iy), (j, iy <> jy), (k, iy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, iy), (j, iy <> jy), (k, iy)] <> js
     StartedBy i j ->
-      nestingsAsc
-        $ Heap.fromList [(i, iy <> jy), (j, iy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, iy <> jy), (j, iy)] <> js
     OverlappedBy i j k ->
-      nestingsAsc
-        $ Heap.fromList [(i, jy), (j, iy <> jy), (k, iy)]
-        <> js
+      nestingsAsc do
+        Heap.fromList [(i, jy), (j, iy <> jy), (k, iy)] <> js
     MetBy i j k ->
       (i, jy) : nestingsAsc (Heap.fromList [(j, iy <> jy), (k, iy)] <> js)
     After i j -> (i, jy) : nestingsAsc (Heap.insert (j, iy) js)
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -2,7 +2,10 @@
 
 module Main where
 
+import Algebra.Lattice (Lattice (..))
 import Algebra.Lattice.Levitated (Levitated (..))
+import Control.Applicative
+import Control.Monad
 import Data.Interval (
   Interval,
   pattern (:<->:),
@@ -14,12 +17,18 @@
   pattern (:|>:),
   pattern (:||:),
  )
+import Data.Interval qualified as Interval
+import Data.Interval.Borel (Borel)
 import Data.Interval.Borel qualified as Borel
 import Data.Interval.Layers qualified as Layers
 import Data.Semigroup
 import GHC.TypeNats
 import Test.Hspec
 import Test.QuickCheck
+import Text.Parsec (sepBy, try)
+import Text.Parsec.Char (char, digit, spaces, string)
+import Text.Parsec.Text (Parser)
+import Text.ParserCombinators.Parsec (choice)
 
 type family Ints (n :: Nat) x where
   Ints 0 x = x
@@ -29,26 +38,15 @@
 main = hspec do
   describe "smart constructors" do
     it "orient finite intervals" do
-      property @(Ints 2 _) \x y -> do
-        if x <= y
-          then do
-            (x :<>: y) `shouldBe` (x :<>: y)
-            (x :|>: y) `shouldBe` (x :|>: y)
-            (x :<|: y) `shouldBe` (x :<|: y)
-            (x :||: y) `shouldBe` (x :||: y)
-            (Levitate x :<->: Levitate y) `shouldBe` (Levitate x :<->: Levitate y)
-            (Levitate x :|->: Levitate y) `shouldBe` (Levitate x :|->: Levitate y)
-            (Levitate x :<-|: Levitate y) `shouldBe` (Levitate x :<-|: Levitate y)
-            (Levitate x :|-|: Levitate y) `shouldBe` (Levitate x :|-|: Levitate y)
-          else do
-            (x :<>: y) `shouldBe` (y :<>: x)
-            (x :|>: y) `shouldBe` (y :<|: x)
-            (x :<|: y) `shouldBe` (y :|>: x)
-            (x :||: y) `shouldBe` (y :||: x)
-            (Levitate x :<->: Levitate y) `shouldBe` (Levitate y :<->: Levitate x)
-            (Levitate x :|->: Levitate y) `shouldBe` (Levitate y :<-|: Levitate x)
-            (Levitate x :<-|: Levitate y) `shouldBe` (Levitate y :|->: Levitate x)
-            (Levitate x :|-|: Levitate y) `shouldBe` (Levitate y :|-|: Levitate x)
+      property @(Ints 2 _) \x y -> when (x > y) do
+        (x :<>: y) `shouldBe` (y :<>: x)
+        (x :|>: y) `shouldBe` (y :<|: x)
+        (x :<|: y) `shouldBe` (y :|>: x)
+        (x :||: y) `shouldBe` (y :||: x)
+        (Levitate x :<->: Levitate y) `shouldBe` (Levitate y :<->: Levitate x)
+        (Levitate x :|->: Levitate y) `shouldBe` (Levitate y :<-|: Levitate x)
+        (Levitate x :<-|: Levitate y) `shouldBe` (Levitate y :|->: Levitate x)
+        (Levitate x :|-|: Levitate y) `shouldBe` (Levitate y :|-|: Levitate x)
 
     it "orient infinite intervals" do
       (Top :<->: Bottom) `shouldBe` (Bottom :<->: Top :: Interval Int)
@@ -57,7 +55,7 @@
       (Top :|-|: Bottom) `shouldBe` (Bottom :|-|: Top :: Interval Int)
 
     it "close point intervals" do
-      property @(Int -> _) $ \x -> do
+      property @(Int -> _) \x -> do
         (x :<>: x) `shouldBe` (x :||: x)
         (x :|>: x) `shouldBe` (x :||: x)
         (x :<|: x) `shouldBe` (x :||: x)
@@ -87,3 +85,71 @@
             cdy = Layers.singleton (c :||: d) (Sum y)
             efz = Layers.singleton (e :<>: f) (Sum z)
         (abx <> cdy) <> efz `shouldBe` abx <> (cdy <> efz)
+
+newtype Version = Version [Int]
+  deriving (Eq, Ord, Show)
+
+version :: Parser Version
+version = Version <$> sepBy (read <$> many digit) (char '.')
+
+data Tk
+  = TkAnd
+  | TkOr
+  | TkBorel (Borel Version)
+  | TkOpen
+  | TkClose
+
+tk :: Parser Tk
+tk =
+  choice
+    [ try tkAnd
+    , try tkOr
+    , try do liftM2 ((TkBorel . Borel.singleton) .) tkCmp tkVersion
+    , try tkOpen
+    , try tkClose
+    ]
+ where
+  tkAnd = TkAnd <$ (spaces *> string "&&" <* spaces)
+  tkOr = TkOr <$ (spaces *> string "||" <* spaces)
+  tkVersion = spaces *> version <* spaces
+  tkCmp =
+    choice
+      [ (Bottom :<-|:) . Levitate <$ try do string "<="
+      , (Bottom :<->:) . Levitate <$ try do string "<"
+      , (:|->: Top) . Levitate <$ try do string ">="
+      , (:<->: Top) . Levitate <$ try do string ">"
+      , Interval.point <$ try do string "=="
+      ]
+  tkOpen = TkOpen <$ (spaces *> string "(" <* spaces)
+  tkClose = TkClose <$ (spaces *> string ")" <* spaces)
+
+foldTk :: [Tk] -> Borel Version
+foldTk = \case
+  [TkBorel b] -> b
+  TkOpen : TkBorel b0 : TkAnd : TkBorel b1 : TkClose : rest ->
+    foldTk do TkBorel (b0 /\ b1) : rest
+  TkOpen : TkBorel b0 : TkOr : TkBorel b1 : TkClose : rest ->
+    foldTk do TkBorel (b0 \/ b1) : rest
+  TkBorel b0 : TkAnd : TkOpen : rest ->
+    foldTk do TkBorel b0 : TkAnd : [TkBorel (foldTk (TkOpen : rest))]
+  TkBorel b0 : TkOr : TkOpen : rest ->
+    foldTk do TkBorel b0 : TkOr : [TkBorel (foldTk (TkOpen : rest))]
+  TkBorel b0 : TkAnd : TkBorel b1 : rest -> foldTk do TkBorel (b0 /\ b1) : rest
+  TkBorel b0 : TkOr : TkBorel b1 : rest -> foldTk do TkBorel (b0 \/ b1) : rest
+  TkOpen : TkBorel b : TkClose : rest -> foldTk do TkBorel b : rest
+  _ -> error "malformed bounds"
+
+versionBounds :: Parser (Borel Version)
+versionBounds = foldTk <$> many tk
+
+-- >>> Text.Parsec.parse versionBounds "" ">= 2.0.0 && <3"
+-- Right (Borel (fromList [(Version [2,0,0] :|>: Version [3])]))
+
+-- >>> Text.Parsec.parse versionBounds "" ">= 4"
+-- Right (Borel (fromList [(Levitate (Version [4]) :|->: Top)]))
+
+-- >>> Text.Parsec.parse versionBounds "" "(>= 1.2 && <3) || (>= 4.0 && < 5)"
+-- Right (Borel (fromList [(Version [1,2] :|>: Version [3]),(Version [4,0] :|>: Version [5])]))
+
+-- >>> Text.Parsec.parse versionBounds "" "(>= 1.2 && <3) || (>= 2.0 && < 5)"
+-- Right (Borel (fromList [(Version [1,2] :|>: Version [5])]))