Shpadoinkle-widgets (empty) → 0.0.0.1

raw patch · 16 files changed

+1612/−0 lines, 16 filesdep +QuickCheckdep +Shpadoinkledep +Shpadoinkle-html

Dependencies added: QuickCheck, Shpadoinkle, Shpadoinkle-html, Shpadoinkle-widgets, aeson, base, compactable, containers, edit-distance, email-validate, hspec, jsaddle, mtl, stm, template-haskell, text, unliftio

Files

CHANGELOG.md +0/−0
LICENSE +26/−0
README.md +22/−0
Shpadoinkle-widgets.cabal +76/−0
Shpadoinkle/Widgets/Form/Dropdown.hs +192/−0
Shpadoinkle/Widgets/Form/Input.hs +50/−0
Shpadoinkle/Widgets/Table.hs +151/−0
Shpadoinkle/Widgets/Types.hs +16/−0
Shpadoinkle/Widgets/Types/Choice.hs +402/−0
Shpadoinkle/Widgets/Types/Core.hs +77/−0
Shpadoinkle/Widgets/Types/Form.hs +178/−0
Shpadoinkle/Widgets/Types/Physical.hs +73/−0
Shpadoinkle/Widgets/Types/Remote.hs +34/−0
Shpadoinkle/Widgets/Types/Search.hs +57/−0
Shpadoinkle/Widgets/Validation.hs +53/−0
tests/Test.hs +205/−0

+ CHANGELOG.md view

+ LICENSE view

@@ -0,0 +1,26 @@+Shpadoinkle Widgets, I think I know exactly what it means+Copyright © 2019 Isaac Shpaira+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+1. Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.+3. Neither the name of the <`3:organization`> nor the+names of its contributors may be used to endorse or promote products+derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY <|2|> ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <|2|> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

+ README.md view

@@ -0,0 +1,22 @@+# Shpadoinkle Widgets++[![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle)+[![Hackage](https://img.shields.io/hackage/v/Shpadoinkle-widgets.svg)](https://hackage.haskell.org/package/Shpadoinkle-widgets)+[![Hackage Deps](https://img.shields.io/hackage-deps/v/Shpadoinkle-widgets.svg)](http://packdeps.haskellers.com/reverse/Shpadoinkle-widgets)+[![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/Shpadoinkle-widgets/badge)](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-widgets)++There are many shared abstractions between various UI's that represent+themselves in frameworks, and applications. This package provides a useful+subset of these concepts as types. Along with implimentations consuming+these types.++Docs are very WIP right now, and themeing via property injection is still being explored.++## Current Widgets++- Dropdown+- Textual Input+- Numeric Input+- Data Table++

+ Shpadoinkle-widgets.cabal view

@@ -0,0 +1,76 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.32.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: da8a19caa819b338cdab73065a3f5e9112de2440da5ecb431080860f51889144++name:           Shpadoinkle-widgets+version:        0.0.0.1+synopsis:       A collection of common reusable types and components.+description:    There are many shared abstractions between various UI's that represent themselves in frameworks, and applications. This package provides a useful subset of these concepts as types. Along with implimentations consuming these types.+category:       Web+author:         Isaac Shapira+maintainer:     fresheyeball@protonmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://gitlab.com/fresheyeball/Shpadoinkle.git++library+  exposed-modules:+      Shpadoinkle.Widgets.Form.Input+      Shpadoinkle.Widgets.Form.Dropdown+      Shpadoinkle.Widgets.Table+      Shpadoinkle.Widgets.Types+      Shpadoinkle.Widgets.Types.Choice+      Shpadoinkle.Widgets.Types.Core+      Shpadoinkle.Widgets.Types.Form+      Shpadoinkle.Widgets.Types.Physical+      Shpadoinkle.Widgets.Types.Remote+      Shpadoinkle.Widgets.Types.Search+      Shpadoinkle.Widgets.Validation+  other-modules:+      Paths_Shpadoinkle_widgets+  hs-source-dirs:+      ./.+  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+  build-depends:+      Shpadoinkle <0.1+    , Shpadoinkle-html <0.1+    , aeson >=1.4.4 && <1.5+    , base >=4.12.0 && <4.13+    , compactable >=0.1.2 && <0.2+    , containers >=0.6.0 && <0.7+    , edit-distance >=0.2.2 && <0.3+    , email-validate >=2.3.2 && <2.4+    , jsaddle >=0.9.7 && <0.20+    , mtl >=2.2.2 && <2.3+    , stm >=2.5.0 && <2.6+    , template-haskell >=2.14.0 && <2.15+    , text >=1.2.3 && <1.3+    , unliftio >=0.2.12 && <0.3+  default-language: Haskell2010++test-suite unit+  type: exitcode-stdio-1.0+  main-is: Test.hs+  other-modules:+      Paths_Shpadoinkle_widgets+  hs-source-dirs:+      tests+  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+  build-depends:+      QuickCheck+    , Shpadoinkle-widgets+    , base >=4.12.0 && <4.13+    , containers+    , hspec+  default-language: Haskell2010

