Created
March 21, 2015 11:35
-
-
Save luite/a60cced132d6a3eb7b18 to your computer and use it in GitHub Desktop.
Client side points free with GHCJS
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| <!DOCTYPE html> | |
| <head> | |
| <title>Points Free!</title> | |
| <meta charset="utf-8"> | |
| <link rel="stylesheet" type="text/css" href="tryps.css"> | |
| <link rel="stylesheet" type="text/css" href="codemirror.css"> | |
| <script language="javascript" src="codemirror.min.js"></script> | |
| </head> | |
| <html> | |
| <body> | |
| <div id="content"> | |
| <div id="source_outer"> | |
| <div id="source"> | |
| <textarea id="editor"> | |
| f x y = x + y + x | |
| </textarea> | |
| </div> | |
| </div> | |
| <div id="result_outer"> | |
| <div id="result"> | |
| <pre id="result_text"></pre> | |
| </div> | |
| </div> | |
| </div> | |
| <div id="footer"> | |
| Points Free! - Powered by <a href="https://github.com/ghcjs/ghcjs">GHCJS</a> - | |
| <a href="https://github.com/ghcjs/ghcjs-examples/">More GHCJS examples</a> | |
| </div> | |
| <script language="javascript"> | |
| if (navigator.userAgent.match(/iPad;.*CPU.*OS 7_\d/i)) { | |
| document.getElementsByTagName("html")[0].style.height = window.innerHeight +"px !important"; | |
| } | |
| </script> | |
| <script language="javascript" src="all.min.js"></script> | |
| </body> | |
| </html> |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, Rank2Types, JavaScriptFFI, OverloadedStrings #-} | |
| module Main where | |
| import Control.Applicative | |
| import Control.Concurrent | |
| import Control.Exception | |
| import Control.Monad | |
| import GHCJS.Types | |
| import GHCJS.Foreign | |
| import qualified Pointfree | |
| setError :: String -> IO () | |
| setError xs = js_setError (toJSString xs) | |
| compileWorker :: MVar String -> (forall a. IO a -> IO a) -> IO () | |
| compileWorker mv unmask = | |
| forever $ unmask doCompile `catch` \(e::AsyncException) -> return () | |
| where | |
| setResult :: String -> [String] -> IO () | |
| setResult r [] | null r = js_setResult "Not a valid Haskell expression" | |
| | otherwise = js_setResult (toJSString r) >> return () | |
| setResult r (x:xs) = | |
| let r' = r ++ "\n\n" ++ x | |
| in js_setResult (toJSString r) >> {- js_setBusy >> -} setResult r' xs | |
| doCompile = do | |
| src <- takeMVar mv | |
| setResult "" (Pointfree.pointfree src) | |
| abortCompilation :: ThreadId -> IO () | |
| abortCompilation worker = killThread worker | |
| main :: IO () | |
| main = do | |
| js_trypsInit | |
| mv <- newEmptyMVar | |
| worker <- mask_ $ forkIOWithUnmask (compileWorker mv) | |
| forever $ do | |
| js_waitForChange | |
| abortCompilation worker | |
| threadDelay 500000 | |
| putMVar mv . fromJSString =<< js_getEditorContents | |
| -------------------------------------------------------------------------------- | |
| foreign import javascript unsafe | |
| "trypsInit();" js_trypsInit :: IO () | |
| foreign import javascript unsafe | |
| "tryps.getEditorContents()" js_getEditorContents :: IO JSString | |
| foreign import javascript unsafe | |
| "tryps.setBusy();" js_setBusy :: IO () | |
| foreign import javascript interruptible | |
| "tryps.waitForChange($c);" js_waitForChange :: IO () | |
| foreign import javascript unsafe | |
| "tryps.setError($1);" js_setError :: JSString -> IO () | |
| foreign import javascript unsafe | |
| "tryps.setResult($1);" js_setResult :: JSString -> IO () |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| /** @constructor */ | |
| function TryPs(editor, res, res_text, run_btn, run_output, run_templ, prelude) { | |
| this.changed = true; | |
| this.waiting = []; | |
| this.result = document.getElementById(res); | |
| this.result_text = document.getElementById(res_text); | |
| this.code = null; | |
| this.editor = CodeMirror['fromTextArea']( | |
| document.getElementById(editor), { 'lineNumbers': true | |
| , 'mode': 'haskell' | |
| , 'theme': 'elegant' | |
| }); | |
| var that = this; | |
| this.editor['on']('changes', function() { | |
| that.changed = true; | |
| var x; | |
| while(x = that.waiting.pop()) x(); | |
| }); | |
| } | |
| TryPs.prototype.waitForChange = function(c) { | |
| if(this.changed) c(); else this.waiting.push(c); | |
| } | |
| TryPs.prototype.getEditorContents = function() { | |
| this.changed = false; | |
| return this.editor['getDoc']()['getValue'](); | |
| } | |
| TryPs.prototype.setError = function(err) { | |
| this.result.className = "error"; | |
| this.result_text.textContent = err; | |
| } | |
| TryPs.prototype.setResult = function(res) { | |
| this.result.className = "runnable"; | |
| this.result_text.textContent = res; | |
| this.code = res; | |
| } | |
| TryPs.prototype.setBusy = function() { | |
| this.result.className = "busy"; | |
| this.result_text.textContent = ""; | |
| } | |
| var tryps; | |
| function trypsInit() { | |
| tryps = new TryPs( 'editor', 'result_outer', 'result_text', 'run_button' | |
| , 'run_output', 'run_template', 'purescript_prelude'); | |
| } | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment