starlitcanopy/purescript-halogen-select
starlitcanopy/purescript-halogen-select
1
Fork 0
Code Activity

Update for Halogen 5 ()

Browse source 
* Remove QueryF from Select in preparation for v5 changes, as there is no longer the ability to leverage a query within ComponentHTML. Add the npm-check-updates package to dev dependencies.

* switch to variants

* Complete switch to Halogen 5

* switch examples to v5

* switch to extensible state, no comonad

* now that state can be embedded, take as an argument

* cleanup

* switch to handling messages, which addresses lingering concerns with extensibility in the components

* uncomment

* cleanup

* add default.nix file containing mkdocs

* update dependencies

* fix infinite recursion (compiler bug?)

* eta-expand instead of removing helper

* remove unused css

* Add type synonyms for simple cases

* rename RunQuery to AsAction

* allow external initialization, merge state fields

* simplify examples

* Simplify a little more

* formatting

* add finalizer to default spec

* extensible actions

* update item counts on attempted highlight

* cleanup

* polish up CSS for examples to test behavior

* switch to void
This commit is contained in:
Thomas Honeyman 2019-04-15 19:18:42 -07:00 • committed by GitHub
commit 9dacac780c
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
18 changed files with 866 additions and 914 deletions

27
.circleci/config.yml
View file

@ -48,21 +48,6 @@ jobs:
paths:
- js
css:
<<: *defaults
steps:
- checkout
- run:
name: Fetch and persist CSS
command: |
yarn fetch-css && yarn move-css
- persist_to_workspace:
root: docs
paths:
- css
site:
working_directory: ~/select
docker:
@ -139,16 +124,6 @@ workflows:
ignore: gh-pages
# On master branch, rebuild docs
- css:
filters:
branches:
only:
- master
- docs
requires:
- test
- site:
filters:
branches:
@ -168,4 +143,4 @@ workflows:
requires:
- site
- css

8
bower.json
View file

@ -31,10 +31,12 @@
"generated-docs"
],
"dependencies": {
"purescript-halogen": "^4.0.0",
"purescript-halogen-renderless": "^0.0.3"
"purescript-halogen": "^5.0.0-rc.3",
"purescript-record": "^2.0.0"
},
"devDependencies": {
"purescript-debug": "^4.0.0"
"purescript-debug": "^4.0.0",
"purescript-affjax": "^9.0.0",
"purescript-argonaut": "^6.0.0"
}
}

97
default.nix Normal file
View file

@ -0,0 +1,97 @@
{ nixpkgs ? import <nixpkgs> {} }:
with nixpkgs;
let
livereload = python27Packages.buildPythonPackage {
name = "livereload-2.5.1";
src = fetchurl {
url = https://pypi.python.org/packages/e9/2e/c4972828cf526a2e5f5571d647fb2740df68f17e8084a9a1092f4d209f4c/livereload-2.5.1.tar.gz;
sha256 = "0b2yyfnpddmrwjfqsndidzchkf3l9jlgzfkwl8dplim9gq6y2ba2";
};
propagatedBuildInputs = with python27Packages; [ six tornado ];
meta = {
homepage = https://github.com/lepture/python-livereload;
description = "Python LiveReload is an awesome tool for web developers";
license = stdenv.lib.licenses.bsd3;
};
};
mkdocs = python27Packages.buildPythonApplication rec {
name="mkdocs-0.17.2";
src = fetchurl {
url = https://pypi.python.org/packages/27/0a/bb42cda3b298ffb4b30375b7538a4d57803ff8be418ee3e00460188c4332/mkdocs-0.17.2.tar.gz;
sha256 = "18d3m9iws5shlbg0yj5xwiy68bliiz70v32y5pa8wi274c36nssa";
};
propagatedBuildInputs = with python27Packages;
[ tornado livereload click pyyaml markdown jinja2 ];
meta = {
homepage = http://www.mkdocs.org/;
description = "MkDocs is a fast, simple and downright gorgeous static site generator that’s geared towards building project documentation. Documentation source files are written in Markdown, and configured with a single YAML configuration file.";
license = stdenv.lib.licenses.bsd3;
};
};
pymdown-extensions = python27Packages.buildPythonPackage {
name = "pymdown-extensions-4.8";
src = fetchurl {
url = https://pypi.python.org/packages/f5/9f/74d8a85458e831f3b161956b30bc60d31c6a507ed72ac4f4cb2ca08d8042/pymdown-extensions-4.8.tar.gz;
sha256 = "1zvi8d44v758vbhi9fl5x5gqs098ajamilfz53jzid0v0fad88nj";
};
propagatedBuildInputs = with python27Packages; [ markdown ];
doCheck = false;
meta = {
homepage = https://github.com/facelessuser/pymdown-extensions;
description = "Extension pack for Python Markdown.";
license = stdenv.lib.licenses.mit;
};
};
mkdocs-material = python27Packages.buildPythonPackage {
name = "mkdocs-material-2.6.0";
src = fetchurl {
url = https://pypi.python.org/packages/e3/85/f42493d453d9b6f51912b818134a4a555c597807ba96b40eae12017ede35/mkdocs-material-2.6.0.tar.gz;
sha256 = "1xq5nkj0g6gg4lm8nhcwc30g9drq1i4p4pky8s5c0rfa1s9s7sla";
};
propagatedBuildInputs = with python27Packages; [ pymdown-extensions pygments mkdocs ];
meta = {
homepage = https://squidfunk.github.io/mkdocs-material/;
description = "A Material Design theme for MkDocs";
license = stdenv.lib.licenses.mit;
};
};
markdown-fenced-code-tabs = python27Packages.buildPythonPackage {
name = "markdown-fenced-code-tabs-0.2.0";
src = fetchurl {
url = https://pypi.python.org/packages/21/7a/0cee39060c5173cbd80930b720fb18f5cb788477c03214ccdef44ec91d85/markdown-fenced-code-tabs-0.2.0.tar.gz;
sha256 = "05k5v9wlxgghw2k18savznxc1xgg60gqz60mka4gnp8nsxpz99zs";
};
propagatedBuildInputs = with python27Packages; [ markdown ];
meta = {
homepage = https://github.com/yacir/markdown-fenced-code-tabs;
description = "Generates Bootstrap HTML Tabs for Consecutive Fenced Code Blocks";
license = stdenv.lib.licenses.mit;
};
};
in
nixpkgs.stdenv.mkDerivation {
name = "env";
buildInputs = [
mkdocs
mkdocs-material
nixpkgs.nodejs
nixpkgs.yarn
nixpkgs.stack
];
}

8
docs/examples.md
View file