@@ -0,0 +1,192 @@+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ExtendedDefaultRules      #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module Shpadoinkle.Widgets.Form.Dropdown where+++import           Control.Compactable+import           Data.Aeson+import           Data.Text+import           GHC.Generics+import           Prelude                   hiding (div)+++import           Shpadoinkle+import           Shpadoinkle.Html          hiding (p, s, s', selected)+import           Shpadoinkle.Keyboard+import           Shpadoinkle.Widgets.Types+++default (Text)+++data Dropdown p a = Dropdown+  { _considered :: ConsideredChoice p a+  , _toggle     :: Toggle+  }+++deriving instance (Show (Selected p a), Show (Considered p a), Show a)        => Show (Dropdown p a)+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 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)+++instance Control (Dropdown 'One) where+  type Val (Dropdown 'One) a = Maybe a+  hygiene  :: Applicative f          => (Hygiene -> f Hygiene)   -> Dropdown 'One a -> f (Dropdown 'One a)+  hygiene f d = (\x -> d {_toggle = Closed x }) <$> f (togHygiene $ _toggle d)+  value    :: (Applicative f, Ord a) => (Maybe a -> f (Maybe a)) -> Dropdown 'One a -> f (Dropdown 'One a)+  value   f d = maybe d (select' d) <$> f (selected d)++instance Control (Dropdown 'AtleastOne) where+  hygiene f d = (\x -> d {_toggle = Closed x }) <$> f (togHygiene $ _toggle d)+  value f d = select' d <$> f (selected d)+++instance (Consideration ConsideredChoice p, Ord a)+    => IsToggle (Dropdown p a) where+  close  p = shrug $ p { _toggle = close  (_toggle p) }+  toggle p = shrug $ p { _toggle = toggle (_toggle p) }+  open   p = shrug $ p { _toggle = open   (_toggle p) }+++newtype Config m = Config+  { _attrs :: forall a. [(Text, Prop m a)] }+++defConfig :: Config m+defConfig = Config []+++instance (Compactable (ConsideredChoice p)) => Compactable (Dropdown p) where+  compact (Dropdown c t) = Dropdown (compact c) t+  separate (Dropdown c t) = let (l,r) = separate c in (Dropdown l t, Dropdown r t)+  filter p (Dropdown c t) = Dropdown (Control.Compactable.filter p c) t+  partition p (Dropdown c t) = let (l, r) = Control.Compactable.partition p c in (Dropdown l t, Dropdown r t)+++instance Semigroup (ConsideredChoice p a) => Semigroup (Dropdown p a) where+  Dropdown c t <> Dropdown c' t' = Dropdown (c <> c') (t <> t')+++instance Monoid (ConsideredChoice p a) => Monoid (Dropdown p a) where+  mempty = Dropdown mempty mempty+++instance SetLike (ConsideredChoice p) => SetLike (Dropdown p) where+  toSet = toSet . _considered+  smap f (Dropdown c t) = Dropdown (smap f c) t+  valid (Dropdown c _) = valid c+++instance Consideration ConsideredChoice 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+++instance (Consideration ConsideredChoice p, Deselection ConsideredChoice p)+    => Deselection Dropdown p where+  noselection xs = Dropdown (noselection xs) mempty+  deselect (Dropdown c t) = close $ Dropdown (deselect c) t+++instance Consideration ConsideredChoice 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+  shrug (Dropdown c xs) = Dropdown (shrug c) xs+++data Theme m = Theme+  { _wrapper :: forall a. [Html m a] -> Html m a+  , _header  :: forall a. [Html m a] -> [Html m a]+  , _list    :: forall a. [Html m a] -> Html m a+  , _item    :: forall a. [Html m a] -> Html m a+  }+++semantic :: Dropdown p b -> Theme m+semantic Dropdown {..} = Theme+  { _wrapper = div+    [ className [ ("dropdown", True)+                , ("ui",       True)+                , ("active", _toggle == Open) ]+    ]+  , _header  = \cs ->+    [ div [ class' "text" ] cs+    , i' [ className ["dropdown", "icon"] ]+    ]+  , _list    = div+    [ className [ "menu"+                , "transition" ]+    ]+  , _item    = div [ className "item" ]+  }+++act :: ( Considered p ~ Maybe+       , Consideration ConsideredChoice p+       , Consideration Dropdown p+       , Ord a)+    => Dropdown p a -> Dropdown p a+act x | _toggle x == Open =+  close $ case considered x of+    Just _ -> choose x+    _      -> x+act x = open x+++dropdown ::+  ( Considered p ~ Maybe+  , Consideration Dropdown p+  , Consideration ConsideredChoice p+  , Present (Selected p a), Present a, Ord a+  , MonadJSM m+  ) => (forall b. Dropdown p b -> Theme m)+    -> Config m -> Dropdown p a -> Html m (Dropdown p a)+dropdown toTheme Config {..} x =+  let+    Theme {..} = toTheme x+  in injectProps+  ([onKeyup' $ \case+    Enter     -> act x+    UpArrow   -> considerPrev x+    DownArrow -> considerNext x+    _ -> x+  , onClick $ act x+  , tabbable+  ] ++ _attrs) . _wrapper $+  (_header . present $ selected x) +++  [ _list $ (\y -> injectProps+    [ onMouseover $ consider' y x+    , onFocus     $ consider' y x+    , onClick     $ select' x y+    , tabbable+    ] . _item $ present y) <$> toList (unselected x)+  ]

