Initial commit of TextCursor

Author: MonoidMusician

bower.json

@@ -0,0 +1,17 @@
+{
+  "name": "purescript-textcursor",
+  "ignore": [
+    "**/.*",
+    "node_modules",
+    "bower_components",
+    "output"
+  ],
+  "dependencies": {
+    "purescript-prelude": "^3.0.0",
+    "purescript-newtype": "^2.0.0",
+    "purescript-profunctor-lenses": "^3.2.0",
+    "purescript-dom": "^4.3.1",
+    "purescript-symbols": "^3.0.0"
+  },
+  "devDependencies": {}
+}

src/DOM/Util/TextCursor.purs

@@ -0,0 +1,106 @@
+module DOM.Util.TextCursor
+    ( TextCursor(..)
+    , _before, _selected, _after
+    , selectAll, moveCursorToStart, moveCursorToEnd
+    , content, empty, single
+    , insert, mapAll
+    ) where
+
+import Prelude
+import Data.Symbol (SProxy(..))
+import Data.Newtype (class Newtype)
+import Data.Lens (Lens', (.~))
+import Data.Lens.Record (prop)
+import Data.Lens.Iso.Newtype (_Newtype)
+
+-- | The `TextCursor` type represents text selection within an input element.
+-- | It consists of three regions of text: the text before the cursor, the text
+-- | selected, and the text after the selection. This allows replacements to
+-- | occur while keeping intact the cursor position/selection.
+newtype TextCursor = TextCursor
+    { before :: String
+    , selected :: String
+    , after :: String
+    }
+
+derive instance textCursorNewtype :: Newtype TextCursor _
+
+-- | Get the current text in the field. (Everything before, inside, and after
+-- | the selection.)
+content :: TextCursor -> String
+content (TextCursor { before, selected, after }) = before <> selected <> after
+
+-- | An empty input field. No selection.
+empty :: TextCursor
+empty = TextCursor { before: "", selected: "", after: "" }
+
+-- | Lens for the text before the selection. Empty if the cursor is at the
+-- | beginning or the selection starts from the beginning.
+_before :: Lens' TextCursor String
+_before = _Newtype <<< prop (SProxy :: SProxy "before")
+
+-- | Lens for the text that is selected. Empty if nothing is selected.
+_selected :: Lens' TextCursor String
+_selected = _Newtype <<< prop (SProxy :: SProxy "selected")
+
+-- | Lens for the text after the selection. Empty if the cursor or selection
+-- | reaches the end.
+_after :: Lens' TextCursor String
+_after = _Newtype <<< prop (SProxy :: SProxy "after")
+
+-- | Apply a `Lens` setting a value to an empty `TextCursor`. When used with
+-- | `beforeL`, `selectedL`, or `afterL` this will provide a `TextCursor` with
+-- | only one non-empty field.
+single :: Lens' TextCursor String -> String -> TextCursor
+single l v = l .~ v $ empty
+
+-- | Map all three fields of the `TextCursor` with an endomorphism, performing
+-- | a replacement or other transformation such as normalization.
+mapAll :: (String -> String) -> TextCursor -> TextCursor
+mapAll f (TextCursor { before, selected, after }) = TextCursor
+    { before: f before
+    , selected: f selected
+    , after: f after
+    }
+
+-- | Move the cursor to the start of a field, preserving the overall text
+-- | content.
+moveCursorToStart :: TextCursor -> TextCursor
+moveCursorToStart tc = TextCursor
+    { before: ""
+    , selected: ""
+    , after: content tc
+    }
+
+-- | Select all of the text in a field.
+-- |
+-- | Note: selection direction is not specified.
+selectAll :: TextCursor -> TextCursor
+selectAll tc = TextCursor
+    { before: ""
+    , selected: content tc
+    , after: ""
+    }
+
+-- | Move the cursor to the end of a field, preserving the overall text content.
+moveCursorToEnd :: TextCursor -> TextCursor
+moveCursorToEnd tc = TextCursor
+    { before: content tc
+    , selected: ""
+    , after: ""
+    }
+
+-- | Insert a string at the cursor position. If text is selected, the insertion
+-- | will be part of the selection. Otherwise it is inserted before the cursor.
+insert :: String -> TextCursor -> TextCursor
+insert insertion = case _ of
+    TextCursor { before, selected: "", after } -> TextCursor
+        { before: before <> insertion
+        , selected: ""
+        , after: after
+        }
+    TextCursor { before, selected, after } -> TextCursor
+        { before: before
+        , selected: selected <> insertion
+        , after: after
+        }

src/DOM/Util/TextCursor/Element.purs

@@ -0,0 +1,95 @@
+module DOM.Util.TextCursor.Element
+    ( module DOM.Util.TextCursor.Element.Type
+    , module DOM.Util.TextCursor.Element.HTML
+    , textCursor, setTextCursor
+    , modifyTextCursor, modifyTextCursorST
+    , focusTextCursor, focusTextCursorById
+    ) where
+
+import Prelude
+import Data.Maybe (Maybe(Just))
+import Data.Tuple (Tuple(Tuple))
+import Data.String (length, splitAt)
+import Data.Lens (Lens', (.~))
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Class (class MonadEff, liftEff)
+import Control.Monad.State.Class (class MonadState, modify)
+import DOM (DOM)
+import DOM.Node.Types (ElementId)
+import DOM.HTML.HTMLElement (focus)
+import DOM.Util.TextCursor (TextCursor(..), content)
+import DOM.Util.TextCursor.Element.Type
+    ( TextCursorElement(..)
+    , htmlTextCursorElementToHTMLElement
+    , read, readEventTarget
+    , validate, validate'
+    , lookupAndValidate
+    , lookupValidateAndDo
+    )
+import DOM.Util.TextCursor.Element.HTML
+    ( value, setValue
+    , selectionStart, setSelectionStart
+    , selectionEnd, setSelectionEnd
+    )
+
+-- | Helper to split a `String` at a specific position without worrying about
+-- | `Nothing`.
+splitAtTuple :: Int -> String -> Tuple String String
+splitAtTuple i s = case splitAt i s of
+    Just {before, after} -> Tuple before after
+    _ | i > 0     -> Tuple s ""
+      | otherwise -> Tuple "" s
+
+-- | Get the `TextCursor` from a `TextCursorElement`.
+textCursor :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) TextCursor
+textCursor element = do
+    val <- value element
+    start <- selectionStart element
+    end <- selectionEnd element
+    let (Tuple prior after) = splitAtTuple end val
+    let (Tuple before selected) = splitAtTuple start prior
+    pure $ TextCursor
+        { before
+        , selected
+        , after
+        }
+
+-- | Set the `TextCursor` on a `TextCursorElement`. Calls `setValue`,
+-- | `setSelectionStart`, and `setSelectionEnd`.
+setTextCursor :: forall eff. TextCursor -> TextCursorElement -> Eff ( dom :: DOM | eff ) Unit
+setTextCursor (tc@TextCursor { before, selected, after }) element = do
+    setValue (content tc) element
+    let start = length before
+    let end = start + length selected
+    setSelectionStart start element
+    setSelectionEnd end element
+
+-- | Modifies the `TextCursor` on an element through the given endomorphism.
+modifyTextCursor :: forall eff. (TextCursor -> TextCursor) -> TextCursorElement -> Eff ( dom :: DOM | eff ) Unit
+modifyTextCursor f element = do
+    tc <- f <$> textCursor element
+    setTextCursor tc element
+
+-- | Modifies the `TextCursor` on an element as well as setting the result in a
+-- | State+Eff monad via a lens. Useful for components processing input events!
+modifyTextCursorST :: forall eff m s.
+    MonadState s m =>
+    MonadEff ( dom :: DOM | eff ) m =>
+    Lens' s TextCursor ->
+    (TextCursor -> TextCursor) ->
+    TextCursorElement -> m Unit
+modifyTextCursorST l f element = do
+    tc <- liftEff $ f <$> textCursor element
+    liftEff $ setTextCursor tc element
+    modify $ l .~ tc
+
+-- | Focuses an element after setting the `TextCursor`.
+focusTextCursor :: forall eff. TextCursor -> TextCursorElement -> Eff ( dom :: DOM | eff ) Unit
+focusTextCursor tc element = do
+    setTextCursor tc element
+    focus (htmlTextCursorElementToHTMLElement element)
+
+-- | Looks up an element by id to focus with a `TextCursor`.
+focusTextCursorById :: forall eff. ElementId -> TextCursor -> Eff ( dom :: DOM | eff ) Unit
+focusTextCursorById name tc = do
+    lookupValidateAndDo name (focusTextCursor tc)

src/DOM/Util/TextCursor/Element/HTML.purs

@@ -0,0 +1,55 @@
+module DOM.Util.TextCursor.Element.HTML
+    ( value, setValue
+    , selectionStart, setSelectionStart
+    , selectionEnd, setSelectionEnd
+    ) where
+
+import Prelude
+import DOM.Util.TextCursor.Element.Type (TextCursorElement(TextArea, Input))
+import Control.Monad.Eff (Eff)
+import DOM (DOM)
+import DOM.HTML.Types (HTMLInputElement, HTMLTextAreaElement)
+import DOM.HTML.HTMLInputElement as HInput
+import DOM.HTML.HTMLTextAreaElement as HTextArea
+
+-- | Lift a pair of getters (Input/TextArea).
+getter
+    :: forall a.
+    (HTMLInputElement -> a) ->
+    (HTMLTextAreaElement -> a) ->
+    TextCursorElement -> a
+getter f _ (Input e) = f e
+getter _ g (TextArea e) = g e
+
+-- | Lift a pair of setters (Input/TextArea).
+setter
+    :: forall a b.
+    (b -> HTMLInputElement -> a) ->
+    (b -> HTMLTextAreaElement -> a) ->
+    b -> TextCursorElement -> a
+setter f _ v (Input e) = f v e
+setter _ g v (TextArea e) = g v e
+
+-- | Get the current text value of a `TextCursorElement`.
+value :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) String
+value = getter HInput.value HTextArea.value
+
+-- | Set the text value of a `TextCursorElement` to the specified string.
+setValue :: forall eff. String -> TextCursorElement -> Eff ( dom :: DOM | eff ) Unit
+setValue = setter HInput.setValue HTextArea.setValue
+
+-- | Get the index of the start of the selection.
+selectionStart :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) Int
+selectionStart = getter HInput.selectionStart HTextArea.selectionStart
+
+-- | Set the index of the start of the selection.
+setSelectionStart :: forall eff. Int -> TextCursorElement -> Eff ( dom :: DOM | eff ) Unit
+setSelectionStart = setter HInput.setSelectionStart HTextArea.setSelectionStart
+
+-- | Get the index of the end of the selection.
+selectionEnd :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) Int
+selectionEnd = getter HInput.selectionEnd HTextArea.selectionEnd
+
+-- | Set the index of the end of the selection.
+setSelectionEnd :: forall eff. Int -> TextCursorElement -> Eff ( dom :: DOM | eff ) Unit
+setSelectionEnd = setter HInput.setSelectionEnd HTextArea.setSelectionEnd

