diff --git a/Shpadoinkle-widgets.cabal b/Shpadoinkle-widgets.cabal
--- a/Shpadoinkle-widgets.cabal
+++ b/Shpadoinkle-widgets.cabal
@@ -1,13 +1,13 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.32.0.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 3dd750fddc520269eb2759eb0dfadb6e7617b86f52611b35e5ea407a7b13ca37
+-- hash: 200e32bc905bdf7a4b38b56da888233628b9617d7ed23485264f9732aab4c225
 
 name:           Shpadoinkle-widgets
-version:        0.1.0.0
+version:        0.2.0.0
 synopsis:       A collection of common reusable types and components.
 description:    There are many shared abstractions between various UIs that represent themselves in frameworks and applications. This package provides a useful subset of these concepts as types along with implementations consuming these types.
 category:       Web
@@ -24,6 +24,11 @@
   type: git
   location: https://gitlab.com/fresheyeball/Shpadoinkle.git
 
+flag testing
+  description: Provide test kit around QuickCheck
+  manual: True
+  default: False
+
 library
   exposed-modules:
       Shpadoinkle.Widgets.Form.Input
@@ -32,6 +37,7 @@
       Shpadoinkle.Widgets.Table.Lazy
       Shpadoinkle.Widgets.Types
       Shpadoinkle.Widgets.Types.Choice
+      Shpadoinkle.Widgets.Types.ConsideredChoice
       Shpadoinkle.Widgets.Types.Core
       Shpadoinkle.Widgets.Types.Form
       Shpadoinkle.Widgets.Types.Physical
@@ -58,6 +64,17 @@
     , template-haskell >=2.14.0 && <2.17
     , text >=1.2.3 && <1.3
     , unliftio >=0.2.12 && <0.3
+  if flag(testing)
+    exposed-modules:
+        Test.QuickCheck.Classes.Hspec
+        Test.QuickCheck.Classes.FoldableOrd
+    cpp-options: -DTESTING
+    build-depends:
+        QuickCheck
+      , hspec
+      , quickcheck-classes
+      , quickcheck-classes-base
+      , transformers
   default-language: Haskell2010
 
 test-suite unit
@@ -68,10 +85,13 @@
   hs-source-dirs:
       tests
   ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities
+  cpp-options: -DTESTING
   build-depends:
       QuickCheck
     , Shpadoinkle-widgets
     , base >=4.12.0 && <4.16
     , containers
     , hspec
+    , quickcheck-classes
+    , quickcheck-classes-base
   default-language: Haskell2010