+ Shpadoinkle/Widgets/Form/Input.hs view

@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module Shpadoinkle.Widgets.Form.Input where+++import           Data.Coerce+import           Data.Text+import           Data.Text.Read++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+++type Config m a = Props m (Input a)+++mkInput :: MonadJSM m => 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.type' t+  : attrs ) []+++fractional :: MonadJSM m => Fractional n => Show n => Config m n -> Input n -> Html m (Input n)+fractional cfg inp = mkInput "number" to (pack . show) cfg inp where+  to t = case double t of+    Right (d,"") -> realToFrac d+    _            -> _value inp+++integral :: MonadJSM m => Integral n => Show n => Config m n -> Input n -> Html m (Input n)+integral cfg inp = mkInput "number" to (pack . show) cfg inp where+  to t = case double t of+    Right (d,"") -> round d+    _            -> _value inp+++search :: MonadJSM m => Config m Search -> Input Search -> Html m (Input Search)+search = mkInput "search" coerce coerce+++text :: forall m t. (MonadJSM m, Coercible Text t) => Config m t -> Input t -> Html m (Input t)+text = mkInput "text" coerce coerce

+ Shpadoinkle/Widgets/Table.hs view

@@ -0,0 +1,151 @@+{-# 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   #-}+++module Shpadoinkle.Widgets.Table+  ( Sort (..)+  , SortCol (..)+  , compareOn+  , negateSort+  , Tabular (..)+  , Column, Row+  , Theme (..)+  , toggleSort+  , view+  , viewWith+  ) where+++import           Data.Aeson+import           Data.Kind+import           Data.List                 (sortBy)+import           Data.Text+import           GHC.Generics++import           Shpadoinkle+import           Shpadoinkle.Html          hiding (a, a', max, min, s, s')+import qualified Shpadoinkle.Html          as Html+import           Shpadoinkle.Widgets.Types+++data Sort = ASC | DESC+  deriving (Show, Eq, Ord, Bounded, Enum, Generic, ToJSON, FromJSON)+++instance Semigroup Sort where (<>) = min+instance Monoid Sort where mempty = maxBound+++negateSort :: Sort -> Sort+negateSort ASC  = DESC+negateSort DESC = ASC+++data SortCol a = SortCol (Column a) Sort+deriving instance Show (Column a) => Show (SortCol a)+deriving instance Eq   (Column a) => Eq   (SortCol a)+deriving instance Ord  (Column a) => Ord  (SortCol a)+deriving instance Functor Column => Functor SortCol+deriving instance Generic (SortCol a)+instance (ToJSON   (Column a)) => ToJSON   (SortCol a)+instance (FromJSON (Column a)) => FromJSON (SortCol a)+++instance Ord (Column a) => Semigroup (SortCol a) where+  SortCol a s <> SortCol a' s' = SortCol (max a a') (min s s')+++instance ( Bounded (Column a)+         , Ord (Column a)+         , Enum (Column a)+         ) => Monoid (SortCol a) where+  mempty = SortCol minBound maxBound+++compareOn :: Ord a => Sort -> a -> a -> Ordering+compareOn DESC = compare+compareOn ASC  = flip compare+++data family Column (a :: Type) :: Type+data family Row    (a :: Type) :: Type+++class Tabular a where+  type Effect a (m :: Type -> Type) :: Constraint+  type Effect a m = Applicative m+  toRows    :: a -> [Row a]+  toCell    :: Effect a m => a -> Row a -> Column a -> [Html m a]+  sortTable :: SortCol a -> Row a -> Row a -> Ordering+++toggleSort :: Eq (Column a) => Column a -> SortCol a -> SortCol a+toggleSort c (SortCol c' s) = if c == c' then SortCol c $ negateSort s else SortCol c mempty+++data Theme m a = Theme+  { tableProps ::             [(Text, Prop m (a, SortCol a))]+  , headProps  ::             [(Text, Prop m (a, SortCol a))]+  , thProps    :: Column a -> [(Text, Prop m (a, SortCol a))]+  , bodyProps  ::             [(Text, Prop m (a, SortCol a))]+  , tdProps    :: Column a -> [(Text, Prop m a)]+  } deriving Generic+++instance Semigroup (Theme m a) where+  Theme v w x y z <> Theme v' w' x' y' z' =+    Theme (v <> v') (w <> w') (x <> x') (y <> y') (z <> z')+instance Monoid (Theme m a) where+  mempty = Theme mempty mempty mempty mempty mempty+++view :: forall m a.+  ( Tabular a+  , Effect a m+  , Applicative m+  , Humanize (Column a)+  , Bounded  (Column a)+  , Ord      (Column a)+  , Enum     (Column a) )+  => a -> SortCol a -> Html m (a, SortCol a)+view = viewWith mempty+++viewWith :: forall m a.+  ( Tabular a+  , Effect a m+  , Applicative m+  , Humanize (Column a)+  , Bounded  (Column a)+  , Ord      (Column a)+  , Enum     (Column a) )+  => Theme m a -> a -> SortCol a -> Html m (a, SortCol a)+viewWith Theme {..} xs s@(SortCol sorton sortorder) =+  table tableProps+    [ thead headProps [ tr_ $ cth_ <$> [minBound..maxBound] ]+    , tbody bodyProps $ do+        row <- sortBy (sortTable s) (toRows xs)+        return . (fmap (, s)) . tr_ $ (\c -> td (tdProps c) $ toCell xs row c) <$> [minBound..maxBound]+    ]++  where++  cth_ c = th (thProps c) . pure . Html.a [ onClick (xs, toggleSort c s) ]+         . mappend [ text (humanize c) ] . pure . text $+          if c == sorton then+            case sortorder of ASC -> "↑"; DESC -> "↓"+          else ""

+ Shpadoinkle/Widgets/Types.hs view

@@ -0,0 +1,16 @@+module Shpadoinkle.Widgets.Types+  ( module Shpadoinkle.Widgets.Types.Core+  , module Shpadoinkle.Widgets.Types.Choice+  , module Shpadoinkle.Widgets.Types.Form+  , module Shpadoinkle.Widgets.Types.Physical+  , module Shpadoinkle.Widgets.Types.Remote+  , module Shpadoinkle.Widgets.Types.Search+  ) where+++import           Shpadoinkle.Widgets.Types.Choice+import           Shpadoinkle.Widgets.Types.Core+import           Shpadoinkle.Widgets.Types.Form+import           Shpadoinkle.Widgets.Types.Physical+import           Shpadoinkle.Widgets.Types.Remote+import           Shpadoinkle.Widgets.Types.Search

+ Shpadoinkle/Widgets/Types/Choice.hs view

@@ -0,0 +1,402 @@+{-# 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          #-}+++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+++data Pick   = One | AtleastOne | Many+++type family Selected (p :: Pick) (a :: Type) :: Type where+  Selected 'One        a = Maybe a+  Selected 'AtleastOne a = a+  Selected 'Many       a = Set a+++data Choice (p :: Pick) a = Choice+  { _selected :: Selected p a+  , _options  :: Set a+  }+++deriving instance (Show (Selected p a), Show a)        => Show (Choice p a)+deriving instance (Read (Selected p a), Read a, Ord a) => Read (Choice p a)+deriving instance (Eq   (Selected p a), Eq a)          => Eq   (Choice p a)+deriving instance (Ord  (Selected p a), Ord a)         => Ord  (Choice p a)+deriving instance Generic (Choice p a)+instance (ToJSON   (Selected p a), ToJSON   a)        => ToJSON   (Choice p a)+instance (FromJSON (Selected p a), FromJSON a, Ord a) => FromJSON (Choice p a)+++instance (Bounded a, Enum a) => Bounded (Choice 'AtleastOne a) where+  minBound = Choice minBound fullset+  maxBound = Choice maxBound fullset+++instance (Bounded a, Enum a) => Enum (Choice 'AtleastOne a) where+  toEnum n = Choice (toEnum n) fullset+  fromEnum (Choice x _) = fromEnum x+++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 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 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)+  filter p (Choice x xs) = Choice (Control.Compactable.filter p x) $ Set.filter p xs+  partition p (Choice x xs) = let (l, r) = Set.partition p xs; (l',r') = Control.Compactable.partition p x in (Choice l' l, Choice r' r)+++instance Compactable (Choice 'Many) 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)+  filter p (Choice x xs) = Choice (Control.Compactable.filter p x) $ Set.filter p xs+  partition p (Choice x xs) = let (l, r) = Set.partition p xs; (l',r') = Control.Compactable.partition p x in (Choice l' l, Choice r' r)+++class SetLike f where+  -- must be injective+  toSet :: Ord a => f a -> Set a+  smap  :: Ord b => (a -> b) -> f a -> f b+  valid :: Ord a => f a -> Bool++instance SetLike Set where+  toSet = id+  smap  = Set.map+  valid = Set.valid++instance SetLike Maybe where+  toSet = maybe mempty Set.singleton+  smap  = fmap+  valid = const True++instance SetLike (Choice 'One) where+  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++instance SetLike (Choice 'AtleastOne) where+  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+  smap f (Choice x xs) = Choice (Set.map f x) (Set.map f xs)+  valid (Choice x xs)  = Set.valid x && Set.valid xs+++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++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++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++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+++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++instance Deselection Choice 'One where+  noselection = Choice Nothing . Set.fromList . F.toList+  deselect = flip select Nothing++instance Deselection Choice 'Many where+  noselection = Choice mempty . Set.fromList . F.toList+  deselect (Choice ys xs) = Choice mempty (ys <> xs)+++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+prev     xs = maybe xs                     (select xs) . Set.lookupLT (selected xs) $ toSet xs+prevLoop xs = maybe (unsafeSelectLast xs)  (select xs) . Set.lookupLT (selected xs) $ toSet xs+++selectAll :: Choice 'Many a -> Choice 'Many a+selectAll (Choice _ xs) = Choice xs xs+++unsafeSelectFirst :: (Selection f p, Ord a) => f p a -> f p a+unsafeSelectFirst c = select' c . Set.findMin $ toSet c+++unsafeSelectLast :: (Selection f p, Ord a) => f p a -> f p a+unsafeSelectLast c = select' c . Set.findMax $ toSet c+++selectFirst :: (Selection f p, Ord a) => f p a -> Maybe (f p a)+selectFirst c = fmap (select' c) . Set.lookupMin $ toSet c+++selectLast :: (Selection f p, Ord a) => f p a -> Maybe (f p a)+selectLast c = fmap (select' c) . Set.lookupMax $ toSet c+++fullset :: (Bounded a, Enum a) => Set a+fullset = Set.fromDistinctAscList [minBound..maxBound]+++fullOptions :: (Deselection f p, Bounded a, Enum a, Ord a) => f p a+fullOptions = noselection fullset+++fullOptionsMin :: (Selection f p, Bounded a, Enum a, Ord a) => f p a+fullOptionsMin = fromNonEmpty $ minBound NE.:| [succ minBound..maxBound]+++fullOptionsMax :: (Selection f p, Bounded a, Enum a, Ord a) => f p a+fullOptionsMax = fromNonEmpty $ maxBound NE.:| [minBound..pred maxBound]+++fromNonEmpty :: (Selection f p, Ord a) => NE.NonEmpty a -> f p a+fromNonEmpty xs' = let (x NE.:| xs) = NE.sort xs' in x `withOptions'` Set.fromList xs+++selectWhen :: (SetLike g, Selection f 'Many, Ord a) => (a -> Bool) -> g a -> Maybe (f 'Many a)+selectWhen p xs' = if sub == Set.empty then Nothing else Just (sub `withOptions` xs)+  where sub = Set.filter p xs+        xs = toSet xs'+++selectFirstWhen :: (SetLike g, Deselection f p, Ord a) => (a -> Bool) -> g a -> Maybe (f p a)+selectFirstWhen p xs = if sub == Set.empty then Nothing else selectFirst $ noselection sub+  where sub = Set.filter p $ toSet xs+++selectLastWhen :: (SetLike g, Deselection f p, Ord a) => (a -> Bool) -> g a -> Maybe (f p a)+selectLastWhen p xs = if sub == Set.empty then Nothing else selectLast $ noselection sub+  where sub = Set.filter p $ toSet xs+++toList :: (SetLike f, Ord a) => f a -> [a]+toList = Set.toList . toSet+++singleton :: (Selection f p, Ord a) => a -> f p a+singleton x = x `withOptions'` Set.singleton x+++before :: (Selection f 'AtleastOne, Ord a) => f 'AtleastOne a -> Set a+before xs = Set.filter (< selected xs) $ toSet xs+++unsafeSelectAt :: (SetLike g, Selection f 'AtleastOne, Ord a) => Int -> g a -> f 'AtleastOne a+unsafeSelectAt i xs' = let xs = toSet xs' in Set.elemAt i xs `withOptions'` xs+++getIndex :: (Selection f 'AtleastOne, Ord a) => f 'AtleastOne a -> Int+getIndex xs = findIndex (selected xs) $ toSet xs+++after :: (Selection f 'AtleastOne, Ord a) => f 'AtleastOne a -> Set a+after xs = Set.filter (> selected xs) $ toSet xs+++size :: (SetLike g, Ord a) => g a -> Int+size = Set.size . toSet+++insert :: (Selection f p, Ord a) => a -> f p a -> f p a+insert y xs = selected xs `withOptions` Set.insert y (toSet xs)+++delete :: (Compactable (f p), Ord a) => a -> f p a -> f p a+delete y = Control.Compactable.filter (/= y)+++addSelection :: (Selection f 'Many, Ord a) => a -> f 'Many a -> f 'Many a+addSelection y c = select c $ Set.singleton y+++deselectMany :: (Compactable (f p), Ord a) => Set a -> f p a -> f p a+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)

+ Shpadoinkle/Widgets/Types/Core.hs view

@@ -0,0 +1,77 @@+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Shpadoinkle.Widgets.Types.Core where+++import           Data.Aeson+import           Data.Text+import           GHC.Generics++import           Shpadoinkle+++data Hygiene = Clean | Dirty+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, ToJSON, FromJSON)+++instance Semigroup Hygiene where+  Clean <> Clean = Clean+  _ <> _ = Dirty+++instance Monoid Hygiene where+  mempty = Clean+++data Ability = Enabled | Disabled+  deriving (Eq, Ord, Show, Enum, Bounded)+++toBool :: Ability -> Bool+toBool Enabled  = True+toBool Disabled = False+++fromBool :: Bool -> Ability+fromBool True  = Enabled+fromBool False = Disabled+++class Humanize a where+  humanize :: a -> Text+  default humanize :: Show a => a -> Text+  humanize = pack . show+  {-# INLINE humanize #-}+++instance Humanize Text where+  humanize = id+  {-# INLINE humanize #-}+++instance Humanize String where+  humanize = pack+  {-# INLINE humanize #-}+++class Present a where+  present :: a -> [Html m b]+  default present :: Humanize a => a -> [Html m b]+  present = pure . text . humanize+  {-# INLINE present #-}+++instance {-# OVERLAPPABLE #-} Humanize a => Present a

+ Shpadoinkle/Widgets/Types/Form.hs view

@@ -0,0 +1,178 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PartialTypeSignatures      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+++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           GHC.Generics++import           Shpadoinkle.Widgets.Types.Core+++data Input a = Input+  { _hygiene :: Hygiene+  , _value   :: a+  } deriving (Eq, Ord, Show, Read, Functor, Traversable, Foldable, Generic, ToJSON, FromJSON)+++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)+  value   :: (Applicative f, Ord a) => (Val g a -> f (Val g a)) -> g a -> f (g a)+++getValue :: (Ord a, Monoid (Val g a), Control g) => g a -> Val g a+getValue = getConst . value Const+++getHygiene :: Control g => g a -> Hygiene+getHygiene = getConst . hygiene Const+++instance Control Input where+  hygiene f i = (\h -> i { _hygiene = h }) <$> f (_hygiene i)+  value   f i = (\a -> i { _value   = a }) <$> f (_value i)+++instance Applicative Input where+  Input h fa <*> Input h' a = Input (h <> h') (fa a)+  pure = Input mempty+++instance Monad Input where+  Input h a >>= f = let Input h' a' = f a in Input (h <> h') a'+++instance Semigroup a => Semigroup (Input a) where+  Input h a <> Input h' a' = Input (h <> h') (a <> a')+++instance Monoid a => Monoid (Input a) where+  mempty = Input mempty mempty+++newtype Placeholder = Placeholder { unPlaceholder :: Text }+  deriving newtype (Eq, Ord, Show, Read, IsString, Semigroup, Monoid, ToJSON, FromJSON)+  deriving stock Generic+++data Validated e a = Validated a | Invalid e [e]+  deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON, Functor, Foldable, Traversable)++instance Semigroup (Validated e a) where+  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+  pure = Validated+++instance Monad (Validated e) where+  Validated a >>= f = f a+  Invalid x xs >>= _ = Invalid x xs+++instance MonadError e (Validated e) where+  throwError e = Invalid e []+  catchError (Invalid x _) f = f x+  catchError v _             = v+++data Status = Edit | Rules | Valid | Errors+++type family Field (s :: Status) (e :: Type) (f :: Type -> Type) (x :: Type) :: Type where+  Field 'Valid    _ _ a = a+  Field 'Errors   e _ a = Validated e a+  Field 'Edit     _ f a = f a+  Field 'Rules    e f a = Val f a -> Validated e a+++class ValidateG rules edit errs where+  validateg :: rules a -> edit a -> errs a+instance ValidateG U1 U1 U1 where+  validateg _ _ = U1+instance (ValidateG a b c, ValidateG d e f)+  => ValidateG (a :*: d) (b :*: e) (c :*: f) where+  validateg (a :*: b) (c :*: d) = validateg a c :*: validateg b d+instance (ValidateG a b c, ValidateG d e f, Alternative (c :+: f))+  => ValidateG (a :+: d) (b :+: e) (c :+: f) where+  validateg (L1 a) (L1 b) = L1 $ validateg a b+  validateg (R1 a) (R1 b) = R1 $ validateg a b+  validateg _ _           = empty+instance ValidateG a b c+  => ValidateG (M1 i x a) (M1 i' x' b) (M1 i'' x'' c) where+  validateg (M1 a) (M1 b) = M1 $ validateg a b+instance (Control c, Monoid v, Val c a ~ v, Ord a)+  => ValidateG (K1 i (v -> b)) (K1 i' (c a)) (K1 i'' b) where+  validateg (K1 f) (K1 x) = K1 (f $ getValue x)+++class ValidG err valid where+  validg :: err a -> Maybe (valid a)+instance ValidG U1 U1 where+  validg _ = Just U1+instance (ValidG a c, ValidG b d) => ValidG (a :*: b) (c :*: d) where+  validg (a :*: b) = liftA2 (:*:) (validg a) (validg b)+instance (ValidG a c, ValidG b d) => ValidG (a :+: b) (c :+: d) where+  validg (L1 a) = L1 <$> validg a+  validg (R1 a) = R1 <$> validg a+instance (ValidG a b) => ValidG (M1 i c a) (M1 i' c' b) where+  validg (M1 a) = M1 <$> validg a+instance ValidG (K1 i (Validated t a)) (K1 i' a) where+  validg (K1 (Validated a)) = Just $ K1 a+  validg _                  = Nothing+++class Validate (f :: Status -> Type) where+  validate :: f 'Edit -> f 'Errors+  default validate+    :: Generic (f 'Edit)+    => Generic (f 'Rules)+    => Generic (f 'Errors)+    => ValidateG (Rep (f 'Rules)) (Rep (f 'Edit)) (Rep (f 'Errors))+    => f 'Edit -> f 'Errors+  validate edit = to $ validateg (from (rules @ f)) (from edit)++  getValid :: f 'Errors -> Maybe (f 'Valid)+  default getValid+    :: Generic (f 'Errors)+    => Generic (f 'Valid)+    => ValidG (Rep (f 'Errors)) (Rep (f 'Valid))+    => f 'Errors -> Maybe (f 'Valid)+  getValid = fmap to . validg . from++  rules :: f 'Rules

+ Shpadoinkle/Widgets/Types/Physical.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE LambdaCase     #-}+++module Shpadoinkle.Widgets.Types.Physical where+++import           Data.Aeson+import           GHC.Generics++import           Shpadoinkle.Widgets.Types.Core+++data Toggle = Closed Hygiene | Open+  deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)+++togHygiene :: Toggle -> Hygiene+togHygiene = \case+  Closed x -> x+  _ -> Dirty+++instance Enum Toggle where+  fromEnum (Closed Clean) = 0+  fromEnum Open           = 1+  fromEnum (Closed Dirty) = 2+  toEnum 0 = Closed Clean+  toEnum 1 = Open+  toEnum 2 = Closed Dirty+  toEnum _ = error "Not a valid Toggle"+++instance Bounded Toggle where+  minBound = Closed Clean+  maxBound = Closed Dirty+++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+++instance Monoid Toggle where+  mempty = Closed Clean+++class IsToggle a where+  close    :: a -> a+  toggle   :: a -> a+  open     :: a -> a+++instance IsToggle Toggle where++  close = \case+    Open -> Closed Dirty+    t    -> t++  toggle = \case+    Open     -> Closed Dirty+    Closed _ -> Open++  open = const Open+++data Visbility = Visible | Hidden+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)

+ Shpadoinkle/Widgets/Types/Remote.hs view

