Merge pull request #15 from gspia/master

update fileinput example to allow newer reflex

Author: Ryan Trinkle

.gitignore

@@ -1,4 +1,6 @@
 dist
+dist-newstyle
+dist-ghcjs
 cabal-dev
 *.o
 *.hi

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "reflex-platform"]
+	path = reflex-platform
+	url = https://github.com/reflex-frp/reflex-platform

BasicTodo/BasicTodo.cabal

@@ -0,0 +1,22 @@
+name:                BasicTodo
+version:             0.1.0.1
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable basictodo
+  main-is:             Main.hs
+  ghc-options:         -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
+  -- other-extensions:    
+  build-depends:       base 
+                     -- , common -- we don't need common parts here
+                     , containers
+                     , lens
+                     , text
+                     , ghcjs-dom
+                     , reflex
+                     , reflex-dom
+                     -- , reflex-dom-core
+                     , jsaddle
+                     -- , jsaddle-warp
+  hs-source-dirs:      src
+  default-language:    Haskell2010

BasicTodo/BasicTodo.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecursiveDo           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
+{-
+ - Stripped version of todo list: just add new todo and delete an old one
+ -}
+
+import           Control.Lens
+import qualified Data.Map     as M
+import qualified Data.Text    as T
+import           Reflex
+import           Reflex.Dom                  hiding (mainWidget)
+import           Reflex.Dom.Core             (mainWidget)
+
+
+type MM a = M.Map Int a
+
+-- add a new value to a map, automatically choosing an unused key
+new ::  a -> MM a -> MM a
+new v m = case M.maxViewWithKey m of
+    Nothing          -> [(0,v)] -- overloadedlists
+    Just ((k, _), _) -> M.insert (succ k) v m
+
+-- output the ul of the elements of the given map and return the delete
+-- event for each key
+ulW :: MonadWidget t m => Dynamic t (MM T.Text) -> m (Dynamic t (MM (Event t Int)))
+ulW xs = elClass "ul" "list" $ listWithKey xs $ \k x -> elClass "li" "element" $ do
+    dynText x -- output the text
+    fmap (const k) <$> elClass "div" "delete" (button "x")
+    -- tag the event of button press with the key of the text
+
+-- output an input text widget with auto clean on return and return an
+-- event firing on return containing the string before clean
+inputW :: MonadWidget t m => m (Event t T.Text)
+inputW = do
+    rec let send = ffilter (==13) $ view textInput_keypress input
+            -- send signal firing on *return* key press
+        input <- textInput $ def & setValue .~ fmap (const "") send
+        -- textInput with content reset on send
+    return $ tag (current $ view textInput_value input) send
+    -- tag the send signal with the inputText value BEFORE resetting
+
+-- circuit ulW with a MM String kept updated by new strings from the passed
+-- event and deletion of single element in the MM
+listW :: MonadWidget t m => Event t T.Text -> m ()
+listW e = do
+    rec xs <- foldDyn ($) M.empty $ mergeWith (.)
+        -- live state, updated by two signals
+            [   fmap new e -- insert a new text
+            ,   switch . current $ zs  -- delete text at specific keys
+            ]
+        bs <- ulW xs -- delete signals from outputted state
+        let zs = fmap (mergeWith (.) . map (fmap M.delete) . M.elems) bs
+            -- merge delete events
+    return ()
+
+app :: forall t m. MonadWidget t m => m ()
+app = el "div" $ inputW >>= listW
+
+main :: IO ()
+main = run $ mainWidget app
+

BasicTodo/src/Main.hs

@@ -0,0 +1,25 @@
+# Revision history for reflex-examples
+
+## 2018-01-12
+
+* Update README
+* Updated all examples to use ghcjs-dom and GHCJS.DOM in the imports.
+
+## 2018-01-11
+
+* Update README
+* Update reflex-platform submodule
+
+## 2018-01-10
+
+* Cabal file reorganization
+* Use "project" from reflex-platform for all examples.
+* Small fixes to nasa-pod -example.
+* Small fixes to drag-and-drop -example.
+* Added two simple websocket chat examples.
+* Changed .gitignore a bit
+* Other minor changes.
+
+## 2017 and earlier
+
+* Earlier versions of the examples.

ChangeLog.md

@@ -0,0 +1,20 @@
+name:                Keyboard
+version:             0.1.0.1
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable keyboard
+  main-is:             Main.hs
+  ghc-options:         -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
+  -- other-extensions:    
+  build-depends:       base 
+                     -- , common -- we don't need common parts here
+                     , text
+                     , ghcjs-dom
+                     , reflex
+                     , reflex-dom
+                     , reflex-dom-core
+                     , jsaddle
+                     -- , jsaddle-warp
+  hs-source-dirs:      src
+  default-language:    Haskell2010

Keyboard/Keyboard.cabal

@@ -0,0 +1,5 @@
+
+
+Run with
+
+cabal --project-file=cabal-ghcjs.project --builddir=dist-ghcjs new-build all

Keyboard/Keyboard.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecursiveDo           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
+{-
+ - buttons + real keyboard both writing to a text box
+ -}
+
+import           Control.Monad               (void, forM)
+import qualified Data.List.NonEmpty          as DL (head)
+import           Data.Monoid                 ((<>))
+import qualified Data.Text                   as T
+import           GHCJS.DOM.HTMLElement       (focus)
+import           GHCJS.DOM.HTMLInputElement  hiding (setValue)
+import           Language.Javascript.JSaddle
+import           Reflex
+import           Reflex.Dom                  hiding (mainWidget)
+import           Reflex.Dom.Core             (mainWidget)
+
+-- import Language.Javascript.JSaddle.Warp
+
+
+insertAt :: Int -> Char -> T.Text -> T.Text
+insertAt n c v = T.take n v <> T.singleton c <> T.drop n v
+
+fromListE :: Reflex t => [Event t a] -> Event t a
+fromListE = fmap DL.head . mergeList
+
+performArg :: MonadWidget t m => (b -> JSM a) -> Event t b -> m (Event t a)
+performArg f x = performEvent (fmap (liftJSM . f) x)
+
+inputW :: forall m t . MonadWidget t m => Event t Char -> m ()
+inputW buttonE = do
+    rec let newStringE =
+                attachWith (\v (c,n) -> (n + 1,insertAt n c v)) cur posCharE
+            cur = current $ value input        -- actual string
+            html = _textInput_element input    -- html element
+        input <- textInput $ def & setValue .~ fmap snd newStringE
+        posCharE :: Event t (Char,Int)
+          <- performArg (\c -> (,) c <$> getSelectionStart html) buttonE
+        _ <- delay 0.1 (fmap snd posCharE)
+                >>= performArg (\n -> setSelectionStart html (n+ 1)
+                >> setSelectionEnd html (n + 1))
+    void $ performArg (const $ focus html) buttonE -- keep the focus right
+
+keys :: MonadWidget t m => m [Event t Char]
+keys = forM "qwerty" $ \c -> fmap (const c) <$> button [c] -- OverloadedLists
+
+app :: forall t m. MonadWidget t m => m ()
+app = el "div" $ elClass "div" "keys" keys >>= inputW . fromListE
+
+main :: IO ()
+main = run $ mainWidget app
+
+