diff --git a/Shpadoinkle/Widgets/Form/Dropdown.hs b/Shpadoinkle/Widgets/Form/Dropdown.hs
--- a/Shpadoinkle/Widgets/Form/Dropdown.hs
+++ b/Shpadoinkle/Widgets/Form/Dropdown.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE CPP                       #-}
 {-# LANGUAGE DataKinds                 #-}
+{-# LANGUAGE DeriveFoldable            #-}
 {-# LANGUAGE DeriveGeneric             #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ExtendedDefaultRules      #-}
@@ -25,6 +27,9 @@
 import           Data.Text
 import           GHC.Generics
 import           Prelude                   hiding (div)
+#ifdef TESTING
+import           Test.QuickCheck           (Arbitrary (..))
+#endif
 
 
 import           Shpadoinkle
@@ -47,6 +52,7 @@
 deriving instance (Read (Selected p a), Read (Considered p a), Read a, Ord a) => Read (Dropdown p a)
 deriving instance (Eq   (Selected p a), Eq   (Considered p a), Eq a)          => Eq   (Dropdown p a)
 deriving instance (Ord  (Selected p a), Ord  (Considered p a), Ord a)         => Ord  (Dropdown p a)
+deriving instance (Foldable (ConsideredChoice p)) => Foldable (Dropdown p)
 deriving instance Generic (Dropdown p a)
 instance (ToJSON a,   ToJSON (Selected p a),   ToJSON (Considered p a))          => ToJSON   (Dropdown p a)
 instance (FromJSON a, FromJSON (Selected p a), FromJSON (Considered p a), Ord a) => FromJSON (Dropdown p a)
@@ -100,13 +106,12 @@
   valid (Dropdown c _) = valid c
 
 
-instance Consideration ConsideredChoice p => Selection Dropdown p where
+instance (Consideration ConsideredChoice p, PickToSelected p) => Selection Dropdown p where
   select  (Dropdown c t) x = close $ Dropdown (select c x) t
-  select' (Dropdown c t) x = close $ Dropdown (select' c x) t
   unselected = unselected . _considered
   selected   = selected . _considered
   withOptions x xs  = Dropdown (x `withOptions` xs) mempty
-  withOptions' x xs = Dropdown (x `withOptions'` xs) mempty
+  retain (Dropdown c t) (Dropdown c' t') = Dropdown (retain c c') (t <> t')
 
 
 instance (Consideration ConsideredChoice p, Deselection ConsideredChoice p)
@@ -115,9 +120,8 @@
   deselect (Dropdown c t) = close $ Dropdown (deselect c) t
 
 
-instance Consideration ConsideredChoice p => Consideration Dropdown p where
+instance (Consideration ConsideredChoice p, PickToConsidered p) => Consideration Dropdown p where
   consider  x (Dropdown c t) = Dropdown (consider x c) t
-  consider' x (Dropdown c t) = Dropdown (consider' x c) t
   choose (Dropdown c t) = Dropdown (choose c) t
   choice (Dropdown c _) = choice c
   considered (Dropdown c _) = considered c
@@ -125,10 +129,10 @@
 
 
 data Theme m p b = Theme
-    { _wrapper :: forall a . [Html m a]  -> Html m a
+    { _wrapper :: forall a . [Html m a]   ->  Html m a
     , _header  :: forall a . Selected p b -> [Html m a]
-    , _list    :: forall a . [Html m a]  -> Html m a
-    , _item    :: forall a . b            -> Html m a
+    , _list    :: forall a . [Html m a]   ->  Html m a
+    , _item    :: forall a . b            ->  Html m a
     }
 
 
@@ -175,18 +179,23 @@
     Theme {..} = toTheme x
   in injectProps
   ([onKeyup $ \case
-    Enter     -> act x
-    UpArrow   -> considerPrev x
-    DownArrow -> considerNext x
-    _ -> x
-  , onClick $ act x
+    Enter     -> act
+    UpArrow   -> considerPrev
+    DownArrow -> considerNext
+    _         -> id
+  , onClickAway close
+  , onClick act
   , tabbable
   ] ++ _attrs) . _wrapper $
-  (_header $ selected x) ++
+  _header (selected x) ++
   [ _list $ (\y -> injectProps
-    [ onMouseover $ consider' y x
-    , onFocus     $ consider' y x
-    , onClick     $ select' x y
+    [ onMouseover (consider' y)
+    , onFocus     (consider' y)
     , tabbable
     ] . _item $ y) <$> toList (unselected x)
   ]
+
+#ifdef TESTING
+instance (Ord a, Arbitrary a, Arbitrary (ConsideredChoice p a)) => Arbitrary (Dropdown p a) where
+  arbitrary = Dropdown <$> arbitrary <*> arbitrary
+#endif
diff --git a/Shpadoinkle/Widgets/Form/Input.hs b/Shpadoinkle/Widgets/Form/Input.hs
--- a/Shpadoinkle/Widgets/Form/Input.hs
+++ b/Shpadoinkle/Widgets/Form/Input.hs
@@ -6,15 +6,16 @@
 module Shpadoinkle.Widgets.Form.Input where
 
 
-import           Data.Coerce
-import           Data.Text
-import           Data.Text.Read
+import           Data.Coerce                      (Coercible, coerce)
+import           Data.Text                        (Text, pack)
+import           Data.Text.Read                   (double)
 
-import           Shpadoinkle                      hiding (text)
-import           Shpadoinkle.Html                 as Html
-import           Shpadoinkle.Widgets.Types.Core
-import           Shpadoinkle.Widgets.Types.Form   as Form
-import           Shpadoinkle.Widgets.Types.Search
+import           Shpadoinkle                      (Html, Prop)
+import           Shpadoinkle.Html                 as Html (input, onInput,
+                                                           type', value)
+import           Shpadoinkle.Widgets.Types.Core   (Hygiene (Dirty))
+import           Shpadoinkle.Widgets.Types.Form   as Form (Input (Input, _value))
+import           Shpadoinkle.Widgets.Types.Search (Search (Search))
 
 
 type Config m a = [(Text, Prop m (Input a))]
@@ -23,7 +24,7 @@
 mkInput :: Text -> (Text -> a) -> (a -> Text) -> Config m a -> Input a -> Html m (Input a)
 mkInput t to from attrs inp = Html.input
   ( Html.value (from $ Form._value inp)
-  : Html.onInput (Input Dirty . to)
+  : Html.onInput (\x _ -> Input Dirty $ to x)
   : Html.type' t
   : attrs ) []
 
diff --git a/Shpadoinkle/Widgets/Table.hs b/Shpadoinkle/Widgets/Table.hs
--- a/Shpadoinkle/Widgets/Table.hs
+++ b/Shpadoinkle/Widgets/Table.hs
@@ -1,20 +1,18 @@
-{-# LANGUAGE AllowAmbiguousTypes    #-}
-{-# LANGUAGE ConstraintKinds        #-}
-{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE DeriveAnyClass         #-}
-{-# LANGUAGE DeriveFunctor          #-}
-{-# LANGUAGE DeriveGeneric          #-}
-{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE OverloadedStrings      #-}
-{-# LANGUAGE PolyKinds              #-}
-{-# LANGUAGE RecordWildCards        #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE StandaloneDeriving     #-}
-{-# LANGUAGE TupleSections          #-}
-{-# LANGUAGE TypeFamilies           #-}
-{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 
 module Shpadoinkle.Widgets.Table
@@ -173,7 +171,7 @@
         Just (PText sty) -> M.toList (M.insert "style" (textProp $ sty <> "; display: none") pMap)
         _ -> M.toList (M.insert "style" (textProp "display: none") pMap)
 
-  cth_ c = th (thProps xs s c) . pure . Html.a [ second rightC . onClick $ toggleSort c s ]
+  cth_ c = th (thProps xs s c) . pure . Html.a [ second rightC . onClick $ toggleSort c ]
          . mappend [ text (humanize c) ] . pure $
           if c == sorton then
             case sortorder of ASC -> ascendingIcon Proxy; DESC -> descendingIcon Proxy
diff --git a/Shpadoinkle/Widgets/Table/Lazy.hs b/Shpadoinkle/Widgets/Table/Lazy.hs
--- a/Shpadoinkle/Widgets/Table/Lazy.hs
+++ b/Shpadoinkle/Widgets/Table/Lazy.hs
@@ -22,22 +22,22 @@
   ) where
 
 
-import Prelude hiding (div)
+import           Prelude                     hiding (div)
 
-import Control.Arrow (second)
-import Data.Aeson
-import Data.Functor.Identity
-import Data.List (sortBy)
-import Data.Maybe (fromMaybe)
-import Data.Proxy
-import Data.Text hiding (filter, find, take)
-import GHC.Generics
+import           Control.Arrow               (second)
+import           Data.Aeson
+import           Data.Functor.Identity
+import           Data.List                   (sortBy)
+import           Data.Maybe                  (fromMaybe)
+import           Data.Proxy
+import           Data.Text                   hiding (filter, find, take)
+import           GHC.Generics
 
-import Language.Javascript.JSaddle hiding (JSM, MonadJSM)
-import Shpadoinkle
-import Shpadoinkle.Html (div)
-import Shpadoinkle.Widgets.Table
-import Shpadoinkle.Widgets.Types
+import           Language.Javascript.JSaddle hiding (JSM, MonadJSM)
+import           Shpadoinkle
+import           Shpadoinkle.Html            (div)
+import           Shpadoinkle.Widgets.Table
+import           Shpadoinkle.Widgets.Types
 
 default (Text)
 
@@ -56,7 +56,7 @@
 data instance (Row (LazyTable a)) = LazyRow (Row a) | FakeRow
 
 
-data instance (Column (LazyTable a)) = LazyColumn (Column a)
+newtype instance (Column (LazyTable a)) = LazyColumn (Column a)
 
 
 instance Humanize (Column a) => Humanize (Column (LazyTable a)) where
@@ -88,9 +88,9 @@
     mapToLazyTable <$> toCell xs r c
   toCell _ FakeRow _ = []
   sortTable sc (LazyRow a) (LazyRow b) = sortTable (fromLazySortCol sc) a b
-  sortTable _ FakeRow FakeRow = EQ
-  sortTable _ _ FakeRow = LT
-  sortTable _ FakeRow _ = GT
+  sortTable _ FakeRow FakeRow          = EQ
+  sortTable _ _ FakeRow                = LT
+  sortTable _ FakeRow _                = GT
   ascendingIcon _ = mapToLazyTableSc $ ascendingIcon Proxy
   descendingIcon _ = mapToLazyTableSc $ descendingIcon Proxy
 
@@ -194,7 +194,7 @@
   . mapFromLazyTableSc lazyTab
   $ viewWith lazyTheme lazyTab (SortCol (LazyColumn c) s)
   where
-    lazyTab@(LazyTable _ _ _ _ _ _ _) = toLazyTable tableHeight rowHeight scrollY xs sc
+    lazyTab@LazyTable {} = toLazyTable tableHeight rowHeight scrollY xs sc
 
     totalRows = countRows xs
 
@@ -207,12 +207,12 @@
         runIdentity . props (Identity . (listenRaw "scroll" (debounceScroll scrollHandlerContainer) :))
       TbodyIsScrollable _ -> id
 
-    scrollHandlerContainer = \(RawNode n) _ ->
+    scrollHandlerContainer (RawNode n) _ =
       pur . second . const . CurrentScrollY . fromMaybe 0
         <$> (fromJSVal =<< n ! "scrollTop")
 
     scrollHandlerTbody :: RawNode -> RawEvent -> JSM (Continuation m (LazyTable a, SortCol (LazyTable a)))
-    scrollHandlerTbody = \(RawNode n) _ -> do
+    scrollHandlerTbody (RawNode n) _ = do
       sy <- CurrentScrollY . fromMaybe 0 <$> (fromJSVal =<< n ! "scrollTop")
       return . pur $ \(LazyTable t th rh _ rts sc' rs, sc'') -> (LazyTable t th rh sy rts sc' rs, sc'')
 
diff --git a/Shpadoinkle/Widgets/Types.hs b/Shpadoinkle/Widgets/Types.hs
--- a/Shpadoinkle/Widgets/Types.hs
+++ b/Shpadoinkle/Widgets/Types.hs
@@ -1,6 +1,7 @@
 module Shpadoinkle.Widgets.Types
   ( module Shpadoinkle.Widgets.Types.Core
   , module Shpadoinkle.Widgets.Types.Choice
+  , module Shpadoinkle.Widgets.Types.ConsideredChoice
   , module Shpadoinkle.Widgets.Types.Form
   , module Shpadoinkle.Widgets.Types.Physical
   , module Shpadoinkle.Widgets.Types.Remote
@@ -9,6 +10,7 @@
 
 
 import           Shpadoinkle.Widgets.Types.Choice
+import           Shpadoinkle.Widgets.Types.ConsideredChoice
 import           Shpadoinkle.Widgets.Types.Core
 import           Shpadoinkle.Widgets.Types.Form
 import           Shpadoinkle.Widgets.Types.Physical
diff --git a/Shpadoinkle/Widgets/Types/Choice.hs b/Shpadoinkle/Widgets/Types/Choice.hs
--- a/Shpadoinkle/Widgets/Types/Choice.hs
+++ b/Shpadoinkle/Widgets/Types/Choice.hs
@@ -1,35 +1,46 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DefaultSignatures     #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE IncoherentInstances   #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE StandaloneDeriving    #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE UndecidableInstances  #-}
-{-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE ViewPatterns               #-}
 
+#ifdef TESTING
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE QuantifiedConstraints      #-}
+#endif
 
+
 module Shpadoinkle.Widgets.Types.Choice where
 
 
-import           Control.Applicative
-import           Control.Compactable
-import           Data.Aeson
-import qualified Data.Foldable       as F
-import           Data.Kind
-import qualified Data.List.NonEmpty  as NE
-import           Data.Maybe
-import           Data.Set            as Set
-import           GHC.Generics
+import           Control.Compactable              (Compactable (compact, filter, partition, separate))
+import           Data.Aeson                       (FromJSON, ToJSON)
+import qualified Data.Foldable                    as F
+import           Data.Functor.Classes             (Eq1 (..), Ord1 (..))
+import           Data.Kind                        (Type)
+import qualified Data.List.NonEmpty               as NE
+import           Data.Proxy
+import           Data.Set                         as Set
+import           GHC.Generics                     (Generic)
+#ifdef TESTING
+import           Data.Monoid                      (Sum (..))
+import           Test.QuickCheck
+import           Test.QuickCheck.Classes
+import           Test.QuickCheck.Classes.Hspec
+import           Test.QuickCheck.Classes.Internal (eq1, func1, func2)
+#endif
 
 
 data Pick = One | AtleastOne | Many
+  deriving (Eq, Ord, Show, Generic)
 
 
 type family Selected (p :: Pick) (a :: Type) :: Type where
@@ -53,6 +64,28 @@
 instance (FromJSON (Selected p a), FromJSON a, Ord a) => FromJSON (Choice p a)
 
 
+class DemotePick (p :: Pick)    where demotePick :: Pick
+instance DemotePick 'One        where demotePick = One
+instance DemotePick 'AtleastOne where demotePick = AtleastOne
+instance DemotePick 'Many       where demotePick = Many
+
+
+instance Eq1 (Choice 'One) where
+  liftEq f (Choice s o) (Choice s' o') = liftEq f s s' && liftEq f o o'
+instance Eq1 (Choice 'AtleastOne) where
+  liftEq f (Choice s o) (Choice s' o') = f s s' && liftEq f o o'
+instance Eq1 (Choice 'Many) where
+  liftEq f (Choice s o) (Choice s' o') = liftEq f s s' && liftEq f o o'
+
+
+instance Ord1 (Choice 'One) where
+  liftCompare f (Choice s o) (Choice s' o') = liftCompare f s s' `compare` liftCompare f o o'
+instance Ord1 (Choice 'AtleastOne) where
+  liftCompare f (Choice s o) (Choice s' o') = f s s' `compare` liftCompare f o o'
+instance Ord1 (Choice 'Many) where
+  liftCompare f (Choice s o) (Choice s' o') = liftCompare f s s' `compare` liftCompare f o o'
+
+
 instance (Bounded a, Enum a) => Bounded (Choice 'AtleastOne a) where
   minBound = Choice minBound fullset
   maxBound = Choice maxBound fullset
@@ -64,19 +97,22 @@
 
 
 instance Foldable (Choice 'One)         where foldr f x (Choice y xs) = Set.foldr f (Prelude.foldr f x y) xs
-instance Foldable (Choice 'AtleastOne)  where foldr f x (Choice y xs)  = Set.foldr f (f y x) xs
-instance Foldable (Choice 'Many)        where foldr f x (Choice y xs)  = Set.foldr f (Set.foldr f x y) xs
+instance Foldable (Choice 'AtleastOne)  where foldr f x (Choice y xs) = Set.foldr f               (f y x) xs
+instance Foldable (Choice 'Many)        where foldr f x (Choice y xs) = Set.foldr f     (Set.foldr f x y) xs
 
 
-instance Ord a => Semigroup (Choice 'One a)  where
-  Choice (Just x) _ <> Choice _ ys | Set.member x ys = Choice (Just x) ys
-  _                 <> y           = y
-instance Ord a => Semigroup (Choice 'AtleastOne a)  where Choice x _ <> Choice y ys = if Set.member x ys then Choice x ys else Choice y ys
-instance Ord a => Semigroup (Choice 'Many a) where Choice x _ <> Choice y ys = Choice (Set.intersection x ys <> y) ys
-instance Ord a => Monoid    (Choice 'One  a) where mempty = noselection (mempty :: Set a)
-instance Ord a => Monoid    (Choice 'Many a) where mempty = noselection (mempty :: Set a)
+instance (Semigroup a, Ord a) => Semigroup (Choice 'One a)
+  where Choice x xs <> Choice y ys = Choice (x <> y) (xs <> ys)
 
+instance (Semigroup a, Ord a) => Semigroup (Choice 'AtleastOne a)
+  where Choice x xs <> Choice y ys = Choice (x <> y) (xs <> ys)
 
+instance (Semigroup a, Ord a) => Semigroup (Choice 'Many a)
+  where Choice x xs <> Choice y ys = Choice (x <> y) (xs <> ys)
+instance (Semigroup a, Ord a) => Monoid    (Choice 'One  a) where mempty = noselection (mempty :: Set a)
+instance (Semigroup a, Ord a) => Monoid    (Choice 'Many a) where mempty = noselection (mempty :: Set a)
+
+
 instance Compactable (Choice 'One) where
   compact (Choice x xs) = Choice (compact x) (compact xs)
   separate (Choice x xs) = let (l,r) = separate xs; (l',r') = separate x in (Choice l' l, Choice r' r)
@@ -93,7 +129,7 @@
 
 -- | Laws:
 -- @
--- if toSet a == toSet b then a == b -- toSet is injective
+-- a == b ==> toSet a == toSet b -- toSet is injective
 -- toSet (smap f s) == fmap f (toSet s)
 -- if valid s then Set.valid (toSet s)
 -- @
@@ -104,67 +140,276 @@
 
 instance SetLike Set where
   toSet = id
+  {-# INLINE toSet #-}
   smap  = Set.map
+  {-# INLINE smap #-}
   valid = Set.valid
 
 instance SetLike Maybe where
   toSet = maybe mempty Set.singleton
+  {-# INLINE toSet #-}
   smap  = fmap
+  {-# INLINE smap #-}
   valid = const True
 
 instance SetLike (Choice 'One) where
-  toSet (Choice x xs) = toSet x <> xs
+  toSet (Choice x xs)  = toSet x <> xs
   smap f (Choice x xs) = Choice (f <$> x)     (Set.map f xs)
-  valid (Choice _ xs) = Set.valid xs
+  valid (Choice _ xs)  = Set.valid xs
 
 instance SetLike (Choice 'AtleastOne) where
-  toSet (Choice x xs) = Set.singleton x <> xs
+  toSet (Choice x xs)  = Set.singleton x <> xs
   smap f (Choice x xs) = Choice (f x)         (Set.map f xs)
   valid (Choice _ xs)  = Set.valid xs
 
 instance SetLike (Choice 'Many) where
-  toSet (Choice x xs) = toSet x <> xs
+  toSet (Choice x xs)  = toSet x <> xs
   smap f (Choice x xs) = Choice (Set.map f x) (Set.map f xs)
   valid (Choice x xs)  = Set.valid x && Set.valid xs
 
 
+#ifdef TESTING
+class
+  ( forall v. Eq                v  => Eq        (f v)
+  , forall w. Show              w  => Show      (f w)
+  , forall x. Ord               x  => Ord       (f x)
+  , forall y. (Ord y, Semigroup y) => Semigroup (f y)
+  , forall z. (Ord z, Arbitrary z) => Arbitrary (f z)
+  ) => Propable1Set f
+instance
+  ( forall v. Eq                v  => Eq        (f v)
+  , forall w. Show              w  => Show      (f w)
+  , forall x. Ord               x  => Ord       (f x)
+  , forall y. (Ord y, Semigroup y) => Semigroup (f y)
+  , forall z. (Ord z, Arbitrary z) => Arbitrary (f z)
+  ) => Propable1Set f
+
+
+type instance Justice SetLike f = Propable1Set f
+instance Legal SetLike where legal' _ = setLikeLaws
+
+
+newtype ApplyOrd f a = ApplyOrd { unApplyOrd :: f a }
+deriving instance (forall x. Eq x   => Eq (f x),   Eq a)   => Eq   (ApplyOrd f a)
+deriving instance (forall x. Show x => Show (f x), Show a) => Show (ApplyOrd f a)
+deriving instance
+  ( forall x. (Ord x, Arbitrary x) => Arbitrary (f x)
+  , Ord a
+  , Arbitrary a
+  ) => Arbitrary (ApplyOrd f a)
+
+
+setLikeLaws ::
+  ( SetLike f
+  , forall c. Eq                c  => Eq        (f c)
+  , forall d. Show              d  => Show      (f d)
+  , forall e. (Arbitrary e, Ord e) => Arbitrary (f e)
+  ) => proxy f -> Laws
+setLikeLaws p = Laws "SetLike"
+  [ ("Composition", setFunctorComposition p)
+  , ("Identity",    setFunctorIdentity    p)
+  , ("Const",       setFunctorConst       p)
+  ]
+
+
+setFunctorComposition, setFunctorIdentity, setFunctorConst :: forall proxy f.
+  ( SetLike f
+  , forall a. Eq                a  => Eq        (f a)
+  , forall a. Show              a  => Show      (f a)
+  , forall a. (Arbitrary a, Ord a) => Arbitrary (f a)
+  ) => proxy f -> Property
+
+setFunctorComposition _ = property $ \(ApplyOrd (a :: f Integer)) ->
+  eq1 (smap func2 (smap func1 a)) (smap (func2 . func1) a)
+
+setFunctorIdentity _    = property $ \(ApplyOrd (a :: f Integer)) ->
+  eq1 (smap id a) a
+
+setFunctorConst _       = property $ \(ApplyOrd (a :: f Integer)) ->
+  let (<$$) = smap . const in
+  eq1 (smap (const 'X') a) ('X' <$$ a)
+
+
+class
+  ( Propable1Ord (f p)
+  , Propable0 (Selected p Integer)
+  , DemotePick p, PickToSet p
+  , Selection f p
+  ) => PropableChoice f p
+instance
+  ( Propable1Ord (f p)
+  , Propable0 (Selected p Integer)
+  , DemotePick p, PickToSet p
+  , Selection f p
+  ) => PropableChoice f p
+
+
+type instance Justice (Selection f) p = PropableChoice f p
+instance Legal (Selection f) where
+  legal' (_ :: Proxy (Selection f)) (_ :: Proxy p) =
+    let Laws _ laws = selectionLaws (Proxy @(f p))
+    in   Laws ("Selection '" <> show (demotePick @p)) laws
+
+
+selectionLaws :: forall proxy f (p :: Pick).
+  ( Selection f p
+  , PickToSet p
+  , Propable1Ord (f p)
+  , Propable0 (Selected p Integer)
+  ) => proxy (f p) -> Laws
+selectionLaws p = Laws "Selection"
+  [ ("Selected is an option",                 selectionIsAnOption               p)
+  , ("Selected and unselected are exclusive", selectedAndUnselectedAreExclusive p)
+  , ("If we select something it's an option", selectIsAnOption                  p)
+  , ("Idempotence select",                    selectIdempotence                 p)
+  , ("Select selected identity",              selectSelectedIdentity            p)
+  , ("Unselected withOptions identity",       unSelectedWithOptionsIdentity     p)
+  , ("Selected is not unselected",            selectIsNotUnselected             p)
+  , ("Retain preserves as much user selection as possible", retainPreserves     p)
+  , ("Retain sets the values",                retainSets                        p)
+  ]
+
+
+selectionIsAnOption, selectedAndUnselectedAreExclusive
+  :: forall proxy f (p :: Pick).
+  ( Selection f p
+  , PickToSet p
+  , Propable1Ord (f p)
+  ) => proxy (f p) -> Property
+selectionIsAnOption _ = property $ \(c :: f p Integer) ->
+  pickToSet @p (selected c) `isSubsetOf` toSet c
+
+selectedAndUnselectedAreExclusive _ = property $ \(c :: f p Integer) ->
+  pickToSet @p (selected c) `disjoint` unselected c
+
+
+selectIsAnOption, selectIdempotence, selectIsNotUnselected
+  :: forall proxy f (p :: Pick).
+  ( Selection f p
+  , Propable1Ord (f p)
+  ) => proxy (f p) -> Property
+selectIsAnOption _ = property $ \(c :: f p Integer) x ->
+  x `member` toSet (select' c x)
+
+selectIdempotence _ = property $ \(c :: f p Integer) x ->
+  select' (select' c x) x == select' c x
+
+selectIsNotUnselected _ = property $ \(c :: f p Integer) x ->
+  not $ x `member` unselected (select' c x)
+
+
+selectSelectedIdentity, unSelectedWithOptionsIdentity
+  :: forall proxy f (p :: Pick).
+  ( Selection f p
+  , Propable0 (Selected p Integer)
+  ) => proxy (f p) -> Property
+selectSelectedIdentity _ = property $ \x ->
+  selected (x `withOptions` Set.empty :: f p Integer) == x
+
+unSelectedWithOptionsIdentity _ = property $ \x ->
+  unselected (x `withOptions` Set.empty :: f p Integer ) == mempty
+
+
+retainPreserves
+  :: forall proxy f (p :: Pick).
+  ( Selection f p
+  , PickToSet p
+  ) => proxy (f p) -> Property
+retainPreserves _ = property $ \(xs' :: Set Integer) x' y' ->
+  let x, y :: Selected p Integer
+      x = pickToSelected @p x'
+      y = pickToSelected @p y'
+
+      xs :: Set Integer
+      xs = Set.insert x' $ Set.insert y' xs'
+
+      r :: f p Integer
+      r = (x `withOptions` xs) `retain` (y `withOptions` xs)
+
+   in pickToSet @p x `isSubsetOf` pickToSet @p @Integer (selected r)
+
+
+retainSets
+  :: forall proxy f (p :: Pick).
+  ( Selection f p
+  , Propable1Ord (f p)
+  ) => proxy (f p) -> Property
+retainSets _ = property $ \(c :: f p Integer) x ->
+  toSet (retain c x) == toSet x
+
+#endif
+
+
 ftoSet :: (Ord a, Foldable g) => g a -> Set a
 ftoSet = Set.fromList . F.toList
 
 
-class SetLike (f p) => Selection f (p :: Pick) where
-  select       :: Ord a => f p a -> Selected p a -> f p a
-  select'      :: Ord a => f p a -> a -> f p a
-  unselected   :: Ord a => f p a -> Set a
-  selected     :: Ord a => f p a -> Selected p a
-  withOptions  :: (Foldable g, Ord a) => Selected p a -> g a -> f p a
-  withOptions' :: (Foldable g, Ord a) => a -> g a -> f p a
+class    PickToSet (p :: Pick) where pickToSet :: Ord a => Selected p a -> Set a
+instance PickToSet 'One        where pickToSet = toSet
+instance PickToSet 'AtleastOne where pickToSet = Set.singleton
+instance PickToSet 'Many       where pickToSet = toSet
 
+
+class    PickToSelected (p :: Pick) where pickToSelected' :: Ord a => Proxy p -> a -> Selected p a
+instance PickToSelected 'One        where pickToSelected' _ = Just
+instance PickToSelected 'AtleastOne where pickToSelected' _ = id
+instance PickToSelected 'Many       where pickToSelected' _ = Set.singleton
+
+
+pickToSelected :: forall (p :: Pick) a. (Ord a, PickToSelected p) => a -> Selected p a
+pickToSelected = pickToSelected' (Proxy @p)
+
+
+class (SetLike (f p), PickToSelected p) => Selection f (p :: Pick) where
+  select        :: Ord a => f p a -> Selected p a -> f p a
+  unselected    :: Ord a => f p a -> Set a
+  selected      :: Ord a => f p a -> Selected p a
+  withOptions   :: (Foldable g, Ord a) => Selected p a -> g a -> f p a
+  retain        :: Ord a => f p a -> f p a -> f p a
+
+
+select' :: forall f (p :: Pick) a. (Selection f p, Ord a) => f p a -> a -> f p a
+select' c = select c . pickToSelected @p
+
+
+withOptions' :: forall f (p :: Pick) a g. (Selection f p, Ord a, Foldable g) => a -> g a -> f p a
+withOptions' = withOptions . pickToSelected @p
+
+
+retain' :: (Ord a, Deselection f p, Foldable g) => f p a -> g a -> f p a
+retain' xs = retain xs . noselection
+
+
 instance Selection Choice 'One where
   select (Choice w xs) y = Choice y (toSet w <> toSet y <> xs)
-  select' c = select c . Just
   unselected (Choice x xs) = maybe xs (`Set.delete` xs) x
   selected = _selected
   withOptions x (ftoSet -> xs) = Choice x $ maybe xs (`Set.insert` xs) x
-  withOptions' = withOptions . Just
+  retain (Choice w _) xs = case w of
+    Just x | Set.member x (toSet xs) -> w `withOptions` xs; _ -> xs
 
+
 instance Selection Choice 'AtleastOne where
   select (Choice _ xs) y = Choice y (Set.insert y xs)
-  select' = select
   unselected (Choice x xs) = Set.delete x xs
   selected = _selected
   withOptions x (ftoSet -> xs) = Choice x (Set.insert x xs)
-  withOptions' = withOptions
+  retain (Choice w _) xs = if Set.member w (toSet xs) then w `withOptions` xs else xs
 
+
 instance Selection Choice 'Many where
   select (Choice x xs) y = Choice (y <> x) (y <> xs)
-  select' c = select c . Set.singleton
   unselected (Choice x xs) = Set.difference xs x
   selected = _selected
   withOptions x (ftoSet -> xs) = Choice x (x <> xs)
-  withOptions' = withOptions . Set.singleton
+  retain (Choice x _) (Choice y ys) = Choice (Set.intersection x ys <> y) ys
 
 
+type family ToS (p :: Pick) :: Type -> Type where
+  ToS 'One  = Maybe
+  ToS 'Many = Set
+
+
 class Selection f p => Deselection f (p :: Pick) where
   noselection :: (Foldable g, Ord a) => g a -> f p a
   deselect    :: Ord a => f p a -> f p a
@@ -178,6 +423,115 @@
   deselect (Choice ys xs) = Choice mempty (ys <> xs)
 
 
+#ifdef TESTING
+
+
+class
+  ( Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  , Monoid    (Selected p (Sum Int))
+  , DemotePick p, PickToSet p
+  , Selected p (Sum Int) ~ ToS p (Sum Int)
+  , SetLike (ToS p)
+  , Selection f p
+  ) => PropableChoiceDe f p
+instance
+  ( Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  , Monoid    (Selected p (Sum Int))
+  , DemotePick p, PickToSet p
+  , Selected p (Sum Int) ~ ToS p (Sum Int)
+  , SetLike (ToS p)
+  , Selection f p
+  ) => PropableChoiceDe f p
+
+
+type instance Justice (Deselection f) p = PropableChoiceDe f p
+
+
+instance Legal (Deselection f) where
+  legal' (_ :: Proxy (Deselection f)) (_ :: Proxy p) =
+     deselectionLaws (Proxy @(f p))
+
+
+deselectionLaws :: forall proxy f (p :: Pick).
+  ( Deselection f p
+  , Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  , Monoid    (Selected p (Sum Int))
+  , Selected p (Sum Int) ~ ToS p (Sum Int)
+  , SetLike (ToS p)
+  , DemotePick p
+  ) => proxy (f p) -> Laws
+deselectionLaws p = Laws ("Deselection '" <> show (demotePick @p))
+  [ ("idempotence deselect",              idempotenceSelect p)
+  , ("deselect select selected identity", dselectSelectSelectedIdentity p)
+  , ("selected deselect annihliation",    selectedDeselectAnnihliation p)
+  , ("deselect keeps",                    deselectKeeps p)
+  , ("unselected passes through deselect keeps", unselectedPasses p)
+  , ("deselect unselected is full set",   deselectFullSet p)
+  ]
+
+
+idempotenceSelect, deselectFullSet
+  :: forall proxy f (p :: Pick).
+  ( Deselection f p
+  , Propable1Ord (f p)
+  ) => proxy (f p) -> Property
+idempotenceSelect _ = property $ \(c :: f p (Sum Int)) ->
+  deselect (deselect c) == deselect c
+
+
+deselectFullSet _ = property $ \(c :: f p (Sum Int)) ->
+  unselected (deselect c) == toSet c
+
+
+dselectSelectSelectedIdentity
+  :: forall proxy f (p :: Pick).
+  ( Deselection f p
+  , Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  ) => proxy (f p) -> Property
+dselectSelectSelectedIdentity _ = property $ \(c :: f p (Sum Int)) x ->
+  selected (select (deselect c) x) == x
+
+
+selectedDeselectAnnihliation
+  :: forall proxy f (p :: Pick).
+  ( Deselection f p
+  , Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  , Monoid    (Selected p (Sum Int))
+  ) => proxy (f p) -> Property
+selectedDeselectAnnihliation _ = property $ \(c :: f p (Sum Int)) ->
+  selected (deselect c) == mempty
+
+
+deselectKeeps
+  :: forall proxy f (p :: Pick).
+  ( Deselection f p
+  , Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  , Selected p (Sum Int) ~ ToS p (Sum Int)
+  , SetLike (ToS p)
+  ) => proxy (f p) -> Property
+deselectKeeps _ = property $ \(c :: f p (Sum Int)) (x :: Selected p (Sum Int)) ->
+  toSet (x :: ToS p (Sum Int)) `isSubsetOf` toSet (deselect (select c x))
+
+
+unselectedPasses
+  :: forall proxy f (p :: Pick).
+  ( Deselection f p
+  , Propable1Ord (f p)
+  , Propable0 (Selected p (Sum Int))
+  , Selected p (Sum Int) ~ ToS p (Sum Int)
+  , SetLike (ToS p)
+  ) => proxy (f p) -> Property
+unselectedPasses _ = property $ \(c :: f p (Sum Int)) (x :: Selected p (Sum Int)) ->
+  toSet x `isSubsetOf` unselected (deselect (select c x))
+#endif
+
+
 next, nextLoop, prev, prevLoop :: (Selection f 'AtleastOne, Ord a) => f 'AtleastOne a -> f 'AtleastOne a
 next     xs = maybe xs                     (select xs) . Set.lookupGT (selected xs) $ toSet xs
 nextLoop xs = maybe (unsafeSelectFirst xs) (select xs) . Set.lookupGT (selected xs) $ toSet xs
@@ -285,123 +639,7 @@
 deselectMany y = Control.Compactable.filter (`Set.member` y)
 
 
-data ConsideredChoice p a = ConsideredChoice
-  { _consideration :: Considered p a
-  , _choice        :: Choice p a
-  }
-
-
-deriving instance (Show (Selected p a), Show (Considered p a), Show a)        => Show (ConsideredChoice p a)
-deriving instance (Read (Selected p a), Read (Considered p a), Read a, Ord a) => Read (ConsideredChoice p a)
-deriving instance (Eq   (Selected p a), Eq   (Considered p a), Eq a)          => Eq   (ConsideredChoice p a)
-deriving instance (Ord  (Selected p a), Ord  (Considered p a), Ord a)         => Ord  (ConsideredChoice p a)
-deriving instance Generic (ConsideredChoice p a)
-instance (FromJSON a, FromJSON (Considered p a), FromJSON (Selected p a), Ord a) => FromJSON (ConsideredChoice p a)
-instance (ToJSON a,   ToJSON (Considered p a),   ToJSON (Selected p a))          => ToJSON   (ConsideredChoice p a)
-
-instance (Compactable (Choice p), Compactable (Considered p)) => Compactable (ConsideredChoice p) where
-  compact (ConsideredChoice x xs) = ConsideredChoice (compact x) (compact xs)
-  separate (ConsideredChoice x xs) = let (l,r) = separate xs; (l',r') = separate x in (ConsideredChoice l' l, ConsideredChoice r' r)
-  filter p (ConsideredChoice x xs) = ConsideredChoice (Control.Compactable.filter p x) $ Control.Compactable.filter p xs
-  partition p (ConsideredChoice x xs) = let (l, r) = Control.Compactable.partition p xs; (l',r') = Control.Compactable.partition p x in (ConsideredChoice l' l, ConsideredChoice r' r)
-
-instance (Ord a, Considered p ~ Maybe, Semigroup (Choice p a))
-    => Semigroup (ConsideredChoice p a) where
-  ConsideredChoice c cc <> ConsideredChoice c' cc' = ConsideredChoice (c <|> c') (cc <> cc')
-
-instance {-# OVERLAPPING #-} (Ord a) => Semigroup (ConsideredChoice 'Many a) where
-  ConsideredChoice c cc <> ConsideredChoice c' cc' = ConsideredChoice (c <> c') (cc <> cc')
-
-
-type family Considered (p :: Pick) :: Type -> Type where
-  Considered 'One        = Maybe
-  Considered 'AtleastOne = Maybe
-  Considered 'Many       = Set
-
-
-instance (Considered p ~ Maybe, SetLike (Choice p)) => SetLike (ConsideredChoice p) where
-  toSet (ConsideredChoice x xs) = toSet xs <> case x of
-    Just y -> Set.singleton y
-    _      -> mempty
-  smap f (ConsideredChoice x xs) = ConsideredChoice (f <$> x) (smap f xs)
-  valid (ConsideredChoice _ xs) = Shpadoinkle.Widgets.Types.Choice.valid xs
-
-
-instance SetLike (ConsideredChoice 'Many) where
-  toSet (ConsideredChoice ys xs) = ys <> toSet xs
-  smap f (ConsideredChoice ys xs) = ConsideredChoice (smap f ys) (smap f xs)
-  valid (ConsideredChoice ys xs) = Set.valid ys && Shpadoinkle.Widgets.Types.Choice.valid xs
-
-
-instance (Considered p ~ Maybe, SetLike (ConsideredChoice p), Selection Choice p)
-    => Selection ConsideredChoice p where
-  select  (ConsideredChoice c xs) x = ConsideredChoice c (select xs x)
-  select' (ConsideredChoice c xs) x = ConsideredChoice c (select' xs x)
-  unselected        = unselected . _choice
-  selected          = selected . _choice
-  withOptions  x xs = ConsideredChoice Nothing (x `withOptions` xs)
-  withOptions' x xs = ConsideredChoice Nothing (x `withOptions'` xs)
-
-
-instance SetLike (ConsideredChoice 'Many) => Selection ConsideredChoice 'Many where
-  select  (ConsideredChoice c xs) x = ConsideredChoice c (select xs x)
-  select' (ConsideredChoice c xs) x = ConsideredChoice c (select' xs x)
-  unselected        = unselected . _choice
-  selected          = selected . _choice
-  withOptions  x xs = ConsideredChoice mempty (x `withOptions` xs)
-  withOptions' x xs = ConsideredChoice mempty (x `withOptions'` xs)
-
-
-instance Selection ConsideredChoice 'One => Deselection ConsideredChoice 'One where
-  noselection = ConsideredChoice Nothing . noselection
-  deselect (ConsideredChoice c xs) = ConsideredChoice c $ deselect (select xs c)
-
-instance Selection ConsideredChoice 'Many => Deselection ConsideredChoice 'Many where
-  noselection = ConsideredChoice mempty . noselection
-  deselect (ConsideredChoice c xs) = ConsideredChoice c $ deselect (select xs c)
-
-
-class Selection f p => Consideration f (p :: Pick) where
-  consider   :: Ord a => Considered p a -> f p a -> f p a
-  consider'  :: Ord a => a -> f p a -> f p a
-  choose     :: Ord a => f p a -> f p a
-  choice     :: Ord a => f p a -> Choice p a
-  considered :: Ord a => f p a -> Considered p a
-  shrug      :: Ord a => f p a -> f p a
-
-instance Consideration ConsideredChoice 'One where
-  consider x = ConsideredChoice x . maybe id Shpadoinkle.Widgets.Types.Choice.insert x . _choice
-  consider' = consider @ConsideredChoice @'One . Just
-  choose (ConsideredChoice x xs) = ConsideredChoice Nothing $ select xs x
-  choice = _choice
-  considered = _consideration
-  shrug (ConsideredChoice _ xs) = ConsideredChoice Nothing xs
-
-instance Consideration ConsideredChoice 'AtleastOne where
-  consider x = ConsideredChoice x . maybe id Shpadoinkle.Widgets.Types.Choice.insert x . _choice
-  consider' = consider @ConsideredChoice @'AtleastOne . Just
-  choose (ConsideredChoice x xs) = ConsideredChoice Nothing . fromMaybe xs $ select xs <$> x
-  choice = _choice
-  considered = _consideration
-  shrug (ConsideredChoice _ xs) = ConsideredChoice Nothing xs
-
-instance Selection ConsideredChoice 'Many => Consideration ConsideredChoice 'Many where
-  consider xs (ConsideredChoice _ (Choice y ys)) = ConsideredChoice xs (Choice y (xs <> ys))
-  consider' = consider @ConsideredChoice @'Many . Set.singleton
-  choose (ConsideredChoice s xs) = ConsideredChoice Set.empty $ select xs s
-  choice = _choice
-  considered = _consideration
-  shrug (ConsideredChoice _ xs) = ConsideredChoice mempty xs
-
-
-unsafeConsiderFirst :: (Consideration f p, Ord a) => f p a -> f p a
-unsafeConsiderFirst c = Set.findMin (toSet c) `consider'` c
-
-
-unsafeConsiderLast :: (Consideration f p, Ord a) => f p a -> f p a
-unsafeConsiderLast c = Set.findMax (toSet c) `consider'` c
-
-
-considerNext, considerPrev :: (Considered p a ~ Maybe a, Consideration f p, Ord a) => f p a -> f p a
-considerNext c = maybe (unsafeConsiderFirst c) (`consider'` c) $ considered c >>= (\x -> Set.lookupGT x $ toSet c)
-considerPrev c = maybe (unsafeConsiderLast c)  (`consider'` c) $ considered c >>= (\x -> Set.lookupLT x $ toSet c)
+#ifdef TESTING
+instance (Ord a, Arbitrary a, Arbitrary (Selected p a)) => Arbitrary (Choice p a) where
+  arbitrary = Choice <$> arbitrary <*> arbitrary
+#endif
diff --git a/Shpadoinkle/Widgets/Types/ConsideredChoice.hs b/Shpadoinkle/Widgets/Types/ConsideredChoice.hs
new file mode 100644
--- /dev/null
+++ b/Shpadoinkle/Widgets/Types/ConsideredChoice.hs
@@ -0,0 +1,186 @@
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveFoldable        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE IncoherentInstances   #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+
+module Shpadoinkle.Widgets.Types.ConsideredChoice where
+
+
+import           Control.Applicative              (Alternative ((<|>)))
+import           Control.Compactable              (Compactable (compact, filter, partition, separate))
+import           Data.Aeson                       (FromJSON, ToJSON)
+import           Data.Kind                        (Type)
+import           Data.Proxy
+import           Data.Set                         as Set
+import           GHC.Generics                     (Generic)
+#ifdef TESTING
+import           Test.QuickCheck                  (Arbitrary (..))
+#endif
+
+
+import           Shpadoinkle.Widgets.Types.Choice
+
+
+data ConsideredChoice p a = ConsideredChoice
+  { _consideration :: Considered p a
+  , _choice        :: Choice p a
+  }
+
+
+deriving instance (Show (Selected p a), Show (Considered p a), Show a)        => Show (ConsideredChoice p a)
+deriving instance (Read (Selected p a), Read (Considered p a), Read a, Ord a) => Read (ConsideredChoice p a)
+deriving instance (Eq   (Selected p a), Eq   (Considered p a), Eq a)          => Eq   (ConsideredChoice p a)
+deriving instance (Ord  (Selected p a), Ord  (Considered p a), Ord a)         => Ord  (ConsideredChoice p a)
+deriving instance (Foldable (Choice p), Foldable (Considered p))             => Foldable (ConsideredChoice p)
+deriving instance Generic (ConsideredChoice p a)
+instance (FromJSON a, FromJSON (Considered p a), FromJSON (Selected p a), Ord a) => FromJSON (ConsideredChoice p a)
+instance (ToJSON a,   ToJSON (Considered p a),   ToJSON (Selected p a))          => ToJSON   (ConsideredChoice p a)
+
+instance (Compactable (Choice p), Compactable (Considered p)) => Compactable (ConsideredChoice p) where
+  compact (ConsideredChoice x xs) = ConsideredChoice (compact x) (compact xs)
+  separate (ConsideredChoice x xs) = let (l,r) = separate xs; (l',r') = separate x in (ConsideredChoice l' l, ConsideredChoice r' r)
+  filter p (ConsideredChoice x xs) = ConsideredChoice (Control.Compactable.filter p x) $ Control.Compactable.filter p xs
+  partition p (ConsideredChoice x xs) = let (l, r) = Control.Compactable.partition p xs; (l',r') = Control.Compactable.partition p x in (ConsideredChoice l' l, ConsideredChoice r' r)
+
+instance (Ord a, Considered p ~ Maybe, Semigroup (Choice p a))
+    => Semigroup (ConsideredChoice p a) where
+  ConsideredChoice c cc <> ConsideredChoice c' cc' = ConsideredChoice (c <|> c') (cc <> cc')
+
+instance (Ord a, Considered p ~ Maybe, Monoid (Choice p a))
+    => Monoid (ConsideredChoice p a) where
+      mempty = ConsideredChoice Nothing mempty
+
+instance {-# OVERLAPPING #-} (Semigroup a, Ord a) => Semigroup (ConsideredChoice 'Many a) where
+  ConsideredChoice c cc <> ConsideredChoice c' cc' = ConsideredChoice (c <> c') (cc <> cc')
+
+instance {-# OVERLAPPING #-} (Semigroup a, Ord a)
+    => Monoid (ConsideredChoice 'Many a) where
+      mempty = ConsideredChoice mempty mempty
+
+
+type family Considered (p :: Pick) :: Type -> Type where
+  Considered 'One        = Maybe
+  Considered 'AtleastOne = Maybe
+  Considered 'Many       = Set
+
+
+class    PickToConsidered (p :: Pick) where pickToConsidered' :: Proxy p -> a -> Considered p a
+instance PickToConsidered 'One        where pickToConsidered' _ = Just
+instance PickToConsidered 'AtleastOne where pickToConsidered' _ = Just
+instance PickToConsidered 'Many       where pickToConsidered' _ = Set.singleton
+
+
+pickToConsidered :: forall (p :: Pick) a. PickToConsidered p => a -> Considered p a
+pickToConsidered = pickToConsidered' (Proxy @p)
+
+
+instance (Considered p ~ Maybe, SetLike (Choice p)) => SetLike (ConsideredChoice p) where
+  toSet (ConsideredChoice x xs) = toSet xs <> case x of
+    Just y -> Set.singleton y
+    _      -> mempty
+  smap f (ConsideredChoice x xs) = ConsideredChoice (f <$> x) (smap f xs)
+  valid (ConsideredChoice _ xs) = Shpadoinkle.Widgets.Types.Choice.valid xs
+
+
+instance SetLike (ConsideredChoice 'Many) where
+  toSet (ConsideredChoice ys xs) = ys <> toSet xs
+  smap f (ConsideredChoice ys xs) = ConsideredChoice (smap f ys) (smap f xs)
+  valid (ConsideredChoice ys xs) = Set.valid ys && Shpadoinkle.Widgets.Types.Choice.valid xs
+
+
+instance (PickToSelected p, Considered p ~ Maybe, SetLike (ConsideredChoice p), Selection Choice p)
+    => Selection ConsideredChoice p where
+  select  (ConsideredChoice c xs) x = ConsideredChoice c (select xs x)
+  unselected        = unselected . _choice
+  selected          = selected . _choice
+  withOptions  x xs = ConsideredChoice Nothing (x `withOptions` xs)
+  retain  (ConsideredChoice c xs) ys@(ConsideredChoice c' (Choice y ys')) =
+    ConsideredChoice (case c of Just x | Set.member x (toSet ys) -> c; _ -> c') (retain xs $ case c' of
+      Nothing  -> Choice y ys'
+      Just c'' -> Choice y $ Set.insert c'' ys')
+
+
+instance SetLike (ConsideredChoice 'Many) => Selection ConsideredChoice 'Many where
+  select  (ConsideredChoice c xs) x = ConsideredChoice c (select xs x)
+  unselected        = unselected . _choice
+  selected          = selected . _choice
+  withOptions  x xs = ConsideredChoice mempty (x `withOptions` xs)
+  retain  (ConsideredChoice x xs) ys@(ConsideredChoice y ys')  =
+    ConsideredChoice (Set.intersection x (toSet ys) <> y) (retain xs ys')
+
+
+instance Selection ConsideredChoice 'One => Deselection ConsideredChoice 'One where
+  noselection = ConsideredChoice Nothing . noselection
+  deselect (ConsideredChoice c xs) = ConsideredChoice c $ deselect (select xs c)
+
+instance Selection ConsideredChoice 'Many => Deselection ConsideredChoice 'Many where
+  noselection = ConsideredChoice mempty . noselection
+  deselect (ConsideredChoice c xs) = ConsideredChoice c $ deselect (select xs c)
+
+
+class (Selection f p, PickToConsidered p) => Consideration f (p :: Pick) where
+  consider      :: Ord a => Considered p a -> f p a -> f p a
+  choose        :: Ord a => f p a -> f p a
+  choice        :: Ord a => f p a -> Choice p a
+  considered    :: Ord a => f p a -> Considered p a
+  shrug         :: Ord a => f p a -> f p a
+
+
+consider'
+  :: forall (f :: Pick -> Type -> Type) p a
+   . (Ord a, Consideration f p)
+  => a -> f p a -> f p a
+consider' = consider @f @p . pickToConsidered @p
+
+
+instance Consideration ConsideredChoice 'One where
+  consider x = ConsideredChoice x . maybe id Shpadoinkle.Widgets.Types.Choice.insert x . _choice
+  choose (ConsideredChoice x xs) = ConsideredChoice Nothing $ select xs x
+  choice = _choice
+  considered = _consideration
+  shrug (ConsideredChoice _ xs) = ConsideredChoice Nothing xs
+
+instance Consideration ConsideredChoice 'AtleastOne where
+  consider x = ConsideredChoice x . maybe id Shpadoinkle.Widgets.Types.Choice.insert x . _choice
+  choose (ConsideredChoice x xs) = ConsideredChoice Nothing (maybe xs (select xs) x)
+  choice = _choice
+  considered = _consideration
+  shrug (ConsideredChoice _ xs) = ConsideredChoice Nothing xs
+
+instance Selection ConsideredChoice 'Many => Consideration ConsideredChoice 'Many where
+  consider xs (ConsideredChoice _ (Choice y ys)) = ConsideredChoice xs (Choice y (xs <> ys))
+  choose (ConsideredChoice s xs) = ConsideredChoice Set.empty $ select xs s
+  choice = _choice
+  considered = _consideration
+  shrug (ConsideredChoice _ xs) = ConsideredChoice mempty xs
+
+
+unsafeConsiderFirst :: (Consideration f p, Ord a) => f p a -> f p a
+unsafeConsiderFirst c = Set.findMin (toSet c) `consider'` c
+
+
+unsafeConsiderLast :: (Consideration f p, Ord a) => f p a -> f p a
+unsafeConsiderLast c = Set.findMax (toSet c) `consider'` c
+
+
+considerNext, considerPrev :: (Considered p a ~ Maybe a, Consideration f p, Ord a) => f p a -> f p a
+considerNext c = maybe (unsafeConsiderFirst c) (`consider'` c) $ considered c >>= (\x -> Set.lookupGT x $ toSet c)
+considerPrev c = maybe (unsafeConsiderLast c)  (`consider'` c) $ considered c >>= (\x -> Set.lookupLT x $ toSet c)
+
+
+#ifdef TESTING
+instance (Ord a, Arbitrary a, Arbitrary (Selected p a), Arbitrary (Considered p a)) => Arbitrary (ConsideredChoice p a) where
+  arbitrary = ConsideredChoice <$> arbitrary <*> arbitrary
+#endif
diff --git a/Shpadoinkle/Widgets/Types/Core.hs b/Shpadoinkle/Widgets/Types/Core.hs
--- a/Shpadoinkle/Widgets/Types/Core.hs
+++ b/Shpadoinkle/Widgets/Types/Core.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE CPP                  #-}
 {-# LANGUAGE ConstraintKinds      #-}
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE DefaultSignatures    #-}
@@ -8,7 +9,6 @@
 {-# LANGUAGE InstanceSigs         #-}
 {-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -19,6 +19,9 @@
 import           Data.Aeson
 import           Data.Text
 import           GHC.Generics
+#ifdef TESTING
+import           Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum)
+#endif
 
 import           Shpadoinkle
 
@@ -29,7 +32,7 @@
 
 instance Semigroup Hygiene where
   Clean <> Clean = Clean
-  _ <> _ = Dirty
+  _ <> _         = Dirty
 
 
 instance Monoid Hygiene where
@@ -75,3 +78,7 @@
 
 
 instance {-# OVERLAPPABLE #-} Humanize a => Present a
+
+#ifdef TESTING
+instance Arbitrary Hygiene where arbitrary = arbitraryBoundedEnum
+#endif
diff --git a/Shpadoinkle/Widgets/Types/Form.hs b/Shpadoinkle/Widgets/Types/Form.hs
--- a/Shpadoinkle/Widgets/Types/Form.hs
+++ b/Shpadoinkle/Widgets/Types/Form.hs
@@ -1,9 +1,8 @@
 {-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DefaultSignatures          #-}
 {-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveFoldable             #-}
-{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE DerivingStrategies         #-}
@@ -20,19 +19,24 @@
 
 
 module Shpadoinkle.Widgets.Types.Form
-  (module Shpadoinkle.Widgets.Types.Form
+  ( module Shpadoinkle.Widgets.Types.Form
   ) where
 
 
-import           Control.Applicative
-import           Control.Monad.Except
-import           Data.Aeson
-import           Data.Kind
-import           Data.String
-import           Data.Text                      hiding (empty)
+import           Control.Applicative            (Alternative (empty),
+                                                 Applicative (liftA2),
+                                                 Const (Const, getConst))
+import           Control.Monad.Except           (MonadError (..))
+import           Data.Aeson                     (FromJSON, ToJSON)
+import           Data.Kind                      (Type)
+import           Data.String                    (IsString)
+import           Data.Text                      (Text)
 import           GHC.Generics
+#ifdef TESTING
+import           Test.QuickCheck                (Arbitrary (..), elements)
+#endif
 
-import           Shpadoinkle.Widgets.Types.Core
+import           Shpadoinkle.Widgets.Types.Core (Hygiene)
 
 
 data Input a = Input
@@ -41,10 +45,15 @@
   } deriving (Eq, Ord, Show, Read, Functor, Traversable, Foldable, Generic, ToJSON, FromJSON)
 
 
+#ifdef TESTING
+instance Arbitrary a => Arbitrary (Input a) where arbitrary = Input <$> arbitrary <*> arbitrary
+#endif
+
+
 class Control g where
   type Val g a :: Type
   type Val g a = a
-  hygiene :: Applicative f => (Hygiene -> f Hygiene) -> g a -> f (g a)
+  hygiene ::  Applicative f => (Hygiene -> f Hygiene) -> g a -> f (g a)
   value   :: (Applicative f, Ord a) => (Val g a -> f (Val g a)) -> g a -> f (g a)
 
 
@@ -88,21 +97,21 @@
 
 
 instance Semigroup (Validated e a) where
-  Validated a <> Validated _ = Validated a
-  Validated _ <> x = x
-  x <> Validated _ = x
+  Validated a <> Validated _   = Validated a
+  Validated _ <> x             = x
+  x <> Validated _             = x
   Invalid x xs <> Invalid y ys = Invalid x (xs <> (y:ys))
 
 
 instance Applicative (Validated e) where
   Validated f <*> Validated a = Validated (f a)
-  Invalid x xs <*> _ = Invalid x xs
-  _ <*> Invalid x xs = Invalid x xs
+  Invalid x xs <*> _          = Invalid x xs
+  _ <*> Invalid x xs          = Invalid x xs
   pure = Validated
 
 
 instance Monad (Validated e) where
-  Validated a >>= f = f a
+  Validated a >>= f  = f a
   Invalid x xs >>= _ = Invalid x xs
 
 
@@ -177,3 +186,11 @@
   getValid = fmap to . validg . from
 
   rules :: f 'Rules
+
+
+#ifdef TESTING
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Validated a b) where
+  arbitrary = do
+    (e, es, a) <- (,,) <$> arbitrary <*> arbitrary <*> arbitrary
+    elements [ Validated  a, Invalid  e es ]
+#endif
diff --git a/Shpadoinkle/Widgets/Types/Physical.hs b/Shpadoinkle/Widgets/Types/Physical.hs
--- a/Shpadoinkle/Widgets/Types/Physical.hs
+++ b/Shpadoinkle/Widgets/Types/Physical.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE CPP            #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
 {-# LANGUAGE LambdaCase     #-}
+{-# LANGUAGE TupleSections  #-}
 
 
 module Shpadoinkle.Widgets.Types.Physical where
@@ -9,6 +11,10 @@
 import           Data.Aeson
 import           Data.Functor.Identity
 import           GHC.Generics
+#ifdef TESTING
+import           Test.QuickCheck                (Arbitrary (..),
+                                                 arbitraryBoundedEnum)
+#endif
 
 import           Shpadoinkle.Html               hiding (s)
 import           Shpadoinkle.Widgets.Types.Core
@@ -22,19 +28,29 @@
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, ToJSON, FromJSON)
 
 
+instance Semigroup Hover where
+  MouseOver <> _ = MouseOver
+  _ <> MouseOver = MouseOver
+  _ <> _         = MouseOut
+
+
+instance Monoid Hover where
+  mempty = MouseOut
+
+
 withHover
   :: ((Hover, a) -> Html m (Hover, a))
   ->  (Hover, a) -> Html m (Hover, a)
-withHover f s@(_,x) = runIdentity . props
-  (Identity . mappend [ onMouseenter (MouseOver, x)
-                      , onMouseleave (MouseOut,  x)
-                      ]) $ f s
+withHover f = runIdentity . props
+  (Identity . mappend [ onMouseenter $ (MouseOver, ) . snd
+                      , onMouseleave $ (MouseOut,  ) . snd
+                      ]) . f
 
 
 togHygiene :: Toggle -> Hygiene
 togHygiene = \case
   Closed x -> x
-  _ -> Dirty
+  Open     -> Dirty
 
 
 instance Enum Toggle where
@@ -54,11 +70,11 @@
 
 instance Semigroup Toggle where
   Closed x <> Closed y = Closed (x <> y)
-  Closed Clean <> x = x
-  x <> Closed Clean = x
-  Closed Dirty <> _ = Closed Dirty
-  _ <> Closed Dirty = Closed Dirty
-  _ <> _ = Open
+  Closed Clean <> x    = x
+  x <> Closed Clean    = x
+  Closed Dirty <> _    = Closed Dirty
+  _ <> Closed Dirty    = Closed Dirty
+  _ <> _               = Open
 
 
 instance Monoid Toggle where
@@ -86,3 +102,10 @@
 
 data Visbility = Visible | Hidden
   deriving (Eq, Ord, Show, Enum, Bounded, Generic)
+
+
+#ifdef TESTING
+instance Arbitrary Toggle    where arbitrary = arbitraryBoundedEnum
+instance Arbitrary Hover     where arbitrary = arbitraryBoundedEnum
+instance Arbitrary Visbility where arbitrary = arbitraryBoundedEnum
+#endif
diff --git a/Shpadoinkle/Widgets/Types/Remote.hs b/Shpadoinkle/Widgets/Types/Remote.hs
--- a/Shpadoinkle/Widgets/Types/Remote.hs
+++ b/Shpadoinkle/Widgets/Types/Remote.hs
@@ -1,6 +1,5 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveFoldable    #-}
-{-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE DeriveTraversable #-}
 
@@ -11,6 +10,9 @@
 import           Control.Applicative
 import           Data.Aeson          (FromJSON, ToJSON)
 import           GHC.Generics
+#ifdef TESTING
+import           Test.QuickCheck     (Arbitrary (..), elements)
+#endif
 
 
 data Remote e a
@@ -24,23 +26,25 @@
 instance Applicative (Remote e) where
   pure = Success
   Success f <*> Success x = Success (f x)
-  Failure e <*> _ = Failure e
-  _ <*> Failure e = Failure e
-  Loading <*> _   = Loading
-  _ <*> Loading   = Loading
-  NotAsked <*> _  = NotAsked
-  _ <*> NotAsked  = NotAsked
+  Failure e <*> _         = Failure e
+  Loading <*> _           = Loading
+  NotAsked <*> _          = NotAsked
+  _ <*> Failure e         = Failure e
+  _ <*> Loading           = Loading
+  _ <*> NotAsked          = NotAsked
 
 
 instance Alternative (Remote e) where
    empty = NotAsked
    x@(Success _) <|> _ = x
-   _ <|> x = x
+   NotAsked <|> x      = x
+   x <|> NotAsked      = x
+   _ <|> x             = x
 
 
 instance Semigroup a => Semigroup (Remote e a) where
   Success x <> Success y = Success (x <> y)
-  x <> y = x <|> y
+  x <> y                 = x <|> y
 
 
 instance Semigroup a => Monoid (Remote e a) where
@@ -52,3 +56,11 @@
   Failure e >>= _ = Failure e
   NotAsked  >>= _ = NotAsked
   Loading   >>= _ = Loading
+
+
+#ifdef TESTING
+instance (Arbitrary e, Arbitrary a) => Arbitrary (Remote e a) where
+  arbitrary = do
+    (e, a) <- (,) <$> arbitrary <*> arbitrary
+    elements [ Success a, Failure e, Loading, NotAsked ]
+#endif
diff --git a/Shpadoinkle/Widgets/Types/Search.hs b/Shpadoinkle/Widgets/Types/Search.hs
--- a/Shpadoinkle/Widgets/Types/Search.hs
+++ b/Shpadoinkle/Widgets/Types/Search.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -10,14 +8,15 @@
 module Shpadoinkle.Widgets.Types.Search where
 
 
-import           Data.Aeson
-import           Data.Foldable     as F
+import           Data.Aeson        (FromJSON, ToJSON)
+import           Data.Foldable     as F (Foldable (foldl'))
 import           Data.List         (sort)
 import           Data.Maybe        (mapMaybe)
-import           Data.String
-import           Data.Text
-import           GHC.Generics
-import           Text.EditDistance
+import           Data.String       (IsString)
+import           Data.Text         (Text, isInfixOf, splitOn, strip, toLower,
+                                    unpack)
+import           GHC.Generics      (Generic)
+import           Text.EditDistance (defaultEditCosts, levenshteinDistance)
 
 
 newtype Search = Search { unSearch :: Text }
@@ -36,8 +35,8 @@
 
 
 mkLevenshtiened :: Text -> Search -> a -> Levenshtiened a
-mkLevenshtiened  t (Search s) x =
-  Levenshtiened (EditDistance $ levenshteinDistance defaultEditCosts (prep s) (prep t)) x
+mkLevenshtiened  t (Search s) =
+  Levenshtiened . EditDistance $ levenshteinDistance defaultEditCosts (prep s) (prep t)
   where prep = unpack . strip
 
 
@@ -46,7 +45,7 @@
 forgivingly (Search s) haystack = Prelude.all test . splitOn " " $ strip s
   where test ""     = False
         test needle = forgive needle `isInfixOf` forgive haystack
-        forgive = toLower . strip
+        forgive     = toLower . strip
 
 
 concatFuzzy :: [a -> Text] -> a -> Text
diff --git a/Shpadoinkle/Widgets/Validation.hs b/Shpadoinkle/Widgets/Validation.hs
--- a/Shpadoinkle/Widgets/Validation.hs
+++ b/Shpadoinkle/Widgets/Validation.hs
@@ -51,3 +51,5 @@
 
 email :: Text -> Validated Text Text
 email i = if isValid (encodeUtf8 i) then pure i else throwError "Not a valid email"
+
+
diff --git a/Test/QuickCheck/Classes/FoldableOrd.hs b/Test/QuickCheck/Classes/FoldableOrd.hs
new file mode 100644
--- /dev/null
+++ b/Test/QuickCheck/Classes/FoldableOrd.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE QuantifiedConstraints      #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# OPTIONS_GHC -fno-warn-orphans       #-}
+
+module Test.QuickCheck.Classes.FoldableOrd
+  (
+    foldableLaws
+  ) where
+
+import           Control.Exception                (ErrorCall, evaluate, try)
+import           Control.Monad.Trans.Class        (lift)
+import           Test.QuickCheck                  hiding ((.&.))
+import           Test.QuickCheck.Monadic          (monadicIO)
+import           Test.QuickCheck.Property         (Property)
+
+import qualified Data.Foldable                    as F
+import qualified Data.Semigroup                   as SG
+
+import           Test.QuickCheck.Classes.Internal
+
+
+newtype ApplyOrd f a = ApplyOrd { unApplyOrd :: f a }
+deriving instance (forall x. Eq x   => Eq (f x),   Eq a)   => Eq   (ApplyOrd f a)
+deriving instance (forall x. Show x => Show (f x), Show a) => Show (ApplyOrd f a)
+deriving instance
+  ( forall x. (Ord x, Arbitrary x) => Arbitrary (f x)
+  , Ord a
+  , Arbitrary a
+  ) => Arbitrary (ApplyOrd f a)
+
+
+deriving instance Ord (Bottom Integer)
+deriving instance Ord (VerySmallList Integer)
+
+
+-- | Tests the following 'Foldable' properties:
+--
+-- [/fold/]
+--   @'fold' ≡ 'foldMap' 'id'@
+-- [/foldMap/]
+--   @'foldMap' f ≡ 'foldr' ('mappend' . f) 'mempty'@
+-- [/foldr/]
+--   @'foldr' f z t ≡ 'appEndo' ('foldMap' ('Endo' . f) t ) z@
+-- [/foldr'/]
+--   @'foldr'' f z0 xs ≡ let f\' k x z = k '$!' f x z in 'foldl' f\' 'id' xs z0@
+-- [/foldr1/]
+--   @'foldr1' f t ≡ let 'Just' (xs,x) = 'unsnoc' ('toList' t) in 'foldr' f x xs@
+-- [/foldl/]
+--   @'foldl' f z t ≡ 'appEndo' ('getDual' ('foldMap' ('Dual' . 'Endo' . 'flip' f) t)) z@
+-- [/foldl'/]
+--   @'foldl'' f z0 xs ≡ let f' x k z = k '$!' f z x in 'foldr' f\' 'id' xs z0@
+-- [/foldl1/]
+--   @'foldl1' f t ≡ let x : xs = 'toList' t in 'foldl' f x xs@
+-- [/toList/]
+--   @'F.toList' ≡ 'foldr' (:) []@
+-- [/null/]
+--   @'null' ≡ 'foldr' ('const' ('const' 'False')) 'True'@
+-- [/length/]
+--   @'length' ≡ 'getSum' . 'foldMap' ('const' ('Sum' 1))@
+--
+-- Note that this checks to ensure that @foldl\'@ and @foldr\'@
+-- are suitably strict.
+foldableLaws :: forall proxy f.
+  (Foldable f, forall a. Show a => Show (f a), forall a. (Arbitrary a, Ord a) => Arbitrary (f a))
+  => proxy f -> Laws
+foldableLaws = foldableLawsInternal
+
+foldableLawsInternal :: forall proxy f.
+  (Foldable f, forall a. Show a => Show (f a), forall a. (Arbitrary a, Ord a) => Arbitrary (f a))
+  => proxy f -> Laws
+foldableLawsInternal p = Laws "Foldable"
+  [ (,) "fold" $ property $ \(ApplyOrd (a :: f (VerySmallList Integer))) ->
+      F.fold a == F.foldMap id a
+  , (,) "foldMap" $ property $ \(ApplyOrd (a :: f Integer)) (e :: QuadraticEquation) ->
+      let f = VerySmallList . return . runQuadraticEquation e
+       in F.foldMap f a == F.foldr (mappend . f) mempty a
+  , (,) "foldr" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (ApplyOrd (t :: f Integer)) ->
+      let f = runLinearEquationTwo e
+       in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z
+  , (,) "foldr'" (foldableFoldr' p)
+  , (,) "foldl" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (ApplyOrd (t :: f Integer)) ->
+      let f = runLinearEquationTwo e
+       in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z
+  , (,) "foldl'" (foldableFoldl' p)
+  , (,) "foldl1" $ property $ \(e :: LinearEquationTwo) (ApplyOrd (t :: f Integer)) ->
+      case compatToList t of
+        [] -> True
+        x : xs ->
+          let f = runLinearEquationTwo e
+           in F.foldl1 f t == F.foldl f x xs
+  , (,) "foldr1" $ property $ \(e :: LinearEquationTwo) (ApplyOrd (t :: f Integer)) ->
+      case unsnoc (compatToList t) of
+        Nothing -> True
+        Just (xs,x) ->
+          let f = runLinearEquationTwo e
+           in F.foldr1 f t == F.foldr f x xs
+  , (,) "toList" $ property $ \(ApplyOrd (t :: f Integer)) ->
+      eq1 (F.toList t) (F.foldr (:) [] t)
+#if MIN_VERSION_base(4,8,0)
+  , (,) "null" $ property $ \(ApplyOrd (t :: f Integer)) ->
+      null t == F.foldr (const (const False)) True t
+  , (,) "length" $ property $ \(ApplyOrd (t :: f Integer)) ->
+      F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t)
+#endif
+  ]
+
+unsnoc :: [a] -> Maybe ([a],a)
+unsnoc []       = Nothing
+unsnoc [x]      = Just ([],x)
+unsnoc (x:y:xs) = fmap (\(bs,b) -> (x:bs,b)) (unsnoc (y : xs))
+
+compatToList :: Foldable f => f a -> [a]
+compatToList = foldMap (\x -> [x])
+
+foldableFoldl' :: forall proxy f.
+  (Foldable f, forall a. Show a => Show (f a), forall a. (Arbitrary a, Ord a) => Arbitrary (f a))
+  => proxy f -> Property
+foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (ApplyOrd (xs :: f (Bottom Integer))) ->
+  monadicIO $ do
+    let f :: Integer -> Bottom Integer -> Integer
+        f a b = case b of
+          BottomUndefined -> error "foldableFoldl' example"
+          BottomValue v -> if even v
+            then a
+            else v
+        z0 = 0
+    r1 <- lift $ do
+      let f' x k z = k $! f z x
+      e <- try (evaluate (F.foldr f' id xs z0))
+      case e of
+        Left (_ :: ErrorCall) -> return Nothing
+        Right i               -> return (Just i)
+    r2 <- lift $ do
+      e <- try (evaluate (F.foldl' f z0 xs))
+      case e of
+        Left (_ :: ErrorCall) -> return Nothing
+        Right i               -> return (Just i)
+    return (r1 == r2)
+
+foldableFoldr' :: forall proxy f.
+  (Foldable f, forall a. Show a => Show (f a), forall a. (Arbitrary a, Ord a) => Arbitrary (f a))
+  => proxy f -> Property
+foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (ApplyOrd (xs :: f (Bottom Integer))) ->
+  monadicIO $ do
+    let f :: Bottom Integer -> Integer -> Integer
+        f a b = case a of
+          BottomUndefined -> error "foldableFoldl' example"
+          BottomValue v -> if even v
+            then v
+            else b
+        z0 = 0
+    r1 <- lift $ do
+      let f' k x z = k $! f x z
+      e <- try (evaluate (F.foldl f' id xs z0))
+      case e of
+        Left (_ :: ErrorCall) -> return Nothing
+        Right i               -> return (Just i)
+    r2 <- lift $ do
+      e <- try (evaluate (F.foldr' f z0 xs))
+      case e of
+        Left (_ :: ErrorCall) -> return Nothing
+        Right i               -> return (Just i)
+    return (r1 == r2)
+
+{-# ANN module ("HLint: ignore" :: String) #-}
diff --git a/Test/QuickCheck/Classes/Hspec.hs b/Test/QuickCheck/Classes/Hspec.hs
new file mode 100644
--- /dev/null
+++ b/Test/QuickCheck/Classes/Hspec.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# OPTIONS_GHC -fno-warn-implicit-kind-vars #-}
+
+
+module Test.QuickCheck.Classes.Hspec where
+
+
+import           Control.Applicative                 (Alternative)
+import           Data.Kind
+import           Data.Proxy
+
+import           Test.Hspec
+import           Test.QuickCheck
+import           Test.QuickCheck.Classes
+import qualified Test.QuickCheck.Classes.FoldableOrd as Ord
+
+
+toSpec :: Laws -> Spec
+toSpec (Laws name ps) = describe name $
+  () <$ traverse (\(name', p) -> it name' $ property p) ps
+
+
+legal :: forall c a.
+  ( Legal c, c a, Justice c a) => Spec
+legal = toSpec $ legal' (Proxy @c) (Proxy @a)
+
+
+class Legal (c :: k -> Constraint) where
+  legal' :: forall (a :: k). (c a, Justice c a) => Proxy c -> Proxy a -> Laws
+
+
+class
+  ( forall a. Eq        a => Eq        (f a)
+  , forall a. Show      a => Show      (f a)
+  , forall a. Arbitrary a => Arbitrary (f a)
+  ) => Propable1 f
+instance
+  ( forall a. Eq        a => Eq        (f a)
+  , forall a. Show      a => Show      (f a)
+  , forall b. Arbitrary b => Arbitrary (f b)
+  ) => Propable1 f
+
+
+class
+  ( forall a. Eq        a => Eq        (f a)
+  , forall a. Show      a => Show      (f a)
+  , forall a. Ord       a => Ord       (f a)
+  , forall g. (Ord g, Arbitrary g) => Arbitrary (f g)
+  ) => Propable1Ord f
+instance
+  ( forall a. Eq        a => Eq        (f a)
+  , forall a. Show      a => Show      (f a)
+  , forall a. Ord       a => Ord       (f a)
+  , forall c. (Ord c, Arbitrary c) => Arbitrary (f c)
+  ) => Propable1Ord f
+
+
+class    (Eq a, Show a, Arbitrary a) => Propable0 a
+instance (Eq a, Show a, Arbitrary a) => Propable0 a
+class    (Bounded a, Eq a, Show a, Arbitrary a) => Propable0Bounded a
+instance (Bounded a, Eq a, Show a, Arbitrary a) => Propable0Bounded a
+
+
+type family Justice
+  (c :: k -> Constraint)
+  (a :: k)
+     :: Constraint
+
+
+type instance Justice Monoid      a = Propable0 a
+type instance Justice Semigroup   a = Propable0 a
+type instance Justice Eq          a = Propable0 a
+type instance Justice Enum        a = Propable0Bounded a
+type instance Justice Ord         a = Propable0 a
+type instance Justice Functor     f = Propable1 f
+type instance Justice Applicative f = Propable1 f
+type instance Justice Alternative f = Propable1 f
+type instance Justice Monad       f = Propable1 f
+type instance Justice Show        a = Propable0 a
+type instance Justice Foldable    f = Propable1Ord f
+type instance Justice Traversable f = Propable1 f
+
+-- foldableLawsOrd :: forall proxy f.
+--   ( Foldable f
+--   , forall w. Eq        w => Eq   (f w)
+--   , forall e. Show      e => Show (f e)
+--   , forall s. Ord       s => Ord  (f s)
+--   , forall q. (Arbitrary q, Ord q) => Arbitrary (f q))
+--   => proxy f -> Laws
+-- foldableLawsOrd = foldableLaws
+
+
+instance Legal Monoid      where legal' _ = monoidLaws
+instance Legal Semigroup   where legal' _ = semigroupLaws
+instance Legal Eq          where legal' _ = eqLaws
+instance Legal Enum        where legal' _ = boundedEnumLaws
+instance Legal Ord         where legal' _ = ordLaws
+instance Legal Functor     where legal' _ = functorLaws
+instance Legal Applicative where legal' _ = applicativeLaws
+instance Legal Alternative where legal' _ = alternativeLaws
+instance Legal Monad       where legal' _ = monadLaws
+instance Legal Show        where legal' _ = showLaws
+instance Legal Foldable    where legal' _ = Ord.foldableLaws
+-- instance Legal Traversable where legal' _ = traversableLaws
diff --git a/tests/Test.hs b/tests/Test.hs
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -1,205 +1,197 @@
-{-# LANGUAGE AllowAmbiguousTypes  #-}
-{-# LANGUAGE ConstraintKinds      #-}
-{-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DeriveGeneric        #-}
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE KindSignatures       #-}
-{-# LANGUAGE RankNTypes           #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TypeApplications     #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 
 module Main where
 
 
-import           Data.Kind
+import           Control.Applicative               (Alternative)
+import           Data.Monoid                       (Sum)
 import           Data.Set                          as Set
-import           GHC.Generics
 
 import           Test.Hspec
-import           Test.QuickCheck
-
+import           Test.QuickCheck.Classes.Hspec
 
 import           Shpadoinkle.Widgets.Form.Dropdown
 import           Shpadoinkle.Widgets.Types
 
 
-data Foo = Bar | Baz | Qux | Nerp
-  deriving (Eq, Ord, Show, Enum, Bounded, Generic)
-
-
-instance Semigroup Foo where (<>) = min
-instance Monoid Foo where mempty = maxBound
-
-
-instance Arbitrary Foo where
-  arbitrary = arbitraryBoundedEnum
-
-instance (Ord a, Arbitrary a, Arbitrary (Selected p a)) => Arbitrary (Choice p a) where
-  arbitrary = Choice <$> arbitrary <*> arbitrary
-
-instance (Ord a, Arbitrary a, Arbitrary (Selected p a), Arbitrary (Considered p a)) => Arbitrary (ConsideredChoice p a) where
-  arbitrary = ConsideredChoice <$> arbitrary <*> arbitrary
-
-instance (Ord a, Arbitrary a, Arbitrary (ConsideredChoice p a)) => Arbitrary (Dropdown p a) where
-  arbitrary = Dropdown <$> arbitrary <*> arbitrary
-
-instance Arbitrary Toggle where
-  arbitrary = arbitraryBoundedEnum
-
-
-type TestConstrant f p =
-  ( Arbitrary (f p Foo)
-  , Selection f p
-  , Show (f p Foo)
-  , Eq (f p Foo)
-  )
-
-
-type TestConstrants f =
-  ( TestConstrant f 'One
-  , TestConstrant f 'AtleastOne
-  , TestConstrant f 'Many
-  )
+instance Show (a -> b) where
+  show _ = "(a -> b)"
 
 
-selectionProps :: forall (f :: Pick -> Type -> Type). TestConstrants f => Spec
-selectionProps = do
-
-  describe "selected is an option" $ do
+main :: IO ()
+main = hspec $ do
 
-    it "One"        . property $ \(c :: f 'One Foo) ->
-      toSet (selected c) `isSubsetOf` toSet c
-    it "AtleastOne" . property $ \(c :: f 'AtleastOne Foo) ->
-      Set.singleton (selected c) `isSubsetOf` toSet c
-    it "Many"       . property $ \(c :: f 'Many Foo) ->
-      toSet (selected c) `isSubsetOf` toSet c
+  describe "Set" $ legal @SetLike @Set
 
 
-  describe "if we select something it's an option" $ do
-
-    it "One'"        . property $ \(c :: f 'One Foo) x ->
-      x `member` toSet (select' c x)
-    it "AtleastOne'" . property $ \(c :: f 'AtleastOne Foo) x ->
-      x `member` toSet (select' c x)
-    it "Many'"       . property $ \(c :: f 'Many Foo) x ->
-      x `member` toSet (select' c x)
+  describe "Toggle"  $ do
+    legal @Eq        @Toggle
+    legal @Ord       @Toggle
+    legal @Show      @Toggle
+    legal @Semigroup @Toggle
+    legal @Monoid    @Toggle
 
 
-  describe "selected and unselected are exclusive" $ do
-
-    it "One"        . property $ \(c :: f 'One Foo) ->
-      toSet (selected c) `disjoint` unselected c
-    it "AtleastOne" . property $ \(c :: f 'AtleastOne Foo) ->
-      Set.singleton (selected c) `disjoint` unselected c
-    it "Many"       . property $ \(c :: f 'Many Foo) ->
-      toSet (selected c) `disjoint` unselected c
+  describe "Hover"   $ do
+    legal @Eq        @Hover
+    legal @Ord       @Hover
+    legal @Show      @Hover
+    legal @Semigroup @Hover
+    legal @Monoid    @Hover
 
 
-  describe "idempotence select" $ do
-
-    it "One"        . property $ \(c :: f 'One Foo) x ->
-      select' (select' c x) x == select' c x
-    it "AtleastOne" . property $ \(c :: f 'AtleastOne Foo) x ->
-      select' (select' c x) x == select' c x
-    it "Many"       . property $ \(c :: f 'Many Foo) x ->
-      select' (select' c x) x == select' c x
+  describe "Hygiene" $ do
+    legal @Eq        @Hygiene
+    legal @Ord       @Hygiene
+    legal @Show      @Hygiene
+    legal @Semigroup @Hygiene
+    legal @Monoid    @Hygiene
 
 
-  describe "select selected identity" $ do
-
-    it "One"        . property $ \x ->
-      selected (x `withOptions` Set.empty :: f 'One Foo) == x
-    it "AtleastOne" . property $ \x ->
-      selected (x `withOptions` Set.empty :: f 'AtleastOne Foo) == x
-    it "Many"       . property $ \x ->
-      selected (x `withOptions` Set.empty :: f 'Many Foo) == x
+  describe "Remote"  $ do
+    legal @Eq          @(Remote Int Int)
+    legal @Ord         @(Remote Int Int)
+    legal @Show        @(Remote Int Int)
+    legal @Monoid      @(Remote Int (Sum Int))
+    legal @Functor     @(Remote Int)
+    legal @Applicative @(Remote Int)
+    legal @Monad       @(Remote Int)
+    legal @Alternative @(Remote Int)
+    legal @Foldable    @(Remote Int)
 
 
-  describe "unselected withOptions identity" $ do
-
-    it "One"        . property $ \x ->
-      unselected (x `withOptions` Set.empty :: f 'One Foo) == mempty
-    it "AtleastOne" . property $ \x ->
-      unselected (x `withOptions` Set.empty :: f 'AtleastOne Foo) == mempty
-    it "Many"       . property $ \x ->
-      unselected (x `withOptions` Set.empty :: f 'Many Foo) == mempty
+  describe "Input" $ do
+    legal @Eq          @(Input (Sum Int))
+    legal @Ord         @(Input (Sum Int))
+    legal @Show        @(Input (Sum Int))
+    legal @Monoid      @(Input (Sum Int))
+    legal @Functor     @Input
+    legal @Applicative @Input
+    legal @Monad       @Input
+    legal @Foldable    @Input
 
 
-  describe "selected is not unselected" $ do
-
-    it "One" . property $ \(c :: f 'One Foo) x ->
-      not $ x `member` unselected (select' c x)
-    it "AtleastOne" . property $ \(c :: f 'AtleastOne Foo) x ->
-      not $ x `member` unselected (select' c x)
-    it "Many" . property $ \(c :: f 'Many Foo) x ->
-      not $ x `member` unselected (select' c x)
+  describe "Validated" $ do
+    legal @Eq          @(Validated Int Int)
+    legal @Ord         @(Validated Int Int)
+    legal @Show        @(Validated Int Int)
+    legal @Semigroup   @(Validated Int Int)
+    legal @Functor     @(Validated Int)
+    legal @Applicative @(Validated Int)
+    legal @Monad       @(Validated Int)
+    legal @Foldable    @(Validated Int)
 
 
-deselectionPropsOne :: forall (f :: Pick -> Type -> Type). TestConstrants f => Deselection f 'One => Spec
-deselectionPropsOne = describe "One" $ do
-
-    it "idempotence deselect" . property $ \(c :: f 'One Foo) ->
-        deselect (deselect c) == deselect c
-
-    it "deselect select selected identity" . property $ \(c :: f 'One Foo) x ->
-        selected (select (deselect c) x) == x
-
-    it "selected deselect annihliation" . property $ \(c :: f 'One Foo) ->
-        selected (deselect c) == mempty
+  describe "Choice" $ do
 
-    it "deselect keeps" . property $ \(c :: f 'One Foo) x ->
-        toSet x `isSubsetOf` toSet (deselect (select c x))
+    describe "'One" $ do
+      legal @Eq         @(Choice   'One Int)
+      legal @Ord        @(Choice   'One Int)
+      legal @Show       @(Choice   'One Int)
+      legal @Semigroup  @(Choice   'One (Sum Int))
+      legal @Monoid     @(Choice   'One (Sum Int))
+      legal @SetLike    @(Choice   'One)
+      legal @Foldable   @(Choice   'One)
+      legal @(Selection   Choice) @'One
+      legal @(Deselection Choice) @'One
 
-    it "unselected passes through deselect keeps" . property $ \(c :: f 'One Foo) x ->
-        toSet x `isSubsetOf` unselected (deselect (select c x))
+    describe "'AtleastOne" $ do
+      legal @Eq         @(Choice   'AtleastOne Int)
+      legal @Ord        @(Choice   'AtleastOne Int)
+      legal @Show       @(Choice   'AtleastOne Int)
+      legal @Semigroup  @(Choice   'AtleastOne (Sum Int))
+      legal @SetLike    @(Choice   'AtleastOne)
+      legal @Foldable   @(Choice   'AtleastOne)
+      legal @(Selection   Choice) @'AtleastOne
 
-    it "deselect unselected is full set" . property $ \(c :: f 'One Foo) ->
-        unselected (deselect c) == toSet c
+    describe "'Many" $ do
+      legal @Eq         @(Choice   'Many Int)
+      legal @Ord        @(Choice   'Many Int)
+      legal @Show       @(Choice   'Many Int)
+      legal @Semigroup  @(Choice   'Many (Sum Int))
+      legal @Monoid     @(Choice   'Many (Sum Int))
+      legal @SetLike    @(Choice   'Many)
+      legal @Foldable   @(Choice   'Many)
+      legal @(Selection   Choice) @'Many
+      legal @(Deselection Choice) @'Many
 
 
-deselectionPropsMany :: forall (f :: Pick -> Type -> Type). TestConstrants f => Deselection f 'Many => Spec
-deselectionPropsMany = describe "Many" $ do
-
-    it "idempotence deselect" . property $ \(c :: f 'Many Foo) ->
-        deselect (deselect c) == deselect c
-
-    it "deselect select selected identity" . property $ \(c :: f 'Many Foo) x ->
-        selected (select (deselect c) x) == x
-
-    it "selected deselect annihliation" . property $ \(c :: f 'Many Foo) ->
-        selected (deselect c) == mempty
+  describe "ConsideredChoice" $ do
 
-    it "deselect keeps" . property $ \(c :: f 'Many Foo) x ->
-        toSet x `isSubsetOf` toSet (deselect (select c x))
+    describe "'One" $ do
+      legal @Eq         @(ConsideredChoice   'One Int)
+      legal @Ord        @(ConsideredChoice   'One Int)
+      legal @Show       @(ConsideredChoice   'One Int)
+      legal @Semigroup  @(ConsideredChoice   'One (Sum Int))
+      legal @Monoid     @(ConsideredChoice   'One (Sum Int))
+      legal @SetLike    @(ConsideredChoice   'One)
+      legal @Foldable   @(ConsideredChoice   'One)
+      legal @(Selection   ConsideredChoice) @'One
+      legal @(Deselection ConsideredChoice) @'One
 
-    it "unselected passes through deselect keeps" . property $ \(c :: f 'Many Foo) x ->
-        toSet x `isSubsetOf` unselected (deselect (select c x))
+    describe "'AtleastOne" $ do
+      legal @Eq        @(ConsideredChoice   'AtleastOne Int)
+      legal @Ord       @(ConsideredChoice   'AtleastOne Int)
+      legal @Show      @(ConsideredChoice   'AtleastOne Int)
+      legal @Semigroup @(ConsideredChoice   'AtleastOne (Sum Int))
+      legal @SetLike   @(ConsideredChoice   'AtleastOne)
+      legal @Foldable  @(ConsideredChoice   'AtleastOne)
+      legal @(Selection  ConsideredChoice) @'AtleastOne
 
-    it "deselect unselected is full set" . property $ \(c :: f 'Many Foo) ->
-        unselected (deselect c) == toSet c
+    describe "'Many" $ do
+      legal @Eq         @(ConsideredChoice   'Many Int)
+      legal @Ord        @(ConsideredChoice   'Many Int)
+      legal @Show       @(ConsideredChoice   'Many Int)
+      legal @Semigroup  @(ConsideredChoice   'Many (Sum Int))
+      legal @Monoid     @(ConsideredChoice   'Many (Sum Int))
+      legal @SetLike    @(ConsideredChoice   'Many)
+      legal @Foldable   @(ConsideredChoice   'Many)
+      legal @(Selection   ConsideredChoice) @'Many
+      legal @(Deselection ConsideredChoice) @'Many
 
 
-main :: IO ()
-main = hspec $ do
-  it "foooid" . property $ \(x :: Foo) y z ->
-    x <> mempty == x && x == mempty <> x && (x <> y) <> z == x <> (y <> z)
-
-  describe "Choice" $ do
-    selectionProps       @Choice
-    deselectionPropsOne  @Choice
-    deselectionPropsMany @Choice
-
+  describe "Dropdown" $ do
 
-  describe "ConsideredChoice" $ do
-    selectionProps       @ConsideredChoice
-    deselectionPropsOne  @ConsideredChoice
-    deselectionPropsMany @ConsideredChoice
+    describe "'One" $ do
+      legal @Eq         @(Dropdown   'One Int)
+      legal @Ord        @(Dropdown   'One Int)
+      legal @Show       @(Dropdown   'One Int)
+      legal @Semigroup  @(Dropdown   'One (Sum Int))
+      legal @Monoid     @(Dropdown   'One (Sum Int))
+      legal @SetLike    @(Dropdown   'One)
+      legal @Foldable   @(Dropdown   'One)
+      legal @(Selection   Dropdown) @'One
+      legal @(Deselection Dropdown) @'One
 
+    describe "'AtleastOne" $ do
+      legal @Eq        @(Dropdown   'AtleastOne Int)
+      legal @Ord       @(Dropdown   'AtleastOne Int)
+      legal @Show      @(Dropdown   'AtleastOne Int)
+      legal @Semigroup @(Dropdown   'AtleastOne (Sum Int))
+      legal @SetLike   @(Dropdown   'AtleastOne)
+      legal @Foldable  @(Dropdown   'AtleastOne)
+      legal @(Selection  Dropdown) @'AtleastOne
 
-  describe "Dropdown" $ do
-    selectionProps      @Dropdown
-    deselectionPropsOne @Dropdown
+    describe "'Many" $ do
+      legal @Eq         @(Dropdown   'Many Int)
+      legal @Ord        @(Dropdown   'Many Int)
+      legal @Show       @(Dropdown   'Many Int)
+      legal @Semigroup  @(Dropdown   'Many (Sum Int))
+      legal @Monoid     @(Dropdown   'Many (Sum Int))
+      legal @SetLike    @(Dropdown   'Many)
+      legal @Foldable   @(Dropdown   'Many)
+      legal @(Selection   Dropdown) @'Many
+      legal @(Deselection Dropdown) @'Many