Shpadoinkle-widgets 0.1.0.0 → 0.2.0.0

raw patch · 17 files changed

+1241/−450 lines, 17 filesdep +quickcheck-classesdep +quickcheck-classes-basedep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: quickcheck-classes, quickcheck-classes-base, transformers

API changes (from Hackage documentation)

Files

• Shpadoinkle-widgets.cabal +23/−3
• Shpadoinkle/Widgets/Form/Dropdown.hs +26/−17
• Shpadoinkle/Widgets/Form/Input.hs +10/−9
• Shpadoinkle/Widgets/Table.hs +16/−18
• Shpadoinkle/Widgets/Table/Lazy.hs +21/−21
• Shpadoinkle/Widgets/Types.hs +2/−0
• Shpadoinkle/Widgets/Types/Choice.hs +409/−171
• Shpadoinkle/Widgets/Types/ConsideredChoice.hs +186/−0
• Shpadoinkle/Widgets/Types/Core.hs +9/−2
• Shpadoinkle/Widgets/Types/Form.hs +34/−17
• Shpadoinkle/Widgets/Types/Physical.hs +33/−10
• Shpadoinkle/Widgets/Types/Remote.hs +22/−10
• Shpadoinkle/Widgets/Types/Search.hs +10/−11
• Shpadoinkle/Widgets/Validation.hs +2/−0
• Test/QuickCheck/Classes/FoldableOrd.hs +170/−0
• Test/QuickCheck/Classes/Hspec.hs +115/−0
• tests/Test.hs +153/−161

@@ -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

@@ -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

@@ -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 ) [] 

@@ -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

@@ -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'') 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -51,3 +51,5 @@  email :: Text -> Validated Text Text email i = if isValid (encodeUtf8 i) then pure i else throwError "Not a valid email"++

@@ -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) #-}

@@ -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

@@ -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