src/DOM/Util/TextCursor/Element/Type.purs

@@ -0,0 +1,104 @@
+module DOM.Util.TextCursor.Element.Type
+    ( TextCursorElement(..)
+    , htmlTextCursorElementToHTMLElement
+    , read, read', readEventTarget
+    , validate, validate'
+    , lookupAndValidate
+    , lookupValidateAndDo
+    ) where
+
+import Prelude (Unit, bind, map, pure, (<$>), (<#>), (<<<), (>>=))
+import Data.Maybe (Maybe(..), maybe)
+import Data.Either (Either(..))
+import Data.Array (elem)
+import Data.Traversable (traverse_)
+import Data.Foreign (F, Foreign, toForeign)
+import Control.Alternative ((<|>))
+import Control.Monad.Except (runExcept)
+import Control.Monad.Eff (Eff)
+import DOM (DOM)
+import DOM.Event.Event (Event, target)
+import DOM.HTML.Types
+    ( HTMLElement, HTMLInputElement, HTMLTextAreaElement
+    , htmlDocumentToNonElementParentNode
+    , htmlInputElementToHTMLElement
+    , htmlTextAreaElementToHTMLElement
+    , readHTMLInputElement
+    , readHTMLTextAreaElement
+    )
+import DOM.HTML (window)
+import DOM.HTML.Window (document)
+import DOM.HTML.HTMLInputElement (type_)
+import DOM.Node.Types (Element, ElementId)
+import DOM.Node.NonElementParentNode (getElementById)
+
+-- | A container for the two usable `Element` types:
+-- | - `HTMLInputElement`
+-- | - `HTMLTextAreaElement`
+-- |
+-- | Note that not all `HTMLInputElement` nodes are valid, as they must contain
+-- | text content. See `validate` for specifics.
+-- |
+-- | Common operations are defined in `TextCursor.Element.HTML`.
+data TextCursorElement = Input HTMLInputElement | TextArea HTMLTextAreaElement
+
+-- | Convert a `TextCursorElement` to a generic `HTMLElement`. Useful for
+-- | `focus`.
+htmlTextCursorElementToHTMLElement :: TextCursorElement -> HTMLElement
+htmlTextCursorElementToHTMLElement (Input e) = htmlInputElementToHTMLElement e
+htmlTextCursorElementToHTMLElement (TextArea e) = htmlTextAreaElementToHTMLElement e
+
+-- | Read a `TextCursorElement` from a `Foreign` type.
+read' :: Foreign -> F TextCursorElement
+read' e = ta <|> i
+    where
+        -- prefer TextArea, which needs no validation
+        ta = TextArea <$> readHTMLTextAreaElement e
+        i = Input <$> readHTMLInputElement e
+
+read :: Element -> F TextCursorElement
+read = read' <<< toForeign
+
+-- | Read a `TextCursorElement` from the `target` field of an `Event`.
+readEventTarget :: Event -> F TextCursorElement
+readEventTarget = read' <<< toForeign <<< target
+
+-- | Validate a `TextCursorElement`. Input fields need to have one of the
+-- | following types when this is called:
+-- | - text (default)
+-- | - email
+-- | - search
+-- | - url
+validate :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
+validate = case _ of
+    tae@(TextArea e) -> pure (Just tae)
+    Input e -> map Input <$> validateInput e
+    where
+        validateInput :: HTMLInputElement -> Eff ( dom :: DOM | eff ) (Maybe HTMLInputElement)
+        validateInput e = do
+            inputtype <- type_ e
+            pure if elem inputtype whitelist
+                then Just e
+                else Nothing
+            where
+                whitelist = ["", "text", "email", "search", "url"]
+
+-- | Convert from a `Foreign` error computation (type `F`) to a validated
+-- | `TextCursorElement`.
+validate' :: forall eff. F TextCursorElement -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
+validate' f =
+    case runExcept f of
+        Left _ -> pure Nothing
+        Right e -> validate e
+
+-- | Look up a `TextCursorElement` in the document by id.
+lookupAndValidate :: forall eff. ElementId -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
+lookupAndValidate name = do
+    win <- window
+    doc <- htmlDocumentToNonElementParentNode <$> document win
+    getElementById name doc <#> map read >>= maybe (pure Nothing) validate'
+
+-- | Look up a `TextCursorElement` by id and run an action if found.
+lookupValidateAndDo :: forall eff. ElementId -> (TextCursorElement -> Eff ( dom :: DOM | eff ) Unit) -> Eff ( dom :: DOM | eff ) Unit
+lookupValidateAndDo name action =
+    lookupAndValidate name >>= traverse_ action