packages feed

haste-lib (empty) → 0.6.0.0

raw patch · 39 files changed

+5083/−0 lines, 39 filesdep +arraydep +basedep +binarysetup-changed

Dependencies added: array, base, binary, bytestring, containers, data-binary-ieee754, ghc-prim, hashable, haste-prim, integer-gmp, monads-tf, random, time, transformers, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Copyright 2012-2013, Anton Ekblad+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the Anton Ekblad nor the names of his contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haste-lib.cabal view
@@ -0,0 +1,82 @@+Name:           haste-lib+Version:        0.6.0.0+License:        BSD3+License-File:   LICENSE+Category:       Web+Synopsis:       Base libraries for haste-compiler.+Description:    Base libraries for haste-compiler. Only useful for web development, with Haste or vanilla GHC + haste-app.+Cabal-Version:  >= 1.10+Build-Type:     Simple+Author:         Anton Ekblad <anton@ekblad.cc>+Maintainer:     anton@ekblad.cc+Homepage:       http://github.com/valderman/haste-compiler+Bug-reports:    http://github.com/valderman/haste-compiler/issues+Stability:      Experimental++flag haste+     description: Is haste-lib being installed for Haste?+     default: False++Library+    Hs-Source-Dirs: src+    GHC-Options: -Wall -O2+    Exposed-Modules:+        Haste+        Haste.Ajax+        Haste.Audio+        Haste.Binary+        Haste.Concurrent+        Haste.Crypto+        Haste.DOM+        Haste.DOM.JSString+        Haste.Events+        Haste.Foreign+        Haste.Graphics.AnimationFrame+        Haste.Graphics.Canvas+        Haste.JSON+        Haste.JSString+        Haste.LocalStorage+        Haste.Parsing+        Haste.Performance+        Haste.Serialize+        Haste.WebSockets+    Other-Modules:+        Haste.Audio.Events+        Haste.Binary.Get+        Haste.Binary.Put+        Haste.Binary.Types+        Haste.Concurrent.Monad+        Haste.Crypto.Prim+        Haste.Crypto.Types+        Haste.DOM.Core+        Haste.Events.BasicEvents+        Haste.Events.Core+        Haste.Events.KeyEvents+        Haste.Events.MessageEvents+        Haste.Events.MouseEvents+        Haste.Events.TouchEvents+        Haste.Foreign.Array+        Haste.Hash+        Haste.Timer+    Build-Depends:+        base >= 4.8 && < 5,+        integer-gmp,+        transformers,+        monads-tf,+        ghc-prim,+        containers > 0.5.6 && < 0.5.7,+        bytestring < 0.11,+        haste-prim == 0.6.0.0,+        time == 1.5.0.1+    if flag(haste)+       Build-Depends:+         array == 0.5.1.0,+         hashable >= 1.2 && < 1.3+    else+      Build-Depends:+        array,+        random,+        binary              >= 0.7 && < 0.8,+        data-binary-ieee754 >= 0.4 && < 0.5,+        utf8-string         >= 1   && < 2+    Default-Language: Haskell98
+ src/Haste.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, OverloadedStrings #-}+-- | Haste's companion to the Prelude.+module Haste (+    -- * Basic utility functions+    JSString, JSAny, URL, MonadIO (..),+    alert, prompt, eval, writeLog, catJSStr, fromJSStr,++    -- * Location handling+    onHashChange, setHash, getHash,+    getLocationHref, setLocationHref, getLocationHostName, getLocationPort,++    -- * Timers+    Timer, Interval (..), setTimer, stopTimer,++    -- * Fast conversions for JS-native types+    JSType (..), JSNum (..), toString, fromString, convert,++    -- * Reflection+    getProgramId, getProgramJS+  ) where+import Haste.Prim+import Haste.Timer+import Haste.Prim.JSType+import Haste.Hash+import Haste.Foreign+import Control.Monad.IO.Class++jsAlert :: JSString -> IO ()+jsAlert = ffi "alert"++jsLog :: JSString -> IO ()+jsLog = ffi "(function(x){console.log(x);})"++jsPrompt :: JSString -> IO JSString+jsPrompt = ffi "(function(s){var x = prompt(s);\+\return (x === null) ? '' : x.toString();})"++jsEval :: JSString -> IO JSString+jsEval = ffi "(function(s){var x = eval(s);\+\return (typeof x === 'undefined') ? 'undefined' : x.toString();})"++-- | JavaScript @alert()@ function.+alert :: MonadIO m => JSString -> m ()+alert = liftIO . jsAlert++-- | JavaScript @prompt()@ function.+prompt :: MonadIO m => JSString -> m JSString+prompt = liftIO . jsPrompt++-- | JavaScript @eval()@ function.+eval :: MonadIO m => JSString -> m JSString+eval = liftIO . jsEval++-- | JavaScript @console.log()@.+writeLog :: MonadIO m => JSString -> m ()+writeLog = liftIO . jsLog++-- | Get the value of the @__haste_prog_id@ variable. Unless programmatically+--   changed, this variable contains the SHA3-256 hash of the currently+--   executing Haste program.+getProgramId :: MonadIO m => m JSString+getProgramId = liftIO getProgramId'++getProgramId' :: IO JSString+getProgramId' = ffi "(function(){return __haste_prog_id;})"++-- | Get the complete JavaScript source code of the currently executing Haste+--   program. On IE, this requires that the program's identifier, as returned+--   by 'getProgramId', has not been tampered with.+getProgramJS :: MonadIO m => m (Either URL JSString)+getProgramJS = liftIO $ do+  (murl, msrc) <- getCurrentScript+  return $ maybe (maybe impossible Right msrc) Left murl+  where+    impossible = error "impossible!"++-- | JS worker for 'getProgramJS'.+getCurrentScript :: IO (Maybe URL, Maybe JSString)+getCurrentScript = ffi "(function(){\+\    if(__haste_script_elem) {\+\        if(__haste_script_elem.innerHTML) {\+\            return [null, __haste_script_elem.innerHTML];\+\        } else {\+\            return [__haste_script_elem.src, null];\+\        }\+\    } else {\+\        var es = document.getElementsByTagName('SCRIPT');\+\        var re = new RegExp('var __haste_prog_id = \\'\\([0-9a-f]{64}\\)\\';');\+\        for(var i in es) {\+\            if(es[i].innerHTML) {\+\                var match = es[i].innerHTML.match(re);\+\                if(match && match[1] == __haste_prog_id) {\+\                    return [null, es[i].innerHTML];\+\                }\+\            } else if(es[i].src) {\+\                var xhr = new XMLHttpRequest();\+\                xhr.open('GET', es[i].src, false);\+\                xhr.send();\+\                var match = xhr.responseText.match(re);\+\                if(match && match[1] == __haste_prog_id) {\+\                    return [es[i].src, null];\+\                }\+\            }\+\        }\+\    }\+\    throw 'source of current program not found';\+\})"++-- | Get the current complete location URL.+getLocationHref :: MonadIO m => m URL+getLocationHref = liftIO getLocationHref'++getLocationHref' :: IO URL+getLocationHref' = ffi "(function(){return location.href;})"++-- | Set the location URL.+setLocationHref :: MonadIO m => URL -> m ()+setLocationHref href = liftIO (setLocationHref' href)++setLocationHref' :: URL -> IO ()+setLocationHref' = ffi "(function(href){location.href = href;})"++-- | Get the current location host name.+getLocationHostName :: MonadIO m => m JSString+getLocationHostName = liftIO getLocationHostName'++getLocationHostName' :: IO JSString+getLocationHostName' = ffi "(function(){return location.hostname;})"++-- | Get the current location port.+getLocationPort :: MonadIO m => m Int+getLocationPort = liftIO getLocationPort'++getLocationPort' :: IO Int+getLocationPort' = ffi "(function(){return location.port;})"
+ src/Haste/Ajax.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables #-}+-- | XMLHttpRequest support. IE9 and older are not supported.+module Haste.Ajax+  ( Method (..)+  , AjaxData (..)+  , AjaxError (..)+  , ajax, ajaxWithMime+  ) where+import Haste.Prim.Foreign+import Haste.Prim+import Haste.Prim.JSType+import Control.Monad.IO.Class+import Control.Monad (join)+import Haste.Concurrent+import Data.Proxy+import Haste.Binary hiding (get)++class (ToAny a, FromAny a) => AjaxData a where+  -- | The MIME type of the data represented by this type.+  mimeType     :: Proxy a -> JSString++  -- | The XHR response type that corresponds to this type.+  responseType :: Proxy a -> JSString++instance AjaxData JSString where+  mimeType _ = ""+  responseType _ = ""++instance AjaxData Blob where+  mimeType _ = "application/octet-stream"+  responseType _ = "blob"++instance AjaxData () where+  mimeType _ = ""+  responseType _ = ""++-- | Make an AJAX request. The return value is either the body of the requested+--   document, or an error.+ajax :: forall m post resp.+       (MonadConc m, AjaxData post, AjaxData resp)+     => Method post -- ^ HTTP method to use for request. @post@ is always @()@+                    --   for GET requests.+     -> URL         -- ^ URL to request.+     -> m (Either AjaxError resp)+ajax = ajaxWithMime ""++-- | Like 'ajax', but accepts a custom MIME type for POST data.+--   Use this with the appropriate MIME type and POST data if you want to send,+--   for instance, form data.+ajaxWithMime :: forall m post resp.+       (MonadConc m, AjaxData post, AjaxData resp)+     => JSString    -- ^ MIME type of any POST data. Decided by the 'AjaxData'+                    --   instance for @post@ if the empty string is given.+                    --   Only relevant to POST requests.+     -> Method post -- ^ HTTP method to use for request.+     -> URL         -- ^ URL to request.+     -> m (Either AjaxError resp)+ajaxWithMime mime method url = do+    res <- newEmptyMVar+    liftIO $ ajaxReq methodStr url mime' respType postdata $ \merr md -> do+      case (md, merr) of+        (Just d, _)   -> fromAny d >>= concurrent . putMVar res . Right+        (_, Just err) -> concurrent $ putMVar res (Left err)+    liftCIO $ takeMVar res+  where+    mime'+      | "" /= mime = mime+      | otherwise  = mimeType (Proxy :: Proxy post)+    respType = responseType (Proxy :: Proxy resp)+    (postdata, methodStr) = case method of+      GET    -> (Nothing, "GET")+      POST d -> (Just $ toAny d, "POST")+      PUT d  -> (Just $ toAny d, "PUT")+      DELETE -> (Nothing, "DELETE")++-- | An error which occurred during an AJAX request.+--   Might be either a network error (denied by CSP, host unreachable etc.)+--   or an HTTP error, with status code and description.+data AjaxError+  = NetworkError+  | HttpError Int JSString+    deriving (Show, Eq)++instance FromAny AjaxError where+  fromAny x = do+    errtype <- get x "type"+    case errtype of+      "network" -> pure NetworkError+      "http"    -> HttpError <$> get x "status" <*> get x "status-text"+      _         -> fail $ "unknown type of ajax error: " ++ fromJSStr errtype++-- | HTTP method to use for request. POST requests take an (optionally empty)+--   JSString representing data to POST.+data Method a where+  GET    :: Method ()+  DELETE :: Method ()+  POST   :: a -> Method a+  PUT    :: a -> Method a++ajaxReq :: JSString -- ^ method (GET/POST)+        -> JSString -- ^ URI+        -> JSString -- ^ Outgoing MIME type; empty string means default+        -> JSString -- ^ responseType field+        -> Maybe JSAny -- ^ POST data+        -> (Maybe AjaxError -> Maybe JSAny -> IO ())+           -- ^ Callback; if successful, first argument is 0, the second the+           --   empty string, and the third the response data.+           --   If not, third argument is null and the other two give+           --   HTTP status and error message.+        -> IO ()+ajaxReq = ffi "(function(method, uri, mimeout, responseType, postdata, cb) {\+    \var xhr = new XMLHttpRequest();\+    \xhr.open(method, uri);\+    \xhr.responseType = responseType;\+    \if(mimeout != '') {\+      \xhr.setRequestHeader('Content-type', mimeout);\+    \}\+    \xhr.addEventListener('load', function() {\+      \if(xhr.status < 400) {cb(null, xhr.response);}\+      \else {cb({'type':'http', 'status':xhr.status, 'status-text': xhr.statusText}, null);}\+    \});\+    \xhr.addEventListener('error', function() {\+      \if(xhr.status != 0) {\+        \cb({'type':'http', 'status':xhr.status, 'status-text': xhr.statusText}, null);\+      \} else {\+        \cb({'type':'network'}, null);\+      \}\+    \});\+    \xhr.send(postdata);\+  \})"
+ src/Haste/Audio.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+-- | High-ish level bindings to the HTML5 audio tag and JS API.+module Haste.Audio (+    module Events,+    Audio, AudioSettings (..), AudioType (..), AudioSource (..),+    AudioPreload (..), AudioState (..), Seek (..),+    defaultAudioSettings,+    mkSource, newAudio, setSource,+    getState,+    setMute, isMute, toggleMute,+    setLooping, isLooping, toggleLooping,+    getVolume, setVolume, modVolume,+    play, pause, stop, togglePlaying,+    seek, getDuration, getCurrentTime+  ) where+import Haste.Audio.Events as Events+import Haste.DOM.JSString+import Haste.Events.Core+import Haste.Prim.Foreign+import Haste.Prim.JSType+import Haste.Prim+import Control.Monad+import Control.Monad.IO.Class+import Data.String++-- | Represents an audio player.+data Audio = Audio Elem++instance IsElem Audio where+  elemOf (Audio e) = e+  fromElem e = do+    tn <- getProp e "tagName"+    return $ case tn of+      "AUDIO" -> Just $ Audio e+      _       -> Nothing++instance EventSource Audio where+  eventSource = eventSource . elemOf++data AudioState = Playing | Paused | Ended+  deriving (Show, Eq)+data AudioType = MP3 | OGG | WAV+  deriving (Show, Eq)+data AudioSource = AudioSource !AudioType !JSString+  deriving (Show, Eq)+data AudioPreload = None | Metadata | Auto+  deriving Eq+data Seek = Start | End | Seconds Double+  deriving Eq++instance JSType AudioPreload where+  toJSString None     = "none"+  toJSString Metadata = "metadata"+  toJSString Auto     = "auto"+  fromJSString "none"     = Just None+  fromJSString "metadata" = Just Metadata+  fromJSString "auto"     = Just Auto+  fromJSString _          = Nothing++data AudioSettings = AudioSettings {+    -- | Show controls?+    --   Default: False+    audioControls :: !Bool,+    -- | Immediately start playing?+    --   Default: False+    audioAutoplay :: !Bool,+    -- | Initially looping?+    --   Default: False+    audioLooping  :: !Bool,+    -- | How much audio to preload.+    --   Default: Auto+    audioPreload  :: !AudioPreload,+    -- | Initially muted?+    --   Default: False+    audioMuted    :: !Bool,+    -- | Initial volume+    --   Default: 0+    audioVolume   :: !Double+  }++defaultAudioSettings :: AudioSettings+defaultAudioSettings = AudioSettings {+    audioControls = False,+    audioAutoplay = False,+    audioLooping = False,+    audioPreload = Auto,+    audioMuted = False,+    audioVolume = 0+  }++-- | Create an audio source with automatically detected media type, based on+--   the given URL's file extension.+--   Returns Nothing if the given URL has an unrecognized media type.+mkSource :: JSString -> Maybe AudioSource+mkSource url =+  case take 3 $ reverse $ fromJSStr url of+    "3pm" -> Just $ AudioSource MP3 url+    "ggo" -> Just $ AudioSource OGG url+    "vaw" -> Just $ AudioSource WAV url+    _     -> Nothing++instance IsString AudioSource where+  fromString s =+    case mkSource $ Data.String.fromString s of+      Just src -> src+      _        -> error $ "Not a valid audio source: " ++ s++mimeStr :: AudioType -> JSString+mimeStr MP3 = "audio/mpeg"+mimeStr OGG = "audio/ogg"+mimeStr WAV = "audio/wav"++-- | Create a new audio element.+newAudio :: MonadIO m => AudioSettings -> [AudioSource] -> m Audio+newAudio cfg sources = liftIO $ do+  srcs <- forM sources $ \(AudioSource t url) -> do+    newElem "source" `with` ["type" =: mimeStr t, "src" =: toJSString url]+  Audio <$> newElem "audio" `with` [+      "controls" =: falseAsEmpty (audioControls cfg),+      "autoplay" =: falseAsEmpty (audioAutoplay cfg),+      "loop"     =: falseAsEmpty (audioLooping cfg),+      "muted"    =: falseAsEmpty (audioMuted cfg),+      "volume"   =: toJSString (audioVolume cfg),+      "preload"  =: toJSString (audioPreload cfg),+      children srcs+    ]++-- | Returns "true" or "", depending on the given boolean.+falseAsEmpty :: Bool -> JSString+falseAsEmpty True = "true"+falseAsEmpty _    = ""++-- | (Un)mute the given audio object.+setMute :: MonadIO m => Audio -> Bool -> m ()+setMute (Audio e) = setAttr e "muted" . falseAsEmpty++-- | Is the given audio object muted?+isMute :: MonadIO m => Audio -> m Bool+isMute (Audio e) = liftIO $ maybe False id . fromJSString <$> getProp e "muted"++-- | Mute/unmute.+toggleMute :: MonadIO m => Audio -> m ()+toggleMute a = isMute a >>= setMute a . not++-- | Set whether the given sound should loop upon completion or not.+setLooping :: MonadIO m => Audio -> Bool -> m ()+setLooping (Audio e) = setAttr e "loop" . falseAsEmpty++-- | Is the given audio object looping?+isLooping :: MonadIO m => Audio -> m Bool+isLooping (Audio e) =+  liftIO $ maybe False id . fromJSString <$> getProp e "looping"++-- | Toggle looping on/off.+toggleLooping :: MonadIO m => Audio -> m ()+toggleLooping a = isLooping a >>= setLooping a . not++-- | Starts playing audio from the given element.+play :: MonadIO m => Audio -> m ()+play a@(Audio e) = do+    st <- getState a+    when (st == Ended) $ seek a Start+    liftIO $ play' e+  where+    play' :: Elem -> IO ()+    play' = ffi "(function(x){x.play();})"++-- | Get the current state of the given audio object.+getState :: MonadIO m => Audio -> m AudioState+getState (Audio e) = liftIO $ do+  ended <- maybe False id . fromJSString <$> getProp e "ended"+  if ended+    then return Ended+    else maybe Playing paused . fromJSString <$> getProp e "paused"+  where+    paused True = Paused+    paused _    = Playing++-- | Pause the given audio element.+pause :: MonadIO m => Audio -> m ()+pause (Audio e) = liftIO $ pause' e++pause' :: Elem -> IO ()+pause' = ffi "(function(x){x.pause();})"++-- | If playing, stop. Otherwise, start playing.+togglePlaying :: MonadIO m => Audio -> m ()+togglePlaying a = do+  st <- getState a+  case st of+    Playing    -> pause a+    Ended      -> seek a Start >> play a+    Paused     -> play a++-- | Stop playing a track, and seek back to its beginning.+stop :: MonadIO m => Audio -> m ()+stop a = pause a >> seek a Start++-- | Get the volume for the given audio element as a value between 0 and 1.+getVolume :: MonadIO m => Audio -> m Double+getVolume (Audio e) = liftIO $ maybe 0 id . fromJSString <$> getProp e "volume"++-- | Set the volume for the given audio element. The value will be clamped to+--   [0, 1].+setVolume :: MonadIO m => Audio -> Double -> m ()+setVolume (Audio e) = setProp e "volume" . toJSString . clamp++-- | Modify the volume for the given audio element. The resulting volume will+--   be clamped to [0, 1].+modVolume :: MonadIO m => Audio -> Double -> m ()+modVolume a diff = getVolume a >>= setVolume a . (+ diff)++-- | Clamp a value to [0, 1].+clamp :: Double -> Double+clamp = max 0 . min 1++-- | Seek to the specified time.+seek :: MonadIO m => Audio -> Seek -> m ()+seek a@(Audio e) st = liftIO $ do+    case st of+      Start     -> seek' e 0+      End       -> getDuration a >>= seek' e+      Seconds s -> seek' e s+  where+    seek' :: Elem -> Double -> IO ()+    seek' = ffi "(function(e,t) {e.currentTime = t;})"++-- | Get the duration of the loaded sound, in seconds.+getDuration :: MonadIO m => Audio -> m Double+getDuration (Audio e) = do+  dur <- getProp e "duration"+  case fromJSString dur of+    Just d -> return d+    _      -> return 0++-- | Get the current play time of the loaded sound, in seconds.+getCurrentTime :: MonadIO m => Audio -> m Double+getCurrentTime (Audio e) = do+  dur <- getProp e "currentTime"+  case fromJSString dur of+    Just d -> return d+    _      -> return 0++-- | Set the source of the given audio element.+setSource :: MonadIO m => Audio -> AudioSource -> m ()+setSource (Audio e) (AudioSource _ url) = setProp e "src" (toJSString url)
+ src/Haste/Audio/Events.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies, OverloadedStrings #-}+-- | Audio related events.+module Haste.Audio.Events where+import Haste.Events.Core++data AudioEvent+  = AudioEnded       -- ^ Audio playback ended.+  | AudioError       -- ^ There was some kind of error.+  | AudioPaused      -- ^ Audio paused.+  | AudioResumed     -- ^ Resumed playing after pause.+  | AudioPlaying     -- ^ Audio started playing, initially or after pause.+  | AudioSeekBegins  -- ^ Seek operation starts.+  | AudioSeekEnds    -- ^ Seek operation completes.+  | AudioTimeUpdate  -- ^ Audio object't current time changed.+  | AudioProgress    -- ^ Progress was made downloading audio.+  | AudioStalled     -- ^ Audio download stalled.+  | AudioLoadStart   -- ^ Start downloading audio.+  | AudioLoadSuspend -- ^ Finished or paused downloading audio.++instance Event AudioEvent where+  type EventData AudioEvent = ()+  eventName AudioEnded       = "ended"+  eventName AudioError       = "error"+  eventName AudioPaused      = "pause"+  eventName AudioResumed     = "play"+  eventName AudioPlaying     = "playing"+  eventName AudioSeekBegins  = "seeking"+  eventName AudioSeekEnds    = "seeked"+  eventName AudioTimeUpdate  = "timeupdate"+  eventName AudioProgress    = "progress"+  eventName AudioStalled     = "stalled"+  eventName AudioLoadStart   = "loadstart"+  eventName AudioLoadSuspend = "suspend"+  eventData _ _ = return ()
+ src/Haste/Binary.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings,+             TypeSynonymInstances , FlexibleInstances,+             GeneralizedNewtypeDeriving, BangPatterns, TypeOperators,+             KindSignatures, DefaultSignatures, FlexibleInstances,+             TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables,+             TupleSections #-}+-- | Handling of Javascript-native binary blobs.+--+-- Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3)+module Haste.Binary+  ( -- * High level binary API+    MonadConc, Binary (..), Blob, BlobData, encode, decode, decodeBlob+  , module Haste.Binary.Put+  , module Haste.Binary.Get+  , Word8, Word16, Word32, Word64+  , Int8, Int16, Int32, Int64++    -- * Working with raw blobs+  , Ix, ArrView+  , getBlobData, getBlobText', getBlobText+  , blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob+  , toUArray, fromUArray+  ) where+import Data.Array.Unboxed+import Data.Bits+import Data.Char+import Data.Int+import Data.Word+import GHC.Fingerprint.Type+import GHC.Generics+import qualified Haste.JSString as J (length)+import Haste.Prim+import Haste.Concurrent+import Haste.Prim.Foreign hiding (get)+import Haste.Binary.Types+import Haste.Binary.Put+import Haste.Binary.Get+#ifndef __HASTE__+import qualified Data.ByteString.Lazy.Char8 as BS (unpack)+#endif++-- | Retrieve the raw data from a blob.+getBlobData  :: MonadConc m => Blob -> m BlobData+-- | Interpret a blob as UTF-8 text, as a JSString.+getBlobText' :: MonadConc m => Blob -> m JSString++#ifdef __HASTE__+getBlobData b = liftCIO $ do+    res <- newEmptyMVar+    liftIO $ convertBlob b (mkBlobData res (blobSize b))+    takeMVar res+  where+    mkBlobData res len x = concurrent $ do+      putMVar res (BlobData 0 len x)++    convertBlob :: Blob -> (JSAny -> IO ()) -> IO ()+    convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){cb(new DataView(r.result));};r.readAsArrayBuffer(b);})"++getBlobText' b = liftCIO $ do+    res <- newEmptyMVar+    liftIO $ convertBlob b (concurrent . putMVar res)+    takeMVar res+  where+    convertBlob :: Blob -> (JSString -> IO ()) -> IO ()+    convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){cb(r.result);};r.readAsText(b);})"+#else+getBlobData (Blob b) = return (BlobData b)+getBlobText' (Blob b) = return . toJSStr $ BS.unpack b+#endif+++-- | Interpret a blob as UTF-8 text.+getBlobText :: MonadConc m => Blob -> m String+getBlobText b = getBlobText' b >>= return . fromJSStr++-- | Somewhat efficient serialization/deserialization to/from binary Blobs.+--   The layout of the binaries produced/read by get/put and encode/decode may+--   change between versions. If you need a stable binary format, you should+--   make your own using the primitives in Haste.Binary.Get/Put.+class Binary a where+  get :: Get a+  put :: a -> Put++  default put :: (Generic a, GBinary (Rep a)) => a -> Put+  put = gput . from++  default get :: (Generic a, GBinary (Rep a)) => Get a+  get = to `fmap` gget++-- | Generic version+class GBinary f where+    gput :: f t -> Put+    gget :: Get (f t)++instance Binary Bool where+  put True = putWord8 1+  put _    = putWord8 0+  get = do+    n <- getWord8+    case n of+      0 -> pure False+      1 -> pure True+      _ -> fail $ "Not a valid Bool: " ++ show n++instance Binary Word8 where+  put = putWord8+  get = getWord8++instance Binary Word16 where+  put = putWord16le+  get = getWord16le++instance Binary Word32 where+  put = putWord32le+  get = getWord32le++instance Binary Word64 where+  get = do+    lo <- get :: Get Word32+    hi <- get :: Get Word32+    return $ fromIntegral lo .|. shiftL (fromIntegral hi) 32+  put x = do+    put (fromIntegral x :: Word32)+    put (fromIntegral (shiftR x 32) :: Word32)++instance Binary Int8 where+  put = putInt8+  get = getInt8++instance Binary Int16 where+  put = putInt16le+  get = getInt16le++instance Binary Int32 where+  put = putInt32le+  get = getInt32le++instance Binary Int64 where+  get = do+    lo <- get :: Get Int32+    hi <- get :: Get Int32+    return $ fromIntegral lo .|. shiftL (fromIntegral hi) 32+  put x = do+    put (fromIntegral x :: Int32)+    put (fromIntegral (shiftR x 32) :: Int32)++instance Binary Int where+  put = putInt32le . fromIntegral+  get = fromIntegral <$> getInt32le++instance Binary Float where+  put = putFloat32le+  get = getFloat32le++instance Binary Double where+  put = putFloat64le+  get = getFloat64le++instance Binary Fingerprint where+  get = Fingerprint <$> get <*> get+  put (Fingerprint a b) = put a >> put b++instance (Binary a, Binary b) => Binary (a, b) where+  put (a, b) = put a >> put b+  get = (,) <$> get <*> get+instance (Binary a, Binary b, Binary c) => Binary (a, b, c) where+  put (a, b, c) = put a >> put b >> put c+  get = (,,) <$> get <*> get <*> get+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) where+  put (a, b, c, d) = put a >> put b >> put c >> put d+  get = (,,,) <$> get <*> get <*> get <*> get+instance (Binary a, Binary b, Binary c, Binary d, Binary e)+         => Binary (a, b, c, d, e) where+  put (a, b, c, d, e) = put a >> put b >> put c >> put d >> put e+  get = (,,,,) <$> get <*> get <*> get <*> get <*> get+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)+         => Binary (a, b, c, d, e, f) where+  put (a, b, c, d, e, f) = put a >> put b >> put c >> put d >> put e >> put f+  get = (,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)+         => Binary (a, b, c, d, e, f, g) where+  put (a, b, c, d, e, f, g) = put a>>put b>>put c>>put d>>put e>>put f>>put g+  get = (,,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get <*> get++instance Binary a => Binary (Maybe a) where+  put (Just x) = putWord8 1 >> put x+  put _        = putWord8 0+  get = do+    tag <- getWord8+    case tag of+      0 -> return Nothing+      1 -> Just <$> get+      _ -> fail "Wrong constructor tag when reading Maybe value!"++instance (Binary a, Binary b) => Binary (Either a b) where+  put (Left x)  = putWord8 0 >> put x+  put (Right x) = putWord8 1 >> put x+  get = do+    tag <- getWord8+    case tag of+      0 -> Left <$> get+      1 -> Right <$> get+      _ -> fail "Wrong constructor tag when reading Either value!"++instance Binary () where+  put _ = return ()+  get = return ()++instance Binary a => Binary [a] where+  put xs = do+    putWord32le (fromIntegral $ length xs)+    mapM_ put xs+  get = getWord32le >>= getMany++instance Binary JSString where+  {-# NOINLINE put #-}+  put s = do+    putWord32le $ fromIntegral $ J.length s+    putJSString s+  {-# NOINLINE get #-}+  get = get >>= getJSString+    +instance Binary Blob where+  {-# NOINLINE put #-}+  put b = do+    put (blobSize b)+    putBlob b+  {-# NOINLINE get #-}+  get = do+    sz <- get+    bd <- getBytes sz+    return $ toBlob bd++instance Binary Char where+  put = put . ord+  get = get >>= \x ->+    case chr x of+      !x' -> return x'++-- Borrowed from the @binary@ package.+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where+  put a = do+    put (bounds a)+    put (rangeSize $ bounds a)+    mapM_ put (elems a)+  get = do+    bs <- get+    n  <- get+    xs <- getMany n+    return (listArray bs xs)++-- | 'getMany n' get 'n' elements in order, without blowing the stack.+{-# INLINE getMany #-}+getMany :: Binary a => Word32 -> Get [a]+getMany n = go [] n+ where+    go xs 0 = return $! reverse xs+    go xs i = do x <- get+                 -- we must seq x to avoid stack overflows due to laziness in+                 -- (>>=)+                 x `seq` go (x:xs) (i-1)++-- | Encode any serializable data into a 'Blob'.+encode :: Binary a => a -> Blob+encode x = runPut (put x)++-- | Decode any deserializable data from a 'BlobData'.+decode :: Binary a => BlobData -> Either JSString a+decode = runGet get++-- | Decode a 'Blob' into some deserializable value, inconveniently locked up+--   inside the 'CIO' monad (or any other concurrent monad) due to the somewhat+--   special way JavaScript uses to deal with binary data.+decodeBlob :: (MonadConc m, Binary a) => Blob -> m (Either JSString a)+decodeBlob b = getBlobData b >>= return . decode++-- Type without constructors+instance GBinary V1 where+    gput _ = return ()+    gget   = return undefined++-- Constructor without arguments+instance GBinary U1 where+    gput U1 = return ()+    gget    = return U1++-- Product: constructor with parameters+instance (GBinary a, GBinary b) => GBinary (a :*: b) where+    gput (x :*: y) = gput x >> gput y+    gget = (:*:) <$> gget <*> gget++-- Metadata (constructor name, etc)+instance GBinary a => GBinary (M1 i c a) where+    gput = gput . unM1+    gget = M1 <$> gget++-- Constants, additional parameters, and rank-1 recursion+instance Binary a => GBinary (K1 i a) where+    gput = put . unK1+    gget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.+--+-- NB: changed to 2^32-1 constructors++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++instance ( GSum     a, GSum     b+         , GBinary a, GBinary b+         , SumSize    a, SumSize    b) => GBinary (a :+: b) where+    gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) --  | PUTSUM(Word64)+         | otherwise = sizeError "encode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word32)+    {-# INLINE gput #-}++    gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) --  | GETSUM(Word64)+         | otherwise = sizeError "decode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word32)+    {-# INLINE gget #-}++sizeError :: Show size => String -> size -> error+sizeError s size =+    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++checkGetSum :: (Ord word, Num word, Bits word, GSum f)+            => word -> word -> Get (f a)+checkGetSum size code | code < size = getSum code size+                      | otherwise   = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSum f where+    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where+    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL+                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE getSum #-}++    putSum !code !size s = case s of+                             L1 x -> putSum code           sizeL x+                             R1 x -> putSum (code + sizeL) sizeR x+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE putSum #-}++instance GBinary a => GSum (C1 c a) where+    getSum _ _ = gget+    {-# INLINE getSum #-}++    putSum !code _ x = put code *> gput x+    {-# INLINE putSum #-}++------------------------------------------------------------------------++class SumSize f where+    sumSize :: Tagged f Word32++newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word32) ++                       unTagged (sumSize :: Tagged b Word32)++instance SumSize (C1 c a) where+    sumSize = Tagged 1
+ src/Haste/Binary/Get.hs view
@@ -0,0 +1,179 @@+{-# Language CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-}+module Haste.Binary.Get (+    Get,+    getWord8, getWord16le, getWord32le,+    getInt8, getInt16le, getInt32le,+    getFloat32le, getFloat64le,+    getBytes, getJSString, skip,+    runGet+  ) where+import Data.Int+import Data.Word+import Haste.Prim+import Haste.Binary.Types+import Control.Monad+import System.IO.Unsafe+import qualified Control.Exception as Ex+#ifdef __HASTE__+import Haste.Prim.Foreign hiding (get)+#else+import Data.Char (chr)+import qualified Data.Binary as B+import qualified Data.Binary.IEEE754 as BI+import qualified Data.Binary.Get as BG+#endif++#ifdef __HASTE__+data Result a = Ok !Int !a | Fail !JSString+data Get a = Get {unG :: JSAny -> Int -> Result a}++instance Functor Get where+  fmap f (Get m) = Get $ \buf next ->+    case m buf next of+      Ok next' x -> Ok next' (f x)+      Fail s     -> Fail s++instance Applicative Get where+  (<*>) = ap+  pure  = return++instance Monad Get where+  return x = Get $ \_ next -> Ok next x+  (Get m) >>= f = Get $ \buf next ->+    case m buf next of+      Ok next' x -> unG (f x) buf next'+      Fail e     -> Fail e+  fail s = Get $ \_ _ -> Fail (toJSStr s)++getW8 :: JSAny -> Int -> IO Word8+getW8 = ffi "(function(b,i){return b.getUint8(i);})"++getWord8 :: Get Word8+getWord8 =+  Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getW8 buf next)++getW16le :: JSAny -> Int -> IO Word16+getW16le = ffi "(function(b,i){return b.getUint16(i,true);})"++getWord16le :: Get Word16+getWord16le =+  Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getW16le buf next)++getW32le :: JSAny -> Int -> IO Word32+getW32le = ffi "(function(b,i){return b.getUint32(i,true);})"++getWord32le :: Get Word32+getWord32le =+  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getW32le buf next)++getI8 :: JSAny -> Int -> IO Int8+getI8 = ffi "(function(b,i){return b.getInt8(i);})"++getInt8 :: Get Int8+getInt8 =+  Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getI8 buf next)++getI16le :: JSAny -> Int -> IO Int16+getI16le = ffi "(function(b,i){return b.getInt16(i,true);})"++getInt16le :: Get Int16+getInt16le =+  Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getI16le buf next)++getI32le :: JSAny -> Int -> IO Int32+getI32le = ffi "(function(b,i){return b.getInt32(i,true);})"++getInt32le :: Get Int32+getInt32le =+  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getI32le buf next)++getF32le :: JSAny -> Int -> IO Float+getF32le = ffi "(function(b,i){return b.getFloat32(i,true);})"++getFloat32le :: Get Float+getFloat32le =+  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getF32le buf next)++getF64le :: JSAny -> Int -> IO Double+getF64le = ffi "(function(b,i){return b.getFloat64(i,true);})"++getFloat64le :: Get Double+getFloat64le =+  Get $ \buf next -> Ok (next+8) (unsafePerformIO $ getF64le buf next)++getBytes :: Int -> Get BlobData+getBytes len = Get $ \buf next -> Ok (next+len) (BlobData next len buf)++-- | Read a 'JSString' of @n@ characters. Encoding is assumed to be UTF-16.+getJSString :: Word32 -> Get JSString+getJSString len = Get $ \buf next ->+  Ok (next+fromIntegral (len+len)) (unsafePerformIO $ getJSS buf next len)++getJSS :: JSAny -> Int -> Word32 -> IO JSString+getJSS = ffi "(function(b,off,len){return String.fromCharCode.apply(null,new Uint16Array(b.buffer,off,len));})"++-- | Skip n bytes of input.+skip :: Int -> Get ()+skip len = Get $ \_buf next -> Ok (next+len) ()++-- | Run a Get computation.+runGet :: Get a -> BlobData -> Either JSString a+runGet (Get p) (BlobData off len bd) = do+  let res = unsafePerformIO $ do+        Ex.catch (pure $! p bd off)+                 (\(JSException e) -> pure (Fail e))+  case res of+    Ok consumed x+      | consumed <= len -> Right x+      | otherwise       -> Left "Not enough data!"+    Fail s              -> Left s++#else++newtype Get a = Get (BG.Get a) deriving (Functor, Applicative, Monad)++runGet :: Get a -> BlobData -> Either JSString a+runGet (Get g) (BlobData bd) = unsafePerformIO $ do+  Ex.catch (Right <$> (return $! BG.runGet g bd)) mEx++mEx :: Ex.SomeException -> IO (Either JSString a)+mEx ex = return . Left $ toJSStr $ show ex++getWord8 :: Get Word8+getWord8 = Get BG.getWord8++getWord16le :: Get Word16+getWord16le = Get BG.getWord16le++getWord32le :: Get Word32+getWord32le = Get BG.getWord32le++getInt8 :: Get Int8+getInt8 = Get B.get++getInt16le :: Get Int16+getInt16le = fromIntegral <$> getWord16le++getInt32le :: Get Int32+getInt32le = fromIntegral <$> getWord32le++getFloat32le :: Get Float+getFloat32le = Get BI.getFloat32le++getFloat64le :: Get Double+getFloat64le = Get BI.getFloat64le++getBytes :: Int -> Get BlobData+getBytes len = Get $ do+  bs <- BG.getLazyByteString (fromIntegral len)+  return (BlobData bs)++getJSString :: Int -> Get JSString+getJSString len = Get $ do+  toJSStr `fmap` forM [1..len] (\_ -> fmap (chr . fromIntegral) BG.getWord16le)++-- | Skip n bytes of input.+skip :: Int -> Get ()+skip = Get . BG.skip++#endif
+ src/Haste/Binary/Put.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-}+module Haste.Binary.Put (+    Put, PutM,+    putWord8, putWord16le, putWord32le,+    putInt8, putInt16le, putInt32le,+    putFloat32le, putFloat64le,+    putBlob, putJSString,+    runPut+  ) where+import Data.Int+import Data.Word+import Haste.Prim+import Haste.Binary.Types+#ifdef __HASTE__+import Control.Monad+import Haste.Prim.Foreign+import System.IO.Unsafe+#else+import Data.Char (ord)+import qualified Data.Binary as B+import qualified Data.Binary.IEEE754 as BI+import qualified Data.Binary.Put as BP+#endif++type Put = PutM ()++#ifdef __HASTE__+type JSArr = JSAny+newArr :: IO JSArr+newArr = ffi "(function(){return [];})"++push :: JSArr -> JSAny -> IO ()+push = ffi "(function(a,x) {a.push(x);})"++data PutM a = PutM {unP :: JSArr -> IO a}++instance Functor PutM where+  fmap f (PutM m) = PutM $ \a -> fmap f (m a)++instance Applicative PutM where+  (<*>) = ap+  pure  = return++instance Monad PutM where+  return x = PutM $ \_ -> return x+  PutM m >>= f = PutM $ \a -> do+    x <- m a+    unP (f x) a++putWord8 :: Word8 -> Put+putWord8 w = PutM $ \a -> push a (toAB "Uint8Array" 1 w)++putWord16le :: Word16 -> Put+putWord16le w = PutM $ \a -> push a (toAB "Uint16Array" 2 w)++putWord32le :: Word32 -> Put+putWord32le w = PutM $ \a -> push a (toAB "Uint32Array" 4 w)++putInt8 :: Int8 -> Put+putInt8 i = PutM $ \a -> push a (toAB "Int8Array" 1 i)++putInt16le :: Int16 -> Put+putInt16le i = PutM $ \a -> push a (toAB "Int16Array" 2 i)++putInt32le :: Int32 -> Put+putInt32le i = PutM $ \a -> push a (toAB "Int32Array" 4 i)++putFloat32le :: Float -> Put+putFloat32le f = PutM $ \a -> push a (unsafePerformIO $ f2ab f)++f2ab :: Float -> IO JSAny+f2ab = ffi "(function(f) {var a=new ArrayBuffer(4);new DataView(a).setFloat32(0,f,true);return a;})"++putFloat64le :: Double -> Put+putFloat64le f = PutM $ \a -> push a (unsafePerformIO $ d2ab f)++d2ab :: Double -> IO JSAny+d2ab = ffi "(function(f) {var a=new ArrayBuffer(8);new DataView(a).setFloat64(0,f,true);return a;})"++-- | Write a Blob verbatim into the output stream.+putBlob :: Blob -> Put+putBlob b = PutM $ \a -> push a (toAny b)++toAB :: ToAny a => JSString -> Int -> a -> JSAny+toAB view size el = unsafePerformIO $ toABle view size (toAny el)++toABle :: ToAny a => JSString -> Int -> a -> IO JSAny+toABle s n x = jsToABle s n (toAny x)++jsToABle :: JSString -> Int -> JSAny -> IO JSAny+jsToABle = ffi "window['toABle']"++-- | Serialize a 'JSString' as UTF-16 (somewhat) efficiently.+putJSString :: JSString -> Put+putJSString s = PutM $ \a -> push a (unsafePerformIO $ str2ab s)++str2ab :: JSString -> IO JSAny+str2ab = ffi "(function(s) {\+  var l = s.length;\+  var v = new Uint16Array(new ArrayBuffer(l*2));\+  for (var i=0; i<l; ++i) {\+    v[i]=s.charCodeAt(i);\+  }\+  return v.buffer;})"++-- | Run a Put computation.+runPut :: Put -> Blob+runPut (PutM putEverything) = unsafePerformIO $ do+    a <- newArr+    putEverything a+    jsGetBlob a++jsGetBlob :: JSArr -> IO Blob+jsGetBlob = ffi "(function(parts){return new Blob(parts);})"++#else++newtype PutM a = PutM (BP.PutM a) deriving (Functor, Applicative, Monad)++runPut :: Put -> Blob+runPut (PutM p) = Blob (BP.runPut p)++putWord8 :: Word8 -> Put+putWord8 = PutM . BP.putWord8++putWord16le :: Word16 -> Put+putWord16le = PutM . BP.putWord16le++putWord32le :: Word32 -> Put+putWord32le = PutM . BP.putWord32le++putInt8 :: Int8 -> Put+putInt8 = PutM . B.put++putInt16le :: Int16 -> Put+putInt16le = putWord16le . fromIntegral++putInt32le :: Int32 -> Put+putInt32le = putWord32le . fromIntegral++putFloat32le :: Float -> Put+putFloat32le = PutM . BI.putFloat32le++putFloat64le :: Double -> Put+putFloat64le = PutM . BI.putFloat64le++putBlob :: Blob -> Put+putBlob (Blob b) = PutM $ BP.putLazyByteString b++-- | Serialize a 'JSString' as UTF-16 (somewhat) efficiently.+putJSString :: JSString -> Put+putJSString = mapM_ (putWord16le . fromIntegral . ord) . fromJSStr++#endif
+ src/Haste/Binary/Types.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}+module Haste.Binary.Types (+    Ix, ArrView, Blob (..), BlobData (..),+    blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob,+    toUArray, fromUArray+  ) where+import Haste.Prim+import Haste.Prim.Foreign+import Haste.Foreign.Array+import qualified Data.ByteString.Lazy as BS+import Data.Array.Unboxed+#ifndef __HASTE__+import qualified Data.ByteString.UTF8 as BU+#else+import System.IO.Unsafe+#endif++#ifdef __HASTE__+-- | In a browser context, BlobData is essentially a DataView, with an+--   accompanying offset and length for fast slicing.+--   In a server context, it is simply a 'BS.ByteString'.+data BlobData = BlobData Int Int JSAny++-- | A JavaScript Blob on the client, a 'BS.ByteString' on the server.+newtype Blob = Blob JSAny deriving (ToAny, FromAny)++-- | The size, in bytes, of the contents of the given blob.+blobSize :: Blob -> Int+blobSize = unsafePerformIO . ffi "(function(b){return b.size;})"++-- | The size, in bytes, of the contents of the given blob data.+blobDataSize :: BlobData -> Int+blobDataSize (BlobData _ len _) = len++-- | Convert a 'BlobData' to an unboxed array; client-side only.+toUArray :: (Ix i, ArrView e) => BlobData -> UArray i e+toUArray (BlobData from to buf) = unsafePerformIO $ toUArray' from to buf++-- | Convert a an unboxed array into a 'Blob'; client-side only.+fromUArray :: (Ix i, ArrView e) => UArray i e -> Blob+fromUArray = unsafePerformIO . fromUArray'++fromUArray' :: (Ix i, ArrView e) => UArray i e -> IO Blob+fromUArray' = ffi "(function(arr){return new Blob([arr]);})"++toUArray' :: (Ix i, ArrView e) => Int -> Int -> JSAny -> IO (UArray i e)+toUArray' = ffi "(function(from, to, buf){return new Uint8Array(buf.buffer.slice(from, to+from));})"++-- | Convert a BlobData to a ByteString. Only usable server-side.+toByteString :: BlobData -> BS.ByteString+toByteString =+  error "Haste.Binary.Types.toByteString called in browser context!"++-- | Convert a ByteString to a BlobData. Only usable server-side.+fromByteString :: BS.ByteString -> BlobData+fromByteString =+  error "Haste.Binary.Types.toByteString called in browser context!"++-- | Convert a piece of BlobData back into a Blob.+toBlob :: BlobData -> Blob+toBlob (BlobData 0 len buf) =+  case newBlob buf of+    b | blobSize b > len -> sliceBlob b 0 len+      | otherwise        -> b+toBlob (BlobData off len buf) =+  sliceBlob (newBlob buf) off (off+len)++-- | Create a Blob from a JSString.+strToBlob :: JSString -> Blob+strToBlob = newBlob . toAny++sliceBlob :: Blob -> Int -> Int -> Blob+sliceBlob b off len = unsafePerformIO $ jsSlice b off len++jsSlice :: Blob -> Int -> Int -> IO Blob+jsSlice = ffi "(function(b,off,len){return b.slice(off,len);})"++newBlob :: JSAny -> Blob+newBlob = unsafePerformIO . jsNewBlob++jsNewBlob :: JSAny -> IO Blob+jsNewBlob =+  ffi "(function(b){try {return new Blob([b]);} catch (e) {return new Blob([b.buffer]);}})"+#else++-- | In a browser context, BlobData is essentially a DataView, with an+--   accompanying offset and length for fast slicing.+--   In a server context, it is simply a 'BS.ByteString'.+newtype BlobData = BlobData BS.ByteString++-- | A JavaScript Blob on the client, a 'BS.ByteString' on the server.+newtype Blob = Blob BS.ByteString++-- Never used except for type checking+clientOnly :: a+clientOnly = error "ToAny/FromAny only usable client-side!"+instance ToAny BlobData where toAny = clientOnly+instance FromAny BlobData where fromAny = clientOnly+instance ToAny Blob where toAny = clientOnly+instance FromAny Blob where fromAny = clientOnly++-- | Convert a 'BlobData' to an unboxed array; client-side only.+toUArray :: (Ix i, ArrView e) => BlobData -> UArray i e+toUArray _ = error "toUArray only usable client-side!"++-- | Convert a an unboxed array into a 'Blob'; client-side only.+fromUArray :: (Ix i, ArrView e) => UArray i e -> Blob+fromUArray = error "fromUArray only usable client-side!"++-- | The size, in bytes, of the contents of the given blob.+blobSize :: Blob -> Int+blobSize (Blob b) = fromIntegral $ BS.length b++-- | The size, in bytes, of the contents of the given blob data.+blobDataSize :: BlobData -> Int+blobDataSize (BlobData bd) = fromIntegral $ BS.length bd++-- | Convert a BlobData to a ByteString. Only usable server-side.+toByteString :: BlobData -> BS.ByteString+toByteString (BlobData bd) = bd++-- | Convert a ByteString to a BlobData. Only usable server-side.+fromByteString :: BS.ByteString -> BlobData+fromByteString = BlobData++-- | Convert a piece of BlobData back into a Blob.+toBlob :: BlobData -> Blob+toBlob (BlobData bs) = Blob bs++-- | Create a Blob from a JSString.+strToBlob :: JSString -> Blob+strToBlob s = Blob $ BS.fromChunks [BU.fromString $ fromJSStr s]++#endif
+ src/Haste/Concurrent.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies,+             EmptyDataDecls #-}+-- | Concurrency for Haste. Includes MVars, forking, Ajax and more.+module Haste.Concurrent (+    module Haste.Concurrent.Monad,+    wait, withResult+  ) where+import Haste.Concurrent.Monad+import Haste.Timer++-- | Wait for n milliseconds.+wait :: Int -> CIO ()+wait ms = do+  v <- newEmptyMVar+  _ <- liftIO $ setTimer (Once ms) $ concurrent $ putMVar v ()+  takeMVar v++-- | When the given concurrent computation is done, pass the result to the+--   given callback.+withResult :: CIO a -> (a -> IO ()) -> IO ()+withResult m f = concurrent $ m >>= liftIO . f
+ src/Haste/Concurrent/Monad.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances, FlexibleContexts, CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Implements concurrency for Haste based on "A Poor Man's Concurrency Monad".+module Haste.Concurrent.Monad (+    MVar, CIO, MonadConc (..),+    forkIO, forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, withMVarIO,+    modifyMVarIO, readMVar, concurrent, liftIO,+    tryTakeMVar, tryPutMVar+  ) where+import Control.Monad.IO.Class+import Control.Monad+import Data.IORef+import Haste.Events.Core (MonadEvent (..))++#ifndef __HASTE__++-- Running native: proper concurrency++import qualified Control.Concurrent as CC++-- | Concurrent IO monad. The normal IO monad does not have concurrency+--   capabilities with Haste. This monad is basically IO plus concurrency.+newtype CIO a = CIO (IO a)+  deriving (Functor, Applicative, Monad, MonadIO)++newtype MVar a = MVar {unV :: CC.MVar a}++-- | Run a concurrent computation. Two different concurrent computations may+--   share MVars; if this is the case, then a call to `concurrent` may return+--   before all the threads it spawned finish executing.+concurrent :: CIO () -> IO ()+concurrent (CIO m) = m++-- | Spawn a new thread.+forkIO :: CIO () -> CIO ()+forkIO (CIO m) = CIO $ void $ CC.forkIO m++-- | Spawn several threads at once.+forkMany :: [CIO ()] -> CIO ()+forkMany = mapM_ forkIO++-- | Create a new MVar with an initial value.+newMVar :: MonadIO m => a -> m (MVar a)+newMVar = fmap MVar . liftIO . CC.newMVar++-- | Create a new empty MVar.+newEmptyMVar :: MonadIO m => m (MVar a)+newEmptyMVar = MVar <$> liftIO CC.newEmptyMVar++-- | Read an MVar. Blocks if the MVar is empty.+--   Only the first writer in the write queue, if any, is woken.+takeMVar :: MonadConc m => MVar a -> m a+takeMVar = liftIO . CC.takeMVar . unV++-- | Try to take a value from an MVar, but return @Nothing@ if it is empty.+tryTakeMVar :: MonadConc m => MVar a -> m (Maybe a)+tryTakeMVar = liftIO . CC.tryTakeMVar . unV++-- | Write an MVar. Blocks if the MVar is already full.+--   Only the first reader in the read queue, if any, is woken.+putMVar :: MonadConc m => MVar a -> a -> m ()+putMVar (MVar v) x = liftIO $ CC.putMVar v x++-- | Try to put a value into an MVar, returning @False@ if the MVar is already+--   full.+tryPutMVar :: MonadConc m => MVar a -> a -> m Bool+tryPutMVar (MVar v) x = liftIO $ CC.tryPutMVar v x+#else++-- Running in Haste: poor man's concurrency+-- See native version for docs.++data MV a+  = Full a [(a, CIO ())] -- A full MVar: a queue of writers+  | Empty  [a -> CIO ()] -- An empty MVar: a queue of readers+newtype MVar a = MVar (IORef (MV a))++data Action where+  Atom :: IO Action -> Action+  Fork :: [Action] -> Action+  Stop :: Action++newtype CIO a = C {unC :: (a -> Action) -> Action}++instance Monad CIO where+  return x    = C $ \next -> next x+  (C m) >>= f = C $ \b -> m (\a -> unC (f a) b)++instance Functor CIO where+  fmap f m = do+    x <- m+    return $ f x++instance Applicative CIO where+  (<*>) = ap+  pure  = return++instance MonadIO CIO where+  liftIO m = C $ \next -> Atom (fmap next m)++callCC f = C $ \next -> unC (f (\a -> C $ \_ -> next a)) next++forkIO :: CIO () -> CIO ()+forkIO (C m) = C $ \next -> Fork [next (), m (const Stop)]++forkMany :: [CIO ()] -> CIO ()+forkMany ms = C $ \next -> Fork (next () : [act (const Stop) | C act <- ms])++newMVar :: MonadIO m => a -> m (MVar a)+newMVar a = liftIO $ MVar `fmap` newIORef (Full a [])++newEmptyMVar :: MonadIO m => m (MVar a)+newEmptyMVar = liftIO $ MVar `fmap` newIORef (Empty [])++takeMVar :: MonadConc m => MVar a -> m a+takeMVar (MVar ref) = liftCIO $ do+  callCC $ \next -> join $ liftIO $ do+    v <- readIORef ref+    case v of+      Full x ((x',w):ws) -> do+        writeIORef ref (Full x' ws)+        return $ forkIO w >> return x+      Full x _ -> do+        writeIORef ref (Empty [])+        return $ return x+      Empty rs -> do+        writeIORef ref (Empty (rs ++ [next]))+        return $ C (const Stop)++tryTakeMVar :: MonadConc m => MVar a -> m (Maybe a)+tryTakeMVar (MVar ref) = liftCIO $ do+  join $ liftIO $ do+    v <- readIORef ref+    case v of+      Full x ((x',w):ws) -> do+        writeIORef ref (Full x' ws)+        return $ forkIO w >> return (Just x)+      Full x _ -> do+        writeIORef ref (Empty [])+        return $ return (Just x)+      Empty rs -> do+        return $ return Nothing++putMVar :: MonadConc m => MVar a -> a -> m ()+putMVar (MVar ref) x = liftCIO $ do+  callCC $ \next -> join $ liftIO $ do+    v <- readIORef ref+    case v of+      Full oldx ws -> do+        writeIORef ref (Full oldx (ws ++ [(x, next ())]))+        return $ C (const Stop)+      Empty (r:rs) -> do+        writeIORef ref (Empty rs)+        return $ forkIO (r x)+      Empty _ -> do+        writeIORef ref (Full x [])+        return $ return ()++tryPutMVar :: MonadConc m => MVar a -> a -> m Bool+tryPutMVar (MVar ref) x = liftCIO $ do+  join $ liftIO $ do+    v <- readIORef ref+    case v of+      Full oldx ws -> do+        return $ return False+      Empty (r:rs) -> do+        writeIORef ref (Empty rs)+        return $ forkIO (r x) >> return True+      Empty _ -> do+        writeIORef ref (Full x [])+        return $ return True++concurrent :: CIO () -> IO ()+concurrent (C m) = scheduler [m (const Stop)]+  where+    scheduler (p:ps) =+      case p of+        Atom io -> do+          next <- io+          scheduler (ps ++ [next])+        Fork ps' -> do+          scheduler (ps ++ ps')+        Stop -> do+          scheduler ps+    scheduler _ =+      return ()+#endif++-- | Any monad which supports concurrency.+class MonadIO m => MonadConc m where+  liftCIO :: CIO a -> m a+  fork    :: m () -> m ()++instance MonadConc CIO where+  liftCIO = id+  fork = forkIO++instance MonadEvent CIO where+  mkHandler = return . fmap concurrent++-- | Read an MVar then put it back. As Javascript is single threaded, this+--   function is atomic. If this ever changes, this function will only be+--   atomic as long as no other thread attempts to write to the MVar.+readMVar :: MonadConc m => MVar a -> m a+readMVar m = do+  x <- takeMVar m+  putMVar m x+  return x++-- | Perform an IO action over an MVar.+withMVarIO :: MonadConc m => MVar a -> (a -> IO b) -> m b+withMVarIO v m = takeMVar v >>= liftIO . m++-- | Perform an IO action over an MVar, then write the MVar back.+modifyMVarIO :: MonadConc m => MVar a -> (a -> IO (a, b)) -> m b+modifyMVarIO v m = do+  (x, res) <- withMVarIO v m+  putMVar v x+  return res
+ src/Haste/Crypto.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module Haste.Crypto+  ( MonadConc (..), MonadIO (..), Binary (..), ArrView (..)+  , Word8, Word16, Word32, Word64+    -- * Crypto-strength random number generation+  , CryptoRandom (..)+  , cryptoRandomSalt+  , cryptoRandomUArray+  , cryptoRandomIOUArray++    -- * SubtleCrypto API. Presently only supports symmetric encryption, due to+    --   lack of browser support for other components.+  , Cipher (..), CipherMode (..), KeyLength (..), SymmetricKey, IV (..)+  , Salt (..), Password+  , generateKey, generateIV, keyFromBytes, getKeyBytes, deriveKey, keyCipher+  , encrypt, decrypt+  , encryptWithIV, decryptWithIV+  , encryptUArray, decryptUArray+  ) where+import Control.Monad+import Control.Monad.IO.Class+import Haste+import Haste.Binary+import Haste.Concurrent+import Haste.Foreign (toAny, fromAny)+import Data.Word+import Data.Int+import Data.Array.IO+import Data.Array.Unboxed+import System.IO.Unsafe++import Haste.Crypto.Types+import Haste.Crypto.Prim++-- crypto.getRandomBytes bindings++class CryptoRandom a where+  -- | Generate an element of type @a@ using the browser's crypto strength+  --   random bit generator.+  cryptoRandom :: MonadIO m => m a++  -- | Generate @n@ random elements of type @a@.+  cryptoRandoms :: MonadIO m => Word32 -> m [a]+  cryptoRandoms n = mapM (const cryptoRandom) [1..n]++instance ArrView a => CryptoRandom a where+  cryptoRandom = randomPrimitive+  cryptoRandoms = cryptoRandomIOUArray >=> liftIO . getElems++-- | Generate a random immutable array of @n@ elements.+cryptoRandomUArray :: (MonadIO m, ArrView a) => Word32 -> m (UArray Word32 a)+cryptoRandomUArray = cryptoRandomIOUArray >=> liftIO . unsafeFreeze++-- | Generate a random mutable array of @n@ elements.+cryptoRandomIOUArray :: (MonadIO m, ArrView a) => Word32 -> m (IOUArray Word32 a)+cryptoRandomIOUArray n = liftIO $ do+  a <- newArray_ (0, n-1)+  randomBits a+  return a++-- | Generate a random salt of the given length.+{-# INLINE cryptoRandomSalt #-}+cryptoRandomSalt :: MonadIO m => Word32 -> m Salt+cryptoRandomSalt = fmap Salt . cryptoRandomUArray++-- | Generate a random primitive using @window.crypto@.+randomPrimitive :: (MonadIO m, ArrView a) => m a+randomPrimitive = cryptoRandomIOUArray 1 >>= liftIO . flip readArray 0++-- | Freeze a mutable array into an immutable one. Only safe if the source+--   array is guaranteed to never be mutated post-freeze.+unsafeFreeze :: (Ix i, ArrView e) => IOUArray i e -> IO (UArray i e)+unsafeFreeze = pure . toAny >=> fromAny++++-- Partial SubtleCrypto bindings++-- | Generate a key for the given cipher.+generateKey :: MonadConc m => Cipher -> m SymmetricKey+generateKey = promise . generateKey'++-- | Get the specified key as an unboxed byte array.+--   Only the bytes of the key itself are returned; exported keys do not+--   include information about which cipher they are for.+getKeyBytes :: MonadConc m => SymmetricKey -> m (UArray Word32 Word8)+getKeyBytes = promise . keyBytes'++-- | Import a key from an unboxed byte array.+keyFromBytes :: MonadConc m => Cipher -> UArray Word32 Word8 -> m (Either JSString SymmetricKey)+keyFromBytes c k = promiseE $ keyFromBytes' c k++-- | Encrypt a message using the given cipher, key and initialization vector.+encryptUArray :: (Ix i, ArrView e, MonadConc m)+        => SymmetricKey -> IV -> UArray i e -> m (UArray Word32 Word8)+encryptUArray k iv msg = promise (encrypt' k iv msg)++-- | Encrypt a message using the given cipher, key and initialization vector.+decryptUArray :: (Ix i, ArrView e, MonadConc m)+        => SymmetricKey -> IV -> UArray i e -> m (Either JSString (UArray Word32 Word8))+decryptUArray k iv msg = promiseE $ decrypt' k iv msg++-- | Encrypt a message using a custom initialization vector. The IV will+--   not be prepended to the output.+encryptWithIV :: (Binary a, MonadConc m)+              => IV+              -> SymmetricKey+              -> a+              -> m Blob+encryptWithIV iv k val = do+  msg <- getBlobData $ encode val+  fromUArray <$> encryptUArray k iv (toUArray msg :: UArray Word32 Word8)++-- | Decrypt a message using a custom initialization vector.+decryptWithIV :: (Binary a, MonadConc m)+              => IV+              -> SymmetricKey+              -> Blob+              -> m (Either JSString a)+decryptWithIV iv k blob = do+  msg <- getBlobData blob+  emsg' <- decryptUArray k iv (toUArray msg :: UArray Word32 Word8)+  case emsg' of+    Left err   -> return $ Left err+    Right msg' -> do+      eres <- decodeBlob $ fromUArray msg'+      case eres of+        Right res -> return $ Right res+        Left err  -> return $ Left $ toJSString err++-- | Generate an byte initialization vector of appropriate length for the+--   given cipher.+generateIV :: MonadIO m => Cipher -> m IV+generateIV = fmap IV . cryptoRandomUArray . ivLength++-- | The default initialization vector length for the available ciphers.+ivLength :: Cipher -> Word32+ivLength (AES CBC Bits128) = 16+ivLength (AES CBC Bits256) = 32+ivLength (AES GCM _)       = 12++-- | Encrypt and encrypt a 'Binary' value using a random initialization vector.+--   The IV will be prepended to the message; when using GCM mode, the IV will+--   be 12 bytes, otherwise it will match the length of the key.+--+--   An unboxed array can be obtained from the+--   resulting 'Blob':+--+--       toUArray <$> getBlobData blob+encrypt :: (Binary a, MonadConc m)+        => SymmetricKey+        -> a+        -> m Blob+encrypt k msg = do+  iv <- generateIV (keyCipher k)+  msg' <- encryptWithIV iv k msg+  let derp = runPut (putBlob (fromUArray (ivBytes iv)) >> putBlob msg')+  return derp++-- | Decrypt and decode a 'Binary' value from a 'Blob'. The initialization+--   vector will be read from the beginning of the message; see 'encrypt' for+--   information about IV lengths.+--   A blob can be obtained from an unboxed array using 'fromUArray'.+decrypt :: (Binary a, MonadConc m)+        => SymmetricKey+        -> Blob+       -> m (Either JSString a)+decrypt k blob = do+  bd <- getBlobData blob+  case (getIV bd, getMsg bd) of+    (Left e, _)           -> return $ Left $ catJSStr "" ["couldn't read IV: ", e]+    (_, Left e)           -> return $ Left $ catJSStr "" ["couldn't read data: ", e]+    (Right iv, Right msg) -> do+      emsg' <- decryptUArray k (IV $ toUArray iv) (toUArray msg :: UArray Word32 Word8)+      case emsg' of+        Left err   -> return $ Left $ catJSStr "" ["decryption failed: ", err]+        Right msg' -> do+          eres <- decodeBlob $ fromUArray msg'+          case eres of+            Left err  -> return $ Left $ catJSStr "" ["couldn't parse value: ", err]+            Right res -> return $ Right res+  where+    ivLen = fromIntegral $ ivLength (keyCipher k)+    getIV = runGet $ getBytes ivLen+    getMsg = runGet $ skip ivLen >> getBytes (blobSize blob - ivLen)++-- | Derive a key from the given password and salt, using the PBKDF2 key+--   derivation over SHA-256, with the given number of iterations.+--+--   One million iterations take roughly half a second on a modern laptop.+--   Returns @Nothing@ on browsers where the operation is not supported.+--   Presently not supported by IE/Edge.+deriveKey :: MonadConc m => Cipher -> Int -> Salt -> Password -> m (Maybe SymmetricKey)+deriveKey c n s pass = promise $ deriveKey' c s n (encodeUtf8 pass)++encodeUtf8 :: JSString -> UArray Word32 Word8+encodeUtf8 = unsafePerformIO . encodeUtf8'
+ src/Haste/Crypto/Prim.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+module Haste.Crypto.Prim where+import Haste+import Haste.Foreign+import Haste.Crypto.Types+import Data.Array.Unboxed+import Data.Array.IO+import Data.Word+import Haste.Concurrent++-- | Fill the given array with random bits, using the browser's @window.crypto@+--   object.+randomBits :: ArrView e => IOUArray Word32 e -> IO ()+randomBits = ffi "(function(arr){window['__haste_crypto'].getRandomValues(arr);})"++-- | Wait for a promise to either complete or get rejected. Promises used with+--   this function should not get rejected unless there is a bug in this very+--   library.+--   Promises that may fail for normal reasons should not use this function.+promise :: MonadConc m+        => ((a -> IO ()) -> (JSString -> IO ()) -> IO ())+        -> m a+promise f = liftCIO $ do+  res <- promiseE f+  case res of+    Right x -> return x+    Left e  -> error ("promise rejected: " ++ fromJSStr e)++-- | A promise that might fail.+promiseE :: MonadConc m+        => ((a -> IO ()) -> (JSString -> IO ()) -> IO ())+        -> m (Either JSString a)+promiseE f = liftCIO $ do+  v <- newEmptyMVar+  liftIO $ f (concurrent . putMVar v . Right) (concurrent . putMVar v . Left)+  takeMVar v++generateKey' :: Cipher -> (SymmetricKey -> IO ()) -> (JSString -> IO ()) -> IO ()+generateKey' = ffi "(function(c, yay, nay) {\+  \window['__haste_crypto'].subtle.generateKey(c, true, ['encrypt','decrypt'])\+  \.then(function(k) {yay({key: k, cipher: c});})\+  \.catch(nay);\+  \})"++encrypt' :: (Ix i, ArrView e)+         => SymmetricKey -> IV -> UArray i e+         -> (UArray Word32 Word8 -> IO ())+         -> (JSString -> IO ())+         -> IO ()+encrypt' = ffi "(function(k, iv, data, yay, nay) {\+  \k.cipher.iv = iv;\+  \window['__haste_crypto'].subtle.encrypt(k.cipher, k.key, data)\+  \.then(function(enc){yay(new Uint8Array(enc));})\+  \.catch(nay);\+  \})"++decrypt' :: (Ix i, ArrView e)+         => SymmetricKey -> IV -> UArray i e+         -> (UArray Word32 Word8 -> IO ())+         -> (JSString -> IO ())+         -> IO ()+decrypt' = ffi "(function(k, iv, data, yay, nay) {\+  \k.cipher.iv = iv;\+  \window['__haste_crypto'].subtle.decrypt(k.cipher, k.key, data)\+  \.then(function(dec){yay(new Uint8Array(dec));})\+  \.catch(nay);\+  \})"++keyBytes' :: SymmetricKey+          -> (UArray Word32 Word8 -> IO ())+          -> (JSString -> IO ())+          -> IO ()+keyBytes' = ffi "(function(k, yay, nay){\+  \window['__haste_crypto'].subtle.exportKey('raw', k.key)\+  \.then(function(dec){yay(new Uint8Array(dec));})\+  \.catch(nay);\+  \})"++keyFromBytes' :: Cipher+              -> UArray Word32 Word8+              -> (SymmetricKey -> IO ())+              -> (JSString -> IO ())+              -> IO ()+keyFromBytes' = ffi "(function(alg, k, yay, nay){\+  \window['__haste_crypto'].subtle.importKey('raw', k, alg, true, ['encrypt', 'decrypt'])\+  \.then(function(k) {yay({key: k, cipher: alg});})\+  \.catch(nay);\+  \})"++deriveKey' :: Cipher -> Salt -> Int -> UArray Word32 Word8 -> (Maybe SymmetricKey -> IO ()) -> (JSString -> IO ()) -> IO ()+deriveKey' = ffi "(function(alg, s, n, k, yay, nay){\+  \window['__haste_crypto'].subtle.importKey('raw', k, {name:'PBKDF2'}, false, ['deriveKey']).then(function(mk) {\+  \window['__haste_crypto'].subtle.deriveKey({name:'PBKDF2',salt:s,iterations:n,hash:'SHA-256'}, mk, alg, true, ['encrypt', 'decrypt']).then(function(k){yay({key: k, cipher: alg});}).catch(function(_){yay(null);});\+  \});})"++encodeUtf8' :: JSString -> IO (UArray Word32 Word8)+encodeUtf8' = ffi "(function(s){\+  \s = unescape(encodeURIComponent(s));\+  \var arr = new Uint8Array(s.length);\+  \for(var i = 0 ; i < s.length; ++i) {\+  \  arr[i] = s.charCodeAt(i);\+  \}\+  \return arr;\+  \})"
+ src/Haste/Crypto/Types.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+module Haste.Crypto.Types where+import Haste (JSString, JSType (..))+import Haste.Binary as B+import Haste.Foreign as F+import Data.Array.Unboxed+import Data.Word++-- | Denotes a block cipher mode. As only CBC and GCM are universally supported+--   by browsers, these are presently the only modes exported by Haste.+--   If unsure, always use @GCM@.+data CipherMode = CBC | GCM+  deriving (Show, Read, Eq, Ord)++data KeyLength = Bits128 | Bits256+  deriving (Show, Read, Eq, Ord)++data Cipher = AES CipherMode KeyLength+  deriving (Show, Read, Eq, Ord)++-- | A key for a symmetric cipher.+data SymmetricKey = SymmetricKey JSAny Cipher++keyCipher :: SymmetricKey -> Cipher+keyCipher (SymmetricKey _ c) = c++instance ToAny SymmetricKey where+  toAny (SymmetricKey k c) = toObject [("key", k), ("cipher", toAny c)]++instance FromAny SymmetricKey where+  fromAny x = SymmetricKey <$> F.get x "key" <*> F.get x "cipher"++newtype IV = IV {ivBytes :: UArray Word32 Word8}+  deriving (ToAny, FromAny, Binary)++newtype Salt = Salt {saltBytes :: UArray Word32 Word8}+  deriving (ToAny, FromAny, Binary)++type Password = JSString++instance Binary CipherMode where+  put CBC = putWord8 0+  put GCM = putWord8 1+  get = do+    n <- getWord8+    case n of+      0 -> pure CBC+      1 -> pure GCM+      _ -> fail "Cipher mode was neither CBC nor GCM"++instance Binary KeyLength where+  put Bits128 = putWord8 0+  put Bits256 = putWord8 1+  get = do+    n <- getWord8+    case n of+      0 -> pure Bits128+      1 -> pure Bits256+      _ -> fail "Key length was neither 128 nor 256 bits"++instance Binary Cipher where+  put (AES mode len) = putWord8 0 >> put mode >> put len+  get = do+    n <- getWord8+    case n of+      0 -> AES <$> B.get <*> B.get+      _ -> fail "Invalid cipher"++instance ToAny CipherMode where+  toAny = toAny . toJSString++instance ToAny KeyLength where+  toAny = toAny . toJSString++instance FromAny CipherMode where+  fromAny x = do+    s <- fromAny x+    maybe (fail "Unable to read CipherMode") return (fromJSString s)++instance FromAny KeyLength where+  fromAny x = do+    s <- fromAny x+    maybe (fail "Unable to read KeyLength") return (fromJSString s)++instance JSType KeyLength where+  toJSString Bits128 = "128"+  toJSString Bits256 = "256"+  fromJSString "128" = Just Bits128+  fromJSString "256" = Just Bits256+  fromJSString _     = Nothing++instance ToAny Cipher where+  toAny (AES mode len) = toObject+    [ ("name", toAny mode)+    , ("length", toAny len)+    ]++instance FromAny Cipher where+  fromAny x = AES <$> F.get x "name" <*> F.get x "length"++instance JSType CipherMode where+  toJSString CBC = "AES-CBC"+  toJSString GCM = "AES-GCM"++  fromJSString "AES-CBC" = Just CBC+  fromJSString "AES-GCM" = Just GCM+  fromJSString _         = Nothing
+ src/Haste/DOM.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE GADTs #-}+-- | DOM manipulation functions using 'String' for string representation.+module Haste.DOM (+    -- * Basic types and elements+    IsElem (..), Elem (..),+    document, documentBody, documentHead,++    -- * Adding and removing child elements+    appendChild, insertChildBefore,  setChildren, clearChildren, deleteChild,++    -- * Selecting child elements+    getFirstChild, getLastChild, getChildren,++    -- * Creating elements+    newElem, newTextElem,++    -- * Setting attributes on elements+    Attribute, AttrValue, AttrName (..),+    attribute, set, with, children,+    prop, style, attr, (=:),++    -- * Selecting elements+    QuerySelector, ElemID,+    elemById, elemsByQS, elemsByClass,+    withElem , withElems, withElemsQS, mapQS, mapQS_,++    -- * Properties and attributes+    PropID,+    setProp, unsetProp, getProp, setAttr, unsetAttr, getAttr, J.getValue,++    -- * Style sheets and classes+    ElemClass, getStyle, setStyle, setClass, toggleClass, hasClass,+    addStylesheet,++    -- * Triggering events+    click, focus, blur,++    -- * File elements+    J.getFileData, getFileName,+  ) where+import qualified Haste.DOM.JSString as J+import Haste.DOM.Core+import Haste.Prim (fromJSStr, toJSStr)+import Control.Monad.IO.Class++type PropID = String+type ElemID = String+type QuerySelector = String+type ElemClass = String+type AttrValue = String++-- | Create a style attribute name.+style :: String -> AttrName+style = StyleName . toJSStr++-- | Create an HTML attribute name.+attr :: String -> AttrName+attr = AttrName . toJSStr++-- | Create a DOM property name.+--   See <http://stackoverflow.com/questions/6003819/properties-and-attributes-in-html> for more information about the difference between attributes and properties.+prop :: String -> AttrName+prop = PropName . toJSStr++-- | Create an 'Attribute'.+(=:) :: AttrName -> AttrValue -> Attribute+name =: val = attribute name (toJSStr val)++-- | Create an element.+newElem :: MonadIO m => String -> m Elem+newElem = J.newElem . toJSStr++-- | Create a text node.+newTextElem :: MonadIO m => String -> m Elem+newTextElem = J.newTextElem . toJSStr++-- | Set a property of the given element.+setProp :: (IsElem e, MonadIO m) => e -> PropID -> String -> m ()+setProp e property val = J.setProp e (toJSStr property) (toJSStr val)++-- | Unset a property of the given element. Primarily useful with boolean+--   properties.+unsetProp :: (IsElem e, MonadIO m) => e -> PropID -> m ()+unsetProp e property = J.unsetProp e (toJSStr property)++-- | Set an attribute of the given element.+setAttr :: (IsElem e, MonadIO m) => e -> PropID -> String -> m ()+setAttr e property val = J.setAttr e (toJSStr property) (toJSStr val)++-- | Unset an attribute of the given element. Primarily useful with boolean+--   attributes.+unsetAttr :: (IsElem e, MonadIO m) => e -> PropID -> m ()+unsetAttr e property = J.unsetAttr e (toJSStr property)++-- | Get a property of an element.+getProp :: (IsElem e, MonadIO m) => e -> PropID -> m String+getProp e property = J.getProp e (toJSStr property) >>= return . fromJSStr++-- | Get an attribute of an element.+getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m String+getAttr e property = J.getAttr e (toJSStr property) >>= return . fromJSStr++-- | Get a CSS style property of an element.+getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m String+getStyle e property = J.getStyle e (toJSStr property) >>= return . fromJSStr++-- | Set a CSS style property on an element.+setStyle :: (IsElem e, MonadIO m) => e -> PropID -> String -> m ()+setStyle e property val = J.setStyle e (toJSStr property) (toJSStr val)++-- | Get an element by its HTML ID attribute.+elemById :: MonadIO m => ElemID -> m (Maybe Elem)+elemById = J.elemById . toJSStr++-- | Get all elements of the given class.+elemsByClass :: MonadIO m => ElemClass -> m [Elem]+elemsByClass = J.elemsByClass . toJSStr++-- | Get all children elements matching a query selector.+elemsByQS :: MonadIO m => Elem -> QuerySelector -> m [Elem]+elemsByQS el = J.elemsByQS el . toJSStr++-- | Perform an IO action on an element.+withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a+withElem = J.withElem . toJSStr++-- | Perform an IO action over several elements. Throws an error if some of the+--   elements are not found.+withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a+withElems = J.withElems . map toJSStr++-- | Perform an IO action over the a list of elements matching a query+--   selector.+withElemsQS :: (IsElem e, MonadIO m)+            => e+            -> QuerySelector+            -> ([Elem] -> m a)+            -> m a+withElemsQS el = J.withElemsQS el . toJSStr++-- | Map an IO computation over the list of elements matching a query selector.+mapQS :: (IsElem e, MonadIO m)+      => e+      -> QuerySelector+      -> (Elem -> m a)+      -> m [a]+mapQS el = J.mapQS el . toJSStr++-- | Like @mapQS@ but returns no value.+mapQS_ :: (IsElem e, MonadIO m)+       => e+       -> QuerySelector+       -> (Elem -> m a)+       -> m ()+mapQS_ el = J.mapQS_ el . toJSStr++-- | Get the name of the currently selected file from a file input element.+--   Any directory information is stripped, and only the actual file name is+--   returned, as the directory information is useless (and faked) anyway.+getFileName :: (IsElem e, MonadIO m) => e -> m String+getFileName e = J.getFileName e >>= return . fromJSStr++-- | Add or remove a class from an element's class list.+setClass :: (IsElem e, MonadIO m) => e -> String -> Bool -> m ()+setClass e sel = J.setClass e (toJSStr sel)++-- | Toggle the existence of a class within an elements class list.+toggleClass :: (IsElem e, MonadIO m) => e -> String -> m ()+toggleClass e = J.toggleClass e . toJSStr++-- | Does the given element have a particular class?+hasClass :: (IsElem e, MonadIO m) => e -> String -> m Bool+hasClass e = J.hasClass e . toJSStr++-- | Append the stylesheet at the given URL to @document.head@.+addStylesheet :: MonadIO m => String -> m ()+addStylesheet = J.addStylesheet . toJSStr
+ src/Haste/DOM/Core.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}+-- | Core types and operations for DOM manipulation.+module Haste.DOM.Core (+    Elem (..), IsElem (..), Attribute, AttrName (..),+    set, with, attribute, children,+    click, focus, blur,+    document, documentBody, documentHead,+    deleteChild, clearChildren,+    setChildren, getChildren,+    getLastChild, getFirstChild, getChildBefore,+    insertChildBefore, appendChild,+    -- Low level stuff+    jsSet, jsSetAttr, jsSetStyle, jsUnset, jsUnsetAttr,+  ) where+import Haste.Prim+import Control.Monad.IO.Class+import Haste.Prim.Foreign+import Data.String++jsSet :: Elem -> JSString -> JSString -> IO ()+jsSet = ffi "(function(e,p,v){e[p] = v;})"++jsUnset :: Elem -> JSString -> IO ()+jsUnset = ffi "(function(e,p){delete e[p];})"++jsSetAttr :: Elem -> JSString -> JSString -> IO ()+jsSetAttr = ffi "(function(e,p,v){e.setAttribute(p, v);})"++jsUnsetAttr :: Elem -> JSString -> IO ()+jsUnsetAttr = ffi "(function(e,p){e.removeAttribute(p);})"++jsSetStyle :: Elem -> JSString -> JSString -> IO ()+jsSetStyle = ffi "(function(e,p,v){e.style[p] = v;})"++jsAppendChild :: Elem -> Elem -> IO ()+jsAppendChild = ffi "(function(c,p){p.appendChild(c);})"++jsGetFirstChild :: Elem -> IO (Maybe Elem)+jsGetFirstChild = ffi "(function(e){\+for(e = e.firstChild; e != null; e = e.nextSibling)\+  {if(e instanceof HTMLElement) {return e;}}\+return null;})"++jsGetLastChild :: Elem -> IO (Maybe Elem)+jsGetLastChild = ffi "(function(e){\+for(e = e.lastChild; e != null; e = e.previousSibling)\+  {if(e instanceof HTMLElement) {return e;}}\+return null;})"++jsGetChildren :: Elem -> IO [Elem]+jsGetChildren = ffi "(function(e){\+var ch = [];\+for(e = e.firstChild; e != null; e = e.nextSibling)\+  {if(e instanceof HTMLElement) {ch.push(e);}}\+return ch;})"++jsSetChildren :: Elem -> [Elem] -> IO ()+jsSetChildren = ffi "(function(e,ch){\+while(e.firstChild) {e.removeChild(e.firstChild);}\+for(var i in ch) {e.appendChild(ch[i]);}})"++jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()+jsAddChildBefore = ffi "(function(c,p,a){p.insertBefore(c,a);})"++jsGetChildBefore :: Elem -> IO (Maybe Elem)+jsGetChildBefore = ffi "(function(e){\+for(; e != null; e = e.previousSibling)\+  {if(e instanceof HTMLElement) {return e;}\+return null;})"++jsKillChild :: Elem -> Elem -> IO ()+jsKillChild = ffi "(function(c,p){p.removeChild(c);})"++jsClearChildren :: Elem -> IO ()+jsClearChildren = ffi "(function(e){\+while(e.firstChild){e.removeChild(e.firstChild);}})"++-- | A DOM node.+newtype Elem = Elem JSAny+  deriving (ToAny, FromAny)++-- | The class of types backed by DOM elements.+class IsElem a where+  -- | Get the element representing the object.+  elemOf :: a -> Elem++  -- | Attempt to create a DOM element backed object from an 'Elem'.+  --   The default instance always returns @Nothing@.+  fromElem :: MonadIO m => Elem -> m (Maybe a)+  fromElem = const $ return Nothing++instance IsElem Elem where+  elemOf = id+  fromElem = return . Just++-- | The name of an attribute. May be either a common property, an HTML+--   attribute or a style attribute.+data AttrName+  = PropName  !JSString+  | StyleName !JSString+  | AttrName  !JSString+  deriving (Eq, Ord)++instance IsString AttrName where+  fromString = PropName . fromString++-- | A key/value pair representing the value of an attribute.+--   May represent a property, an HTML attribute, a style attribute or a list+--   of child elements.+data Attribute+  = Attribute !AttrName !JSString+  | Children ![Elem]++-- | Construct an 'Attribute'.+attribute :: AttrName -> JSString -> Attribute+attribute = Attribute++-- | Set a number of 'Attribute's on an element.+set :: (IsElem e, MonadIO m) => e -> [Attribute] -> m ()+set e as =+    liftIO $ mapM_ set' as+  where+    e' = elemOf e+    set' (Attribute (PropName k) v)  = jsSet e' k v+    set' (Attribute (StyleName k) v) = jsSetStyle e' k v+    set' (Attribute (AttrName k) v)  = jsSetAttr e' k v+    set' (Children cs)               = mapM_ (flip jsAppendChild e') cs++-- | Attribute adding a list of child nodes to an element.+children :: [Elem] -> Attribute+children = Children++-- | Set a number of 'Attribute's on the element produced by an IO action.+--   Gives more convenient syntax when creating elements:+--+--   > newElem "div" `with` [+--   >     style "border" =: "1px solid black",+--   >     ...+--   >   ]+--+with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e+with m attrs = do+  x <- m+  set x attrs+  return x++-- | Generate a click event on an element.+click :: (IsElem e, MonadIO m) => e -> m ()+click = liftIO . click' . elemOf++click' :: Elem -> IO ()+click' = ffi "(function(e) {e.click();})"++-- | Generate a focus event on an element.+focus :: (IsElem e, MonadIO m) => e -> m ()+focus = liftIO . focus' . elemOf++focus' :: Elem -> IO ()+focus' = ffi "(function(e) {e.focus();})"++-- | Generate a blur event on an element.+blur :: (IsElem e, MonadIO m) => e -> m ()+blur = liftIO . blur' . elemOf++blur' :: Elem -> IO ()+blur' = ffi "(function(e) {e.blur();})"++-- | The DOM node corresponding to @document@.+document :: Elem+document = constant "document"++-- | The DOM node corresponding to @document.body@.+documentBody :: Elem+documentBody = constant "document.body"++-- | The DOM node corresponding to @document.head@.+documentHead :: Elem+documentHead = constant "document.body"++-- | Append the second element as a child of the first.+appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()+appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent)++-- | Insert an element into a container, before another element.+--   For instance:+-- @+--   insertChildBefore theContainer olderChild childToAdd+-- @+insertChildBefore :: (IsElem parent, IsElem before, IsElem child, MonadIO m)+               => parent -> before -> child -> m ()+insertChildBefore parent oldChild child =+  liftIO $ jsAddChildBefore (elemOf child) (elemOf parent) (elemOf oldChild)++-- | Get the sibling before the given one, if any.+getChildBefore :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)+getChildBefore e = liftIO $ jsGetChildBefore (elemOf e)++-- | Get the first of an element's children.+getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)+getFirstChild e = liftIO $ jsGetFirstChild (elemOf e)++-- | Get the last of an element's children.+getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)+getLastChild e = liftIO $ jsGetLastChild (elemOf e)++-- | Get a list of all children belonging to a certain element.+getChildren :: (IsElem e, MonadIO m) => e -> m [Elem]+getChildren e = liftIO $ jsGetChildren (elemOf e)++-- | Clear the given element's list of children, and append all given children+--   to it.+setChildren :: (IsElem parent, IsElem child, MonadIO m)+            => parent+            -> [child]+            -> m ()+setChildren e ch = liftIO $ jsSetChildren (elemOf e) (map elemOf ch)++-- | Remove all children from the given element.+clearChildren :: (IsElem e, MonadIO m) => e -> m ()+clearChildren = liftIO . jsClearChildren . elemOf++-- | Remove the second element from the first's children.+deleteChild :: (IsElem parent, IsElem child, MonadIO m)+            => parent+            -> child+            -> m ()+deleteChild parent child = liftIO $ jsKillChild (elemOf child) (elemOf parent)
+ src/Haste/DOM/JSString.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE OverloadedStrings #-}+-- | DOM manipulation functions using 'JSString' for string representation.+module Haste.DOM.JSString (+    -- * Basic types and elements+    IsElem (..), Elem (..),+    document, documentBody, documentHead,++    -- * Adding and removing child elements+    appendChild, insertChildBefore,  setChildren, clearChildren, deleteChild,++    -- * Selecting child elements+    getFirstChild, getLastChild, getChildren,++    -- * Creating elements+    newElem, newTextElem,++    -- * Setting attributes on elements+    Attribute, AttrValue, AttrName (..),+    attribute, set, with, children,+    prop, style, attr, (=:),++    -- * Selecting elements+    QuerySelector, ElemID,+    elemById, elemsByQS, elemsByClass,+    withElem , withElems, withElemsQS, mapQS, mapQS_,++    -- * Properties and attributes+    PropID,+    setProp, unsetProp, getProp, setAttr, unsetAttr, getAttr, getValue,++    -- * Style sheets and classes+    ElemClass, getStyle, setStyle, setClass, toggleClass, hasClass,+    addStylesheet,++    -- * Triggering events+    click, focus, blur,++    -- * File elements+    getFileData, getFileName,+  ) where+import Haste.Prim+import Haste.Prim.JSType+import Haste.DOM.Core+import Data.Maybe (isNothing, fromJust)+import Control.Monad.IO.Class+import Haste.Prim.Foreign+import Haste.Binary.Types++type PropID = JSString+type ElemID = JSString+type QuerySelector = JSString+type ElemClass = JSString+type AttrValue = JSString++jsGet :: Elem -> JSString -> IO JSString+jsGet = ffi "(function(e,p){var x = e[p];\+  \return typeof x === 'undefined' ? '' : x.toString();})"++jsGetAttr :: Elem -> JSString -> IO JSString+jsGetAttr = ffi "(function(e,p){\+\return e.hasAttribute(p) ? e.getAttribute(p) : '';})"++jsGetStyle :: Elem -> JSString -> IO JSString+jsGetStyle = ffi "(function(e,p){var x = e.style[p];\+  \return typeof x === 'undefined' ? '' : x.toString();})"++jsFind :: JSString -> IO (Maybe Elem)+jsFind = ffi "(function(id){return document.getElementById(id);})"++jsQuerySelectorAll :: Elem -> JSString -> IO [Elem]+jsQuerySelectorAll = ffi "(function(e,q){\+  \if(!e || typeof e.querySelectorAll !== 'function') {\+    \throw 'querySelectorAll not supported by this element';\+  \} else {\+    \return e.querySelectorAll(q);\+  \}})"++jsElemsByClassName :: JSString -> IO [Elem]+jsElemsByClassName = ffi "(function(c){\+\return document.getElementsByClassName(c);})"++jsCreateElem :: JSString -> IO Elem+jsCreateElem = ffi "(function(t){return document.createElement(t);})"++jsCreateTextNode :: JSString -> IO Elem+jsCreateTextNode = ffi "(function(s){return document.createTextNode(s);})"++-- | Create a style attribute name.+style :: JSString -> AttrName+style = StyleName++-- | Create an HTML attribute name.+attr :: JSString -> AttrName+attr = AttrName++-- | Create a DOM property name.+--   See <http://stackoverflow.com/questions/6003819/properties-and-attributes-in-html> for more information about the difference between attributes and properties.+prop :: JSString -> AttrName+prop = PropName++-- | Create an 'Attribute'.+infixl 4 =:+(=:) :: AttrName -> AttrValue -> Attribute+(=:) = attribute++-- | Create an element.+newElem :: MonadIO m => JSString -> m Elem+newElem = liftIO . jsCreateElem++-- | Create a text node.+newTextElem :: MonadIO m => JSString -> m Elem+newTextElem = liftIO . jsCreateTextNode++-- | Set a property of the given element.+setProp :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()+setProp e property val = liftIO $ jsSet (elemOf e) property val++-- | Unset a property of the given element. Primarily useful with boolean+--   properties.+unsetProp :: (IsElem e, MonadIO m) => e -> PropID -> m ()+unsetProp e property = liftIO $ jsUnset (elemOf e) property++-- | Set an attribute of the given element.+setAttr :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()+setAttr e property val = liftIO $ jsSetAttr (elemOf e) property val++-- | Unset an attribute of the given element. Primarily useful with boolean+--   attributes.+unsetAttr :: (IsElem e, MonadIO m) => e -> PropID -> m ()+unsetAttr e property = liftIO $ jsUnsetAttr (elemOf e) property++-- | Get the value property of an element; a handy shortcut.+getValue :: (IsElem e, MonadIO m, JSType a) => e -> m (Maybe a)+getValue e = liftIO $ fromJSString `fmap` jsGet (elemOf e) "value"++-- | Get a property of an element.+getProp :: (IsElem e, MonadIO m) => e -> PropID -> m JSString+getProp e property = liftIO $ jsGet (elemOf e) property++-- | Get an attribute of an element.+getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m JSString+getAttr e property = liftIO $ jsGetAttr (elemOf e) property++-- | Get a CSS style property of an element.+getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m JSString+getStyle e property = liftIO $ jsGetStyle (elemOf e) property++-- | Set a CSS style property on an element.+setStyle :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()+setStyle e property val = liftIO $ jsSetStyle (elemOf e) property val++-- | Get an element by its HTML ID attribute.+elemById :: MonadIO m => ElemID -> m (Maybe Elem)+elemById eid = liftIO $ jsFind eid++-- | Get all elements of the given class.+elemsByClass :: MonadIO m => ElemClass -> m [Elem]+elemsByClass cls = liftIO $ jsElemsByClassName cls++-- | Get all children elements matching a query selector.+elemsByQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> m [Elem]+elemsByQS el sel = liftIO $ jsQuerySelectorAll (elemOf el) sel++-- | Perform an IO action on an element.+withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a+withElem e act = do+  me' <- elemById e+  case me' of+    Just e' -> act e'+    _       -> error $ "No element with ID " ++ fromJSStr e ++ " found!"++-- | Perform an IO action over several elements. Throws an error if some of the+--   elements are not found.+withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a+withElems es act = do+    mes <- mapM elemById es+    if any isNothing mes+      then error $ "Elements with the following IDs could not be found: "+                 ++ show (findElems es mes)+      else act $ map fromJust mes+  where+    findElems (i:is) (Nothing:mes) = i : findElems is mes+    findElems (_:is) (_:mes)       = findElems is mes+    findElems _ _                  = []++-- | Perform an IO action over the a list of elements matching a query+--   selector.+withElemsQS :: (IsElem e, MonadIO m)+            => e+            -> QuerySelector+            -> ([Elem] -> m a)+            -> m a+withElemsQS el sel act = elemsByQS el sel >>= act++-- | Map an IO computation over the list of elements matching a query selector.+mapQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m [a]+mapQS el sel act = elemsByQS el sel >>= mapM act++-- | Like @mapQS@ but returns no value.+mapQS_ :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m ()+mapQS_ el sel act = elemsByQS el sel >>= mapM_ act++-- | Get a file from a file input element.+getFileData :: (IsElem e, MonadIO m) => e -> Int -> m (Maybe Blob)+getFileData e ix = liftIO $ do+    num <- getFiles (elemOf e)+    if ix < num+      then Just `fmap` getFile (elemOf e) ix+      else return Nothing++getFiles :: Elem -> IO Int+getFiles = ffi "(function(e){return e.files.length;})"++getFile :: Elem -> Int -> IO Blob+getFile = ffi "(function(e,ix){return e.files[ix];})"++-- | Get the name of the currently selected file from a file input element.+--   Any directory information is stripped, and only the actual file name is+--   returned, as the directory information is useless (and faked) anyway.+getFileName :: (IsElem e, MonadIO m) => e -> m JSString+getFileName e = liftIO $ do+    fn <- fromJSStr `fmap` getProp e "value"+    return $ toJSStr $ reverse $ takeWhile (not . separator) $ reverse fn+  where+    separator '/'  = True+    separator '\\' = True+    separator _    = False++-- | Add or remove a class from an element's class list.+setClass :: (IsElem e, MonadIO m) => e -> JSString -> Bool -> m ()+setClass e c x = liftIO $ setc (elemOf e) c x++setc :: Elem -> JSString -> Bool -> IO ()+setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})"++-- | Toggle the existence of a class within an elements class list.+toggleClass :: (IsElem e, MonadIO m) => e -> JSString -> m ()+toggleClass e c = liftIO $ toggc (elemOf e) c++toggc :: Elem -> JSString -> IO ()+toggc = ffi "(function(e,c) {e.classList.toggle(c);})"++-- | Does the given element have a particular class?+hasClass :: (IsElem e, MonadIO m) => e -> JSString -> m Bool+hasClass e c = liftIO $ getc (elemOf e) c++getc :: Elem -> JSString -> IO Bool+getc = ffi "(function(e,c) {return e.classList.contains(c);})"++-- | Append the stylesheet at the given URL to @document.head@.+addStylesheet :: MonadIO m => JSString -> m ()+addStylesheet url = do+  e <- newElem "link" `with` [ "rel" =: "stylesheet", "href" =: url]+  appendChild documentHead e
+ src/Haste/Events.hs view
@@ -0,0 +1,29 @@+-- | Event handling for Haste.+module Haste.Events (+    -- * Core event functionality+    Event (..), MonadEvent (..),+    HandlerInfo,+    unregisterHandler, onEvent, preventDefault, stopPropagation,++    -- * Basic events with no arguments+    BasicEvent (..),++    -- * Keyboard-related events+    KeyEvent (..), KeyData (..), mkKeyData,++    -- * Mouse-related events+    MouseEvent (..), MouseData (..), MouseButton (..),++    -- * Touch-related events+    TouchEvent (..), TouchData (..), Touch (..),++    -- * Messaging events and @postMessage@ API.+    MessageEvent (..), MessageData (..), Window, Recipient (..),+    window, getContentWindow, fromAny+  ) where+import Haste.Events.Core as Core+import Haste.Events.BasicEvents as BasicEvents+import Haste.Events.KeyEvents as KeyEvents+import Haste.Events.MouseEvents as MouseEvents+import Haste.Events.TouchEvents as TouchEvents+import Haste.Events.MessageEvents as MessageEvents
+ src/Haste/Events/BasicEvents.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+-- | Basic events: load, unload, focus, submit, etc.+module Haste.Events.BasicEvents (BasicEvent (..)) where+import Haste.Events.Core++data BasicEvent+  = Load+  | Unload+  | Change+  | Focus+  | Blur+  | Submit+  | Scroll+  | Input++instance Event BasicEvent where+  type EventData BasicEvent = ()+  eventName Load   = "load"+  eventName Unload = "unload"+  eventName Change = "change"+  eventName Focus  = "focus"+  eventName Blur   = "blur"+  eventName Submit = "submit"+  eventName Scroll = "scroll"+  eventName Input  = "input"+  eventData _ _    = return ()
+ src/Haste/Events/Core.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts #-}+-- | Basic framework for event handling.+module Haste.Events.Core (+    Event (..), MonadEvent (..), EventSource (..),+    HandlerInfo,+    unregisterHandler, onEvent, preventDefault, stopPropagation+  ) where+import Haste.Prim+import Haste.DOM.Core+import Haste.Prim.Foreign+import Control.Monad.IO.Class+import Data.IORef+import System.IO.Unsafe++-- | Any type whose underlying DOM object can receive events.+class EventSource a where+  eventSource :: a -> JSAny++instance EventSource Elem where+  eventSource (Elem e) = e++-- | Any monad in which we're able to handle events.+class MonadIO m => MonadEvent m where+  mkHandler :: (a -> m ()) -> m (a -> IO ())++instance MonadEvent IO where+  mkHandler = return++-- | Any type that describes an event.+class Event evt where+  -- | The type of data to pass to handlers for this event.+  type EventData evt++  -- | The name of this event, as expected by the DOM.+  eventName :: evt -> JSString++  -- | Construct event data from the event identifier and the JS event object.+  eventData :: evt -> JSAny -> IO (EventData evt)++-- | Information about an event handler.+data HandlerInfo = HandlerInfo {+    -- | Name of the handler's event.+    handlerEvent :: JSString,+    -- | Element the handler is set on.+    handlerElem  :: JSAny,+    -- | Handle to handler function.+    handlerFun   :: JSAny+  }++-- | Unregister an event handler.+unregisterHandler :: MonadIO m => HandlerInfo -> m ()+unregisterHandler (HandlerInfo ev el f) = liftIO $ unregEvt el ev f++-- | Reference to the event currently being handled.+{-# NOINLINE evtRef #-}+evtRef :: IORef (Maybe JSAny)+evtRef = unsafePerformIO $ newIORef Nothing++{-# INLINE setEvtRef #-}+setEvtRef :: JSAny -> IO ()+setEvtRef = writeIORef evtRef . Just++-- | Prevent the event being handled from resolving normally.+--   Does nothing if called outside an event handler.+preventDefault :: MonadIO m => m ()+preventDefault = liftIO $ readIORef evtRef >>= preventDefault'++preventDefault' :: Maybe JSAny -> IO ()+preventDefault' = ffi "(function(e){if(e){e.preventDefault();}})"++-- | Stop the event being handled from propagating.+--   Does nothing if called outside an event handler.+stopPropagation :: MonadIO m => m ()+stopPropagation = liftIO $ readIORef evtRef >>= stopPropagation'++stopPropagation' :: Maybe JSAny -> IO ()+stopPropagation' = ffi "(function(e){if(e){e.stopPropagation();}})"++-- | Set an event handler on a DOM element.+onEvent :: (MonadEvent m, EventSource el, Event evt)+        => el            -- ^ Element to set handler on.+        -> evt           -- ^ Event to handle.+        -> (EventData evt -> m ()) -- ^ Event handler.+        -> m HandlerInfo -- ^ Information about the handler.+onEvent el evt f = do+  f' <- mkHandler $ \o -> prepareEvent o >>= f+  hdl <- liftIO $ setEvt e name f'+  return $ HandlerInfo {+      handlerEvent = name,+      handlerElem  = e,+      handlerFun   = hdl+    }+  where+    name = eventName evt+    e    = eventSource el+    prepareEvent o = liftIO $ do+      setEvtRef o+      eventData evt o++-- | Set an event handler on an element, returning a reference to the handler+--   exactly as seen by @addEventListener@. We can't reuse the reference to+--   the Haskell function as the FFI does some marshalling to functions,+--   meaning that the same function marshalled twice won't be reference equal+--   to each other.+setEvt :: JSAny -> JSString -> (JSAny -> IO ()) -> IO JSAny+setEvt = ffi "(function(e,name,f){e.addEventListener(name,f,false);\+             \return [f];})"++-- | Unregister an event.+--   Note @f[0]@ and corresponding @[f]@ in 'setEvt'; this is a workaround for+--   a bug causing functions being packed into anything to be accidentally+--   called. Remove when properly fixed.+unregEvt :: JSAny -> JSString -> JSAny -> IO ()+unregEvt = ffi "(function(e,name,f){e.removeEventListener(name,f[0]);})"
+ src/Haste/Events/KeyEvents.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-}+-- | Events relating to keyboard input.+module Haste.Events.KeyEvents (KeyEvent (..), KeyData (..), mkKeyData) where+import Haste.Prim.Any+import Haste.Events.Core++-- | Event data for keyboard events.+data KeyData = KeyData {+    keyCode  :: !Int,+    keyCtrl  :: !Bool,+    keyAlt   :: !Bool,+    keyShift :: !Bool,+    keyMeta  :: !Bool+  } deriving (Show, Eq)++-- | Build a 'KeyData' object for the given key, without any modifier keys+--   pressed.+mkKeyData :: Int -> KeyData+mkKeyData n = KeyData {+    keyCode  = fromIntegral n,+    keyCtrl  = False,+    keyAlt   = False,+    keyShift = False,+    keyMeta  = False+  }++-- | Num instance for 'KeyData' to enable pattern matching against numeric+--   key codes.+instance Num KeyData where+  fromInteger = mkKeyData . fromInteger+  a + b    = a {keyCode = keyCode a  +  keyCode b}+  a * b    = a {keyCode = keyCode a  *  keyCode b}+  a - b    = a {keyCode = keyCode a  -  keyCode b}+  negate a = a {keyCode = negate $ keyCode a}+  signum a = a {keyCode = signum $ keyCode a}+  abs a    = a {keyCode = abs $ keyCode a}++data KeyEvent+  = KeyPress+  | KeyUp+  | KeyDown++instance Event KeyEvent where+  type EventData KeyEvent = KeyData+  eventName KeyPress = "keypress"+  eventName KeyUp    = "keyup"+  eventName KeyDown  = "keydown"+  eventData _ e =+    KeyData <$> get e "keyCode"+            <*> get e "ctrlKey"+            <*> get e "altKey"+            <*> get e "shiftKey"+            <*> get e "metaKey"
+ src/Haste/Events/MessageEvents.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, GeneralizedNewtypeDeriving #-}+-- | Events relating to the @postMessage@ API for passing messages between+--   windows.+module Haste.Events.MessageEvents+  ( MessageEvent (..) , MessageData (..), Recipient (..), Window+  , getContentWindow, window, fromAny+  ) where+import Control.Monad.IO.Class+import Haste.JSString (JSString)+import Haste.Prim.Foreign+import Haste.Events.Core+import Haste.DOM.Core (Elem (..))++-- | A DOM window.+newtype Window = Window JSAny+  deriving (ToAny, FromAny, Eq)++class Recipient a where+  -- | Post a message to the given window. Messages are serialized using the+  --   structured clone algorithm, meaning that you can post pretty much any+  --   type of data, except functions, references and the like.+  postMessage :: (ToAny msg, MonadIO m) => a -> msg -> m ()++instance Recipient Window where+  postMessage wnd msg = liftIO $ postMessage' wnd (toAny msg)++instance EventSource Window where+  eventSource (Window e) = e++-- | The window in which the program is executing.+window :: Window+window = constant "window"++-- | Event data for keyboard events.+data MessageData = MessageData+  { messageData   :: !JSAny+  , messageOrigin :: !JSString+  , messageSource :: !Window+  }++data MessageEvent = Message++instance Event MessageEvent where+  type EventData MessageEvent = MessageData+  eventName Message = "message"+  eventData _ e =+    MessageData <$> get e "data"+                <*> get e "origin"+                <*> get e "source"++postMessage' :: Window -> JSAny -> IO ()+postMessage' = ffi "(function(w,m){w.postMessage(m,'*');})"++-- | Get the window object for an iframe. Must be called after the iframe is+--   attached to the DOM.+getContentWindow :: MonadIO m => Elem -> m (Maybe Window)+getContentWindow e = liftIO $ getContentWindow' e++getContentWindow' :: Elem -> IO (Maybe Window)+getContentWindow' = ffi "(function(e){return e.contentWindow;})"
+ src/Haste/Events/MouseEvents.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, CPP #-}+-- | Events relating to mouse clicks and movement.+module Haste.Events.MouseEvents (+    MouseEvent (..), MouseData (..), MouseButton (..)+  ) where+import Haste.Events.Core+import Haste.Prim.Foreign++data MouseButton = MouseLeft | MouseMiddle | MouseRight+  deriving (Show, Eq, Enum)++instance FromAny MouseButton where+  fromAny = fmap toEnum . fromAny++-- | Event data for mouse events.+data MouseData = MouseData {+    -- | Mouse coordinates.+    mouseCoords      :: !(Int, Int),+    -- | Pressed mouse button, if any.+    mouseButton      :: !(Maybe MouseButton),+    -- | (x, y, z) mouse wheel delta. Always all zeroes except for 'Wheel'.+    mouseWheelDeltas :: !(Double, Double, Double)+  }++data MouseEvent+  = Click+  | DblClick+  | MouseDown+  | MouseUp+  | MouseMove+  | MouseOver+  | MouseOut+  | Wheel++instance Event MouseEvent where+  type EventData MouseEvent = MouseData+  eventName Click     = "click"+  eventName DblClick  = "dblclick"+  eventName MouseDown = "mousedown"+  eventName MouseUp   = "mouseup"+  eventName MouseMove = "mousemove"+  eventName MouseOver = "mouseover"+  eventName MouseOut  = "mouseout"+  eventName Wheel     = "wheel"+  eventData Wheel e =+    MouseData <$> jsGetMouseCoords e+              <*> pure Nothing+              <*> ((,,) <$> (get e "deltaX")+                        <*> (get e "deltaY")+                        <*> (get e "deltaZ"))++  eventData _ e =+    MouseData <$> jsGetMouseCoords e+              <*> get e "button"+              <*> pure (0,0,0)++jsGetMouseCoords :: JSAny -> IO (Int, Int)+jsGetMouseCoords = ffi "jsGetMouseCoords"
+ src/Haste/Events/TouchEvents.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-}+-- | Events relating to touch input.+module Haste.Events.TouchEvents (+    TouchEvent (..), TouchData (..), Touch (..)+  ) where+import Haste.Prim.Any+import Haste.Prim.Foreign+import Haste.Events.Core+import Haste.DOM.Core++data TouchEvent+  = TouchStart+  | TouchMove+  | TouchEnd+  | TouchCancel++-- | Event data for touch events.+data TouchData = TouchData {+    -- | All fingers currently on the screen.+    touches        :: [Touch],++    -- | All fingers on the DOM element receiving the event.+    targetTouches  :: [Touch],++    -- | All fingers involved in the current event. For instance, fingers+    --   removed for the 'TouchEnd' event.+    changedTouches :: [Touch]+  }++-- | A finger touching the screen.+data Touch = Touch {+    -- | Unique identifier for this touch.+    identifier    :: !Int,++    -- | Target element of the touch.+    target        :: !Elem,++    -- | Page coordinates of the touch, including scroll offsets.+    pageCoords    :: !(Int, Int),++    -- | Page coordinates of the touch, excluding scroll offsets.+    clientCoords  :: !(Int, Int),++    -- | Screen coordinates of the touch.+    screenCoords  :: !(Int, Int)+  }++instance FromAny Touch where+  fromAny t =+    Touch <$> get t "identifier"+          <*> get t "target"+          <*> ((,) <$> get t "pageX"   <*> get t "pageY")+          <*> ((,) <$> get t "clientX" <*> get t "clientY")+          <*> ((,) <$> get t "screenX" <*> get t "screenY")++instance Event TouchEvent where+  type EventData TouchEvent = TouchData+  eventName TouchStart  = "touchstart"+  eventName TouchMove   = "touchmove"+  eventName TouchEnd    = "touchend"+  eventName TouchCancel = "touchcancel"++  eventData _ e = do+    ts <- get e "touches"+    (cts, tts) <- getTIDs e+    return $ TouchData {+        touches = ts,+        changedTouches = filter ((`elem` cts) . identifier) ts,+        targetTouches = filter ((`elem` tts) . identifier) ts+      }++-- | Get the touch IDs of all touches for changedTouches and targetTouches.+getTIDs :: JSAny -> IO ([Int], [Int])+getTIDs = ffi "(function(e) {\+  var len = e.changedTouches.length;\+  var chts = new Array(len);\+  for(var i = 0; i < len; ++i) {chts[i] = e.changedTouches[i].identifier;}\+  var len = e.targetTouches.length;\+  var tts = new Array(len);\+  for(var i = 0; i < len; ++i) {tts[i] = e.targetTouches[i].identifier;}\+  return [chts, tts];})"
+ src/Haste/Foreign.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+-- | High level JavaScript foreign interface.+module Haste.Foreign+  ( -- * Conversion to/from JSAny+    ArrView, ToAny (..), FromAny (..), JSAny+  , Opaque, toOpaque, fromOpaque+  , nullValue, toObject, has, get, index, isUndefined+  , getMaybe, hasAll, lookupAny, JSException (..)++    -- * Importing and exporting JavaScript functions+  , FFI, JSFunc+  , ffi, constant, export+  , safe_ffi, StaticPtr+  , withLibraries+  ) where+import Haste.Prim.Foreign+import Haste.Prim (JSString)+import qualified Haste.JSString as J+import Control.Monad (foldM)++-- For withLibraries+import Haste.Concurrent+import Haste.DOM.JSString+import Haste.Events++-- For array instances+import Haste.Foreign.Array (ArrView)++-- | Read a member from a JS object. Succeeds if the member exists.+getMaybe :: FromAny a => JSAny -> JSString -> IO (Maybe a)+getMaybe a k = do exists <- has a k+                  if exists then Just <$> get a k+                    else pure Nothing++-- | Checks if a JS object has a list of members. Succeeds if the JS object+--   has every member given in the list. +hasAll :: JSAny -> [JSString] -> IO Bool+hasAll a ks = and <$> mapM (has a) ks+++-- | Looks up an object by a `.`-separated string. Succeeds if the lowest+--   member exists.+--+-- Usage example:+-- +-- >>> {'child': {'childrer': {'childerest': "I am very much a child."}}}+--+-- Given the JS Object above, we can access the deeply nested object,+--  childerest, by lookupAny as in the below example+--+-- >>> lookupAny jsObject "child.childrer.childerest"+lookupAny :: JSAny -> JSString -> IO (Maybe JSAny)+lookupAny root i = foldM hasGet (Just root) $ J.match dotsplit i+  where hasGet Nothing       _     = pure Nothing+        hasGet (Just parent) ident = do h <- has parent ident+                                        if h then Just <$> get parent ident+                                          else pure Nothing+        dotsplit = J.regex "[^.]+" "g"++-- | Wait for the given libraries to load before executing the given+--   computation. Note that this function returns immediately, BEFORE the given+--   libraries are loaded.+withLibraries :: [JSString] -> IO () -> IO ()+withLibraries libs m = concurrent $ do+    vars <- mapM (const newEmptyMVar) libs+    liftIO . sequence_ $ zipWith addLib libs vars+    mapM_ takeMVar vars+    liftIO m+  where+    addLib lib var = do+      s <- newElem "SCRIPT" `with` ["src" =: lib]+      s `onEvent` Load $ \_ -> concurrent $ putMVar var ()+      appendChild documentBody s
+ src/Haste/Foreign/Array.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Haste.Foreign.Array where+import Data.Array.IO hiding (index)+import Data.Array.Unboxed hiding (index)+import Data.Word+import Data.Int+import System.IO.Unsafe+import Haste.Prim+import Haste.Prim.Foreign++-- Additional instances+iouarrToAny :: JSString -> Opaque (IOUArray i e) -> IO JSAny+iouarrToAny = ffi "(function(v,a){return a.d['v'][v];})"++uarrToAny :: JSString -> Opaque (UArray i e) -> IO JSAny+uarrToAny = ffi "(function(v,a){return new a.d['v'][v].constructor(a.d['v'][v]);})"++anyToIOUArr :: JSAny -> IO (Opaque (IOUArray i e))+anyToIOUArr = ffi "(function(a){\+  \var arr = new ByteArray(a['buffer']);\+  \return new T4(0,0,a['length']-1,a['length'],arr);\+  \})"++anyToUArr :: JSAny -> IO (Opaque (UArray i e))+anyToUArr = ffi "(function(a){\+  \var arr = new ByteArray(new a.constructor(a['buffer']));\+  \return new T4(0,0,a['length']-1,a['length'],arr);\+  \})"++class (IArray UArray a, MArray IOUArray a IO) => ArrView a where+  arrView :: a -> JSString++instance ArrView Double where arrView _ = "f64"+instance ArrView Float  where arrView _ = "f32"+instance ArrView Int    where arrView _ = "i32"+instance ArrView Int8   where arrView _ = "i8"+instance ArrView Int16  where arrView _ = "i16"+instance ArrView Int32  where arrView _ = "i32"+instance ArrView Word   where arrView _ = "w32"+instance ArrView Word8  where arrView _ = "w8"+instance ArrView Word16 where arrView _ = "w16"+instance ArrView Word32 where arrView _ = "w32"++instance ArrView e => FromAny (IOUArray i e) where+  fromAny = fmap fromOpaque . anyToIOUArr++instance forall i e. ArrView e => ToAny (IOUArray i e) where+  toAny = unsafePerformIO . iouarrToAny (arrView (undefined :: e)) . toOpaque++instance (Ix i, ArrView e) => FromAny (UArray i e) where+  fromAny = fmap fromOpaque . anyToUArr++instance forall i e. (Ix i, ArrView e) => ToAny (UArray i e) where+  toAny = unsafePerformIO . uarrToAny (arrView (undefined :: e)) . toOpaque
+ src/Haste/Graphics/AnimationFrame.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+-- | Request and cancel animation frames from the browser.+--   Straightforward bindings to the corresponding DOM interface.+module Haste.Graphics.AnimationFrame (+    FrameRequest, HRTimeStamp,+    requestAnimationFrame,+    cancelAnimationFrame+  ) where+import Haste.Prim.Foreign+import Haste.Performance++-- | Handle to a previously issued request for an animation frame.+--   Only useful together with 'cancelAnimationFrame'.+newtype FrameRequest = FrameRequest JSAny deriving (ToAny, FromAny)++-- | Request a function to be called by the browser before the next repaint.+--   Paints generally happen in tune with the user's monitor refresh rate,+--   which usually means at 60 FPS.+--+--   Do note that you need to request *each* animation callback you plan to+--   use, similar to @setTimeout@ as opposed to @setInterval@, as they are not+--   recurring.+requestAnimationFrame :: (HRTimeStamp -> IO ()) -> IO FrameRequest+requestAnimationFrame = ffi "window.requestAnimationFrame"++-- | Cancel an animation callback previously requested by+--   'requestAnimationFrame'.+cancelAnimationFrame :: FrameRequest -> IO ()+cancelAnimationFrame = ffi "window.cancelAnimationFrame"
+ src/Haste/Graphics/Canvas.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances,+             GADTs, CPP, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+-- | Basic Canvas graphics library.+module Haste.Graphics.Canvas (+    -- * Basic types and classes+    Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),+    Ctx, AnyImageBuffer (..),+    ImageBuffer (..), BitmapSource (..),++    -- *  Obtaining a canvas+    getCanvasById, getCanvas, createCanvas,++    -- * Rendering and reading canvases+    render, renderOnTop, buffer, toDataURL,++    -- * Colors and opacity+    setStrokeColor, setFillColor, color, opacity,++    -- * Matrix operations+    translate, scale, rotate,+    -- * Drawing shapes+    stroke, fill, clip,+    lineWidth, line, path, rect, circle, arc,++    -- * Rendering text+    font, text,++    -- * Extending the library+    withContext+  ) where+import Control.Monad.IO.Class+import Data.Maybe (fromJust)+import Haste+import Haste.DOM.JSString+import Haste.DOM.Core+import Haste.Events.Core+import Haste.Concurrent (CIO) -- for SPECIALISE pragma+import Haste.Prim.Foreign (ToAny (..), FromAny (..), ffi)++jsHasCtx2D :: Elem -> IO Bool+jsHasCtx2D = ffi "(function(e){return !!e.getContext;})"++jsGetCtx2D :: Elem -> IO Ctx+jsGetCtx2D = ffi "(function(e){return e.getContext('2d');})"++jsBeginPath :: Ctx -> IO ()+jsBeginPath = ffi "(function(ctx){ctx.beginPath();})"++jsMoveTo :: Ctx -> Double -> Double -> IO ()+jsMoveTo = ffi "(function(ctx,x,y){ctx.moveTo(x,y);})"++jsLineTo :: Ctx -> Double -> Double -> IO ()+jsLineTo = ffi "(function(ctx,x,y){ctx.lineTo(x,y);})"++jsStroke :: Ctx -> IO ()+jsStroke = ffi "(function(ctx){ctx.stroke();})"++jsFill :: Ctx -> IO ()+jsFill = ffi "(function(ctx){ctx.fill();})"++jsRotate :: Ctx -> Double -> IO ()+jsRotate = ffi "(function(ctx,rad){ctx.rotate(rad);})"++jsTranslate :: Ctx -> Double -> Double -> IO ()+jsTranslate = ffi "(function(ctx,x,y){ctx.translate(x,y);})"++jsScale :: Ctx -> Double -> Double -> IO ()+jsScale = ffi "(function(ctx,x,y){ctx.scale(x,y);})"++jsPushState :: Ctx -> IO ()+jsPushState = ffi "(function(ctx){ctx.save();})"++jsPopState :: Ctx -> IO ()+jsPopState = ffi "(function(ctx){ctx.restore();})"++jsResetCanvas :: Elem -> IO ()+jsResetCanvas = ffi "(function(e){e.width = e.width;})"++jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()+jsDrawImage = ffi "(function(ctx,i,x,y){ctx.drawImage(i,x,y);})"++jsDrawImageClipped :: Ctx -> Elem+                   -> Double -> Double+                   -> Double -> Double -> Double -> Double+                   -> IO ()+jsDrawImageClipped = ffi "(function(ctx, img, x, y, cx, cy, cw, ch){\+ctx.drawImage(img, cx, cy, cw, ch, x, y, cw, ch);})"++jsDrawImageScaled :: Ctx -> Elem+                  -> Double -> Double -> Double -> Double+                  -> IO ()+jsDrawImageScaled = ffi "(function(ctx, img, x, y, w, h){\+ctx.drawImage(img, x, y, w, h);})"++jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()+jsDrawText = ffi "(function(ctx,s,x,y){ctx.fillText(s,x,y);})"++jsClip :: Ctx -> IO ()+jsClip = ffi "(function(ctx){ctx.clip();})"++jsArc :: Ctx -> Double -> Double+             -> Double+             -> Double -> Double+             -> IO ()+jsArc = ffi "(function(ctx, x, y, radius, fromAngle, toAngle){\+ctx.arc(x, y, radius, fromAngle, toAngle);})"++jsCanvasToDataURL :: Elem -> IO URL+jsCanvasToDataURL = ffi "(function(e){return e.toDataURL('image/png');})"++-- | A bitmap, backed by an IMG element.+--   JS representation is a reference to the backing IMG element.+newtype Bitmap = Bitmap Elem+  deriving (ToAny, FromAny)++-- | Any type that contains a buffered image which can be drawn onto a canvas.+class ImageBuffer a where+  -- | Draw the image buffer with its top left corner at the specified point.+  draw :: a -> Point -> Picture ()+  -- | Draw a portion of the image buffer with its top left corner at the+  --   specified point.+  drawClipped :: a -> Point -> Rect -> Picture ()+  -- | Draw the image buffer within given rectangle.+  drawScaled :: a -> Rect -> Picture ()++instance ImageBuffer Canvas where+  draw (Canvas _ buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y+  drawClipped (Canvas _ buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx ->+    jsDrawImageClipped ctx buf x y cx cy cw ch+  drawScaled (Canvas _ buf) (Rect x y w h) = Picture $ \ctx ->+    jsDrawImageScaled ctx buf x y w h++instance ImageBuffer Bitmap where+  draw (Bitmap buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y+  drawClipped (Bitmap buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx ->+    jsDrawImageClipped ctx buf x y cx cy cw ch+  drawScaled (Bitmap buf) (Rect x y w h) = Picture $ \ctx ->+    jsDrawImageScaled ctx buf x y w h++-- | Any type that can be used to obtain a bitmap.+class BitmapSource src where+  -- | Load a bitmap from some kind of bitmap source.+  loadBitmap :: MonadIO m => src -> m Bitmap++instance BitmapSource URL where+  loadBitmap url = liftIO $ do+    img <- newElem "img"+    setProp img "src" url+    loadBitmap img++instance BitmapSource Elem where+  loadBitmap = return . Bitmap++data AnyImageBuffer where+  AnyImageBuffer :: ImageBuffer a => a -> AnyImageBuffer++instance ImageBuffer AnyImageBuffer where+  draw (AnyImageBuffer buf) = draw buf+  drawClipped (AnyImageBuffer buf) = drawClipped buf+  drawScaled (AnyImageBuffer buf) = drawScaled buf++instance IsElem Canvas where+  elemOf (Canvas _ctx e) = e+  fromElem               = getCanvas++instance EventSource Canvas where+  eventSource = eventSource . elemOf++instance IsElem Bitmap where+  elemOf (Bitmap e) = e++-- | A point in the plane.+type Point = (Double, Double)++-- | A two dimensional vector.+type Vector = (Double, Double)++-- | An angle, given in radians.+type Angle = Double++-- | A rectangle.+data Rect = Rect {rect_x :: !Double,+                  rect_y :: !Double,+                  rect_w :: !Double,+                  rect_h :: !Double}++-- | A color, specified using its red, green and blue components, with an+--   optional alpha component.+data Color = RGB  !Int !Int !Int+           | RGBA !Int !Int !Int !Double++-- | Somewhat efficient conversion from Color to JSString.+color2JSString :: Color -> JSString+color2JSString (RGB r g b) =+  catJSStr "" ["rgb(", toJSString r, ",", toJSString g, ",", toJSString b, ")"]+color2JSString (RGBA r g b a) =+  catJSStr "" ["rgba(", toJSString r, ",",+                        toJSString g, ",",+                        toJSString b, ",",+                        toJSString a, ")"]++-- | A drawing context; part of a canvas.+--   JS representation is the drawing context object itself.+newtype Ctx = Ctx JSAny+  deriving (ToAny, FromAny)++-- | A canvas; a viewport into which a picture can be rendered.+--   The origin of the coordinate system used by the canvas is the top left+--   corner of the canvas element.+--   JS representation is a reference to the backing canvas element.+data Canvas = Canvas !Ctx !Elem++instance FromAny Canvas where+  fromAny c = do+    mcan <- fromAny c >>= fromElem+    case mcan of+      Just can -> return can+      _        -> error "Attempted to turn a non-canvas element into a Canvas!"++instance ToAny Canvas where+  toAny (Canvas _ el) = toAny el++-- | A picture that can be drawn onto a canvas.+newtype Picture a = Picture {unP :: Ctx -> IO a}++-- | A shape which can be either stroked or filled to yield a picture.+newtype Shape a = Shape {unS :: Ctx -> IO a}++instance Functor Picture where+  fmap f p = Picture $ \ctx ->+    unP p ctx >>= return . f++instance Applicative Picture where+  pure a = Picture $ \_ -> return a++  pfab <*> pa = Picture $ \ctx -> do+    fab <- unP pfab ctx+    a   <- unP pa   ctx+    return (fab a)++instance Monad Picture where+  return x = Picture $ \_ -> return x+  Picture m >>= f = Picture $ \ctx -> do+    x <- m ctx+    unP (f x) ctx++instance Functor Shape where+  fmap f s = Shape $ \ctx ->+    unS s ctx >>= return . f++instance Applicative Shape where+  pure a = Shape $ \_ -> return a++  sfab <*> sa = Shape $ \ctx -> do+    fab <- unS sfab ctx+    a   <- unS sa   ctx+    return (fab a)++instance Monad Shape where+  return x = Shape $ \_ -> return x+  Shape m >>= f = Shape $ \ctx -> do+    x <- m ctx+    unS (f x) ctx++-- | Create a 2D drawing context from a DOM element identified by its ID.+getCanvasById :: MonadIO m => String -> m (Maybe Canvas)+getCanvasById eid = liftIO $ do+  e <- elemById (toJSString eid)+  maybe (return Nothing) getCanvas e++{-# DEPRECATED getCanvas "use the more general fromElem instead." #-}+-- | Create a 2D drawing context from a DOM element.+getCanvas :: MonadIO m => Elem -> m (Maybe Canvas)+getCanvas e = liftIO $ do+  hasCtx <- jsHasCtx2D e+  case hasCtx of+    True -> do+      ctx <- jsGetCtx2D e+      return $ Just $ Canvas ctx e+    _    -> return Nothing++-- | Create an off-screen buffer of the specified size.+createCanvas :: MonadIO m => Int -> Int -> m Canvas+createCanvas w h = liftIO $ do+  buf <- newElem "canvas"+  setProp buf "width" (toJSString w)+  setProp buf "height" (toJSString h)+  fromJust <$> getCanvas buf++-- | Clear a canvas, then draw a picture onto it.+{-# SPECIALISE render :: Canvas -> Picture a -> IO a #-}+{-# SPECIALISE render :: Canvas -> Picture a -> CIO a #-}+render :: MonadIO m => Canvas -> Picture a -> m a+render (Canvas ctx el) (Picture p) = liftIO $ do+  jsResetCanvas el+  p ctx++-- | Draw a picture onto a canvas without first clearing it.+{-# SPECIALISE renderOnTop :: Canvas -> Picture a -> IO a #-}+{-# SPECIALISE renderOnTop :: Canvas -> Picture a -> CIO a #-}+renderOnTop :: MonadIO m => Canvas -> Picture a -> m a+renderOnTop (Canvas ctx _) (Picture p) = liftIO $ p ctx++-- | Generate a data URL from the contents of a canvas.+toDataURL :: MonadIO m => Canvas -> m URL+toDataURL (Canvas _ el) = liftIO $ jsCanvasToDataURL el++-- | Create a new off-screen buffer and store the given picture in it.+buffer :: MonadIO m => Int -> Int -> Picture () -> m Bitmap+buffer w h pict = liftIO $ do+  buf@(Canvas _ el) <- createCanvas w h+  render buf pict+  return $ Bitmap el++-- | Perform a computation over the drawing context of the picture.+--   This is handy for operations which are either impossible, hard or+--   inefficient to express using the Haste.Graphics.Canvas API.+withContext :: (Ctx -> IO a) -> Picture a+withContext f = Picture $ \ctx -> f ctx++-- | Set a new color for strokes.+setStrokeColor :: Color -> Picture ()+setStrokeColor c = Picture $ \(Ctx ctx) -> do+  setProp (Elem ctx) "strokeStyle" (color2JSString c)++-- | Set a new fill color.+setFillColor :: Color -> Picture ()+setFillColor c = Picture $ \(Ctx ctx) -> do+  setProp (Elem ctx) "fillStyle" (color2JSString c)++-- | Draw a picture with the given opacity.+opacity :: Double -> Picture () -> Picture ()+opacity alpha (Picture pict) = Picture $ \(Ctx ctx) -> do+  alpha' <- getProp (Elem ctx) "globalAlpha"+  setProp (Elem ctx) "globalAlpha" (toJSString alpha)+  pict (Ctx ctx)+  setProp (Elem ctx) "globalAlpha" alpha'++-- | Draw the given Picture using the specified Color for both stroke and fill,+--   then restore the previous stroke and fill colors.+color :: Color -> Picture () -> Picture ()+color c (Picture pict) = Picture $ \(Ctx ctx) -> do+    fc <- getProp (Elem ctx) "fillStyle"+    sc <- getProp (Elem ctx) "strokeStyle"+    setProp (Elem ctx) "fillStyle" c'+    setProp (Elem ctx) "strokeStyle" c'+    pict (Ctx ctx)+    setProp (Elem ctx) "fillStyle" fc+    setProp (Elem ctx) "strokeStyle" sc+  where+    c' = color2JSString c++-- | Draw the given picture using a new line width.+lineWidth :: Double -> Picture () -> Picture ()+lineWidth w (Picture pict) = Picture $ \(Ctx ctx) -> do+  lw <- getProp (Elem ctx) "lineWidth"+  setProp (Elem ctx) "lineWidth" (toJSString w)+  pict (Ctx ctx)+  setProp (Elem ctx) "lineWidth" lw++-- | Draw the specified picture using the given point as the origin.+translate :: Vector -> Picture () -> Picture ()+translate (x, y) (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsTranslate ctx x y+  pict ctx+  jsPopState ctx++-- | Draw the specified picture rotated @r@ radians clockwise.+rotate :: Double -> Picture () -> Picture ()+rotate rad (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsRotate ctx rad+  pict ctx+  jsPopState ctx++-- | Draw the specified picture scaled as specified by the scale vector.+scale :: Vector -> Picture () -> Picture ()+scale (x, y) (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsScale ctx x y+  pict ctx+  jsPopState ctx++-- | Draw a filled shape.+fill :: Shape () -> Picture ()+fill (Shape shape) = Picture $ \ctx -> do+  jsBeginPath ctx+  shape ctx+  jsFill ctx+  +-- | Draw the contours of a shape.+stroke :: Shape () -> Picture ()+stroke (Shape shape) = Picture $ \ctx -> do+  jsBeginPath ctx+  shape ctx+  jsStroke ctx++-- | Draw a picture clipped to the given path.+clip :: Shape () -> Picture () -> Picture ()+clip (Shape shape) (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsBeginPath ctx+  shape ctx+  jsClip ctx+  pict ctx+  jsPopState ctx++-- | Draw a path along the specified points.+path :: [Point] -> Shape ()+path ((x1, y1):ps) = Shape $ \ctx -> do+  jsMoveTo ctx x1 y1+  mapM_ (uncurry $ jsLineTo ctx) ps+path _ =+  return ()++-- | Draw a line between two points.+line :: Point -> Point -> Shape ()+line p1 p2 = path [p1, p2]++-- | Draw a rectangle between the two given points.+rect :: Point -> Point -> Shape ()+rect (x1, y1) (x2, y2) = path [(x1, y1), (x2, y1), (x2, y2), (x1, y2), (x1, y1)]++-- | Draw a circle shape.+circle :: Point -> Double -> Shape ()+circle (x, y) radius = Shape $ \ctx -> do+  jsMoveTo ctx (x+radius) y+  jsArc ctx x y radius (0 :: Double) twoPi++{-# INLINE twoPi #-}+twoPi :: Double+twoPi = 2*pi++-- | Draw an arc. An arc is specified as a drawn portion of an imaginary+--   circle with a center point, a radius, a starting angle and an ending+--   angle.+--   For instance, @arc (0, 0) 10 0 pi@ will draw a half circle centered at+--   (0, 0), with a radius of 10 pixels.+arc :: Point -> Double -> Angle -> Angle -> Shape ()+arc (x, y) radius from to = Shape $ \ctx -> jsArc ctx x y radius from to++-- | Draw a picture using a certain font. Obviously only affects text.+font :: String -> Picture () -> Picture ()+font f (Picture pict) = Picture $ \(Ctx ctx) -> do+  f' <- getProp (Elem ctx) "font"+  setProp (Elem ctx) "font" (toJSString f)+  pict (Ctx ctx)+  setProp (Elem ctx) "font" f'++-- | Draw some text onto the canvas.+text :: Point -> String -> Picture ()+text (x, y) str = Picture $ \ctx -> jsDrawText ctx (toJSString str) x y
+ src/Haste/Hash.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, GADTs, OverloadedStrings #-}+-- | Hash manipulation and callbacks.+module Haste.Hash (+    onHashChange, setHash, getHash+  ) where+import Haste.Prim.Foreign+import Control.Monad.IO.Class+import Haste.Prim+import Haste.Events.Core++-- | Register a callback to be run whenever the URL hash changes.+--   The first and second argument of the callback are the old and new and+--   hash respectively.+onHashChange :: MonadEvent m+              => (JSString -> JSString -> m ())+              -> m ()+onHashChange f = do+  f' <- mkHandler $ uncurry f+  firsthash <- getHash+  liftIO $ jsOnHashChange firsthash f'++jsOnHashChange :: JSString -> ((JSString, JSString) -> IO ()) -> IO ()+jsOnHashChange =+  ffi "(function(firsthash,cb){\+          \window.__old_hash = firsthash;\+          \window.onhashchange = function(e){\+            \var oldhash = window.__old_hash;\+            \var newhash = window.location.hash.split('#')[1] || '';\+            \window.__old_hash = newhash;\+            \cb([oldhash,newhash]);\+          \};\+       \})"++-- | Set the hash part of the current URL.+setHash :: MonadIO m => JSString -> m ()+setHash = liftIO . jsSetHash++jsSetHash :: JSString -> IO ()+jsSetHash = ffi "(function(h) {location.hash = '#'+h;})"++-- | Read the hash part of the current URL.+getHash :: MonadIO m => m JSString+getHash = liftIO jsGetHash++jsGetHash :: IO JSString+jsGetHash = ffi "(function() {return location.hash.substring(1);})"
+ src/Haste/JSON.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE PatternGuards            #-}+-- | Haste-specific JSON library. JSON is common enough that it's a good idea+--   to create as fast and small an implementation as possible. To that end,+--   the parser is implemented entirely in Javascript, and works with any+--   browser that supports JSON.parse; IE does this from version 8 and up, and+--   everyone else has done it since just about forever.+module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where+import Prelude hiding (null)+import Haste+import Haste.Prim+import Data.String as S+#ifndef __HASTE__+import Haste.Parsing+import Numeric+#endif+import Haste.Prim.Foreign hiding (toObject)++-- | Create a JavaScript object from a JSON object. Only makes sense in a+--   browser context, obviously.+toObject :: JSON -> JSAny+toObject = jsJSONParse . encodeJSON+jsJSONParse :: JSString -> JSAny+jsJSONParse = veryUnsafePerformIO . _jsJSONParse++_jsJSONParse :: JSString -> IO JSAny+_jsJSONParse = ffi "JSON.parse"++-- Remember to update jsParseJSON if this data type changes!+data JSON+  = Num  {-# UNPACK #-} !Double+  | Str  !JSString+  | Bool !Bool+  | Arr  ![JSON]+  | Dict ![(JSString, JSON)]+  | Null++instance IsString JSON where+  fromString = Str . S.fromString++instance JSType JSON where+  toJSString = encodeJSON+  fromJSString x =+    case decodeJSON x of+      Right x' -> Just x'+      _        -> Nothing++numFail :: a+numFail = error "Num JSON: not a numeric JSON node!"++-- | This instance may be a bad idea, but it's nice to be able to create JSON+--   objects using plain numeric literals.+instance Num JSON where+  (Num a) + (Num b) = Num (a+b)+  _ + _             = numFail+  (Num a) * (Num b) = Num (a*b)+  _ * _             = numFail+  (Num a) - (Num b) = Num (a-b)+  _ - _             = numFail+  negate (Num a)    = Num (negate a)+  negate _          = numFail+  abs (Num a)       = Num (abs a)+  abs _             = numFail+  signum (Num a)    = Num (signum a)+  signum _          = numFail+  fromInteger n     = Num (fromInteger n)++#ifdef __HASTE__+foreign import ccall "jsShow" jsShowD :: Double -> JSString+foreign import ccall "jsParseJSON" jsParseJSON :: JSString -> Ptr (Maybe JSON)+jsStringify :: JSString -> IO JSString+jsStringify = ffi "JSON.stringify"+#else+jsShowD :: Double -> JSString+jsShowD = toJSStr . flip (showFFloat Nothing) ""++jsStringify :: JSString -> IO JSString+jsStringify = return . toJSStr . ('"' :) . unq . fromJSStr+  where+    unq ('"' : cs) = "\\\"" ++ unq cs+    unq (c : cs)+      | c == '\\'          = "\\\\" ++ unq cs+      | otherwise          = c : unq cs+    unq _          = ['"']+#endif++-- | Look up a JSON object from a JSON dictionary. Panics if the dictionary+--   isn't a dictionary, or if it doesn't contain the given key.+(!) :: JSON -> JSString -> JSON+dict ! k =+  case dict ~> k of+    Just x -> x+    _      -> error $ "Haste.JSON.!: unable to look up key " ++ fromJSStr k+infixl 5 !++class JSONLookup a where+  -- | Look up a key in a JSON dictionary. Return Nothing if the key can't be+  --   found for some reason.+  (~>) :: a -> JSString -> Maybe JSON+infixl 5 ~>++instance JSONLookup JSON where+  (Dict m) ~> key = lookup key m+  _        ~> _   = Nothing++instance JSONLookup (Maybe JSON) where+  (Just (Dict m)) ~> key = lookup key m+  _               ~> _   = Nothing++encodeJSON :: JSON -> JSString+encodeJSON = catJSStr "" . enc []+  where+    comma   = ","+    openbr  = "["+    closebr = "]"+    opencu  = "{"+    closecu = "}"+    colon   = ":"+    quote   = "\""+    true    = "true"+    false   = "false"+    null    = "null"+    enc acc Null         = null : acc+    enc acc (Str s)      = veryUnsafePerformIO (jsStringify s) : acc+    enc acc (Num d)      = jsShowD d : acc+    enc acc (Bool True)  = true : acc+    enc acc (Bool False) = false : acc+    enc acc (Arr elems)+      | (x:xs) <- elems =+        openbr : enc (foldr (\s a -> comma:enc a s) (closebr:acc) xs) x+      | otherwise =+        openbr : closebr : acc+    enc acc (Dict elems)+      | ((key,val):xs) <- elems =+        let encElem (k, v) a = comma : quote : k : quote : colon : enc a v+            encAll =+              opencu : veryUnsafePerformIO (jsStringify key) : colon : encRest+            encRest = enc (foldr encElem (closecu:acc) xs) val+        in encAll+      | otherwise =+        opencu : closecu : acc++decodeJSON :: JSString -> Either JSString JSON+#ifdef __HASTE__+decodeJSON = liftMaybe . fromPtr . jsParseJSON+  where+    liftMaybe (Just x) = Right x+    liftMaybe _        = Left "Invalid JSON!"+#else+decodeJSON = liftMaybe . runParser json . fromJSStr+  where+    liftMaybe (Just x) = Right x+    liftMaybe _        = Left "Invalid JSON!"+    json = oneOf [Num  <$> double,+                  Bool <$> boolean,+                  Str  <$> jsstring,+                  Arr  <$> array,+                  Dict <$> object,+                  null]+    jsstring = toJSStr <$> oneOf [quotedString '\'', quotedString '"']+    boolean = oneOf [string "true" >> pure True, string "false" >> pure False]+    null = string "null" >> pure Null+    array = do+      _ <- char '[' >> possibly whitespace+      elements <- commaSeparated json+      _ <- possibly whitespace >> char ']'+      return elements+    commaSeparated p =+      oneOf [do x <- p+                _ <- possibly whitespace >> char ',' >> possibly whitespace+                xs <- commaSeparated p+                return (x:xs),+             do x <- p+                return [x],+             do return []]+    object = do+      _ <- char '{' >> possibly whitespace+      pairs <- commaSeparated kvPair+      _ <- possibly whitespace >> char '}'+      return pairs+    kvPair = do+      k <- jsstring+      _ <- possibly whitespace >> char ':' >> possibly whitespace+      v <- json+      return (k, v)+#endif++instance Show JSON where+  show = fromJSStr . encodeJSON
+ src/Haste/JSString.hs view
@@ -0,0 +1,372 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface, CPP, MagicHash,+             GeneralizedNewtypeDeriving #-}+-- | JSString standard functions, to make them a more viable alternative to+--   the horribly inefficient standard Strings.+--+--   Many functions have linear time complexity due to JavaScript engines not+--   implementing slicing, etc. in constant time.+--+--   All functions are supported on both client and server, with the exception+--   of 'match', 'matches', 'regex' and 'replace', which are wrappers on top of+--   JavaScript's native regular expressions and thus only supported on the+--   client.+module Haste.JSString+  ( JSString+  -- * Building JSStrings+  , empty, singleton, pack, cons, snoc, append, replicate+    -- * Deconstructing JSStrings+  , (!), unpack, head, last, tail, drop, take, init, splitAt+    -- * Examining JSStrings+  , null, length, any, all+    -- * Modifying JSStrings+  , map, reverse, intercalate, foldl', foldr, concat, concatMap+    -- * Regular expressions (client-side only)+  , RegEx, match, matches, regex, replace+    -- * JSString I/O+  , putStrLn, putStr+  ) where+import qualified Data.List+import Prelude hiding (foldr, concat, concatMap, reverse, map, all, any,+                       length, null, splitAt, init, take, drop, tail, head,+                       last, replicate, putStrLn, putStr)+import qualified Prelude+import Data.String+import Haste.Prim+import Haste.Prim.Foreign+import Control.Monad.IO.Class+import System.IO.Unsafe++#ifdef __HASTE__+import GHC.Prim++{-# INLINE d2c #-}+d2c :: Double -> Char+d2c d = unsafeCoerce# d++_jss_singleton :: Char -> IO JSString+_jss_singleton = ffi "String.fromCharCode"++_jss_cons :: Char -> JSString -> IO JSString+_jss_cons = ffi "(function(c,s){return String.fromCharCode(c)+s;})"++_jss_snoc :: JSString -> Char -> IO JSString+_jss_snoc = ffi "(function(s,c){return s+String.fromCharCode(c);})"++_jss_append :: JSString -> JSString -> IO JSString+_jss_append = ffi "(function(a,b){return a+b;})"++_jss_len :: JSString -> IO Int+_jss_len = ffi "(function(s){return s.length;})"++_jss_index :: JSString -> Int -> IO Double+_jss_index = ffi "(function(s,i){return s.charCodeAt(i);})"++_jss_substr :: JSString -> Int -> IO JSString+_jss_substr = ffi "(function(s,x){return s.substr(x);})"++_jss_take :: Int -> JSString -> IO JSString+_jss_take = ffi "(function(n,s){return s.substr(0,n);})"++_jss_rev :: JSString -> IO JSString+_jss_rev = ffi "(function(s){return s.split('').reverse().join('');})"++_jss_re_match :: JSString -> RegEx -> IO Bool+_jss_re_match = ffi "(function(s,re){return s.search(re)>=0;})"++_jss_re_compile :: JSString -> JSString -> IO RegEx+_jss_re_compile = ffi "(function(re,fs){return new RegExp(re,fs);})"++_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString+_jss_re_replace = ffi "(function(s,re,rep){return s.replace(re,rep);})"++_jss_re_find :: RegEx -> JSString -> IO [JSString]+_jss_re_find = ffi "(function(re,s) {\+var a = s.match(re);\+return a ? a : [];})"++{-# INLINE _jss_map #-}+_jss_map :: (Char -> Char) -> JSString -> JSString+_jss_map f s = unsafePerformIO $ cmap_js (_jss_singleton . f) s++{-# INLINE _jss_cmap #-}+_jss_cmap :: (Char -> JSString) -> JSString -> JSString+_jss_cmap f s = unsafePerformIO $ cmap_js (return . f) s++cmap_js :: (Char -> IO JSString) -> JSString -> IO JSString+cmap_js = ffi "(function(f,s){\+var s2 = '';\+for(var i in s) {\+   s2 += f(s.charCodeAt(i));\+}\+return s2;})"++{-# INLINE _jss_foldl #-}+_jss_foldl :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a+_jss_foldl f x s = fromOpaque . unsafePerformIO $ do+  foldl_js (\a c ->  toOpaque $ f (fromOpaque a) c) (toOpaque x) s++foldl_js :: (Opaque a -> Char -> Opaque a)+         -> Opaque a+         -> JSString+         -> IO (Opaque a)+foldl_js = ffi "(function(f,x,s){\+for(var i in s) {\+  x = f(x,s.charCodeAt(i));\+}\+return x;})"++{-# INLINE _jss_foldr #-}+_jss_foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a+_jss_foldr f x s = fromOpaque . unsafePerformIO $ do+  foldr_js (\c -> toOpaque . f c . fromOpaque) (toOpaque x) s++foldr_js :: (Char -> Opaque a -> Opaque a)+         -> Opaque a+         -> JSString+         -> IO (Opaque a)+foldr_js = ffi "(function(f,x,s){\+for(var i = s.length-1; i >= 0; --i) {\+  x = f(s.charCodeAt(i),x);\+}\+return x;})"++#else++{-# INLINE d2c #-}+d2c :: Char -> Char+d2c = id++_jss_singleton :: Char -> IO JSString+_jss_singleton c = return $ toJSStr [c]++_jss_cons :: Char -> JSString -> IO JSString+_jss_cons c s = return $ toJSStr (c : fromJSStr s)++_jss_snoc :: JSString -> Char -> IO JSString+_jss_snoc s c = return $ toJSStr (fromJSStr s ++ [c])++_jss_append :: JSString -> JSString -> IO JSString+_jss_append a b = return $ catJSStr "" [a, b]++_jss_len :: JSString -> IO Int+_jss_len s = return $ Data.List.length $ fromJSStr s++_jss_index :: JSString -> Int -> IO Char+_jss_index s n = return $ fromJSStr s !! n++_jss_substr :: JSString -> Int -> IO JSString+_jss_substr s n = return $ toJSStr $ Data.List.drop n $ fromJSStr s++_jss_take :: Int -> JSString -> IO JSString+_jss_take n = return . toJSStr . Data.List.take n . fromJSStr++_jss_map :: (Char -> Char) -> JSString -> JSString+_jss_map f = toJSStr . Data.List.map f . fromJSStr++_jss_cmap :: (Char -> JSString) -> JSString -> JSString+_jss_cmap f =+  toJSStr . Data.List.concat . Data.List.map (fromJSStr . f) . fromJSStr++_jss_rev :: JSString -> IO JSString+_jss_rev = return . toJSStr . Data.List.reverse . fromJSStr++_jss_foldl :: (a -> Char -> a) -> a -> JSString -> a+_jss_foldl f x = Data.List.foldl' f x . fromJSStr++_jss_foldr :: (Char -> a -> a) -> a -> JSString -> a+_jss_foldr f x = Data.List.foldr f x . fromJSStr++_jss_re_compile :: JSString -> JSString -> IO RegEx+_jss_re_compile _ _ =+  error "Regular expressions are only supported client-side!"++_jss_re_match :: JSString -> RegEx -> IO Bool+_jss_re_match _ _ =+  error "Regular expressions are only supported client-side!"++_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString+_jss_re_replace _ _ _ =+  error "Regular expressions are only supported client-side!"++_jss_re_find :: RegEx -> JSString -> IO [JSString]+_jss_re_find _ _ =+  error "Regular expressions are only supported client-side!"++#endif++-- | A regular expression. May be used to match and replace JSStrings.+newtype RegEx = RegEx JSAny+  deriving (ToAny, FromAny)++instance IsString RegEx where+  fromString s = unsafePerformIO $ _jss_re_compile (fromString s) ""++-- | O(1) The empty JSString.+empty :: JSString+empty = ""++-- | O(1) JSString consisting of a single character.+singleton :: Char -> JSString+singleton = veryUnsafePerformIO . _jss_singleton++-- | O(n) Convert a list of Char into a JSString.+pack :: [Char] -> JSString+pack = toJSStr++-- | O(n) Convert a JSString to a list of Char.+unpack :: JSString -> [Char]+unpack = fromJSStr++infixr 5 `cons`+-- | O(n) Prepend a character to a JSString.+cons :: Char -> JSString -> JSString+cons c s = veryUnsafePerformIO $ _jss_cons c s++infixl 5 `snoc`+-- | O(n) Append a character to a JSString.+snoc :: JSString -> Char -> JSString+snoc s c = veryUnsafePerformIO $ _jss_snoc s c++-- | O(n) Append two JSStrings.+append :: JSString -> JSString -> JSString+append a b = veryUnsafePerformIO $ _jss_append a b++-- | O(1) Extract the first element of a non-empty JSString.+head :: JSString -> Char+head s =+#ifdef __HASTE__+  case veryUnsafePerformIO $ _jss_index s 0 of+    c | isNaN c   -> error "Haste.JSString.head: empty JSString"+      | otherwise -> d2c c -- Double/Int/Char share representation.+#else+  Data.List.head $ fromJSStr s+#endif++-- | O(1) Extract the last element of a non-empty JSString.+last :: JSString -> Char+last s =+  case veryUnsafePerformIO $ _jss_len s of+    0 -> error "Haste.JSString.head: empty JSString"+    n -> d2c (veryUnsafePerformIO $ _jss_index s (n-1))++-- | Get a single character from a JSString.+(!) :: JSString -> Int -> Char+s ! n =+#ifdef __HASTE__+  case veryUnsafePerformIO $ _jss_index s n of+    c | isNaN c   -> error "Haste.JSString.(!): index out of bounds"+      | otherwise -> d2c c -- Double/Int/Char share representation.+#else+  fromJSStr s !! n+#endif+++-- | O(n) All elements but the first of a JSString. Returns an empty JSString+--   if the given JSString is empty.+tail :: JSString -> JSString+tail s = veryUnsafePerformIO $ _jss_substr s 1++-- | O(n) Drop 'n' elements from the given JSString.+drop :: Int -> JSString -> JSString+drop n s = veryUnsafePerformIO $ _jss_substr s (max 0 n)++-- | O(n) Take 'n' elements from the given JSString.+take :: Int -> JSString -> JSString+take n s = veryUnsafePerformIO $ _jss_take n s++-- | O(n) All elements but the last of a JSString. Returns an empty JSString+--   if the given JSString is empty.+init :: JSString -> JSString+init s = veryUnsafePerformIO $ _jss_take (veryUnsafePerformIO (_jss_len s)-1) s++-- | O(1) Test whether a JSString is empty.+null :: JSString -> Bool+null s = veryUnsafePerformIO (_jss_len s) == 0++-- | O(1) Get the length of a JSString as an Int.+length :: JSString -> Int+length = veryUnsafePerformIO . _jss_len++-- | O(n) Map a function over the given JSString.+map :: (Char -> Char) -> JSString -> JSString+map f s = _jss_map f s++-- | O(n) reverse a JSString.+reverse :: JSString -> JSString+reverse = veryUnsafePerformIO . _jss_rev++-- | O(n) Join a list of JSStrings, with a specified separator. Equivalent to+--   'String.join'.+intercalate :: JSString -> [JSString] -> JSString+intercalate = catJSStr++-- | O(n) Left fold over a JSString.+foldl' :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a+foldl' = _jss_foldl++-- | O(n) Right fold over a JSString.+foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a+foldr = _jss_foldr++-- | O(n) Concatenate a list of JSStrings.+concat :: [JSString] -> JSString+concat = catJSStr ""++-- | O(n) Map a function over a JSString, then concatenate the results.+--   Note that this function is actually faster than 'map' in most cases.+concatMap :: (Char -> JSString) -> JSString -> JSString+concatMap = _jss_cmap++-- | O(n) Determines whether any character in the string satisfies the given+--   predicate.+any :: (Char -> Bool) -> JSString -> Bool+any p = Haste.JSString.foldl' (\a x -> a || p x) False++-- | O(n) Determines whether all characters in the string satisfy the given+--   predicate.+all :: (Char -> Bool) -> JSString -> Bool+all p = Haste.JSString.foldl' (\a x -> a && p x) False++-- | O(n) Create a JSString containing 'n' instances of a single character.+replicate :: Int -> Char -> JSString+replicate n c = Haste.JSString.pack $ Data.List.replicate n c++-- | O(n) Equivalent to (take n xs, drop n xs).+splitAt :: Int -> JSString -> (JSString, JSString)+splitAt n s = (Haste.JSString.take n s, Haste.JSString.drop n s)++-- | As 'Prelude.putStrLn'.+putStrLn :: MonadIO m => JSString -> m ()+putStrLn = liftIO . Prelude.putStrLn . unpack++-- | As 'Prelude.putStr'.+putStr :: MonadIO m => JSString -> m ()+putStr = liftIO . Prelude.putStr . unpack++-- | O(n) Determines whether the given JSString matches the given regular+--   expression or not.+matches :: JSString -> RegEx -> Bool+matches s re = veryUnsafePerformIO $ _jss_re_match s re++-- | O(n) Find all strings corresponding to the given regular expression.+match :: RegEx -> JSString -> [JSString]+match re s = veryUnsafePerformIO $ _jss_re_find re s++-- | O(n) Compile a regular expression and an (optionally empty) list of flags+--   into a 'RegEx' which can be used to match, replace, etc. on JSStrings.+--+--   The regular expression and flags are passed verbatim to the browser's+--   RegEx constructor, meaning that the syntax is the same as when using+--   regular expressions in raw JavaScript.+regex :: JSString -- ^ Regular expression.+      -> JSString -- ^ Potential flags.+      -> RegEx+regex re flags = veryUnsafePerformIO $ _jss_re_compile re flags++-- | O(n) String substitution using regular expressions.+replace :: JSString -- ^ String perform substitution on.+        -> RegEx    -- ^ Regular expression to match.+        -> JSString -- ^ Replacement string.+        -> JSString+replace s re rep = veryUnsafePerformIO $ _jss_re_replace s re rep
+ src/Haste/LocalStorage.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Basic bindings to HTML5 WebStorage.+module Haste.LocalStorage (setItem, getItem, removeItem) where+import Haste+import Haste.Prim.Foreign+import Haste.Serialize+import Haste.JSON++-- | Locally store a serializable value.+setItem :: Serialize a => JSString -> a -> IO ()+setItem k = store k . encodeJSON . toJSON++store :: JSString -> JSString -> IO ()+store = ffi "(function(k,v) {localStorage.setItem(k,v);})"++-- | Load a serializable value from local storage. Will fail if the given key+--   does not exist or if the value stored at the key does not match the+--   requested type.+getItem :: Serialize a => JSString -> IO (Either JSString a)+getItem k = do+  maybe (Left "No such value") (\s -> decodeJSON s >>= fromJSON) <$> load k++load :: JSString -> IO (Maybe JSString)+load = ffi "(function(k) {return localStorage.getItem(k);})"++-- | Remove a value from local storage.+removeItem :: JSString -> IO ()+removeItem = ffi "(function(k) {localStorage.removeItem(k);})"
+ src/Haste/Parsing.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleInstances #-}+-- | Home-grown parser, just because.+module Haste.Parsing (+    Parse, runParser, char, charP, string, oneOf, possibly, atLeast,+    whitespace, word, Haste.Parsing.words, int, double, positiveDouble,+    suchThat, quotedString, skip, rest, lookahead, anyChar+  ) where+import Control.Applicative+import Control.Monad+import Data.Char++newtype Parse a = Parse {unP :: (String -> Maybe (String, a))}++runParser :: Parse a -> String -> Maybe a+runParser (Parse p) s =+  case p s of+    Just ("", x) -> Just x+    _            -> Nothing++instance Monad Parse where+  return x = Parse $ \s -> Just (s, x)+  Parse m >>= f = Parse $ \s -> do+    (s', x) <- m s+    unP (f x) s'++instance Alternative Parse where+  empty = mzero+  (<|>) = mplus++instance MonadPlus Parse where+  mplus (Parse p1) (Parse p2) = Parse $ \s ->+    case p1 s of+      x@(Just _) -> x+      _          -> p2 s+  mzero = Parse $ const Nothing++instance Functor Parse where+  fmap f (Parse g) = Parse $ fmap (fmap f) . g++instance Applicative Parse where+  pure  = return+  (<*>) = ap++-- | Read one character. Fails if end of stream.+anyChar :: Parse Char+anyChar = Parse $ \s ->+  case s of+    (c:cs) -> Just (cs, c)+    _      -> Nothing++-- | Require a specific character.+char :: Char -> Parse Char+char c = charP (== c)++-- | Parse a character that matches a given predicate.+charP :: (Char -> Bool) -> Parse Char+charP p = Parse $ \s ->+  case s of+    (c:next) | p c -> Just (next, c)+    _              -> Nothing  ++-- | Require a specific string.+string :: String -> Parse String+string str = Parse $ \s ->+  let len        = length str+      (s', next) = splitAt len s+  in if s' == str+       then Just (next, str)+       else Nothing++-- | Apply the first matching parser.+oneOf :: [Parse a] -> Parse a+oneOf = msum++-- | Invoke a parser with the possibility of failure.+possibly :: Parse a -> Parse (Maybe a)+possibly p = oneOf [Just <$> p, return Nothing]++-- | Invoke a parser at least n times.+atLeast :: Int -> Parse a -> Parse [a]+atLeast 0 p = do+  x <- possibly p+  case x of+    Just x' -> do+      xs <- atLeast 0 p+      return (x':xs)+    _ ->+      return []+atLeast n p = do+  x <- p+  xs <- atLeast (n-1) p+  return (x:xs)++-- | Parse zero or more characters of whitespace.+whitespace :: Parse String+whitespace = atLeast 0 $ charP isSpace++-- | Parse a non-empty word. A word is a string of at least one non-whitespace+--   character.+word :: Parse String+word = atLeast 1 $ charP (not . isSpace)++-- | Parse several words, separated by whitespace.+words :: Parse [String]+words = atLeast 0 $ word <* whitespace++-- | Parse an Int.+int :: Parse Int+int = oneOf [read <$> atLeast 1 (charP isDigit),+             char '-' >> (0-) . read <$> atLeast 1 (charP isDigit)]++-- | Parse a floating point number.+double :: Parse Double+double = oneOf [positiveDouble,+                char '-' >> (0-) <$> positiveDouble]++-- | Parse a non-negative floating point number.+positiveDouble :: Parse Double+positiveDouble = do+  first <- atLeast 1 $ charP isDigit+  msecond <- possibly $ char '.' *> atLeast 1 (charP isDigit)+  case msecond of+    Just second -> return $ read $ first ++ "." ++ second+    _           -> return $ read first++-- | Fail on unwanted input.+suchThat :: Parse a -> (a -> Bool) -> Parse a+suchThat p f = do {x <- p ; if f x then return x else mzero}++-- | A string quoted with the given quotation mark. Strings can contain escaped+--   quotation marks; escape characters are stripped from the returned string.+quotedString :: Char -> Parse String+quotedString q = char q *> strContents q <* char q++strContents :: Char -> Parse String+strContents c = do+  s <- atLeast 0 $ charP (\x -> x /= c && x /= '\\')+  c' <- lookahead anyChar+  if c == c'+    then do+      return s+    else do+      skip 1+      c'' <- anyChar+      s' <- strContents c+      return $ s ++ [c''] ++ s'++-- | Read the rest of the input.+rest :: Parse String+rest = Parse $ \s -> Just ("", s)++-- | Run a parser with the current parsing state, but don't consume any input.+lookahead :: Parse a -> Parse a+lookahead p = do+  s' <- Parse $ \s -> Just (s, s)+  x <- p+  Parse $ \_ -> Just (s', x)++-- | Skip n characters from the input.+skip :: Int -> Parse ()+skip n = Parse $ \s -> Just (drop n s, ())
+ src/Haste/Performance.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+-- | (Very incomplete) Haste bindings to the @Performance@ DOM interface.+module Haste.Performance (HRTimeStamp, now, navigationStart) where+import Haste.Prim.Foreign++type HRTimeStamp = Double++-- | Returns the number of milliseconds since 'navigationStart', with+--   (theoretically) microsecond precision.+now :: IO HRTimeStamp+now = ffi "(function(){return performance.now();})"++-- | Returns the number of milliseconds elapsed since UNIX epoch at the moment+--   when this document started loading.+navigationStart :: IO Double+navigationStart = ffi "(function(){return performance.timing.navigationStart;})"
+ src/Haste/Serialize.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+-- | JSON serialization and de-serialization for Haste.+module Haste.Serialize (+    Serialize (..), Parser, fromJSON, (.:), (.:?)+  ) where+import GHC.Float+import GHC.Int+import Haste.JSON+import Haste.JSString (JSString)+import qualified Haste.JSString as JS+import Control.Monad (ap, when)++class Serialize a where+  toJSON :: a -> JSON++  listToJSON :: [a] -> JSON+  listToJSON = Arr . map toJSON++  parseJSON :: JSON -> Parser a++  parseJSONList :: JSON -> Parser [a]+  parseJSONList (Arr xs) = mapM parseJSON xs+  parseJSONList _        = fail "Tried to deserialie a non-array to a list!"++instance Serialize JSON where+  toJSON = id+  parseJSON = return++instance Serialize Float where+  toJSON = Num . float2Double+  parseJSON (Num x) = return (double2Float x)+  parseJSON _       = fail "Tried to deserialize a non-Number to a Float"++instance Serialize Double where+  toJSON = Num+  parseJSON (Num x) = return x+  parseJSON _       = fail "Tried to deserialize a non-Number to a Double"++instance Serialize Int where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int"++instance Serialize Int8 where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | x <= 0xff && fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int8"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int8"++instance Serialize Int16 where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | x <= 0xffff && fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int16"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int16"++instance Serialize Int32 where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | x < 0xffffffff && fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int32"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int32"++instance Serialize Bool where+  toJSON = Bool+  parseJSON (Bool x) = return x+  parseJSON _        = fail "Tried to deserialize a non-Bool to a Bool"++instance Serialize () where+  toJSON _ = Dict []+  parseJSON _ = return ()++instance Serialize Char where+  toJSON c = Str $ JS.pack [c]+  parseJSON (Str s) = do+    when (JS.length s > 1) $ fail "Tried to deserialize long string to a Char"+    return $ JS.head s+  parseJSON _ =+    fail "Tried to deserialize a non-string to a Char"+  listToJSON = toJSON . JS.pack+  parseJSONList s = fmap JS.unpack (parseJSON s)++instance Serialize JSString where+  toJSON = Str+  parseJSON (Str s) = return s+  parseJSON _ = fail "Tried to deserialize a non-JSString to a JSString"++instance (Serialize a, Serialize b) => Serialize (a, b) where+  toJSON (a, b) = Arr [toJSON a, toJSON b]+  parseJSON (Arr [a, b]) = do+    a' <- parseJSON a+    b' <- parseJSON b+    return (a', b')+  parseJSON _ =+    fail "Tried to deserialize a non-array into a pair!"++instance Serialize a => Serialize (Maybe a) where+  toJSON (Just x)  = Dict [("hasValue", toJSON True), ("value", toJSON x)]+  toJSON (Nothing) = Dict [("hasValue", toJSON False)]+  parseJSON d = do+    hasVal <- d .: "hasValue"+    case hasVal of+      False -> return Nothing+      _     -> Just `fmap` (d .: "value")++instance Serialize a => Serialize [a] where+  toJSON = listToJSON+  parseJSON = parseJSONList++instance (Serialize a, Serialize b) => Serialize (Either a b) where+  toJSON (Right x) = Dict [("success", toJSON True), ("value", toJSON x)]+  toJSON (Left e)  = Dict [("success", toJSON False), ("error", toJSON e)]+  parseJSON d = do+    success <- d .: "success"+    case success of+      False -> Left `fmap` (d .: "error")+      _     -> Right `fmap` (d .: "value")++fromJSON :: Serialize a => JSON -> Either JSString a+fromJSON = runParser parseJSON++-- | Type for JSON parser.+newtype Parser a = Parser (Either JSString a)++runParser :: (a -> Parser b) -> a -> Either JSString b+runParser p x = case p x of Parser y -> y++instance Monad Parser where+  return = Parser . return+  (Parser (Right x)) >>= f = f x+  (Parser (Left e))  >>= _ = Parser (Left e)+  fail = Parser . Left . JS.pack++instance Functor Parser where+  fmap f m = m >>= return . f++instance Applicative Parser where+  (<*>) = ap+  pure  = return++-- | Look up a key in a JSON object.+(.:) :: Serialize a => JSON -> JSString -> Parser a+Dict o .: key =+  case lookup key o of+    Just x -> parseJSON x+    _      -> Parser . Left $ JS.concat ["Key not found: ", key]+_ .: _ =+  Parser $ Left "Tried to do lookup on non-object!"++(.:?) :: Serialize a => JSON -> JSString -> Parser (Maybe a)+o .:? key =+  case o .: key of+    Parser (Right x) -> return (Just x)+    _                -> return Nothing
+ src/Haste/Timer.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+module Haste.Timer (Timer, Interval (..), setTimer, stopTimer) where+import Control.Monad.IO.Class+import Haste.Prim.Foreign+import Haste.Events.Core++type Identifier = Int++-- | Timer handle.+data Timer = Timer !Identifier !Interval++-- | Interval and repeat for timers.+data Interval+  = Once !Int   -- ^ Fire once, in n milliseconds.+  | Repeat !Int -- ^ Fire every n milliseconds.++-- | Set a timer.+setTimer :: MonadEvent m+         => Interval -- ^ Milliseconds until timer fires.+         -> m ()     -- ^ Function to call when timer fires.+         -> m Timer  -- ^ Timer handle for interacting with the timer.+setTimer i f = do+    f' <- mkHandler $ const f+    liftIO $ do+      flip Timer i <$> case i of+        Once n   -> timeout n (f' ())+        Repeat n -> interval n (f' ())++timeout :: Int -> IO () -> IO Int+timeout = ffi "(function(t,f){return window.setTimeout(f,t);})"++interval :: Int -> IO () -> IO Int+interval = ffi "(function(t,f){return window.setInterval(f,t);})"++-- | Stop a timer.+stopTimer :: MonadIO m => Timer -> m ()+stopTimer (Timer ident (Once _)) = liftIO $ clearTimeout ident+stopTimer (Timer ident (Repeat _)) = liftIO $ clearInterval ident++clearTimeout :: Int -> IO ()+clearTimeout = ffi "(function(id){window.clearTimeout(id);})"++clearInterval :: Int -> IO ()+clearInterval = ffi "(function(id){window.clearInterval(id);})"
+ src/Haste/WebSockets.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleInstances #-}+-- | WebSockets API for Haste.+module Haste.WebSockets+  ( module Haste.Concurrent+  , WebSocket, WebSocketConfig (..), WebSocketCloseEvent (..)+  , WebSocketData (..)+  , noHandlers+  , wsOpenSync+  , wsClose+  , withWebSocket, withBinaryWebSocket, wsSendBlob+  ) where+import Haste+import Haste.Prim.Foreign+import Haste.Concurrent+import Haste.Binary (Blob)++-- | A WebSocket, parameterized over the type of data that can be sent and+--   received over it.+newtype WebSocket a = WebSocket JSAny deriving (ToAny, FromAny)++instance Eq (WebSocket a) where+  (WebSocket a) == (WebSocket b) = a == b++-- | Some data that can be sent and received over a WebSocket.+class WebSocketData a where+  -- | Send a piece of data to a WebSocket of the appropriate type.+  --   Returns @False@ if the data could not be sent, for instance due to a+  --   closed socket.+  wsSend :: WebSocket a -> a -> CIO Bool++  -- | Open a new WebSocket connection, returning @Just socket@ when successful.+  wsOpen :: WebSocketConfig a -> CIO (Maybe (WebSocket a))++instance WebSocketData Blob where+  wsSend ws b = liftIO $ sendB ws b+  wsOpen = open newBin++instance WebSocketData JSString where+  wsSend ws s = liftIO $ sendS ws s+  wsOpen = open new++open mkNew (WebSocketConfig url close msg) = do+  sock <- newEmptyMVar+  liftIO $ mkNew url+    (\s d -> concurrent $ msg s d)+    (concurrent . putMVar sock . Just)+    (concurrent . close)+    (concurrent $ putMVar sock Nothing)+  takeMVar sock++-- | The various event handlers supported by WebSockets.+data WebSocketConfig t = WebSocketConfig+  { -- | URL to which to attempt a WebSocket connection.+    wsOpenURL   :: URL+    -- | Called when the connection is closed by the server.+  , wsOnClose   :: WebSocketCloseEvent -> CIO ()+    -- | Called when a new message arrives.+  , wsOnMessage :: WebSocket t -> t -> CIO ()+  }++-- | Event describing the remote closing of a WebSocket.+data WebSocketCloseEvent = WebSocketCloseEvent+  { -- | Reason for close event, computer-readable version.+    wsCloseCode   :: Int+    -- | Reason for close event, human-readable version.+  , wsCloseReason :: JSString+    -- | Was the socket closed cleanly?+  , wsCloseClean  :: Bool+  }++instance FromAny WebSocketCloseEvent where+  fromAny o = WebSocketCloseEvent <$> get o "code"+                                  <*> get o "reason"+                                  <*> get o "wasClean"++-- | No-op handlers for all WebSocket events.+noHandlers :: WebSocketConfig t+noHandlers = WebSocketConfig+  { wsOpenURL   = ""+  , wsOnClose   = \_ -> return ()+  , wsOnMessage = \_ _ -> return ()+  }++-- | Open a WebSocket, returning the socket as well as a blocking CIO+--   computation to await incoming data on the socket.+--   When data arrives on the socket, the waiting computation will return+--   @Right received_data@. When the socket is closed, the waiting computation+--   will return @Left close_event@.+wsOpenSync :: WebSocketData t+           => URL+           -> CIO (Maybe (WebSocket t, CIO (Either WebSocketCloseEvent t)))+wsOpenSync url = do+  incoming <- newEmptyMVar+  msock <- wsOpen (WebSocketConfig+                   { wsOpenURL     = url+                   , wsOnClose     = putMVar incoming . Left+                   , wsOnMessage   = \_ -> putMVar incoming . Right+                   })+  case msock of+    Just sock -> return $ Just (sock, takeMVar incoming)+    _         -> return Nothing++-- | Close a WebSocket. Closing a WebSocket which has been previously closed+--   is a no-op. Any associated 'wsOnClose' handler will not be called.+wsClose :: WebSocket a -> CIO ()+wsClose ws = liftIO $ close ws++++-- * Legacy API++-- | Run a computation with a WebSocket. The computation will not be executed+--   until a connection to the server has been established.+--   The WebSocket will not be closed after the computation finishes.+withWebSocket :: URL+              -- ^ URL to bind the WebSocket to+              -> (WebSocket JSString -> JSString -> CIO ())+              -- ^ Computation to run when new data arrives+              -> CIO a+              -- ^ Computation to run when an error occurs+              -> (WebSocket JSString -> CIO a)+              -- ^ Computation using the WebSocket+              -> CIO a+withWebSocket = withWS++-- | Run a computation with a WebSocket. The computation will not be executed+--   until a connection to the server has been established.+--   The WebSocket will not be closed after the computation finishes.+withBinaryWebSocket :: URL+                    -- ^ URL to bind the WebSocket to+                    -> (WebSocket Blob -> Blob -> CIO ())+                    -- ^ Computation to run when new data arrives+                    -> CIO a+                    -- ^ Computation to run when an error occurs+                    -> (WebSocket Blob -> CIO a)+                    -- ^ Computation using the WebSocket+                    -> CIO a+withBinaryWebSocket = withWS++-- | Worker for legacy API.+withWS :: WebSocketData t+       => URL+       -> (WebSocket t -> t -> CIO ())+       -> CIO a+       -> (WebSocket t -> CIO a)+       -> CIO a+withWS url cb err f = do+  mws <- wsOpen (noHandlers {wsOpenURL = url, wsOnMessage = cb})+  case mws of+    Just ws -> f ws+    _       -> err++-- | Send a Blob over a WebSocket.+wsSendBlob :: WebSocket Blob -> Blob -> CIO Bool+wsSendBlob = wsSend++++-- * Hairy internals++-- | Open a new WebSocket in text mode.+new :: URL+    -> (WebSocket JSString -> JSString -> IO ())+    -> (WebSocket JSString -> IO ())+    -> (WebSocketCloseEvent -> IO ())+    -> IO ()+    -> IO ()+new = ffi "(function(url, cb, f, close, err) {\+             \var ws = new WebSocket(url);\+             \ws.onmessage = function(e) {cb(ws,e.data);};\+             \ws.onopen = function(e) {f(ws);};\+             \ws.onclose = function(e) {close(e.data);};\+             \ws.error = function(e) {err();};\+             \return ws;\+           \})" ++-- | Open a new WebSocket in binary mode.+newBin :: URL+       -> (WebSocket Blob -> Blob -> IO ())+       -> (WebSocket Blob -> IO ())+       -> (WebSocketCloseEvent -> IO ())+       -> IO ()+       -> IO ()+newBin = ffi "(function(url, cb, f, close, err) {\+                \var ws = new WebSocket(url);\+                \ws.binaryType = 'blob';\+                \ws.onmessage = function(e) {cb(ws,e.data);};\+                \ws.onopen = function(e) {f(ws);};\+                \ws.onclose = function(e) {close(e.data);};\+                \ws.onerror = function(e) {err();};\+                \return ws;\+              \})" ++-- | Send text over a WebSocket.+sendS :: WebSocket JSString -> JSString -> IO Bool+sendS = ffi "(function(s, msg) {if(s.readyState != 1) {return false;} else {s.send(msg); return true;}})"++-- | Send a blob over a WebSocket.+sendB :: WebSocket Blob -> Blob -> IO Bool+sendB = ffi "(function(s, msg) {if(s.readyState != 1) {return false;} else {s.send(msg); return true;}})"++-- | Close a WebSocket.+close :: WebSocket a -> IO ()+close = ffi "(function(ws){ws.onclose = ws.onerror = function(){}; ws.close();})"