GHCJS Test Code

ghcjs-test.cabal

-- This project is moved to https://github.com/ayu-mushi/ghcjs-test

name:                ghcjs-test
version:             0.1.0.0
synopsis:            Initial project template from stack
description:         Please see README.md
homepage:            https://github.com/ayu-mushi/ghcjs-test
license:             BSD3
author:              Author name here
maintainer:          example@example.com
copyright:           2017 Author name here
category:            Web
build-type:          Simple
cabal-version:       >=1.10

library
  exposed-modules:     Lib
  build-depends:       base
                     , ghcjs-base ==0.2.0.0
                     , ghcjs-dom
                     , reflex-dom
                     , diagrams-reflex
                     , diagrams-lib
                     , time
                     , mtl
                     , transformers
                     , lens
                     , objective
                     , ghcjs-jquery
                     , containers
                     , shakespeare
                     , blaze-html
                     , text
                     , keycode
                     , stm

  default-language:    Haskell2010

executable ghcjs-test-exe
  main-is:             Main.hs
  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  build-depends:       base
                     , ghcjs-test
  default-language:    Haskell2010

source-repository head
  type:     git
  location: https://github.com/githubuser/ghcjs-test

Lib.hs

{-# LANGUAGE JavaScriptFFI      #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE GADTs  #-}
{-# LANGUAGE RecursiveDo  #-}
{-# LANGUAGE ScopedTypeVariables  #-}

module Lib
    ( myMain
    ) where

import GHCJS.Marshal.Pure (PFromJSVal(..))
import GHCJS.DOM (currentWindowUnchecked, currentDocumentUnchecked)
import GHCJS.DOM.Document (createElement, getBody)
import GHCJS.DOM.Node (insertBefore)
import GHCJS.DOM.Element (setInnerHTML)
import Control.Concurrent
       (tryTakeMVar, takeMVar, readMVar, newMVar, MVar, swapMVar, threadDelay, putMVar, forkIO, newEmptyMVar, forkIOWithUnmask, killThread, isEmptyMVar, ThreadId)
import GHCJS.Concurrent (OnBlocked(..))
import GHCJS.DOM.Types as DOMTypes (Element(unElement), castTo, ToJSString, HTMLInputElement(HTMLInputElement), Window, toElement)
import GHCJS.Types (JSString, JSVal)
import Control.Monad.Cont (ContT(..), callCC)
import GHCJS.Foreign.Callback (Callback, asyncCallback, asyncCallback1, asyncCallback2, syncCallback, syncCallback2, releaseCallback)
import Control.Monad (when, forever, forM_, void)
import Control.Monad.IO.Class (liftIO)
import GHCJS.DOM.HTMLInputElement (getValue)
import System.Timeout (timeout)
import Data.Time.Clock (getCurrentTime, UTCTime, diffUTCTime, NominalDiffTime)
import Data.Time.Format () -- Show instance
import qualified Data.JSString as JSString (pack)
import Data.JSString.Text (lazyTextToJSString)
import JavaScript.JQuery (append, selectElement, select)
import Reflex.Dom as Reflex
  (mainWidget, text, el, elAttr, el', elAttr', MonadWidget, textInput, TextInput(..), dynText, def,
  holdDyn, EventName(Click), domEvent, foldDyn, mapDyn, El, tickLossy, TickInfo(_tickInfo_lastUTC, _tickInfo_n), Event, delay, count, Dynamic, ffilter, FunctorMaybe(fmapMaybe), keypress, display, leftmost, button)
import Diagrams.Prelude as Diagrams ()
import Diagrams.Backend.Reflex as Diagrams ()
import Control.Lens ((&))
import Data.Map (fromList)
import Text.Hamlet (shamlet)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html (Html)
import Data.Text.Internal (Text)
import qualified Data.Text as Text(pack)
import Web.KeyCode (Key(..))

foreign import javascript unsafe "alert($1)" alert :: GHCJS.Types.JSString -> IO ()
foreign import javascript interruptible "setTimeout($c, $1);" delayJS :: Int -> IO ()
foreign import javascript interruptible "setTimeout($2, $1);" settimeout_js :: Int -> Callback (IO ()) -> IO ()
foreign import javascript unsafe "document.getElementById($1)" getElementById :: JSString -> IO Element
foreign import javascript interruptible "$1.onmousemove = function(e) { $c(e.clientX, e.clientY) };" mouseXY
    :: Element -> IO (Int, Int) -- 一応、うまく周期をずらせば複数のスレッドのループからでも使えるはず…
foreign import javascript interruptible "$1.onmousedown = function(e) { $c(e.clientX, e.clientY) };" clickXY
    :: Element -> IO (Int, Int)
foreign import javascript interruptible "(function(){ var flag = true; $1.onmousemove = function(e) { if (flag == true) { $2(e.clientX, e.clientY); } flag = false;}})();" mouseXY_contjs
    :: Element -> Callback (JSVal -> JSVal -> IO ()) -> IO ()
foreign import javascript interruptible "document.onkeydown = function(e) { $c(e.keyCode) };" keydown
    :: IO Int
--foreign import javascript unsafe "console.log($1)" consoleLog :: JSString -> IO ()

waiting :: (Int -> IO ()) -> IO ()
waiting act = waiting' 0
  where
    waiting' :: Int -> IO ()
    waiting' n = do
      act n
      delayJS $ 3 * (10^3)
      waiting' $ n+1

doSth :: IO Bool
doSth = do
  delayJS $ 10 * 10^3
  return True

initialHtml :: Html
initialHtml = [shamlet|
<div>
<canvas #canvas>
<input #in>
<p #out>
<p #mouse>
<p #p_key>
|]

showJS :: Show a => a -> JSString
showJS = JSString.pack . show

-- 継続モナドを利用する版
sleepCont :: Int -> ContT () IO ()
sleepCont n = ContT $ \f -> do
  cb <- asyncCallback $ f ()
  settimeout_js n cb
  releaseCallback cb

mouseXYCont :: Element -> ContT () IO (Int, Int) -- Element -> ((Int,Int) -> IO ()) -> IO ()
mouseXYCont elm = ContT $ \f -> do
  cb <- asyncCallback2 $ \x y -> f (pFromJSVal x, pFromJSVal y)
  mouseXY_contjs elm cb
  releaseCallback cb

sleepingPerson :: Element -> IO ()
sleepingPerson elm = (`runContT` return) $ callCC $ \k -> forever $ do
  liftIO $ putStrLn "zzz...zzz"
  () <- sleepCont $ 1 * 10^4
  (x, y) <- mouseXYCont elm
  when (x < 10) $ do
    liftIO $ putStrLn "your mouse is on (x, y) for some x that < 10. I get up now."
    k ()
  liftIO $ putStrLn $ "Oh, your mouse is on  " ++ show (x, y) ++ "...zzzz"

watchMouse :: MVar (Int, Int) -> Element -> IO ()
watchMouse mouseVar elm = forever $ do
  xy <- mouseXY elm
  isntEmp <- not <$> isEmptyMVar mouseVar
  when isntEmp $ void $ takeMVar mouseVar
  putMVar mouseVar xy
  forkIO $ do
    threadDelay $ 10 ^ 5
    isntEmp <- not <$> isEmptyMVar mouseVar
    when isntEmp $ void $ takeMVar mouseVar

threadLoop :: Int -> IO () -> IO ThreadId
threadLoop n = forkIO . forever . (>> threadDelay n)

-- 敵の攻撃とかに種類あるならオブジェクトを使う
data Action a where
  Attack :: Action ()
  Defence :: Action ()
  Cure :: Action ()
  Poison :: Action ()

data Player = Player {
  hp :: Int
, atk :: Int
, dfc :: Int
, isPoison :: Bool
  }

myWidget :: (MonadWidget t m) => m ()
myWidget = do
  el "div" $ text "Welcome to Reflex"
  t <- textInput def
  el "div" $ dynText $ _textInput_value t
  el "div" $ do
    text "Last keypressed: "
    (holdDyn "None" $ show <$> _textInput_keypress t) >>= display
  rec
    (e, _) <- elAttr' "div" (fromList [("style", "color: red")]) $ text "[Click Here]: " >> clicker e
  el "div" $ do
    ct <- liftIO getCurrentTime
    (tick::Event t TickInfo) <- tickLossy 1 ct
    (holdDyn (0, ct) $ (\t -> (_tickInfo_n t, _tickInfo_lastUTC t)) <$> tick)
      & fmap (fmap show)
      >>= display
  rec
    (e', _) <- el' "div" $ do
      c <- button "clickMe"
      text "CLICKCLICK"
      (n :: Dynamic t Int) <- count $ leftmost [keypress Enter e', c]
      display n
  return ()

  where
    clicker :: (MonadWidget t m) => El t -> m ()
    clicker e = do
      deleyed <- delay 0.1 $ domEvent Click e
      (d::Dynamic t Int) <- count deleyed
      display $ (\x -> ("鈍感 ["++show x++"]"::String)) <$> d
      (d'::Dynamic t Int) <- foldDyn (const(+1)) 0 $ domEvent Click e
      display $ (\x -> ("敏感 ["++show x++"]"::String)) <$> d'

htmlInputElem :: Element -> HTMLInputElement
htmlInputElem = HTMLInputElement . unElement

-- TODO  作ってみる： RPGの戦闘画面, Virtue & Viceシステム(実績解放のようなもの)
-- テトリス、戦略シミュレーション、生態系シミュレーション、ライフゲーム
-- 将棋
myMain :: IO ()
myMain = (mainWidget myWidget) {- reflex part -} >> (do {- normal part -}
  (window::DOMTypes.Window) <- currentWindowUnchecked
  doc <- currentDocumentUnchecked
  Just (body::Element) <- fmap toElement <$> getBody doc
  selectElement body >>= append (lazyTextToJSString $ renderHtml initialHtml)
  canvas <- getElementById "canvas"
  inElem <- htmlInputElem <$> getElementById "in"
  out <- getElementById "out"
  mouse <- getElementById "mouse"
  p_key <- getElementById "p_key"

  mouseVar <- newEmptyMVar
  forkIO $ watchMouse mouseVar canvas
  watchMouseTh <- forkIO $ forM_ (reverse [0..99]) $ \n -> do
    setInnerHTML mouse $ (Nothing :: Maybe String)
    setInnerHTML mouse $ Just ("mouse is not moving"::String)
    (mx1, my1) <- takeMVar mouseVar
    setInnerHTML mouse $ Just $ "rest: " ++ show n ++ ", moving to" ++ show (mx1, my1)
    putStrLn $ "rest: " ++ show n ++ ", moving to" ++ show (mx1, my1)
    threadDelay $ 10^6
  forkIO $ forever $ do
    k <- keydown
    setInnerHTML p_key $ Just $ show k

  forkIO $ forever $ do
    threadDelay $ 10^6
    xy <- takeMVar mouseVar
    putStrLn $ show xy

  -- 「10 秒間クリック可能」みたいなのはどうやる？→
  putStrLn "you can click canvas over 10 second"
  answer <- timeout (10 * 10^6) $ do
    xy <- clickXY canvas
    putStrLn $ "you clicked canvas: " ++ show xy
  when (answer == Nothing) $ do
    putStrLn "you did not clicked canvas"

  {-sleepingTh <- forkIO $ sleepingPerson canvas
  forkIO $ do
    (x, y) <- clickXY canvas
    putStrLn "Killed sleeping person (Sorry!)"
    when (x == x) $ killThread sleepingTh -- doesn't work
    -}
  w <- forkIO $ waiting $ \n -> setInnerHTML out $ Just $ show n
  u <- doSth
  when u $ killThread w
  setInnerHTML out $ Just $ show "killed waiting thread"
  delayJS $ 5 * 10^3
  w' <- forkIO $ forever $ do
    val <- getValue inElem :: IO (Maybe String)
    setInnerHTML out val
    threadDelay $ 5 * 10^5
  u' <- doSth
  when u' $ killThread w'
  return ())

stack.yaml

# This project is moved to https://github.com/ayu-mushi/ghcjs-test!


# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/

# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
#  name: custom-snapshot
#  location: "./custom-snapshot.yaml"

#resolver: lts-6.30
#compiler: ghcjs-0.2.0.9006030_ghc-7.10.3
#compiler-check: match-exact

#setup-info:
#  ghcjs:
#    source:
#     ghcjs-0.2.0.9006030_ghc-7.10.3:
#        url: http://ghcjs.tolysz.org/lts-6.30-9006030.tar.gz
#        sha1: 2371e2ffe9e8781808b7a04313e6a0065b64ee51
resolver: lts-7.19
compiler: ghcjs-0.2.1.9007019_ghc-8.0.1
compiler-check: match-exact

setup-info:
  ghcjs:
    source:
      ghcjs-0.2.1.9007019_ghc-8.0.1:
           url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz
           sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9

# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
#    git: https://github.com/commercialhaskell/stack.git
#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#   extra-dep: true
#  subdirs:
#  - auto-update
#  - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
- location:
    git: https://github.com/ghcjs/ghcjs-base
    commit: dd7034ef8582ea8a175a71a988393a9d1ee86d6f
  extra-dep: true
- location:
    git: https://github.com/reflex-frp/reflex
    commit: a1092192c61f3dec924a8e2686dfe3440681bab3
  extra-dep: true
- location:
    git: https://github.com/reflex-frp/reflex-dom
    commit: 644b1a056f6689bdf6c0eed83cce576889a14284
  subdirs:
  - reflex-dom-core
  - reflex-dom
  extra-dep: true
- location:
    git: https://github.com/RasmusKlett/diagrams-reflex
    commit: b352c5fece74bf40657936d1934f96f20ec1e387
  extra-dep: true
- location:
    git: https://github.com/reflex-frp/reflex-dom-contrib
    commit: 57eeca60e5f2d579bd202e4af40c430bebd0f853
  extra-dep: true
- './ghcjs-jquery'

# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps:
  - ghcjs-dom-0.8.0.0
  - ref-tf-0.4.0.1
  - jsaddle-0.8.3.2
  - prim-uniq-0.1.0.1
  - zenc-0.1.1
  - ghcjs-dom-jsffi-0.8.0.0
  - dlist-0.7.1.2

# Override default flag values for local packages and extra-deps
flags: {}

# Extra package databases containing global packages
extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.3"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor