hamishmack/Devel.hs

## Devel.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Devel (
    test
  , debug
) where

import Data.Monoid ((<>))
import Reflex.Dom.Core

#ifndef ghcjs_HOST_OS
import Data.Bool (bool)
import qualified Data.Text as T (unpack, pack)
import Language.Javascript.JSaddle.Warp (jsaddleOr, debugWrapper, jsaddleJs)
import Network.Wai.Handler.Warp
       (defaultSettings, setTimeout, setPort, runSettings)
import Network.Wai.Middleware.RequestLogger
import Network.WebSockets (defaultConnectionOptions)
import Language.Javascript.JSaddle (syncPoint, JSM)
import qualified Network.Wai as W
       (responseLBS, pathInfo, requestMethod)
import qualified Network.HTTP.Types as H (status200)
import System.Directory (doesDirectoryExist)
import System.Environment (getEnv)

import Network.Wai.Application.Static
       (defaultFileServerSettings, staticApp)
import System.FilePath ((</>), joinPath, addTrailingPathSeparator)
import qualified Data.ByteString.Lazy as LBS (fromStrict, pack, ByteString)
import qualified Data.Text.Encoding as T (encodeUtf8)

#if MIN_VERSION_ghcjs_dom(0,9,4)
import GHCJS.DOM.Debug (addDebugMenu)
#else
addDebugMenu :: JSM ()
addDebugMenu = return ()
#endif

debug :: Int -> JSM () -> IO ()
debug prt f = do
    let ghcjsFiles = ["rts.js", "lib.js", "out.js", "runmain.js"]
    debugWrapper $ \withRefresh registerContext ->
        runSettings (setPort prt (setTimeout 36000 defaultSettings)) =<<
            jsaddleOr defaultConnectionOptions (registerContext >> addDebugMenu >> f >> syncPoint) (withRefresh $ \req sendResponse ->
                case (W.requestMethod req, W.pathInfo req) of
                    ("GET", ["jsaddle.js"]) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs True
                    ("GET", []) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] (indexHtml [“/jsaddle.js”])
                    ("GET", ["ghcjs"]) -> sendResponse . W.responseLBS H.status200 [("Content-Type", "text/html")]
                        =<< indexHtml (map (LBS.fromStrict . T.encodeUtf8) ghcjsFiles)
                    ("GET", [ghcjsFile]) | ghcjsFile `elem` ghcjsFiles ->
                        staticApp (defaultFileServerSettings
                                ("../dist-ghcjs/build/x86_64-osx/ghcjs-0.2.1/" <> projectName <> "-0.1.0.0/c/" <> projectName <> "/build/" <> projectName <> "/" <> projectName <> ".jsexe/"))
                            req sendResponse
                    _ -> logStdoutDev app req sendResponse)
    putStrLn $ "<a href=\"http://localhost:" <> show prt <> "\">run</a>"
#else
import Language.Javascript.JSaddle (JSM)

debug :: Int -> JSM () -> IO ()
debug _ = id
#endif

indexHtml :: [LBS.ByteString] -> IO LBS.ByteString
indexHtml jsFiles = do
  body <- LBS.fromStrict . snd <$> renderStatic uiStatic
  return . mconcat $
      [ "<!DOCTYPE html>"
      , "<html lang=\"en\" class=\"has-navbar-fixed-top\">"

      , "<head>"
      ,   "<meta charset=\"utf-8\">"
      ,   "<title>Title</title>"
      , "</head>"

      , "<body id=\"body\">"
      ,   body
      ] ++ map (\js -> "<script src='" <> js <> "'></script>") jsFiles ++
      [ "</body>"

      , "</html>"
      ]

app = undefined -- Some Wai Application (eg. servant)

test :: JSM ()
test = mainWidget ui