@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+++module Shpadoinkle.Widgets.Types.Remote where+++import           GHC.Generics+++data Remote e a+  = Success a+  | Failure e+  | Loading+  | NotAsked+  deriving (Eq, Ord, Show, Read, Generic, Functor)+++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+++instance Monad (Remote e) where+  Success a >>= f = f a+  Failure e >>= _ = Failure e+  NotAsked  >>= _ = NotAsked+  Loading   >>= _ = Loading

+ Shpadoinkle/Widgets/Types/Search.hs view

@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ViewPatterns               #-}+++module Shpadoinkle.Widgets.Types.Search where+++import           Data.Aeson+import           Data.Foldable     as F+import           Data.List         (sort)+import           Data.Maybe        (mapMaybe)+import           Data.String+import           Data.Text+import           GHC.Generics+import           Text.EditDistance+++newtype Search = Search { unSearch :: Text }+  deriving newtype (Eq, Ord, Show, Read, IsString, Semigroup, Monoid, ToJSON, FromJSON)+  deriving stock Generic+++data Levenshtiened a = Levenshtiened { _distance :: !Int, _unLevenshtiened :: a } deriving Eq+instance Eq       a => Ord      (Levenshtiened a) where+  compare (Levenshtiened x _) (Levenshtiened y _) = compare x y+++mkLevenshtiened :: Text -> Search -> a -> Levenshtiened a+mkLevenshtiened  t (Search s) x =+  Levenshtiened (levenshteinDistance defaultEditCosts (prep s) (prep t)) x+  where prep = unpack . strip+++forgivingly :: Search -> Text -> Bool+forgivingly (Search (strip -> "")) _ = True+forgivingly (Search s) haystack = Prelude.all test . splitOn " " $ strip s+  where test ""     = False+        test needle = forgive needle `isInfixOf` forgive haystack+        forgive = toLower . strip+++concatFuzzy :: [a -> Text] -> a -> Text+concatFuzzy = F.foldl' (\f g a -> f a <> " " <> g a) (const "")+++fuzzySearch :: Ord a => [a -> Text] -> Search -> [a] -> [a]+fuzzySearch toChunks s = fmap _unLevenshtiened . sort .+  mapMaybe (\x -> let hay = concatFuzzy toChunks x+                  in if forgivingly s hay+                     then Just $ mkLevenshtiened hay s x+                     else Nothing+           )