@ -11,9 +11,9 @@ You can play around with a few example components here. However, for a much rich
Dropdowns are a common button-driven input type, especially for navigation. But most custom dropdowns sacrifice usability: unlike browser default dropdowns, you can't type on most custom dropdowns, nor are many built with accessibility in mind. With `Select` you can easily create rich, usable dropdowns with little code.
<div data-component="dropdown" class="ocelot-scoped"></div>
<div data-component="dropdown"></div>
Curious how to build a dropdown with `Select`? Check out [the dropdown tutorial](https://citizennet.github.io/tutorials/build-a-dropdown).
Curious how to build a dropdown with `Select`? Check out [the dropdown tutorial](https://citizennet.github.io/tutorials/dropdown).
### Typeahead / Autocomplete
@ -23,6 +23,6 @@ Building typeaheads with `Select` is only a little more complex than building dr
The typeahead below is quite simple; to see examples of more sophisticated typeaheads -- including ones that fetch and display data asynchronously -- check out the [Ocelot component library](https://citizennet.github.io/purescript-ocelot/#typeaheads).
<div data-component="typeahead" class="ocelot-scoped"></div>
<div data-component="typeahead"></div>
Curious how to build a typeahead with `Select`? Check out [the typeahead tutorial](https://citizennet.github.io/tutorials/build-a-typehead).
Curious how to build a typeahead with `Select`? Check out [the typeahead tutorial](https://citizennet.github.io/tutorials/typeahead).

88
examples/Components/CSS.purs
View file

@ -1,88 +0,0 @@
module Docs.CSS where
import Prelude
import Halogen.HTML as HH
baseContainer :: Array HH.ClassName
baseContainer = HH.ClassName <$>
[ "bg-white"
, "border-grey-80"
, "border-l-2"
, "border-r-2"
, "w-full"
]
selectionContainer :: Array HH.ClassName
selectionContainer = baseContainer <>
( HH.ClassName <$>
[ "border-t-2"
]
)
itemContainer :: Array HH.ClassName
itemContainer = baseContainer <>
( HH.ClassName <$>
[ "absolute"
, "shadow"
, "max-h-80"
, "overflow-y-scroll"
, "pin-t"
, "pin-l"
, "z-50"
, "border-b-2"
]
)
menu :: Array HH.ClassName
menu = HH.ClassName <$> [ "relative z-50" ]
ul :: Array HH.ClassName
ul = HH.ClassName <$> [ "list-reset" ]
li :: Array HH.ClassName
li = HH.ClassName <$>
[ "px-3"
, "rounded-sm"
, "text-black-20"
, "group"
, "hover:bg-grey-97"
, "cursor-pointer"
]
button :: Array HH.ClassName
button = HH.ClassName <$>
[ "no-outline"
, "px-4"
, "py-2"
, "!active:border-b"
, "active:border-t"
, "disabled:opacity-50"
, "disabled:cursor-default"
, "bg-blue-88"
, "border-blue-88"
, "hover:!disabled:bg-blue-82"
, "focus:bg-blue-82"
, "text-white"
, "rounded"
]
input :: Array HH.ClassName
input = HH.ClassName <$>
[ "bg-white"
, "border-t-2"
, "border-b-2"
, "font-light"
, "cc-blue-88"
, "border-grey-80"
, "disabled:bg-grey-95"
, "disabled:text-grey-70"
, "focus:no-outline"
, "py-2"
, "transition-1/4-bounce"
, "border-l-2"
, "border-r-2"
, "w-full"
, "px-3"
, "focus:border-blue-88"
, "!focus:!disabled:hover:border-grey-70"
]

82
examples/Components/Dropdown.purs Normal file
View file

@ -0,0 +1,82 @@
module Components.Dropdown where
import Prelude
import Data.Const (Const)
import Effect.Aff (Aff)
import Data.Array ((!!), mapWithIndex, length)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (guard)
import Halogen as H
import Halogen.HTML as HH
import Internal.CSS (class_, classes_, whenElem)
import Select as S
import Select.Setters as SS
type Slot =
H.Slot S.Query' Message
type State =
( items :: Array String
, selection :: Maybe String
, buttonLabel :: String
)
data Message
= SelectionChanged (Maybe String) (Maybe String)
-- it is unnecessary to export your own input type, but doing so helps if you
-- would like to set some sensible defaults behind the scenes.
type Input =
{ items :: Array String
, buttonLabel :: String
}
input :: Input -> S.Input State
input { items, buttonLabel } =
{ inputType: S.Toggle
, search: Nothing
, debounceTime: Nothing
, getItemCount: length <<< _.items
, items
, buttonLabel
, selection: Nothing
}
spec :: S.Spec State (Const Void) Void () Message Aff
spec = S.defaultSpec { render = render, handleMessage = handleMessage }
where
handleMessage = case _ of
S.Selected ix -> do
st <- H.get
let selection = st.items !! ix
H.modify_ _ { selection = selection, visibility = S.Off }
H.raise $ SelectionChanged st.selection selection
_ -> pure unit
render st =
HH.div
[ class_ "Dropdown" ]
[ renderToggle, renderContainer ]
where
renderToggle =
HH.button
( SS.setToggleProps st [ class_ "Dropdown__toggle" ] )
[ HH.text (fromMaybe st.buttonLabel st.selection) ]
renderContainer = whenElem (st.visibility == S.On) \_ ->
HH.div
( SS.setContainerProps [ class_ "Dropdown__container" ] )
( renderItem `mapWithIndex` st.items )
where
renderItem index item =
HH.div
( SS.setItemProps index
[ classes_
[ "Dropdown__item"
, "Dropdown__item--highlighted" # guard (st.highlightedIndex == Just index)
]
]
)
[ HH.text item ]

101
examples/Components/Dropdown/Dropdown.purs
View file

@ -1,101 +0,0 @@
module Docs.Components.Dropdown where
import Prelude
import Effect.Aff.Class (class MonadAff)
import Data.Array (difference, mapWithIndex)
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Select as Select
import Select.Setters as Setters
import Docs.CSS as CSS
type State =
{ items :: Array String
, text :: String }
type Input =
{ items :: Array String }
data Query a
= HandleSelect (Select.Message Query String) a
data Message
= Void
type ChildSlot = Unit
type ChildQuery = Select.Query Query String
component :: ∀ m. MonadAff m => H.Component HH.HTML Query Input Message m
component =
H.parentComponent
{ initialState
, render
, eval
, receiver: const Nothing
}
where
initialState :: Input -> State
initialState i = { items: i.items, text: "Select an option" }
eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message m
eval = case _ of
HandleSelect (Select.Selected item) a -> do
st <- H.get
_ <- H.query unit $ Select.setVisibility Select.Off
_ <- H.query unit $ Select.replaceItems $ difference st.items [ item ]
H.modify_ _ { text = item }
pure a
HandleSelect other a -> pure a
render :: State -> H.ParentHTML Query ChildQuery ChildSlot m
render st =
HH.div
[ HP.class_ $ HH.ClassName "w-full" ]
[ HH.slot unit Select.component input (HE.input HandleSelect) ]
where
input =
{ initialSearch: Nothing
, debounceTime: Nothing
, inputType: Select.Toggle
, items: difference st.items [ st.text ]
, render: renderDropdown
}
renderDropdown :: Select.State String -> Select.ComponentHTML Query String
renderDropdown state = HH.div_ [ renderToggle, renderMenu ]
where
renderToggle =
HH.button
( Setters.setToggleProps [ HP.classes CSS.button ] )
[ HH.text st.text ]
renderMenu =
HH.div [ HP.classes CSS.menu ]
$ if state.visibility == Select.Off
then []
else [ renderContainer $ renderItem `mapWithIndex` state.items ]
where
renderContainer html =
HH.div
( Setters.setContainerProps [ HP.classes CSS.itemContainer ] )
[ HH.ul [ HP.classes CSS.ul ] html ]
renderItem index item =
HH.li
( Setters.setItemProps index props )
[ HH.text item ]
where
props =
[ HP.classes
( CSS.li <>
if state.highlightedIndex == Just index
then [ HH.ClassName "bg-grey-lighter" ]
else []
)
]

220
examples/Components/Typeahead.purs Normal file
View file

@ -0,0 +1,220 @@
module Components.Typeahead where
import Prelude
import Affjax as AX
import Affjax.ResponseFormat as AR
import Components.Dropdown as D
import Data.Argonaut.Decode ((.:), decodeJson)
import Data.Array (mapWithIndex, filter, (:), (!!), length, null, difference)
import Data.Foldable (for_)
import Data.Bifunctor (lmap)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (guard)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (traverse)
import Effect.Aff (Aff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Internal.CSS (class_, classes_, whenElem)
import Internal.RemoteData as RD
import Select as S
import Select.Setters as SS
type Slot =
S.Slot Query ChildSlots Message
type State =
( selections :: Array Location
, available :: RD.RemoteData String (Array Location)
)
data Action
= Remove Location
| HandleDropdown D.Message
data Query a
= GetSelections (Array Location -> a)
data Message
= ItemRemoved Location
| SelectionsChanged (Array Location)
type ChildSlots =
( dropdown :: D.Slot Unit )
-- this typeahead will be opaque; users can just use this pre-built
-- input instead of the usual select one.
input :: S.Input State
input =
{ inputType: S.Text
, debounceTime: Just (Milliseconds 300.0)
, search: Nothing
, getItemCount: maybe 0 length <<< RD.toMaybe <<< _.available
, selections: []
, available: RD.NotAsked
}
spec :: S.Spec State Query Action ChildSlots Message Aff
spec = S.defaultSpec
{ render = render
, handleAction = handleAction
, handleQuery = handleQuery
, handleMessage = handleMessage
}
where
handleMessage
:: S.Message
-> H.HalogenM (S.State State) (S.Action Action) ChildSlots Message Aff Unit
handleMessage = case _ of
S.Selected ix -> do
st <- H.get
for_ st.available \arr ->
for_ (arr !! ix) \item -> do
let newSelections = item : st.selections
H.modify_ _
{ selections = item : st.selections
, available = RD.Success (filter (_ /= item) arr)
, search = ""
}
H.raise $ SelectionsChanged newSelections
S.Searched str -> do
st <- H.get
-- we'll use an external api to search locations
H.modify_ _ { available = RD.Loading }
items <- H.liftAff $ searchLocations str
H.modify_ _ { available = items <#> \xs -> difference xs st.selections }
_ -> pure unit
-- You can remove all type signatures except for this one; we need to tell the
-- compiler about the `a` type variable. The minimal necessary signature is below.
handleQuery :: forall a. Query a -> H.HalogenM _ _ _ _ _ (Maybe a)
handleQuery = case _ of
GetSelections reply -> do
st <- H.get
pure $ Just $ reply st.selections
handleAction
:: Action
-> H.HalogenM (S.State State) (S.Action Action) ChildSlots Message Aff Unit
handleAction = case _ of
Remove item -> do
st <- H.get
let newSelections = filter (_ /= item) st.selections
H.modify_ _ { selections = newSelections }
H.raise $ ItemRemoved item
HandleDropdown msg -> case msg of
D.SelectionChanged oldSelection newSelection -> do
st <- H.get
let
mkLocation str = { name: "User Added: " <> str, population: "1" }
newSelections = case oldSelection, newSelection of
Nothing, Nothing ->
Nothing
Nothing, Just str ->
Just (mkLocation str : st.selections)
Just str, Nothing ->
Just (filter (_ /= mkLocation str) st.selections)
Just old, Just new ->
Just (mkLocation new : (filter (_ /= mkLocation old) st.selections))
for_ newSelections \selections ->
H.modify_ _ { selections = selections }
render :: S.State State -> H.ComponentHTML (S.Action Action) ChildSlots Aff
render st =
HH.div
[ class_ "Typeahead" ]
[ renderSelections, renderInput, renderDropdown, renderContainer ]
where
hasSelections = length st.selections > 0
renderSelections = whenElem hasSelections \_ ->
HH.div
[ class_ "Typeahead__selections" ]
(renderSelectedItem <$> st.selections)
where
renderSelectedItem item =
HH.div
[ class_ "Typeahead__item--selected Location" ]
[ HH.span
[ class_ "Location__name" ]
[ HH.text item.name ]
, closeButton item
]
closeButton item =
HH.span
[ class_ "Location__closeButton"
, HE.onClick \_ -> Just $ S.Action $ Remove item
]
[ HH.text "×" ]
renderInput = HH.input $ SS.setInputProps
[ classes_
[ "Typeahead__input"
, "Typeahead__input--selections" # guard hasSelections
, "Typeahead__input--active" # guard (st.visibility == S.On)
]
, HP.placeholder "Type to search..."
]
renderDropdown = whenElem (st.visibility == S.On) \_ ->
HH.slot _dropdown unit (S.component D.spec) (D.input dropdownInput) handler
where
_dropdown = SProxy :: SProxy "dropdown"
handler msg = Just $ S.Action $ HandleDropdown msg
dropdownInput = { items: [ "Earth", "Mars" ], buttonLabel: "Human Planets" }
renderContainer = whenElem (st.visibility == S.On) \_ ->
HH.div
(SS.setContainerProps
[ classes_
[ "Typeahead__container"
, "Typeahead__container--hasItems" # guard hasItems
]
]
)
renderItems
where
hasItems = maybe false (not <<< null) (RD.toMaybe st.available)
renderItems = do
let renderMsg msg = [ HH.span_ [ HH.text msg ] ]
case st.available of
RD.NotAsked -> renderMsg "No search performed..."
RD.Loading -> renderMsg "Loading..."
RD.Failure e -> renderMsg e
RD.Success available
| hasItems -> renderItem `mapWithIndex` available
| otherwise -> renderMsg "No results found"
renderItem index { name, population } =
HH.div
(SS.setItemProps index [ classes_ [ base, highlight, "Location" ] ])
[ HH.span
[ class_ "Location__name" ]
[ HH.text name ]
, HH.span
[ class_ "Location__population" ]
[ HH.text population ]
]
where
base = "Typeahead__item"
highlight = "Typeahead__item--highlighted" # guard (st.highlightedIndex == Just index)
-- Let's make this typeahead async.
type Location =
{ name :: String
, population :: String
}
searchLocations :: String -> Aff (RD.RemoteData String (Array Location))
searchLocations search = do
res <- AX.get AR.json ("https://swapi.co/api/planets/?search=" <> search)
let body = lmap AR.printResponseFormatError res.body
pure $ RD.fromEither $ traverse decodeJson =<< (_ .: "results") =<< decodeJson =<< body

179
examples/Components/Typeahead/Typeahead.purs
View file

@ -1,179 +0,0 @@
module Docs.Components.Typeahead where
import Prelude
import Effect.Aff.Class (class MonadAff)
import Data.Array (elemIndex, mapWithIndex, difference, filter, (:))
import Data.Foldable (length, traverse_)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), contains)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Select as Select
import Select.Setters as Setters
import Docs.CSS as CSS
type TypeaheadItem = String
data Query a
= Log String a
| HandleInputContainer (Select.Message Query TypeaheadItem) a
| Removed TypeaheadItem a
type State =
{ items :: Array TypeaheadItem
, selected :: Array TypeaheadItem
, keepOpen :: Boolean }
type Input = { items :: Array String, keepOpen :: Boolean }
data Message = Void
type ChildSlot = Unit
type ChildQuery = Select.Query Query TypeaheadItem
component :: ∀ m. MonadAff m => H.Component HH.HTML Query Input Message m
component =
H.parentComponent
{ initialState
, render
, eval
, receiver: const Nothing
}
where
initialState :: Input -> State
initialState i = { items: i.items, selected: [], keepOpen: i.keepOpen }
render :: State -> H.ParentHTML Query ChildQuery ChildSlot m
render st =
HH.div
[ class_ "w-full" ]
[ renderSelections st.selected
, HH.slot unit Select.component input (HE.input HandleInputContainer)
]
where
input =
{ initialSearch: Nothing
, debounceTime: Nothing
, inputType: Select.TextInput
, items: difference st.items st.selected
, render: renderInputContainer
}
eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message m
eval = case _ of
Log str a -> pure a
HandleInputContainer m a -> a <$ case m of
Select.Emit q -> eval q
Select.Searched search -> do
st <- H.get
let newItems = difference (filterItems search st.items) st.selected
index = elemIndex search st.items
_ <- H.query unit $ Select.replaceItems newItems
traverse_ (H.query unit <<< Select.highlight <<< Select.Index) index
Select.Selected item -> do
st <- H.get
_ <- if st.keepOpen
then pure unit
else do
_ <- H.query unit $ Select.setVisibility Select.Off
pure unit
if length (filter ((==) item) st.items) > 0
then H.modify_ _ { selected = ( item : st.selected ) }
else H.modify_ _
{ items = ( item : st.items )
, selected = ( item : st.selected ) }
newSt <- H.get
let newItems = difference newSt.items newSt.selected
_ <- H.query unit $ Select.replaceItems newItems
pure unit
otherwise -> pure unit
Removed item a -> do
st <- H.get
H.modify_ _ { selected = filter ((/=) item) st.selected }
newSt <- H.get
let newItems = difference newSt.items newSt.selected
_ <- H.query unit $ Select.replaceItems newItems
pure a
----------
-- Helpers
class_ :: ∀ p i. String -> H.IProp ( "class" :: String | i ) p
class_ = HP.class_ <<< HH.ClassName
filterItems :: TypeaheadItem -> Array TypeaheadItem -> Array TypeaheadItem
filterItems str = filter (\i -> contains (Pattern str) i)
renderInputContainer :: Select.State TypeaheadItem -> Select.ComponentHTML Query TypeaheadItem
renderInputContainer state = HH.div_ [ renderInput, renderContainer ]
where
renderInput = HH.input $ Setters.setInputProps
[ HP.classes CSS.input
, HP.placeholder "Type to search..." ]
renderContainer =
HH.div [ class_ "relative z-50" ]
$ if state.visibility == Select.Off
then []
else [ renderItems $ renderItem `mapWithIndex` state.items ]
where
renderChild =
HH.div
[ HE.onClick $ Select.always $ Select.raise $ H.action $ Log "I was clicked" ]
[ HH.text "CLICK ME I'M FROM THE PARENT" ]
renderItems html =
HH.div
( Setters.setContainerProps
[ class_ "absolute bg-white shadow rounded-sm pin-t pin-l w-full" ]
)
[ renderChild, HH.ul [ class_ "list-reset" ] html ]
renderItem index item =
HH.li ( Setters.setItemProps index props ) [ HH.text item ]
where
props = [ class_
$ "px-4 py-1 text-grey-darkest"
<> if state.highlightedIndex == Just index
then " bg-grey-lighter"
else "" ]
renderSelections
:: ∀ p
. Array TypeaheadItem
-> H.HTML p Query
renderSelections items =
if length items == 0
then HH.div_ []
else
HH.div
[ class_ "bg-white rounded-sm w-full border-b border-grey-lighter" ]
[ HH.ul
[ class_ "list-reset" ]
( renderSelectedItem <$> items )
]
where
renderSelectedItem item =
HH.li
[ class_ "px-4 py-1 text-grey-darkest hover:bg-grey-lighter relative" ]
[ HH.span_ [ HH.text item ]
, closeButton item
]
closeButton item =
HH.span
[ HE.onClick $ HE.input_ (Removed item)
, class_ "absolute pin-t pin-b pin-r p-1 mx-3 cursor-pointer" ]
[ HH.text "×" ]

16
examples/Internal/CSS.purs Normal file
View file

@ -0,0 +1,16 @@
module Internal.CSS where
import Prelude
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
class_ :: forall p i. String -> HH.IProp (class :: String | i) p
class_ = HP.class_ <<< HH.ClassName
classes_ :: forall p i. Array String -> HH.IProp (class :: String | i) p
classes_ = HP.classes <<< map HH.ClassName
whenElem :: forall p i. Boolean -> (Unit -> HH.HTML i p) -> HH.HTML i p
whenElem cond render = if cond then render unit else HH.text ""

79
examples/Internal/Component.purs
View file

@ -1,79 +0,0 @@
-- | A centralized module ready for use to mount components into documentation pages.
module Docs.Internal.Component where
import Prelude
import Effect.Aff.Class (class MonadAff)
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML as HH
import Docs.Components.Typeahead as Typeahead
import Docs.Components.Dropdown as Dropdown
----------
-- Component Types
type State = Unit
type Input = Unit
type Message = Void
data Query a = NoOp a
type Component m = H.Component HH.HTML Query Unit Void m
type DSL q m = H.ParentDSL State Query q Unit Void m
type HTML q m = H.ParentHTML Query q Unit m
----------
-- Built components
typeahead :: ∀ m. MonadAff m => Component m
typeahead =
H.parentComponent
{ initialState: const unit
, render
, eval
, receiver: const Nothing
}
where
eval :: Query ~> DSL Typeahead.Query m
eval (NoOp a) = pure a
render :: Unit -> HTML Typeahead.Query m
render _ = HH.slot unit Typeahead.component { items: users, keepOpen: false } (const Nothing)
users :: Array String
users =
[ "Lyndsey Duffield"
, "Chris Pine"
, "Kevin Hart"
, "Dave Chappelle"
, "Hannibal Buress"
, "Rico Suave"
]
dropdown :: ∀ m. MonadAff m => Component m
dropdown =
H.parentComponent
{ initialState: const unit
, render
, eval
, receiver: const Nothing
}
where
eval :: Query ~> DSL Dropdown.Query m
eval (NoOp a) = pure a
render :: Unit -> HTML Dropdown.Query m
render _ = HH.slot unit Dropdown.component { items: users } (const Nothing)
users :: Array String
users =
[ "Lyndsey Duffield"
, "Chris Pine"
, "Kevin Hart"
, "Dave Chappelle"
, "Hannibal Buress"
, "Rico Suave"
]

27
examples/Internal/Proxy.purs
View file

@ -1,7 +1,7 @@
-- | A proxy that hides both the Query and Message of wrapped component.
-- | Adapted from `Halogen.Component.Proxy` and `Halogen.Storybook.Proxy`.
module Docs.Internal.Proxy
module Internal.Proxy
( ProxyS
, proxy
) where
@ -12,6 +12,7 @@ import Data.Const (Const(..))
import Data.Coyoneda (Coyoneda, unCoyoneda)
import Data.Maybe (Maybe(..))
import Data.Newtype (un)
import Data.Symbol (SProxy(..))
import Halogen as H
import Halogen.HTML as HH
@ -21,25 +22,23 @@ data ProxyS f i a
-- | A proxy that hides both the Query and Message of wrapped component.
proxy
:: forall f i o m
. H.Component HH.HTML f i o m
. H.Component HH.HTML f i o m
-> H.Component HH.HTML (ProxyS (Const Void) i) i Void m
proxy = proxyEval (const (absurd <<< un Const))
proxyEval
:: forall f g i o m
. (forall a b. (b -> a) -> g b -> H.ParentDSL i (ProxyS g i) f Unit Void m a)
. (forall a b. (b -> a) -> g b -> H.HalogenM i Void (child :: H.Slot f o Unit) Void m a)
-> H.Component HH.HTML f i o m
-> H.Component HH.HTML (ProxyS g i) i Void m
proxyEval evalQuery component =
H.parentComponent
{ initialState: identity
, render
, eval
, receiver: const Nothing
}
proxyEval evalQuery component = H.mkComponent
{ initialState: identity
, render
, eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery }
}
where
render :: i -> H.ParentHTML (ProxyS g i) f Unit m
render i = HH.slot unit component i (const Nothing)
render :: i -> H.ComponentHTML Void (child :: H.Slot f o Unit) m
render i = HH.slot (SProxy :: SProxy "child") unit component i (const Nothing)
eval :: ProxyS g i ~> H.ParentDSL i (ProxyS g i) f Unit Void m
eval (Query iq) = unCoyoneda evalQuery iq
handleQuery :: forall a. ProxyS g i a -> H.HalogenM i Void (child :: H.Slot f o Unit) Void m (Maybe a)
handleQuery (Query iq) = Just <$> unCoyoneda evalQuery iq

45
examples/Internal/RemoteData.purs Normal file
View file

@ -0,0 +1,45 @@
-- | Copied over from
-- | https://github.com/krisajenkins/purescript-remotedata
-- |
-- | due to dependency conflicts
module Internal.RemoteData where
import Prelude
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Foldable (class Foldable, foldrDefault, foldlDefault)
-- | A datatype representing fetched data.
data RemoteData e a
= NotAsked
| Loading
| Failure e
| Success a
derive instance eqRemoteData :: (Eq e, Eq a) => Eq (RemoteData e a)
derive instance functorRemoteData :: Functor (RemoteData e)
instance foldableRemoteData :: Foldable (RemoteData e) where
foldMap f (Success a) = f a
foldMap _ (Failure e) = mempty
foldMap _ NotAsked = mempty
foldMap _ Loading = mempty
foldr f = foldrDefault f
foldl f = foldlDefault f
-- | Convert a `RemoteData` to a `Maybe`.
toMaybe :: forall e a. RemoteData e a -> Maybe a
toMaybe (Success value) = Just value
toMaybe _ = Nothing
-- | Convert a `Maybe` to `RemoteData`.
fromMaybe :: forall e a. Maybe a -> RemoteData e a
fromMaybe Nothing = NotAsked
fromMaybe (Just value) = Success value
-- | Convert an `Either` to `RemoteData`
fromEither :: forall e a. Either e a -> RemoteData e a
fromEither (Left err) = Failure err
fromEither (Right value) = Success value

114
examples/Main.purs
View file

@ -2,74 +2,65 @@ module Main where
import Prelude
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Effect.Class (liftEffect)
import Web.HTML.HTMLElement (HTMLElement, toElement, fromNode)
import Web.HTML (window)
import Web.HTML.Window (document)
import Web.HTML.HTMLDocument (toParentNode)
import Web.DOM.Element (getAttribute)
import Web.DOM.NodeList (toArray)
import Web.DOM.ParentNode (QuerySelector(..), querySelectorAll)
import Data.Array (zipWith)
import Data.Const (Const)
import Data.Map as Map
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Traversable (sequence, traverse, traverse_)
import Data.Symbol (SProxy(..))
import Data.Traversable (for_, sequence, traverse)
import Data.Tuple (Tuple(..))
import Components.Typeahead as Typeahead
import Components.Dropdown as Dropdown
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.VDom.Driver (runUI)
import Docs.Internal.Proxy (ProxyS, proxy)
import Docs.Internal.Component as Component
import Internal.Proxy (ProxyS, proxy)
import Select as Select
import Web.DOM.Element (getAttribute)
import Web.DOM.NodeList (toArray)
import Web.DOM.ParentNode (QuerySelector(..), querySelectorAll)
import Web.HTML (window)
import Web.HTML.HTMLDocument (toParentNode)
import Web.HTML.HTMLElement (HTMLElement, toElement, fromNode)
import Web.HTML.Window (document)
-- Finds all nodes labeled "data-component-id" and retrieves the associated attribute.
-- Then, mounts the right component at each node.
main :: Effect Unit
main = HA.runHalogenAff do
elements <- awaitSelectAll
{ query: QuerySelector "div[data-component]"
, attr: "data-component"
}
flip traverse_ elements $ \e -> runUI app e.attr e.element
for_ elements \e -> runUI app e.attr e.element
----------
-- Routes
type ComponentQuery = ProxyS (Const Void) Unit
type Components m
= Map.Map String (H.Component HH.HTML ComponentQuery Unit Void m)
type Components
= M.Map String (H.Component HH.HTML (ProxyS (Const Void) Unit) Unit Void Aff)
routes :: ∀ m. MonadAff m => Components m
routes = Map.fromFoldable
[ Tuple "typeahead" $ proxy Component.typeahead
, Tuple "dropdown" $ proxy Component.dropdown ]
routes :: Components
routes = M.fromFoldable
[ Tuple "typeahead" $ proxy typeahead
, Tuple "dropdown" $ proxy dropdown
]
data Query a = NoOp a
app :: ∀ m. MonadAff m => H.Component HH.HTML Query String Void m
app =
H.parentComponent
{ initialState: identity
, render
, eval
, receiver: const Nothing
}
app :: H.Component HH.HTML (Const Void) String Void Aff
app = H.mkComponent
{ initialState: identity
, render
, eval: H.mkEval H.defaultEval
}
where
render st = do
let mbComponent = Map.lookup st routes
case mbComponent of
Nothing -> HH.div_ []
Just component -> HH.slot unit component unit absurd
eval :: Query ~> H.ParentDSL String Query ComponentQuery Unit Void m
eval (NoOp a) = pure a
render st = M.lookup st routes # case _ of
Nothing -> HH.div_ []
Just component -> HH.slot (SProxy :: SProxy "child") unit component unit absurd
----------
-- Selection Helpers
@ -77,17 +68,40 @@ app =
awaitSelectAll
:: { query :: QuerySelector, attr :: String }
-> Aff (Array { element :: HTMLElement, attr :: String })
awaitSelectAll ask@{ query } = HA.awaitLoad >>= \_ -> selectElements ask >>= pure
awaitSelectAll ask@{ query } = HA.awaitLoad >>= \_ -> selectElements ask
selectElements
:: { query :: QuerySelector, attr :: String }
-> Aff (Array { element :: HTMLElement, attr :: String })
selectElements { query, attr } = do
nodeArray <- liftEffect do
nodeArray <- liftEffect do
toArray =<< querySelectorAll query <<< toParentNode =<< document =<< window
let elems :: Array HTMLElement
elems = fromMaybe [] <<< sequence $ fromNode <$> nodeArray
let
elems = fromMaybe [] <<< sequence $ fromNode <$> nodeArray
attrs <- liftEffect $ traverse (getAttribute attr <<< toElement) elems
pure $ zipWith ({ element: _, attr: _ }) elems (fromMaybe "" <$> attrs)
----------
-- Components
dropdown :: forall t0 t1 t2. H.Component HH.HTML t0 t1 t2 Aff
dropdown = H.mkComponent
{ initialState: const unit
, render: \_ ->
HH.slot label unit (Select.component Dropdown.spec) (Dropdown.input input) \_ -> Nothing
, eval: H.mkEval H.defaultEval
}
where
label = SProxy :: SProxy "dropdown"
input = { items: [ "Chris", "Forest", "Dave" ], buttonLabel: "Choose a character" }
typeahead :: forall t0 t1 t2. H.Component HH.HTML t0 t1 t2 Aff
typeahead = H.mkComponent
{ initialState: const unit
, render: \_ ->
HH.slot label unit (Select.component Typeahead.spec) Typeahead.input \_ -> Nothing
, eval: H.mkEval H.defaultEval
}
where
label = SProxy :: SProxy "typeahead"

14
mkdocs.yml
View file

@ -9,7 +9,7 @@ repo_name: 'purescript-halogen-select'
repo_url: 'https://github.com/citizennet/purescript-halogen-select'
# Copyright
copyright: 'Copyright &copy; 2018 CitizenNet'
copyright: 'Copyright &copy; 2019 CitizenNet'
# Config
theme:
@ -24,18 +24,11 @@ theme:
logo:
icon: 'school'
# To mount components
extra_javascript:
- js/app.js
# To style components
# extra_css:
# - css/cn-tailwind.scoped.css
# Google Analytics
# google_analytics:
# - 'UA-XXXXXXXX-X'
# - 'auto'
extra_css:
- css/Select.css
# Extensions
# Recommended here:
@ -84,3 +77,4 @@ pages:
# - 'Controlling component behavior from HTML': 'index.md'
- 'Understanding free queries': 'concepts/understanding-free-queries.md'
- Examples: 'examples.md'

15
package.json
View file

@ -5,14 +5,13 @@
"watch": "pulp -w build",
"build-docs": "pulp build -I examples --to docs/js/app.js",
"watch-docs": "pulp -w --then 'mkdocs serve' build -I examples --to docs/js/app.js",
"clean": "rm -rf output bower_components node_modules site docs/js docs/css",
"postinstall": "bower i --silent",
"fetch-css": "curl https://cdn.rawgit.com/citizennet/purescript-ocelot/dev/dist/cn-tailwind.scoped.css --output cn-tailwind.scoped.css",
"move-css": "mkdir -p docs/css/ && mv cn-tailwind.scoped.css docs/css/"
"clean": "rm -rf output bower_components site docs/js",
"postinstall": "bower i --silent"
},
"devDependencies": {},
"dependencies": {
"pulp": "^12.2.0",
"purescript": "^0.12.0"
"devDependencies": {
"bower": "^1.8.8",
"npm-check-updates": "^3.1.0",
"pulp": "12.3.1",
"purescript": "0.12.3"
}
}

564
src/Select.purs
View file

@ -7,12 +7,11 @@ module Select where
import Prelude
import Control.Comonad (extract)
import Control.Comonad.Store (Store, store)
import Control.Monad.Free (Free, foldFree, liftF)
import Data.Array (length, (!!))
import Control.Monad.Free (liftF)
import Data.Const (Const)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (for_, traverse, traverse_)
import Effect.Aff (Fiber, delay, error, forkAff, killFiber)
import Effect.Aff.AVar (AVar)
@ -22,124 +21,54 @@ import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen as H
import Halogen.HTML as HH
import Renderless.State (getState, modifyState_, modifyStore)
import Halogen.Query.ChildQuery (ChildQueryBox)
import Prim.Row as Row
import Record.Builder as Builder
import Unsafe.Coerce (unsafeCoerce)
import Web.Event.Event (preventDefault)
import Web.HTML.HTMLElement (blur, focus)
import Web.HTML.HTMLElement as HTMLElement
import Web.UIEvent.KeyboardEvent as KE
import Web.UIEvent.MouseEvent as ME
----------
-- Component Types
data Action act
= Search String
| Highlight Target
| Select Target (Maybe ME.MouseEvent)
| ToggleClick ME.MouseEvent
| Focus Boolean
| Key KE.KeyboardEvent
| PreventClick ME.MouseEvent
| SetVisibility Visibility
| Initialize (Maybe (Action act))
| Action act
-- | A useful shorthand for the Halogen component type
type Component o item m = H.Component HH.HTML (Query o item) (Input o item) (Message o item) m
type Action' = Action Void
-- | A useful shorthand for the Halogen component HTML type
type ComponentHTML o item = H.ComponentHTML (Query o item)
-----
-- QUERIES
-- | A useful shorthand for the Halogen component DSL type
type ComponentDSL o item m = H.ComponentDSL (StateStore o item) (Query o item) (Message o item) m
data Query query ps a
= Send (ChildQueryBox ps (Maybe a))
| Query (query a)
-- | The component's state type, wrapped in `Store`. The state and result of the
-- | render function are stored so that `extract` from `Control.Comonad` can be
-- | used to pull out the render function.
type StateStore o item = Store (State item) (ComponentHTML o item)
type Query' = Query (Const Void) ()
----------
-- Core Constructors
-----
-- Message
-- | These queries ensure the component behaves as expected so long as you use the
-- | helper functions from `Select.Setters.Utils` to attach them to the right elements.
-- |
-- | - `o`: The query type of the component that will mount this component in a child slot.
-- | This allows you to embed your own queries into the `Select` component.
-- | - `item`: Your custom item type. It can be a simple type like `String`, or something
-- | complex like `CalendarItem StartDate EndDate (Maybe Disabled)`.
-- |
-- | See the below functions for documentation for the individual constructors.
-- | The README details how to use them in Halogen code, since the patterns
-- | are a little different.
data QueryF o item a
= Search String a
| Highlight Target a
| Select Int a
| Focus Boolean a
| Key KE.KeyboardEvent a
| PreventClick ME.MouseEvent a
| SetVisibility Visibility a
| GetVisibility (Visibility -> a)
| ReplaceItems (Array item) a
| Raise (o Unit) a
| Initialize a
| Receive (Input o item) a
data Message
= Searched String
| Selected Int
| VisibilityChanged Visibility
type Query o item = Free (QueryF o item)
-----
-- HELPER TYPES
-- | Trigger the relevant action with the event each time it occurs
always :: ∀ a b. a -> b -> Maybe a
always = const <<< Just
-- | The component slot type for easy use in a parent component
type Slot query ps msg = H.Slot (Query query ps) msg
-- | Perform a new search with the included string.
search :: ∀ o item. String -> Query o item Unit
search s = liftF (Search s unit)
-- | Change the highlighted index to the next item, previous item, or a
-- | specific index.
highlight :: ∀ o item. Target -> Query o item Unit
highlight t = liftF (Highlight t unit)
-- | Triggers the "Selected" message for the item at the specified index.
select :: ∀ o item. Int -> Query o item Unit
select i = liftF (Select i unit)
-- | Trigger the DOM focus event for the element we have a reference to.
triggerFocus :: ∀ o item . Query o item Unit
triggerFocus = liftF (Focus true unit)
-- | Trigger the DOM blur event for the element we have a reference to
triggerBlur :: ∀ o item . Query o item Unit
triggerBlur = liftF (Focus false unit)
-- | Register a key event. `TextInput`-driven components use these only for
-- | navigation, whereas `Toggle`-driven components also use the key stream for
-- | highlighting.
key :: ∀ o item . KE.KeyboardEvent -> Query o item Unit
key e = liftF (Key e unit)
-- | A helper query to prevent click events from bubbling up.
preventClick :: ∀ o item . ME.MouseEvent -> Query o item Unit
preventClick i = liftF (PreventClick i unit)
-- | Set the container visibility (`On` or `Off`)
setVisibility :: ∀ o item . Visibility -> Query o item Unit
setVisibility v = liftF (SetVisibility v unit)
-- | Get the container visibility (`On` or `Off`). Most useful when sequenced
-- | with other actions.
getVisibility :: ∀ o item . Query o item Visibility
getVisibility = liftF (GetVisibility identity)
-- | Toggles the container visibility.
toggleVisibility :: ∀ o item . Query o item Unit
toggleVisibility = getVisibility >>= not >>> setVisibility
-- | Replaces all items in state with the new array of items.
replaceItems :: ∀ o item . Array item -> Query o item Unit
replaceItems items = liftF (ReplaceItems items unit)
-- | A helper query that the component that mounts `Select` can use to embed its
-- | own queries. Triggers an `Emit` message containing the query when triggered.
-- | This can be used to easily extend `Select` with more behaviors.
raise :: ∀ o item . o Unit -> Query o item Unit
raise o = liftF (Raise o unit)
-- | Sets the component with new input.
receive :: ∀ o item . Input o item -> Query o item Unit
receive i = liftF (Receive i unit)
-- | Initializes the component on mount.
initialize :: ∀ o item. Query o item Unit
initialize = liftF (Initialize unit)
-- | The component slot type when there is no extension
type Slot' = Slot (Const Void) () Void
-- | Represents a way to navigate on `Highlight` events: to the previous
-- | item, next item, or the item at a particular index.
@ -152,232 +81,267 @@ derive instance eqTarget :: Eq Target
-- | ```purescript
-- | render state = if state.visibility == On then renderAll else renderInputOnly
-- | ```
-- |
-- | This is a Boolean Algebra, where `On` corresponds to true, and `Off` to
-- | false, as one might expect. Thus, `not` will invert visibility.
data Visibility = Off | On
derive instance eqVisibility :: Eq Visibility
derive instance ordVisibility :: Ord Visibility
instance heytingAlgebraVisibility :: HeytingAlgebra Visibility where
tt = On
ff = Off
not On = Off
not Off = On
conj On On = On
conj _ _ = Off
disj Off Off = Off
disj _ _ = On
implies On Off = Off
implies _ _ = On
instance booleanAlgebraVisibility :: BooleanAlgebra Visibility
-- | Text-driven inputs will operate like a normal search-driven selection component.
-- | Toggle-driven inputs will capture key streams and debounce in reverse (only notify
-- | about searches when time has expired).
data InputType
= TextInput
| Toggle
data InputType = Text | Toggle
-- | The component's state, once unpacked from `Store`.
-- |
-- | - `inputType`: Controls whether the component is input-driven or toggle-driven
-- | - `search`: The text the user has typed into the text input, or stream of keys
-- | they have typed on the toggle.
-- | - `debounceTime`: How long, in milliseconds, before events should occur based
-- | on user searches.
-- | - `debounceRef`: A representation of a running timer that, when it expires, will
-- | trigger debounced events.
-- | - `inputElement`: A reference to the toggle or input element.
-- | - `items`: An array of user-provided `item`s.
-- | - `visibility`: Whether the array of items should be considered visible or not.
-- | Useful for rendering.
-- | - `highlightedIndex`: What item in the array of items should be considered
-- | highlighted. Useful for rendering.
-- | - `lastIndex`: The length of the array of items.
type State item =
{ inputType :: InputType
, search :: String
, debounceTime :: Milliseconds
, debounceRef :: Maybe (Ref (Maybe Debouncer))
, items :: Array item
, visibility :: Visibility
-- | The component state
type State st =
{ inputType :: InputType
, search :: String
, debounceTime :: Milliseconds
, debounceRef :: Maybe (Ref (Maybe Debouncer))
, visibility :: Visibility
, highlightedIndex :: Maybe Int
, lastIndex :: Int
, getItemCount :: {| st } -> Int
| st
}
-- | Represents a running computation that, when it completes, will trigger debounced
-- | .cts.
type Debouncer =
{ var :: AVar Unit
, fiber :: Fiber Unit
{ var :: AVar Unit
, fiber :: Fiber Unit
}
-- | The component's input type, which includes the component's render function. This
-- | render function can also be used to share data with the parent component, as every
-- | time the parent re-renders, the render function will refresh in `Select`.
type Input o item =
{ inputType :: InputType
, items :: Array item
, initialSearch :: Maybe String
, debounceTime :: Maybe Milliseconds
, render :: State item -> ComponentHTML o item
type Input st =
{ inputType :: InputType
, search :: Maybe String
, debounceTime :: Maybe Milliseconds
, getItemCount :: {| st } -> Int
| st
}
-- | The parent is only notified for a few important events, but `Emit` makes it
-- | possible to raise arbitrary queries on events.
-- |
-- | - `Searched`: A new text search has been performed. Contains the text.
-- | - `Selected`: An item has been selected. Contains the item.
-- | - `VisibilityChanged`: The visibility has changed. Contains the new visibility.
-- | - `Emit`: An embedded query has been triggered and can now be evaluated.
-- | Contains the query.
data Message o item
= Searched String
| Selected item
| VisibilityChanged Visibility
| Emit (o Unit)
type Spec st query act ps msg m =
{ -- usual Halogen component spec
render
:: State st
-> H.ComponentHTML (Action act) ps m
-- handle additional actions provided to the component
, handleAction
:: act
-> H.HalogenM (State st) (Action act) ps msg m Unit
component :: ∀ o item m. MonadAff m => Component o item m
component =
H.lifecycleComponent
{ initialState
, render: extract
, eval: eval'
, receiver: Just <<< receive
, initializer: Just initialize
, finalizer: Nothing
}
where
initialState i = store i.render
{ inputType: i.inputType
, search: fromMaybe "" i.initialSearch
, debounceTime: fromMaybe (Milliseconds 0.0) i.debounceTime
, debounceRef: Nothing
, items: i.items
, highlightedIndex: Nothing
, visibility: Off
, lastIndex: length i.items - 1
-- handle additional queries provided to the component
, handleQuery
:: forall a
. query a
-> H.HalogenM (State st) (Action act) ps msg m (Maybe a)
-- handle messages emitted by the component; provide H.raise to simply
-- raise the Select messages to the parent.
, handleMessage
:: Message
-> H.HalogenM (State st) (Action act) ps msg m Unit
-- optionally handle input on parent re-renders; off by default, but use
-- `Just <<< Receive` to enable Select's default receiver
, receive
:: Input st
-> Maybe (Action act)
-- perform some action when the component initializes.
, initialize
:: Maybe (Action act)
-- optionally perform some action on initialization. disabled by default.
, finalize
:: Maybe (Action act)
}
type Spec' st m = Spec st (Const Void) Void () Void m
defaultSpec :: forall st query act ps msg m. Spec st query act ps msg m
defaultSpec =
{ render: const (HH.text mempty)
, handleAction: const (pure unit)
, handleQuery: const (pure Nothing)
, handleMessage: const (pure unit)
, receive: const Nothing
, initialize: Nothing
, finalize: Nothing
}
component
:: forall st query act ps msg m
. MonadAff m
=> Row.Lacks "debounceRef" st
=> Row.Lacks "visibility" st
=> Row.Lacks "highlightedIndex" st
=> Spec st query act ps msg m
-> H.Component HH.HTML (Query query ps) (Input st) msg m
component spec = H.mkComponent
{ initialState
, render: spec.render
, eval: H.mkEval $ H.defaultEval
{ handleQuery = handleQuery spec.handleQuery
, handleAction = handleAction spec.handleAction spec.handleMessage
, initialize = Just (Initialize spec.initialize)
, receive = spec.receive
, finalize = spec.finalize
}
}
where
initialState :: Input st -> State st
initialState = Builder.build pipeline
where
pipeline =
Builder.modify (SProxy :: _ "search") (fromMaybe "")
>>> Builder.modify (SProxy :: _ "debounceTime") (fromMaybe mempty)
>>> Builder.insert (SProxy :: _ "debounceRef") Nothing
>>> Builder.insert (SProxy :: _ "visibility") Off
>>> Builder.insert (SProxy :: _ "highlightedIndex") Nothing
-- Construct the fold over the free monad based on the stepwise eval
eval' :: Query o item ~> ComponentDSL o item m
eval' a = foldFree eval a
handleQuery
:: forall st query act ps msg m a
. MonadAff m
=> (query a -> H.HalogenM (State st) (Action act) ps msg m (Maybe a))
-> Query query ps a
-> H.HalogenM (State st) (Action act) ps msg m (Maybe a)
handleQuery handleQuery' = case _ of
Send box ->
H.HalogenM $ liftF $ H.ChildQuery box
-- Helper for setting visibility inside `eval`. Eta-expanded bc strict
-- mutual recursion woes.
setVis v = eval' (setVisibility v)
Query query ->
handleQuery' query
-- Just the normal Halogen eval
eval :: QueryF o item ~> ComponentDSL o item m
eval = case _ of
Initialize a -> a <$ do
ref <- H.liftEffect $ Ref.new Nothing
modifyState_ _ { debounceRef = Just ref }
handleAction
:: forall st act ps msg m
. MonadAff m
=> Row.Lacks "debounceRef" st
=> Row.Lacks "visibility" st
=> Row.Lacks "highlightedIndex" st
=> (act -> H.HalogenM (State st) (Action act) ps msg m Unit)
-> (Message -> H.HalogenM (State st) (Action act) ps msg m Unit)
-> Action act
-> H.HalogenM (State st) (Action act) ps msg m Unit
handleAction handleAction' handleMessage = case _ of
Initialize mbAction -> do
ref <- H.liftEffect $ Ref.new Nothing
H.modify_ _ { debounceRef = Just ref }
for_ mbAction handle
Search str -> do
st <- H.get
ref <- H.liftEffect $ map join $ traverse Ref.read st.debounceRef
H.modify_ _ { search = str }
void $ H.fork $ handle $ SetVisibility On
Search str a -> a <$ do
st <- getState
ref :: Maybe Debouncer <- H.liftEffect $ map join $ traverse Ref.read st.debounceRef
modifyState_ _ { search = str }
setVis On
case st.inputType, ref of
Text, Nothing -> unit <$ do
var <- H.liftAff AVar.empty
fiber <- H.liftAff $ forkAff do
delay st.debounceTime
AVar.put unit var
case st.inputType, ref of
TextInput, Nothing -> unit <$ do
var <- H.liftAff AVar.empty
fiber <- H.liftAff $ forkAff do
delay st.debounceTime
AVar.put unit var
-- This compututation will fork and run in the background. When the
-- var is finally filled, the action will run
void $ H.fork do
void $ H.liftAff $ AVar.take var
void $ H.liftEffect $ traverse_ (Ref.write Nothing) st.debounceRef
H.modify_ _ { highlightedIndex = Just 0 }
newState <- H.get
handleMessage $ Searched newState.search
-- This compututation will fork and run in the background. When the
-- var is finally filled, the action will run (raise a new search)
_ <- H.fork do
_ <- H.liftAff $ AVar.take var
void $ H.liftEffect $ traverse_ (Ref.write Nothing) st.debounceRef
modifyState_ _ { highlightedIndex = Just 0 }
newState <- getState
H.raise $ Searched newState.search
void $ H.liftEffect $ traverse_ (Ref.write $ Just { var, fiber }) st.debounceRef
void $ H.liftEffect $ traverse_ (Ref.write $ Just { var, fiber }) st.debounceRef
Text, Just debouncer -> do
let var = debouncer.var
void $ H.liftAff $ killFiber (error "Time's up!") debouncer.fiber
fiber <- H.liftAff $ forkAff do
delay st.debounceTime
AVar.put unit var
void $ H.liftEffect $ traverse_ (Ref.write $ Just { var, fiber }) st.debounceRef
TextInput, Just debouncer -> do
let var = debouncer.var
_ <- H.liftAff $ killFiber (error "Time's up!") debouncer.fiber
fiber <- H.liftAff $ forkAff do
delay st.debounceTime
AVar.put unit var
-- Key stream is not yet implemented. However, this should capture user
-- key events and expire their search after a set number of milliseconds.
_, _ -> pure unit
void $ H.liftEffect $ traverse_ (Ref.write $ Just { var, fiber }) st.debounceRef
Highlight target -> do
st <- H.get
when (st.visibility == On) do
H.modify_ _ { highlightedIndex = Just $ getTargetIndex st target }
-- Key stream is not yet implemented. However, this should capture user
-- key events and expire their search after a set number of milliseconds.
_, _ -> pure unit
Select target mbEv -> do
for_ mbEv (H.liftEffect <<< preventDefault <<< ME.toEvent)
st <- H.get
when (st.visibility == On) case target of
Index ix -> handleMessage $ Selected ix
Next -> handleMessage $ Selected $ getTargetIndex st target
Prev -> handleMessage $ Selected $ getTargetIndex st target
Highlight target a -> a <$ do
st <- getState
when (st.visibility /= Off) $ do
let highlightedIndex = case target of
Prev -> case st.highlightedIndex of
Just i | i /= 0 ->
Just (i - 1)
_ ->
Just st.lastIndex
Next -> case st.highlightedIndex of
Just i | i /= st.lastIndex ->
Just (i + 1)
_ ->
Just 0
Index i ->
Just i
modifyState_ _ { highlightedIndex = highlightedIndex }
pure unit
ToggleClick ev -> do
H.liftEffect $ preventDefault $ ME.toEvent ev
st <- H.get
case st.visibility of
On -> do
handle $ Focus false
handle $ SetVisibility Off
Off -> do
handle $ Focus true
handle $ SetVisibility On
Select index a -> a <$ do
st <- getState
when (st.visibility == On) $
for_ (st.items !! index)
\item -> H.raise (Selected item)
Focus shouldFocus -> do
inputElement <- H.getHTMLElementRef $ H.RefLabel "select-input"
for_ inputElement \el -> H.liftEffect case shouldFocus of
true -> HTMLElement.focus el
_ -> HTMLElement.blur el
Focus focusOrBlur a -> a <$ do
Key ev -> do
void $ H.fork $ handle $ SetVisibility On
let preventIt = H.liftEffect $ preventDefault $ KE.toEvent ev
case KE.code ev of
"ArrowUp" ->
preventIt *> handle (Highlight Prev)
"ArrowDown" ->
preventIt *> handle (Highlight Next)
"Escape" -> do
inputElement <- H.getHTMLElementRef $ H.RefLabel "select-input"
traverse_ (H.liftEffect <<< if focusOrBlur then focus else blur) inputElement
preventIt
for_ inputElement (H.liftEffect <<< HTMLElement.blur)
"Enter" -> do
st <- H.get
preventIt
for_ st.highlightedIndex \ix ->
handle $ Select (Index ix) Nothing
otherKey -> pure unit
Key ev a -> a <$ do
setVis On
let preventIt = H.liftEffect $ preventDefault $ KE.toEvent ev
case KE.code ev of
"ArrowUp" -> preventIt *> eval' (highlight Prev)
"ArrowDown" -> preventIt *> eval' (highlight Next)
"Escape" -> do
inputElement <- H.getHTMLElementRef $ H.RefLabel "select-input"
preventIt
for_ inputElement (H.liftEffect <<< blur)
"Enter" -> do
st <- getState
preventIt
for_ st.highlightedIndex (eval' <<< select)
otherKey -> pure unit
PreventClick ev ->
H.liftEffect $ preventDefault $ ME.toEvent ev
PreventClick ev a -> a <$ do
H.liftEffect <<< preventDefault <<< ME.toEvent $ ev
SetVisibility v -> do
st <- H.get
when (st.visibility /= v) do
H.modify_ _ { visibility = v, highlightedIndex = Just 0 }
handleMessage $ VisibilityChanged v
SetVisibility v a -> a <$ do
st <- getState
when (st.visibility /= v) do
modifyState_ _ { visibility = v, highlightedIndex = Just 0 }
H.raise $ VisibilityChanged v
Action act -> handleAction' act
GetVisibility f -> do
st <- getState
pure (f st.visibility)
where
-- eta-expansion is necessary to avoid infinite recursion
handle act = handleAction handleAction' handleMessage act
getTargetIndex st = case _ of
Index i -> i
Prev -> case st.highlightedIndex of
Just i | i /= 0 -> i - 1
_ -> lastIndex st
Next -> case st.highlightedIndex of
Just i | i /= lastIndex st -> i + 1
_ -> 0
where
-- we know that the getItemCount function will only touch user fields,
-- and that the state record contains *at least* the user fields, so
-- this saves us from a set of unnecessary record deletions / modifications
userState :: State st -> {| st }
userState = unsafeCoerce
lastIndex :: State st -> Int
lastIndex = (_ - 1) <<< st.getItemCount <<< userState
ReplaceItems items a -> a <$ do
modifyState_ _
{ items = items
, lastIndex = length items - 1
, highlightedIndex = Nothing }
Raise parentQuery a -> a <$ do
H.raise (Emit parentQuery)
Receive input a -> a <$ do
modifyStore input.render identity

96
src/Select/Setters.purs
View file

@ -4,29 +4,28 @@
-- | below.
module Select.Setters where
import Prelude
import Prelude (append, ($), (<<<))
import Data.Maybe (Maybe(..))
import Halogen (RefLabel(..)) as H
import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Select (Query, Target(..), Visibility(..))
import Select as Select
import Web.Event.Event (Event)
import Select
import Web.Event.Event as E
import Web.UIEvent.FocusEvent as FE
import Web.UIEvent.KeyboardEvent as KE
import Web.UIEvent.MouseEvent as ME
-- | The properties that must be supported by the HTML element that serves
-- | as a menu toggle. This should be used with toggle-driven `Select` components.
type ToggleProps p =
type ToggleProps props =
( onFocus :: FE.FocusEvent
, onKeyDown :: KE.KeyboardEvent
, onMouseDown :: ME.MouseEvent
, onClick :: ME.MouseEvent
, onBlur :: FE.FocusEvent
, tabIndex :: Int
| p
| props
)
-- | A helper function that augments an array of `IProps` with `ToggleProps`. It
@ -38,37 +37,30 @@ type ToggleProps p =
-- | renderToggle = div (setToggleProps [ class "btn-class" ]) [ ...html ]
-- | ```
setToggleProps
:: ∀ o item p
. Array (HP.IProp (ToggleProps p) (Query o item Unit))
-> Array (HP.IProp (ToggleProps p) (Query o item Unit))
setToggleProps = (<>)
[ HE.onFocus $ Select.always $ Select.setVisibility On
, HE.onMouseDown \ev -> Just do
Select.preventClick ev
Select.getVisibility >>= case _ of
Select.On -> do
Select.triggerBlur
Select.setVisibility Select.Off
Select.Off -> do
Select.triggerFocus
Select.setVisibility Select.On
, HE.onKeyDown $ Just <<< Select.key
, HE.onBlur $ Select.always $ Select.setVisibility Off
:: forall props st act
. State st
-> Array (HP.IProp (ToggleProps props) (Action act))
-> Array (HP.IProp (ToggleProps props) (Action act))
setToggleProps st = append
[ HE.onFocus \_ -> Just $ SetVisibility On
, HE.onMouseDown $ Just <<< ToggleClick
, HE.onKeyDown $ Just <<< Key
, HE.onBlur \_ -> Just $ SetVisibility Off
, HP.tabIndex 0
, HP.ref (H.RefLabel "select-input")
]
-- | The properties that must be supported by the HTML element that serves
-- | as a text input. This should be used with input-driven `Select` components.
type InputProps p =
type InputProps props =
( onFocus :: FE.FocusEvent
, onKeyDown :: KE.KeyboardEvent
, onInput :: Event
, onInput :: E.Event
, value :: String
, onMouseDown :: ME.MouseEvent
, onBlur :: FE.FocusEvent
, tabIndex :: Int
| p
| props
)
-- | A helper function that augments an array of `IProps` with `InputProps`. It
@ -80,15 +72,15 @@ type InputProps p =
-- | renderInput = input_ (setInputProps [ class "my-class" ])
-- | ```
setInputProps
:: ∀ o item p
. Array (HP.IProp (InputProps p) (Query o item Unit))
-> Array (HP.IProp (InputProps p) (Query o item Unit))
setInputProps = (<>)
[ HE.onFocus $ Select.always $ Select.setVisibility On
, HE.onKeyDown $ Just <<< Select.key
, HE.onValueInput $ Just <<< Select.search
, HE.onMouseDown $ Select.always $ Select.setVisibility On
, HE.onBlur $ Select.always $ Select.setVisibility Off
:: forall props act
. Array (HP.IProp (InputProps props) (Action act))
-> Array (HP.IProp (InputProps props) (Action act))
setInputProps = append
[ HE.onFocus \_ -> Just $ SetVisibility On
, HE.onKeyDown $ Just <<< Key
, HE.onValueInput $ Just <<< Search
, HE.onMouseDown \_ -> Just $ SetVisibility On
, HE.onBlur \_ -> Just $ SetVisibility Off
, HP.tabIndex 0
, HP.ref (H.RefLabel "select-input")
]
@ -96,10 +88,10 @@ setInputProps = (<>)
-- | The properties that must be supported by the HTML element that acts as a
-- | selectable "item" in your UI. This should be attached to every item that
-- | can be selected.
type ItemProps p =
type ItemProps props =
( onMouseDown :: ME.MouseEvent
, onMouseOver :: ME.MouseEvent
| p
| props
)
-- | A helper function that augments an array of `IProps` with `ItemProps`. It
@ -109,20 +101,19 @@ type ItemProps p =
-- | with `mapWithIndex`:
-- |
-- | ```purescript
-- | renderItem index itemHTML = HH.li (setItemProps index [ class "my-class" ]) [ itemHTML ]
-- | renderItem index itemHTML =
-- | HH.li (setItemProps index [ props ]) [ itemHTML ]
-- |
-- | render = renderItem `mapWithIndex` itemsArray
-- | ```
setItemProps
:: ∀ o item p
. Int
-> Array (HP.IProp (ItemProps p) (Query o item Unit))
-> Array (HP.IProp (ItemProps p) (Query o item Unit))
setItemProps index = (<>)
[ HE.onMouseDown \ev -> Just do
Select.preventClick ev
Select.select index
, HE.onMouseOver $ Select.always $ Select.highlight (Index index)
:: forall props act
. Int
-> Array (HP.IProp (ItemProps props) (Action act))
-> Array (HP.IProp (ItemProps props) (Action act))
setItemProps index = append
[ HE.onMouseDown \ev -> Just (Select (Index index) (Just ev))
, HE.onMouseOver \_ -> Just $ Highlight (Index index)
]
-- | A helper function that augments an array of `IProps` with a `MouseDown`
@ -130,8 +121,9 @@ setItemProps index = (<>)
-- | from bubbling up a blur event to the DOM. This should be used on the parent
-- | element that contains your items.
setContainerProps
:: ∀ o item p
. Array (HP.IProp (onMouseDown :: ME.MouseEvent | p) (Query o item Unit))
-> Array (HP.IProp (onMouseDown :: ME.MouseEvent | p) (Query o item Unit))
setContainerProps = (<>)
[ HE.onMouseDown $ Just <<< Select.preventClick ]
:: forall props act
. Array (HP.IProp (onMouseDown :: ME.MouseEvent | props) (Action act))
-> Array (HP.IProp (onMouseDown :: ME.MouseEvent | props) (Action act))
setContainerProps = append
[ HE.onMouseDown $ Just <<< PreventClick ]