ui = undefined -- UI
uiStatic = undefined -- Static version of UI (perhaps some of the UI components that work with renderStatic and a "Loading..." message

projectName = undefined -- The name of your project so it (just needed to find cabal new-build --ghcjs output and server it on /ghcjs)

-- Put this in .ghci to make :reload restart the server
-- :def! reload (const $ return "::reload\nDevel.debug 3777 test")
	{-# LANGUAGE CPP #-}
	{-# LANGUAGE TypeOperators #-}
	{-# LANGUAGE DataKinds #-}
	{-# LANGUAGE FlexibleContexts #-}
	{-# LANGUAGE GADTs #-}
	{-# LANGUAGE OverloadedStrings #-}
	{-# LANGUAGE RankNTypes #-}
	{-# LANGUAGE ScopedTypeVariables #-}
	module Devel (
	test
	, debug
	) where

	import Data.Monoid ((<>))
	import Reflex.Dom.Core

	#ifndef ghcjs_HOST_OS
	import Data.Bool (bool)
	import qualified Data.Text as T (unpack, pack)
	import Language.Javascript.JSaddle.Warp (jsaddleOr, debugWrapper, jsaddleJs)
	import Network.Wai.Handler.Warp
	(defaultSettings, setTimeout, setPort, runSettings)
	import Network.Wai.Middleware.RequestLogger
	import Network.WebSockets (defaultConnectionOptions)
	import Language.Javascript.JSaddle (syncPoint, JSM)
	import qualified Network.Wai as W
	(responseLBS, pathInfo, requestMethod)
	import qualified Network.HTTP.Types as H (status200)
	import System.Directory (doesDirectoryExist)
	import System.Environment (getEnv)

	import Network.Wai.Application.Static
	(defaultFileServerSettings, staticApp)
	import System.FilePath ((</>), joinPath, addTrailingPathSeparator)
	import qualified Data.ByteString.Lazy as LBS (fromStrict, pack, ByteString)
	import qualified Data.Text.Encoding as T (encodeUtf8)

	#if MIN_VERSION_ghcjs_dom(0,9,4)
	import GHCJS.DOM.Debug (addDebugMenu)
	#else
	addDebugMenu :: JSM ()
	addDebugMenu = return ()
	#endif

	debug :: Int -> JSM () -> IO ()
	debug prt f = do
	let ghcjsFiles = ["rts.js", "lib.js", "out.js", "runmain.js"]
	debugWrapper $ \withRefresh registerContext ->
	runSettings (setPort prt (setTimeout 36000 defaultSettings)) =<<
	jsaddleOr defaultConnectionOptions (registerContext >> addDebugMenu >> f >> syncPoint) (withRefresh $ \req sendResponse ->
	case (W.requestMethod req, W.pathInfo req) of
	("GET", ["jsaddle.js"]) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs True
	("GET", []) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] (indexHtml [“/jsaddle.js”])
	("GET", ["ghcjs"]) -> sendResponse . W.responseLBS H.status200 [("Content-Type", "text/html")]
	=<< indexHtml (map (LBS.fromStrict . T.encodeUtf8) ghcjsFiles)
	("GET", [ghcjsFile]) \| ghcjsFile `elem` ghcjsFiles ->
	staticApp (defaultFileServerSettings
	("../dist-ghcjs/build/x86_64-osx/ghcjs-0.2.1/" <> projectName <> "-0.1.0.0/c/" <> projectName <> "/build/" <> projectName <> "/" <> projectName <> ".jsexe/"))
	req sendResponse
	_ -> logStdoutDev app req sendResponse)
	putStrLn $ "<a href=\"http://localhost:" <> show prt <> "\">run</a>"
	#else
	import Language.Javascript.JSaddle (JSM)

	debug :: Int -> JSM () -> IO ()
	debug _ = id
	#endif

	indexHtml :: [LBS.ByteString] -> IO LBS.ByteString
	indexHtml jsFiles = do
	body <- LBS.fromStrict . snd <$> renderStatic uiStatic
	return . mconcat $
	[ "<!DOCTYPE html>"
	, "<html lang=\"en\" class=\"has-navbar-fixed-top\">"

	, "<head>"
	, "<meta charset=\"utf-8\">"
	, "<title>Title</title>"
	, "</head>"

	, "<body id=\"body\">"
	, body
	] ++ map (\js -> "<script src='" <> js <> "'></script>") jsFiles ++
	[ "</body>"

	, "</html>"
	]

	app = undefined -- Some Wai Application (eg. servant)

	test :: JSM ()
	test = mainWidget ui

	ui = undefined -- UI
	uiStatic = undefined -- Static version of UI (perhaps some of the UI components that work with renderStatic and a "Loading..." message

	projectName = undefined -- The name of your project so it (just needed to find cabal new-build --ghcjs output and server it on /ghcjs)

	-- Put this in .ghci to make :reload restart the server
	-- :def! reload (const $ return "::reload\nDevel.debug 3777 test")