+ Shpadoinkle/Widgets/Validation.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}+++module Shpadoinkle.Widgets.Validation where+++import           Control.Monad.Except+import           Data.Text+import           Data.Text.Encoding+import           Shpadoinkle.Widgets.Types.Form+import           Text.Email.Validate+++nonMEmpty :: (Monoid a, Eq a) => a -> Validated Text a+nonMEmpty x = if x == mempty then throwError "Cannot be empty" else pure x+++nonMEmpty' :: (Monoid a, Eq a) => Maybe a -> Validated Text a+nonMEmpty' x = case x of+  Just y  -> nonMEmpty y+  Nothing -> throwError "Cannot be empty"+++nonZero :: (Num n, Eq n) => n -> Validated Text n+nonZero n = if n == 0 then throwError "Cannot be zero" else pure n+++positive :: (Num n, Ord n) => n -> Validated Text n+positive n = if n < 0 then throwError "Must be positive" else pure n+++natural :: (Num n, Ord n) => n -> Validated Text n+natural = nonZero <> positive+++negative :: (Num n, Ord n) => n -> Validated Text n+negative n = if n > 0 then throwError "Must be negative" else pure n+++between :: (Ord n, Show n) => (n,n) -> n -> Validated Text n+between (sortTup -> (low, high)) n+  | n < low   = throwError $ "Must be greater than " <> pack (show low)+  | n > high  = throwError $ "Must be less than "    <> pack (show high)+  | otherwise = pure n+++sortTup :: Ord n => (n,n) -> (n,n)+sortTup (x,y) = if x < y then (x,y) else (y,x)+++email :: Text -> Validated Text Text+email i = if isValid (encodeUtf8 i) then pure i else throwError "Not a valid email"

+ tests/Test.hs view

@@ -0,0 +1,205 @@+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Main where+++import           Data.Kind+import           Data.Set                          as Set+import           GHC.Generics++import           Test.Hspec+import           Test.QuickCheck+++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+  )+++selectionProps :: forall (f :: Pick -> Type -> Type). TestConstrants f => Spec+selectionProps = do++  describe "selected is an option" $ 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 "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 "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 "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 "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 "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 "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)+++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++    it "deselect keeps" . property $ \(c :: f 'One Foo) x ->+        toSet x `isSubsetOf` toSet (deselect (select c x))++    it "unselected passes through deselect keeps" . property $ \(c :: f 'One Foo) x ->+        toSet x `isSubsetOf` unselected (deselect (select c x))++    it "deselect unselected is full set" . property $ \(c :: f 'One Foo) ->+        unselected (deselect c) == toSet c+++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++    it "deselect keeps" . property $ \(c :: f 'Many Foo) x ->+        toSet x `isSubsetOf` toSet (deselect (select c x))++    it "unselected passes through deselect keeps" . property $ \(c :: f 'Many Foo) x ->+        toSet x `isSubsetOf` unselected (deselect (select c x))++    it "deselect unselected is full set" . property $ \(c :: f 'Many Foo) ->+        unselected (deselect c) == toSet c+++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 "ConsideredChoice" $ do+    selectionProps       @ConsideredChoice+    deselectionPropsOne  @ConsideredChoice+    deselectionPropsMany @ConsideredChoice+++  describe "Dropdown" $ do+    selectionProps      @Dropdown+    deselectionPropsOne @Dropdown